Cod sursa(job #1538995)

Utilizator hinuNguyen Thu Hien hinu Data 30 noiembrie 2015 04:07:52
Problema Barbar Scor 100
Compilator fpc Status done
Runda Arhiva de probleme Marime 3.27 kb
{$H+}
CONST
    tfi='barbar.in';
    tfo='barbar.out';
    dd : array[1..4] of longint = (0,-1,0,1);
    cc : array[1..4] of longint = (1,0,-1,0);
VAR
    r,c,x1,x2,y1,y2 : longint;
    st : string;
    a : array[1..1000,1..1000] of longint;
    q,q1 : array[1..10000000] of longint;
    d : array[1..1000,1..1000] of longint;
    free : array[1..1000,1..1000] of boolean;
    fre : array[1..1000,1..1000] of longint;
procedure nhap;
    var i,j : longint;
    begin
        readln(r,c);
        for i:=1 to r do
          begin
            readln(st);
            for j:=1 to c do
              if st[j] = 'D' then a[i,j]:=1
              else if st[j] = '*' then a[i,j]:=2
              else if st[j] = 'I' then
                begin
                  a[i,j]:=3;
                  x1:=i; y1:=j;
                end
              else if st[j] = 'O' then
                begin
                  a[i,j]:=4;
                  x2:=i; y2:=j;
                end;
          end;

    end;

procedure bfs;
    var i,j,u,v,ll,rr,ii,jj:longint;
    begin
        ll:=1; rr:=0;
        for i:=1 to r do
          for j:=1 to c do
            begin
              d[i,j]:=1000000;
              free[i,j]:=true;
            end;
        for i:=1 to r do
          for j:=1 to c do
            if a[i,j] = 1 then
              begin
                inc(rr);
                q[rr]:=i;
                q1[rr]:=j;
                free[i,j]:=false;
                d[i,j]:=0;
              end;

        while ll <= rr do
          begin
            u:=q[ll]; v:=q1[ll];
            inc(ll);
            for i:=1 to 4 do
              begin
                ii:=u + dd[i];
                jj:=v + cc[i];
                if (ii >=1) and (ii <= r) and (jj >=1) and (jj <= c) then
                  if free[ii,jj] and (a[ii,jj] <> 1) and (a[ii,jj] <> 2) then
                    begin
                      d[ii,jj]:=d[u,v] + 1;
                      inc(rr); q[rr]:=ii; q1[rr]:=jj;
                      free[ii,jj]:=false;
                    end;
              end;
          end;

    end;
function dfs(u,v,mid : longint) : boolean;
    var i,ii,jj : longint;
    begin
        if (u = x2) and (v = y2) then exit(true);
        fre[u,v]:=mid;
        for i:=1 to 4 do
          begin
            ii:=u + dd[i]; jj:=v + cc[i];
            if (ii >=1) and (ii <= r) and (jj >=1) and (jj <= c) then
              if (a[ii,jj] <> 2) and (a[ii,jj] <> 1) and (fre[ii,jj] <> mid) and (d[ii,jj] >= mid) then
                if dfs(ii,jj,mid) then exit(true);
          end;
        exit(false);
    end;
function check(mid : longint) : boolean;
    begin
        if dfs(x1,y1,mid) then exit(true) else exit(false);

    end;
procedure main;
    var ll,rr,mid,kq : longint;
    begin
        bfs;
        ll:=1; rr:=d[x1,y1]; kq:=-1;
        while ll <= rr do
          begin
            mid:=(ll+rr) div 2;
            if check(mid) then
              begin
                kq:=mid;
                ll:=mid + 1;
              end
            else rr:=mid -1;
          end;
        writeln(kq);
    end;
BEGIN
    assign(input,tfi); reset(input);
    assign(output,tfo); rewrite(output);
        nhap;
        main;
    close(input); close(output);
END.