Cod sursa(job #825520)

Utilizator hungntnktpHungntnktp hungntnktp Data 29 noiembrie 2012 09:55:00
Problema Barbar Scor 80
Compilator fpc Status done
Runda Arhiva de probleme Marime 4.23 kb
{$H+}
Const
        tfi     =       'barbar.in';
        tfo     =       'barbar.out';
        nmax    =       1001;
        d       :       array [1..4] of longint = (1,-1,0,0);
        c       :       array [1..4] of longint = (0,0,1,-1);
Type
        arr1    =       array [0..nmax] of string;
        arr2    =       array [0..nmax,0..nmax] of boolean;
        arr3    =       array [0..nmax*nmax] of longint;
        arr4    =       array [0..nmax,0..nmax] of longint;
Var
        fi,fo   :       text;
        m,n,f,r,res     :       longint;
        s       :       arr1;
        dd      :       arr2;
        qx,qy   :       arr3;
        kc,g    :       arr4;
        sx,sy,ex,ey     :       longint;
Procedure mo;
  Begin
        assign(fi,tfi);reset(fi);
        assign(fo,tfo);rewrite(fo);
  End;
Procedure dong;
  begin
        close(fi);
        close(fo);
  End;
procedure nhap;
  Var
        i,j     :       longint;
  Begin
        readln(fi,m,n);
        For i:=1 to m do readln(fi,s[i]);
  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 init;
  Var
        i,j     :       longint;
  Begin
        f:=1;
        r:=0;
        For i:=1 to m do
          For j:=1 to n do
            Begin
                   If s[i,j]='I' then
                     Begin
                            sx:=i;
                            sy:=j;
                     End;
                   If s[i,j]='O' then
                     Begin
                            ex:=i;
                            ey:=j;
                     End;
                   dd[i,j]:=true;
                   If s[i,j]='D' then
                     Begin
                            push(i,j);
                            dd[i,j]:=false;
                     End;
            End;
  End;
Procedure bfs;
  var
        i,j,x,y,u,v     :       longint;
  begin
        While f<=r do
          begin
                 pop(u,v);
                 For i:=1 to 4 do
                   Begin
                          x:=u+d[i];
                          y:=v+c[i];
                          if (x>=1) and (y>=1) and (x<=m) and (y<=n) and (dd[x,y]) then
                            Begin
                                   kc[x,y]:=kc[u,v]+1;
                                   dd[x,y]:=false;
                                   push(x,y);
                            End;
                   End;
          End;
  End;
Function check(mid:longint):boolean;
  Var
        i,j,u,v,x,y     :       longint;
  Begin
        f:=1;
        r:=0;
        For i:=1 to m do
          For j:=1 to n do
            begin
                   dd[i,j]:=true;
                   g[i,j]:=0;
            End;
        push(sx,sy);
        dd[sx,sy]:=false;
        While f<=r do
          Begin
                 pop(u,v);
                 For i:=1 to 4 do
                   Begin
                          x:=u+d[i];
                          y:=v+c[i];
                          If (x>=1) and (y>=1) and (x<=m) and (y<=n) then
                            begin
                                   If (s[x,y]<>'*') and (dd[x,y]) and (kc[x,y]>=mid) then
                                     begin
                                            g[x,y]:=g[u,v]+1;
                                            dd[x,y]:=false;
                                            push(x,y);
                                     End;
                            End;
                   End;
          End;
        If g[ex,ey]<>0 then exit(true)
        else exit(false);
  End;
Procedure inkq;
  Var
        l,r,mid :       longint;
  begin
        l:=0;
        r:=m+n;
		res :=-1;
        While l<=r do
          begin
                 mid:=(l+r) shr 1;
                 If check(mid) then
                   Begin
                          res:=mid;
                          l:=mid+1;
                   End
                 else r:=mid-1;
          End;
        writeln(fo,res);
  End;
BEGIN
        mo;
        nhap;
        init;
        bfs;
        inkq;
        dong;
END.