Add to Favorites    Make Home Page 29379 Online  
 Language Categories  
 Our Services  

Home » Pascal Home » Pascal Projects Home » Recursive Monkey Puzzle Solution - Project

A D V E R T I S E M E N T

Search Projects & Source Codes:

Title Recursive Monkey Puzzle Solution - Project
Author Maxim C.L. Wrne
Author Email max.warne [at] blueyonder.co.uk
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.
Category Pascal » Pascal Projects
Hits 8264
Code Select and Copy the Code
//////////////////////////////////////////////////////////////////////////////// // '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.

Related Source Codes

Script Name Author
Calendar date to day number and back Nicky McLean
Matrix Multiple Cirruse Salehnasab
Function Power Recursive Cirruse Salehnasab
swim brian colston
tetris (Mini Project) mehdi farrokhzad
Macsi - space fighting game. Macsi PÚter
Maze Game Project In Pascal Mahmood
Excellent Rat in a Maze Program. VyomWorld
A car game. You have to drive the car in such a way that you dont strike a barrier on the road. VyomWorld
Student Database Information System. VyomWorld
Tic Tac Toe Game implemented in Pascal. VyomWorld
Game to Gain more blocks by drawing appropriate lines from correct places(dots). VyomWorld
To Find The Coinage Of The Amount Entered. VyomWorld
Randomizes two 3x3 arrays and indicates the numbers whih are common in both the arrays otherwise an cross 'x' is shown instead. VyomWorld
Program that checks the space on drive a: and also gives a graphical representation of memory. VyomWorld

A D V E R T I S E M E N T




Google Groups Subscribe to SourceCodesWorld - Techies Talk
Email:

Free eBook - Interview Questions: Get over 1,000 Interview Questions in an eBook for free when you join JobsAssist. Just click on the button below to join JobsAssist and you will immediately receive the Free eBook with thousands of Interview Questions in an ebook when you join.

New! Click here to Add your Code!


ASP Home | C Home | C++ Home | COBOL Home | Java Home | Pascal Home
Source Codes Home Page

 Advertisements  

Google Search

Google

Source Codes World.com is a part of Vyom Network.

Vyom Network : Web Hosting | Dedicated Server | Free SMS, GRE, GMAT, MBA | Online Exams | Freshers Jobs | Software Downloads | Interview Questions | Jobs, Discussions | Placement Papers | Free eBooks | Free eBooks | Free Business Info | Interview Questions | Free Tutorials | Arabic, French, German | IAS Preparation | Jokes, Songs, Fun | Free Classifieds | Free Recipes | Free Downloads | Bangalore Info | Tech Solutions | Project Outsourcing, Web Hosting | GATE Preparation | MBA Preparation | SAP Info | Software Testing | Google Logo Maker | Freshers Jobs

Sitemap | Privacy Policy | Terms and Conditions
Copyright ©2003-2017 SourceCodesWorld.com, All Rights Reserved.
Page URL: http://www.sourcecodesworld.com/source/show.asp?ScriptID=766


Download Yahoo Messenger | Placement Papers | Free SMS | C Interview Questions | C++ Interview Questions | Quick2Host Review