uses crt;
var a:array[1..10,1..9] of integer;
b:array[1..9] of byte;
m,n,i,j,f,p,k:byte;
begin
clrscr;
randomize;
n:=10;
m:=9;
writeln('Исходная матрица:');
for i:=1 to n do
begin
for j:=1 to m do
begin
a[i,j]:=random(10);
write(a[i,j]:3);
end;
writeln;
end;
writeln;
{номера столбцов с нолями}
f:=0;
for j:=1 to m do
begin
k:=0;
for i:=1 to n do
if a[i,j]=0 then
begin
k:=1;
f:=1;
end;
b[j]:=k;
end;
if f=0 then write('В матрице нет нолей!')
else
begin
{удаление строк с нолем}
i:=n;{начнем с конца}
while(i>=1)and(n>0) do
begin
k:=0;
j:=1;
while(j<=m)and(k=0) do
if a[i,j]=0 then k:=1
else j:=j+1;
if k=1 then{если есть ноль}
begin
f:=f-1;{вычитаем строку}
if i=n then {если строка на этот момент последняя}
begin
n:=n-1;{обрезаем}
i:=i-1;{верх}
end
else {если не последняя}
begin
for k:=i to n-1 do{от этой строки до предпоследней}
for p:=1 to m do{всем элементам строк}
a[k,p]:=a[k+1,p];{присваиваем значения нижней}
n:=n-1;{уменьшаем количество}
end;
end
else i:=i-1;{если нет нолей, вверх}
end;
if n=0 then writeln('Все строки и столбцы удалены!')
else{если остались строки, удаляем столбцы}
begin
f:=m;{начнем с конца}
for i:=m downto 1 do{в обратном порядке читаем массив номеров}
if b[i]=1 then{если есть ноль}
begin
if i=f then{и последний на данный момент, также как строки}
begin
m:=m-1;
f:=f-1;
end
else {если не последний, тоже как строки}
begin
for k:=i to m-1 do
for p:=1 to n do
a[p,k]:=a[p,k+1];
m:=m-1;
end;
end;
writeln('Матрица после сжатия:');
for i:=1 to n do
begin
for j:=1 to m do
write(a[i,j]:3);
writeln;
end;
end;
end;
readln
end.