(1,1,1,1,0,0), (1,0,1,1,0,0)); var
bianshu:array[1..max]of 0..max; {与每一条边相连的边数} path:array[0..1000]of integer; {记录画法,只记录顶点} zongbianshu,ii,first,i,total:integer;
procedure output(dep:integer); {输出各个顶点的画法顺序} var sum,i,j:integer; begin
inc(total);
writeln('total:',total);
for i:=0 to dep do write(Path[i]);writeln; end;
function ok(now,i:integer;var next:integer):boolean;{判断第I条连接边是否已行过} var j,jj:integer; begin
j:=0; jj:=0;
while jj<>i do begin inc(j);if a[now,j]<>0 then inc(jj);end; next:=j;
{判断当前顶点的第I条连接边的另一端是哪个顶点,找出后赋给NEXT传回} ok:=true;
if (a[now,j]<>1) then ok:=false; {A[I,J]=0:原本不通} end; { =2:曾走过}
procedure init; {初始化} var i,j :integer; begin
total:=0; {方案总数} zongbianshu:=0; {总边数} for i:=1 to max do for j:=1 to max do if a[i,j]<>0 then begin inc(bianshu[i]);inc(zongbianshu);end; {求与每一边连接的边数bianshu[i]}
zongbianshu:=zongbianshu div 2; {图中的总边数} end;
procedure find(dep,nowpoint:integer); {dep:画第几条边;nowpoint:现在所处的顶点} var i,next,j:integer; begin
for i:=1 to bianshu[nowpoint] do {与当前顶点有多少条相接,则有多少种走法} if ok(nowpoint,i,next) then begin {与当前顶点相接的第I条边可行吗?} {如果可行,其求出另一端点是NEXT} a[nowpoint,next]:=2; a[next,nowpoint]:=2; {置成已走过标志} path[dep]:=next; {记录顶点,方便输出} if dep < zongbianshu then find(dep+1,next) {未搜索完每一条边} else output(dep); path[dep]:=0; {回溯}
- 36 -
a[nowpoint,next]:=1; a[next,nowpoint]:=1; end;
begin
init; {初始化,求边数等}
for first:=1 to max do {分别从各个顶点出发,尝试一笔画} fillchar(path,sizeof(path),0); path[0]:=first; {记录其起始的顶点} writeln('from point ',first,':');readln;
find(1,first); {从起始点first,一条边一条边地画下去} end.
6.【题目】城市遍历问题.
给出六个城市的道路连接图,找出从某一城市出发,遍历每个城市一次且仅一次的最短路径 及其路程长度.(图见高级本P147} 【参考程序】 const
a:array[1..6,1..6]of 0..10 {城市间连接图.数字表示两城市间的路程} =((0,4,8,0,0,0), (4,0,3,4,6,0), (8,3,0,2,2,0), (0,4,2,0,4,9), (0,6,2,4,0,4), (0,0,0,9,4,0)); var
had:array[1..6]of boolean; {某个城市是否已到过} pathmin,path:array[1..6]of integer; {记录遍历顺序} ii,first,i,summin,total:integer;
procedure output(dep:integer); sum,i,j:integer; sum:=0; i:=2 6 {求这条路的路程总长} if sum><6 then find(dep+1)
else output(dep); had[i]:=false; {回溯} path[dep]:=0; end; end;
begin
for first:=1 to 6 do begin {轮流从每一个城市出发,寻找各自的最短路} fillchar(had,sizeof(had),false); fillchar(path,sizeof(path),0); total:=0;
SumMin:=maxint; {最短路程}
path[1]:=first;had[first]:=true;{处理出发点的城市信息,记录在册并置到过标志} find(2); {到下一城市}
writeln('from city ',first,' start,total is:',total,' the min sum:',summin);
for i:=1 to 6 do write(PathMin[i]);writeln; {输出某个城市出发的最短方案} end; end.
- 37 -
7.【题目】马的遍历问题。在Ｎ＊Ｍ的棋盘中，马只能走日字。马从位置(x,y)处出发，把 棋盘的每一格都走一次，且只走一次。找出所有路径。 【参考程序】 {深度优先搜索法} const n=5;m=4;
fx:array[1..8,1..2]of -2..2=((1,2),(2,1),(2,-1),(1,-2),(-1,-2),(-2,-1), (-2,1),(-1,2)); {八个方向增量} var
dep,i:byte; x,y:byte;
cont:integer; {统计总数}
a:array[1..n,1..m]of byte; {记录走法数组} procedure output; {输出,并统计总数} var x,y:byte; begin
cont:=cont+1; writeln; writeln('count=',cont); for y:=1 to n do begin
for x:=1 to m do write(a[y,x]:3); writeln; end; { readln; halt;} end;
procedure find(y,x,dep:byte); var i,xx,yy:integer; begin
for i:=1 to 8 do begin
xx:=x+fx[i,1];yy:=y+fx[i,2]; {加上方向增量,形成新的坐标} if ((xx in [1..m])and(yy in [1..n]))and(a[yy,xx]=0) then {判断新坐标是否出界,是否已走过?} begin
a[yy,xx]:=dep; {走向新的坐标} if (dep=n*m) then output
else find(yy,xx,dep+1); {从新坐标出发,递归下一层} a[yy,xx]:=0 {回溯,恢复未走标志} end; end; end;
begin cont:=0;
fillchar(a,sizeof(a),0); dep:=1;
writeln('input y,x');readln(y,x); { x:=1;y:=1;}
if (y>n) or(x>m) then begin writeln('x,y error!');halt;end; a[y,x]:=1; find(y,x,2);
if cont=0 then writeln('No answer!') else write('The End!'); readln; end.
- 38 -
8.【题目】把自然数Ｎ分解为若干个自然数之积。 【参考程序】
var path :array[1..1000] of integer; total,n:integer;
procedure find(k,sum,dep:integer); {K:} var b,d:Integer; begin
if sum=n then {积等于N} begin
write(n,'=',path[1]);
for d:=2 to dep-1 do write('*',path[d]); writeln;inc(total); exit; end;
if sum>n then exit; {累积大于N}
for b:= trunc(n/sum)+1 downto k do {每一种可能都去试} begin
path[dep]:=b;
find(b,sum*b,dep+1); end; end;
begin
readln(n); total:=0;
find(2,1,1);writeln('total:',total); readln; end.
9.【题目】把自然数Ｎ分解为若干个自然数之和。 【参考答案】 n │ total 5 │ 7 6 │ 11 7 │ 15 10 │ 42
100 │ 190569291
【参考程序】
var n:byte; num:array[0..255] of byte; total:word; procedure output(dep:byte); var j:byte; begin
for j:=1 to dep do write(num[j]:3);writeln; inc(total); end;
procedure find(n,dep:byte); {N:待分解的数,DEP:深度} var i,j,rest:byte; begin
for i:=1 to n do {每一位从N到1去试}
- 39 -
if num[dep-1]<=i then {保证选用的数大于前一位} begin num[dep]:=i;
rest:=n - i; {剩余的数进行下一次递归调用} if (rest>0) then begin find(rest,dep+1);end
else if rest=0 then output(dep);{刚好相等则输出} num[dep]:=0; end; end;
begin {主程序}
writeln('input n:');readln(n); fillchar(num,sizeof(num),0); total:=0; num[0]:=0; find(n,1);
writeln('sum=',total); end.
10.【题目】N皇后问题(含八皇后问题的扩展，规则同八皇后)：在N*N的棋盘上，放置N个皇后，要求每一横行
每一列，每一对角线上均只能放置一个皇后，问可能的方案及方案数。 const max=8; var i,j:integer;
a:array[1..max] of 0..max; {放皇后数组}
b:array[2..2*max] of boolean; {/对角线标志数组}
c:array[-(max-1)..max-1] of boolean; {\\对角线标志数组} col:array[1..max] of boolean; {列标志数组} total:integer; {统计总数} procedure output; {输出} var i:integer; begin
write('No.':4,'[',total+1:2,']');
for i:=1 to max do write(a[i]:3);write(' '); if (total+1) mod 2 =0 then writeln; inc(total); end;
function ok(i,dep:integer):boolean; {判断第dep行第i列可放否} begin
ok:=false;
if ( b[i+dep]=true) and ( c[dep-i]=true) {and (a[dep]=0)} and (col[i]=true) then ok:=true end;
procedure try(dep:integer); var i,j:integer; begin
for i:=1 to max do {每一行均有max种放法} if ok(i,dep) then begin a[dep]:=i;
b[i+dep]:=false; {/对角线已放标志} c[dep-i]:=false; {\\对角线已放标志}
- 40 -
col[i]:=false; {列已放标志} if dep=max then output
else try(dep+1); {递归下一层} a[dep]:=0; {取走皇后,回溯} b[i+dep]:=true; {恢复标志数组} c[dep-i]:=true; col[i]:=true; end; end; begin
for i:=1 to max do begin a[i]:=0;col[i]:=true;end; for i:=2 to 2*max do b[i]:=true;
for i:=-(max-1) to max-1 do c[i]:=true; total:=0; try(1);
writeln('total:',total); end.
【测试数据】 n=8 八皇后问题 total:92
对于N皇后: ┏━━━┯━━┯━━┯━━┯━━┯━━┯━━┯━━┓ ┃皇后 N│ 4 │ 5 │ 6 │ 7 │ 8 │ 9 │ 10 ┃ ┠───┼──┼──┼──┼──┼──┼──┼──┨ ┃方案数│ 2 │ 10 │ 4 │ 40 │ 92 │352 │724 ┃ ┗━━━┷━━┷━━┷━━┷━━┷━━┷━━┷━━┛
- 41 -