Отсортировать столбцы матрицы в порядке невозрастания количества отрицательных элементов содержащихсяв них - Free Pascal

Узнай цену своей работы

Формулировка задачи:

Задание\ Отсортировать столбцы матрицы в порядке невозрастания количества отрицательных элементов содержащихсяв них . Сортировка простыми включениями Что можно сделать последовательно расскажите плиз)) {Можно ли какому нибудь элементу сопоставить столбец таким образом чтобы от положения элемента зависело положение столбца ??} \\ у меня была мысль составить последовательность содержащую количество отр чисел для каждого столбца потом отсортировать последовательность

Решение задачи: «Отсортировать столбцы матрицы в порядке невозрастания количества отрицательных элементов содержащихсяв них»

textual
Листинг программы
program rakhim;

 uses crt;
 {$R-}

 const
  nad1 = '    Òàáëèöà íå ñîçäàíà!   '; 
  nad2 = '    Ââåäèòå êîëè÷åñòâî ñòðîê ';
  nad3 = '    Ââåäèòå êîëè÷åñòâî ñòîëáöîâ ';
  nad4 = '    Íåäîñòàòî÷íî ïàìÿòè';
  nad5 = '    The table is created!  ';
  nad6 = '    Ââåäèòå ïóíêò';
  nad7 = '    1|Çàïîëíèòü òàáëèöó âðó÷íóþ';
  nad8 = '    2| Çàïîëíèòü òàáëèöó ñëó÷àéíûì îáðàçîì';
  nad9 = '    3| Çàïîëíèòü èç ôàéëà';
 nad10 = '    4| Íàçàä';
 nad11 = '    1 - Çàïîëíèòü òàáëèöó';
 nad12 = '    2 - Âûïîëíèòü çàäàíèå';
 nad13 = '    3 - Ïîêàçàòü òàáëèöó';
 nad14 = '    4 - Çàïèñàòü òàáëèöó â ôàéë';
 nad15 = '    5 - Âûõîä';




 Type TElem=Single;
      Tmas=array[1..1] of Telem;
      Pmas=^Tmas;
      Ttable=array[1..1] of Pmas;
      Ptable=^Ttable;

 const maxi=65521;

 var mas:Ptable;
     g: text;
     i,j,a,b:byte;
     ns1,ns2,t,i1:integer;
     w,w1:char;

     f:boolean;
     nameFILE:string;
     s:single;
     ntext:double;





  function rand(mqw:integer): TElem;
   begin
    rand := random(2 * mqw + 1) - mqw
   end;



  procedure pr3(var b:TMas; ns2:integer); { сортирует последовательность }

   procedure pr1(var mas:PTable; ns1,ns2:integer); { возвращает последовательность (содержащую количество отриц чисел для каждого столбца) }
    var
     y,u:integer;
     c:TMas;

    begin

    for y:=1 to ns1 do

     c^[y]:=0;



     for y:=1 to ns2 do
      begin
       for u:=1 to ns1 do
        if mas^[u]^[y]<0 then
         inc(c^[y]);

      end;
    end;


  procedure pr2(var mas:PTable; ns1,ns2,y1,y2:integer);  { Меняет два столбца местами  }
  var
   r:TElem;

  begin

    for i:=1 to ns1 do
     begin
      r:=mas^[i]^[y1];
      mas^[i]^[y1]:=mas^[i]^[y2];
      mas^[i]^[y2]:=r;

     end;


  end;








  var i,j:integer;
      x:TElem;
   begin

   for i:=2 to ns1 do
    if b^[i-1]<>b^[i] then
     begin
      x:=b^[i];
      j:=i-1;
       while (j>0) and (b^[j]>x) do
        begin
         b^[j+1]:=b^[j];
         j:j-1;

        end;
        b^[j+1]:=x;

        pr2(mas,ns1,ns,i,j);


     end;


   end;





  procedure FramePlot({Left,Top,}Hight,Width: integer);
   var

     i: integer;
     Left,Top: integer;
   const
     qp =  176;
  begin
   Left:=10;
   Top :=2;
   gotoxy(left,top);  write(char(qp));
   gotoxy(left+width,top);  write(char(qp));
   gotoxy(left,top+hight); write(char(qp));
   gotoxy(left+width,top+hight); write(char(qp));
    for i:=left+1 to left+width-1 do
     begin
      gotoxy(i,top); write(char(qp));
     gotoxy(i,top+hight); write(char(qp));
   end;
    for i:=top+1 to top+hight-1 do
     begin
      gotoxy(left,i); write(char(qp));
     gotoxy(left+width,i); write(char(qp));
   end;
end;




 procedure showtable(var ns1,ns2:integer; var mas:Ptable);
  var i,j: byte;
      a:single;

   begin
    textcolor(1);

     if (ns1=0) or (ns2=0) then
      begin
      clrscr;
      writeln(nad1);
      readln;
      end

     else
       begin
       clrscr;
       textcolor(6);

        FramePlot(ns1{*4}+ns1*2+ns1+ns1,ns2{*11}+ns2*9+ns2);
        textcolor(15);
        for i:=1 to ns1 do
         begin
          writeln;
           for j:=1 to ns2 do



         begin
          gotoxy(j*10+2,i*3+2);
            write('  ',mas^[i]^[j]:3:2,'    ');

         end;


       end;
     readln;
   end;

   textcolor(15);
  end;



procedure createtable;
 ////////////////////////////////////////////////////////////////////////////////////

procedure ctkeyboard(var n,m:integer; f: boolean; var x:Ptable);  // ðóêè
  var i,j: byte;
      k:boolean;
  begin
   f:=false;
   repeat
    writeln(nad2);
     {$I-}
       readln (n);
     {$I+}
        if Ioresult = 0 then f:= true
   until f;

   f:=false;
   repeat
    writeln(nad3);
     {$I-}
       readln(m);
     {$I-}
        if IOresult = 0 then F:=true;
   until f;
    f:=False;
     if (maxi<n*sizeof(Pmas)) and (maxi<m*sizeof(Telem))
     then
      begin
       writeln(nad4);
        f:=true;
       readln;
      end
     else
      begin
       Getmem(x,n*sizeof(Pmas));
        for i:=1 to n do
         Getmem(x^[i],m*sizeof(telem));
      end;
       for i:=1 to n do
        for j:=1 to m do
         begin
          repeat
           Write('[',i,',',j,'] : ');
           k:=false;
           {$I-}
             readln(x^[i]^[j]);
           {$I+}
            if IOResult = 0 then k:=true;
             until k;
         end;

  end;


  procedure ctrandom(var n,m:integer; f: boolean; var x:Ptable);
  var i,j: byte;
      k:boolean;
begin
  f:=false;
   repeat
    writeln(nad2);

    {$I-}
     readln(n);
    {$I+}
       if Ioresult = 0 then f:= true
   until f;
     f:=false;
      repeat
       writeln(nad3);
        {$I-}
         readln(m);
        {$I-}
         if IOresult = 0 then F:=true;
      until f;
       f:=False;
        if (maxi<n*sizeof(Pmas)) and (maxi<m*sizeof(Telem))
      then
         begin
          writeln(nad4);
          writeln(nad1);
          delay(1000);
           f:=true;
            readln;
         end
      else
         begin
           Getmem(x,n*sizeof(Pmas));
           for i:=1 to n do
           Getmem(x^[i],m*sizeof(telem));
         end;
        for i:=1 to n do
         for j:=1 to m do
          begin
           x^[i]^[j]:=rand(100);
         {  x^[i]^[j]:=x^[i]^[j]*pi  }
          end;
     writeln(nad5);
     delay(500);


  end;


 procedure readfile(var n,m:integer; var x:Ptable);
 var i,j,z,q:integer;
     nf:string;
     f:file of TElem;
     c:TElem;
     t:boolean;
 begin


 clrscr;
 writeln('Ââåäèòå èìÿ ôàéëà');
 readln(nf);
 assign (f,nf);
 {$I-}
 reset(f);
 {$I+}
 if IOResult <> 0 then


 begin
   writeln ('  Ôàéë íå íàéäåí!  ');
   delay(500);
 end
  else
   begin
    {$I-}
    read(f,c);
    {$I+}  n:=trunc(c);
    {$I-}
    read(f,c);
    {$I+}  m:=trunc(c);

   if (ioresult=0) and (n>0) and (m>0) then
     begin
       t:=true;
       Getmem(x,n*sizeof(Pmas));
       for i:=1 to n do Getmem(x^[i],m*sizeof(telem));
       for i:=1 to n do
          for j:=1 to m do
          begin
             {$I-}
             read(f,x^[i]^[j]);
             {$I+}
             if ioresult<>0 then t:=false;
          end;

          writeln(nad5);
          delay(500);

     end

    else
       begin
         writeln ('  Ðàçìåðû íåâåðíû!  ');
           writeln(nad1);

         delay(1000);
        end;


    readln;
    {$I-}
    close(f);
    {$I+}


       end;
 end;


 /////////////////////////////////////////////////////////////////////////////////////
begin
 repeat
    clrscr;
  gotoxy(12,4);    Writeln(nad6,#10,#13,nad7,#10,#13,nad8,#10,#13,nad9,#10,#13,nad10);
     writeln;


     repeat
       w1:=readkey();
     until w1 in  ['1'..'4'];



     case w1 of
            '1': ctkeyboard(ns1,ns2,f,mas);
            '2': ctrandom(ns1,ns2,f,mas);
            '3': readfile(ns1,ns2,mas);
     end;
     until w1='4';

end;

{}

  procedure  task(i1:integer);


 function yes(el: telem): integer;
  var
   i, j: integer;

     begin
       yes := 0;
        for j := 1 to ns2 do
          begin
            i := 1;
             while (i <= ns1) and (mas^[i]^[j] <> el)   do
              inc(i);
               if i <= ns1 then
              inc(yes);
          end;
     end;



   var
    max,j1,j2,i2:integer;

   begin
    max:=0;
     for j1:=1 to ns2 do
      if yes(mas^[i1]^[j1]) >=  max then
       begin
        i2:=i1;
        j2:=j1;
          max:=yes(mas^[i1]^[j1]);
       end;
      writeln;
     writeln('   Ýëåìåíò ' ,mas^[i2]^[j2]:3:3,' ñîäåðæèòñÿ â ',max,'- ñòîëáöàõ');
     readln;
   end;



procedure recordfile(n,m:integer; x:Ptable);
 var


 nf: string;
   i,j: byte;
     f: file of TELem;
     g: integer;
     k: boolean;

begin
clrscr;
 if (n=0) or (m=0) then
  begin
  writeln(nad1);
  readln();
  end
  else
  begin
clrscr;



     repeat
      writeln('Ââåäèòå èìÿ ôàéëà');
       k:=false;

    {$I-}  readln(nf);
       if IOResult = 0 then k:=true;
     until k;
     {$I+}


repeat
 repeat

  k:=false;
  {$I-}

  if ioresult = 0 then k:=true;
  until k;
 until ioresult = 0;
 repeat
  repeat

  k:=false;
  {$I-}

  if ioresult = 0 then k:=true;
  until k;
 until ioresult = 0;
 if (n>0) or (m>0) then
  begin
  {$I-}
   Assign(f,nf);
    rewrite(f);
        write(f,n,m);
      {  write(f,m); }
        for i:=1 to n do
          for j:=1 to m do
           begin
             if (x^[i]^[j]=0) then g:=g+1;
             write(f,x^[i]^[j]);

            end;
  {$I+}
       Close(f);
       if g=n*m then writeln('Òàáëèöà èç íóëåé!');
       end
 else begin
 writeln('Íå âåðíûå ãðàíèöû òàáëèöû');
 readln;
  end;
end;
end;





  begin


   repeat
    clrscr;
     textcolor(15);
  gotoxy(12,4);   Writeln(nad6,#10,#13,nad11,#10,#13,nad12,#10,#13,nad13,#10,#13,nad14,#10,#13,nad15);
     writeln;

     repeat
       w:=readkey();
     until w in ['1'..'5'];


     case w of
            '1':  createtable;
            '2':
              begin
               i1:=-1;
                showtable(ns1,ns2,mas);
               if (ns1=0) or (ns2=0) then writeln('') else begin
                while not (ioresult=0) or (i1<=0) or (i1>ns1)  do
                 begin

	          write(' ââåäèòå íîìåð ëèíèé: ');
                   {$I-}
                    readln(i1);
                   {$I+}

                 end;

                 writeln;
	         task(i1);

               end;
              end;
            '3': showtable(ns1,ns2,mas);
            '4': recordfile(ns1,ns2,mas);
     end;
     until w='5';
end.

Оцени полезность:

9   голосов , оценка 3.889 из 5
Похожие ответы