Cod sursa(job #825509)

Utilizator hungntnktpHungntnktp hungntnktp Data 29 noiembrie 2012 09:48:21
Problema Barbar Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 5.21 kb
{$h+}
USES
        math;
CONST
        TFI     =       'barbar,in';
        TFO     =       'barbar.out';
        k       :       array[1..4] of longint = (1,-1,0,0);
        l       :       array[1..4] of longint = (0, 0 ,1 ,-1);

VAR
        N,M,s1,s2,t1,t2,phai,nh     :       longint;
        qx,qy,h,h1   :       array[1..1000000] of longint;
        a,d,cs,g      :       array[0..1010,0..1010] of longint;
        dd      :     array[0..1001,0..1001] of boolean;
        fi,fo   :       text;
{**************************************************************************}
Procedure nhap;
  Var
        i,j     :       longint;
        s       :       string;
  Begin
        Assign(fi,tfi); reset(fi);
                readln(fi,m,n);
                for i:=1 to m do
                        for j:=1 to n do dd[i,j]:=true;
                for i:=1 to m do
                  begin
                        readln(fi,s);
                        for j:=1 to n do
                        if s[j]='*' then a[i,j]:=-1
                        else if s[j]='D' then a[i,j]:=1
                        else if s[j]='I' then begin s1:=i; s2:=j; end
                        else if s[j]='O' then begin t1:=i; t2:=j; end;
                  end;
        close(fi);
  End;
{**************************************************************************}
Procedure init;
  Var
        i,j     :       longint;
  begin
        for i:=0 to m+1 do
                for j:=0 to n+1 do d[i,j]:=2000000;
        for i:=1 to m do
          for j:=1 to n do
                if a[i,j]=1 then d[i,j]:=0 else d[i,j]:=min(d[i,j],min(d[i-1,j],d[i,j-1])+1);
        for i:=1 to m do
          for j:=n downto 1 do
                if a[i,j]=1 then d[i,j]:=0 else d[i,j]:=min(d[i,j],min(d[i-1,j],d[i,j+1])+1);

        for i:=m downto 1 do
          for j:=1 to n do
                if a[i,j]=1 then d[i,j]:=0 else d[i,j]:=min(d[i,j],min(d[i+1,j],d[i,j-1])+1);
        for i:=m downto 1 do
          for j:=n downto 1 do
            if a[i,j]=1 then d[i,j]:=0 else d[i,j]:=min(d[i,j],min(d[i+1,j],d[i,j+1])+1);
  End;
{**************************************************************************}
Procedure doicho(var a,b:longint);
  VAr
        tg      :       longint;
  BEgin
        tg:=a;
        a:=b;
        b:=tg;
  End;
{********************************************************************}
Procedure Upheap(i:longint);
  BEgin
        If (i=1) or (d[h[i div 2],h1[i div 2]]>=d[h[i],h1[i]]) then exit;
        doicho(h[i], h[i div 2]);
        doicho(h1[i], h1[i div 2]);
        doicho(cs[h[i],h1[i]],cs[h[i div 2],h1[i div 2]]);
        upheap( i div 2);
  End;
{********************************************************************}

Procedure downheap(I:LONGINT);
  Var
        j       :       longint;
  BEgin
        j:=i*2;
        if j>nh then exit;
        If d[h[j],h1[j]]<d[h[j+1],h1[j+1]] then inc(j);
        If d[h[i],h1[i]]<d[h[j],h1[j]] then
                begin
                        doicho(h[i],h[j]);
                        doicho(h1[i],h1[j]);
                        doicho(cs[h[i],h1[i]],cs[h[j],h1[j]]);
                        downheap(j);
                end;
  End;
{********************************************************************}
Procedure push(x,y:longint);
  Begin
        inc(nh);
        h[nh]:=x; h1[nh]:=y;
        cs[x,y]:=nh;
        upheap(nh);
  End;
{********************************************************************}

Procedure pop(var u,v:longint);
  Begin
        u:=h[1]; v:=h1[1];
        h[1]:=h[nh]; h1[1]:=h1[nh];
        cs[h[1],h1[1]]:=1;
        dec(nh);
        downheap(1);
  End;
{********************************************************************}
Procedure update(x,y:longint);
  VAr
        i       :       longint;
  Begin
        If cs[x,y]=0 then push(x,y)
        else upheap(cs[x,y]);
  End;
{**************************************************************************}
{**************************************************************************}
Procedure xuli;
  Var
        i,j ,x,y    :       longint;
  Begin
        init;  nh:=0;
        for i:=1 to m do
                for j:=1 to n do g[i,j]:=0;
        push(s1,s2); g[s1,s2]:=d[s1,s2];
        Repeat
                pop(x,y); dd[x,y]:=false;
                if (x=t1) and (y=t2) then break;
                for i:=1 to 4 do
                  begin
                    if dd[x+k[i],y+l[i]] and (a[x+k[i],y+l[i]]<>-1) and (g[x+k[i],y+l[i]]<min(d[x+k[i],y+l[i]],g[x,y])) then
                    begin
                        g[x+k[i],y+l[i]]:=min(d[x+k[i],y+l[i]],g[x,y]);
                        update(x+k[i],y+l[i]);
                    end;
                  end;
                  if nh=0 then exit;
        Until false;
  End;
{**************************************************************************}
procedure inkq;
  Begin
        assign(fo,tfo); rewrite(fo);
                if dd[t1,t2] then write(fo,-1) else write(fo,g[t1,t2]);
        close(fo);
  End;
{**************************************************************************}
{**************************************************************************}
BEGIN
        nhap;
        xuli;
        inkq;
END.