Арифметическая прогрессия

[Idealist 2012]

Вычислить количество арифметических прогрессий с заданным приращением М, состоящих не менее чем из трех подряд расположенных элементов. Порядок расположения элементов в массиве менять нельзя. Для каждой обнаруженной прогрессии напечатать номера входящих в нее элементов. Использование дополнительных массивов запрещено. В программе обязательно применение процедур и/или функций с передаваемыми параметрами.

Есть вариант программы, но он без функций\процедур и номера элементов входящих в арифм. прогрес. он не показывает:

program lab4;

var n,nc,m,k,i,j:integer;
A:array[1..30] of integer;

begin
  n:=0;
     repeat
       inc(n);
       readln(a[n]);
     until a[n]=0;
  dec(n);
  Writeln('Array');

   for i:=1 to n do write(a[i],'  ');
    writeln;
    write('M=');
    readln(m);
    k:=0;
    i:=1;
      while i<=n do
       begin
          if a[i+1]-a[i]=m then
            begin
             inc(k);
             inc(i);
            end
          else
            begin
             if k>=3 then
               begin
                if k=i-1 then nc:=1
                else nc:=i-k+1;
                for  j:=nc to i do
                write(j,' ');
                writeln;k:=0;
                Dec(i);
               end
             else inc(i);
            end;
       end;
    
   if k=i-1 then nc:=1
    else nc:=i-k+1;
    
   if k>=3 then
     for  j:=nc to i do
      write(j,' ');
      readln;
end.

Пишите свои мысли...Буду признателен...

[whatever]

Напиши пример того, что в программу вводить надо, любой удобный вариант. И какой при этом будет (должен быть) результат.

[whatever]

type
  mass=array[1..30] of integer;                     //объявлять массивы в var'е - "плохой стиль програмирования" (с)

procedure CreateMass(Var A:mass; var M,N:integer);
var
  i:integer;
begin
    n:=0;
     repeat
       inc(n);
       readln(a[n]);
     until a[n]=0;
  dec(n);
  for i:=1 to n do write(a[i],'  ');
    writeln;
    write('M=');
    readln(m);
end;

procedure FindProgressions(A:mass; M,N:integer; var Count:integer);
var
  i,k,nc,j:integer;
begin
count:=0;
    k:=0;
    i:=1;
      while i<n do        //если "<=", то выходит за границы
       begin
          if a[i+1]-a[i]=m then
            begin
             inc(k);
             inc(i);
            end
          else
            begin
             if k>=3 then
               begin
                if k=i-1 then nc:=1
                else nc:=i-k+1;

                inc(count);

                for  j:=nc to i do
                write(j,' ');
                writeln;k:=0;
                Dec(i);
               end
             else inc(i);
            end;
       end;
   if k=i-1 then nc:=1
    else nc:=i-k+1;
   if k>=3 then
   begin
     inc(count);
     for  j:=nc to i do
       write(j,' ');
   end;
   writeln;
end;


VAR
  n,m,count:integer;
  a:mass;
BEGIN
  CreateMass(A,m,n);
  Writeln('Array');
  FindProgressions(A,m,N,count);
  writeln('count= ',count);   //количество прогрессий
  readln;
end.

Вроде бы все считает

...и номера элементов входящих в арифм. прогрес. он не показывает

Не показывает количество прогрессий, ты имел ввиду? Номера элементов то как раз выводятся, количества небыло.

[Idealist 2012]

Номера эл. прогрессий программа выводила, причём построчно для каждой прогрессии, но отдельно количество прогрессий не писала.

Нужно что бы было так:
____
Введите числовую последовательность:
1 3 5 10 15 20 25 4 3 6 40 45 50 55 (0-окончание ввода)
Введите приращение:5

(Итог: )
Количество прогрессий:2
Номера эл. 1 прогрессии:4 5 6 7
Номера эл. 2 прогрессии и т.д. 11 12 13 14

[Idealist 2012]

Спасиба whatever

[Idealist 2012]

Хотя программа работает не правильно. Не всегда определяет одну из последовательностей и пишет неверный номер элемента не входящего в прогрессию:

2 3 8 10 12 6 7 20 22 24
M=2
Array
7 8 9 10
count= 1

Тут видно, что последовательности 2, и элемент 7 не верный.

[whatever]

procedure FindProgressions(A:mass; M,N:integer; var Count:integer);
var
  i,k,nc,j:integer;
begin
count:=0;
    k:=1;                   //если имеем a[i+1]-a[i]=m, то элемента уже два, а не один.
    i:=1;
      while i<n do        //если "<=", то выходит за границы
       begin
          if a[i+1]-a[i]=m then
            begin
             inc(k);
             inc(i);
            end
          else
            begin
             if k>=3 then
               begin
                if k=i-1 then nc:=1
                else nc:=i-k+1;

                inc(count);

                for  j:=nc to i do
                write(j,' ');
                writeln;
                k:=1;
                Dec(i);
               end
             else
               begin
                inc(i);
                if i<>n-1 then k:=1; //чтобы не получить лишний элемент, как у тебя в примере 7
               end;
            end;
       end;
   if (k=2) and (a[i]-a[i-1]=m) then inc(k); //проверка последнего элемента

   if k=i-1 then nc:=1
    else nc:=i-k+1;
   if k>=3 then
   begin
     inc(count);
     for  j:=nc to i do
       write(j,' ');
   end;
   writeln;
end;

Работает для

2 3 8 10 12 6 7 20 22 24
M=2

Тестируй, вроде все предусмотрел.

Сам тестировал на

  a[1]:=2;
  a[2]:=4;
  a[3]:=6;
  a[4]:=8;
  a[5]:=1;
  a[6]:=351;
  a[7]:=15;
  a[8]:=17;
  a[9]:=19;
  a[10]:=165;
  a[11]:=651;
  a[12]:=666;
  a[13]:=668;
  a[14]:=670;

  m:=2;
  n:=14;

[Idealist 2012]

Вроде работает...)) Спасибо.