@prog seahaven.muf
1 9999 d
1 i
(
Seahaven game.
Keeps game state in props on the player.
Exits linked to this program must have a property "_function"; its
value must be one of

	new	If a game is in progress, asks for confirmation, then
		discards it, incrementing the player's games-lost
		count.  In any case, starts a new game.

	pile	Takes a card name as an argument; moves that card onto
		the pile appropriate for it.  [If the card is a king,
		and more than one pile is empty, it picks one.]

	work	Takes a card name as an argument; moves that card onto
		an empty work space.  If multiple work spaces are
		empty, it picks one.

	undo	Undoes the last card motion.  Can be repeated to undo
		clear back to the beginning of the current game.

	state	Prints out any game in progress; also prints the
		games-won and games-lost counts.

There are also two special values:

	cmd	If _function is set to this value, the string in
		COMMAND @ must be one of the above.  [This is intended
		for use with an exit with names that match all of the
		above.]

	pfx	If _function is set to this value, the first word of
		the command is taken as one of the above, or any
		unambiguous abbreviation.  [This is intended for use
		with an exit with a very short name, set Prefix.]

Game state is kept in props with this prefix:
)
$def prop-prefix "*seahaven/"
(
Work spaces are "work-0" through "work-3"; the property is nonexistent
for an empty space and holds the card name for a filled one.
)
: work-prop (i -- s) prop-prefix "work-" rot intostr strcat strcat ;
: get-work-contents (i -- s) work-prop me @ swap getpropstr ;
: set-work-card (i c -- ) me @ rot work-prop rot addprop ;
: set-work-empty (i -- ) me @ swap work-prop remove_prop ;
(
Suit piles are represented as a property "home-X" where X is c, d, h,
or s, depending on the suit.  The value is an integer, the number of
cards on that suit pile.
)
: home-prop (suit -- propname) prop-prefix "home-" rot strcat strcat ;
: get-home-height (suit -- height)
	home-prop me @ swap getpropstr atoi
;
: set-home-height (suit height -- )
	me @ rot home-prop rot intostr addprop
;
(
The "pile" piles are represented as "pile-0" through "pile-9"
properties.  The property value is a string of cards, two characters
each, concatenated with no spaces in between.  An empty pile is
represented as a zero-length property, or alternatively, a nonexistent
property.  The last card in the value is the top card of the pile.
)
: pile-prop (i -- s) prop-prefix "pile-" rot intostr strcat strcat ;
: pile-height (i -- n) pile-prop me @ swap getpropstr strlen 2 / ;
: pile-cards (i -- cN ... c2 c1 N) (c1 is top of stack)
	pile-prop me @ swap getpropstr 0
	begin over while swap 2 strcut rot 1 + loop swap pop
;
: pile-set (i cN ... c2 c1 N -- )
	"" rimplode me @ rot pile-prop rot addprop
;
: pile-top-card (i -- c)
	pile-prop me @ swap getpropstr
	dup if -2 strcut swap pop then
;
: pile-pop-card (i -- c)
	pile-prop me @ swap over over getpropstr
	-2 strcut -4 rotate addprop
;
: pile-push-card (i c -- )
	swap pile-prop me @ over over getpropstr
	4 rotate strcat addprop
;
: clear-pile (i -- ) pile-prop me @ swap remove_prop ;
(
Each card's location is remembered in a property loc-Xx, where Xx
is the card name.
	For a card that's	the value is
	on a home pile		"" [or, alternatively, property absent]
	on work space N		wN
	pile N, card M		pNM
N is always one digit; M may be either one or two digits.
Both N and M are zero-origin.
)
: get-card-loc (c -- )
	"loc-" swap strcat prop-prefix swap strcat me @ swap getpropstr
;
: set-card-loc (c loc -- )
	me @ prop-prefix "loc-" 5 rotate strcat strcat rot
	dup if addprop else pop remove_prop then
;
: make-pile-loc (pile cwp -- loc)
	swap intostr swap intostr strcat "p" swap strcat
;
: make-work-loc (pile -- loc)
	intostr "w" swap strcat
;
$def make-home-loc ""
: split-pile-loc (loc -- pile cwp)
	1 -1 substr 1 strcut swap atoi swap atoi
;
: split-work-loc (loc -- pile)
	1 -1 substr atoi
;
$def is-home-loc? (loc -- bool) not
: is-work-loc? (loc -- bool) "w" 1 strncmp not ;
: is-pile-loc? (loc -- bool) "p" 1 strncmp not ;
(
Game-won and game-lost counts are kept in "won" and "lost" properties.
"playing" exists if the player has a game in progress.
)
: get-nwon ( -- n) me @ prop-prefix "won" strcat getpropstr atoi ;
: set-nwon (n -- ) me @ prop-prefix "won" strcat rot intostr addprop ;
: get-nlost ( -- n) me @ prop-prefix "lost" strcat getpropstr atoi ;
: set-nlost (n -- ) me @ prop-prefix "lost" strcat rot intostr addprop ;
: is-playing? ( -- 1/0) me @ prop-prefix "playing" strcat prop-exists? ;
(
)
: say me @ swap notify ;
: panic (s -- never returns)
	"INTERNAL ERROR: " swap strcat say
	depth pstack
	0 sleep daemon kill
;
: split-firstword
	dup " " instr dup if
		1 - strcut 1 strcut swap pop
	else
		pop ""
	then
	swap
;
: shuffled-deck
	"Ac2c3c4c5c6c7c8c9cTcJcQcKcAd2d3d4d5d6d7d8d9dTdJdQdKdAh2h3h4h5h6h7h8h9hThJhQhKhAs2s3s4s5s6s7s8s9sTsJsQsKs"
	52 2 -1 for
		random swap % 2 * strcut 2 strcut
		rot strcat
	loop
	52 "" rimplode
;
: pad-to-2 "  " strcat 2 strcut pop ;
: value-string-0-based "A23456789TJQK" swap 1 substr ;
: value-string-1-based " A23456789TJQK" swap 1 substr ;
: show-game
	"Work: ["
	0 3 1 for
		get-work-contents pad-to-2 "|"
	loop
	pop "]         Home: ["
	"cdhs" begin dup while
		1 strcut swap dup get-home-height
		dup if
			value-string-1-based
		else
			pop " "
		then
		swap strcat swap "|" swap
	loop pop "]" 18 "" rimplode
	say
	0
	0 9 1 for pile-height over over < if swap then pop loop
	dup not if pop exit then
	10 over 2 newarray
	( n a )
	over 1 - 0 -1 for
		( n a y )
		0 9 1 for over "  " -rot 5 pick aset loop
		pop
	loop
	( n a )
	0 9 1 for
		( n a i )
		dup pile-cards
		( n a i cN ... c2 c1 N )
		dup 2 + rotate over 4 + pick 3 pick - 3 pick 4 + pick
		( n a cN ... c2 c1 N i o a )
		begin 4 pick 0 > while
			( n a cN cN-1 ... c2 c1 N i o a )
			4 rotate dup 1 - -5 rotate 4 + rotate
			( n a cN-1 ... c2 c1 N-1 i o a cN )
			4 pick 6 pick 5 pick + 4 pick
			( n a cN-1 ... c2 c1 N-1 i o a cN i o+N-1 a )
			aset
			( n a cN-1 ... c2 c1 N-1 i o a )
		loop
		pop pop pop pop
	loop
	swap
	1 - 0 -1 for
		( a y )
		"" 0 9 1 for
			3 pick 5 pick aget "  " swap 3 "" rimplode
		loop
		say pop
	loop
	pop
;
: card-can-be-moved? (c -- bool)
	get-card-loc
	dup is-home-loc? if
		pop 0
	else dup is-work-loc? eif
		pop 1
	else dup is-pile-loc? eif
		split-pile-loc
		swap pile-height 1 - =
	else
		"Impossible card location: " swap strcat panic
	then
;
: remove-card (c home-allowed -- )
99 "remove-card" pstack
	swap dup get-card-loc
	( h-a c l )
99 "remove-card 2" pstack
	dup is-home-loc? if
99 "remove-card h" pstack
		( h-a c l )
		pop swap not if "Moving off home" panic then
		1 strcut dup get-home-height dup value-string-1-based
		( cv cs hh hv )
		4 rotate strcmp if "Removing wrong home card" panic then
		1 - set-home-height
	else dup is-work-loc? eif
99 "remove-card w" pstack
		( h-a c w )
		split-work-loc
		dup get-work-contents rot strcmp if
			"Removing wrong work card" panic
		then
		set-work-empty pop
	else dup is-pile-loc? eif
99 "remove-card p" pstack
		split-pile-loc
		( h-a c p cwp )
99 "remove-card p1" pstack
		over pile-height 1 - != if
			"Moving non-top pile card" panic
		then
		( h-a c c' )
99 "remove-card p2" pstack
		pile-pop-card strcmp if
			"Removing wrong pile card" panic
		then
		pop
	else
		"Impossible card location: " swap strcat panic
	then
;
: put-card-in (c l -- )
99 "put-card-in" pstack
	over over set-card-loc
	dup is-home-loc? if
		pop 1 strcut
		( cv cs )
		dup get-home-height dup value-string-0-based
		4 rotate strcmp if "Putting wrong card on home" panic then
		1 + set-home-height
	else dup is-work-loc? eif
		split-work-loc
		dup get-work-contents if "Overfilling work space" panic then
		swap set-work-card
	else dup is-pile-loc? eif
		split-pile-loc
		( c pno cwp )
		over pile-height != if "Wrong pile top" panic then
		swap pile-push-card
	else
		"Putting card in bad location: " swap strcat panic
	then
;
: move-card-to (c l -- ) over 0 remove-card put-card-in ;
: no-more-auto-moves
	"cdhs" begin dup while
		1 strcut swap dup get-home-height
		( othersuits suit height )
		dup 13 < if
			( s h )
			value-string-0-based swap strcat
			( card )
			dup card-can-be-moved? if
				"[Auto-move: " over " to home]"
				strcat strcat say
				"" move-card-to pop 0 exit
			else
				pop
			then
		else
			pop pop
		then
		( othersuits )
	loop
	pop 1
;
: auto-moves begin no-more-auto-moves until ;
: do-new
	pop
	is-playing? if
		dup not if
			pop "Discard current game? [N/y]" prompt
			1 strcut pop
		then
		"y" stringcmp if exit then
		get-nlost 1 + set-nlost
	then
	shuffled-deck
	0 set-work-empty
	-2 strcut 1 swap dup "w1" set-card-loc set-work-card
	-2 strcut 2 swap dup "w2" set-card-loc set-work-card
	3 set-work-empty
	"c" 0 set-home-height
	"d" 0 set-home-height
	"h" 0 set-home-height
	"s" 0 set-home-height
	0 9 1 for
		swap 10 strcut -rot 2 strcut 2 strcut 2 strcut 2 strcut
		0 4 1 for
			( pno c0 c1 c2 c3 c4 i )
			7 pick over make-pile-loc
			6 rot - pick swap set-card-loc
		loop
		5 pile-set
	loop
	pop
	"New game dealt." say
	show-game
	auto-moves
;
: do-pile
	nop
;
: do-work
	nop
;
: do-undo
	nop
;
: do-state
	pop show-game
;
: bad-cmd
	"Unrecognized command `" swap "'" strcat strcat say pop
;
: depth-check
	me @ prog owner dbcmp if
		depth if 99 "leftover" pstack then
	then
;
: main
	trigger @ "_function" getpropstr
	dup "cmd" stringcmp not if
		pop command @
	else dup "pfx" stringcmp not eif
		pop split-firstword
	then
	     dup "new"   stringcmp not  if pop do-new
	else dup "pile"  stringcmp not eif pop do-pile
	else dup "work"  stringcmp not eif pop do-work
	else dup "undo"  stringcmp not eif pop do-undo
	else dup "state" stringcmp not eif pop do-state
	else bad-cmd
	then
	depth-check
;
.
c
q