Developing.ru

Код: Выделить всё

                        {Programma  reschaet sleduyuschuyu zadachu:
Otsortirovatq  pryamougolqnuyu matricu  razmerom N*M po neubqivaniyu i
vqivesti ee na ekran
  0 2 3
  1 4 7
  5 6 8
  Metod sortirovki: оптимизированная пузырьковая сортировка}
uses
  Crt;
const
  nMax=100;
type
  TIndex  = 0..nMax;
  TElement = integer;   {tip matricqi}
  K = array [0..nMax*nMax] of integer;
  Matrix = array [TIndex,TIndex] of TElement;

var
  N,M,Min   : integer;
  e,d,R,T   : integer;
  a,b       : Matrix;
  c         : K;
{Procedura zapolnyaet matricu sluchajnqimi znacheniyami}
Procedure MakeMatrix (M : Integer; var a : Matrix );
var
  i,j : TIndex;

begin {MakeMatrix}
  Randomize;
  for i:=0 to m-1 do
    for j:=0 to M-1 do
      a[i,j]:=random(51);
end;  {MakeMatrix}


Procedure Swap ( var k, d: TElement);

var
  t:TElement;
Begin {Swap}
  t:=k;
  k:=d;
  d:=t;

End; {Swap}



{Procedura zapolnyaet matricu znacheniyami}
Procedure Make (a: Matrix; c: K; T,R: integer);
var
  i,j,ii,jj : TIndex;
  s : Integer;
begin {Make}
  for i:=0 to m-1 do
    for j:=0 to M-1 do
    begin

      s:=c[M*i+j];

      If s<=R then
      begin
        e:=s;
        d:=0;
        while e>d do
        begin
          e:=e-d-1;
          inc(d);
        end;
        If d mod 2=1 then
        begin
          ii:=d-e;
          jj:=M-1-e;
        end
        else
        begin
          ii:=e;
          jj:=M-1-d+e;
        end;
      end;

      If (s>R) and (s<T-R) then
      begin
        d:=Min + (s-R-1) div Min;
        e:=(s-R-1) mod Min;
        If m>=M then          {matrica pryamougolqnaya}
          If d mod 2 = 0 then
          begin
            ii:=d-e;
            jj:=M-1-e;
          end
          else
          begin
            ii:=1+d-M+e;
            jj:=e;
          end
        else
        begin
          If d mod 2 = 1 then
          begin
            ii:=m-1-e;
            jj:=M-d+Min-e-2;
          end
          else
          begin
            ii:=e;
            jj:=M-1-d+e;
          end;
        end;
      end;

      If (s>=T-R) and (s<=T) then
      begin
        e:=T-s;
        d:=0;
        while e>d do
        begin
          e:=e-d-1;
          inc(d);
        end;
        If ((d mod 2 = 0) and ((m+M) mod 2 = 0)) or   {chetnostq diagonali}
        ((d mod 2 = 1) and ((m+M)mod 2 = 1)) then
        begin
          ii:=N-1-e;
          jj:=d-e;
        end
        else
        begin
          ii:=m-1-d+e;
          jj:=e;
        end;
      end;

      b[ii,jj]:=a[i,j];
    end;
end; {Make}
   Procedure Sorting (m:tElement; Var a:Matrix);
Var bound,t,j,i1,j1,i2,j2:TElement;
Begin {Sorting}
  bound:=m*m-1;
  Repeat
    t:=0; {место последнего обмена**}
    For j:=0 to bound-1 do
    Begin

      If a[i1,j1] < a[i2,j2] then
      Begin
        Swap(a[i1,j1],a[i2,j2]);
        t:=j;
      End;
    End;
    Bound:=t;
  Until t=0;
End; {Sorting}

{Procedura vqivodit matricu na ekran}
Procedure PrintMatrix (a: Matrix; M:integer);
var
  i,j  :integer;
begin {PrintMatrix}
  for i:=0 to m-1 do
  begin
    for j:=M-1 downto 0 do
      write(a[i,j]:4);
    writeln;
    writeln;
  end;
end; {PrintMatrix}
begin  {Program}
  ClrScr;
  writeln('Vvedite razmernostq matricqi * (1<N<10):');
  readln(M);
  if m>=M then
    Min:=M
  else
    Min:=m;
  T:=m*M-1;
  R:=-1+(Min*(Min+1)) div 2;
  MakeMatrix(M,a);
  Writeln('Ishodnaya Matrica');
  PrintMatrix(a,M);
  Sorting(m,a);
  Make(a,c,T,R);
  Writeln('Poluchennaya matrica');
  PrintMatrix(b,M);
  readln;
end.