Cod sursa(job #825521)

Utilizator hungntnktpHungntnktp hungntnktp Data 29 noiembrie 2012 09:55:29
Problema Barbar Scor 80
Compilator fpc Status done
Runda Arhiva de probleme Marime 3.54 kb
{$h+}
CONST
        tfi     ='barbar.in';
        tfo     ='barbar.out';
        nmax    =1000;
        h       :array [1..4] of longint =(0,1,0,-1);
        c       :array [1..4] of longint =(1,0,-1,0);
TYPE
        arr     =array [1..nmax] of string;
        arr1    =array [1..nmax*nmax] of longint;
        arr2    =array [1..nmax,1..nmax] of longint;
VAR
        fi,fo   :text;
        s       :arr;
        qx,qy   :arr1;
        d,free  :arr2;
        m,n,r,f,u,v,res,p,q,b,t:longint;
 (*********************************************************************)
Procedure nhap;
      Var
        i       :longint;
        ch      :char;
      Begin
        assign(fi,tfi);reset(fi);
          readln(fi,m,n);
          for i:=1 to m do readln(fi,s[i]);
        close(fi);
      End;
 (***********************************************************************)
Procedure push(x,y:longint);
      Begin
        inc(r);
        qx[r]:=x;
        qy[r]:=y;
      End;
 (*********************************************************************)
Procedure pop;
      Begin
        u:=qx[f];
        v:=qy[f];
        inc(f);
      End;
 (********************************************************************)
Procedure khoitao;
      Var
        i,j     :longint;
      Begin
        for i:=1 to m do
          for j:=1 to n do
            if s[i,j]='D' then push(i,j)
            else if s[i,j]='I' then
              begin
                p:=i;
                q:=j;
              end
            else if s[i,j]='O' then
              begin
                b:=i;
                t:=j;
              end;
        f:=1;
        while f<=r do
          begin
            pop;
            for i:=1 to 4 do
              if (u+h[i]<=m) and (u+h[i]>=1) and (v+c[i]<=n)
              and (v+c[i]>=1) and (d[u+h[i],v+c[i]]=0) and (s[u+h[i],v+c[i]]<>'D') then
                begin
                  push(u+h[i],v+c[i]);
                  d[u+h[i],v+c[i]]:=d[u,v]+1;
                end;
          end;
      End;
 (**********************************************************************)
Function check(x:longint):boolean;
      Var
        i,j     :longint;
      Begin
        r:=0;f:=1;
        push(p,q);
        if d[p,q]<x then exit(false);
        free[p,q]:=x;
        while f<=r do
          begin
            pop;
            for i:=1 to 4 do
              if (u+h[i]<=m) and (u+h[i]>=1) and (v+c[i]<=n)
              and (v+c[i]>=1) and (d[u+h[i],v+c[i]]>=x)
              and (free[u+h[i],v+c[i]]<>x) and (s[u+h[i],v+c[i]]<>'*') then
                begin
                  push(u+h[i],v+c[i]);
                  free[u+h[i],v+c[i]]:=x;
                end;
            if free[b,t]=x then exit(true);
          end;
        exit(false);
      End;
 (***********************************************************************)
Procedure find;
      Var
        l,r,mid :longint;
      Begin
        l:=0;r:=n+m;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
        assign(fo,tfo);rewrite(fo);
          write(fo,res);
        close(fo);
      End;
 (***********************************************************************)
BEGIN
        nhap;
        khoitao;
        find;
        inkq;
END.