Cod sursa(job #825523)

Utilizator hungntnktpHungntnktp hungntnktp Data 29 noiembrie 2012 09:56:43
Problema Barbar Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 4.56 kb
{$H+}
Uses math;
Const
        oo=1000000000;
        dong:array [1..4] of longint=(-1,0,1,0);
        cot:array [1..4] of longint=(0,1,0,-1);
Type
        mat=array [0..1001,0..1001] of longint;
        mat1=array [1..1000000] of longint;
Var     a,f,g,b:mat;
        free:array [1..1000,1..1000] of boolean;
        qx,qy:mat1;
        n,m,xp,yp,xc,yc,f0,ro,res:longint;
        s:string;
        fi,fo:text;

Procedure Doc;
        Var i,j:longint;
        Begin
                Readln(fi,n,m);
                For i:=0 to n+1 do
                 For j:=0 to m+1 do
                  Begin
                        f[i,j]:=oo;
                        g[i,j]:=oo;
                  end;
                For i:=1 to n do
                 Begin
                        Readln(fi,s);
                        For j:=1 to m do
                         If s[j]='I' then
                          Begin
                                xp:=i;
                                yp:=j;
                          end
                         else If s[j]='O' then
                          Begin
                                xc:=i;
                                yc:=j;
                          end
                         else If s[j]='*' then a[i,j]:=2
                         else If s[j]='D' then
                          Begin
                                a[i,j]:=1;
                                f[i,j]:=0;
                                g[i,j]:=0;
                          end;
                 end;
        end;

Procedure Khoitao;
        Var i,j:longint;
        Begin
                For i:=1 to n do
                 Begin
                  For j:=1 to m do
                    f[i,j]:=Min(f[i,j],Min(f[i,j-1],f[i-1,j])+1);
                  For j:=m downto 1 do
                    f[i,j]:=Min(f[i,j],Min(f[i,j+1],f[i-1,j])+1);
                 end;
                For i:=n downto 1 do
                 Begin
                  For j:=1 to m do
                    g[i,j]:=Min(g[i,j],Min(g[i,j-1],g[i+1,j])+1);
                  For j:=m downto 1 do
                    g[i,j]:=Min(g[i,j],Min(g[i,j+1],g[i+1,j])+1);
                 end;
                For i:=1 to n do
                 For j:=1 to m do f[i,j]:=Min(f[i,j],g[i,j]);
        end;


Procedure Push(x,y:longint);
        Begin
                inc(ro);
                qx[ro]:=x;
                qy[ro]:=y;
        end;

Procedure Pop(Var x,y:longint);
        Begin
                x:=qx[f0];
                y:=qy[f0];
                inc(f0);
        end;

Function Bfs(mid:longint):boolean;
        Var i,x,y,u,v:longint;
        Begin
                Fillchar(free,sizeof(free),true);
                f0:=1;
                ro:=0;
                Push(xp,yp);
                free[xp,yp]:=false;
				if f[xp,yp] < mid then exit(false);
                While f0<=ro do
                 Begin
                        Pop(x,y);
                        If (x=xc) and (y=yc) then exit(true);
                        For i:=1 to 4 do
                         Begin
                                u:=x+dong[i];
                                v:=y+cot[i];
                                If (u>=1) and (u<=n) and (v>=1) and (v<=m) then
                                If (f[u,v]>=mid) and (a[u,v]<>2) and (free[u,v]) then
                                 Begin
                                        free[u,v]:=false;
                                        Push(u,v);
                                 end;
                         end;
                 end;
                exit(false);
        end;

Function Check(x:longint):boolean;
        Begin
                exit(Bfs(x));
        end;

Procedure Lam;
        Var l,r,mid:longint;
        Begin
                Khoitao;
                l:=0;
                r:=oo;
                res:=-1;
                While l<=r do
                 Begin
                        mid:=(l+r) div 2;
                        If Check(mid) then
                         Begin
                                res:=mid;
                                l:=mid+1;
                         end
                        else r:=mid-1;
                 end;
        end;


Procedure Inkq;
        Begin
                Write(fo,res);
        end;

        Begin
                Assign(fi,'Barbar.in');Reset(fi);
                Assign(fo,'Barbar.out');Rewrite(fo);
                        Doc;
                        Lam;
                        Inkq;
                Close(fo);Close(fi);
        end.