\ Incorporated bugfix from - anton \ Article: 112987 of comp.lang.forth \ Newsgroups: comp.lang.forth \ From: Albert van der Horst \ Subject: Re: pentomino program revisited \ Date: 03 Sep 2005 14:12:50 GMT \ Message-ID: \ Lines: 291 \ Organization: DFW The Netherlands \ References: <2005Aug17.192857@mips.complang.tuwien.ac.at> <430bffd3$1@clear.net.nz> \ Xref: tunews.univie.ac.at comp.lang.forth:112987 \ In article <430bffd3$1@clear.net.nz>, Bruce Hoyt wrote: \ >"Albert van der Horst" wrote in message \ >news:iloyuo.dxa@spenarnc.xs4all.nl... \ >> I'm trying to make a version, in Forth, using masks. \ >> I hope to beat Bruce Hoyt's version. \ >> \ >If you are able to improve on my algorithm, I will be very interested. \ >Please send me a copy. \ At last I have a solution that is marginally faster than Bruces. \ This means 14 versus 10.5 seconds with lina 4.0.6, 12 versus 9 with \ gforth 0.5.0. \ Compared to Bruce I generate the data structures rather than \ the code. Therefore the code to study is only (SOLVE) \ with a few simple factors: LEFT PLACE FIT . \ I'm using bitmasks called ``pentomino in position'' or pip's. \ A pentomino in position is a bit-mask where the left most row \ has a bit occupied. The position is the index of the lowest bit \ occupied in this first row. \ The basic idea is that the whole state is on the stack, \ and that backtracking is accomplished by dropping items. \ The exception is the array of used items, containing \ pointers to an array of bags of pip's. \ This array has its items swapped (and swapped) back, such \ that at all times the lower items refer to pentomino's \ placed. \ A pointer to the first unplaced pentomino is \ kept on the stack on top of bitmaps for each placed \ pentomino, that is successively containing less \ bits. So a solution is found if the last bitmap is zero \ and the pointer points after the last execution token. \ The first bitmap is 2^60-1 and an xor between two consecutive \ bitmaps reveals what pentomino was placed. \ If the first (left) row is used up, the bitmask is shifted \ such that it contains again an unoccupied square. \ This makes it difficult to print the solution. \ The optimisation with the x-piece is accomplished by using \ as starting points differend bit maps, and bumping the \ pointer to the first unplaced pentomino after the x-piece. \ [This solution is still is not optimal. There should not be a pointer \ to an array of bags, but to execution tokens. In that way all data \ pertaining to an execution token is constant and can be fully \ optimised.] \ - This technique foregoes a need for testing boundaries of the field \ - places a piece with a simple xor, to a fresh bitmap. \ It is never erased, but discarded. \ - the ``unused'' technique such as demonstrated in my c-version is \ essential. \ Here it comes. Apparently pentomino solvers are entitled \ to some cryptic data structures. Of course I generated those \ data with a nice object oriented program, that is however non-standard. \ I have included my whole BAG wordset, but little of it is used here. \ Please use the name mpent4x15.frt if you intend to archive \ this program. \ ----------8<--------8<-----------------8<-------------- \ Copyright : Albert van der Horst by Gnu Public Licence \ $Id: mpent.frt,v 1.36.1.5 2005/09/02 15:35:49 albert Exp albert $ \ Solve the problem how to place the 12 pentominos on a rectangular board. \ Tables for the 4 x 15 problem. \ X0 .. X3 are bitmaps for the piece in position at bit 0 ..3 of the leftmost \ column. \ We use a packed representation: \ bit[o,i] bit number o*HEIGHT+i \ i is the swIft vertIcal or fIrst index \ o is the slOw hOrizontal or dOwnmost index. \ 01 11 21 \ 00 10 20 \ However we need a double and PACKED60 is a double with the ls part on top, \ because it is most often used. 4 CONSTANT HEIGHT \ Height of rectangular field. \ Leave first ROW of a PACKED 1 HEIGHT LSHIFT 1 - CONSTANT FIRST : REQUIRE POSTPONE \ ; \ Fetch cell from ADDRES with auto-increment. Leave next ADDRESS and CONTENT. : @+ DUP >R CELL+ R> @ ; \ Leave a don't care ITEM. : _ 0 ; \ Shift DOUBLE N pos to the right. \ Shift DOUBLE N pos to the right. n must be > 0, smaller than bits per cell. \ Return DOUBLE. : (DRSHIFT) 2DUP RSHIFT >R >R 32 R@ - LSHIFT SWAP R> RSHIFT OR R> ; \ Shift DOUBLE N pos to the right. n must be smaller than bits per double. \ Return DOUBLE. : DRSHIFT ?DUP IF DUP 32 < IF (DRSHIFT) ELSE 32 - >R NIP 0 R> (DRSHIFT) THEN THEN ; \ Shift DOUBLE N pos to the left. n must be > 0, smaller than bits per cell. \ Return DOUBLE. : (DLSHIFT) >R R@ LSHIFT OVER 32 R@ - RSHIFT OR SWAP R> LSHIFT SWAP ; \ Shift DOUBLE N pos to the left. n must be smaller than bits per double. \ Return DOUBLE. : DLSHIFT ?DUP IF DUP 32 < IF (DLSHIFT) ELSE 32 - >R DROP 0 SWAP R> (DLSHIFT) THEN THEN ; REQUIRE BAG \ --------------------------------------------------------- ( BAG !BAG BAG? BAG+! BAG@- BAG-REMOVE BAG-HOLE BAG-INSERT ) REQUIRE @+ ( Build a bag with X items. ) : BUILD-BAG HERE CELL+ , CELLS ALLOT ; ( Create a bag "x" with X items. ) : BAG CREATE HERE CELL+ , CELLS ALLOT DOES> ; : !BAG DUP CELL+ SWAP ! ; ( Make the BAG empty ) : BAG? @+ = 0= ; ( For the BAG : it IS non-empty ) : BAG+! DUP >R @ ! 0 CELL+ R> +! ; ( Push ITEM to the BAG ) : BAG@- 0 CELL+ NEGATE OVER +! @ @ ; ( From BAG: pop ITEM ) : BAG-REMOVE ( Remove entry at ADDRESS from BAG. ) >R DUP CELL+ SWAP OVER R@ @ SWAP - MOVE -1 CELLS R> +! ; : BAG-HOLE ( Make hole at ADDRESS in BAG. ) >R DUP CELL+ OVER R@ @ SWAP - MOVE 0 CELL+ R> +! ; ( Insert VALUE at ADDRESS in BAG. ) : BAG-INSERT OVER SWAP BAG-HOLE ! ; \ --------------------------------------------------------- REQUIRE DO-BAG \ --------------------------------------------------------- ( |BAG| DO-BAG .BAG BAG-WHERE IN-BAG? BAG- SET+ SET- ) \ AvdH : |BAG| @+ SWAP - 0 CELL+ / ; ( For BAG : NUMBER of items ) \ Loop over a bag, see ``.BAG'' for an example. : DO-BAG POSTPONE @+ POSTPONE SWAP POSTPONE ?DO ; IMMEDIATE : LOOP-BAG 0 CELL+ POSTPONE LITERAL POSTPONE +LOOP ; IMMEDIATE : .BAG DO-BAG I ? LOOP-BAG ; ( Print BAG ) ( For VALUE and BAG : ADDRESS of value in bag/nill.) : BAG-WHERE DO-BAG DUP I @ = IF DROP I UNLOOP EXIT THEN LOOP-BAG DROP 0 ; ( For VALUE and BAG : value IS present in bag.) : IN-BAG? BAG-WHERE 0= 0= ; ( Remove VALUE from BAG. ) : BAG- DUP >R BAG-WHERE R> BAG-REMOVE ; ( Add/remove VALUE to bag, used as a SET, i.e. no duplicates.) : SET+ 2DUP IN-BAG? IF 2DROP ELSE BAG+! THEN ; : SET- 2DUP IN-BAG? IF BAG- ELSE 2DROP THEN ; \ --------------------------------------------------------- \ Create a "bag" with values known at compile time. : BAG[ CREATE HERE _ , ; : ]BAG HERE SWAP ! ; ( - - - - - - - ) HEX ( - - - - - - - - ) BAG[ X-0 ]BAG BAG[ X-1 272 , ]BAG BAG[ X-2 4E4 , ]BAG BAG[ X-3 ]BAG CREATE X-PIP X-0 , X-1 , X-2 , X-3 , BAG[ F-0 263 , 271 , ]BAG BAG[ F-1 4C6 , 362 , 236 , 632 , 472 , 4E2 , 172 , ]BAG BAG[ F-2 6C4 , 46C , C64 , 274 , 8E4 , 2E4 , ]BAG BAG[ F-3 4E8 , ]BAG CREATE F-PIP F-0 , F-1 , F-2 , F-3 , BAG[ II-0 11111 , ]BAG BAG[ II-1 22222 , ]BAG BAG[ II-2 44444 , ]BAG BAG[ II-3 88888 , ]BAG CREATE II-PIP II-0 , II-1 , II-2 , II-3 , BAG[ L-0 3111 , 1113 , 2223 , 1F , F1 , 8F , ]BAG BAG[ L-1 6222 , 2226 , 3222 , 4446 , ]BAG BAG[ L-2 C444 , 444C , 6444 , 888C , ]BAG BAG[ L-3 C888 , F8 , ]BAG CREATE L-PIP L-0 , L-1 , L-2 , L-3 , BAG[ N-0 2231 , 2311 , C7 , E3 , ]BAG BAG[ N-1 4462 , 1322 , 1132 , 4622 , 3E , ]BAG BAG[ N-2 88C4 , 2644 , 2264 , 8C44 , 7C , ]BAG BAG[ N-3 4C88 , 44C8 , ]BAG CREATE N-PIP N-0 , N-1 , N-2 , N-3 , BAG[ P-0 233 , 133 , 331 , 67 , 73 , 37 , ]BAG BAG[ P-1 466 , 332 , 266 , 662 , 76 , CE , E6 , 6E , ]BAG BAG[ P-2 8CC , 664 , 4CC , CC4 , EC , ]BAG BAG[ P-3 CC8 , ]BAG CREATE P-PIP P-0 , P-1 , P-2 , P-3 , BAG[ T-0 227 , 171 , ]BAG BAG[ T-1 44E , 722 , 2E2 , ]BAG BAG[ T-2 E44 , 474 , ]BAG BAG[ T-3 8E8 , ]BAG CREATE T-PIP T-0 , T-1 , T-2 , T-3 , BAG[ U-0 75 , 57 , 313 , 323 , ]BAG BAG[ U-1 EA , AE , 626 , 646 , ]BAG BAG[ U-2 C4C , C8C , ]BAG BAG[ U-3 ]BAG CREATE U-PIP U-0 , U-1 , U-2 , U-3 , BAG[ V-0 447 , 711 , 117 , ]BAG BAG[ V-1 88E , E22 , 22E , ]BAG BAG[ V-2 744 , ]BAG BAG[ V-3 E88 , ]BAG CREATE V-PIP V-0 , V-1 , V-2 , V-3 , BAG[ W-0 463 , 631 , ]BAG BAG[ W-1 8C6 , C62 , 136 , ]BAG BAG[ W-2 364 , 26C , ]BAG BAG[ W-3 6C8 , ]BAG CREATE W-PIP W-0 , W-1 , W-2 , W-3 , BAG[ Y-0 1131 , 1311 , 4F , 2F , ]BAG BAG[ Y-1 2262 , 2622 , 2232 , 2322 , F2 , ]BAG BAG[ Y-2 44C4 , 4C44 , 4464 , 4644 , F4 , ]BAG BAG[ Y-3 88C8 , 8C88 , ]BAG CREATE Y-PIP Y-0 , Y-1 , Y-2 , Y-3 , BAG[ Z-0 623 , 471 , ]BAG BAG[ Z-1 326 , C46 , 8E2 , ]BAG BAG[ Z-2 64C , 174 , ]BAG BAG[ Z-3 2E8 , ]BAG CREATE Z-PIP Z-0 , Z-1 , Z-2 , Z-3 , BAG[ FI-0 263 , 271 , ]BAG BAG[ FI-1 4C6 , 236 , 4E2 , ]BAG BAG[ FI-2 46C , 274 , ]BAG BAG[ FI-3 4E8 , ]BAG CREATE FI-PIP FI-0 , FI-1 , FI-2 , FI-3 , CREATE USED X-PIP , F-PIP , II-PIP , L-PIP , N-PIP , P-PIP , T-PIP , U-PIP , V-PIP , W-PIP , Y-PIP , Z-PIP , HERE CONSTANT END-USED ( - - - - - - - ) DECIMAL ( - - - - - - - - ) \ Push a PACKED60 as much positions left as possible , return IT. : LEFTEST BEGIN DUP FIRST AND 0= WHILE SWAP HEIGHT DRSHIFT SWAP REPEAT ; \ For a snug PACKED leave FIRST unoccupied square. : FIT DUP 1 AND IF DROP 0 ELSE 1 RSHIFT RECURSE 1+ THEN ; \ Attempt to place in PACKED60 a PIP, return PACKED60 FLAG \ The flag indicates that the pip placement was succesful. : PLACE >R R@ XOR DUP R> AND 0= ; VARIABLE #SOL : SOLUTION-FOUND ." ." 1 #SOL +! ; \ Find and print all solutions to be found in PACKED60 with \ HOWFAR ominos filled in. Leave PACKED60 and HOWFAR \ The entries of ``USED'' behind howfar refer to pips still to be tried. : (SOLVE) >R LEFTEST DUP FIT CELLS R> END-USED OVER DO I @ OVER @ I ! OVER ! 2DUP @ + @ DO-BAG 2OVER I @ PLACE IF 2OVER NIP CELL+ \ New howfar pointer. DUP END-USED = IF SOLUTION-FOUND ELSE RECURSE THEN DROP THEN 2DROP LOOP-BAG I @ OVER @ I ! OVER ! 1 CELLS +LOOP NIP ; \ Find and print all solutions to be found in PACKED60 with \ ominos before HOWFAR filled in. : SOLVE (SOLVE) DROP 2DROP ; ( - - - - - - - ) HEX ( - - - - - - - - ) \ Straightforward solution with all mirror and flips for 4 by 15. : 4x15 0 #SOL ! FFF.FFFF.FFFF.FFFF SWAP USED SOLVE #SOL @ . ; \ Fast sophisticated solution where the x is placed up front \ and symmetric solutions are suppressed. : 4x15-OPT 0 #SOL ! FFF.FFFF.FFFF.FD8D SWAP USED CELL+ SOLVE #SOL @ . FFF.FFFF.FFFF.D8DF SWAP USED CELL+ SOLVE #SOL @ . FFF.FFFF.FFFD.8DFF SWAP USED CELL+ SOLVE #SOL @ . FFF.FFFF.FFD8.DFFF SWAP USED CELL+ SOLVE #SOL @ . FFF.FFFF.FD8D.FFFF SWAP USED CELL+ SOLVE #SOL @ . FFF.FFFF.D8DF.FFFF SWAP USED CELL+ SOLVE #SOL @ . FI-PIP USED CELL+ ! \ Suppress symmetry around vertical FFF.FFFD.8DFF.FFFF SWAP USED CELL+ SOLVE #SOL @ . F-PIP USED CELL+ ! \ Reset it. ; ( - - - - - - - ) DECIMAL ( - - - - - - - - )