NKTABLE - NKTable

Tác giả: ladpro98

Ngôn ngữ: Pascal

program NKTABLE;
uses    math;
const   maxn=555;
        fi='';
        dx:array[1..2] of longint = (0,1);
        dy:array[1..2] of longint = (1,0);
type    e=record
                x,y:longint;
        end;
var     a:array[1..maxn,1..maxn] of longint;
        q:array[1..2*maxn*maxn] of e;
        res:array[1..maxn+maxn] of longint;
        chk,chk2:array[1..maxn,1..maxn] of boolean;
        m,n,l,r,layer:longint;

procedure input;
var     inp:text;
        i,j:longint;
begin
        assign(inp,fi);reset(inp);
        readln(inp,m,n);
        for i:=1 to m do
        for j:=1 to n do read(inp,a[i,j]);
        close(inp);
end;

procedure bfsChk;
var     l,r,i,x,y:longint;
        u:e;
begin
        l:=1;r:=1;
        q[1].x:=m;q[1].y:=n;
        chk[m,n]:=true;
        while l<=r do begin
                u:=q[l];inc(l);
                for i:=1 to 2 do begin
                        x:=u.x-dx[i];
                        y:=u.y-dy[i];
                        if (0<x) and (0<y) and (x<=m) and (y<=n)
                        and (not chk[x,y]) and (a[x,y]<2) then begin
                                inc(r);
                                q[r].x:=x;
                                q[r].y:=y;
                                chk[x,y]:=true;
                        end;
                end;
        end;
end;

function bfs:boolean;
var     i,j,x,y:longint;
        u:e;
        found:boolean;
begin
        j:=r;
        found:=false;
        while l<=r do begin
                u:=q[l];inc(l);
                for i:=1 to 2 do begin
                        x:=u.x+dx[i];
                        y:=u.y+dy[i];
                        if (0<x) and (0<y) and (x<=m) and (y<=n)
                        and (chk[x,y]) and (not chk2[x,y]) and (a[x,y]<2) then begin
                                if a[x,y] = 1 then found:=true;
                                chk2[x,y]:=true;
                                inc(j);
                                q[j].x:=x;
                                q[j].y:=y;
                        end;
                end;
        end;
        r:=j;
        exit(found);
end;

procedure resetQueue;
var     tl,tr,i:longint;
begin
        tl:=l;tr:=r;
        l:=1;r:=0;
        for i:=tl to tr do
        if a[q[i].x,q[i].y]=1 then begin
                inc(r);
                q[r]:=q[i];
        end;
end;

begin
        input;
        bfsChk;
        l:=1;r:=1;q[1].x:=1;q[1].y:=1;
        res[1]:=a[1,1];
        for layer:=2 to m+n-1 do begin
                if bfs then begin
                        res[layer]:=1;
                        resetQueue;
                end
                else    res[layer]:=0;
        end;
        for layer:=1 to m+n-1 do write(res[layer]);
end.

Download