Cod sursa(job #825317)

Utilizator hungntnktpHungntnktp hungntnktp Data 28 noiembrie 2012 15:17:12
Problema Barbar Scor 80
Compilator fpc Status done
Runda Arhiva de probleme Marime 3.86 kb
const
        tfi     =       'barbar.in';
        tfo     =       'barbar.out';
        Nmax    =       1001;
        dong    :       array[1..4] of longint = (-1,1,0,0) ;
        cot     :       array[1..4] of longint = (0,0,-1,1) ;
type
        node    =       record
                x,y:longint;
                end;
        arr1    =       array[0..Nmax,0..Nmax] of longint ;
var
        fi,fo   :       text;
        n,m,f,r,nho,res     :       longint;
        a,d,dd       :       arr1 ;
        q       :       array[0..Nmax*Nmax] of node ;
        s:node;
procedure Nhap;
var
        i,j :longint;
        c:char;
begin
        readln(fi,m,n) ;
        for i := 1 to m do
        begin
                for j := 1 to n do
                  begin
                        read(fi,c);
                        case c of
                                '.' : a[i,j] := 1;
                                '*' : a[i,j] := 2;
                                'D' : a[i,j] := 3;
                                'I' :
                                 begin
                                  a[i,j] := 4;
                                  s.x := i ;
                                  s.y := j ;
                                 end  ;
                                'O' : a[i,j] := 5;
                        end;
                  end;
                 readln(fi);
        end;
end;
procedure Push(x,y:longint) ;
begin
        inc(r);
        q[r].x := x;
        q[r].y := y;
end;
function Pop :node;
begin
        pop := q[f];
        inc(f) ;
end;
procedure init;
var
         i,j,u,v: longint;
         x:node;
begin
        f := 1;
        r := 0;
         for i := 1 to m do
        for j := 1 to n do if a[i,j] = 3 then
         begin
                d[i,j] := 1;
                Push(i,j) ;
         end;
         while f <= r do
          begin
               x := pop ;
            //   writeln(x.x,' ',x.y,' ',d[x.x,x.y]);
               for i := 1 to 4 do
                begin
                        u := x.x + dong[i];
                        v := x.y + cot[i];
                        if (a[u,v] > 0) and (d[u,v] = 0) then
                         begin
                              d[u,v] := d[x.x,x.y] + 1 ;
                              Push(u,v) ;
                         end ;
                end ;
              dec(d[x.x,x.y]) ;
          end;
end;
function Check(y :longint) :boolean;
var
        i,u,v : longint ;
        x:node;
begin
        inc(nho) ;
        f := 1;
        r := 0;
        dd[s.x,s.y] := nho ;
        Push(s.x,s.y) ;
        while f <= r do
         begin
                x := pop ;
                if a[x.x,x.y] = 5 then
                 exit(true) ;
                for i := 1 to 4 do
                 begin
                        u := x.x + dong[i];
                        v := x.y + cot[i];
                        if (a[u,v] > 0) and (a[u,v] <> 2) and (dd[u,v] < nho) and (d[u,v] >= y) then
                         begin
                           dd[u,v] := nho ;
                           Push(u,v) ;
                         end;
                 end;
         end ;
        exit(false) ;
end;
procedure xuly;
var
        l,r,mid: longint;
begin
        res := -1;
        l := 0;
        r := d[s.x,s.y] ;
        while l  <= r do
         begin
                mid := (l + r) shr 1;
                if check(mid) then
                 begin
                     res := mid ;
                     l := mid + 1;
                  end else r := mid - 1;
         end ;
end ;
procedure inkq;
begin
        write(fo,res) ;
end;
begin
        assign(fi,tfi);reset(fi);
        assign(fo,tfo);rewrite(fo);
                   Nhap;
                   init;
                   xuly;
                   inkq;
        close(fi);
        close(fo) ;
end.