Cod sursa(job #850217)

Utilizator baolaptrinhbaolaptrinh baolaptrinh Data 8 ianuarie 2013 03:53:09
Problema Barbar Scor 70
Compilator fpc Status done
Runda Arhiva de probleme Marime 4.22 kb
{$H+}
Const
        dong:array [1..4] of longint=(-1,0,1,0);
        cot:array [1..4] of longint=(0,1,0,-1);
Type
        mat=array [1..1000,1..1000] of longint;
Var     d:mat;
        a:array [1..1000,1..1000] of char;
        free:array [1..1000,1..1000] of boolean;
        n,m,res,f,r,x1,y1,x2,y2:longint;
        qx,qy:array [1..1000000] of longint;
        s:string;
        fi,fo:text;

Procedure Doc;
        Var i,j:longint;
        Begin
                Readln(fi,m,n);
                For i:=1 to m do
                 Begin
                        Readln(fi,s);
                        For j:=1 to n do
                          Begin
                            a[i,j]:=s[j];
                            If s[j]='I' then
                             Begin
                                x1:=i;
                                y1:=j;
                             end
                            else If s[j]='O' then
                             Begin
                                x2:=i;
                                y2:=j;
                             end;
                          end;
                 end;
        end;

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

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

Procedure Bfs;
        Var i,x,y,u,v,j:longint;
        Begin
                f:=1;
                r:=0;
                Fillchar(free,sizeof(free),true);
                For i:=1 to m do
                 For j:=1 to n do
                  If a[i,j]='D' then
                    Begin
                        free[i,j]:=false;
                        Push(i,j);
                    end;
                While f<=r do
                 Begin
                        Pop(x,y);
                        For i:=1 to 4 do
                         Begin
                             u:=x+dong[i];
                             v:=y+cot[i];
                             If (u>=1) and (u<=m) and (v>=1) and (v<=n) then
                              If free[u,v] then
                              Begin
                               d[u,v]:=d[x,y]+1;
                               free[u,v]:=false;
                               Push(u,v);
                              end;
                         end;
                 end;
        end;

Function Check(mid:longint):boolean;
        Var i,u,v,x,y:longint;
        Begin
                f:=1;
                r:=0;
                Fillchar(free,sizeof(free),true);
                Push(x1,y1);
                free[x1,y1]:=false;
                While f<=r do
                 Begin
                        Pop(x,y);
                        If (x=x2) and (y=y2) then exit(true);
                        For i:=1 to 4 do
                         Begin
                            u:=x+dong[i];
                            v:=y+cot[i];
                            If (u>=1) and (u<=m) and (v>=1) and (v<=n) then
                            If (free[u,v]) and (d[u,v]>=mid) then
                             Begin
                                free[u,v]:=false;
                                Push(u,v);
                             end;
                         end;
                 end;
                exit(false);
        end;

Procedure Lam;
        Var l,r,mid:longint;
        Begin
                Bfs;
                l:=0;
                r:=2000;
                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.