unit Unit1;
{
  A farmer has to row a cabbage, a goat and a wolf to the other side
  of the river.
  The boat only has space for 1 passenger.
  The goat and the wolf may not be left alone: the wolf would eat the goat.
  The cabbage and the goat may not be left alone: the goat would eat the cabbage.
  What to do?
  This program finds the solution.

  data
  situation   farmer    x - - -           x=0 :  left bank
              cabbage   - x - -           x=1 : right bank
              goat      - - x -
              wolf      - - - x

  action  0: nothing                    code: 0000
          1: farmer + cabbage rowing          1100
          2: farmer + goat                    1010
          3: farmer + wolf                    1001
          4: farmer                           1000

  actionlist:   array of action codes

  start situation :  0000
  end situation   :  1111

  illegal situations: 0011, 0110, 0111, 1000, 1001, 1100

  solution : xor action codes with situation avoiding illegal situations.

  crossList is counter holding indexes to actionCode array

  This is a "brute force" search method:  all moves are systematically counted
  until the solution is encountered.

  History List: entry for each situation if situation was passed before
  Reaching same situation at later move is illegal.
  This avoids repetion of moves.
}

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Buttons, ExtCtrls;

type
  TForm1 = class(TForm)
    listbox: TPaintBox;
    resetBtn: TBitBtn;
    goBtn: TBitBtn;
    msglabel: TLabel;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    procedure resetBtnClick(Sender: TObject);
    procedure goBtnClick(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure listboxPaint(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

type TCrossStatus = (csStart,csSolution,csEnd);

const maxcross = 20;
      maxItem = 4;
      maxSit = (1 shl maxItem) - 1;

var situation : byte;
    crossList : array[1..maxcross] of byte;
    crossNr : byte;
    legal : array[0..maxSit] of boolean;
    actionCode : array[0..4] of byte;
    maxactionCode : byte;
    history : array[0..maxSit] of boolean;
    solutionNr : byte;
    crossStatus : TCrossStatus;

//low level helpers

procedure paintframe(pb : Tpaintbox);
//paint edges on form1 around paintbox pb
var x1,y1,x2,y2 : word;
    i : byte;
begin
 with pb do
  begin
   x1 := left - 2;
   x2 := left + width + 1;
   y1 := top - 2;
   y2 := top + height + 1;
  end;
 with form1.Canvas do
  begin
   pen.Width := 1;
   for i := 0 to 1 do
    begin
     pen.Color := $000000;
     moveto(x2-i,y1+i);
     lineto(x1+i,y1+i);
     lineto(x1+i,y2-i);
     pen.color := $808080;
     lineto(x2-i,y2-i);
     lineto(x2-i,y1+i);
    end;
  end;
end;

procedure clearbox(pb : Tpaintbox);
//make paintbox white
begin
 with pb do with canvas do
  begin
   brush.Style := bsSolid;
   brush.Color := $ffffff;
   fillrect(rect(0,0,width,height));
  end;
end;

//solution

procedure generateLegals;
//set legal bit n to "1" if situation is legal
var i : byte;
    ill,F,C,G,W,NF,NC,NG,NW : boolean;
begin
 for i := 0 to maxSit do
  begin
   F := (i and $8) > 0;
   NF := not F;
   C := (i and $4) > 0;
   NC := not C;
   G := (i and $2) > 0;
   NG := not G;
   W := (i and $1) > 0;
   NW := not W;
   ill := NF and ((C and G) or (G and W));
   if ill = false then
    ill := F and ((NC and NG) or (NG and NW));
   legal[i] := not ill;
  end;
end;

procedure generateActionCodes;
var i : byte;
begin
 actionCode[0] := 0;
 for i := 1 to 3 do actionCode[i] := $8 or (1 shl (3-i));
 actionCode[4] := $8;
 maxActionCode := 4;
end;

procedure resetAll;
var i : byte;
begin
 history[0] := true;
 for i := 1 to maxSit do history[i] := false;
 for i := 1 to maxcross do crosslist[i] := 0;
 situation := 0;
 crossNr := 0;
 crossStatus := csStart;
 solutionNr := 0;
end;

function crossOK(ac,nr : byte) : boolean;
//return true if action ac is possible
//test FCGW positions, illegal situtions, situation was met before
var pos,newsituation,code : byte;
begin
 code := actioncode[ac];
 pos := situation and code;                    //test items on proper bank
 if (nr and 1) = 1 then result :=  (pos = 0)
  else result := (pos = code);
 newsituation := situation xor code;
 if result then
  result := legal[newsituation];
 if result then result := (history[newsituation] = false);//avoid repetition
end;

function FindSolution(cs : TcrossStatus) : TCrossStatus;
label testCross,nextChoice,crossback;
var ac : byte;
begin
 if cs = csEnd then
  begin
   result := csEnd;
   exit;
  end;
 if cs = csSolution then goto crossBack;

 crossNr := 1;
 ac := 1;

testCross :

 if crossOK(ac,crossNr) = false then goto nextChoice;

//row to opposite bank

 crossList[crossNr] := ac;
 situation := situation xor actionCode[ac];
 history[situation] := true;

//test solution

 if situation = maxSit then
  begin
   result := csSolution;
   exit;
  end;

 if crossNr = maxCross then goto crossBack;

 inc(crossNr);
 ac := 1;
 goto testCross;

nextChoice:

 if ac < maxActionCode then
  begin
   inc(ac);
   goto  testCross;
  end;

 if crossNr = 1 then
  begin
   result := csEnd;
   exit;
  end;

 history[situation] := false;
 situation := situation xor actionCode[crossList[crossNr]];
 crossList[crossNr] := 0;
 dec(crossNr);

crossBack:

  history[situation] := false;
  ac := crossList[crossNr];
  situation := situation xor actionCode[ac];
  crossList[crossNr] := 0;
  goto nextChoice;

end;

function code2string(c : byte) : string;
//convert FCGW code to string
begin
 result := '';
 if (c and $8) > 0 then result := result + 'F';
 if (c and $4) > 0 then result := result + 'C';
 if (c and $2) > 0 then result := result + 'G';
 if (c and $1) > 0 then result := result + 'W';
end;

procedure listSolution;
var acode,i,line,pos : byte;
         s : string;
         w : word;
begin
 line := 0;
 clearbox(form1.listbox);
 with form1.listbox.canvas do
  begin
   font.name := 'arial';
   font.height := 18;
   font.style := [];
   font.Color := $000000;
   brush.style := bsClear;
   pos := 0;
   for i := 1 to crossNr do
    begin
     s := inttostr(line+1);
     w := textwidth(s);
     textout(25-w,line*20,s);
     acode := actionCode[crossList[i]];
     s := code2string(pos xor maxSit);   //left bank
     textout(45,line*20,s);
     if (i and 1) = 0 then s := ' <-- ' else s := '';
     s := s + code2string(acode);
     if (i and 1) > 0 then s := s + ' -->';
     textout(140,line*20,s);
     s := code2string(pos);
     textout(240,line*20,s);
     pos := pos xor acode;
     inc(line);
    end;
   s := code2string(pos);
   textout(240,line*20,s);
  end;
end;

//events

procedure TForm1.FormCreate(Sender: TObject);
begin
 msglabel.Caption := 'press GO for solution';
 resetAll;
 generateLegals;
 generateActionCodes;
end;

procedure TForm1.resetBtnClick(Sender: TObject);
begin
 clearbox(listbox);
 resetAll;
 msglabel.caption := 'press GO for solution';
end;

procedure TForm1.goBtnClick(Sender: TObject);
begin
 crossStatus := FindSolution(crossStatus);
 case crossStatus of
  csSolution : begin
                inc(solutionNr);
                msglabel.Caption := 'Solution '+inttostr(solutionNr)+
                                    ' found. Press GO for more';
                listsolution;
               end;
  csEnd      : msglabel.Caption := 'No more solutions. Press restart';
 end;//case
end;

//paints

procedure TForm1.FormPaint(Sender: TObject);
begin
 paintframe(listbox);
end;

procedure TForm1.listboxPaint(Sender: TObject);
begin
 clearbox(listbox);
 Listsolution;
end;

end.