农夫过河问题 .txt

农夫过河问题的广度优先搜索算法的PASCAL程序

农夫过河问题 

有一个农夫带一条狼、一只羊和一棵白菜过河。如果没有农夫看管，则狼要吃羊，羊要吃白菜。但是船很小，只够农夫带一样东西过河。问农夫该如何解此难题？ 

分析：以向量（人，狼，羊，菜）表示状态，其中每个变元可取0或1，取0表示在左岸（出发点），取1表示在右岸，则我们有八个规则： 
              （0，*，*，*）--->（1，*，*，*）         （1） 
              （0，0，*，*）--->（1，1，*，*）         （2） 
              （0，*，0，*）--->（1，*，1，*）         （3） 
              （0，*，*，0）--->（1，*，*，1）         （4） 
              （1，*，*，*）--->（0，*，*，*）         （5） 
              （1，1，*，*）--->（0，0，*，*）         （6） 
              （1，*，1，*）--->（0，*，0，*）         （7） 
              （1，*，*，1）--->（0，*，*，0）         （8） 
注：每个*号可以是任意的0或1，但是在每条规则内部，左边和右边的对应*号应取相同值。 
将这八个规则存储在一个二维数组rule(8,4)中，易知该数组的内容是： 
              （1，  0， 0， 0） 
              （1，  1， 0， 0） 
              （1，  0， 1， 0） 
              （1，  0， 0， 1） 
              （1，  0， 0， 0） 
              （-1， 0， 0， 0） 
              （-1，-1， 0， 0） 
              （-1， 0，-1， 0） 
              （-1， 0， 0，-1） 
初态是：（0，0，0，0），终态是：（1，1，1，1）， 
非法中间状态有：（0，0，1，1），（0，1，1，0），（0，1，1，1）， 
                （1，1，0，0），（1，0，0，1），（1，0，0，0）。 
相应的广度优先搜索算法的PASCAL程序如下： 
program farmer(output); 
{programmer: Cheng Zhengxian    Date: 1995.1} 
  const rule:array[1..8,1..4] of -1..1=((1,0,0,0),(1,1,0,0),(1,0,1,0),(1,0,0,1), 
                                        (-1,0,0,0),(-1,-1,0,0),(-1,0,-1,0),(-1,0,0,-1)); 
  type stype=string[4]; 
  var s:array[1..100] of record 
                           info:stype; 
                           rn:0..8; 
                           father:integer; 
                         end; 
      ob,mr:stype; 
      j,closed,open:integer; 
  procedure op; 
    var pre1,pre2,k,c:integer; 
    begin 
      writeln;writeln;c:=0; 
      k:=open;pre1:=s[k].father;s[k].father:=0; 
      repeat 
        pre2:=s[pre1].father;s[pre1].father:=k; 
        k:=pre1;pre1:=pre2; 
      until pre1=0; 
      k:=1; 
      repeat 
        writeln('Step ',c,':',s[k].info:20,s[k].rn:10); 
        k:=s[k].father;inc(c); 
      until k=0; 
      readln;halt; 
    end; 
  function extend(var mr:stype):boolean; 
    var f:boolean; 
        k,x:integer; 
        ss:stype; 
    begin 
      ss:=s[closed].info;mr:='';f:=true; 
      for k:=1 to 4 do 
        begin 
          x:=ord(ss[k])-ord('0')+rule[j,k]; 
          if (x<0) or (x>1) then f:=false; 
          mr:=mr+chr(x+ord('0')); 
        end; 
      extend:=f; 
    end; 
  function passchk:boolean; 
    var f:boolean; 
        k:integer; 
    begin 
      f:=true; 
      for k:=1 to 4 do 
        if ((mr[2]=mr[3])and(mr[2]<>mr[1])) or ((mr[4]=mr[3])and(mr[3]<>mr[1])) 
        then f:=false; 
      if f then 
        for k:=1 to open-1 do 
          if mr=s[k].info then f:=false; 
      passchk:=f; 
    end; 
  Begin {=========================main program=============================} 
    ob:='1111'; 
    closed:=0;open:=1; 
    s[1].info:='0000';s[1].rn:=0;s[1].father:=0; 
    repeat 
      j:=0;closed:=closed+1; 
      repeat 
        j:=j+1;mr:=''; 
        if extend(mr) and passchk then 
        begin 
          open:=open+1; 
          s[open].info:=mr;s[open].rn:=j;s[open].father:=closed; 
          if mr=ob then op; 
        end; 
      until j=8; 
    until closed=open; 
    writeln('No solution!'); 
  End.