Помогите с процедурой... Опции

[Mouse]

Упорядочить строки целочисленной прямоугольной матрицы по возрастанию количества одинаковых элементов в каждой строке(в виде процедуры)
найти номер первого из столбцов, не содержащих ни одного отриц элемента(в виде ф-ии)

Помогите доделать прогу...Функция сделана,а вот процедура не получается

program matrica;
uses crt;
const
  max=10;
type
   mas=array[1..max,1..max] of integer;
var
   nmax,mmax:integer;
   m:mas;
   i,j:integer;
   function otr(var m:mas):integer;
   var
    found:boolean;
    d,t:integer;
    nom:integer;
     begin
       d:=0;
       t:=0;
       nom:=0;
       for j:=1 to mmax do
         begin
           d:=d+t;
           found:=false;
           for i:=1 to nmax do
             if m[i,j]<0 then
               begin
                 found:=true;
               end
             else nom:=j;
             if (found=false) and (d=0) then
               begin
                 t:=1;
                 writeln('Номер первого столбца в котором нет отрицателных чисел = ',nom);
               end;
         end;
       if (t=0) then writeln('Во всех столбцах матрицы присутствуют отрицательные числа.');
     end;
begin
  clrscr;
  writeln ('  Упорядочить строки целочисленной прямоугольной матрицы');
  writeln ('по возрастанию количества одинаковых элементов в каждой стоке; ');
  writeln ('найти номер первого из столбцов, не содержащий ни одного   ');
  writeln ('отрицательного элемента. ');
  writeln;
  repeat
    writeln('Введите размер прямоугольной матрицы:');
    write('n=');
    readln(nmax);
    write('m=');
    readln(mmax);
    if (nmax<=0) or (nmax>max) or (mmax<=0) or (mmax>max) then
      writeln('Ошибка! Размер матрицы не должен выходить за рамки 10х10.');
  until (nmax>0) and (nmax<=max) and (mmax>0) and (mmax<=max);
    for i:=1 to nmax do
      for j:=1 to nmax do
        begin
          write ('[',i,';',j,']=');
          readln(m[i,j]);
        end;
  writeln('_________________________________________________________');
  writeln('полученная матрица');
    for i:=1 to nmax do
      begin
        for j:=1 to mmax do
          write (m[i,j],'  ');
        writeln;
      end;
  writeln('_________________________________________________________');
  otr(m);
  writeln('_________________________________________________________');
  writeln('Для выхода из программы нажмите Enter');
  readln;
end.

[volvo]

Ну, посмотри вот тут: Сравнение Borland Pascal со стандартами - там указаны отличия... Можно и выгоду найти... При желании

[Айра]

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

[mouse1]

Повременил я с благодарствами =)

С утра не успел проверить,в инст пришёл и опана...

[Client]

Ты про это

[mouse1]

эм,он строки местами меняет тока кажись...

Сообщение отредактировано: mouse1 - 18.01.2008 1:59

[Client]

в инст пришёл и опана...

Скажи пример, на каком неправильно отработало

[mouse1]

Там несоответствие типов было,а сейчас он не сортирует... Прост отображается точно такая же матрица 2-ой раз...
n=3
m=3
[1,1]=1
[1,2]=3
[1,3]=2
[2,1]=5
[2,2]=5
[2,3]=5
[3,1]=2
[3,2]=2
[3,3]=1
Про отриц элементы в матрице всё правильно выдаёт

1 3 2
5 5 5
2 2 1

Номер первого столбца, в котором нет отриц элементов=1

а дальше должен отсортировать строки по возрастанию количества одинаковых элементов

5 5 5
2 2 1
1 3 2

Сообщение отредактировано: mouse1 - 18.01.2008 2:21

[Client]

по возрастанию количества одинаковых элементов

А ты пишешь

5 5 5
2 2 1
1 3 2

Надо ведь так:
1 3 2
2 2 1
5 5 5

[mouse1]

упс...ну да

[Client]

Тогда надо изменить процедуру bubble

for i:=1 to nmax do
      for j:=nmax downto i do
        if kol(m[i])>kol(m[j]) then
          begin
            t:=m[j];
            m[j]:=m[i];
            m[i]:=t;
          end;

Вроде на всех примерах отработала

[mouse1]

вставил,type mismatch выдаёт

[Client]

Надо же, несовпадение типов, ты хоть скажи где именно, и еще покажи ВЕСЬ код, куда и как ты это вставил

[mouse1]

program proga;
uses crt;
const
  max=10;
type
  mas=array[1..max,1..max] of integer;
  str = array[1..max] of integer;
var
   nmax,mmax:integer;
   m: mas;
   i,j,n:integer;
   function otr(var m:mas):integer;
   var
    found:boolean;
    d,t:integer;
    nom:integer;
     begin
       d:=0;
       t:=0;
       nom:=0;
       for j:=1 to mmax do
         begin
           d:=d+t;
           found:=false;
           for i:=1 to nmax do
             if m[i,j]<0 then
               begin
                 found:=true;
               end
             else nom:=j;
             if (found=false) and (d=0) then
               begin
                 t:=1;
                 writeln('Номер первого столбца в котором нет отрицателных чисел = ',nom);
               end;
         end;
       if (t=0) then writeln('Во всех столбцах матрицы присутствуют отрицательные числа.');
     end;

  Procedure bubble (Var m: mas);
  Var t: str; //массив, который будет равен i-й строке матрицы
    function kol(s: str): integer;  //нахождение количества одинаковых
    var v,w,k,kmax,x: integer;
    begin
      kmax:=0;
      for v:=1 to mmax do
        begin
          k:=1;
          x:=s[v];
          for w:=v+1 to mmax do if s[w]=x then inc(k);
          if k>kmax then kmax:=k;
        end;
      kol:=kmax;
    end;
  begin //начало процедуры
    for i:=1 to nmax do
      for j:=nmax downto i do
        if kol(m[i])>kol(m[j]) then
          begin
            t:=m[j];
            m[j]:=m[i];
            m[i]:=t;
          end;
  end;

begin
  clrscr;
  writeln ('  Упорядочить строки целочисленной прямоугольной матрицы');
  writeln ('по возрастанию количества одинаковых элементов в каждой стоке; ');
  writeln ('найти номер первого из столбцов, не содержащий ни одного   ');
  writeln ('отрицательного элемента. ');
  writeln;
  repeat
    writeln('Введите размер прямоугольной матрицы:');
    write('n=');
    readln(nmax);
    write('m=');
    readln(mmax);
    if (nmax<=0) or (nmax>max) or (mmax<=0) or (mmax>max) then
      writeln('Ошибка! Размер матрицы не должен выходить за рамки 10х10.');
  until (nmax>0) and (nmax<=max) and (mmax>0) and (mmax<=max);
    for i:=1 to nmax do
      for j:=1 to mmax do
        begin
write ('[',i,';',j,']=');
          readln(m[i,j]);
        end;
  writeln('_________________________________________________________');
  writeln('полученная матрица');
    for i:=1 to nmax do
      begin
        for j:=1 to mmax do
          write (m[i,j]:4);
        writeln;
      end;
  writeln('_________________________________________________________');
  otr(m);
  writeln('_________________________________________________________');
  bubble (m);
  writeln('полученная матрица');
    for i:=1 to nmax do
      begin
        for j:=1 to mmax do
          write (m[i,j]:4);
        writeln;
      end;
  writeln('_________________________________________________________');
  writeln('Для выхода из программы нажмите Enter');
  readln;
end.

if kol(m[i])>kol(m[j]) then

здесь выдаёт

[Client]

Если ты еще не понял в чем ошибка, то читай пост #15

[mouse1]

Всё..понял..исправил !

program proga;
uses crt;
const
  max=10;
type
  str = array[1..max] of integer;
  mas=array[1..max] of str;
var
   nmax,mmax:integer;
   m: mas;
   i,j,n:integer;
   function otr(var m:mas):integer;
   var
    found:boolean;
    d,t:integer;
    nom:integer;
     begin
       d:=0;
       t:=0;
       nom:=0;
       for j:=1 to mmax do
         begin
           d:=d+t;
           found:=false;
           for i:=1 to nmax do
             if m[i,j]<0 then
               begin
                 found:=true;
               end
             else nom:=j;
             if (found=false) and (d=0) then
               begin
                 t:=1;
                 writeln('Номер первого столбца в котором нет отрицателных чисел = ',nom);
               end;
         end;
       if (t=0) then writeln('Во всех столбцах матрицы присутствуют отрицательные 

числа.');
     end;

  Procedure bubble (Var m: mas);
  Var t: str; {массив, который будет равен i-й строке матрицы}
    function kol(s: str): integer;  {нахождение количества одинаковых}
    var v,w,k,kmax,x: integer;
    begin
      kmax:=0;
      for v:=1 to mmax do
        begin
          k:=1;
          x:=s[v];
          for w:=v+1 to mmax do if s[w]=x then inc(k);
          if k>kmax then kmax:=k;
        end;
      kol:=kmax;
    end;
  begin {начало процедуры}
    for i:=1 to nmax do
      for j:=nmax downto i do
        if kol(m[i])>kol(m[j]) then
          begin
            t:=m[j];
            m[j]:=m[i];
            m[i]:=t;
          end;
  end;

begin
  clrscr;
  writeln ('  Упорядочить строки целочисленной прямоугольной матрицы');
  writeln ('по возрастанию количества одинаковых элементов в каждой стоке; ');
  writeln ('найти номер первого из столбцов, не содержащий ни одного   ');
  writeln ('отрицательного элемента. ');
  writeln;
  repeat
    writeln('Введите размер прямоугольной матрицы:');
    write('n=');
    readln(nmax);
    write('m=');
    readln(mmax);
    if (nmax<=0) or (nmax>max) or (mmax<=0) or (mmax>max) then
      writeln('Ошибка! Размер матрицы не должен выходить за рамки 10х10.');
  until (nmax>0) and (nmax<=max) and (mmax>0) and (mmax<=max);
    for i:=1 to nmax do
      for j:=1 to mmax do
        begin
write ('[',i,';',j,']=');
          readln(m[i,j]);
        end;
  writeln('_________________________________________________________');
  writeln('полученная матрица');
    for i:=1 to nmax do
      begin
        for j:=1 to mmax do
          write (m[i,j]:4);
        writeln;
      end;
  writeln('_________________________________________________________');
  otr(m);
  writeln('_________________________________________________________');
  bubble (m);
  writeln('полученная матрица');
    for i:=1 to nmax do
      begin
        for j:=1 to mmax do
          write (m[i,j]:4);
        writeln;
      end;
  writeln('_________________________________________________________');
  writeln('Для выхода из программы нажмите Enter');
  readln;
end.

Tnx everybody !!

[Айра]

Тогда надо изменить процедуру bubble

Странно, но у меня прежний вариант сортирует нормально..
to mouse1 за "тип несовместим" сорри((( уже разобрали, почему у меня работало.. Ну хоть сдать еще есть возможность?

[mouse1]

Да,20 пойду ! Сёравно ещё другая прога не сделана,прост хотел облегчить себе учесть...