Cod sursa(job #249313)

Utilizator belgun_adrianBelgun Dimitri Adrian belgun_adrian Data 28 ianuarie 2009 00:10:44
Problema Barbar Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 3.25 kb
var r,c,iIN,jIN,iOUT,jOUT:integer;
    d,min,max,x:longint;
    a,uz:array[1..1000,1..1000] of shortint;
    dr,cd:array[1..10000000] of record i,j:integer; end;
    b:array[1..1000,1..1000] of longword;

const di:array[1..4] of shortint=(1,-1,0,0);
      dj:array[1..4] of shortint=(0,0,-1,1);

procedure citire;
        var f:text;
            i,j:integer;
            t:char;
        begin
        assign(f,'barbar.in');
        reset(f);
        readln(f,r,c);
        d:=0;
        for i:=1 to r do
            begin
            for j:=1 to c do
                begin
                read(f,t);
                case t of
                     '.': a[i,j]:=0;
                     '*': a[i,j]:=1;
                     'D': begin
                                a[i,j]:=-1;
                                inc(d);
                                dr[d].i:=i; dr[d].j:=j;
                          end;
                     'I': begin a[i,j]:=-2; iIN :=i; jIN :=j; end;
                     'O': begin a[i,j]:=-3; iOUT:=i; jOUT:=j; end;
                    end;
                end;
            readln(f);
            end;
        close(f);
        end;

procedure calculdist;
        var i,j,ii,jj,dist:integer;
            k:longint;
        begin
        for i:=1 to r do for j:=1 to c do b[i,j]:=2000000;
        for k:=1 to d do begin
            ii:=dr[k].i; jj:=dr[k].j;
            for i:=1 to r do begin
                dist:=abs(i-ii);
                if (dist<b[i,jj]) then
                     b[i,jj]:=dist;
                end;
            for j:=1 to c do begin
                dist:=abs(j-jj);
                if (dist<b[ii,j]) then
                     b[ii,j]:=dist;
                end;
            end;
        end;

procedure scrie(k:longint);
        var f:text;
        begin
        assign(f,'barbar.out');
        reset(f);

        close(f);
        end;

function bf(dist:longint):boolean;
        var i,j,p,u,ii,jj,k:integer;
            ok:boolean;
        begin
        for i:=1 to r do for j:=1 to c do uz[i,j]:=0;
        cd[1].i:=iIN;
        cd[1].j:=jIN;
        uz[iIN,jIN]:=1;
        p:=1;
        u:=1;
        ok:=false;
        while (p<=u) and (ok=false) do begin
              for k:=1 to 4 do begin
                  ii:=cd[p].i+di[k]; jj:=cd[p].j+dj[k];;
                  if (not ((ii<1) or (ii>r) or (jj<1) or (jj>c))) and
                   (uz[ii,jj]=0) and (a[ii,jj]<>1) and (b[ii,jj]>=dist) then
                    if (ii=iOUT) and (jj=jOUT) then begin
                       ok:=true;
                       break;
                       end
                    else
                        begin
                        inc(u);
                        cd[u].i:=ii;
                        cd[u].j:=jj;
                        uz[ii,jj]:=1;
                        end;
                  end;
              end;
        bf:=ok;
        end;

begin
citire;
calculdist;
if b[iIN,jIN]<b[iOUT,jOUT] then
   max:=b[iIN,jIN]
else
   max:=b[iOUT,jOUT];

min:=0;

if not bf(max) then
   scrie(-1)
else
   while (min<max) do begin
        x:=(min+max) div 2;
        if bf(x) then
           max:=x
        else
           min:=x;
        end;
scrie(min);
end.