unit Unit1;

  The 3 jealous husbands problem.
  Three jealous husbands (and their wives) have to cross a river.
  The boat allows for 2 passengers.
  The husbands do not allow their wive in companion with another man without
  supervision.
  Both man anf woman may row the boat.
  How is this rivercrossing to be realized?
  This program finds the solution.

  Note: see the rivercross1 problem (farmer, cabbage, goat and wolf)
  This code is almost the same, data is different.

  data
  situation   husband A    x - - - - -   x=0 :  left bank
              wife a       - x - - - -   x=1 : right bank
              husband B    - - x - - -
              wife b       - - - x - -
              husband C    - - - - x -
              wife c       - - - - - x

  action  0: nothing                    code: 00 00 00
          1: Aa rowing                        11 00 00
          2: .........
          etc.

  actionlist:   array of action codes

  start situation :  00 00 00
  end situation   :  11 11 11

  find solution : xor action codes with situation avoiding illegal situations.

  crossList is counter holding indexes to actionList array

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

  History List: entry for each situation indicating situation was reached before.
  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;
    procedure resetBtnClick(Sender: TObject);
    procedure goBtnClick(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure listboxPaint(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

type TCrossStatus = (csStart,csSolution,csEnd);

const maxcross = 20;
      maxItem = 6;
      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..32] of byte;
    maxActionCode : byte;
    history : array[0..maxsit] of boolean;
    solutionNr : word;
    crossStatus : TCrossStatus;
    stopflag : boolean;  //debug
    exitflag : boolean;

procedure listSolution;forward;    

//low level helpers

procedure debugstop;
begin
 if exitflag then exit;
 stopflag := true;
 form1.msglabel.Caption := 'STOP... to continue';
 while stopflag do application.ProcessMessages;
end;

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;
    mA,fA,mB,fB,mC,fC,nmA,nfA,nmB,nfB,nmC,nfC : boolean;
    ill : boolean;
begin
 for i := 0 to maxsit do
  begin
   mA := (i and $20) > 0;
   nmA := not mA;
   fA:= (i and $10) > 0;
   nfA := not fA;
   mB := (i and $8) > 0;
   nmB := not mB;
   fB := (i and $4) > 0;
   nfB := not fB;
   mC := (i and $2) > 0;
   nmC := not mC;
   fC := (i and $1) > 0;
   nfC := not fC;
   ill := (nmA and fA and (mB or mC)) or
          (nmB and fB and (mA or mC)) or
          (nmC and fC and (mA or mB)) or
          (mA and nfA and (nmB or nmC)) or
          (mB and nfB and (nmA or nmC)) or
          (mC and nfC and (nmA or nmB));
   legal[i] := not ill;
  end;
end;

procedure generateActionCodes;
var ac,i,j : byte;
    mA,fA,mB,fB,mC,fC : boolean;
    ill : boolean;
begin
 maxActionCode := 0;
 actionCode[maxActionCode] := 0;
 for i := 1 to 5 do                       //2 passengers actions
  for j := i+1 to 6 do
   begin
    ac := (1 shl (6-i)) or (1 shl (6-j)); //action code
    mA := (ac and $20) > 0;               //male A
    fA := (ac and $10) > 0;               //female a
    mB := (ac and $8)  > 0;
    fB := (ac and $4)  > 0;
    mC := (ac and $2)  > 0;
    fC := (ac and $1)  > 0;
    ill := (mA and (fB or fC)) or         //illegal
           (mB and (fA or fC)) or
           (mC and (fA or fB));
    if ill = false then
     begin
      inc(maxActionCode);
      actionCode[maxActionCode] := ac;
     end;
   end;
 for i := 1 to 6 do                       //1 passenger actions
  begin
   inc(maxActionCode);
   actionCode[maxActionCode] := (1 shl (6-i));
  end;
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;
 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
 result := csEnd;
 if cs = csEnd then exit;
 if cs = csSolution then goto crossBack;

 crossNr := 1;
 ac := 1;
 situation := 0;

testCross :

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

//row to opposite bank

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

//-----debug  start
{
 if exitflag then exit;
 clearbox(form1.listbox);
 listSolution;
 debugStop;
}

//----debug end

//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]]; //remove
 crossList[crossNr] := 0;
 dec(crossNr);

crossBack:

  ac := crossList[crossNr];
  history[situation] := false;
  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 $20) > 0 then result := result + 'A';
 if (c and $10) > 0 then result := result + 'a';
 if (c and $8)  > 0 then result := result + 'B';
 if (c and $4)  > 0 then result := result + 'b';
 if (c and $2)  > 0 then result := result + 'C';
 if (c and $1)  > 0 then result := result + 'c';
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(40-w,line*20,s);
     acode := actionCode[crossList[i]];
     s := code2string(pos xor $3f);   //left bank
     textout(60,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(160,line*20,s);
     s := code2string(pos);
     textout(260,line*20,s);
     pos := pos xor acode;
     inc(line);
    end;
   s := code2string(pos xor $3f);
   textout(60,line*20,s);
   s := code2string(pos);
   textout(260,line*20,s);
  end;
end;

//events

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

procedure TForm1.resetBtnClick(Sender: TObject);
begin
 clearbox(listbox);
 resetAll;
 msglabel.caption := 'press GO for solution';
 activecontrol := nil;
 exitflag := true;
 stopflag := false;
end;

procedure TForm1.goBtnClick(Sender: TObject);
begin
 if stopflag then exit; //if debug in progress
 exitflag := false;
 crossStatus := FindSolution(crossStatus);
 case crossStatus of
  csSolution : begin
                inc(solutionNr);
                msglabel.Caption := 'Solution '+inttostr(solutionNr)+
                                    '. Press GO for more';
                listsolution;
               end;
  csEnd      : msglabel.Caption := 'No more solutions. Press restart';
 end;//case
 activecontrol := nil;
end;

//paints

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

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

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
 if key = VK_SPACE then
  begin
   stopflag := false; //exit stop mode
   key := 0;
  end;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
 stopflag := false; //exit debug stop
 exitflag := true;
end;

end.