Рабочая программа, готовая процедура, а сложить не удается.

[Macintoshka]

Имеется готовая программа, условие которой звучит следующим образом:

Вводится матрица МАТР(n,n) с цифровой информацией. Составить программу подсчета сумм элементов, составляющих "черные", и, отдельно, "белые" поля предполагаемой шахматной доски, наложенной на матрицу. Исходную матрицу и подсчитанные суммы вывести на экран дисплея.

Program lab;
Uses crt;
Var a:array[1..10,1..10] of integer;
    x,y:array[1..10] of integer;
    i,j,n,m,s,s1:integer;
    error:integer;
    label l1,l2;
begin
clrscr;
textcolor(cyan);
gotoxy(19,3);  writeln('Вашему вниманию представляется:');
textcolor(yellow);
gotoxy(15,5);  writeln('программа, которая считает сумму элементов,');
gotoxy(15,6);  writeln('составляющих "черные" и "белые" поля предполагаемой');
gotoxy(15,7);  writeln('шахматной доски, наложенной на матрицу.');
textcolor(red);
gotoxy(35,9);  writeln('Внимание!');
textcolor(cyan);
gotoxy(17,10); writeln('Размер матрицы должен быть не более 10*10.');
gotoxy(19,11); writeln('Элементами матрицы должны являться');
gotoxy(18,12); writeln('целые числа из интервала (-100..100)');
gotoxy(44,15); writeln('Программу выполнил');
gotoxy(44,16); writeln('студент группы X');
textcolor(red);
gotoxy(44,17); writeln('ФИО');
textcolor(cyan);
gotoxy(44,18); writeln('г. Москва, 23.03.09');
gotoxy(18,24); write('Нажмите любую клавишу для продолжения...');
readkey;
l1:
clrscr;
repeat
  write('Введите количество строк: ');
  {$i-}
  readln(n);
  error:=ioresult;
  {$i+}
  if (n>10) or (n<2) or (error<>0) then writeln('Неверно задано количество строк. Повторите ввод:');
until (n<=10) and (n>=2) and (error=0);

repeat
  write('Введите количество столбцов: ');
  {$i-}
  readln(m);
  error:=ioresult;
  {$i+}
  if (m>10) or (m<2) or (error<>0) then writeln('Неверно задано количество строк. Повторите ввод:');
until (m<=10) and (m>=2) and (error=0);
for i:=1 to n do
   for j:=1 to m do
     repeat
     write('Введите A[',i,',',j,']: ');
     {$i-}
     readln(a[i,j]);
     error:=ioresult;
     {$i+}
     if (a[i,j]>=100) or (a[i,j]<=-100) or (error<>0) then writeln('Неверно задан элемент. Повторите ввод:');
     until (a[i,j]>-100) and (a[i,j]<100) and (error=0);
clrscr;
textcolor(yellow);
gotoxy(15,1);    writeln('Результаты работы программы:');
textcolor(cyan); writeln('');
textcolor(red);  writeln('Введенная матрица:');
textcolor(cyan); writeln('');
for i:=1 to n do begin
for j:=1 to m do
write ('   ',a[i,j]);
writeln;
end;
s:=0; s1:=0;
for i:=1 to n do
begin
for j:=1 to m do
  if (i+j) mod 2=0 then s1:=s1+a[i,j]
  else s:=s+a[i,j]
end;
		 writeln('');
		 writeln('');
textcolor(red);  writeln('Сумма "черных" элементов:');
		 writeln('');
textcolor(cyan); writeln(s);
		 writeln('');
		 writeln('');
textcolor(red);  writeln('Сумма "белых" элементов:');
		 writeln('');
textcolor(cyan); writeln(s1);

gotoxy(15,25); write('Хотите ли вы ввести новую матрицу? (Y-Да, N-Нет)');

l2:
case readkey of
  #89: goto l1;
  #121: goto l1;
  #78: exit;
  #110: exit;
end;
  goto l2;
end.

Так вот, в эту программу необходимо ввести следующие параметры:

Вводится матрица МАТР(n,n) с цифровой информацией. Составить программу подсчета сумм элементов, составляющих "черные", и, отдельно, "белые" поля предполагаемой шахматной доски, наложенной на матрицу.

1. Размерность, имя. Необходимо два новых варианта, помимо существующего.
а) B (5;5)
б) C (3;3)

2. Действие над элементами. Подобно первому:
а) сумма элементов(уже существующий вариант)
б) произведение элементов.

3. Тип элементов. Точно также:
а) четные и нечетные
б) положительные и отрицательные
в)ну и, соответственно, уже существующий вариант: "черные" и "белые".



Я приставал к вам с этой проблемой ранее, где, сопсно, Sazary мне отчасти и помог, написав одну из необходимых процедур, но разобраться в ней, а потому и вставить в программу, мне не удалось; поскольку тему закрыли(по моей же глупости) и часом позже интернет упал вплоть до вчерашнего дня. Ну впрочем это не важно, работа горит, много времени утерял, надеюсь на вашу помощь.

[Macintoshka]

Вот процедура, написанная Sazary:

procedure rez(m,n : integer; sp : byte; tip : byte; var S1,S2 : longint);
 var S : longint;
 i,j : integer;
 begin
 
 case sp of
  1 : begin  
      S1 := 0;
      S2 := 0;
      for i:=1 to m do
       for j:=1 to n do
        begin
        case tip of
         1 : if a[i,j] mod 2 = 0 then inc(S1,a[i,j])
             else inc(S2,a[i,j]);
         2 : if a[i,j]>0 then inc(S1,a[i,j])
             else if a[i,j]<0 then inc(S2,a[i,j]);
         3 : if (i+j) mod 2 = 0 then inc(S1,a[i,j])
             else inc(S2,a[i,j]);
        end;
        end;
      end;
  2 : begin  
      S1 := 1;
      S2 := 1;
      for i:=1 to m do
       for j:=1 to n do
        begin
        case tip of
         1 : if a[i,j] mod 2 = 0 then S1 := S1 * a[i,j]
             else S2 := S2 * a[i,j];
         2 : if a[i,j]>0 then S1 := S1 * a[i,j]
             else if a[i,j]<0 then S2 := S2 * a[i,j];
         3 : if (i+j) mod 2 = 0 then S1 := S1 * a[i,j]
             else S2 := S2 * a[i,j];
        end;
        end;
      end;
 end;
 end;

тип операции (1-сложить, 2 - умножить) ©

[Sazary]

Ну здравствуйте снова..
Поясняю:

procedure rez(m,n : integer; sp : byte; tip : byte; var S1,S2 : longint);

Здесь:
m,n - размерность матрицы. (имя матрицы - a)
sp - Действие над элементами. 1- сложение, 2 - умножение
tip - Тип элементов.
1 - четные и нечетные
2 - положительные и отрицательные
3 - "черные" и "белые".

S1,S2 - переменные, в которые запишется результат.
Пример вызова:

rez(3,3,1,1,R1,R2);

Здесь, для матрицы 3x3, в R1 запишем сумму четных элементов, а в R2 - сумму нечетных.

---------------------
Также, повторюсь: советую переписать программу через процедуры и избавиться от операторов goto.

[Macintoshka]

Драсти.. и снова спасибо.

Вопрос, при вызове процедуры в программе не нужно ли указывать тип элементов?

Вставлять процедуру в программу можно в любою ее часть? к примеру перед началом основного тела программы?
И где именно будет наиболее правильным использование приведенного выше вызова?

Мне стыдно. Но в моей ситуации иных вариантов нет, тянуть дальше некуда, да и интернет ненадежный =/

Кстати откуда взялись переменные R1 и R2?
Ранее они вроде бы не упоминались..?
По части оператора goto: я понимаю что это не самый лучший вариант, но я как минимум к нему привык, и в альтернативной замене пока не силен, да и времени на то нет. Но в ближайшем будущем обязательно займусь, спасибо.

[Sazary]

Вопрос, при вызове процедуры в программе не нужно ли указывать тип элементов?

нет

Вставлять процедуру в программу можно в любою ее часть? к примеру перед началом основного тела программы?

Вставьте ее перед телом.

Вот, написал кое-что. Практически готовая программа. Остается только добавить некоторые проверки (если вам это нужно). И при выводе S1 и S2 еще можно (скажем так, желательно) указывать, что это такое (сумма или произведение). Но это несложно.

Program lab;
Uses crt;
type matrix = array[1..100,1..100] of integer;
var
m,n : integer;
c : char;
deistv,tip : byte;
S1,S2 : longint;
a : matrix;


procedure rez(a : matrix; m,n : integer; sp : byte; tip : byte; var S1,S2 : longint);
var i,j : integer;
begin

case sp of
 1 : begin
     S1 := 0;
     S2 := 0;
     for i:=1 to m do
      for j:=1 to n do
       begin
       case tip of
        1 : if a[i,j] mod 2 = 0 then inc(S1,a[i,j])
            else inc(S2,a[i,j]);
        2 : if a[i,j]>0 then inc(S1,a[i,j])
            else if a[i,j]<0 then inc(S2,a[i,j]);
        3 : if (i+j) mod 2 = 0 then inc(S1,a[i,j])
            else inc(S2,a[i,j]);
       end;
       end;
     end;
 2 : begin
     S1 := 1;
     S2 := 1;
     for i:=1 to m do
      for j:=1 to n do
       begin
       case tip of
        1 : if a[i,j] mod 2 = 0 then S1 := S1 * a[i,j]
            else S2 := S2 * a[i,j];
        2 : if a[i,j]>0 then S1 := S1 * a[i,j]
            else if a[i,j]<0 then S2 := S2 * a[i,j];
        3 : if (i+j) mod 2 = 0 then S1 := S1 * a[i,j]
            else S2 := S2 * a[i,j];
       end;
       end;
     end;
end;
end;
{----------------}
procedure vvod(m,n : integer; var a : matrix);
 var i,j : integer;
 begin
 for i:= 1 to m do
  for j:=1 to n do
   begin
   write('Vvedite A[',i,',',j,']: ');
   readln(a[i,j]);
   end;
 writeln('-----------');
 writeln;
 end;
{-------}

begin
clrscr;

repeat
clrscr;
write('Vvedite kolichestvo strok: ');
readln(m);

write('Vvedite kolichestvo stolbcov: ');
readln(n);

vvod(m,n,a);

writeln('Vyberite deistvie (1 - summa, 2 - proizvedenie):');
 repeat
 c := readkey;
 until (c='1') or (c='2');
 if c='1' then deistv:=1
 else deistv := 2;

 writeln('Vyberite tip elementov:');
 writeln('1 - chetnye/nechetnye');
 writeln('2 - polozhitelnye/otricatelnye');
 writeln('3 - "chernye"/"belye"');
 repeat
 c := readkey;
 until (c='1') or (c='2') or (c='3');
 case c of
 '1' : tip := 1;
 '2' : tip := 2;
 '3' : tip := 3;
 end;

 rez(a,m,n,deistv,tip,S1,S2);
 writeln('Rezultat: S1 = ',S1);
 writeln('S2= ',S2);

 writeln('Hotite vvesti eshe matricu? (y/n)');
 repeat
 c := readkey;
 until (c='y') or (c='n');
until c='n';

end.

Вроде, все понятно. Процедуру rez почти не трогал.

[Stilet]

Новички, имейте совесть - оформляйте код спецтегом по кнопке #

[Macintoshka]

Спасибо, Sazary.
Только вот все равно не хочет она работать. Вылетает ошибка о переполненом стеке.(Error 202. Stack owerflow error.
Скорее всего я начудил, но вроде бы делал все как Вы написали.

[Sazary]

Вылетает ошибка о переполненом стеке

Так а где ошибка-то?

Скорее всего я начудил, но вроде бы делал все как Вы написали.

А что вы сделали? Скопировали код? У меня работает.
Жду указания места с ошибкой.

[Macintoshka]

Program lab;
Uses crt;
type matrix = array[1..100,1..100] of integer;
var
m,n,i,j : integer;
c : char;
deistv,tip : byte;
S1,S2 : longint;
a : matrix;
error : integer;
label l1,l2;
procedure rez(a : matrix; m,n : integer; sp : byte; tip : byte; var S1,S2 : longint);
var i,j : integer;

begin {Error 202: Stack owerflow error}
case sp of
 1 : begin
     S1 := 0;
     S2 := 0;
     for i:=1 to m do
      for j:=1 to n do
       begin
       case tip of
        1 : if a[i,j] mod 2 = 0 then inc(S1,a[i,j])
            else inc(S2,a[i,j]);
        2 : if a[i,j]>0 then inc(S1,a[i,j])
            else if a[i,j]<0 then inc(S2,a[i,j]);
        3 : if (i+j) mod 2 = 0 then inc(S1,a[i,j])
	    else inc(S2,a[i,j]);
       end;
       end;
     end;
 2 : begin
     S1 := 1;
     S2 := 1;
     for i:=1 to m do
      for j:=1 to n do
       begin
       case tip of
        1 : if a[i,j] mod 2 = 0 then S1 := S1 * a[i,j]
            else S2 := S2 * a[i,j];
        2 : if a[i,j]>0 then S1 := S1 * a[i,j]
            else if a[i,j]<0 then S2 := S2 * a[i,j];
        3 : if (i+j) mod 2 = 0 then S1 := S1 * a[i,j]
            else S2 := S2 * a[i,j];
       end;
       end;
     end;
end;
end;

procedure vvod(m,n : integer; var a : matrix);
 var i,j : integer;
 begin
 for i:= 1 to m do
  for j:=1 to n do
   begin
   write('Введите A[',i,',',j,']: ');
   readln(a[i,j]);
   end;
 writeln('12345');
 writeln;
 end;


begin
clrscr;
textcolor(cyan);
gotoxy(19,3);  writeln('Вашему вниманию представляется:');
textcolor(yellow);
gotoxy(15,5);  writeln('программа, которая считает сумму/произведение элементов,');
gotoxy(15,6);  writeln('составляющих честные и нечетные, положительные и');
gotoxy(15,7);  writeln('отрицательные, а также "черные" и "белые" поля предполагаемой');
gotoxy(15,8);  writeln('шахматной доски, наложенной на матрицу.');
textcolor(red);
gotoxy(35,9);  writeln('Внимание!');
textcolor(cyan);
gotoxy(17,10); writeln('Размер матрицы должен быть не более 10*10.');
gotoxy(19,11); writeln('Элементами матрицы должны являться');
gotoxy(18,12); writeln('целые числа из интервала (-100..100)');
gotoxy(44,15); writeln('Программу выполнил');
gotoxy(44,16); writeln('студент группы ЭИЭ ***');
textcolor(red);
gotoxy(44,17); writeln('ФИО');
textcolor(cyan);
gotoxy(44,18); writeln('г. Москва, 29.11.2008');
gotoxy(18,24); write('Нажмите любую клавишу для продолжения...');
readkey;


begin
clrscr;

repeat
clrscr;
repeat
  write('Введите количество строк: ');
  {$i-}
  readln(n);
  error:=ioresult;
  {$i+}
  if (n>10) or (n<2) or (error<>0) then writeln('Неверно задано количество строк. Повторите ввод:');
until (n<=10) and (n>=2) and (error=0);

repeat
  write('Введите количество столбцов: ');
  {$i-}
  readln(m);
  error:=ioresult;
  {$i+}
  if (m>10) or (m<2) or (error<>0) then writeln('Неверно задано количество строк. Повторите ввод:');
until (m<=10) and (m>=2) and (error=0);

vvod(m,n,a);

writeln('Выберите действие (1 - сумма, 2 - произведение):');
 repeat
 c := readkey;
 until (c='1') or (c='2');
 if c='1' then deistv:=1
 else deistv := 2;

 writeln('Выберите тип элементов:');
 writeln('1 - четные/нечетные');
 writeln('2 - положительные/отрицательные');
 writeln('3 - "черные"/"белые"');
 repeat
 c := readkey;
 until (c='1') or (c='2') or (c='3');
 case c of
 '1' : tip := 1;
 '2' : tip := 2;
 '3' : tip := 3;
 end;

 rez(a,m,n,deistv,tip,S1,S2);
 writeln('Rezultat: S1 = ',S1);
 writeln('S2= ',S2);

gotoxy(15,25); write('Хотите ли вы ввести новую матрицу? (Y-Да, N-Нет)');
repeat
c := readkey;
 until (c='y') or (c='n');
until c = 'n';

end;
end.

Ошибка приходится как раз на процедуру.

[Sazary]

Macintoshka
Да, действительно, в TP дает ошибку.. Просто я писал на Free pascal.

Тогда измените объявление процедуры на:

procedure rez(m,n : integer; sp : byte; tip : byte; var S1,S2 : longint);

и вызов на:

 rez(m,n,deistv,tip,S1,S2);

Таким образом, процедура будет работать с глобальным массивом.