123 Eng

Engineering the engineers™


Latest Jobs   Forum Map

 


Home
Source Codes
Engineering Colleges
Training  Reports
Seminar Reports
Placement Papers
Forums
   Computer Science / IT
   Electronics
   Electrical
   Mechanical
   Chemical
   Civil
   CAT / MBA
   GMAT / Foreign MBA
Latest Jobs

Engineering Jobs / Technical Jobs
Management Jobs

Sitemap
Terms of use

Displaying  Source Code(s)  
 

 
Recursive Monkey Puzzle Solution - Project
--------------------------------------------------------------------------------

Description : A recursive solution for a particular form of monkey puzzle called "To The Extreme" by Lagoon Games. There are 523,069,747,249 incorrect combinations - and just one correct combination! Program typically takes 2-3 seconds to solve the puzzle from scratch.

////////////////////////////////////////////////////////////////////////////////
// 'To The Extreme' Puzzle - Solved! Copyright © 2005 Maxim C.L. Warne
//
//
//
// A recursive solution for 'Professor McBrainy's Zany to the Extreme Puzzle' //
// This puzzle is a traditional 'monkey puzzle' - with surfers, skaters etc. //
// substituted for the poor monkeys. Its grid is 4x4, giving 529,069,747,249 //
// incorrect combinations, and one correct combination.
//
//
//
// Usage: Just call TTESolve (2 or 3 seconds on a modern computer), then
//
// iterate over TTEBoard calling TTEPieceAsText on each element to produce
//
// human-friendly output. Note that TTEInitialize randomizes the order and
//
// rotation of the pieces, so TTESolve starts from scratch each time -hence //
// the running time of TTESolve varies.
//
//
//
// Unit originally authored using Delphi 6, but uses no VCL or OO so should //
// port without trouble to just about any flavour of Pascal.
//
////////////////////////////////////////////////////////////////////////////////

interface
type
TTTESide = (NULL, SURF_BLACK, SURF_BLONDE, SKATE_GREEN, SKATE_RED ,
SNOW_GREEN, SNOW_MAUVE , WIND_BLACK , WIND_BLONDE);
TTTEPiece = array[0..3] of TTTESide;
TTTEPieceList = array[0..15] of TTTEPiece;
TTTEPieces = packed record
LastPiece: ShortInt;
PieceList: TTTEPieceList;
end;

procedure TTEInitialize;
function TTESolve: string;
procedure TTERecurrence(MyPieces: TTTEPieces);
function TTEPieceFits: Boolean;
procedure TTERotatePiece;
procedure TTEInsertIntoBoard(var ThePieces: TTTEPieces; const PieceIdx:
Integer);
procedure TTERemoveFromBoard(var ThePieces: TTTEPieces; const PieceIdx:
Integer);
function TTEPieceAsText(const ThePiece: TTTEPiece): string;

////////////////////////////////////////////////////////////////////////////////

implementation
const
TTE_3SIDE_SIZE: Integer = SizeOf(TTTESide) * 3;
TTE_PIECE_SIZE: Integer = SizeOf(TTTEPiece);
TTE_PIECES : TTTEPieces =
(LastPiece: 15;
PieceList: ((SURF_BLACK , WIND_BLACK , WIND_BLONDE, SKATE_GREEN),
(SNOW_GREEN , WIND_BLACK , WIND_BLONDE, SKATE_GREEN),
(SURF_BLACK , WIND_BLONDE, WIND_BLACK , SKATE_RED ),
(SURF_BLACK , WIND_BLONDE, WIND_BLACK , SURF_BLACK ),
(SURF_BLONDE, SURF_BLACK , WIND_BLACK , SKATE_RED ),
(WIND_BLONDE, SKATE_GREEN, WIND_BLACK , WIND_BLONDE),
(SKATE_GREEN, SNOW_GREEN , WIND_BLACK , WIND_BLONDE),
(WIND_BLACK , WIND_BLONDE, WIND_BLACK , SURF_BLONDE),
(SURF_BLONDE, SKATE_RED , SURF_BLACK , SURF_BLACK ),
(SKATE_GREEN, SURF_BLONDE, SNOW_MAUVE , SKATE_GREEN),
(SNOW_MAUVE , SKATE_RED , SNOW_GREEN , SNOW_GREEN ),
(SURF_BLACK , WIND_BLONDE, WIND_BLONDE, WIND_BLACK ),
(WIND_BLACK , SKATE_RED , WIND_BLONDE, SKATE_GREEN),
(SURF_BLACK , WIND_BLACK , WIND_BLONDE, WIND_BLACK ),
(SURF_BLACK , WIND_BLACK , WIND_BLONDE, WIND_BLACK ),
(SURF_BLACK , SURF_BLACK , WIND_BLONDE, WIND_BLACK )));

var
TTEPieces: TTTEPieces;
TTEBoard : TTTEPieces;
TTESolved: Boolean;

////////////////////////////////////////////////////////////////////////////////

procedure TTEInitialize;
var LoopA, LoopB, Temp: Integer;
begin
Randomize;
TTESolved := False;
TTEPieces := TTE_PIECES;
TTEBoard.LastPiece := 0;
for LoopA := 0 to 15 do
begin
repeat Temp := Random(16) until Temp <> LoopA;
TTEBoard.PieceList[0] := TTEPieces.PieceList[LoopA];
for LoopB := 1 to Random(4) do TTERotatePiece;
TTEPieces.PieceList[LoopA] := TTEPieces.PieceList[Temp];
TTEPieces.PieceList[Temp] := TTEBoard.PieceList[0];
end;
TTEBoard.LastPiece := -1;
end;

function TTESolve: string;
var Loop: Integer;
begin
TTEInitialize;
TTERecurrence(TTEPieces);
Result := 'Solution ...'#13#10#13#10;
for Loop := 0 to 15 do
Result := Result + TTEPieceAsText(TTEBoard.PieceList[Loop]) +
#13#10;
end;

procedure TTERecurrence(MyPieces: TTTEPieces);
var Index, Loop: Integer;
begin
if MyPieces.LastPiece < 0 then TTESolved := True
else
begin
Index := 0;
while Index <= MyPieces.LastPiece do
begin
TTEInsertIntoBoard(MyPieces, Index);
if TTEPieceFits then
begin
TTERecurrence(MyPieces);
if TTESolved then Exit;
end;
for Loop := 1 to 3 do
begin
TTERotatePiece;
if TTEPieceFits then
begin
TTERecurrence(MyPieces);
if TTESolved then Exit;
end;
end;
TTERemoveFromBoard(MyPieces, Index);
Inc(Index);
end;
end;
end;

procedure TTERotatePiece;
var TempSide: TTTESide;
begin
TempSide := TTEBoard.PieceList[TTEBoard.LastPiece][3];
Move(TTEBoard.PieceList[TTEBoard.LastPiece][0],
TTEBoard.PieceList[TTEBoard.LastPiece][1], TTE_3SIDE_SIZE);
TTEBoard.PieceList[TTEBoard.LastPiece][0] := TempSide;
end;

procedure TTEInsertIntoBoard(var ThePieces: TTTEPieces; const PieceIdx:Integer);
var ThePiece: TTTEPiece;
begin
ThePiece := ThePieces.PieceList[PieceIdx];
Move(ThePieces.PieceList[PieceIdx + 1],
ThePieces.PieceList[PieceIdx],
(ThePieces.LastPiece - PieceIdx) *
TTE_PIECE_SIZE);
Dec(ThePieces.LastPiece);
Inc(TTEBoard.LastPiece);
TTEBoard.PieceList[TTEBoard.LastPiece] := ThePiece;
end;

procedure TTERemoveFromBoard(var ThePieces: TTTEPieces; const PieceIdx:Integer);
begin
Move(ThePieces.PieceList[PieceIdx], ThePieces.PieceList[PieceIdx + 1],
(ThePieces.LastPiece - PieceIdx + 1) * TTE_PIECE_SIZE);
ThePieces.PieceList[PieceIdx] := TTEBoard.PieceList[TTEBoard.LastPiece];
Inc(ThePieces.LastPiece);
Dec(TTEBoard.LastPiece);
end;

function TTEPieceFits: Boolean;
begin
case TTEBoard.LastPiece of
0: Result := True;
1: Result := TTEBoard.PieceList[0][1] = TTEBoard.PieceList[1][3];
2: Result := TTEBoard.PieceList[1][1] = TTEBoard.PieceList[2][3];
3: Result := TTEBoard.PieceList[2][1] = TTEBoard.PieceList[3][3];
4: Result := TTEBoard.PieceList[0][2] = TTEBoard.PieceList[4][0];
5: Result := (TTEBoard.PieceList[1][2] = TTEBoard.PieceList[5][0])
and (TTEBoard.PieceList[4][1] = TTEBoard.PieceList[5][3]);
6: Result := (TTEBoard.PieceList[2][2] = TTEBoard.PieceList[6][0])
and (TTEBoard.PieceList[5][1] = TTEBoard.PieceList[6][3]);
7: Result := (TTEBoard.PieceList[3][2] = TTEBoard.PieceList[7][0])
and
(TTEBoard.PieceList[6][1] =
TTEBoard.PieceList[7][3]);
8: Result := TTEBoard.PieceList[4][2] =
TTEBoard.PieceList[8][0];
9: Result := (TTEBoard.PieceList[5][2] =
TTEBoard.PieceList[9][0])
and
(TTEBoard.PieceList[8][1] =
TTEBoard.PieceList[9][3]);
10: Result := (TTEBoard.PieceList[6][2] =
TTEBoard.PieceList[10][0])
and
(TTEBoard.PieceList[9][1] =
TTEBoard.PieceList[10][3]);
11: Result := (TTEBoard.PieceList[7][2] =
TTEBoard.PieceList[11][0])
and
(TTEBoard.PieceList[10][1] =
TTEBoard.PieceList[11][3]);
12: Result := TTEBoard.PieceList[8][2] =
TTEBoard.PieceList[12][0];
13: Result := (TTEBoard.PieceList[9][2] =
TTEBoard.PieceList[13][0])
and
(TTEBoard.PieceList[12][1] =
TTEBoard.PieceList[13][3]);
14: Result := (TTEBoard.PieceList[10][2] =
TTEBoard.PieceList[14][0])
and
(TTEBoard.PieceList[13][1] =
TTEBoard.PieceList[14][3]);
15: Result := (TTEBoard.PieceList[11][2] =
TTEBoard.PieceList[15][0])
and
(TTEBoard.PieceList[14][1] =
TTEBoard.PieceList[15][3]);
else
Result := False;
end;
end;

function TTEPieceAsText(const ThePiece: TTTEPiece): string;
var Loop: Integer;
begin
Result := '[ ';
for Loop := 0 to 2 do
case ThePiece[Loop] of
SURF_BLACK : Result := Result + 'Surfer-Black-Hair, ' ;
SURF_BLONDE: Result := Result + 'Surfer-Blonde-Hair, ' ;
SKATE_GREEN: Result := Result + 'Skater-Green-Top, ' ;
SKATE_RED : Result := Result + 'Skater-Red-Top, ' ;
SNOW_GREEN : Result := Result + 'Snowboarder-Green-Top, ' ;
SNOW_MAUVE : Result := Result + 'Snowboarder-Mauve-Top, ' ;
WIND_BLACK : Result := Result + 'Windsurfer-Black-Hair, ' ;
WIND_BLONDE: Result := Result + 'Windsurfer-Blonde-Hair, ';
else Result := Result + 'null, ';
end;
case ThePiece[3] of
SURF_BLACK : Result := Result + 'Surfer-Black-Hair ]' ;
SURF_BLONDE: Result := Result + 'Surfer-Blonde-Hair ]' ;
SKATE_GREEN: Result := Result + 'Skater-Green-Top ]' ;
SKATE_RED : Result := Result + 'Skater-Red-Top ]' ;
SNOW_GREEN : Result := Result + 'Snowboarder-Green-Top ]' ;
SNOW_MAUVE : Result := Result + 'Snowboarder-Mauve-Top ]' ;
WIND_BLACK : Result := Result + 'Windsurfer-Black-Hair ]' ;
WIND_BLONDE: Result := Result + 'Windsurfer-Blonde-Hair ]';
else Result := Result + 'null ]';
end;
end;

////////////////////////////////////////////////////////////////////////////////
// 'To The Extreme' Puzzle - Solved! Copyright © 2005 Maxim C.L. Warne
//
////////////////////////////////////////////////////////////////////////////////

end.

--------------------------------------------------------------------------------

 

 

Contribute content or training reports / feedback / Comments
job placement papers
All rights reserved © copyright 123ENG