\ The Computer Language Shootout
\ http://shootout.alioth.debian.org/
\ Contributed by Ian Osgood and Josh Grams

: enum ( n -- ) 0 do I constant loop ;
: table create does> ( i -- t[i] ) swap cells + @ ;

7 enum         E   SE   SW    W   NW   NE   STOP
table offset   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 ,

\ paths are more easily transformable than bit masks

create path 5 cells allot
create offsets 6 cells allot
variable #solutions
create smallest 64 chars allot
create largest  64 chars allot
variable board
variable shift
1024 allot \ padding for Pentium 4 and bigforth shortcomings

: init-path ( 4*dirs -- )
  E path 5 0 do tuck ! cell+ loop drop ;
: 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 @ offset
    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 + @
    1 swap lshift or
  loop ;

\ make and store the twelve transformations of the path

: path-mask ( -- mask )
  path-offsets normalize-offsets offsets-mask ;
: path-masks ( 4*dirs -- )
                             0 , \ used flag
           init-path path-mask ,
  5 0 do rotate-path path-mask , loop
        reflect-path path-mask ,
  5 0 do rotate-path path-mask , loop ;

13 cells constant /piece

\  all paths start with an implicit E

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

: put-piece ( shift piece -- )
        dup pieces - /piece / [char] 0 + >r ( R: piece-char )
        swap chars here + swap @ ( buf 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 ;

: adjust ( shift -- shift' )
        shift @ tuck + shift ! ;

\ extract solution from stack and store at HERE
\ (non-destructive because we need the data for backtracking).
: store-solution ( pieceN shiftN ... piece0 shift0 board )
  0 shift !
  here 64 [char] * fill
  depth 1- 2 swap do
    i pick i pick adjust swap put-piece
  -2 +loop ;

: .line ( line -- line+6 )
  5 0 do dup c@ emit space char+ loop cr char+ ;
: .solution ( buffer -- )
  5 0 do .line char+  space .line loop drop cr ;

: record ( [st] -- [st] )
  store-solution  \ here .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
  1 #solutions +! ;  \ throw if #solutions == NUM

\ initial board, with edges filled in
2 base !
0000011.000001.0000011.000001.0000011.000001.0000011.000001.0000011.00000
2constant init-board

hex
80000000 constant hi-bit

decimal


: shift-board ( board -- shift board' )
        0 swap board @ begin
                over 1 and while d2/ hi-bit or rot 1+ -rot
        repeat board ! ;

: unshift-board ( shift board -- board' )
        swap >r board @ begin r> dup while 1- >r
                d2* swap 1+ swap repeat drop board ! ;


\ returns true if solution is complete
: add ( board piece -- piece shift board' flag )
        tuck @ xor dup invert if shift-board false else 0 swap dup then
;

: remove ( piece shift board' -- board piece )
        unshift-board  over @ xor swap ;


: solve ( board -- board )
        pieces  10 0 do
                dup @ if
                        /piece +
                else
                        true over ! cell+  \ mark used
                        12 0 do
                                2dup @ and 0= if
                                        add if record else recurse then
remove
                                then
                        cell+ loop
                        false over /piece - !  \ mark unused
                then
        loop drop ;


: main
        0 #solutions !
        smallest 64 [char] 9 fill
        largest  64 [char] 0 fill
                init-board board ! solve
        #solutions @ . ." solutions found" cr cr
        smallest .solution
        largest  .solution ;

main bye