Создание меню в Паскале ABC

[SunHab]

Создание меню в Паскале ABC

Добрый день! Помогите отредактировать программу, так что бы было меню.
каждый пункт меню - вызов одной из задачи программы. После работы очередной задачи должен быть возврат в меню. Буду очень благодарна за помощь!
Вот сама программа:

program matritsa; 
const 
 n=8; 
type  
 matr= array[1..n,1..n] of integer;  
var 
 a: matr; 
 i, j, k,l,ko,sm : integer;  

Procedure findk (a:matr; var k:integer ); 
var i, j: integer; 
 begin 
  for i:=1 to n do 
   begin 
    k:=i; 
    for j:=1 to n do 
     if A[i,j] <> A [j,i] then 
      begin 
        k:=0; 
        break; 
      end; 
    if k>0 then break; 
   end; 
 end;  

begin 
 for i:=1 to n do 
  for j:=1 to n do 
   begin 
    write('a[',i,',',j,']='); 
    read(a[i,j]) 
   end; 
 findk(a, k); 
 writeln(k); 
 writeln; 
 for i:=1 to n do 
  begin 
   for j:=1 to n do write(a[i,j]:3); 
   writeln; 
  end; 
 writeln('Совпадающие строки и столбцы;'); 
 l:=0;{считаем что совпадающих строк и столбцов нет} 
 for k:=1 to n do 
  begin 
   i:=0;{считаем что в данных строке и столбце совпадений нет }  
   for j:=1 to n do 
    if a[k,j]=a[j,k] then i:=i+1;{если есть, считаем} 
   if i=n then{если все совпали} 
    begin 
     writeln('Строка и столбец № ',k);{выводим на экран}   
     l:=1;{фиксируем что есть такие} 
    end; 
  end; 
 if l=0 then writeln('Таких строк и столбцов нет!'); 
 writeln; 
 for i:=1 to n do 
  begin 
   ko:=0;{считаем что отрицательных в строке нет} 
   for j:=1 to n do 
    if a[i,j]<0 then {если нашли} 
     begin 
      ko:=1;{фиксируем} 
      break;{больше не ищем} 
     end; 
   if ko=1 then{если есть отрицательные} 
    begin 
     sm:=0;{сумма=0} 
     for k:=1 to n do sm:=sm+a[i,k];{считаем сумму в строке}    
     writeln('Сумма в строке ',i,'=',sm); 
    end; 
  end; 
 readln 
end.

 

[Vladimir_S]

Поправил листинг. Для читабельности.

Буду очень благодарна за помощь!

А помощь воспоследует не прежде, чем будет выложена полная формулировка задачи. А то, знаете ли, восстанавливать задание по чужой программе - нет уж, увольте!

 

[SunHab]

Поправил листинг. Для читабельности.А помощь воспоследует не прежде, чем будет выложена полная формулировка задачи. А то, знаете ли, восстанавливать задание по чужой программе - нет уж, увольте!

Прошу прощения! Вот формулировка задачи:

Для заданной матрицы размером 8x8 найти такие k, что k-я строка матрицы совпадает с k-м столбцом (оформить в виде процедуры).
Найти сумму элементов в тех строках, которые содержат хотя бы один отрицательный элемент (оформить в виде функции).

 

[Vladimir_S]

Для заданной матрицы размером 8x8 найти такие k, что k-я строка матрицы совпадает с k-м столбцом (оформить в виде процедуры). Найти сумму элементов в тех строках, которые содержат хотя бы один отрицательный элемент (оформить в виде функции).

Легко. Если, конечно, не считать традиционно-тупых преподских указулек. Вот как раз вторую задачу было бы удобно решать через процедуру с ДВУМЯ выходными параметрами: булевским (содержит/не содержит) и собственно самой суммой. Но нет - подай им, вишь, функцию. Ладно, вывернемся.

const
 n=8;
type
 matr= array[1..n,1..n] of integer;
 vect= array[1..n] of integer;
var
 a,b: matr;
 i,j,l,sum : integer;

Procedure findk(q1,q2:vect; k:integer);
var
 p:integer;
 bu:boolean;
begin
 bu:=true;
 for p:=1 to n do
  if q1[p]<>q2[p] then bu:=false;
 if bu then write(k:3);
end;

Function FindSum(q:vect):Integer;
var
 p,S:integer;
 bu:boolean;
begin
 bu:=true;
 S:=0;
 for p:=1 to n do
  begin
   Inc(S,q[p]);
   if q[p]<0 then bu:=false;
  end;
 if bu then S:=-32000;
 FindSum:=S;
end;

Begin
 for i:=1 to n do
  for j:=1 to n do
   begin
    write('a[',i,',',j,']= ');
    readln(a[i,j]);
    b[j,i]:=a[i,j];
   end;
 writeln;
 for i:=1 to n do
  begin
   for j:=1 to n do write(a[i,j]:4);
   writeln;
  end;
 writeln;
 Repeat
  Writeln('Enter the action number:');
  Writeln('                       1 - FindK');
  Writeln('                       2 - FindSums');
  Writeln('                       3 - Exit');
  Readln(l);
  Case l of
   1: begin
       write('K: ');
       for i:=1 to n do FindK(a[i],b[i],i);
       writeln;
      end;
   2: begin
       for i:=1 to n do
        begin
         sum:=FindSum(a[i]);
         if sum<>-32000 then writeln('i= ',i,'   Sum= ',Sum);
        end;
      end;
   else l:=3;
  end; {Case}
 Until l=3;
End.

 

[SunHab]

Легко. Если, конечно, не считать традиционно-тупых преподских указулек. Вот как раз вторую задачу было бы удобно решать через процедуру с ДВУМЯ выходными параметрами: булевским (содержит/не содержит) и собственно самой суммой. Но нет - подай им, вишь, функцию. Ладно, вывернемся.

const
 n=8;
type
 matr= array[1..n,1..n] of integer;
 vect= array[1..n] of integer;
var
 a,b: matr;
 i,j,l,sum : integer;

Procedure findk(q1,q2:vect; k:integer);
var
 p:integer;
 bu:boolean;
begin
 bu:=true;
 for p:=1 to n do
  if q1[p]<>q2[p] then bu:=false;
 if bu then write(k:3);
end;

Function FindSum(q:vect):Integer;
var
 p,S:integer;
 bu:boolean;
begin
 bu:=true;
 S:=0;
 for p:=1 to n do
  begin
   Inc(S,q[p]);
   if q[p]<0 then bu:=false;
  end;
 if bu then S:=-32000;
 FindSum:=S;
end;

Begin
 for i:=1 to n do
  for j:=1 to n do
   begin
    write('a[',i,',',j,']= ');
    readln(a[i,j]);
    b[j,i]:=a[i,j];
   end;
 writeln;
 for i:=1 to n do
  begin
   for j:=1 to n do write(a[i,j]:4);
   writeln;
  end;
 writeln;
 Repeat
  Writeln('Enter the action number:');
  Writeln('                       1 - FindK');
  Writeln('                       2 - FindSums');
  Writeln('                       3 - Exit');
  Readln(l);
  Case l of
   1: begin
       write('K: ');
       for i:=1 to n do FindK(a[i],b[i],i);
       writeln;
      end;
   2: begin
       for i:=1 to n do
        begin
         sum:=FindSum(a[i]);
         if sum<>-32000 then writeln('i= ',i,'   Sum= ',Sum);
        end;
      end;
   else l:=3;
  end; {Case}
 Until l=3;
End.

Большое спасибо за помощь!

 

[Vladimir_S]

Большое спасибо за помощь!

Да не за что. Если что-то непонятно - спрашивайте, разберемся.

 

[poiu]

а у меня при фразе "создать меню" почему то сразу была единственная мысль- графическое меню.

 

[Vladimir_S]

а у меня при фразе "создать меню" почему то сразу была единственная мысль- графическое меню.

Да можно было бы и графическое, или, на худой конец, разукрасить текстовое всякими там CRT-шными рюшечками (фон, цвет, размер окошка и т.п.), но вот беда - у заказчицы не нормальный Паскаль, а этот... это... эта... как бы по-приличнее выразиться... ну, в общем, АВС. А в нём всё с ног на голову поставлено, да так и оставлено.

 

[SunHab]

Легко. Если, конечно, не считать традиционно-тупых преподских указулек. Вот как раз вторую задачу было бы удобно решать через процедуру с ДВУМЯ выходными параметрами: булевским (содержит/не содержит) и собственно самой суммой. Но нет - подай им, вишь, функцию. Ладно, вывернемся.

const
 n=8;
type
 matr= array[1..n,1..n] of integer;
 vect= array[1..n] of integer;
var
 a,b: matr;
 i,j,l,sum : integer;

Procedure findk(q1,q2:vect; k:integer);
var
 p:integer;
 bu:boolean;
begin
 bu:=true;
 for p:=1 to n do
  if q1[p]<>q2[p] then bu:=false;
 if bu then write(k:3);
end;

Function FindSum(q:vect):Integer;
var
 p,S:integer;
 bu:boolean;
begin
 bu:=true;
 S:=0;
 for p:=1 to n do
  begin
   Inc(S,q[p]);
   if q[p]<0 then bu:=false;
  end;
 if bu then S:=-32000;
 FindSum:=S;
end;

Begin
 for i:=1 to n do
  for j:=1 to n do
   begin
    write('a[',i,',',j,']= ');
    readln(a[i,j]);
    b[j,i]:=a[i,j];
   end;
 writeln;
 for i:=1 to n do
  begin
   for j:=1 to n do write(a[i,j]:4);
   writeln;
  end;
 writeln;
 Repeat
  Writeln('Enter the action number:');
  Writeln('                       1 - FindK');
  Writeln('                       2 - FindSums');
  Writeln('                       3 - Exit');
  Readln(l);
  Case l of
   1: begin
       write('K: ');
       for i:=1 to n do FindK(a[i],b[i],i);
       writeln;
      end;
   2: begin
       for i:=1 to n do
        begin
         sum:=FindSum(a[i]);
         if sum<>-32000 then writeln('i= ',i,'   Sum= ',Sum);
        end;
      end;
   else l:=3;
  end; {Case}
 Until l=3;
End.

Сегодня попыталась запустить в программе выдал ошибку:"Нельзя преобразовать тип array [1..8] of integer к array [1..8] of integer" tehno015

 

[Vladimir_S]

Сегодня попыталась запустить в программе выдал ошибку:"Нельзя преобразовать тип array [1..8] of integer к array [1..8] of integer" tehno015

М-да... Паскаль АВС во всей красе! Даже не знаю, чем бы я мог в такой ситуации помочь... Согласитесь - сообщение об ошибке запредельно абсурдное.
Но вообще-то... А Вы точно сообщение процитировали? Может быть, там говорится "Нельзя преобразовать тип array [1..8] of integer к array [1..8, 1..8] of integer" или наоборот?
Попробуйте так:
Вместо

type
  matr= array[1..n,1..n] of integer;  
  vect= array[1..n] of integer;

запишите

type
  vect= array[1..n] of integer;
  matr= array[1..n] of vect;

И дальше
вместо

    readln(a[i,j]);
    b[j,i]:=a[i,j];

поставьте

    readln(a[i][j]);
    b[j][i]:=a[i][j];

Может быть, хоть так проскочит.