优先队列的方法（pascal）：

var
  dx:array[1..4] of longint=(-1,1,0,0);
  dy:array[1..4] of longint=(0,0,1,-1);
  p1:array[1..4] of char=('n','s','e','w');
  p2:array[1..4] of char=('N','S','E','W');
type
  rec=record
    f:ansistring;
    x,y,bx,by,step,step2:longint;
  end;
var
  map:array[1..20,1..20] of boolean;
  ch:char;
  stx,sty,enx,eny,bx,by,n,m,r,cash:longint;
  q:array[1..10000] of rec;
  v:array[1..20,1..20,1..20,1..20] of boolean;

procedure swap(var x,y:rec);
var
  t:rec;
begin
  t:=x;x:=y;y:=t;
end;

procedure change(i:longint);
var
  lc,rc,min:longint;
begin
  min:=i;lc:=i shl 1;rc:=lc+1;
  if (lc<=r) and ((q[lc].step<q[min].step) or ((q[lc].step=q[min].step) and (q[lc].step2<q[min].step2))) then min:=lc;
  if (rc<=r) and ((q[rc].step<q[min].step) or ((q[rc].step=q[min].step) and (q[rc].step2<q[min].step2))) then min:=rc;
  if i<>min then
    begin
      swap(q[i],q[min]);
      change(min);
    end;
end;

function getmin:rec;
begin
  getmin:=q[1];q[1]:=q[r];dec(r);change(1);
end;

procedure insert(x:rec);
var
  i:longint;
begin
  inc(r);
  q[r]:=x;i:=r;
  while (i>1) and ((q[i shr 1].step>q[i].step) or ((q[i shr 1].step=q[i].step) and (q[i shr 1].step2>q[i].step2))) do
    begin
      swap(q[i],q[i shr 1]);
      i:=i shr 1;
    end;
end;

procedure init;
var i,j:longint;
begin
  fillchar(map,sizeof(map),true);
  for i:=1 to n do
    begin
      for j:=1 to m do
        begin
          read(ch);
          if ch='#' then map[i,j]:=false
          else if ch='S' then
            begin
              stx:=i;sty:=j;
            end
          else if ch='T' then
            begin
              enx:=i;eny:=j;
            end
          else if ch='B' then
            begin
              bx:=i;by:=j;
            end;
        end;
      readln;
    end;
end;

function ok(x,y:longint):boolean;
begin
  if (x<1) or (x>n) or (y<1) or (y>m) then exit(false);
  exit(map[x,y]);
end;

procedure bfs;
var
  i:longint;
  x,nx:rec;
begin
  fillchar(v,sizeof(v),false);
  x.f:='';x.step:=0;x.step2:=0;
  x.x:=stx;x.y:=sty;x.bx:=bx;x.by:=by;
  r:=0;
  insert(x);
  while r>0 do
    begin
      x:=getmin;
      if (x.bx=enx) and (x.by=eny) then
        begin
          writeln(x.f);
          exit;
        end;
      for i:=1 to 4 do
        begin
          if (x.x+dx[i]=x.bx) and (x.y+dy[i]=x.by) and ok(x.bx+dx[i],x.by+dy[i]) then
            begin
              nx:=x;
              nx.bx:=x.bx+dx[i];nx.by:=x.by+dy[i];
              nx.x:=x.x+dx[i];nx.y:=x.y+dy[i];
              nx.step:=x.step+1;
              nx.step2:=x.step2+1;
              nx.f:=x.f+p2[i];
              if not v[nx.x,nx.y,nx.bx,nx.by] then
                begin
                  insert(nx);
                  v[nx.x,nx.y,nx.bx,nx.by]:=true;
                end;
            end
          else if ok(x.x+dx[i],x.y+dy[i]) and (not ((x.x+dx[i]=x.bx) and (x.y+dy[i]=x.by))) then
            begin
              nx:=x;
              nx.x:=x.x+dx[i];nx.y:=x.y+dy[i];
              nx.f:=x.f+p1[i];
              nx.step2:=x.step2+1;
              if not v[nx.x,nx.y,nx.bx,nx.by] then
                begin
                  insert(nx);
                  v[nx.x,nx.y,nx.bx,nx.by]:=true;
                end;
            end;
        end;
    end;
  writeln('Impossible.');
end;

begin
  cash:=0;
  while not eof do
    begin
      readln(n,m);
      if n+m=0 then break;
      init;
      inc(cash);
      writeln('Maze #',cash);
      bfs;
      writeln;
    end;
  writeln;
end.
双向BFS的方法也许更好理解：
const
   dx:array[1..4] of longint=(-1,1,0,0);dy:array[1..4] of longint=(0,0,1,-1);
   p:string[4]=('NSEW'); m:string[4]=('nsew');
type
  node=record
    x,y:longint; ans:ansistring;
  end;
  rec=record
    bx,by,px,py:longint; ans:ansistring;
  end;
var
  r,c,begx,begy,endx,endy,begsx,begsy,cases,i,j:longint;
  map:array[1..21] of string[20];
  vis,v:array[1..21,1..21] of boolean;
  f1,g1:node;   f,g:rec;
  q:array[1..401] of rec;
  q1:array[1..401] of node;

function ok(x,y:longint):boolean;
begin
  if (x>=1) and (x<=r) and (y>=1) and (y<=c) then exit(true) else exit(false);
end;

function slove(bx,by,ex,ey:longint):boolean;
var l,r,i:longint;
begin
  fillchar(v,sizeof(v),false); v[bx,by]:=true;
  f1.x:=bx;  f1.y:=by;  f1.ans:='';
  if (bx=ex) and (by=ey) then exit(true);
  l:=0; r:=1; q1[r]:=f1;
  while l<r do
    begin
      inc(l); f1:=q1[l];
      for i:=1 to 4 do
        begin
          g1.x:=f1.x+dx[i]; g1.y:=f1.y+dy[i];
          if not ok(g1.x,g1.y) or (map[g1.x,g1.y]='#') or ((f.bx=g1.x) and (f.by=g1.y)) then continue;
          if not v[g1.x,g1.y] then
            begin
              v[g1.x,g1.y]:=true; g1.ans:=f1.ans+m[i];
              if (g1.x=ex) and (g1.y=ey) then
                begin
                  f1:=g1; exit(true);
                end;
              inc(r); q1[r]:=g1;
            end;
        end;
    end;
  exit(false);
end;

function bfs():boolean;
var l,r,newx,newy,tx,ty:longint;
begin
  f.bx:=begx; f.by:=begy; f.px:=begsx; f.py:=begsy; f.ans:='';
  vis[begx,begy]:=true; r:=1; l:=0; q[r]:=f;
  while l<r do
    begin
      inc(l); f:=q[l];
      for i:=1 to 4 do
        begin
          newx:=f.bx+dx[i]; newy:=f.by+dy[i];
          tx:=f.bx-dx[i]; ty:=f.by-dy[i];
          if (not ok(newx, newy)) or (map[newx,newy]='#') or (not ok(tx,ty))
            or (map[tx,ty]='#') or (vis[newx,newy]) then continue;
          if slove(f.px,f.py,tx,ty) then
            begin
              g.bx:=newx; g.by:=newy; g.px:=f.bx; g.py:=f.by;
              g.ans:=f.ans+f1.ans+p[i];
              if (g.bx=endx) and (g.by=endy) then exit(true);
              vis[newx,newy]:=true;  inc(r); q[r]:=g;
            end;
        end;
    end;
  exit(false);
end;

begin
  cases:=1; readln(r,c);
  while (r+c>0) do
    begin
      fillchar(vis,sizeof(vis),0);
      writeln('Maze #', cases); inc(cases);
      for i:=1 to r do readln(map[i]);
      for i:=1 to r do
        for j:=1 to c do
          begin
            if map[i,j]='B' then
              begin begx:=i; begy:=j; end;
            if map[i,j]='T' then
              begin endx:=i; endy:=j; end;
            if map[i,j]='S' then
              begin begsx:=i; begsy:=j; end;
          end;
      if bfs() then  writeln(g.ans) else writeln('Impossible.');
      readln(r,c); writeln;
    end;
end.

• Re:推箱子Pascal源程序 简单AC (47) lazycal 2016-01-20 17:32:26