написанные программы / задание №3 — 2 / LABA3_02

{(c) 2000, M-byte ‹ Ў®а в®а­ п а Ў®в  ь3.}
program laba3;
uses crt;
const n=4;m=4;
type mass=array[1..n,1..m] of integer;
var i,j:byte;
a:mass;
f:text;

procedure pack(b:mass);
var i,j,k,l,o,nl1,nl2:byte;
one:boolean;
tmp:integer;
begin
nl1:=0;
nl2:=0;
i:=1;
j:=1;
while i<=n-nl2 do begin
j:=1;
while j<=m-nl1 do begin
if b[i,j]=0 then begin
one:=true;
for k:=1 to n do begin
if b[k,j]<>0 then begin
one:=false;
break;
end;
end;
if one then begin
inc(nl1);
for l:=1 to n do begin
for o:=j to m-1 do begin
b[l,o]:=b[l,o+1];
end;
b[l,m]:=0;
end;
end;
one:=true;
for k:=1 to m do begin
if b[i,k]<>0 then begin
one:=false;
break;
end;
end;
if one then begin
inc(nl2);
for o:=1 to m do begin
for l:=i to n-1 do begin
b[l,o]:=b[l+1,o];
end;
b[n,o]:=0;
end;
end;
end;
inc(j);
end;
inc(i);
end;
writeln(f);
writeln(f);
write(f,'“Ї«®в­Ґ­­ п ¬ ваЁж :');
for i:=1 to n-nl2 do begin
writeln(f,'');
for j:=1 to m-nl1 do write(f,' ',b[i,j]:4);
end;
end;
function max:byte;
var i,j:byte;
flag:boolean;
begin
flag:=false;
for i:=1 to n do begin
for j:=1 to m do begin
if a[i,j]>0 then begin
flag:=true;
break;
end;
end;
if flag then break;
end;
max:=i;
end;

begin
clrscr;
assign(f,'result3.txt');
rewrite(f);
write(f,'€б室­ п ¬ ваЁж :');
for i:=1 to n do begin
writeln(f);
for j:=1 to m do begin
write('ўўҐ¤ЁвҐ н«Ґ¬Ґ­в [',i,',',j,']: ');
readln(a[i,j]);
write(f,' ',a[i,j]:4);
end;
end;
pack(a);
writeln(f);
writeln(f);
writeln(f,'Ќ®¬Ґа бва®ЄЁ Ёб室­®© ¬ ваЁжл ᮤҐа¦ йЁ© Ї®«®¦ЁвҐ«м­л© н«Ґ¬Ґ­в: ',max);
close(f);
end.