rule:array[1..4,1..2]of -1..1=((1,0),(-1,0),(0,1),(0,-1)); var
a:array[1..5000]of node; b:array[1..5000]of integer; i,j,x,y,k:integer;
procedure look(k:integer;var x,y:integer); var
i,j:integer; begin
for i:=1 to 3 do for j:=1 to 3 do
if a[k,i,j]=0 then begin x:=i;y:=j;exit;end; end;
function nrep(k:integer):boolean; var
i,j,l:integer; p:boolean; begin
nrep:=false;
for i:=1 to k-1 do begin p:=true; for j:=1 to 3 do for l:=1 to 3 do
if a[i,j,l]<>a[k,j,l] then begin p:=false;break;end; if p then exit; nrep:=true; end; end;
function result(k:integer):boolean; var
i,j:integer; begin
result:=false; for i:=1 to 3 do for j:=1 to 3 do
if a[k,i,j]<>goal[i,j] then exit; result:=true; end;
procedure print(k:integer); var
i,j:integer; begin
if k=0 then exit; print(b[k]);
for i:=1 to 3 do begin
for j:=1 to 3 do write(a[k,i,j]:2); writeln; end;
writeln('-----------'); end; begin
a[1]:=start; b[1]:=0; i:=1; j:=2; repeat
look(i,x,y); for k:=1 to 4 do
if (x+rule[k,1]>0)and(x+rule[k,1]<4)and(y+rule[k,2]<4)and(y+rule[k,2]>0)then begin
a[j]:=a[i];
a[j,x,y]:=a[i,x+rule[k,1],y+rule[k,2]]; a[j,x+rule[k,1],y+rule[k,2]]:=0;b[j]:=i;
if nrep(j) then if result(j) then begin print(j);exit;end else j:=j+1; end; i:=i+1; until i=j;
write('no answer'); end.
2. 中国盒问题
将ABBA_ _ABAB 移动成AAAA _ _BBBB
程序如下：（宽搜） var
a:array[1..5000]of string[10]; b:array[1..5000]of integer; i,j,k,p:integer;
function nrep(k:integer):boolean; var
i:integer; begin
nrep:=false;
for i:=1 to k-1 do
if a[i]=a[k] then exit; nrep:=true;
end;
procedure print(k:integer); begin
if k=0 then exit; print(b[k]); writeln(a[k]); end; begin
a[1]:='abababab__'; b[1]:=0; i:=1; j:=2; repeat
for k:=1 to 9 do
if a[i,k]='_' then break; for p:=1 to 9 do
if (p<>k)and(p<>k+1) then begin
a[j]:=a[i]; a[j,k]:=a[i,p];
a[j,k+1]:=a[i,p+1]; a[j,p]:='_'; a[j,p+1]:='_'; b[j]:=i;
if nrep(j) then
if a[j]='aaaa__bbbb' then begin print(j);exit;end else j:=j+1; end; i:=i+1; until i=j;
write('no answer'); end.
3. 24点
程序如下：（宽搜） var
a:array[1..2000,0..4]of integer; b:array[1..2000]of integer; c:array[1..2000,1..2]of integer; d:array[1..2000]of char; i,j,x,y,m,n,k,l,t:integer; procedure print(j:integer); var
f:integer; begin
if j=0 then exit; print(b[j]);
for f:=1 to a[j,0] do write(a[j,f]:3);
if (c[j,1]>0)and(c[j,2]>0) then writeln(c[j,1]:6,d[j],c[j,2],'=',a[j,a[j,0]]) else writeln; end;
function nrep(j:integer):boolean; var
k,l:integer; p:boolean; begin
nrep:=false;
for k:=1 to j-1 do if a[k,0]=a[j,0] then
begin
p:=true;
for l:=1 to a[j,0] do if a[k,l]<> a[j,l] then
begin
p:=false; break;
end; if p then exit; end; nrep:=true; end;
procedure ch(l,t:integer); var
k:integer; begin
a[j,0]:=l;
for k:=1 to l do a[j,k]:=a[t,k]; end; begin
a[1,0]:=4; a[1,1]:=1; a[1,2]:=2; a[1,3]:=3; a[1,4]:=4; b[1]:=0; i:=1; j:=2; repeat
for x:=1 to a[i,0] do
for y:=1 to a[i,0] do if x<>y then begin
a[j,0]:=0;
for k:=1 to a[i,0] do
if (a[i,k]<>a[i,x])and(a[i,k]<>a[i,y]) then begin inc(a[j,0]);
a[j,a[j,0]]:=a[i,k]; end; l:=a[j,0]; t:=j; for m:=1 to 4 do begin
case m of
1:begin inc(a[j,0]); a[j,a[j,0]]:=a[i,x]+a[i,y]; b[j]:=i;
c[j,1]:=a[i,x]; c[j,2]:=a[i,y]; d[j]:='+'; end;
2:if a[i,x]-a[i,y]>0 then begin ch(l,t); inc(a[j,0]); a[j,a[j,0]]:=a[i,x]-a[i,y]; b[j]:=i;
c[j,1]:=a[i,x]; c[j,2]:=a[i,y]; d[j]:='-'; end;
3:begin ch(l,t); inc(a[j,0]); a[j,a[j,0]]:=a[i,x]*a[i,y]; b[j]:=i;
c[j,1]:=a[i,x]; c[j,2]:=a[i,y]; d[j]:='*'; end;
4:if (a[i,y]>0)and(a[i,x] mod a[i,y]=0) then
begin
ch(l,t); inc(a[j,0]);
a[j,a[j,0]]:=a[i,x] div a[i,y];b[j]:=i;c[j,1]:=a[i,x];c[j,2]:=a[i,y];d[j]:='/'; end;
end;
if a[j,0]>=l then if nrep(j) then
if (a[j,0]=1)and(a[j,1]=24) then begin print(j);exit;end else inc(j); end; end; inc(i); until i=j;
writeln('no answer'); end.
第九次课宽搜（2）+双向搜索
4. 最短序列编号（测试数据见zdbhxl）