Cod sursa(job #1539009)

Utilizator TheMastermindThe Mastermind TheMastermind Data 30 noiembrie 2015 04:26:22
Problema Barbar Scor 90
Compilator fpc Status done
Runda Arhiva de probleme Marime 2.6 kb
{$H+}
const
  tfi = 'barbar.in';
  tfo = 'barbar.out';
  oo = maxlongint;
  d : array[1..4] of longint = (-1,0,0,1);
  c : array[1..4] of longint = (0,-1,1,0);
var
  fi,fo : text;
  n,m,dx,dy,res,f,l : longint;
  dd : array[1..1000,1..1000] of boolean;
  g : array[1..1000,1..1000] of longint;
  qx,qy : array[1..1000000] of longint;
  st : array[1..1000] of string;
procedure input;
  var i : longint;
  begin
    readln(fi,n,m);
    for i:=1 to n do readln(fi,st[i]);
  end;
procedure push(i,j : longint);
  begin
    inc(l);
    qx[l]:=i;
    qy[l]:=j;
  end;
procedure pop(var i,j : longint);
  begin
    i:=qx[f];
    j:=qy[f];
    inc(F);
  end;
procedure bfs;
  var i,j,i1,j1,k : longint;
  begin
    f:=1;l:=0;
    for i:=1 to n do
      for j:=1 to m do
        if st[i,j]<>'*' then
          if st[i,j]='D' then push(i,j)
          else g[i,j]:=oo;
    while f<=l do
      begin
        pop(i,j);
        for k:=1 to 4 do
          begin
            i1:=i+d[k];
            j1:=j+c[k];
            if (i1>0) and (j1>0) and (i1<=n) and (j1<=m) and (st[i,j]<>'*') then
              if g[i1,j1]=oo then
                begin
                  g[i1,j1]:=g[i,j]+1;
                  push(i1,j1);
                end;
          end;
      end;
  end;
function check(x : longint) : boolean;
  var i,j,i1,j1,k : longint;
  begin
    fillchar(dd,sizeof(dd),false);
    f:=1;l:=0;
    push(dx,dy);
    dd[dx,dy]:=true;
    while f<=l do
      begin
        pop(i,j);
        if st[i,j]='O' then exit(true);
        for k:=1 to 4 do
          begin
            i1:=i+d[k];
            j1:=j+c[k];
            if (i1>0) and (j1>0) and (i1<=n) and (j1<=m) and (st[i,j]<>'*') then
              if (g[i1,j1]>=x) and (dd[i1,j1]=false) then
                begin
                  dd[i1,j1]:=true;
                  push(i1,j1);
                end;
          end;
      end;
    exit(false);
  end;
procedure work;
  var i,j,mid,l,r : longint;
  begin
    bfs;
    for i:=1 to n do
      for j:=1 to m do
        begin
          if st[i,j]='I' then
            begin
              dx:=i;dy:=j;
            end;
          if (st[i,j]<>'*') and (g[i,j]=oo) then g[i,j]:=0;
        end;
    res:=-1;
    l:=1;r:=n*m;
    while l<=r do
      begin
        mid:=(l+r) div 2;
        if check(mid) then
          begin
            l:=mid+1;
            res:=mid;
          end
        else r:=mid-1;
      end;
    writeln(fo,res);
  end;
begin
  assign(fi,tfi);reset(fi);
  assign(fo,tfo);rewrite(fo);
    input;
    work;
  close(fi);close(fo);
end.