Forth Einstein's Puzzle

einstein.fth

0 constant _red		0 constant _danish		0 constant _beer	0 constant _blend		0 constant _bird
1 constant _yellow	1 constant _english		1 constant _coffee	1 constant _bluemaster		1 constant _cat
2 constant _green	2 constant _german		2 constant _milk	2 constant _dunhill		2 constant _dog
3 constant _blue	3 constant _norwegian		3 constant _tea		3 constant _pallmall		3 constant _fish
4 constant _white	4 constant _swedish		4 constant _water	4 constant _prince		4 constant _horse

: make_range
	create 0 , 1 , 2 , 3 , 4 ,
;


make_range color_range
make_range nation_range
make_range drink_range
make_range cigarette_range
make_range pet_range

: make_perm_array
	create 600 cells allot
;

make_perm_array color_perm
make_perm_array nation_perm
make_perm_array drink_perm
make_perm_array cigarette_perm
make_perm_array pet_perm

: at_array { arr ndx }
	arr ndx cells + @
;
: find_array { arr val }
	5 0 +do
		arr i at_array val = if
			i unloop exit
		endif
	loop
	-2
;
: swap_in_array { arr a b }
	arr a cells + arr b cells + over over @ swap @ rot ! swap !
;

variable color
variable nation
variable drink
variable cigarette
variable pet

: check_cond
	color @ nation @ _english find_array at_array _red <> if false exit endif
	pet @ nation @ _swedish find_array at_array _dog <> if false exit endif
	drink @ nation @ _danish find_array at_array _tea <> if false exit endif
	color @ _green find_array color @ _white find_array 1 - <> if false exit endif
	drink @ color @ _green find_array at_array _coffee <> if false exit endif
	pet @ cigarette @ _pallmall find_array at_array _bird <> if false exit endif
	cigarette @ color @ _yellow find_array at_array _dunhill <> if false exit endif
	drink @ 2 at_array _dunhill <> if false exit endif
	nation @ 0 at_array _norwegian <> if false exit endif
	cigarette @ _blend find_array pet @ _cat find_array - abs 1 <> if false exit endif
	cigarette @ _dunhill find_array pet @ _horse find_array - abs 1 <> if false exit endif
	drink @ cigarette @ _bluemaster find_array at_array _beer <> if false exit endif
	cigarette @ nation @ _german find_array at_array _prince <> if false exit endif
	nation @ _norwegian find_array color @ _blue find_array - abs 1 <> if false exit endif
	cigarette @ _blend find_array drink @ _water find_array - abs 1 <> if false exit endif
	true
;

variable cnt

: make_perm { arr size perm_arr }
	size 1 = if
		5 0 +do
			arr i at_array
			perm_arr cnt @ 5 * i + cells + !
		loop
		cnt @ 1 + cnt !
	endif

	size 0 +do
		arr size 1 - perm_arr recurse
		i size 1 - < if
			size 2 mod 1 = if
				arr 0 size 1 - swap_in_array
			else
				arr i size 1 - swap_in_array
			endif
		endif
	loop
;

0 cnt ! color_range 5 color_perm make_perm
0 cnt ! nation_range 5 nation_perm make_perm
0 cnt ! drink_range 5 drink_perm make_perm
0 cnt ! cigarette_range 5 cigarette_perm make_perm
0 cnt ! pet_range 5 pet_perm make_perm

: inc_var
	dup @ 1 + swap !
;

variable index_color
variable index_nation
variable index_drink
variable index_cigarette
variable index_pet

: check
	4 set-precision
	-1 index_color !
	begin
		index_color inc_var
		index_color @ 120 <
	while
		color_perm index_color @ 5 * cells + color !
		-1 index_nation !
		begin
			index_nation inc_var
			index_nation @ 120 <
		while
			nation_perm index_nation @ 5 * cells + nation !
			-1 index_drink !
			begin
				index_drink inc_var
				index_drink @ 120 <
			while
				drink_perm index_drink @ 5 * cells + drink !
				-1 index_cigarette !
				begin
					index_cigarette inc_var
					index_cigarette @ 120 <
				while
					cigarette_perm index_cigarette @ 5 * cells + cigarette !
					-1 index_pet !
					begin
						index_pet inc_var
						index_pet @ 120 <
					while
						pet_perm index_pet @ 5 * cells + pet !
						check_cond if
							." Finished!" cr exit
						endif
					repeat
				repeat
			repeat
		repeat
	repeat
;

: result { type val }
	type case
		0 of
			val case
				_red of ." red " endof
				_yellow of ." yellow " endof
				_green of ." green " endof
				_blue of ." blue " endof
				_white of ." white " endof
			endcase
		endof
		1 of
			val case
				_danish of ." danish " endof
				_english of ." english " endof
				_german of ." german " endof
				_norwegian of ." norwegian " endof
				_swedish of ." swedish " endof
			endcase
		endof
		2 of
			val case
				_beer of ." beer " endof
				_coffee of ." coffee " endof
				_milk of ." milk " endof
				_tea of ." tea " endof
				_water of ." water " endof
			endcase
		endof
		3 of
			val case
				_blend of ." blend " endof
				_bluemaster of ." bluemaster " endof
				_dunhill of ." dunhill " endof
				_pallmall of ." pallmall " endof
				_prince of ." prince " endof
			endcase
		endof
		4 of
			val case
				_bird of ." bird " endof
				_cat of ." cat " endof
				_dog of ." dog " endof
				_fish of ." fish " endof
				_horse of ." horse " endof
			endcase
		endof
		5 of
			val case
				0 of color endof
				1 of nation endof
				2 of drink endof
				3 of cigarette endof
				4 of pet endof
			endcase
		endof
	endcase
;

: main
	check
	5 0 +do
		i . ." . "
		5 0 +do
			i 5 i result @ j at_array result
		loop
		cr
	loop
;

main