\ by Joshua Grams, 2008-06-18 -- public domain.
\ 
\ Puzzle from Charlie Springer, 2008-06-16, comp.lang.forth
\ <0001HW.C47C4D2F001B037AF02845B0@news.nw.centurytel.net>


( cards )

\ Cards have four symbols on them.  Symbols come in four colors
\ (red, green, blue, and yellow), and two types (front and back).
\ We represent them by letters, using RGBY and rgby for front and
\ back halves, respectively.

\ symbols match if they are the same letter in different cases.
: match? ( char1 char2 -- flag )  xor 32 = ;

\ a card is a four-character string stored in a cell.
: card: ( "trbl" -- )  parse-word drop @ , ;
create cards
	card: rBRy
	card: gBYR
	card: bRGy
	card: ybGr
	card: yrGB
	card: BRYb
	card: gbRy
	card: yGbB
	card: gYgR
: card ( u -- card )  1 - cells cards + @ ;

base c@ 0= [if]  \ big endian
: top    ( card -- char )  24 rshift 255 and ;
: right  ( card -- char )  16 rshift 255 and ;
: bottom ( card -- char )   8 rshift 255 and ;
: left   ( card -- char )            255 and ;
[else]  \ little endian
: top    ( card -- char )            255 and ;
: right  ( card -- char )   8 rshift 255 and ;
: bottom ( card -- char )  16 rshift 255 and ;
: left   ( card -- char )  24 rshift 255 and ;
[then]

: rotate ( card -- card' )  ( direction depends on endianness )
	dup 8 rshift swap 24 lshift or ;

: .card ( card -- )
	cr space dup top emit space cr
	dup left emit space dup right emit cr
	space bottom emit space cr ;

( board )
create board 9 cells allot
variable position

: complete? ( -- flag )  position @ 9 = ;
: board[] ( u -- addr )  cells board + ;
: place-card ( card -- )  position @ board[] !  1 position +! ;

: left-matches? ( card -- flag )
	position @ 3 mod if left  position @ 1 - board[] @ right  match?
	else drop true then ;
: top-matches? ( card -- flag )
	position @ 3 < if drop true
	else top  position @ 3 - board[] @ bottom match? then ;
: fits? ( card -- flag )  dup left-matches? swap top-matches? and ;

: .line ." +---+---+---+" cr ;
: | [char] | emit ;
: row ( u -- u limit index )  dup 3 + over ;
: .row ( u -- )
	row do | space i board[] @ top emit space loop | cr
	row do | i board[] @ dup left emit  space  right emit loop | cr
	row do | space i board[] @ bottom emit space loop | cr drop ;
: .board cr
	.line 0 .row
	.line 3 .row
	.line 6 .row .line ;


( unused cards )

\ are stored as the digits of a decimal number.
variable unused
987654321 constant all-cards

\ the current card is indicated by a power of 10.
1 constant first-card
: next-card 10 * ;

: current ( u -- card )  unused @ swap / 10 mod ;
: use ( u -- )  unused @ over /mod 10 / rot * + unused ! ;


( solver )

: with-card  unused @ position @  2over place-card use ;
: undo       position ! unused ! ;

: (solve)  ( -- )
	complete? if .board else
		first-card begin dup current while
			dup current card 4 0 do
				dup fits? if with-card recurse undo then
			rotate loop drop
		next-card repeat drop
	then ;

: solve  all-cards unused !  0 position !  (solve) ;