Cod sursa(job #42766)

Utilizator andradaqAndrada Georgescu andradaq Data 29 martie 2007 15:10:33
Problema Barbar Scor 100
Compilator fpc Status done
Runda Arhiva de probleme Marime 2.45 kb
type pct=record x,y:integer end;
     pnod=^nod;
     nod=record
     x,y:integer;
     leG:pnod;
     end;
const ix:array[1..4] of -1..1=(-1,1,0,0);
      iy:array[1..4] of -1..1=(0,0,-1,1);
var mij,r,c,i,j,k,nx,ny,inf,sup,sol:integer;
    a:array[1..1000,1..1000] of integer;
    viz:array[1..1000,1..1000] of boolean;
    f:text;
    q,nou,ultim:pnod;
    pin,pout:pct;
    ch:char;

function bf(dmin:integer):boolean;
begin
bf:=false;
new(Q); q^.x:=pin.x; q^.y:=pin.y; q^.leg:=nil;ultim:=q;
fillchar(viz,sizeof(viz),false);
viz[q^.x,q^.y]:=true;
while q<>nil do
 begin
 for k:=1 to 4 do
  begin
  nx:=q^.x+ix[k];
  ny:=q^.y+iy[k];
  if (0<nx)and(0<ny)and(nx<=r)and(ny<=c)and(not viz[nx,ny])and
   (a[nx,ny]>=dmin) then
    begin
    new(nou);
    nou^.x:=nx;
    nou^.y:=ny;
    nou^.leg:=nil;
    ultim^.leg:=nou;
    ultim:=nou;
    viz[nx,ny]:=true;
    if (nx=pout.x)and(ny=pout.y) then
     begin
     bf:=true;
     exit;
     end;
    end;
   end;
  nou:=q; q:=q^.leg; dispose(nou);
  end;
end;

begin
assign(f,'barbar.in'); reset(F);
readln(f,r,c);
for i:=1to r do
 begin
 for j:=1 to c do
   begin
   read(f,ch);
   if ch='*' then a[i,j]:=-1
   else
   if ch='I' then
     begin
     pin.x:=i;
     pin.y:=j;
     a[i,j]:=maxint
     end
   else if ch='O' then
      begin
      pout.x:=i;
      pout.y:=j;
      a[i,j]:=maxint
      end
   else
   if ch='D' then
    if q=nil then
      begin
      new(Q);
      q^.x:=i;
      q^.y:=j;
      q^.leg:=nil;
      ultim:=q;
      end
      else
      begin
      new(nou);
      nou^.x:=i;
      nou^.y:=j;
      nou^.leg:=nil;
      ultim^.leg:=nou;
      ultim:=nou;
      end else a[i,j]:=maxint;
end;
readln(F);
end;
close(F);sup:=0;
while q<>nil do
 begin
  for k:=1 to 4 do
   begin
   nx:=q^.x+ix[k];
   ny:=q^.y+iy[k];
   if (nx>0)and(nx<=r)and(ny>0)and(ny<=c)then
     if (a[nx,ny]<>-1)and(a[nx,ny]>a[q^.x,q^.y]+1) then
      begin
      new(nou);
      nou^.x:=nx;
      nou^.y:=ny;
      nou^.leg:=nil;
      ultim^.leg:=nou;
      ultim:=nou;
      a[nx,ny]:=a[q^.x,q^.y]+1;
      end;
  end;
 nou:=q; q:=q^.leg; dispose(nou);
 end;
inf:=1;sup:=a[pin.x,pin.y];
assign(f,'barbar.out'); rewrite(F);
if not bf(0) then writeln(f,-1) else
 begin
 while inf<=sup do
  begin
  mij:=(inf+sup)shr 1;
  if bf(mij) then begin sol:=mij ;inf:=mij+1; end
     else sup:=mij-1;
  end;
 writeln(f,sol);
 end;
closE(f);
end.