Cod sursa(job #1537398)

Utilizator hungntnktpHungntnktp hungntnktp Data 27 noiembrie 2015 10:50:23
Problema Barbar Scor 100
Compilator fpc Status done
Runda Arhiva de probleme Marime 4.45 kb
{$~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
{$H+}
{$~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
uses math;
{$~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
const
   tfi='barbar.in';
   tfo='barbar.out';
  maxn=trunc(1e3);
    oo=trunc(1e9);
     c:array[1..4] of longint=(1,0,-1,0);
     d:array[1..4] of longint=(0,1,0,-1);
{$~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
var                   fi,fo:text;
     n,m,f,r,kl,sx,sy,ex,ey:longint;
                  dd,free,a:array[1..maxn,1..maxn] of longint;
                      qx,qy:array[1..maxn*maxn] of longint;
                         tt:array[0..maxn,0..maxn] of boolean;
{$~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
procedure nhap;
   var i,j:longint;
        st:string;
      begin
         readln(fi,m,n);
         for j:=1 to m do
            begin
               readln(fi,st);
               for i:=1 to n do
                  case st[i] of
                     '.':a[i,j]:=0;
                     '*':a[i,j]:=1;
                     'I':a[i,j]:=2;
                     'D':a[i,j]:=3;
                     'O':a[i,j]:=4;
                  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,x1,y1,x,y:longint;
      begin
         while f<=r do
            begin
               pop(x,y);
               for i:=1 to 4 do
                  begin
                     x1:=x+c[i];
                     y1:=y+d[i];
                     if tt[x1,y1] and (dd[x1,y1]>dd[x,y]+1) then
                        begin
                           dd[x1,y1]:=dd[x,y]+1;
                           push(x1,y1);
                        end;
                  end;
            end;
      end;
{$~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
procedure khoitao;
   var i,j:longint;
      begin
         f:=1;
         r:=0;
         for i:=1 to n do
         for j:=1 to m do dd[i,j]:=oo;
         for i:=1 to n do
         for j:=1 to m do
            begin
               if a[i,j]=2 then
                  begin
                     sx:=i;
                     sy:=j;
                  end;
               if a[i,j]=3 then
                  begin
                     push(i,j);
                     dd[i,j]:=0;
                  end;
               if a[i,j]<>1 then tt[i,j]:=true;
               if a[i,j]=4 then
                  begin
                     ex:=i;
                     ey:=j;
                  end;
            end;
         bfs;
      end;
{$~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
procedure dfs(x,y,hp:longint);
   var i,x1,y1:longint;
      begin
         free[x,y]:=kl;
         for i:=1 to 4 do
            begin
               x1:=x+c[i];
               y1:=y+d[i];
               if (tt[x1,y1]) and (dd[x1,y1]>=hp) and (free[x1,y1]<>kl) then dfs(x1,y1,hp);
            end;
      end;
{$~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
function kt(x:longint):boolean;
   var i:longint;
      begin
         if dd[sx,sy]<x then exit(false);
         inc(kl);
         dfs(sx,sy,x);
         if free[ex,ey]=kl then exit(true) else exit(false);
      end;
{$~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
procedure xuly;
   var l,r,mid,kq:longint;
      begin
         l:=1;
         r:=n+m;
         kq:=-1;
         while l<=r do
            begin
               mid:=(l+r) div 2;
               if kt(mid) then
                  begin
                     l:=mid+1;
                     kq:=mid;
                  end else r:=mid-1;
            end;
         writeln(fo,kq);
      end;
{$~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
BEGIN
   assign(fi,tfi);reset(fi);
   assign(fo,tfo);rewrite(fo);
   nhap;
   khoitao;
   xuly;
   close(fi);close(fo);
END.
{$~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}