SLIKAR - Slikar

Tác giả: flashmt

Ngôn ngữ: Pascal

const fi='';
      fo='';
      maxn=512;
      maxc=1000000000;
      dx:array[1..4] of longint=(-1,-1,0,0);
      dy:array[1..4] of longint=(-1,0,-1,0);
var n,m:longint;
    a,re:array[1..maxn,1..maxn] of byte;
    min,b,tr:array[0..9,1..maxn,1..maxn] of longint;
    p:array[0..9] of longint;
    d:array[1..4] of byte;
    dt:array[1..9,1..maxn div 2,1..maxn div 2,1..4] of byte;

procedure rf;
var i,j:longint; c:char;
begin
     assign(input,fi);
     reset(input);
     readln(n);
     for i:=1 to n do
     begin
          for j:=1 to n do
          begin
               read(c);
               if c='0' then
               begin
                    a[i,j]:=0;
                    b[0,i,j]:=0;
               end
               else
               begin
                    a[i,j]:=1;
                    b[0,i,j]:=1;
               end;
          end;
          readln;
     end;
     re:=a;
     p[0]:=1;
     for i:=1 to 9 do p[i]:=p[i-1] shl 1;
     close(input);
end;

procedure fill2(deg,x,y,val:longint);
var i,j:longint;
begin
     for i:=p[deg]*(x-1)+1 to p[deg]*x do
         for j:=p[deg]*(y-1)+1 to p[deg]*y do
             re[i,j]:=val;
end;

procedure fill(deg,x,y:longint);
var i,j,p,q:longint;
begin
     p:=tr[deg,x,y] div 10; q:=tr[deg,x,y] mod 10;
     fill2(deg-1,2*x+dx[p],2*y+dy[p],0);
     fill2(deg-1,2*x+dx[q],2*y+dy[q],1);
     if deg=1 then exit;
     dt[deg,x,y,p]:=1; dt[deg,x,y,q]:=1;
     for i:=1 to 4 do
         if dt[deg,x,y,i]=0 then fill(deg-1,2*x+dx[i],2*y+dy[i]);
end;

procedure pr;
var i,j,k,t,r,q,s,u:longint; kt:boolean;
begin
     for i:=1 to 9 do
     begin
          t:=n div p[i];
          if t=0 then break;
          for j:=1 to t do
              for k:=1 to t do
              begin
                   min[i,j,k]:=maxc;
                   r:=2*j; q:=2*k;
                   b[i,j,k]:=b[i-1,r-1,q-1]+b[i-1,r-1,q]+b[i-1,r,q-1]+b[i-1,r,q];
              end;
     end;
     m:=i-1;
     if n=512 then m:=9;
     for i:=1 to m do
     begin
       t:=n div p[i];
       for j:=1 to t do
         for k:=1 to t do
         begin
              kt:=false;
              for r:=1 to 4 do
                if kt then break
                else
                for q:=1 to 4 do
                  if r<>q then
                  begin
                       fillchar(d,sizeof(d),0);
                       d[r]:=1; d[q]:=1;
                       s:=b[i-1,2*j+dx[r],2*k+dy[r]]+p[i-1]*p[i-1]-b[i-1,2*j+dx[q],2*k+dy[q]];
                       for u:=1 to 4 do
                           if d[u]=0 then
                              s:=s+min[i-1,2*j+dx[u],2*k+dy[u]];
                       if s<min[i,j,k] then
                       begin
                            min[i,j,k]:=s;
                            kt:=s=0;
                            tr[i,j,k]:=r*10+q;
                            if kt then break;
                       end;
                  end;
         end;
     end;
     fill(m,1,1);
end;

procedure wf;
var i,j:longint;
begin
     assign(output,fo);
     rewrite(output);
     writeln(min[m,1,1]);
     for i:=1 to n do
     begin
          for j:=1 to n do
              write(re[i,j]);
          writeln;
     end;
     close(output);
end;

begin
     rf;
     pr;
     wf;
end.

Download