@prog pinochle.muf
1 9999 d
1 i
: obj trigger @ location ;
: sobj prog ;
: prefix "$ " ;
: deck "_pprop-deck" ;
: gamephase "_pprop-gamephase" ;
: sprop "_pprop-sprop" ;
: dealer "_pprop-dealer" ;
: turn "_pprop-turn" ;
: played "_pprop-played" ;
: turnup "_pprop-turnup" ;
: trumpsuit "_pprop-trumpsuit" ;
: turn "_pprop-turn" ;
: glupstate "_pprop-glupstate" ;
: -player "_pprop-player-" ;
: -hand "_pprop-hand-" ;
: -tricks "_pprop-tricks-" ;
: player -player swap intostr strcat ;
: hand -hand swap intostr strcat ;
: tricks -tricks swap intostr strcat ;
: setprop dup if 0 addprop else pop remove_prop then ;
: p@ obj swap getpropstr ;
: p! obj swap rot setprop ;
: pi@ obj swap getpropstr atoi ;
: pi! obj swap rot intostr setprop ;
: p++ dup pi@ 1 + swap pi! ;
: -score sprop p@ "-score-" strcat ;
: -snh sprop p@ "-nh-" strcat ;
: -shist sprop p@ "-hist-" strcat swap intostr strcat "-" strcat ;
: score -score swap player pi@ intostr strcat ;
: snh -snh swap player pi@ intostr strcat ;
: shist -shist swap player pi@ intostr strcat ;
: s@ sobj swap getpropstr ;
: s! sobj swap rot setprop ;
: si@ sobj swap getpropstr atoi ;
: si! sobj swap rot intostr setprop ;
: s++ dup si@ 1 + swap si! ;
: s+= dup si@ rot + swap si! ;
: p-name player pi@ dbref name ;
: p-turn-name turn pi@ p-name ;
: say me @ swap notify ;
: sayhere loc @ swap #-1 swap notify_except ;
: pfxsay prefix swap strcat say ;
: pfxsayhere prefix swap strcat sayhere ;
: pfxtell
	over location trigger @ location location dbcmp if
		prefix swap strcat notify
	else
		pop pop
	then
;
: capitalize 1 strcut swap toupper swap strcat ;
: add-a/an (not fully general, but good enough for what we use it for)
	dup 1 strcut pop
	dup not if pop pop "a" exit then
	"aeiouAEIOU" swap instr if "an " else "a " then swap strcat
;
(Assumptions:
	sortcards assumes cardvec is sorted according to strcmp
	suitvec order controls order of suit on hand display
	facevec must be in sorted order
	cardvec must not contain any digits
	the counter checking code knows that ifaces 3..5 are counters
)
: cardvec "abcdefghijklmnopqrstuvwx" ;
: suitvec "cdhs" ;
: facevec "9JQKTA" ;
: longsuitvec "spades" "hearts" "diamonds" "clubs" 4 ;
: longfacevec "ace" "ten" "king" "queen" "jack" "nine" 6 ;
: am-I-playing?
	1 player pi@ dbref me @ dbcmp if 1 exit then
	2 player pi@ dbref me @ dbcmp
;
: my-turn? turn pi@ player pi@ dbref me @ dbcmp ;
: s-to-i swap instr 1 - ;
: i-to-s swap strcut 1 strcut pop swap pop ;
: i-to-long-s
	dup 2 + rotate 2 + rotate
	1 rot 1 - 1 for pop swap pop loop
;
: card-to-icard cardvec s-to-i ;
: suit-to-isuit tolower suitvec s-to-i ;
: face-to-iface toupper facevec s-to-i ;
: icard-to-card cardvec i-to-s ;
: isuit-to-suit suitvec i-to-s ;
: iface-to-face facevec i-to-s ;
: isuit-to-long-suit longsuitvec i-to-long-s ;
: iface-to-long-face longfacevec i-to-long-s ;
: icard-isuit 6 / ;
: icard-iface 6 % ;
: icard-iface-isuit dup 6 % swap 6 / ;
: iface-isuit-to-icard 6 * + ;
: icard-suit icard-isuit isuit-to-suit ;
: icard-face icard-iface iface-to-face ;
: icard-long-suit icard-isuit isuit-to-long-suit ;
: icard-long-face icard-iface iface-to-long-face ;
: card-isuit card-to-icard icard-isuit ;
: card-iface card-to-icard icard-iface ;
: card-suit card-to-icard icard-suit ;
: card-face card-to-icard icard-face ;
: map-to-ext "10" "T" subst ;
: map-from-ext "T" "10" subst ;
: icard-to-ext
	dup 0 < if pop "??" exit then
	dup icard-face swap icard-suit strcat
	map-to-ext
;
: card-to-ext card-to-icard icard-to-ext ;
: cards-to-ext
	"" swap
	begin dup while
		1 strcut swap card-to-ext " " swap strcat rot swap strcat swap
	loop
	pop 1 strcut swap pop
;
: card-to-long-ext
	card-to-icard
	dup 0 < if pop "?? of ??" exit then
	dup icard-long-face swap icard-long-suit " of " swap strcat strcat
;
: ext-to-icard
	map-from-ext
	dup strlen 2 = not if pop pop -1 exit then
	1 strcut suit-to-isuit dup 0 < if pop pop -1 exit then
	swap face-to-iface dup 0 < if pop pop -1 exit then
	swap iface-isuit-to-icard
;
: ext-to-card ext-to-icard dup 0 < if pop "" else icard-to-card then ;
: split-into-suits (cards -- cards-s cards-h cards-d cards-c)
	(or whatever order suitvec has the suits in, above assumes cdhs)
	"0123" swap
	begin
		dup
	while
		( split left )
		1 strcut swap dup card-isuit intostr
		( split left x xs )
		4 rotate over explode pop
		( left x xs post pre )
		4 rotate strcat rot strcat swap strcat swap
	loop
	pop
	"3" explode pop "2" explode pop "1" explode pop "0" explode pop
	5 rotate pop
;
: iface-counter? 3 >= ;
: takes? (first-card second-card -- i)
	card-to-icard icard-iface-isuit rot card-to-icard icard-iface-isuit rot
	( f2 f1 s1 s2 )
	swap over = if
		pop >
	else
		swap pop swap pop
		trumpsuit pi@ =
	then
;
: incscore (pno inc -- )
	swap over over score s+=
	( inc pno )
	dup snh dup si@ 1 + dup rot si!
	( inc pno nh )
	shist si!
;
: clear-score-hist
	1 snh si@ 1 -1 for 1 swap shist "" swap s! loop
	2 snh si@ 1 -1 for 2 swap shist "" swap s! loop
	"" 1 snh s!
	"" 2 snh s!
;
: shuffle
	0 23 1 for icard-to-card dup dup dup loop
	"" 96 1 -1 for random swap % 2 + rotate strcat loop
	deck p!
;
: take-from-deck
	deck p@ swap strcut deck p!
;
: phase
	gamephase p@ strcmp not
;
: phasenot
	gamephase p@ strcmp
;
: mergecards
	""
	do
		rot dup not if pop swap strcat exit then
		rot dup not if pop strcat exit then
		over over strcmp 0 < if swap then
		1 strcut 4 rotate rot strcat
	loop
;
: sortcards
	dup strlen dup 2 < if pop exit then
	2 / strcut sortcards swap sortcards mergecards
;
: alljoined
	"_sprop-"
	1 player pi@ 2 player pi@ over over < if swap then
	intostr swap intostr "-" swap strcat strcat strcat
	sprop p!
	"predeal" gamephase p!
	random 2 % dealer pi!
	"Game begins; it is " dealer pi@ p-name strcat "'s deal." strcat pfxsayhere
;
: tellturn
	"It is " turn pi@ p-name strcat "'s turn to " strcat
	swap strcat "." strcat pfxsayhere
;
: tellhand
	dup hand p@ split-into-suits
	3 0 -1 for
		5 rotate cards-to-ext swap
		trumpsuit pi@ = if
			"<" swap ">" strcat strcat
		then
	loop
	1 3 1 for pop ".." swap strcat strcat loop
	"Your hand: " swap strcat
	swap player pi@ dbref swap pfxtell
;
: otherturn
	(not `3 swap -' or something; this is robust in the face of
	 weird things getting stored in turn...)
	1 = if 2 else 1 then
;
: glupcheck (just-played -- just-played)
	dup card-to-icard icard-iface-isuit
	played p@ card-to-icard icard-iface-isuit
	rot = if
		over over = if
			pop iface-counter? if
				"glup-glup-glouch" 3 (glup-glup-glouch)
			else
				"glup-glup" 2 (glup-glup)
			then
		else
			over swap < if
				iface-counter? if
					"glup-glouch" 2 (glup-glouch)
				else
					"glup" 1 (simple glup)
				then
			else
				pop 0 (not a glup at all)
			then
		then
	else
		pop pop 0 (not even the same suit)
	then
	dup if
		turn pi@ p-name " gets a " strcat rot strcat "." strcat pfxsayhere
pop ""
( XXX FINISH THIS!
		dup
		glupstate p@ 1 strcut swap atoi turn pi@ = if
			
		else
			pop
		then
		intostr turn pi@ intostr swap strcat
)
	else
		pop ""
	then
	glupstate p!
;
: playoff-play-ok?
	( attempted-play hand already-played --
	  attempted-play hand 1  /
	  0
	)
	pop 1 (XXX FIX THIS)
	(This routine must print a complaint if it returns 0.)
;
: finish-deal
	( XXX FIX THIS )
	"predeal" gamephase p!
	"Reset to pre-deal state" pfxsay
	"" 1 tricks p! "" 2 tricks p!
;
: doreset
	swap
	if "No argument allowed to " swap strcat "!" strcat pfxsay exit then
	pop
	"Game reset by " me @ name strcat "." strcat pfxsayhere
	"" deck p!
	"join" gamephase p!
	"" sprop p!
	"" dealer p!
	"" turn p!
	"" played p!
	"" turnup p!
	"" trumpsuit p!
	"" turn p!
	"" glupstate p!
	1 2 1 for
		"" over player p!
		"" over hand p!
		"" over tricks p!
		pop
	loop
;
: dojoin
	swap
	if "No argument allowed to " swap strcat "!" strcat pfxsay exit then
	pop
	"join" phasenot if "The game has already begun!" pfxsay exit then
	1 player p@ dup if
		atoi dbref me @ dbcmp if
			"You are already playing!" pfxsay exit
		then
		me @ name " has joined the game." strcat pfxsayhere
		me @ int 2 player pi!
		alljoined
	else
		me @ name " has joined the game." strcat pfxsayhere
		pop me @ int 1 player pi!
	then
;
: dodeal
	swap
	if "No argument allowed to " swap strcat "!" strcat pfxsay exit then
	pop
	"join" phase if "The game hasn't begun yet!" pfxsay exit then
	am-I-playing? not if "You're not playing!" pfxsay exit then
	"predeal" phasenot if "The cards have already been dealt!" pfxsay exit then
	dealer pi@ player pi@ dbref me @ dbcmp not if
		"It's not your turn to deal!" pfxsay exit
	then
	shuffle
	18 take-from-deck sortcards 1 hand p!
	18 take-from-deck sortcards 2 hand p!
	1 take-from-deck
	dup turnup p!
	card-isuit trumpsuit pi!
	dealer pi@ p-name " deals, turning up " strcat
	turnup p@ card-to-long-ext add-a/an strcat "." strcat pfxsayhere
	turnup p@ card-face "9" strcmp not if
		dealer pi@ p-name " scores 1 for the nine." strcat pfxsayhere
		dealer pi@ 1 incscore
	then
	1 tellhand
	2 tellhand
	"" 1 tricks p! "" 2 tricks p!
	clear-score-hist
	"meldplay" gamephase p!
	"Meld play begins." pfxsayhere
	"" played p!
	dealer pi@ otherturn turn pi! "lead" tellturn
;
: doplay
	pop
	"join" phase if "The game hasn't begun yet!" pfxsay pop exit then
	am-I-playing? not if "You're not playing!" pfxsay pop exit then
	"predeal" phase if "The cards haven't been dealt yet!" pfxsay pop exit then
	"melddraw" phase "meldmeld" phase or if
		"You must draw before you can play again!" pfxsay pop exit
	then
	my-turn? not if
		played p@ if
			"You've already led!"
		else
			"You must wait for " p-turn-name strcat " to lead!" strcat
		then
		pfxsay pop exit
	then
	dup not if "You must name a card to play!" pfxsay pop exit then
	ext-to-card
	dup not if "That's not a valid card name!" pfxsay pop exit then
	turn pi@ hand p@
	dup 3 pick instr not if
		"You don't have "
		rot card-to-long-ext add-a/an strcat "!" strcat
		pfxsay pop exit
	then
	"playoff" phase if
		played p@ dup if
			playoff-play-ok? not if exit then
		else
			pop
		then
	then
	me @ name played p@ if " plays" else " leads" then strcat
	": " strcat 3 pick card-to-ext strcat "." strcat pfxsayhere
	dup 3 pick instr 1 - strcut 1 strcut swap pop strcat turn pi@ hand p!
	played p@ if
		"meldplay" phase if
			glupcheck
		then
		turn pi@ played p@ 3 pick takes? not if otherturn then
		dup turn pi! p-name " takes the trick." strcat pfxsayhere
		played p@ swap strcat turn pi@ tricks dup p@ rot strcat swap p!
		"meldplay" phase if
			"meldmeld" gamephase p!
			"meld or draw" tellturn
		else
			1 hand p@ not if
				finish-deal
			else
				"lead" tellturn
			then
		then
		""
	else
		turn pi@ otherturn turn pi!
		"play" tellturn
	then
	played p!
;
: dodraw
	swap
	if "No argument allowed to " swap strcat "!" strcat pfxsay exit then
	pop
	"join" phase if "The game hasn't begun yet!" pfxsay exit then
	am-I-playing? not if "You're not playing!" pfxsay exit then
	"predeal" phase if "The cards haven't been dealt yet!" pfxsay exit then
	"playoff" phase if "You don't draw in the playoff!" pfxsay exit then
	my-turn? not if "It's not your turn!" pfxsay exit then
	deck p@ if
		played p@ if "lead" "meldplay" "" else "draw" "melddraw" "yes" then played p!
		1 take-from-deck
		me @ name " draws." strcat pfxsayhere
		swap gamephase p!
	else
		"lead" "" played p!
		turnup p@
		me @ name " draws the final " strcat
		over card-to-long-ext strcat "." strcat pfxsayhere
		"Playoff play begins." pfxsayhere
	then
	"You get " over card-to-long-ext add-a/an strcat "." strcat pfxsay
	turn pi@ hand dup p@ rot strcat sortcards swap p!
	turn pi@ tellhand
	turn pi@ otherturn turn pi! tellturn
;
: domeld
	pop
	"join" phase if "The game hasn't begun yet!" pfxsay pop exit then
	am-I-playing? not if "You're not playing!" pfxsay pop exit then
	"predeal" phase if "The cards haven't been dealt yet!" pfxsay pop exit then
	"playoff" phase if "You don't meld in the playoff!" pfxsay pop exit then
	my-turn? not if "It's not your turn!" pfxsay pop exit then
	"meldmeld" phase not if "You can't meld now!" pfxsay pop exit then
	
;
: dostatus
	swap
	if "No argument allowed to " swap strcat "!" strcat pfxsay exit then
	pop
	"join" phase if
		1 player p@ dup if
			atoi dbref name
			" has joined and is waiting for another player."
		else
			"Nobody is playing."
		then
		strcat pfxsay
		exit
	then
	1 p-name " and " 2 p-name " are playing." strcat strcat strcat pfxsay
	"predeal" phase if
		"The cards have not yet been dealt." pfxsay
		"It is " dealer pi@ p-name "'s turn to deal." strcat strcat pfxsay
		exit
	then
	"meldplay" phase if
		"Meld play is in progress." pfxsay
		played p@ dup if
			turn pi@ otherturn p-name " has led " strcat
			swap card-to-ext strcat "; it is " strcat
			p-turn-name strcat "'s turn to play." strcat
		else
			"It is " p-turn-name strcat "'s turn to lead." strcat
		then
		pfxsay
		my-turn? if turn pi@ tellhand then
		exit
	then
	"meldmeld" phase if
		"Meld play is in progress." pfxsay
		p-turn-name " has taken a trick and may meld or draw." strcat
		pfxsay
		my-turn? if turn pi@ tellhand then
		exit
	then
	"melddraw" phase if
		"Meld play is in progress." pfxsay
		turn pi@ otherturn p-name
		" has taken a trick and drawn; it is " strcat
		p-turn-name strcat "'s turn to draw." strcat pfxsay
		my-turn? if turn pi@ tellhand then
		exit
	then
	"playoff" phase if
		"Playoff play is in progress." pfxsay
		played p@ dup if
			turn pi@ otherturn p-name " has led " strcat
			swap card-to-ext strcat "; it is " strcat
			p-turn-name strcat "'s turn to play." strcat
		else
			"It is " p-turn-name strcat "'s turn to lead." strcat
		then
		pfxsay
		my-turn? if turn pi@ tellhand then
		exit
	then
	"Internal error: unknown phase `" gamephase p@ strcat "'" strcat pfxsay
;
: dofoo
	pop pop
	"predeal" gamephase p!
	"Reset to pre-deal state" pfxsay
;
: main
	trigger @ "action" getpropstr
	dup not if pop trigger @ name then
	dup "reset" strcmp not if doreset exit then
	dup "join" strcmp not if dojoin exit then
	dup "deal" strcmp not if dodeal exit then
	dup "play" strcmp not if doplay exit then
	dup "draw" strcmp not if dodraw exit then
	dup "meld" strcmp not if domeld exit then
	dup "status" strcmp not if dostatus exit then
	dup "foo" strcmp not if dofoo exit then
	"Unrecognized command `" swap strcat "'." strcat pfxsay
;
.
c
q