PMG

uses Graph,Crt;

const
  Map: array[0..14,0..19] of integer =
  (
  (1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1),
  (1,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,1),
  (1,0,0,5,1,0,1,0,0,0,0,1,1,1,1,0,0,0,0,1),
  (1,1,1,1,1,0,1,0,1,1,1,1,0,0,0,0,1,0,0,1),
  (1,1,0,0,0,0,1,0,0,0,1,0,0,1,1,0,1,1,1,1),
  (1,1,0,1,1,1,1,0,0,1,1,0,0,0,0,0,0,0,0,1),
  (1,0,0,0,1,0,0,0,1,1,1,0,0,1,1,1,1,1,0,1),
  (1,0,0,0,1,0,0,0,1,0,0,0,0,1,0,0,0,1,0,1),
  (1,0,0,0,1,0,1,1,1,1,1,1,0,1,0,0,0,0,0,1),
  (1,1,1,0,1,0,1,0,0,0,0,1,0,1,0,0,1,1,1,1),
  (1,0,1,0,0,0,1,0,1,0,1,1,1,1,1,0,1,0,0,1),
  (1,0,1,0,0,0,1,6,1,0,1,0,0,0,1,0,0,0,0,1),
  (1,0,0,0,1,0,1,1,1,0,1,0,1,0,1,1,1,0,0,1),
  (1,0,0,0,1,0,0,0,1,0,0,0,1,0,0,0,0,0,0,1),
  (1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1)
  );

var
  grDriver: Integer;
  grMode: Integer;
  ErrCode: Integer;
  key: char;
  stx,sty,ex,ey:integer;
  Calc:array[0..14,0..19] of integer;

function IntToStr(I: Longint): String;
var
  S: string[11];
begin
  Str(I, S);
  IntToStr := S;
end;

procedure Calculation;
var i,j:integer;
    max:integer;
    findon:boolean;
begin
  setcolor(green);
  Calc[sty,stx]:=1;
  max:=1;
  findon:=false;
  while (findon=false) do
  begin
    for i:=0 to 14 do begin
    for j:=0 to 19 do begin
    if (Calc[i,j]=max) and (i=ey) and (j=ex) then findon:=true;
      if ((Calc[i,j]=max) and (findon=false)) then
      begin
      OutTextXY(round(GetMaxX/20*(j))+6,round(GetMaxY/15*(i))+6,IntToStr(max));
        if Calc[i+1,j]=0 then begin
          Calc[i+1,j]:=max+1;
        end;
        if Calc[i,j-1]=0 then begin
          Calc[i,j-1]:=max+1;
        end;
        if Calc[i-1,j]=0 then begin
          Calc[i-1,j]:=max+1;
        end;
        if Calc[i,j+1]=0 then begin
          Calc[i,j+1]:=max+1;
        end;
      end;
      end;
      end;
      max:=max+1;
      delay(7000);
  end;
end;

procedure Update(ox,oy,x,y:integer);
begin
  setcolor(black);
  Circle(round(GetMaxX/20*(ox))+16,round(GetMaxY/15*(oy))+16,14);
  setcolor(white);
  Circle(round(GetMaxX/20*(x))+16,round(GetMaxY/15*(y))+16,14);
end;

procedure MoveTo;
var i,j,max,x,y:integer;
begin
  max:=Calc[ey,ex];
  x:=ex; y:=ey;
  while max<>1 do begin
    if (Calc[y-1,x]=max-1) then begin
      Update(x,y,x,y-1);
      y:=y-1;
      max:=max-1;
      delay(5000);
    end;
    if (Calc[y,x-1]=max-1) then begin
      Update(x,y,x-1,y);
      x:=x-1;
      max:=max-1;
      delay(5000);
    end;
    if (Calc[y+1,x]=max-1) then begin
      Update(x,y,x,y+1);
      y:=y+1;
      max:=max-1;
      delay(5000);
    end;
    if (Calc[y,x+1]=max-1) then begin
      Update(x,y,x+1,y);
      x:=x+1;
      max:=max-1;
      delay(5000);
    end;
  end;
end;

procedure Grind(lx,ly:integer);
var i:integer;
begin
  for i:=0 to lx do begin
    line(round(GetMaxX/lx*i),0,round(GetMaxX/lx*i),GetMaxY);
  end;
  for i:=0 to ly do begin
    line(0,round(GetMaxY/ly*i),GetMaxX,round(GetMaxY/ly*i));
  end;
end;

procedure LoadMap;
var i,j:integer;
begin
  for i:=0 to 14 do begin
    for j:=0 to 19 do begin
      case Map[i,j] of
        0:Calc[i,j]:=0;
        1:begin
            Calc[i,j]:=-1;
            FloodFill(round(GetMaxX/20*(j))+1, round(GetMaxY/15*(i))+1, White);
        end;
        5:begin
            ex:=j; ey:=i;
            Circle(round(GetMaxX/20*(j))+16,round(GetMaxY/15*(i))+16,14);
        end;
        6:begin
            stx:=j; sty:=i;
            Line(round(GetMaxX/20*(j))+4,round(GetMaxY/15*(i))+4,
                 round(GetMaxX/20*(j))+28,round(GetMaxY/15*(i))+28);
            Line(round(GetMaxX/20*(j))+28,round(GetMaxY/15*(i))+4,
                 round(GetMaxX/20*(j))+4,round(GetMaxY/15*(i))+28);
        end;
      end;
    end;
  end;
end;

begin
  grDriver := Detect;
  InitGraph(grDriver, grMode,'');
  ErrCode := GraphResult;
  if ErrCode = grOk then
  begin  { Do graphics }
    Grind(20,15);
    LoadMap;
    key:=readkey;
    if (key=#13) then halt;
    if (key='L') or (key='l') then Calculation;
    MoveTo;
    Readln;
    CloseGraph;
  end
  else
    Writeln('Graphics error:', GraphErrorMsg(ErrCode));
end.