Функция в Paskal

[Fromki]

Всем привет! Нужно написать программу на Паскале с использование функции... без разницы в какой части программы она будет, по возможности использовать функцию с параметром.

Вводится матрица MT (n,m) с цифровой информацией. Составить программу нахождения в столбцах матрицы положительных (>0) элементов, подсчета их количества и сумм. Получить новую матрицу, в которой элементы будут представлены числами, полученными от деления суммы положительных элементов по столбцу на значение конкретного элемента. Исходные, промежуточные и результатные данные вывести на дисплей.

Вот рабочий код с оформлением,но,повторюсь, нужно через функцию, и желательно с параметром.....

program lab4;
uses  crt;
Label
   L1,L2;
var
A : array [1..10,1..10] of integer;
j : array [1..10,1..10] of integer;
B:array [1..10,1..10] of  real;
ch:char;
x, y, q, error:integer;
begin
clrscr;
   window(3,4,70,14);
    writeln ('Вашему вниманию представляется программа');
    writeln ('которая находит в столбцах матрицы положительные >0 элементы,');
    writeln ('подсчета их количества и сумм.);
    writeln ('Затем получает новую матрицу, в которой элементы’);
    writeln ('будут представлены числами, полученные от деления ');
    writeln ('положительных элементов по столбцу на значение конкретного элемента.');
    writeln ('Требования:');
    writeln ('Элементы матрицы должны быть целыми числами!');
    writeln ('Размерность матрицы должна быть не меньше двух,');
    writeln ('но и не более ста элементов');
    window (42,15,75,23);
    writeln (‘Программу составил студент’);
    writeln ('группы ***********');
    window (1,1,75,25);
    gotoxy(20,24);
    writeln ('для продолжении нажмите любую клавишу ');
    Ch:=readkey;
    L1:Clrscr;
repeat
    write('Введите размерность матрицы: ');
    {$I-}
    readln(q);
    error:=IOResult;
    {$I+}
    If(error<>0) or (q>100) or (q<2) then
    writeln('Ошибка ввода размерности’);
    until(error=0) and (q<=100) and (q>=2);
    writeln('Введите матрицу:',q,' столбца(ов) и ',q,' строк(и)');

for y:=1 to q do
begin
for x:=1 to q do
 begin
{$I-}
repeat
 read (A[y,x]);
         error:=ioresult;
         {$I+}
         If ( A[y,x] > 99) or (A[y,x] < -99) or (Error <> 0)  then
          writeln('ошибка ввода элемента матрицы’);
      until ( A[y,x] <=99) and ((A[y,x] >=-99) and (Error = 0));
     Readln;
     end;
     end;
     clrscr;
   writeln(‘Исходная матрица’);
     y:=0;
   while y < q do
    begin
       x:=1;
       j[y+1,1]:=0;
       j[y+1,2]:=0;
      repeat
     if A[y+1,x]>0 then
        begin
     j[y+1,1]:=j[y+1,1]+ A[y+1,x];
     j[Y+1,2]:=  j[Y+1,2]+1;
        end;
      inc(x);
      until x>q;
     y:=y+1;
    end;
    writeln('');
   y:=1;
   repeat
     for x:=1 to q do
       begin
   if  (y=1)  then
        write('_____')
       else
   if  (y>q+1)  then
        write('-----')
         else
        begin
           if A[x,y-1] > -1 then
                write(' ');
        write(A[x,y-1]);
        write(' | ');
         end;
        end;
       writeln;
       inc(y,1);
    until (q+2<y);

    for x:=1 to q do
      begin
      write(' ');
 write(j[x,1]:1:0);
        write(' | ');
      end;
 writeln(' сумма элементов >0');
     for x:=1 to q do
      begin
   write(' ');
 write(j[x,2]:1:0);
        write(' | ');
      end;
 writeln(' количество элементов >0');

for x:=1 to q do
for y:=1 to q do
if A[x,y]<>0 then
B[x,y]:= j[x,1] div A[x,y];
 writeln;

   writeln(‘Полученная матрица’);
   x:=0;
   repeat
     inc(x,1);
     for y:=1 to q do
     begin
       if  (x=1)  then
         write('_____')
         else
   if  (x>q+1)  then
        write('-----')
         else
        begin
     if B[y,x-1] > -1 then
                write(' ');
     write(B[y,x-1]:1:1);
     write(' | ');
        end;
     end;
     writeln;
   until q<(x-1);
begin
  writeln;
  writeln('Хотите повторить? <Y/N)');
       L2:
           Case Readkey of
           #89: Goto L1;
           #121: Goto L1;
           #78: Exit;
           #110: Exit;
       End;
       Goto L2;
readln;
readln;
end;
end.

[Fromki]

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

program lab5;
uses  crt;
Type 
MyArray=array [1..10,1..10] of  real;
var
A,B :MyArray;
j : array [1..10,1..2] of integer;

ch:char;
x, y, q, error:integer;

procedure Intro;
 begin
 clrscr;
  window(3,4,73,14);
    writeln ('‚*襬㠢*Ё¬**Ёо ЇаҐ¤бв*ў«пҐвбп Їа®Ја*¬¬*,');
    writeln ('Є®в®а*п **室Ёв ў бв®«Ўж*е ¬*ваЁжл ®ваЁж*⥫м*лҐ <0 н«Ґ¬Ґ*вл,');
    writeln ('Ї®¤бзҐв* Ёе Є®«ЁзҐбвў* Ё б㬬.');
    writeln ('‡*⥬ Ї®«гз*Ґв *®ўго ¬*ваЁжг, ў Є®в®а®© н«Ґ¬Ґ*вл');
    writeln ('Ўг¤г⠯।бв*ў«Ґ*л зЁб«*¬Ё, Ї®«гзҐ**лҐ ®в г¬*®¦Ґ*Ёпя ');
    writeln ('®ваЁж*⥫м*ле н«Ґ¬Ґ*в®ў Ї® бв®«Ўжг ** §**зҐ*ЁҐ Є®*ЄаҐв*®Ј® н«Ґ¬Ґ*в*.');
    writeln ('’ॡ®ў**Ёпя:');
    writeln ('ќ«Ґ¬Ґ*вл ¬*ваЁжл ¤®«¦*л Ўлвм 楫묨 зЁб«*¬Ё!');
    writeln ('ђ*§¬Ґа*®бвм ¬*ваЁжл ¤®«¦** Ўлвм *Ґ ¬Ґ*миҐ ¤ўге,');
    writeln ('*® Ё *Ґ Ў®«ҐҐ бв* н«Ґ¬Ґ*в®ў.');
    window (42,15,75,23);
    writeln ('Џа®Ја*¬¬г б®бв*ўЁ« бв㤥*в ');
    writeln ('ЈагЇЇл ќ€ќ-112 ѓа®¬ ‘. ‚.');
    window (1,1,75,25);
    gotoxy(20,24);
    writeln ('¤«п Їа®¤®«¦Ґ*Ёп **¦¬ЁвҐ «оЎго Є«*ўЁиг ');
    Ch:=readkey;
     clrscr;
end;

procedure element_A(N:byte);
var
 x,y:byte;  
begin
for y:=1 to N do
begin
 for x:=1 to N do
   begin
    {$I-}
    repeat
      read (A[y,x]);
      error:=ioresult;
     {$I+}
      If ( A[y,x] > 99) or (A[y,x] < -99) or (Error <> 0)  then
	writeln('®иЁЎЄ* ўў®¤* н«Ґ¬Ґ*в* ¬*ваЁжл');
    until ( A[y,x] <=99) and ((A[y,x] >=-99) and (Error = 0));
    Readln;
    end;
  end;
end;

procedure ishod_J(n:byte);
begin
   y:=0;
   while y < n do
    begin
       x:=1;
       j[y+1,1]:=0;
       j[y+1,2]:=0;
      repeat
     if A[y+1,x]<0 then
        begin
     j[y+1,1]:=round (j[y+1,1]+ A[y+1,x]);
     j[Y+1,2]:=  j[Y+1,2]+1;
        end;
      inc(x);
      until x>n;
     y:=y+1;
    end;
end;


procedure poisk(var Arr:MyArray; n:byte; Formatted:boolean);
var x,y:byte;
begin
 writeln('');
  y:=1;
   repeat
     for x:=1 to n do
       begin
   if  (y=1)  then
        write('_____')
       else
   if  (y>n+1)  then
        write('-----')
         else
        begin
           if Arr[x,y-1] > -1 then
                write(' ');
       if formatted then write(Arr[x,y-1]:1:1) else write(Arr[x,y-1]:1:0);
        write(' | ');
         end;
        end;
       writeln;
       inc(y,1);
    until (n+2<y);
end; 

begin
 Intro; 


repeat
write('‚ўҐ¤ЁвҐ а*§¬Ґа*®бвм ¬*ваЁжл: ');
    {$I-}
    readln(q);
    error:=IOResult;
    {$I+}
    If(error<>0) or (q>100) or (q<2) then
    writeln('®иЁЎЄ* ўў®¤* а*§¬Ґа*®бвЁ');
    until(error=0) and (q<=100) and (q>=2);
    writeln('‚ўҐ¤ЁвҐ ¬*ваЁжг:',q,' бв®«Ўж*(®ў) Ё ',q,' бва®Є(Ё)');

element_A(q);

     clrscr;
   writeln('€б室**п ¬*ваЁж*');
  ishod_J(q);
poisk(a,q,false);
 for x:=1 to q do
      begin
      write(' ');
 write(j[x,1]);
        write(' | ');
      end;
writeln(' б㬬* н«Ґ¬Ґ*в®ў <0');
 for x:=1 to q do
      begin
   write(' ');
 write(j[x,2]);
        write(' | ');
      end;
 writeln(' Є®«ЁзҐбвў® н«Ґ¬Ґ*в®ў <0');


for x:=1 to q do
for y:=1 to q do
if A[x,y]<>0 then
B[x,y]:=j[x,1] * A[x,y];
 writeln;

   writeln('Џ®«гзҐ***п ¬*ваЁж*:');
     poisk(b,q,true);


  writeln;
  writeln('•®вЁвҐ Ї®ўв®аЁвм? <Y/N)');

repeat
repeat
ch:=Readkey;
if (ch=#78)  or (ch=#110) then Exit;
until (ch=#89)or(ch=#121);
until false;
end.

[Serge_Bliznykov]

кстати, у Вас в программе есть косячок-с.. мелкий, но неприятный

Вы матрицу описываете как 1..10 - а предлагаете ввести до 100... - введите хотя-бы 20 - попробуйте, как оно будет работать

(исправить надо в описании типа:
Type
MyArray=array [1..100,1..100] of ....)

[Fromki]

спасибо, но я думаю что 10 это будет уже очень много.....к тому же больше 5 я пробовать не буду

[Serge_Bliznykov]

спасибо, но я думаю что 10 это будет уже очень много

Ну тогда измените: 1) текст сообщения пользователю
2) проверку на корректные границы: until(error=0) and (q<=100) and (q>=2);
то, что лично Вы не будете вводить больше 5-ти не означает, что в программе можно делать такие мелкие и нелепые ошибки!

по сути проблемы-то разобрались? Написали функцию?

p.s. перед тем как скопировать (и вставить) текст программы на форум включайте, пожалуйста, русскую раскладку клавиатуры - кракозябры читать непонятно и неприятно...

[Fromki]

да там тоже самое что и в первом посте, я имею ввиду квакозябры, просто переписывать лень.....я сам не спец в программировании, программу с процедурами я писал очень долго, причем мне очень много помогали. Ну я хочу просто чтобы мне помогли написать программу с использованием функций, желательно с параметром. Но если вы хотите чтобы я внес "мелкие поправки", то к завтрашнему вечеру будет готово.

[Serge_Bliznykov]

Но если вы хотите чтобы я внес "мелкие поправки"..

Вы так говорите, как будто это мне нужна эта программа!
Хотите - вносите, хотите - не вносите! Это дело исключительно Ваше!

вот функция подсчёта количества положительных элементов по заданному столбцу:

function CountPozitive(var MM : MyArray; NumColumn, SizeM : integer) : integer;
var Res : integer;
begin
   Res := 0;
   for i:= 1 to SizeM do
     if MM[i,  NumColumn]>0 then
        Res := Res + 1;  {а если написать +MM[i,  NumColumn] - получится сумма положительных)
   CountPozitive := Res; 
end;

сумма положительных находится полностью аналогично! (смотри комментарий в коде)

[Fromki]

эмммм.....а в какую часть программы мне ее вставить вместо процедуры?

[Fromki]

а можно еще по чему нибудь придумать функцию?

[Fromki]

тут же явно еще что-то можно сделать