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.