从浅入深掌握pascal编程技术.第二十七节回溯法

1、回溯搜索 回溯是一种模拟人类思维过程的算法思想。它的基本方法是：按照深度优先的顺序向下一层扩展结点；扩展到某一层时，若已无法继续扩展且仍未找到解，则退回到父结点，从父结点的下一个分支开始，按同样的策略继续扩展，直到找到问题的解或证明无解。 在方格的棋盘内，放置四个皇后，使得任意两个皇后不在同一行、同一列、同一条对角线上。请找出所有的摆法。 分析： 如果我们把*的棋盘看成是一个平面直角坐标系，那么任意两个皇后在平面上的坐标应同时满足以下三个条件：两个皇后的横坐标(行号)不相等。两个皇后的纵坐标（列号）不相等。两个皇后的横坐标之差的绝对值不等于纵坐标之差的绝对值。 IKXI XK|I-K|XI-X

2、K|例1、四皇后问题 我们用数组xi来描述四个皇后在棋盘上的状态， xi =j表示在第i行的第j列放置了一个皇后。（演示）空棋盘134-1-11-12-13-131-132-133-14-141-142-143-144-2-21-22-23-24-241-241124122413绿色方框表示搜索过程中生成的合法结点，红色方框表示尝试生成的非法结点在回溯算法中，无论搜索进行到哪一结点，都只需要保存根结点到当前结点之前的路径，而不需要保存其他分支，因此只需要一个线性表即可保存搜索的“历程”在向纵深方向扩展结点时，结点是按照访问顺序逐一处理的；在回溯时，结点是按照访问顺序的反序被逐一舍弃的因此可借助

3、栈来处理回溯算法中的结点const n=4;var i,j,k:integer;是栈顶指针 x:array1.n of integer;栈function place(k:integer):boolean; var i:integer; begin place:=true; for i:=1 to k-1 do if ( )or (abs(xi-xk)=abs(i-k) then place:=false ; end;procedure print; 输出一种方案 var i:integer; begin for i:=1 to n do write(xi:4); writeln; end;

4、begin k:=1;摆放第一个皇后 xk:=0;保存第k个皇后的列号 while ( ) do栈非空时 begin xk:=xk+1; while(xk0not place(k)xknprintk:=k+1不满足约束条件0k101230123440120123434212340101230例2、数字排列问题 列出所有从数字1到数字n的连续自然数的排列,要求所产生的任一数字序列中不能出现重复的数字输入：n（1=n0 do begin xk:=xk+1; while ( ) and (not place(k) do xk:=xk+1; if xkn then( ) else if( )then

5、print else begin ( ); xk:=0 end end ;end.var i,k,n:integer;k是栈顶指针 x:array1.9 of integer;栈function place(k:integer):boolean; var i:integer; begin place:=true; for i:=1 to k-1 do if ( )then begin place:=false; break end ; end;procedure print; var i:integer; begin for i:=1 to n do write(xi, ); writeln;

6、 end;xk 1,2 - 3,1 -4,3马12431const x0:array1.4of integer=(1,2,2,1); y0:array1.4of integer=(2,1,-1,-2);var m,n,k,i:integer;k是栈顶指针 x:array0.1000,1.2of integer;保存每一跳的位置 y:array1.1000of integer;栈,保存每一跳的方向function nok(k:integer):boolean;会不会出界 var i,j:integer; begin i:=xk-1,1+x0yk; j:=xk-1,2+y0yk; if(in)or

7、(jm)or(j0 do begin yk:=yk+1; while (yk4 then k:=k-1 回溯 else begin xk,1:=xk-1,1+x0yk; xk,2:=xk-1,2+y0yk; if( ) then begin for i:=( )do write(xi,1,xi,2,-); writeln(n,m); ( ) end else begin ( ) ; yk:=0; end; end; end; writeln(NO);end.nok(k)(xk,1=n)and(xk,2=m)0 to k-1 haltk:=k+1例四色问题（96年初赛试题）87654321 设有

8、下列形状的图形：有8个区域，其编号为，8，图中各区域的相邻关系用0（不相邻）、1（相邻）表示，如以下图表所示。 问题要求：将下面图形的每一部分涂上红（1）、黄（2）、蓝（3）、绿（4）四种颜色之一，要求相邻部分的颜色不同。12345678010000111010011001010100001011000001010001111010110001011000001012345678 分析：设m为图的邻接矩阵。按照涂色的先后顺序将方案存入堆栈s中，其中sk为区域k的颜色码，区域k为第k个涂色的区域。在计算过程中，我们必须记住当前涂色的区域号i，该区域称之为栈顶，区域准备涂颜色j（1j4）。 首先将

9、区域1涂红色（s1:=1），并准备涂区域2（i:=2），从颜色1开始试探（j:=1）。区域 i 能否涂颜色j，关键取决于区域 i 的周边是否有同色区域。搜索已涂色的区域1 区域i-1中与区域 i 相邻的区域k，看一看这些区域是否涂了颜色j。若与区域 i 相邻的区域 k已经涂了颜色j，按照颜色码递增顺序换一种颜色（j:=j+1）；若区域 i 的周边没有涂颜色 j 的区域，则区域 i 可以涂颜色j（si:=j）。“入栈”，准备涂区域i+1，也从颜色1开始试探（i:=i+1，j:=1）。 对区域i，按照颜色码递增顺序试探颜色。如果区域 i 找不到合适的颜色（j4）则应该出栈，按照颜色码递增顺序调整区

10、域i-1的颜色（i:=i-1，j:=si+1）。 如此，从区域1出发，依次类推，直至区域n涂好颜色为止（in）。constn=8;var i,j,k,:integer；I是栈顶指针 m:array1.n，1.n of 0.1;图的邻接矩阵 s:array1.n of integer;栈,存放各区域的颜色begin for i:=1 to n do begin for j:=1 to n do read(mI,j);readln; end; ( ); 首先给第一个图形涂上红色 i:=2; j:=1; s1:=1while i=n do begin while (j=4)and(i=n) do b

11、egin k:=1； while( ) do k:=k+1; if k4 then begin i:=i-1; ( ) ; end; end; (ki)and(skj)or(rI,k1)j:=j+1Si:=jj:=si+1 for i:=1 to n do writeln(I,-,si);end.四皇后问题的递归实现const n=;var i,j,k:integer;x:array1.n of integer; 保存第i个皇后的列号function place(k:integer):boolean; var i:integer; begin place:=true; for i:=1 to

12、k-1 do if(xi=xk)or(abs(xi-xk)=abs(i-k) then place:=false; end;procedure print; var i:integer; begin for i:=1 to n do write(xi:4); writeln; end;procedure try(k:integer); var i:integer; begin if( ) then begin print; ( ) end; for i:=( )do begin ( ); if place(k) then( ); end; end ;begin try(1);摆放第一个皇后en

13、d.k=n+1xk:=itry(k+1)1 to n exit 皇后序号摆放下一个皇后因为从第i个皇后到第i+1个皇后的摆放过程是相同的,所以可以用递归的方法.var i,k,n:integer; x:array1.9 of integer;function place(k:integer):boolean; var i:integer; begin place:=true; for i:=1 to k-1 do if( )then begin place:=false; break end ; end;procedure print; var i:integer; begin for i:=

14、1 to n do write(xi, ); writeln; end;数字排列问题的递归实现xi=xkprocedure try(k:integer); var i :integer; begin if( )then begin print; exit; end; for i:=1 to n do begin ( ); if( )then try(k+1) end end;begin readln(n); try(1);end.knxk:=iplace(k)骑士游历问题的递归实现const x:array1.4,1.2 of integer =(1,2),(2,1),(2,-1),(1,-2

15、);var n,m:integer; a:array1.30,1.2 of integer;procedure print(ii:integer); var i:integer; begin for i:=1 to ii-1 do write(ai,1,ai,2,-); writeln(n,m); ( ) end;procedure try(i:integer); var j:integer; begin for j:=1 to 4 do if (ai-1,1+xj,1=0) and (ai-1,2+xj,2=m) then begin ai,1:=ai-1,1+xj,1; ai,2:=ai-

16、1,2+xj,2; if (ai,1=n)and(ai,2=m) then( ) else( ); ( ) end; end;begin read(n,m); try(2); writeln(NO);end.print(i)ai,1:=0; ai,2:=0try(i+1)halt四色问题的递归实现const num=20;最多20个区域var a:array 1.num,1.num of 0.1;用邻接矩阵表示图 s:array 1.num of 0.4; 1-4代表四色;0代表末填 i,j,n,k:integer;function pd(i,j:integer):boolean;判断可行性

17、var k:integer; begin for k:=1 to i-1 do if (ai,k=1) and ( ) then begin pd:=false; exit; end; pd:=true; end;j=skprocedure try(i:integer); var j:integer; begin for j:=1 to 4 do if( )then begin ( ); if i=n then( ) else( ); si:=0; end; end;begin readln(n); for i:=1 to n do 读入邻接矩阵 begin for j:=1 to n do

18、read(ai,j); readln; end; for i:=1 to n do si:=0;初始化 k:=0;记数 try(1); writeln(k);end.pd(i,j)k:=k+1si:=jtry(i+1)二种方式的区别:1、递归方式实现简单，非递归方式比较复杂。2、递归方式需要利用栈空间，如果搜索量过大，可能造成栈溢出，所以在栈空间无法满足的情况下，选用非递归方式实现较好。回溯法的剪枝回溯搜索的进程可以看作是从树根出发，遍历一棵搜索树的过程所谓剪枝，就是通过某种判断条件，避免一些不必要的遍历过程，形象地说，就是剪去了搜索树中的某些“枝条”下图是一个求最短路径扩展的搜索树，描述了剪

19、枝的过程A(0)B(10)C(20)D(30)E(35)F(40)G(50)H(35)I(25)J(30)当叶子结点D已找到了一个值为30的最短路径,这时在搜索到G(50)、H(35)、J(30)时，其路径长度已大于或等于了当时最优值，因此再搜索下去毫无意义，其下的结点都可以剪除 某乡有n个村庄(1n40)，有一个售货员，他要到各个村庄去售货，各村庄之间的路程s(0s1000)是已知的，且A村到B村与B村到A村的路大多不同。为了提高效率，他从商店出发到每个村庄一次，然后返回商店所在的村，假设商店所在的村庄为1，他不知道选择什么样的路线才能使所走的路程最短。请你帮他选择一条最短的路。 输入:村庄

20、数n和各村之间的路程(均是整数)。 输出:最短的路程。 样例输入: 3 村庄数 0 2 l 村庄1到各村的路程 1 0 2 村庄2到各村的路程 2 1 0 村庄3到各村的路程 样例输出: 3测试、售货员的难题 算法分析： 题目给定的村庄数不多(040)，所以可以用回溯的方 法，从起点出发找出所有经过其他各村庄的回路，计算其中的最短路程。用一个过程road(step，line：byte)来描述走的状况，其中step是当前已到过的村庄数、line是当前所在的村庄。如果stepn，接下去只能回起点了，此时看第line个村庄到起点的路程加上已走的总路程，如果它比最小值还小则替换最小值。如果step还小

21、于n，那么将还没有到过的村庄一个一个地试过去，再调用下一步road(step+1，新到的村庄号)。var a:array1.40,1.40 of integer; n,i,j:integer; min,m:longint; bj:array1.40 of boolean;begin readln(n); for i:=1 to n do for j:=1 to do read(ai,j); fillchar(bj,sizeof(bj),true); min:=99999999; m:=0; road(1,1); writeln(min);end. procedure road(step,lin

22、e:byte); var i,j,k:byte; begin if（ ）then begin if m+aline,1min then min:=m+aline,1; exit; end; for i:=2 to n do if(iline)and（ ）then begin m:=m+aline,i; bjline:=false; if mmin then（ ); m:=m-aline,i; （ ）; end; end;step=nbjiroad(step+1,i)bjline:=true满足最优性要求优化恢复其递归前的值测试2 、棋盘覆盖 有边长为N（偶数）的正方形，用N*N/2个长为2宽为

23、1的长方形将它全部覆盖，请找出所有覆盖方法。如N=4时的一种覆盖方法及输出格式如下所示。1224133456685778输出：1 2 2 41 3 3 45 6 6 85 7 7 8var n:integer; t:longint; a:array1.10,1.10 of integer;procedure print; var i,j:integer; begin inc(t); for i:=1 to n do begin for j:=1 to n do write(ai,j:5); writeln; end; end;procedure try(i:integer); var j,k:

24、integer; begin j:=0; repeat找到第一个未覆盖的空格(j,k) j:=j+1; k:=1; while(k0) do inc(k); until k=n; aj,k:=i; if (jn)and(aj+1,k=0)then begin aj+1,k:=i; if i*2n*n then try(i+1) else print; aj+1,k:=0; end; if (kn)and(aj,k+1=0)then begin aj,k+1:=i; if i*2n*n then try(i+1) else print; aj,k+1:=0; end; aj,k:=0; end;

25、begin readln(n); try(1); write(t);end.测试3.排队购票公园门票每张5角,如果有2n个人排队购票,每人一张，并且其中一半人恰有角钱,另一半人恰有元钱,而票房无零钱可找，那么有多少种方法将这2n个人排成一列，顺次购票，使得不至于因票房无零钱可找而耽误时间？const maxn=10;var a:array1.maxn*2 of integer; n,num:integer;procedure try(k,n0,n1:integer); var i,j:integer; begin if( )then begin inc(num); write(No.,num,

26、 ); for i:=1 to 2*n do write(ai:2); writeln; ( ); end; if(n0=n1)and(n0n)then begin ak:=0; try( ); end;if( )and(n0n1n0=nexitn0是有角钱的人数n1是有元钱的人数测试4.错排问题 在书架上放有编号为1 ，2 ，n的n本书。现将n本书全部取下然后再放回去，当放回去时要求每本书都不能放在原来的位置上。 例如：n = 3时： 原来位置为：1 2 3 放回去时只能为：3 1 2 或 2 3 1 这两种 问题：求当n = 5时满足以上条件的放法共有多少种？（不用列出每种放法）var a:array1.50 of integer; s:set of 1.50; n,num:integer;procedure print; var i:integer; begin inc(num); write(No.,num, ); for i:=1 to n do write(ai:4); writeln; end;procedure cuopai(k:integer); var i:integer; begin if ( )then begin print; exit; end; for i:=1 to n do if not(i