Решаем задачи Абрамян на Паскале. Param29

Param29. Описать процедуру SortCols($$A$$, $$M$$, $$N$$), выполняющую сортировку по возрастанию столбцов целочисленной матрицы $$A$$ размера $$M \times N$$ (столбцы сравниваются лексикографически: если первые элементы столбцов различны, то меньшим считается столбец, содержащий меньший первый элемент; если первые элементы столбцов равны, то анализируются их вторые элементы и т. д.). Двумерный массив $$A$$ является входным и выходным параметром. Используя процедуру SortCols, отсортировать столбцы данной матрицы $$A$$ размера $$M \times N$$.

Решение:

program Param29;
type
 Matrix = array[1..10,1..10] of integer;
var
 M,N,K,L:integer;
 A:Matrix;

Procedure SwaP_Col(var A:Matrix; M,N,K1,K2:integer);
var
 j:integer;
begin
 for j:=1 to N do
  begin
   A[k1,j]:=A[k1,j]+A[k2,j];
   A[k2,j]:=A[k1,j]-A[k2,j];
   A[k1,j]:=A[k1,j]-A[k2,j];
  end;
end;

Function Comparison_Col(A:Matrix; M,N,K1,K2:integer):boolean;
var
 j:integer;
begin
 j:=1;
 While (j<=N) do
  begin
   If A[k1,j]>A[k2,j] then
    begin
     Comparison_Col:=TRUE;
     break;
    end;
   If A[k1,j]<A[k2,j] then
    begin
     Comparison_Col:=FALSE;
     break;
    end;
   inc(j);
  end;
 if n=j then Comparison_Col:=FALSE;
end;

Procedure SortCols(var A:Matrix; M,N:integer);
var
 Atemp:Matrix;
 k1,k2:integer;
begin
 for k:=1 to M-1 do
  for k2:=1 to M-k do
   begin
    Writeln(k2,' - ',k2+1);
    if Comparison_Col(A,M,N,k2,k2+1) then
     begin
      Writeln(k2,' - ',k2+1);
      SwaP_Col(A,M,N,k2,k2+1);
     end;
   end;
end;

Procedure EnterMatrix(var B:Matrix; var M,N:integer);
var j,j2:integer;
begin
 Write('M: ');
 Readln(M);

 Write('N: ');
 Readln(N);

 for j:=1 to N do
  begin
   for j2:=1 to M do
    begin
     Write (' ',J2,':',J,' : ');
     Read (B[J2,J]);
    end;
   Writeln;
  end;
end;

Procedure InputMatrix(B:Matrix; M,N:integer);
var j,j2:integer;
begin
 Writeln('---');
 Writeln(M,'x',N);
 for j:=1 to N do
  begin
   for j2:=1 to M do
    Write (B[J2,J],' ');
   Writeln;
  end;
 Writeln('---');
end;

begin
 EnterMatrix(A,M,N);
 InputMatrix(A,M,N);
 SortCols(A,M,N);
 InputMatrix(A,M,N);
end.

program Param29;

type

Matrix = array[1..10,1..10] of integer;

var

M,N,K,L:integer;

A:Matrix;

Procedure SwaP_Col(var A:Matrix; M,N,K1,K2:integer);

var

j:integer;

begin

for j:=1 to N do

begin

A[k1,j]:=A[k1,j]+A[k2,j];

A[k2,j]:=A[k1,j]-A[k2,j];

A[k1,j]:=A[k1,j]-A[k2,j];

end;

Function Comparison_Col(A:Matrix; M,N,K1,K2:integer):boolean;

var

j:integer;

begin

j:=1;

While (j<=N) do

begin

If A[k1,j]>A[k2,j] then

begin

Comparison_Col:=TRUE;

break;

end;

If A[k1,j]<A[k2,j] then

begin

Comparison_Col:=FALSE;

break;

end;

inc(j);

end;

if n=j then Comparison_Col:=FALSE;

end;

Procedure SortCols(var A:Matrix; M,N:integer);

var

Atemp:Matrix;

k1,k2:integer;

begin

for k:=1 to M-1 do

for k2:=1 to M-k do

begin

Writeln(k2,' - ',k2+1);

if Comparison_Col(A,M,N,k2,k2+1) then

begin

Writeln(k2,' - ',k2+1);

SwaP_Col(A,M,N,k2,k2+1);

end;

Procedure EnterMatrix(var B:Matrix; var M,N:integer);

var j,j2:integer;

begin

Write('M: ');

Readln(M);

Write('N: ');

Readln(N);

for j:=1 to N do

begin

for j2:=1 to M do

begin

Write (' ',J2,':',J,' : ');

Read (B[J2,J]);

end;

Writeln;

end;

Procedure InputMatrix(B:Matrix; M,N:integer);

var j,j2:integer;

begin

Writeln('---');

Writeln(M,'x',N);

for j:=1 to N do

begin

for j2:=1 to M do

Write (B[J2,J],' ');

Writeln;

end;

Writeln('---');

end;

begin

EnterMatrix(A,M,N);

InputMatrix(A,M,N);

SortCols(A,M,N);

InputMatrix(A,M,N);

end.

Другие задачи из раздела Param можно посмотреть здесь.

Комментарии 2

program Param29;//pabc.net

procedure SortCols(a: array[,] of integer);
begin
  var m := a.GetLength(0);
  var n := a.GetLength(1);
  for var k := n - 2 downto 0 do
  begin
    var i := 0;
    var j := 0;
    while (j <= k) and (i <= m - 1) do
    begin
      if a[i, j] > a[i, j + 1] then
      begin
        for var l := 0 to m - 1 do
          Swap(a[l, j], a[l, j + 1]);
        i := 0
      end
      else
      if a[i, j] = a[i, j + 1] then
      begin
        i += 1;
        continue
      end
      else  i := 0;
      j += 1
    end
  end
end;

begin
  var m := 3;
  var n := 6;
  
  var a := MatrRandom(m, n, 0, 9); a.Println;
//  7   2   8   7   4   7
//  1   8   6   8   4   8
//  7   3   9   8   0   6
  SortCols(a);
  Println;
  a.Println;
//  2   4   7   7   7   8
//  8   4   1   8   8   6
//  3   0   7   6   8   9
end.

program Param29;//pabc.net

procedure SortCols(a: array[,] of integer);

begin

var m := a.GetLength(0);

var n := a.GetLength(1);

for var k := n - 2 downto 0 do

begin

var i := 0;

var j := 0;

while (j <= k) and (i <= m - 1) do

begin

if a[i, j] > a[i, j + 1] then

begin

for var l := 0 to m - 1 do

Swap(a[l, j], a[l, j + 1]);

i := 0

end

else

if a[i, j] = a[i, j + 1] then

begin

i += 1;

continue

end

else i := 0;

j += 1

end

end;

begin

var m := 3;

var n := 6;

var a := MatrRandom(m, n, 0, 9); a.Println;

// 7 2 8 7 4 7

// 1 8 6 8 4 8

// 7 3 9 8 0 6

SortCols(a);

Println;

a.Println;

// 2 4 7 7 7 8

// 8 4 1 8 8 6

// 3 0 7 6 8 9

end.

Ответить

type
  aoi = array [1..10, 1..10] of integer;

var
  a: aoi;
  m, n, i, j: integer;

procedure SortCols(var a: aoi; m, n: integer);
var
  i, j, x, v: integer;
begin
  for i := 1 to n do
    for j := i to n do // сортировка пузырьком
    begin
      if a[1, j] < a[1, i] then // если в первой строке элемент столбца меньше 
      begin 
        for x := 1 to m do // с 1ой по последнюю строку
        begin
          v := a[x, j];
          a[x, j] := a[x, i]; 
          a[x, i] := v;       //меняем их местами
        end;
      end
      else if (a[1, j] = a[1, i]) and (i <> j) and (2 <= m) then //если в 1й
      begin //строке элементы одинаковые,и это не один и тот же столбец, и 
      // 2ая строка существует
        if a[2, j] < a[2, i] then //сравниваем элементы тех же столбцов 2й строки
        begin // если меньше 
          for x := 1 to m do //с 1 по последнюю строку меняем столбцы местами 
          begin
            v := a[x, j];
            a[x, j] := a[x, i];
            a[x, i] := v;
          end;
        end
        else if (a[2, j] = a[2, i]) and (3 <= m) then //если они равны и 
        //существует 3я строка
        begin
          if a[3, j] < a[3, i] then // сравниваем те же столбцы по 3й строке
          begin // если меньше
            for x := 1 to m do // с 1 по последнюю строку меняем столбцы местами
            begin
              v := a[x, j];
              a[x, j] := a[x, i];
              a[x, i] := v;
            end;
          end
        end;
      end;
    end;
end;

begin
  writeln ('M:');
  readln(m);
  writeln ('N:');
  readln(n);
  writeln ('A:');
  for i := 1 to m do
    for j := 1 to n do read(a[i, j]); // ввод
  SortCols(a, m, n);                  // процедура
  for i:=1 to m do
  begin
    for j:=1 to n do write (a[i,j],' '); //вывод
    writeln;
    end;
end.

type

aoi = array [1..10, 1..10] of integer;

var

a: aoi;

m, n, i, j: integer;

procedure SortCols(var a: aoi; m, n: integer);

var

i, j, x, v: integer;

begin

for i := 1 to n do

for j := i to n do // сортировка пузырьком

begin

if a[1, j] < a[1, i] then // если в первой строке элемент столбца меньше

begin

for x := 1 to m do // с 1ой по последнюю строку

begin

v := a[x, j];

a[x, j] := a[x, i];

a[x, i] := v; //меняем их местами

end;

end

else if (a[1, j] = a[1, i]) and (i <> j) and (2 <= m) then //если в 1й

begin //строке элементы одинаковые,и это не один и тот же столбец, и

// 2ая строка существует

if a[2, j] < a[2, i] then //сравниваем элементы тех же столбцов 2й строки

begin // если меньше

for x := 1 to m do //с 1 по последнюю строку меняем столбцы местами

begin

v := a[x, j];

a[x, j] := a[x, i];

a[x, i] := v;

end;

end

else if (a[2, j] = a[2, i]) and (3 <= m) then //если они равны и

//существует 3я строка

begin

if a[3, j] < a[3, i] then // сравниваем те же столбцы по 3й строке

begin // если меньше

for x := 1 to m do // с 1 по последнюю строку меняем столбцы местами

begin

v := a[x, j];

a[x, j] := a[x, i];

a[x, i] := v;

end;

end

end;

begin

writeln ('M:');

readln(m);

writeln ('N:');

readln(n);

writeln ('A:');

for i := 1 to m do

for j := 1 to n do read(a[i, j]); // ввод

SortCols(a, m, n); // процедура

for i:=1 to m do

begin

for j:=1 to n do write (a[i,j],' '); //вывод

writeln;

end;

end.

Ответить

Решаем задачи Абрамян на Паскале. Param29

Комментарии:

Комментарии 2

Добавить комментарий Отменить ответ