( MUF-Cribbage Version 2.01. Concept and code by Sjade ) ( Main card and peggging scoring routines by der Mouse ) () ( This code is freely usable by permission of both of ) ( the co-authors listed above with the following stip- ) ( ulations. [1] This header is to be left intact and ) ( all mention of the authors associated with this game ) ( must be left in place and unaltered. [2] All changes ) ( made to the stock code as distributed in this file be ) ( sent via mail to either sjade@hobbes.cs.mcgill.ca or ) ( mouse@collatz.mcrcim.mcgill.edu. Thank you. ) () ( Include the following word if using on fuzzball server ) () ( : & ) ( bitand ) ( ; ) () ( Use the following word and change all references of ) ( addprop to add_prop in the program, except the one in ) ( this word, if your addprop is so braindead that "" 0 ) ( results in adding the 0 instead of the null string. ) () : add_prop over not if pop pop remove_prop else addprop then ; () ( Uncomment the following word on systems with no roll ) () : roll over swap - over % dup 0 < if over + then begin dup 0 > while over 2 + rotate rot rot 1 - loop pop pop ; () : merge over 4 pick + -4 rotate begin over 4 pick and while over 4 pick + 4 + pick 3 pick 5 + pick 3 pick execute if rot 1 - -3 rotate else over 4 + rotate 4 pick 4 pick + 4 + -1 * rotate swap 1 - swap then loop pop pop pop ; : sort (x1 ... xN N fn -- x1 ... xN N) over 2 < if pop exit then over 2 / rot over - over 3 + -1 * rotate over over 3 + -1 * rotate swap sort dup 2 + pick over 4 + pick 3 pick + 4 + 3 pick 2 + roll sort dup 3 + rotate swap dup 3 + rotate merge ; : say ( s -- ) me @ swap notify ; : sayall ( s -- ) loc @ me @ rot notify_except ; : announce ( s -- ) loc @ #-1 rot notify_except ; : strip ( s -- s ) dup not if exit then begin dup 1 strcut pop " " stringcmp not while 1 strcut swap pop loop begin dup dup strlen 1 - strcut swap pop " " stringcmp not while dup strlen 1 - strcut pop loop ; : cmd ( s -- s ) dup dup " " instr dup if 1 - strcut pop else pop then ; : arg ( s -- s ) dup " " instr dup if strcut swap pop strip else pop pop "" then ; : board ( -- d ) trigger @ location ; : crib? ( -- i ) board ".handtotal1" getpropstr not board ".handtotal2" getpropstr not and ; : turn ( -- i ) board ".turn" getpropstr atoi ; : pegturn ( -- i ) board ".pegturn" getpropstr atoi ; : !pegturn ( -- i ) pegturn 1 = if 2 else 1 then ; : next_turn ( -- ) turn 1 = if board ".turn" "2" 0 add_prop else board ".turn" "1" 0 add_prop then ; : next_pegturn ( -- ) pegturn 1 = if board ".pegturn" "2" 0 add_prop else board ".pegturn" "1" 0 add_prop then ; : cp ( -- d ) ".player" turn intostr strcat board swap getpropstr atoi dbref ; : op ( -- d ) turn 1 = if "2" else "1" then ".player" swap strcat board swap getpropstr atoi dbref ; : playing? ( d -- i ) board ".player1" getpropstr atoi dbref over dbcmp board ".player2" getpropstr atoi dbref rot dbcmp or ; : player ( d -- i ) dup playing? not if pop 0 exit then board ".player1" getpropstr atoi dbref swap dbcmp if 1 else 2 then ; : !player ( d -- i ) dup player? not if pop 0 exit then board ".player1" getpropstr atoi dbref swap dbcmp if 2 else 1 then ; : p1 ( -- d ) board ".player1" getpropstr atoi dbref ; : p2 ( -- d ) board ".player2" getpropstr atoi dbref ; : announce_pegturn ( -- ) pegturn 1 = if p1 else p2 then "## It is now %t's turn." over name "%t" subst announce "## Your hand is [%h]" board ".hand" pegturn intostr strcat getpropstr "%h" subst notify ; : game_ready? ( -- i ) board ".player1" getpropstr board ".player2" getpropstr and ; : pegging_display ( -- ) "## " p1 name strcat " [" strcat board ".played1" getpropstr strip dup strlen " " swap strcut swap pop strcat strcat "] => " strcat board ".total" getpropstr atoi intostr dup strlen " " swap strcut swap pop swap strcat strcat " <= [" strcat board ".played2" getpropstr strip dup strlen " " swap strcut swap pop strcat strcat "] " strcat p2 name strcat announce ; : lap ( i -- i ) board ".peg" 3 pick intostr strcat "1" strcat getpropstr board ".peg" 4 rotate intostr strcat "2" strcat getpropstr over not over not and if pop pop 0 exit then over atoi 60 > over atoi 60 > or if 2 else 1 then swap pop swap pop ; : unparse_card ( s -- s ) 1 strcut ".sn" swap strcat board swap getpropstr swap ".cn" swap strcat board swap getpropstr " of " strcat swap strcat ; : face_value ( s -- i ) 1 strcut pop dup atoi if atoi exit then dup "A" stringcmp not if pop 1 exit then pop 10 ; : cut_face_value ( s -- i ) 1 strcut pop dup atoi if atoi exit then dup "A" stringcmp not if pop 1 exit then dup "K" stringcmp not if pop 13 exit then dup "Q" stringcmp not if pop 12 exit then dup "J" stringcmp not if pop 11 exit then pop 10 ; : suit_value ( s -- i ) 1 strcut swap pop tolower "1" "s" subst "2" "d" subst "3" "c" subst "4" "h" subst atoi ; : game_full? ( -- i ) board ".player1" getpropstr board ".player2" getpropstr and ; : explode_clear ( x1 x2 .. xN N -- ) begin dup while swap pop 1 - loop pop ; : can_play? ( i -- i ) board ".hand" 3 pick intostr strcat getpropstr dup not if pop pop 0 exit then strip " " explode begin dup while board ".total" getpropstr atoi 3 pick face_value + 31 <= if explode_clear pop 1 exit then swap pop 1 - loop pop pop 0 ; : repair_card ( s -- s ) 1 strcut tolower swap toupper swap strcat ; : pegval ( i i -- i ) board ".peg" 4 rotate intostr strcat rot intostr strcat getpropstr atoi ; : hipeg ( i -- i ) dup 1 pegval swap 2 pegval over over >= if pop else swap pop then ; : lopeg ( i -- i ) dup 1 pegval swap pegval over over >= if swap pop else pop then ; : winner? ( i -- i ) board ".length" getpropstr if dup 1 pegval 60 > swap 2 pegval 60 > or else dup 1 pegval 120 > swap 2 pegval 120 > or then ; : game_over ( i -- ) dup 1 = if 2 else 1 then board ".length" getpropstr over hipeg 90 > or if pop "## " board ".player" 4 rotate intostr strcat getpropstr atoi dbref name strcat " has won the game!" strcat announce else "## %w has won the game and %s %l!" over hipeg 91 < if "skunked" "%s" subst then over hipeg 61 < if "double skunked" "%s" subst then board ".player" 4 rotate intostr strcat getpropstr atoi dbref name "%l" subst board ".player" 4 rotate intostr strcat getpropstr atoi dbref name "%w" subst announce then board ".game_over" "yes" 0 add_prop ; : peg ( i i -- i ) dup not if pop "## " board ".player" 4 rotate intostr strcat getpropstr atoi dbref name strcat " has a '19' hand, " strcat "worth no points." strcat announce 0 exit then swap dup rot board ".peg" 4 pick intostr strcat "1" strcat getpropstr atoi board ".peg" 5 pick intostr strcat "2" strcat getpropstr atoi >= if ".peg" 3 pick intostr strcat "1" strcat else ".peg" 3 pick intostr strcat "2" strcat then board over getpropstr atoi 3 pick + dup 121 >= if pop 121 then intostr swap dup strlen 1 - strcut "2" stringcmp not if "1" else "2" then strcat board swap rot 0 add_prop "## " rot 1 = if p1 else p2 then name strcat " pegs off " strcat over intostr strcat " points." strcat swap 1 = if "point" "points" subst then announce winner? ; : shuffle ( -- ) board ".suit1" "As2s3s4s5s6s7s8s9sTsJsQsKs" 0 add_prop board ".suit2" "Ac2c3c4c5c6c7c8c9cTcJcQcKc" 0 add_prop board ".suit3" "Ah2h3h4h5h6h7h8h9hThJhQhKh" 0 add_prop board ".suit4" "Ad2d3d4d5d6d7d8d9dTdJdQdKd" 0 add_prop ; : pick_cards ( i -- s ) "" begin over while random 4 % 1 + intostr ".suit" swap strcat board over getpropstr dup strlen 2 / random swap % 2 * strcut 2 strcut rot swap strcat board 4 rotate rot 0 add_prop strcat " " strcat swap 1 - swap loop swap pop dup strlen 1 - strcut pop ; : hand_reset ( -- ) shuffle board ".handtotal1" remove_prop board ".handtotal2" remove_prop board ".cribtotal" remove_prop board ".dispute" remove_prop board ".h1" remove_prop board ".h2" remove_prop board ".c" remove_prop board ".hand1" remove_prop board ".hand2" remove_prop board ".dealt" remove_prop board ".played1" remove_prop board ".played2" remove_prop board ".crib1" remove_prop board ".crib2" remove_prop board ".cc" remove_prop board ".total" remove_prop board ".seq" remove_prop board ".pegturn" remove_prop ; : do_reset ( -- ) dup arg tolower "h" instr if board ".length" "half" 0 add_prop else board ".length" remove_prop then arg tolower "m" instr if board ".manual" "yes" 0 add_prop else board ".manual" remove_prop then board ".player1" remove_prop board ".player2" remove_prop board ".turn" remove_prop board ".cut1" remove_prop board ".cut2" remove_prop board ".peg11" remove_prop board ".peg12" remove_prop board ".peg21" remove_prop board ".peg22" remove_prop board ".game_over" remove_prop board ".sns" "spades" 0 add_prop board ".snd" "diamonds" 0 add_prop board ".snc" "clubs" 0 add_prop board ".snh" "hearts" 0 add_prop board ".cnA" "Ace" 0 add_prop board ".cn2" "2" 0 add_prop board ".cn3" "3" 0 add_prop board ".cn4" "4" 0 add_prop board ".cn5" "5" 0 add_prop board ".cn6" "6" 0 add_prop board ".cn7" "7" 0 add_prop board ".cn8" "8" 0 add_prop board ".cn9" "9" 0 add_prop board ".cnT" "10" 0 add_prop board ".cnJ" "Jack" 0 add_prop board ".cnQ" "Queen" 0 add_prop board ".cnK" "King" 0 add_prop hand_reset "## " me @ name strcat " resets the game." strcat sayall "## You reset the game." say board ".length" getpropstr if "## Next game has been set to half length." announce else "## Next game has been set to full length." announce then board ".manual" getpropstr if "## Next game has been set to manual pegging." announce else "## Next game has been set to automatic pegging." announce then ; : do_join ( -- ) me @ playing? if "## You are already joined." say exit then game_full? if "## Two people are already joined." say exit then board ".player1" getpropstr if board ".player2" me @ intostr 0 add_prop else board ".player1" me @ intostr 0 add_prop then "## " me @ name strcat " joins the game." strcat sayall "## You join the game." say ; : do_deal ( -- ) board ".dealt" getpropstr if "## Hand is in progress." say exit then me @ player not if "## You're not in this game!" say exit then me @ player turn = not if "## It's not your turn to deal." say exit then "## " me @ name strcat " deals the hand." strcat sayall "## You deal the hand." say 6 pick_cards "## Your hand is [" over strcat "]" strcat p1 swap notify board ".hand1" rot 0 add_prop 6 pick_cards "## Your hand is [" over strcat "]" strcat p2 swap notify board ".hand2" rot 0 add_prop board ".dealt" "yes" 0 add_prop ; : do_cutcard ( -- ) me @ player not if "## You're not playing!" say exit then me @ op dbcmp not if "## It's not your turn to cut." say exit then crib? not if "## A crib must be decided first." say exit then board ".cc" getpropstr if "## A cut card has already been chosen!" say exit then 1 pick_cards "## " me @ name strcat " cuts the " strcat over unparse_card strcat "." strcat sayall "## You cut the " over unparse_card strcat "." strcat say board ".cc" 3 pick 0 add_prop "J" 1 strncmp not if "## Lead cut is a Jack." announce cp player 2 peg if cp player game_over exit then then "## Pegging play begins with " op name strcat "." strcat announce op player intostr board ".pegturn" rot 0 add_prop op "## Your hand is [%h]" board ".hand" pegturn intostr strcat getpropstr "%h" subst notify ; : do_cut ( -- ) board ".dealt" getpropstr if do_cutcard exit then me @ player dup not if pop "## You're not playing!" say exit then turn if pop "## Lead deal is already determined." say exit then board ".cut" 3 pick intostr strcat getpropstr if pop "## You have already cut for deal." say exit then game_ready? not if pop "## Two people must join first." say exit then 1 pick_cards "## " me @ name strcat " cuts the " strcat over unparse_card strcat "." strcat sayall "## You cut the " over unparse_card strcat "." strcat say ".cut" rot intostr strcat board swap rot 0 add_prop board ".cut1" getpropstr board ".cut2" getpropstr and if board ".cut1" getpropstr cut_face_value board ".cut2" getpropstr cut_face_value over over = if pop pop "## Cards tie. Cut again." announce board ".cut1" remove_prop board ".cut2" remove_prop exit then < if "## Player 1, " p1 name strcat ", has first deal and crib." strcat announce board ".turn" "1" 0 add_prop else "## Player 2, " p2 name strcat ", has first deal and crib." strcat announce board ".turn" "2" 0 add_prop then then ; : dump_row ( -- s ) ".............................." dup strcat ; : place_peg ( s i -- s ) 1 - strcut 1 strcut swap pop "!" swap strcat strcat ; : insert_spaces ( s -- s ) 60 begin dup while dup dup 30 % swap 5 % not and if swap over strcut " " swap strcat strcat swap then 1 - loop pop ; : reverse ( s -- s ) "" swap 1 begin dup 35 <= while swap dup strlen 1 - strcut 4 rotate swap strcat swap rot 1 + loop pop pop ; : card-suit 1 strcut swap pop ; : card-value-15 1 strcut pop dup "A" strcmp not if pop "1" then "TJQK" over instr if pop "10" then atoi ; : card-value-run 1 strcut pop dup "A" strcmp not if pop "1" then dup "T" strcmp not if pop "10" then dup "J" strcmp not if pop "11" then dup "Q" strcmp not if pop "12" then dup "K" strcmp not if pop "13" then atoi ; : compute-select-sum (n16 n8 n4 n2 n1 x n -- n16 n8 n4 n2 n1 x n sum) 0 over 1 & if 4 pick + then over 2 & if 5 pick + then over 4 & if 6 pick + then over 8 & if 7 pick + then over 16 & if 8 pick + then ; : sort-2 over over > if swap then ; : sort-3 over over < if swap then rot sort-2 rot sort-2 ; : sort-5 sort-3 -5 rotate -5 rotate sort-3 5 rotate sort-3 rot 5 rotate sort-3 4 rotate sort-3 ; : score-15s " " explode pop 5 rotate card-value-15 5 rotate card-value-15 5 rotate card-value-15 5 rotate card-value-15 5 rotate card-value-15 0 3 begin (should be "0 begin" for completeness - we optimize) compute-select-sum 15 = if swap 1 + swap then 1 + dup 31 <= while loop pop -6 rotate pop pop pop pop pop 2 * ; : score-pairs " " explode pop 0 1 begin dup 1 + begin over 3 + pick over 4 + pick 1 strncmp not if rot 1 + rot rot then 1 + dup 5 <= while loop pop 1 + dup 4 <= while loop pop -6 rotate pop pop pop pop pop 2 * ; : run-maybe-pick (n16 n8 n4 n2 n1 s n o b -- ... s [nb] n o b) 3 pick over & if over pick 4 rotate 4 rotate 1 + 4 rotate then ; : check-run (n16 n8 n4 n2 n1 s n -- n16 n8 n4 n2 n1 s 1/0) 9 16 begin run-maybe-pick 2 / swap 1 - swap dup 0 > while loop pop swap pop begin dup 5 > while 1 - swap 3 pick 1 + = not if begin dup 4 > while 1 - swap pop loop pop 0 exit then loop pop pop 1 ; : score-runs " " explode pop 5 rotate card-value-run 5 rotate card-value-run 5 rotate card-value-run 5 rotate card-value-run 5 rotate card-value-run sort-5 0 31 check-run if 5 + then dup 0 = if 15 check-run if 4 + then 23 check-run if 4 + then 27 check-run if 4 + then 29 check-run if 4 + then 30 check-run if 4 + then then dup 0 = if 7 check-run if 3 + then 11 check-run if 3 + then 13 check-run if 3 + then 14 check-run if 3 + then 19 check-run if 3 + then 21 check-run if 3 + then 22 check-run if 3 + then 25 check-run if 3 + then 26 check-run if 3 + then 28 check-run if 3 + then then -6 rotate pop pop pop pop pop ; : score-flushes- " " explode pop card-suit swap card-suit strcat swap card-suit strcat swap card-suit strcat swap card-suit strcat dup "ccccc" strcmp not if pop 5 exit then dup "ddddd" strcmp not if pop 5 exit then dup "hhhhh" strcmp not if pop 5 exit then dup "sssss" strcmp not if pop 5 exit then 4 strcut pop dup "cccc" strcmp not if pop 4 exit then dup "dddd" strcmp not if pop 4 exit then dup "hhhh" strcmp not if pop 4 exit then dup "ssss" strcmp not if pop 4 exit then pop 0 ; : score-flushes score-flushes- ; : score-jack 13 strcut "J" swap strcat instr if 1 else 0 then ; : count_cards ( cards -- score ) "## Determining the value of %n's hand, [%h (%c)]..." swap 3 = if "the crib" "%n's hand" subst else rot name "%n" subst then board ".played" 4 rotate intostr strcat getpropstr strip swap over "%h" subst board ".cc" getpropstr strip swap over "%c" subst announce " " swap strcat strcat dup score-15s over score-pairs + over score-runs + over score-flushes + over score-jack + swap pop ; : check_pairs ( s1 ... sN N i -- i ) over 2 > if 4 pick cut_face_value 6 pick cut_face_value = if pop 6 else pop explode_clear 2 exit then else pop explode_clear 2 exit then over 3 > if 5 pick cut_face_value 7 pick cut_face_value = if pop 12 else pop explode_clear 6 exit then else pop explode_clear 6 exit then over 2 + 0 swap - rotate explode_clear ; : check_peg_run ( s1 ... sN N i -- i ) 1 begin dup 4 pick < while dup 3 + pick cut_face_value over 5 + pick cut_face_value 1 + = if swap 1 + swap 1 + else pop over 2 + 0 swap - rotate explode_clear exit then loop pop over 2 + 0 swap - rotate explode_clear ; : card_compare ( -- ) cut_face_value swap cut_face_value > ; : count_sequence ( cards -- score ) " " explode dup 1 > if over cut_face_value 4 pick cut_face_value = if 2 check_pairs exit then then dup 2 > if dup over 2 + 0 swap - rotate explode_clear begin dup 2 > while board ".seq" getpropstr strip " " strcat over 3 * strcut pop strip " " explode 'card_compare sort 1 check_peg_run over over = if swap pop exit then pop 1 - loop then pop 0 ; : do_display ( -- ) "## .-------------------------------------." say dump_row board ".peg11" getpropstr atoi dup if dup 60 > if 60 - then place_peg else pop then board ".peg12" getpropstr atoi dup if dup 60 > if 60 - then place_peg else pop then insert_spaces 35 strcut reverse swap "## | " swap strcat " | P1: " strcat board ".player1" getpropstr dup if atoi dbref name strcat " (L=" strcat 1 lap intostr strcat ",HP=" strcat 1 hipeg intostr strcat ")" strcat else pop then say "## | " swap strcat " |" strcat say "## | | CC: " board ".cc" getpropstr strcat say dump_row board ".peg21" getpropstr atoi dup if dup 60 > if 60 - then place_peg else pop then board ".peg22" getpropstr atoi dup if dup 60 > if 60 - then place_peg else pop then insert_spaces 35 strcut reverse "## | " swap strcat " |" strcat say "## | " swap strcat " | P2: " strcat board ".player2" getpropstr dup if atoi dbref name strcat " (L=" strcat 2 lap intostr strcat ",HP=" strcat 2 hipeg intostr strcat ")" strcat else pop then say "## |_____________________________________|" say ; : do_crib ( s -- ) me @ playing? not if pop "## You're not playing!" say exit then " " explode dup 2 = not if explode_clear "## Invalid number of cards." say exit then me @ player ".crib" swap intostr strcat board swap getpropstr if explode_clear "## You've already cribbed two cards." say exit then board ".dealt" getpropstr not if explode_clear "## No hand has been dealt yet." say exit then me @ player ".hand" swap intostr strcat board swap getpropstr swap pop dup tolower 3 pick tolower instr not over tolower 5 pick tolower instr not or if pop pop pop "## One or both cards invalid." say exit then over 4 pick stringcmp not if pop pop pop "## Those two cards are identical!" say exit then swap repair_card rot repair_card rot "" 3 pick subst "" 4 pick subst " " " " subst " " " " subst strip me @ player ".hand" swap intostr strcat board swap rot 0 add_prop " " swap strcat strcat me @ player ".crib" swap intostr strcat board swap rot 0 add_prop "## You submit two cards to the crib." say "## " me @ name strcat " submits two cards to the crib." strcat sayall board ".crib1" getpropstr board ".crib2" getpropstr and if "## It is " op name strcat "'s cut." strcat announce then ; : do_play ( s -- ) pegturn not if pop "## Pegging play has not begun." say exit then me @ player pegturn = not if pop "## It is not your turn to play." say exit then dup strlen 2 = not if pop "## Play what?" say exit then board ".hand" pegturn intostr strcat getpropstr dup tolower 3 pick tolower instr not if pop pop "## You don't have that card." say exit then swap repair_card swap board ".total" getpropstr atoi 3 pick face_value + 31 > if pop pop "## Total would exceed 31." say exit then "" 3 pick subst " " " " subst strip board ".hand" pegturn intostr strcat rot 0 add_prop board ".played" pegturn intostr strcat getpropstr over " " strcat strcat board ".seq" getpropstr 3 pick " " strcat swap strcat board ".seq" rot strip 0 add_prop board ".played" pegturn intostr strcat rot 0 add_prop "## You play the " over unparse_card strcat "." strcat say "## " me @ name strcat " plays the " strcat over unparse_card strcat "." strcat sayall board ".seq" getpropstr strip count_sequence dup if pegturn swap peg if pop pegturn game_over exit then else pop then board ".total" getpropstr atoi over face_value + board ".total" 3 pick intostr 0 add_prop dup 31 = if board ".total" "0" 0 add_prop board ".seq" remove_prop board ".hand1" getpropstr not board ".hand2" getpropstr not and if 1 else 2 then pegturn swap peg if pegturn game_over exit then then dup 15 = if pegturn 2 peg if pegturn game_over exit then then pop board ".hand1" getpropstr not board ".hand2" getpropstr not and if "## %t plays the last card in the hand." board ".player" pegturn intostr strcat getpropstr atoi dbref name "%t" subst announce pegturn 1 peg if pop pegturn game_over exit then board ".manual" getpropstr not if pop op dup player dup count_cards op player swap peg if op player game_over exit then cp dup player dup count_cards cp player swap peg if cp player game_over exit then board ".crib1" getpropstr strip " " strcat board ".crib2" getpropstr strip strcat board ".played" cp player intostr strcat rot 0 add_prop cp dup player 3 count_cards cp player swap peg if cp player game_over exit then next_turn hand_reset "## It is now %p's turn to deal." cp name "%p" subst announce exit else pop op dup player dup count_cards intostr board ".handtotal" op player intostr strcat rot 0 add_prop cp dup player dup count_cards intostr board ".handtotal" cp player intostr strcat rot 0 add_prop board dup ".played1" getpropstr strip swap ".cc" getpropstr " " swap strcat strcat strip board ".h1" rot 0 add_prop board dup ".played2" getpropstr strip swap ".cc" getpropstr " " swap strcat strcat strip board ".h2" rot 0 add_prop board ".crib1" getpropstr strip " " strcat board ".crib2" getpropstr strip strcat dup board ".cc" getpropstr " " swap strcat strcat strip board ".c" rot 0 add_prop board ".played" cp player intostr strcat rot 0 add_prop cp dup player 3 count_cards intostr board ".cribtotal" rot 0 add_prop "## %n counts %p hand first." op name "%n" subst op swap pronoun_sub announce board ".pegturn" op player intostr 0 add_prop exit then pop op dup then next_pegturn pegturn can_play? not if next_pegturn pegturn can_play? not if board ".total" "0" 0 add_prop board ".seq" remove_prop "## %p takes a go." board ".player" pegturn intostr strcat getpropstr atoi dbref name "%p" subst announce pegturn 1 peg if pegturn game_over exit then next_pegturn pegturn can_play? not if next_pegturn then pegging_display announce_pegturn exit then then pegging_display announce_pegturn ; : do_hand_pegging ( s -- ) strip me @ playing? not if pop "## You're not playing!" say exit then board ".handtotal1" getpropstr not board ".handtotal2" getpropstr not board ".cribtotal" getpropstr not and and if pop "## It's not time to count hands." say exit then board ".dispute" getpropstr if pop "## A dispute must be settled or waived first." say exit then me @ player pegturn = not if pop "## It's not your turn to count." say exit then "## %n enters a score of %s for %p hand; dispute, %o?" crib? if "crib" "hand" subst then me @ name "%n" subst over "%s" subst me @ swap pronoun_sub board ".player" !pegturn intostr strcat getpropstr atoi dbref name "%o" subst announce board ".dispute" rot 0 add_prop ; : next_hand_count ( -- ) board ".dispute" remove_prop crib? if next_turn hand_reset "## It is now %p's turn to deal." cp name "%p" subst announce exit else board ".handtotal" pegturn intostr strcat remove_prop pegturn turn = not if next_pegturn then then "## It's %n's turn to count %p hand." board ".player" pegturn intostr strcat getpropstr atoi dbref dup rot swap name "%n" subst pronoun_sub crib? if "crib" "hand" subst then announce ; : do_dispute ( s -- ) strip tolower board ".dispute" getpropstr not if pop "## There is nothing to dispute." say exit then me @ player pegturn = if pop "## It's not your turn to dispute." say exit then dup "n" 1 strncmp not over "o" 1 strncmp 3 pick "m" 1 strncmp and or if pop "## %n does not dispute the count." me @ name "%n" subst announce pegturn board ".dispute" getpropstr atoi peg dup if pegturn game_over exit else next_hand_count exit then then dup "o" 1 strncmp not if pop "## %n claims the count is over." me @ name "%n" subst announce crib? if board ".cribtotal" getpropstr atoi else board ".handtotal" pegturn intostr strcat getpropstr atoi then board ".dispute" getpropstr atoi over over < if "## Count is over, actual points pegged." announce pop else "## Count not over, counted score stands." announce swap pop then pegturn swap peg dup if pegturn game_over exit else next_hand_count exit then then dup "m" 1 strncmp not if dup " " instr not if "## You must specify a point value for a muggins dispute." say pop exit then dup " " instr strcut swap pop atoi dup not if "## A muggins dispute value must be positive." say pop exit then "## %n claims a muggins of %p points." me @ name "%n" subst over intostr "%p" subst over atoi 1 = if "point" "points" subst then announce crib? if board ".cribtotal" getpropstr atoi else board ".handtotal" pegturn intostr strcat getpropstr atoi then board ".dispute" getpropstr atoi 3 pick + >= if "## Hand count is short, muggins awarded." announce board ".dispute" getpropstr atoi pegturn swap peg if pegturn game_over exit then !pegturn swap peg if !pegturn game_over exit then else "## Muggins dispute incorrect, count stands." announce board ".dispute" getpropstr atoi pegturn swap peg if pegturn game_over exit then pop then next_hand_count exit then ; : do_status ( -- ) "## Status:" say board ".game_over" getpropstr if "## Game has ended, type '%tdisplay' for results." trigger @ "PREFIX" flag? if trigger @ name "%t" subst else trigger @ name " " strcat "%t" subst then say exit then board ".length" getpropstr if "## Game is set to be half length." say else "## Game is set to be full length." say then board ".manual" getpropstr if "## Game is set to manual hand pegging." say else "## Game is set to automatic hand pegging." say then game_ready? if "## Two people are joined: " p1 name strcat " and " strcat p2 name strcat "." strcat say then board ".player1" getpropstr board ".player2" getpropstr not and if "## One person has joined: " p1 name strcat "." strcat say exit then board ".player1" getpropstr not board ".player2" getpropstr not and if "## No players have joined." say exit then turn not game_ready? and if board ".cut1" getpropstr dup if "## " p1 name strcat " has cut the " strcat swap unparse_card strcat " for deal." strcat say else pop then board ".cut2" getpropstr dup if "## " p2 name strcat " has cut the " strcat swap unparse_card strcat " for deal." strcat say else pop then then turn game_ready? and if "## First deal and crib has been determined." say "## It is now " cp name strcat "'s deal and crib." strcat say then board ".dealt" getpropstr if "## A hand is in progress." say then board ".crib1" getpropstr board ".crib2" getpropstr and if "## A crib has been determined." say else "## A crib has not yet been determined." say then board ".manual" getpropstr board ".cribtotal" getpropstr and if op board ".h" 3 pick player intostr strcat getpropstr "## %n's hand is [%h]" swap "%h" subst swap name "%n" subst say cp board ".h" 3 pick player intostr strcat getpropstr "## %n's hand is [%h]" swap "%h" subst over name "%n" subst say board ".c" getpropstr "## %n's crib is [%h]" swap "%h" subst swap name "%n" subst say else me @ playing? if "## Your hand is [" me @ player ".hand" swap intostr strcat board swap getpropstr strcat "]" strcat say then board ".pegturn" getpropstr if "## " p1 name strcat " [" strcat board ".played1" getpropstr strip dup strlen " " swap strcut swap pop strcat strcat "] => " strcat board ".total" getpropstr atoi intostr dup strlen " " swap strcut swap pop swap strcat strcat " <= [" strcat board ".played2" getpropstr strip dup strlen " " swap strcut swap pop strcat strcat "] " strcat p2 name strcat say "## It is %t's turn to play a card." board ".player" pegturn intostr strcat getpropstr atoi dbref name "%t" subst say then then ; : do_hand ( -- ) me @ playing? not if "## You're not playing!" say exit then board ".dealt" getpropstr not if "## There is no hand in progress." say exit then me @ player ".hand" swap intostr strcat board swap getpropstr "## Your hand is [" swap strcat "]" strcat say ; : addc ( s -- s ) trigger @ dup "PREFIX" flag? swap name strlen 1 = and if trigger @ name "%c" subst else " " "%c" subst then ; : do_sort_suit ( -- ) suit_value swap suit_value > ; : do_sort_face_value ( -- ) cut_face_value swap cut_face_value > ; : do_sort_hand ( -- ) me @ player? not if pop "## You're not playing!" say exit then dup not if "## No argument to sort, face values assumed..." say pop "f" then board ".hand" me @ player intostr strcat getpropstr strip " " explode dup 2 + pick tolower "s" 1 strncmp not if 'do_sort_suit sort else 'do_sort_face_value sort then 1 - begin dup while swap " " strcat rot strcat swap 1 - loop pop swap pop strip board ".hand" me @ player intostr strcat rot 0 add_prop do_hand ; : do_rules ( -- ) "+-----------------------------------------------+" say "| MUF-Cribbage 3.01 |" say "+-----------------------------------------------+" say "| Concept, design and code by Sjade of HoloMUCK |" say "| Major scoring routines created by der Mouse |" say "+-----------+-----------------------------------+" say "| %creset hm | Reset (h=1/2 game, m=manual peg) |" addc say "| %cjoin | Join in the game |" addc say "| %cdeal | Deal a hand |" addc say "| %ccut | Cut for deal or for extra card |" addc say "| %cdisplay | Show the board |" addc say "| %ccrib x y | Submit two cards to the crib |" addc say "| %cplay x | Play a card |" addc say "| %cstatus | Show status of game in progress |" addc say "| %csort s|f | Sort by (s)uit or (f)ace value |" addc say "| %chand | Show your hand |" addc say "| %chelp | This help screen |" addc say "| %cpeg i | Peg i points in manual score mode |" addc say "| %cdispute | 'no', 'over' or 'muggins ' |" addc say "+-----------+-----------------------------------+" say ; : main ( s -- ) board location room? not if pop "## Board must be set down first." say exit then strip cmd "reset" stringcmp not if do_reset exit then cmd "status" stringcmp not if pop do_status exit then cmd "help" stringcmp not if pop do_rules exit then cmd "display" stringcmp not if pop do_display exit then board ".game_over" getpropstr if pop "## You must reset the game first." say exit then cmd "cut" stringcmp not if pop do_cut exit then cmd "hand" stringcmp not if pop do_hand exit then cmd "sort" stringcmp not if arg do_sort_hand exit then cmd "deal" stringcmp not if pop do_deal exit then cmd "crib" stringcmp not if arg do_crib exit then cmd "play" stringcmp not if arg do_play exit then cmd "join" stringcmp not if pop do_join exit then cmd "peg" stringcmp not if arg do_hand_pegging exit then cmd "dispute" stringcmp not if arg do_dispute exit then "## Command \"%t%p%c\" not understood, try \"%t%phelp\"." trigger @ "PREFIX" flag? if "" "%p" subst else " " "%p" subst then swap "%c" subst trigger @ name "%t" subst say ;