Cod sursa(job #212785)

Utilizator antoanelaAntoanela Siminiuc antoanela Data 6 octombrie 2008 20:43:36
Problema Barbar Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 2.36 kb
var f,g:Text;
    ls,cs:array[0..100000000]of integer;
    a:array[0..1000,0..1000]of char;
    v,d:array[0..1000,0..1000]of longint;
    v1:array[1..4]of shortint=(0,0,-1,1);
    v2:array[1..4]of shortint=(-1,1,0,0);
    r,h,i,j,le,ce,lb,cb,m:longint;

procedure bfs1;
var p,l,c:longint;
begin
  p:=1;
  while (p<=h)do
    begin
      for i:=1 to 4 do
        begin
          l:=ls[p]+v1[i];
          c:=cs[p]+v2[i];
          if (l>0)and(l<=r)and(c>0)and(c<=m)and(a[l,c]<>'*')and(a[l,c]<>'D')and(v[l,c]=0)then
            begin
              inc(h);
              ls[h]:=l;
              cs[h]:=c;
              v[l,c]:=v[ls[p],cs[p]]+1;
            end;
        end;
      inc(p);
    end;
end;

function min(a,b:longint):longint;
begin
  min:=a;
  if (b<a)then min:=b;
end;

function max(a,b:longint):longint;
begin
  max:=a;
  if (b>a)then max:=b;
end;

procedure bfs2;
var p,l,c,k:longint;
begin
  h:=1;
  ls[1]:=lb;
  cs[1]:=cb;
  d[lb,cb]:=v[lb,cb];
  p:=1;
  while (p<=h)do
    begin
      for i:=1 to 4 do
        begin
          l:=ls[p]+v1[i];
          c:=cs[p]+v2[i];
          if (l>0)and(l<=r)and(c>0)and(c<=m)and(a[l,c]<>'*')and(a[l,c]<>'D')then
            begin
              k:=min(v[l,c],d[ls[p],cs[p]]);
              if (d[l,c]<k)then
                begin
                  inc(h);
                  ls[h]:=l;
                  cs[h]:=c;
                  d[l,c]:=k;
                end;
            end;
        end;
      inc(p);
    end;
end;


begin
assign(f,'barbar.in');
assign(g,'barbar.out');
reset(f);
rewrite(g);
readln(f,r,m);
for i:=1 to r do
  begin
    for j:=1 to m do
      begin
        read(f,a[i,j]);
        if (a[i,j]='D')then
          begin
            inc(h);
            ls[h]:=i;
            cs[h]:=j;
          end else
        if (a[i,j]='*')then v[i,j]:=-1 else
        if (a[i,j]='I')then
          begin
            lb:=i;
             cb:=j;
          end else
        if (a[i,j]='0')then
          begin
            le:=i;
            ce:=j;
           end;
      end;
    readln(f);
  end;
bfs1;
{for i:=1 to r do
  begin
    for j:=1 to m do write(G,v[i,j], ' ');
    writeln(g);
  end;}
bfs2;
{for i:=1 to r do
  begin
    for j:=1 to m do write(G,d[i,j], ' ');
    writeln(g);
  end;    }
write(g,d[le,ce]);
close(f);
close(g);
end.