Cod sursa(job #1538965)

Utilizator TheMastermindThe Mastermind TheMastermind Data 30 noiembrie 2015 03:05:14
Problema Barbar Scor 100
Compilator fpc Status done
Runda Arhiva de probleme Marime 3.41 kb
USES Math;
CONST
    tfi = 'barbar.in';
    tfo = 'barbar.out';
    d: array[1..4] of longint = (-1,1,0,0);
    c: array[1..4] of longint = (0,0,-1,1);
VAR
    fi,fo                           : text;
    n,m,sx,sy,ex,ey,l,r,mid,ct      : longint;
    q,q1                            : array[0..1000000] of longint;
    a,dd,g                          : array[0..1001,0..1001] of longint;
    free,ins                        : array[0..1001,0..1001] of boolean;

Procedure push(x,y: longint);
    Begin
        inc(r);
        q[r]:=x; q1[r]:=y;
    End;

Procedure pop(var x,y: longint);
    Begin
        x:=q[l]; y:=q1[l];
        inc(l);
    End;

Procedure inp;
    Var
        i,j: longint;
        ch: char;
    Begin
        Read(fi,n,m);
        l:=1; r:=0;
        For i:=1 to n do
            begin
                For j:=1 to m do
                    begin
                        read(fi,ch);
                        case ch of
                            'I':
                                begin
                                    sx:=i; sy:=j;
                                end;
                            'O':
                                begin
                                    ex:=i; ey:=j;
                                end;
                            'D':
                                begin
                                    a[i,j]:=1;
                                    push(i,j);
                                end;
                            '*': a[i,j]:=1;
                        end;
                    end;
                readln(fi);
            end;
    End;

Procedure BFS;
    Var
        i,j,u,v,x,y,k: longint;
    Begin
        For i:=1 to n do
            For j:=1 to m do
                begin
                    free[i,j]:=true;
                    ins[i,j]:=true;
                end;
        While l<=r do
            begin
                pop(u,v);
                For k:=1 to 4 do
                    begin
                        x:=u+d[k]; y:=v+c[k];
                        If ins[x,y] and free[x,y] and (a[x,y]=0) then
                            begin
                                dd[x,y]:=dd[u,v]+1;
                                push(x,y);
                                free[x,y]:=false;
                            end;
                    end;
            end;
    End;

Function visit(u,v: longint): boolean;
    Var
        x,y,k: longint;
    Begin
        If (u=ex) and (v=ey) then exit(true);
        g[u,v]:=ct;
        For k:=1 to 4 do
            begin
                x:=u+d[k]; y:=v+c[k];
                If ins[x,y] and (g[x,y]<>ct) and (dd[x,y]>=mid) and (a[x,y]=0) and visit(x,y) then exit(true);
            end;
        exit(false);
    End;

Procedure process;
    Var
        le,ri,res: longint;
    Begin
        BFS;
        res:=-1;
        le:=1;
        ri:=dd[sx,sy];
        ct:=0;
        While le<=ri do
            begin
                mid:=(le+ri) div 2;
                inc(ct);
                If visit(sx,sy) then
                    begin
                        res:=mid;
                        le:=mid+1;
                    end
                else ri:=mid-1;
            end;
        write(fo,res);
    End;


BEGIN
    assign(fi,tfi); reset(fi);
    assign(fo,tfo); rewrite(fo);
        inp;
        process;
    close(fi); close(fo);
END.