Дана матрица A(N,M) продублировать столбцы матрицы, элементы которых являются перестановкой элементов последнего столбца — Pascal(Паскаль)

uses crt;
const max=20;
type stb=array[1..max] of integer;//1 столбец
     matr=array[1..max] of stb;//массив столбцов=матрица
procedure Sort(var s:stb;m:byte);//сортировка столбца
var i,j:byte;
    b:integer;
begin
for i:=1 to m-1 do
for j:=i+1 to m do
if s[i]>s[j] then**по возрастаеию, хотя это без разницы
 begin
  b:=s[i];
  s[i]:=s[j];
  s[j]:=b;
 end;
end;
function Ravn(s1,s2:stb;n:byte):boolean;//проверка на равность
var i:byte;
    f:boolean;
begin
f:=true;
i:=1;
while (i<=n) and f do
if s2[i]<>s1[i] then f:=false//если не совпал элемент
else i:=i+1;
Ravn:=f;
end;
 
var a:matr;
    x,y:stb;
    m,n,i,j,k,p:byte;
begin
clrscr;
randomize;
repeat
write('Количество строк до ',max,' n=');
readln(n);
until n in [1..max];
repeat
write('Количество столбцов до ',max div 2,' m=');
readln(m);
until m in [1..max div 2];
writeln('Введите элементы последнего столбца:');
for i:=1 to n do
 begin
  write('a[',m,',',i,']=');
  readln(a[m,i]);
 end;
writeln('Введите элементы остальных столбцов:');
for j:=1 to m-1 do
for i:=1 to n do
 begin
  write('a[',j,',',i,']=');
  readln(a[j,i]);
 end;
clrscr;
writeln('Исходная матрица:');
for i:=1 to n do
 begin
  for j:=1 to m do
  write(a[j,i]:4);//вывод транспонировано по строкам
  writeln;
 end;
j:=1;p:=0;//начнем с первого
while j<=m-1 do//пока не предпослебний
 begin
  x:=a[m];//последний на данный момент столбец
  Sort(x,n);//сортируем
  y:=a[j];//текущий
  Sort(y,n);//сортируем
  if Ravn(x,y,n) then//сравниваем
   begin
    m:=m+1;//если равны, добавляем столбец
    p:=1;//фиксируем наличие совпадений
    x:=a[j];//запомним столбец
    for k:=m downto j+2 do//сдвинем вправо на 1
    for i:=1 to n do
    a[k,i]:=a[k-1,i];
    a[j+1]:=x;//вставим столбец
    j:=j+2;//перешагнем
   end
  else j:=j+1;//иначе вперед
 end;
if p=0 then write('Столбцов-перестановок последнего нет!')
else
 begin
  writeln('Дублирование столбцов:');
  for i:=1 to n do
   begin
    for j:=1 to m do
    write(a[j,i]:4);//вывод по строкам
    writeln;
   end;
 end;
readln
end.

Leave a Comment

+ 3 = 10