Cod sursa(job #231250)

Utilizator andreivFMI - vacaroiu andrei andreiv Data 14 decembrie 2008 11:56:17
Problema Tablete Scor 40
Compilator fpc Status done
Runda Algoritmiada 2009, Runda 1, Clasele 9-10 Marime 2.18 kb
program tablete;
var f,g:text;
    a:array[1..1003,1..1003] of integer;
    n,k,aux,q,y,mem,x,i,j:longint;


procedure inlocuire;
var i,j,aux:longint;
begin
for i:=n-1 downto 1 do for j:=n downto k+1 do
if a[i,j] mod 2=0 then begin aux:=a[i,j];a[i,j]:=a[n,k];a[n,k]:=aux; exit; end;
end;

procedure schimbare;
var aux,x,y:longint;
begin
for x:=n-1 downto 1 do for y:=n downto k+1 do
if a[x,y] <a[n,k] then begin aux:=a[x,y];a[x,y]:=a[n,j];a[n,j]:=aux; exit; end;

end;

procedure ordonare;
var i,j,aux:longint;
begin
for i:=1 to k-2 do
for j:=i+1 to k-1 do
if a[n,i]>a[n,j] then begin aux:=a[n,i];a[n,i]:=a[n,j];a[n,j]:=aux;  end;
end;


procedure afis2;
begin
mem:=0;x:=0;
for i:=1 to n-1 do
begin
y:=0;
if mem=0 then
       begin for j:=1 to k-1 do begin x:=x+1; y:=y+1; a[i,y]:=x; end;
             if (x+1) mod 2=0 then begin x:=x+1; y:=y+1; a[i,y]:=x; end else
                                   begin mem:=x+1; x:=x+2; y:=y+1; a[i,y]:=x; end;
             for j:=k+1 to n do begin x:=x+1; y:=y+1; a[i,y]:=x; end;
       end  else

       begin y:=y+1;a[i,y]:=mem;mem:=0;for j:=2 to k-1 do begin x:=x+1; y:=y+1;a[i,y]:=x;end;
             if (x+1) mod 2=0 then begin x:=x+1; y:=y+1; a[i,y]:=x; end else
                                   begin mem:=x+1; x:=x+2; y:=y+1; a[i,y]:=x; end;
             for j:=k+1 to n do begin x:=x+1; y:=y+1;a[i,y]:=x; end;
       end  ;


end;
i:=n;y:=0;q:=0;
if mem<>0 then begin y:=y+1;a[i,y]:=mem; for j:=2 to n do begin x:=x+1; y:=y+1;a[i,y]:=x; if (x mod 2=0) and (y<k) then q:=y;
               end end else
               begin for j:=1 to n do begin x:=x+1; y:=y+1;a[i,y]:=x; if (x mod 2=0) and (y<k) then q:=y;end end;

if a[n,k] mod 2<>0 then begin
                        if q<>0 then begin aux:=a[n,q];a[n,q]:=a[n,k];a[n,k]:=aux;  end else inlocuire;
                        for j:=1 to k-1 do if a[n,j]>k then schimbare;
                        ordonare;
                        end;

for i:=1 to n do
begin
for j:=1 to n do
write(g,a[i,j],' ');
writeln(g);;
end;

end;



begin
assign(f,'tablete.in');
assign(g,'tablete.out');
reset(f);
rewrite(g);
read(f,n,k);
afis2;
close(f);
close(g);
end.