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.