当（两物体在一起而且）代码和为３或５时，必然是相克物体在一起的情况。 【参考程序】 const
wt:array[0..3]of string[5]=(' ', 'WOLF ','SHEEP','LEAVE'); var left,right:array[1..3] of integer ;
what,i,total,left_rest,right_rest:integer; procedure print_left; {输出左岸的物体} var i:integer; begin
total:=total+1;
write('(',total,')'); {第几次渡河} for i:=1 to 3 do write(wt[left[i]]); write('|',' ':4); end;
procedure print_right;{输出右岸的物体} var i:integer; begin
write(' ':4,'|');
for i:=1 to 3 do if right[i]<>0 then write(wt[right[i]]); writeln; end;
procedure print_back(whinteger); {右岸矛盾时，需从右岸捎物体→左岸} var i:integer; begin
for i:=1 to 3 do begin
if not ((i=who) or (right[i]=0)) then begin
{要捎回左岸的物体不会时刚刚从左岸带来的物体，也不会是不在右岸的物体} what:=right[i]; right[i]:=0;
print_left; {输出返回过程} write('<-',wt[i]); print_right;
left[i]:=what; {物体到达左岸} end; end; end; begin
total:=0;
for i:=1 to 3 do begin left[i]:=i; right[i]:=0;end; repeat
- 31 -
for i:=1 to 3 do {共有３种物体}
if left[i]<>0 then {第Ｉ种物体在左岸} begin
what:=left[i];left[i]:=0; {what:放置将要过河的物体编号} left_rest:=left[1]+left[2]+left[3]; {求左岸剩余的物体编号总和} if (left_rest=3) or (left_rest=5) then left[i]:=what
{假如左岸矛盾，则不能带第Ｉ种过河，尝试下一物体} else {否则可带过河}
begin print_left; {输出过河过程} write('->',wt[i]); print_right;
right[i]:=what; {物体到达右岸}
if left_rest=0 then halt; {左岸物体已悉数过河} right_rest:=right[1]+right[2]+right[3];
{求右岸剩余的物体编号总和} if (right_rest=3)or(right_rest=5) then print_back(i) {右岸有矛盾，要捎物体回左岸}
else begin print_left; {右岸有矛盾，空手回左岸} write('<-',' ':5); print_right; end; end; end;
until false; {不断往返} end.
2.【题目】 把1-8这8个数放入下图8个格中,要求相邻的格(横,竖,对角线)上填的数不连续. ┌─┐ │①│ ┌─┼─┼─┐ │②│③│④│ ├─┼─┼─┤ │⑤│⑥│⑦│ └─┼─┼─┘ │⑧│ └─┘
【参考程序】
const lin:array[1..8] of set of 1..8 =
([3,2,4],[1,6,3,5],[5,7,1,2,4,6],[1,6,3,7], [3,8,2,6],[2,4,3,5,7,8],[3,8,4,6],[5,7,6]); var a:array[1..8] of integer;
total,i:integer; had:set of 1..8;
function ok(dep,i:integer):boolean; {判断是否能在第dep格放数字i} var j:integer; begin
ok:=true;
for j:=1 to 8 do {相邻且连续则不行}
if (j in lin[dep]) and (abs(i-a[j])=1) then ok:=false; if i in had then ok:=false; {已用过的也不行} end;
- 32 -
procedure output; {输出一种方案} var j:integer; begin
inc(total); write(total,':');
for j:=1 to 8 do write(a[j]:2);writeln; end;
procedure find(dep:byte); var i:byte; begin
for i:=1 to 8 do begin {每一格可能放1-8这8个数字中的一个} if ok(dep,i) then begin
a[dep]:=i; {把i放入格中}
had:=had+[i]; {设置已放过标志} if (dep=8) then output else find(dep+1);
a[dep]:=10; {回溯,恢复原状态} had:=had-[i]; end; end; end; begin
fillchar(a,sizeof(a),10); total:=0; had:=[]; find(1);
writeln('End.'); end.
3.【题目】迷宫问题.求迷宫的路径.(深度优先搜索法) 【参考程序1】 const
Road:array[1..8,1..8]of 0..3=((1,0,0,0,0,0,0,0), (0,1,1,1,1,0,1,0), (0,0,0,0,1,0,1,0), (0,1,0,0,0,0,1,0), (0,1,0,1,1,0,1,0), (0,1,0,0,0,0,1,1), (0,1,0,0,1,0,0,0), (0,1,1,1,1,1,1,0)); {迷宫数组}
FangXiang:array[1..4,1..2]of -1..1=((1,0),(0,1),(-1,0),(0,-1));{四个移动方向} WayIn:array[1..2]of byte=(1,1); {入口坐标} WayOut:array[1..2]of byte=(8,8); {出口坐标} Var i,j,Total:integer;
Procedure Output; var i,j:integer; Begin
For i:=1 to 8 do begin for j:=1 to 8 do begin if Road[i,j]=1 then write(#219); {1:墙} if Road[i,j]=2 then write(' '); {2:曾走过但不通的路}
- 33 -
if Road[i,j]=3 then write(#03) ; {3:沿途走过的畅通的路} if Road[i,j]=0 then write(' ') ; {0:原本就可行的路} end; writeln;
end; inc(total); {统计总数} readln; end;
Function Ok(x,y,i:byte):boolean; {判断坐标(X,Y)在第I个方向上是否可行} Var NewX,NewY:shortint; Begin
Ok:=True;
Newx:=x+FangXiang[i,1]; Newy:=y+FangXiang[i,2];
If not((NewX in [1..8]) and (NewY in [1..8])) then Ok:=False; {超界?} If Road[NewX,NewY]=3 then ok:=false; {是否已走过的路?} If Road[NewX,NewY]=1 then ok:=false; {是否墙?} End;
Procedure Howgo(x,y:integer); Var i,NewX,NewY:integer; Begin
For i:=1 to 4 do Begin {每一步均有4个方向可选择} If Ok(x,y,i) then Begin {判断某一方向是否可前进} Newx:=x+FangXiang[i,1]; {前进,产生新的坐标} Newy:=y+FangXiang[i,2]; Road[Newx,Newy]:=3; {来到新位置后,设置已走过标志} If (NewX=WayOut[1]) and(NewY=WayOut[2]) Then Output Else Howgo(Newx,NewY); {如到出口则输出,否则下一步递归} Road[Newx,Newy]:=2; {堵死某一方向,不让再走,以免打转} end; end; End;
Begin
total:=0;
Road[wayin[1],wayin[2]]:=3; {入口坐标设置已走标志} Howgo(wayin[1],wayin[2]); {从入口处开始搜索} writeln('Total is ',total); {统计总数} end.
4.【题目】地图着色问题 【参考程序１】
const lin:array[1..12,1..12] of 0..1 {区域相邻数组,1表示相邻} =((0,1,1,1,1,1,0,0,0,0,0,0), (1,0,1,0,0,1,1,1,0,0,0,0), (1,1,0,1,0,0,0,1,1,0,0,0), (1,0,1,0,1,0,1,0,1,1,0,0), (1,0,0,1,0,1,0,0,0,1,1,0), (1,1,0,0,1,0,1,0,0,0,1,0), (0,1,0,0,0,1,0,1,0,0,1,1), (0,1,1,0,0,0,1,0,1,0,0,1),
- 34 -
(0,0,1,1,0,0,0,1,0,1,0,1), (0,0,0,1,1,0,0,0,1,0,1,1), (0,0,0,0,1,1,1,0,0,1,0,1), (0,0,0,0,0,0,1,1,1,1,1,1));
var color:array[1..12] of byte; {color数组放已填的颜色} total:integer;
function ok(dep,i:byte):boolean; {判断选用色i是否可用} var k:byte; {条件:相邻的区域颜色不能相同} begin
for k:=1 to dep do
if (lin[dep,k]=1) and (i=color[k]) then begin ok:=false;exit;end; ok:=true; end;
procedure output; {输出} var k:byte; begin
for k:=1 to 12 do write(color[k],' ');writeln; total:=total+1; end;
procedure find(dep:byte); {参数dep:当前正在填的层数} var i:byte; begin
for i:=1 to 4 do begin {每个区域都可能是1-4种颜色} if ok(dep,i) then begin color[dep]:=i;
if dep=12 then output else find(dep+1);
color[dep]:=0; {恢复初始状态,以便下一次搜索} end; end; end;
begin
total:=0; {总数初始化}
fillchar(color,sizeof(color),0); find(1);
writeln('total:=',total); end.
5.【题目】一笔画问题
从某一点出发,经过每条边一次且仅一次.(具体图见高级本P160) 【参考程序】
const max=6;{顶点数为6}
type shuzu=array[1..max,1..max]of 0..max; const a:shuzu {图的描述与定义 1:连通;0:不通} =((0,1,0,1,1,1), (1,0,1,0,1,0), (0,1,0,1,1,1), (1,0,1,0,1,1),
- 35 -