经典例题

神秘客

【题目】排球队员站位问题
┏━━━━━━━━┓图为排球场的平面图，其中一、二、三、四、五、六为位置编号，
┃　　　　　　　　┃二、三、四号位置为前排，一、六、五号位为后排。某队比赛时，
┃　　　　　　　　┃一、四号位放主攻手，二、五号位放二传手，三、六号位放副攻
┠──┬──┬──┨手。队员所穿球衣分别为１，２，３，４，５，６号，但每个队
┃ 四 │ 三 │ 二 ┃员的球衣都与他们的站位号不同。已知１号、６号队员不在后排，
┠──┼──┼──┨２号、３号队员不是二传手，３号、４号队员不在同一排，５号、
┃ 五 │ 六 │ 一 ┃６号队员不是副攻手。
┗━━┷━━┷━━┛ 编程求每个队员的站位情况。
【算法分析】本题可用一般的穷举法得出答案。也可用回溯法。以下为回溯解法。
【参考程序】
type sset=set of 1..6;
var   a:array[1..6]of 1..6;
      d:array[1..6]of sset;
      i:integer;

procedure output; {输出}
begin
       if not( (a[3]in [2,3,4])= (a[4] in[2,3,4])) then
       begin { 3,4号队员不在同一排 }
  write('number:');for i:=1 to 6 do write(i:8);writeln;
  write('weizhi:');for i:=1 to 6 do write(a:8);writeln;
       end;
end;

procedure try(i:integer;s:sset); {递归过程  i:第i个人,s:哪些位置已安排人了}
var
   j,k:integer;
begin
     for j:=1 to 6 do begin {每个人都有可能站1-6这6个位置}
   if (j in d) and not(j in s) then begin
     {j不在d中,则表明第i号人不能站j位. j如在s集合中,表明j位已排人了}
      a:=j;    {第 i 人可以站 j 位}
      if i<6 then try(i+1,s+[j])   {未安排妥,则继续排下去}
     else  output;    {6个人都安排完,则输出}
    end;
       end;

end;

begin
     for i:=1 to 6 do d:=[1..6]-;       {每个人的站位都与球衣的号码不同}
     d[1]:=d[1]-[1,5,6];
     d[6]:=d[6]-[1,5,6];     {1,6号队员不在后排}
     d[2]:=d[2]-[2,5];
     d[3]:=d[3]-[2,5];      {2,3号队员不是二传手}
     d[5]:=d[5]-[3,6];
     d[6]:=d[6]-[3,6];      {5,6号队员不是副攻手}
     try(1,[]);
end.

[此贴子已经被作者于2004-9-12 10:32:35编辑过]

神秘客

【题目】把自然数Ｎ分解为若干个自然数之积。
【参考程序】
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.

神秘客

【题目】马的遍历问题。在Ｎ＊Ｍ的棋盘中，马只能走日字。马从位置(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.

神秘客

【题目】加法分式分解。如：1/2=1/4+1/4.找出所有方案。
输入：Ｎ  Ｍ Ｎ为要分解的分数的分母
Ｍ为分解成多少项
【参考程序】
program fenshifenjie;
const  nums=5;
var
   t,m,dep:integer;
   n,maxold,max,j:longint;
   path:array[0..nums] of longint;
   maxok,p:boolean;
   sum,sum2:real;

procedure print;
var i:integer;
begin
  t:=t+1;
  if maxok=true then begin maxold:=path[m];maxok:=false;end;
  write ('NO.',t);
  for i:=1 to m do write(' ',path:4); writeln;
  if path[1]=path[m] then begin writeln('Ok!   total:',t:4);readln;halt;end;
end;

procedure input;
begin
  writeln ('input N:'); readln(n);
  writeln ('input M(M<=',nums:1,'):'); readln(m);
  if (n<=0) or (m<=0) or (m>4) or (n>maxlongint)
   then begin writeln('Invalid Input!');readln;halt;end;
end;

function sum1(ab:integer):real;
var a,b,c,d,s1,s2:real;
    i:integer;
begin
if ab=1  then
      sum1:=1/path[1]
else
      begin
  a:=path[1];
  b:=1      ;
  c:=path[2];
  d:=1;
  for i:=1 to ab-1 do
       begin
  s2:=(c*b+a*d);
  s1:=(a*c);
  a:=s1;
  b:=s2;
  c:=path[i+2];
       end;
  sum1:=s2/s1;
       end;

end;

procedure back;
begin
  dep:=dep-1;
  if dep<=m-2 then max:=maxold;
  sum:=sum-1/path[dep];
  j:=path[dep];
end;

procedure find;
begin
   repeat
dep:=dep+1;
j:=path[dep-1]-1;
p:=false;
   repeat
    j:=j+1;
    if (dep<>m) and (j<=max) then
       if (sum+1/j) >=1/n then p:=false
     else  begin
   p:=true;
   path[dep]:=j;
   sum:=sum+1/path[dep];
   end
       else if j>max then back;
    if dep=m then begin
       path[dep]:=j;
       sum2:=sum1(m);
       if (sum2)>1/n then p:=false;
       if (sum2)=1/n then begin     print;
    max:=j;
    back;
    end;
       if (sum2<1/n) then back;
       if (j>=max)   then back;
       end;
      until p
   until dep=0;
end;

begin
     INPUT;
     maxok:=true;
     for t:=0 to m do  path[t]:=n;
     dep:=0; t:=0; sum:=0;
     max:=maxlongint;
     find;
     readln;
end.

[此贴子已经被作者于2004-9-12 10:37:01编辑过]

神秘客

【题目】地图着色问题
【参考程序１】
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),
(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.

【参考程序２】
const   {lin数组:代表区域相邻情况}
lin:array[1..12] of set of  1..12 =
([2,3,4,5,6],[1,3,6,7,8],[1,2,4,8,9],[1,3,5,9,10],[1,4,6,10,11],
  [1,2,5,7,11],[12,8,11,6,2],[12,9,7,2,3],[12,8,10,3,4],
  [12,9,11,4,5],[12,7,10,5,6],[7,8,9,10,11]);
color:array[1..4] of char=('r','y','b','g');
var a:array[1..12] of byte; {因有12个区域,故a数组下标为1-12}
    total:integer;

function ok(dep,i:integer):boolean; {判断第dep块区域是否可填第i种色}
var j:integer; { j 为什么设成局部变量?}
begin
     ok:=true;
     for j:=1 to 12 do
if (j in lin[dep]) and (a[j]=i) then ok:=false;
end;

procedure output; {输出过程}
var j:integer;  { j 为什么设成局部变量?}
begin
  inc(total);  {方案总数加1}
  write(total:4); {输出一种方案}
  for j:=1 to 12 do write(color[a[j]]:2);writeln;
end;

procedure find(dep:byte);
var i:byte; { i 为什么设成局部变量?}
begin
      for i:=1 to 4 do      {每一区域均可从4种颜色中选一}
  begin
   if ok(dep,i) then begin    {可填该色}
      a[dep]:=i;   {第dep块区域填第i种颜色}
      if (dep=12) then output {填完12个区域}
  else find(dep+1); {未填完}
       a[dep]:=0;  {取消第dep块区域已填的颜色}
      end;
  end;
end;
begin {主程序}
     fillchar(a,sizeof(a),0);  {记得要给变量赋初值!}
     total:=0;
     find(1);
     writeln('End.');
end.

神秘客

【题目】在n*n的正方形中放置长为2,宽为1的长条块,问放置方案如何
【参考程序１】
const n=4;
var  k,u,v,result:integer;
     a:array[1..n,1..n]of char;

procedure printf; {输出}
  begin
    result:=result+1; {方案总数加1}
    writeln('--- ',result,' ---');
    for v:=1 to n do   begin
for u:=1 to n do write(a[u,v]); writeln end; writeln;
  end;

procedure try; {填放长条块}
  var i,j,x,y:integer;  full:boolean;
  begin
    full:=true;
    if k<>trunc(n*n/2) then full:=false;{测试是否已放满}
    if full then printf;   {放满则可输出}
    if not full then  begin    {未满}
x:=0;y:=1;   {以下先搜索未放置的第一个空位置}
repeat
   x:=x+1;
   if x>n then begin x:=1;y:=y+1 end
until a[x,y]=' ';
    {找到后,分两种情况讨论}
if a[x+1,y]=' ' then   begin   {第一种情况:横向放置长条块}
     k:=k+1; {记录已放的长条数}
     a[x,y]:=chr(k+ord('@'));   {放置}
     a[x+1,y]:=chr(k+ord('@'));
     try; {递归找下一个空位置放}
     k:=k-1;
     a[x,y]:=' ';               {回溯,恢复原状}
     a[x+1,y]:=' '
end;
if a[x,y+1]=' ' then   begin    {第二种情况:竖向放置长条块}
     k:=k+1; {记录已放的长条数}
     a[x,y]:=chr(k+ord('0'));    {放置}
     a[x,y+1]:=chr(k+ord('0'));
     try; {递归找下一个空位置放}
     k:=k-1;
     a[x,y]:=' ';                {回溯,恢复原状}
     a[x,y+1]:=' '
end;
    end;
  end;

begin {主程序}
  fillchar(a,sizeof(a),' ');  {记录放置情况的字符数组,初始值为空格}
  result:=0; k:=0;  {k记录已放的块数,如果k=n*n/2,则说明已放满}
  try; {每找到一个空位置,把长条块分别横放和竖放试验}
end.

【参考程序２】
const dai:array [1..2,1..2]of integer=((0,1),(1,0));
type node=record
w,f:integer;
end;
var a:array[1..20,1..20]of integer;
path:array[0..200]of node;
s,m,n,nn,i,j,x,y,dx,dy,dep:integer;
p,px:boolean;

procedure inputn;
begin
{ write('input n');readln(n);}
n:=4;
nn:=n*n;m:=nn div 2;
end;

procedure print;
var i,j:integer;
begin
inc(s);writeln('no',s);
for i:=1 to n do begin
   for j:=1 to n do
     write(a[i,j]:3);writeln;
     end;
     writeln;
end;

function fg(h,v:integer):boolean;
var p:boolean;
begin
   p:=false;
   if (h<=n) and (v<=n) then
if a[h,v]=0 then p:=true;
   fg:=p;
  end;

procedure back;
begin
   dep:=dep-1;
   if dep=0 then begin p:=true ;px:=true;end
      else begin
i:=path[dep].w;j:=path[dep].f;
x:=((i-1)div n )+1;y:=i mod n;
if y=0 then y:=n;
dx:=x+dai[j,1];dy:=y+dai[j,2];
a[x,y]:=0;a[dx,dy]:=0;
end;
end;

begin
inputn;
s:=0;
fillchar(a,sizeof(a),0);
x:=0;y:=0;dep:=0;
path[0].w:=0;path[0].f:=0;
repeat
   dep:=dep+1;
   i:=path[dep-1].w;
   repeat
    i:=i+1;x:=((i-1)div n)+1;
    y:=i mod n;if y=0 then y:=n;
    px:=false;
    if fg(x,y)
     then begin
     j:=0;p:=false;
     repeat
     inc(j);
     dx:=x+dai[j,1];dy:=y+dai[j,2];
     if fg(dx,dy) and (j<=2) then begin
       a[x,y]:=dep;a[dx,dy]:=dep;
       path[dep].w:=i;path[dep].f:=j;
       if dep=m then begin print;dep:=m+1;back;end
else begin p:=true;px:=true;end;
end
       else if j>=2 then back
    else p:=false;
       until p;
       end
       else if i>=nn then back
  else px:=false;
     until px;
    until dep=0;
    readln;
end.

神秘客

【题目】找迷宫的最短路径。（广度优先搜索算法）
【参考程序】
uses crt;
const
migong:array  [1..5,1..5] of integer=((0,0,-1,0,0), (0,-1,0,0,-1),
(0,0,0,0,0), (0,-1,0,0,0),  (-1,0,0,-1,0));
{迷宫数组}
fangxiang:array  [1..4,1..2] of -1..1=((1,0),(0,1),(-1,0),(0,-1));
{方向增量数组}
type node=record
     lastx:integer;  {上一位置坐标}
     lasty:integer;
     nowx:integer;   {当前位置坐标}
     nowy:integer;
     pre:byte;     {本结点由哪一步扩展而来}
     dep:byte;     {本结点是走到第几步产生的}
  end;
var
    lujing:array[1..25] of node;   {记录走法数组}
    closed,open,x,y,r:integer;

procedure output;
var i,j:integer;
begin
  for i:=1 to 5 do  begin
    for j:=1 to 5 do
      write(migong[i,j]:4); writeln;end;
  i:=open;
  repeat
     with lujing do
write(nowy:2,',',nowx:2,' <--');
     i:=lujing.pre;
  until lujing.pre=0;
     with lujing do
write(nowy:2,',',nowx:2);
end;


begin
  clrscr;
  with lujing[1] do begin  {初始化第一步}
     lastx:=0; lasty:=0; nowx:=1;nowy:=1;pre:=0;dep:=1;end;
  closed:=0;open:=1;migong[1,1]:=1;
  repeat
    inc(closed); {队列首指针加1,取下一结点}
    for r:=1 to 4 do begin {以4个方向扩展当前结点}
      x:=lujing[closed].nowx+fangxiang[r,1]; {扩展形成新的坐标值}
      y:=lujing[closed].nowy+fangxiang[r,2];
      if not ((x>5)or(y>5) or (x<1) or (y<1) or (migong[y,x]<>0)) then begin
{未出界,未走过则可视为新的结点}
      inc(open);   {队列尾指针加1}
      with lujing[open] do begin  {记录新的结点数据}
nowx:=x; nowy:=y;
lastx:=lujing[closed].nowx;{新结点由哪个坐标扩展而来}
lasty:=lujing[closed].nowy;
dep:=lujing[closed].dep+1; {新结点走到第几步}
pre:=closed;    {新结点由哪个结点扩展而来}
      end;
      migong[y,x]:=lujing[closed].dep+1;  {当前结点的覆盖范围}
      if (x=5) and (y=5) then begin  {输出找到的第一种方案}
  writeln('ok,thats all right');output;halt;end;
      end;
    end;
  until closed>=open; {直到首指针大于等于尾指针,即所有结点已扩展完}
end.

[此贴子已经被作者于2004-9-12 10:37:24编辑过]

神秘客

【题目】火车调度问题
【参考程序】
const max=10;
type shuzu=array[1..max] of 0..max;
var   stack,exitout:shuzu;
      n,total:integer;

procedure output(exitout:shuzu);
var i:integer;
begin
     for i:=1 to n do write(exitout:2);writeln;
     inc(total);
end;

procedure find(dep,have,rest,exit_weizhi:integer;stack,exitout:shuzu);
{dep:步数,have:入口处有多少辆车;rest:车站中有多少车;}
{exit_weizhi:从车站开出后,排在出口处的位置;}
{stack:车站中车辆情况数组;exitout:出口处车辆情况数组}
var i:integer;
begin  {分入站,出站两种情况讨论}
    if have>0 then begin    {还有车未入站}
       stack[rest+1]:=n+1-have;   {入站}
       if dep=2*n then output(exitout)
  else find(dep+1,have-1,rest+1,exit_weizhi,stack,exitout);
    end;
    if rest>0 then begin    {还有车可出站}
       exitout[exit_weizhi+1]:=stack[rest];   {出站}
       if dep=2*n then output(exitout) {经过2n步后,输出一种方案}
  else find(dep+1,have,rest-1,exit_weizhi+1,stack,exitout);
   end;
end;

begin
     writeln('input n:');
     readln(n);
     fillchar(stack,sizeof(stack),0);
     fillchar(exitout,sizeof(exitout),0);
     total:=0;
     find(1,n,0,0,stack,exitout);
     writeln('total:',total);
     readln;
end.

【解法2】用穷举二进制数串的方法完成.
uses crt;
var i,n,m,t:integer;
    a,s,c:array[1..1000] of integer;
procedure test;
var t1,t2,k:integer;
    notok:boolean;
begin
     t1:=0;k:=0;t2:=0;
     i:=0;
     notok:=false;
     repeat   {二进制数串中,0表示出栈,1表示入栈}
           i:=i+1; {数串中第I位}
           if a=1 then begin {第I位为1,则表示车要入栈}
              inc(k); {栈中车数}
              inc(t1); {入栈记录,T1为栈指针,S为栈数组}
              s[t1]:=k;
            end
           else {第I位为0,车要出栈}
             if t1<1 then notok:=true {已经无车可出,当然NOT_OK了}
                        else begin inc(t2);c[t2]:=s[t1];dec(t1);end;
                       {栈中有车,出栈,放到C数组中去,T2为C的指针,栈指针T1下调1}
     until (i=2*n) or notok; {整个数串均已判完,或中途出现不OK的情况}
     if (t1=0) and not notok then begin  {该数串符合出入栈的规律则输出}
        inc(m);write('[',m,']');
        for i:=1 to t2 do write(c:2);
        writeln;
     end;
end;

begin
     clrscr; write('N=');readln(n);
     m:=0;
     for i:=1 to 2*n do a:=0; {
     repeat {循环产生N位二进制数串}
           test;   {判断该数串是否符合车出入栈的规律}
           t:=2*n;
           a[t]:=a[t]+1; {产生下一个二进制数串}
           while (t>1) and (a[t]>1) do begin
                 a[t]:=0;dec(t);a[t]:=a[t]+1;
           end;
     until a[1]=2;
     readln;
end.
N:       4        6        7         8
TOTAL:  14       132      429       1430

[此贴子已经被作者于2004-9-12 10:38:13编辑过]

神秘客

【题目】农夫过河。一个农夫带着一只狼，一只羊和一些菜过河。河边只有一条一船，由
于船太小，只能装下农夫和他的一样东西。在无人看管的情况下，狼要吃羊，羊
要吃菜，请问农夫如何才能使三样东西平安过河。
【算法分析】
    将问题数字化。用１代表狼，２代表羊，３代表菜。则在河某一边物体的分布有以下
８种情况。
┏━━━━┯━┯━━━━━┯━━━━━━━━┯━━━┓
┃物体个数│０│    １   │    ２     │ ３  ┃
┠────┼─┼─┬─┬─┼──┬──┬──┼───┨
┃分布情况│０│１│２│３│1,2 │1,3 │2,3 │1,2,3 ┃
┠────┼─┼─┼─┼─┼──┼──┼──┼───┨
┃代码之和│０│１│２│３│３ │ ４ │ ５ │ ６  ┃
┠────┼─┼─┼─┼─┼──┼──┼──┼───┨
┃是否相克│  │  │  │  │相克│    │相克│     ┃
┗━━━━┷━┷━┷━┷━┷━━┷━━┷━━┷━━━┛
当（两物体在一起而且）代码和为３或５时，必然是相克物体在一起的情况。

【参考程序】
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]);
     write('|',' ':4);
end;

procedure print_right;{输出右岸的物体}
var i:integer;
begin
     write(' ':4,'|');
     for i:=1 to 3 do if right<>0 then write(wt[right]);
     writeln;
end;

procedure print_back(whinteger);  {右岸矛盾时，需从右岸捎物体→左岸}
var i:integer;
begin
     for i:=1 to 3 do begin
if not ((i=who) or (right=0)) then begin
{要捎回左岸的物体不会时刚刚从左岸带来的物体，也不会是不在右岸的物体}
       what:=right;
       right:=0;
print_left;  {输出返回过程}
write('<-',wt);
print_right;
left:=what;  {物体到达左岸}
end;
     end;
end;



begin
     total:=0;
     for i:=1 to 3 do begin  left:=i; right:=0;end;
     repeat
       for i:=1 to 3 do    {共有３种物体}
if left<>0 then  {第Ｉ种物体在左岸}
  begin
    what:=left;left:=0; {what:放置将要过河的物体编号}
    left_rest:=left[1]+left[2]+left[3];  {求左岸剩余的物体编号总和}
    if (left_rest=3) or (left_rest=5) then left:=what
{假如左岸矛盾，则不能带第Ｉ种过河，尝试下一物体}
       else {否则可带过河}
    begin print_left; {输出过河过程}
  write('->',wt);
  print_right;
  right:=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.

[此贴子已经被作者于2004-9-12 10:39:09编辑过]

神秘客

【题目】七段数码管问题。从一个数字变化到其相邻的数字只需要通过某些段(数目不限)  或拿走某些段(数目不限)来实现.但不允许既增加段又拿起段.
   例如:3可以变到9,也可以变到1

要求1)判断从某一数字可以变到其它九个数字中的哪几个.
     (2)找出一种排列这十个数字的方案,便这样组成的十位数数值最小.
type kkk=set of 0..9;
const a:array[-1..9] of set of 1..7
=([5,6],[1,2,3,4,5,6],[2,3],[1,2,4,5,7],[1,2,3,4,7],[2,3,6,7],
  [1,3,4,6,7],[1,3,4,5,6,7],[1,2,3],[1,2,3,4,5,6,7],[1,2,3,4,6,7]);
var
   i,j:integer;
   b:array[-2..9] of set of 0..9;

procedure number(p:string;s,l:integer;k:kkk);
  {P:生成的数;s:用了几个数字;i:前一个是哪个数字;k:可用的数字}
var i:integer;
begin
     for i:=0 to 9 do
if (i in k) and ( i in b[l]) then begin
{数字i未用过,且i可由前一个采用的数字变化而来}
    if s=10 then begin writeln('Min:',p,i);readln;halt;end
       else number(p+chr(48+i),s+1,i,k-);
end;
end;

begin
     for i:=1 to 9 do b:=[];
     b[-2]:=[0..9];
     for i:=-1 to 8 do
for j:=i+1 to 9 do
     if (a<=a[j]) or (a[j]<=a) then begin
b:=b+[j];
b[j]:=b[j]+[abs(i)];
     end;
b[1]:=b[1]+b[-1];
     for i:=0 to 9 do begin
write(i,' may turn to :');
for j:=0 to 9 do if  j in b then write(j,' ');
writeln;
     end;
     number('',1,-2,[0..9]);
end.

[此贴子已经被作者于2004-9-12 10:40:52编辑过]

神秘客

【题目】 把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;

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+;  {设置已放过标志}
   if (dep=8) then output
       else find(dep+1);
    a[dep]:=10;   {回溯,恢复原状态}
    had:=had-;
end;
   end;
end;

begin
     fillchar(a,sizeof(a),10);
     total:=0; had:=[];
     find(1);
     writeln('End.');
end.

[此贴子已经被作者于2004-9-12 10:41:44编辑过]

神秘客

【题目】 在4×4的棋盘上放置8个棋,要求每一行,每一列上只能放置2个.
【参考程序1】
算法:8个棋子,填8次.深度为8.注意判断是否能放棋子时,两个两个为一行.
var a:array[1..8] of 0..4;
    line,bz:array[1..4] of 0..2; {line数组:每行已放多少个的计数器}
{bz数组:  每列已放多少个的计数器}
    total:integer;
procedure output; {输出}
var i:integer;
begin
     inc(total);  write(total,':   ');
     for i:=1 to 8  do write(a);  writeln;
end;

function ok(dep,i:integer):boolean;
begin
ok:=true;
if dep mod 2 =0 then  {假如是某一行的第2个,其位置必定要在第1个之后}
    if (i<=a[dep-1])  then ok:=false;
if (bz=2) or(line[dep div 2]=2) then ok:=false;
{某行或某列已放满2个}
end;

procedure find(dep:integer);
var i:integer;
begin
     for i:=1 to 4 do begin
if ok(dep,i) then   begin
    a[dep]:=i; {放在dep行i列}
    inc(bz);    {某一列记数器加1}
    inc(line[dep div 2]);  {某一行记数器加1}
    if dep=8 then output else find(dep+1);
    dec(bz);  {回溯}
    dec(line[dep div 2]);
    a[dep]:=0;
end;
     end;
end;

begin
     total:=0; fillchar(a,sizeof(a),0); fillchar(bz,sizeof(bz),0);
     find(1);
end.
【参考程序2】
算法:某一行的放法可能性是(1,2格),(1,3格),(1,4格)....共6种放法
const
fa:array[1..6] of array[1..2]of 1..4=((1,2),(1,3),(1,4),(2,3),(2,4),(3,4));
{六种可能放法的行坐标}
var
a:array[1..8] of 0..4;
bz:array[1..4] of 0..2; {列放了多少个的记数器}
total:integer;
procedure output;
var i:integer;
begin
     inc(total);
     write(total,':   ');
     for i:=1 to 8  do write(a);
     writeln;
end;

function ok(dep,i:integer):boolean;
begin
ok:=true;  {判断现在的放法中,相应的两列是否已放够2个}
if (bz[fa[i,1]]=2) or (bz[fa[i,2]]=2) then ok:=false;
end;

procedure find(dep:integer);
var i:integer;
begin
     for i:=1 to 6 do begin  {共有6种可能放法}
if ok(dep,i) then   begin
    a[(dep-1)*2+1]:=fa[i,1];{一次连续放置2个}
    a[(dep-1)*2+2]:=fa[i,2];
    inc(bz[fa[i,1]]);      {相应的两列,记数器均加1}
    inc(bz[fa[i,2]]);
    if dep=4 then output else find(dep+1);
    dec(bz[fa[i,1]]);       {回溯}
    dec(bz[fa[i,2]]);
    a[(dep-1)*2+1]:=0;
    a[(dep-1)*2+2]:=0;
end;
     end;
end;

begin
     total:=0; fillchar(a,sizeof(a),0);    fillchar(bz,sizeof(bz),0);
     find(1);
end.

[此贴子已经被作者于2004-9-12 10:42:27编辑过]

神秘客

【题目】迷宫问题.求迷宫的路径.(深度优先搜索法)
【参考程序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:曾走过但不通的路}
     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.

神秘客

【题目】一笔画问题
从某一点出发,经过每条边一次且仅一次.(具体图见高级本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),
(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);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);inc(zongbianshu);end;
     {求与每一边连接的边数bianshu}
     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;       {回溯}
    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.

[此贴子已经被作者于2004-9-12 10:43:52编辑过]

神秘客

【题目】城市遍历问题.
给出六个城市的道路连接图,找出从某一城市出发,遍历每个城市一次且仅一次的最短路径
及其路程长度.(图见高级本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:=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);writeln; {输出某个城市出发的最短方案}
   end;
end.

[此贴子已经被作者于2004-9-12 10:44:35编辑过]

神秘客

【题目】棋子移动问题
[参考程序]
const
     n=3; {n<5}
type
    ss=string[2*n+1];
    ar=array[1..630]of ss;
var
   a:ar;
   f,z:array[1..630] of integer;
   i,j,k,m,h,t,k1:integer;
   s,d:ss;
   q:boolean;


procedure print (x:integer);
var t:array[1..100] of integer;
    y:integer;
begin
     y:=0;
     repeat
           y:=y+1;
           t[y]:=x;
           x:=f[x];
     until x=0;
     writeln(a[t[y]]:2*n+4);
     writeln(copy('-------------------------',1,2*n+5));
     for x:=2 to y do writeln(x-1:2,':',a[t[y+1-x]]);
end;

begin
     s:='_';d:='_';
     for i:=1 to n do begin
         s:='o'+s+'*';
         d:='*'+d+'o';
     end;
     a[1]:=s;f[1]:=0;z[1]:=n+1;
     q:=false;
     i:=1;j:=2; t:=0;
     repeat
       for h:=1 to 4 do begin
               k:=z;k1:=k;s:=a;
               case h of
                1:if k>1 then k1:=k-1;
                2:if k<(2*n+1) then k1:=k+1;
                3:if (k>2) and (s[k-1]<>s[k-2]) then  k1:=k-2;
                4:if (k<(2*n)) and(s[k+1]<>s[k+2]) then k1:=k+2;
               end;
           if k<>k1 then begin
              s[k]:=s[k1];s[k1]:='_';
              m:=1;
              while (a[m]<>s) and (m< j-1) do m:=m+1;
              if a[m] >>s then begin
                 a[j]:=s;f[j]:=i;z[j]:=k1;
                 if s=d then begin
                    print(j);
                    q:=true;
                 end;
                 j:=j+1;
              end;
           end;
     end; {end for}
     i:=i+1;
  until q or (i=j);
readln;
end.

[此贴子已经被作者于2004-9-12 10:45:51编辑过]

神秘客

【题目】求集合元素问题（1,2x+1,3X+1类)
某集合Ａ中的元素有以下特征：
(1)数1是A中的元素
(2)如果X是A中的元素,则2x+1,3x+1也是A中的元素
(3)除了条件(1),(2)以外的所有元素均不是A中的元素
[参考程序1]
uses crt,dos;
var a:array[1..10000]of longint;
    b:array[1..10000]of boolean;
    times,n,m,long,i:longint;
    hour1,minute1,second1,sec1001:word;
   hour2,minute2,second2,sec1002:word;

begin
     write('N=');readln(n);
{     gettime(hour1,minute1,second1,sec1001);
     times:=minute1*60+second1;
     writeln(minute1,':',second1);}

     fillchar(b,sizeof(b),0);
     a[1]:=1;m:=2;long:=1;
     while long<=n do begin
           for i:=1 to long do
               if (a*2=m-1) or (a*3=m-1) then
                 if not b[m] then begin
                  inc(long);a[long]:=m;b[m]:=true;break;
               end;
           inc(m);
     end;
{     gettime(hour2,minute2,second2,sec1002);
     times:=minute2*60+second2-times;
     writeln(minute2,':',second2);

     writeln('Ok! Uses Time: ',times);}

     for i:=1 to n do write(a,' ');
readln;
end.

[参考程序2]
uses crt;
const n=10000;
var a:array[1..n] of longint;
    i,j,k,l,y:longint;
begin
     clrscr;
     fillchar(a,sizeof(a),0);
     i:=1;j:=1;
     a:=1;
     repeat
           y:=2*a+1;
           k:=j;
           while y〈a[k] do begin
                 a[k+1]:=a[k];
                 k:=k-1;
           end;
           if y>a[k] then begin
              a[k+1]:=y;j:=j+1;
              end
           else for l:=k+1 to j do a[l]:=a[l+1];
           j:=j+1;
           a[j]:=3*a+1;
           inc(i);
     until k>=n;
     for i:=1 to n do begin
         write(a,' ');
         if (i mod 10 =0 ) or (i=n) then writeln
     end;
end.

[参考程序3]
uses crt;
var a:array[1..10000]of longint;
    n,i,one,another,long,s,x,y:longint;
begin
     write('n=');readln(n);
     a[1]:=1;long:=1;one:=1;another:=1;
     while long y then begin s:=y;inc(another);end
                   else begin s:=x;inc(one);inc(another);end;
           inc(long);a[long]:=s;
     end;
     for i:=1 to n do write(a,' ');
end.
[参考程序4]
var n:integer;
    top,x:longint;
function init(x:longint):boolean;
begin
     if x=1 then init:=true
        else if((x-1)mod 2=0)and(init((x-1)div 2))
                     or((x-1)mod 3=0)and(init((x-1)div 3))then
             init:=true
             else init:=false;
end;
begin
     write('input n:');
     readln(n);
     x:=0;
     top:=0;
     while top< n do begin
           x:=x+1;
           if init(x) then
              top:=top+1;
              write(x:8);
           end;
     write('output end.');
     readln
end.

[此贴子已经被作者于2004-9-12 10:46:09编辑过]

神秘客

说明：
来自“广州六中信息学基地”

神秘客

补充：
【题目】把自然数Ｎ分解为若干个自然数之和。
【参考答案】
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去试}
      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.

gongyilun

这些题目我都已经滚瓜烂熟了，
最好来一点新的题目！！！