: ENUM: ( n -- ) 0 DO I CONSTANT LOOP ; : ARRAY CREATE ( n -- ) CELLS ALLOT DOES> ( i -- 'a[i] ) SWAP CELLS + ; : TABLE CREATE DOES> ( i -- t[i] ) SWAP CELLS + @ ; \ Some support for 64-bit math, assuming we are running with 32-bit cells. \ [UNDEFINED] 2, [IF] : 2, ( d -- ) , , ; [THEN] \ [UNDEFINED] 2^x [IF] : 2^x ( x -- 2^x ) 1 SWAP LSHIFT ; [THEN] : 2, ( d -- ) , , ; : 2^x ( x -- 2^x ) 1 SWAP LSHIFT ; : dxor ( d1 d2 -- d ) rot xor >r xor r> ; : dand ( d1 d2 -- d ) rot and >r and r> ; \ a double cell result lshift : dlshift32 ( u s -- l h ) DUP 32 < IF DUP IF 2DUP LSHIFT ROT ROT ( l u s ) 32 SWAP - RSHIFT THEN ELSE 32 - LSHIFT 0 SWAP THEN ; : btab, 64 0 DO 1 I dlshift32 2, LOOP ; \ initial board, with edges filled in \ %0000011.000001.0000011.000001.0000011.000001.0000011.000001.0000011.00000 434650421954089056. 2CONSTANT init-board 0 VALUE found-solutions 2VARIABLE board CREATE _d2^x btab, CREATE smallest 64 CHARS ALLOT CREATE largest 64 CHARS ALLOT CREATE shift-xt 65 CELLS ALLOT CREATE offsets 6 CELLS ALLOT CREATE path 5 CELLS ALLOT 10 ARRAY used 7 ENUM: E SE SW W NW NE STOP! TABLE poffset 1 , 7 , 6 , -1 , -7 , -6 , 0 , TABLE rotate SE , SW , W , NW , NE , E , STOP! , TABLE reflect E , NE , NW , W , SW , SE , STOP! , \ specify via paths because paths are more easily transformable than bit masks : init-path E path 5 0 DO TUCK ! CELL+ LOOP DROP ; ( 4*dirs -- ) : rotate-path path 5 0 DO DUP @ rotate OVER ! CELL+ LOOP DROP ; : reflect-path path 5 0 DO DUP @ reflect OVER ! CELL+ LOOP DROP ; : path-offsets ( -- ) 0 offsets ! path offsets 5 0 DO OVER @ poffset OVER @ + OVER CELL+ ! SWAP CELL+ SWAP CELL+ LOOP 2DROP ; : minimum-offset ( -- n ) offsets @ 6 1 DO offsets I CELLS + @ MIN LOOP ; : normalize-offsets ( -- ) minimum-offset NEGATE 6 0 DO DUP offsets I CELLS + +! LOOP DROP ; : offsets-mask ( -- mask ) 0 6 0 DO offsets I CELLS + @ 2^x OR LOOP ; \ make and store the twelve transformations of the path : path-mask ( -- mask ) path-offsets normalize-offsets offsets-mask ; : path-masks ( 4*dirs -- ) init-path path-mask , 5 0 DO rotate-path path-mask , LOOP reflect-path path-mask , 5 0 DO rotate-path path-mask , LOOP ; \ all path-masks start with an implicit E and are 12 cells long CREATE pieces STOP! SE E E path-masks STOP! NE E SE path-masks STOP! SW SE E path-masks STOP! SE SW E path-masks SW W E SE path-masks \ one backtrack, since this shape branches STOP! SE NE SE path-masks STOP! NE SE SE path-masks STOP! E SW SE path-masks STOP! E SE E path-masks STOP! NE SE E path-masks : shifts, ( -- ) 64 0 DO pieces 120 0 DO DUP @ J dlshift32 2, CELL+ LOOP DROP 8 0 DO 0. 2, LOOP LOOP ; CREATE shifts shifts, \ Next, storing and displaying a solution. : put-piece ( shift piece -- ) DUP pieces - 12 CELLS / [CHAR] 0 + >R ( R: piece-char ) SWAP CHARS HERE + SWAP @ ( display mask ) BEGIN DUP 1 AND IF OVER R@ SWAP C! THEN SWAP CHAR+ DUP HERE 64 CHARS + < WHILE SWAP 2/ DUP 0= UNTIL THEN 2DROP R> DROP ; \ extract solution from stack of (shift, piece addr) : store-solution ( ? -- ) HERE 64 CHARS [CHAR] * FILL DEPTH 1 DO I PICK I PICK put-piece 2 +LOOP ; : .line 5 0 DO COUNT EMIT SPACE LOOP CR CHAR+ ; ( line -- line+6 ) : .solution 5 0 DO .line CHAR+ SPACE .line LOOP CR DROP ; ( buffer -- ) : check-solution ( [st] -- [st] ) store-solution HERE 64 smallest 64 COMPARE 0< IF HERE smallest 64 MOVE THEN largest 64 HERE 64 COMPARE 0< IF HERE largest 64 MOVE THEN found-solutions 1+ TO found-solutions ; \ throw if found-solutions == NUM \ And the non-recursive heart of the program. \ Check whether piece sticks off bottom of the board : fits? ( shift #piece -- bool ) OVER 39 < IF 2DROP TRUE ELSE CELLS pieces + @ 64 ROT - 2^x 1- U< THEN ; : shifted >R 128 * R> + 2* CELLS shifts + 2@ ; ( shift #piece -- dmask ) : mark board 2@ dxor board 2! ; ( dmask -- ) : d2^x 2* CELLS _d2^x + 2@ ; ( x -- d ) \ find next free cell (64 if completely full) \ executes about 3,000,000 times / 16 ms. : next-shift ( shift -- shift+n ) BEGIN 1+ DUP 64 <> WHILE DUP d2^x board 2@ dand OR 0= UNTIL THEN ; : num, ( n -- ) POSTPONE LITERAL ; : dnum, ( d -- ) SWAP num, num, ; : piece, ( shift #piece -- ) DUP 12 * LOCALS| #ipx #piece shift | #piece used num, POSTPONE @ S" IF 12 CELLS + " EVALUATE S" ELSE " EVALUATE #piece used num, S" TRUE SWAP ! " EVALUATE 12 0 DO shift #ipx fits? IF shift #ipx shifted dnum, S" board 2@ dand OR 0= " EVALUATE S" IF " EVALUATE shift #ipx shifted dnum, POSTPONE mark shift num, S" next-shift CELLS shift-xt + @ EXECUTE " EVALUATE shift #ipx shifted dnum, POSTPONE mark S" THEN " EVALUATE THEN S" CELL+ " EVALUATE #ipx 1+ TO #ipx LOOP #piece used num, S" FALSE SWAP ! " EVALUATE S" THEN " EVALUATE ; : solve, ( shift -- ) LOCALS| shift | shift num, pieces num, 10 0 DO shift I piece, LOOP POSTPONE 2DROP ; : solvers, ( -- ) 64 0 DO :NONAME I solve, POSTPONE ; shift-xt I CELLS + ! LOOP ; solvers, :NONAME ( -- ) check-solution ; shift-xt 64 CELLS + ! : MAIN 0 TO found-solutions smallest 64 [CHAR] 9 FILL largest 64 [CHAR] 0 FILL init-board board 2! 0 used 10 CELLS ERASE shift-xt @ EXECUTE found-solutions . ." solutions found." CR CR ." smallest solution: " CR CR smallest .solution CR ." largest solution: " CR CR largest .solution ; main bye