@prog yahtzee.muf 1 9999 d 1 i : obj trigger @ location ; : yp-prefix "% " ; : yp-bonus-point 63 ; : yp-bonus-amount 35 ; : yp-p "_yprop-p-" swap intostr strcat ; : -yp-# "_yprop-" swap intostr strcat "-" strcat ; : -yp-3kind "_yprop-3kind-" ; : -yp-4kind "_yprop-4kind-" ; : -yp-fh "_yprop-fh-" ; : -yp-ss "_yprop-ss-" ; : -yp-ls "_yprop-ls-" ; : -yp-chance "_yprop-chance-" ; : -yp-yahtzee "_yprop-yahtzee-" ; : -yp-top-sum "_yprop-top-sum-" ; : -yp-top-par "_yprop-top-par-" ; : -yp-top-bonus "_yprop-top-bonus-" ; : -yp-bottom-sum "_yprop-bottom-sum-" ; : -yp-total-sum "_yprop-total-sum-" ; : yp-# -yp-# swap intostr strcat ; : yp-3kind -yp-3kind swap intostr strcat ; : yp-4kind -yp-4kind swap intostr strcat ; : yp-fh -yp-fh swap intostr strcat ; : yp-ss -yp-ss swap intostr strcat ; : yp-ls -yp-ls swap intostr strcat ; : yp-chance -yp-chance swap intostr strcat ; : yp-yahtzee -yp-yahtzee swap intostr strcat ; : yp-top-sum -yp-top-sum swap intostr strcat ; : yp-top-par -yp-top-par swap intostr strcat ; : yp-top-bonus -yp-top-bonus swap intostr strcat ; : yp-bottom-sum -yp-bottom-sum swap intostr strcat ; : yp-total-sum -yp-total-sum swap intostr strcat ; : yp-open "_yprop-open" ; : yp-n "_yprop-n" ; : yp-turn "_yprop-turn" ; : yp-rolls "_yprop-rolls" ; : yp-plays "_yprop-plays" ; : yp-max-plays "_yprop-max-plays" ; : yp-dice "_yprop-dice" ; : yp-maxpnl "_yprop-maxpnl" ; : yp-mps "_yprop-mps" ; : yp-head-label "_yprop-head-label" ; : max over over < if swap then pop ; : set-or-remove dup if 0 addprop else pop remove_prop then ; : p@ obj swap getpropstr ; : p! obj swap rot set-or-remove ; : pi@ obj swap getpropstr atoi ; : pi! obj swap rot intostr set-or-remove ; : p++ dup pi@ 1 + swap pi! ; : say me @ swap notify ; : sayhere loc @ swap #-1 swap notify_except ; : pfxsay yp-prefix swap strcat say ; : pfxsayhere yp-prefix swap strcat sayhere ; : p-name yp-p pi@ dbref name ; : pturn-name yp-turn pi@ p-name ; : read-yn read 1 strcut pop "y" "Y" subst "y" strcmp not ; : constant-string? dup strlen dup 2 < if pop pop 1 exit then over swap 1 - strcut pop swap 1 strcut swap pop strcmp not ; : stripwhite " " explode dup 1 > if 1 - 1 swap 1 for pop swap strcat loop else pop then ; : am-I-playing? 1 yp-n pi@ 1 for yp-p pi@ dbref me @ dbcmp if 1 exit then loop 0 ; : my-turn? yp-turn pi@ yp-p pi@ dbref me @ dbcmp ; : still-joining? yp-open p@ ; : game-over? yp-open p@ not yp-turn pi@ 0 = and ; : roll-die yp-dice p@ swap 1 - strcut 1 strcut swap pop random 6 % 1 + intostr swap strcat strcat yp-dice p! ; : set-new-turn yp-turn pi! 0 yp-rolls pi! ; : announce-turn loc @ yp-turn pi@ yp-p pi@ dbref "It is " over name strcat "'s turn." strcat pfxsayhere ; : lpad3 begin dup strlen 3 < while " " swap strcat loop ; : bracket (s -- s) "[" swap "]" strcat strcat ; : ssctr (s -- s) dup strlen yp-maxpnl pi@ swap - dup 0 <= if pop exit then dup 2 / swap over - yp-mps p@ dup rot strcut pop swap rot strcut pop rot swap strcat strcat ; : score-sheet-head-str yp-head-label p@ "" 1 yp-n pi@ 1 for p-name ssctr strcat strcat " " loop pop ; : score-sheet-top-sums-str -yp-top-sum "label" strcat p@ "" 1 yp-n pi@ 1 for yp-top-sum pi@ intostr lpad3 bracket ssctr strcat strcat " " loop pop ; : score-sheet-top-bonus-str -yp-top-bonus "label" strcat p@ "" 1 yp-n pi@ 1 for ( sofar between n ) dup yp-top-bonus p@ dup if swap pop atoi intostr lpad3 bracket else pop dup yp-top-sum pi@ swap yp-top-par pi@ - dup 0 < if intostr else intostr "+" swap strcat then "....." swap strcat dup strlen 5 - strcut swap pop then ssctr strcat strcat " " loop pop ; : score-sheet-bottom-sums-str -yp-bottom-sum "label" strcat p@ "" 1 yp-n pi@ 1 for yp-bottom-sum pi@ intostr lpad3 bracket ssctr strcat strcat " " loop pop ; : score-sheet-total-sums-str -yp-total-sum "label" strcat p@ "" 1 yp-n pi@ 1 for yp-total-sum pi@ intostr lpad3 bracket ssctr strcat strcat " " loop pop ; : score-sheet-line-str (s -- s) dup "label" strcat p@ "" 1 yp-n pi@ 1 for ( s sofar between n ) 4 pick swap intostr strcat p@ dup if atoi intostr lpad3 else pop "---" then ssctr strcat strcat " " loop pop swap pop ; : end-game "Game is over." pfxsayhere "Score totals:" pfxsayhere score-sheet-head-str pfxsayhere score-sheet-total-sums-str pfxsayhere 0 set-new-turn ; : advance-turn yp-plays p++ yp-plays pi@ yp-max-plays pi@ >= if end-game exit then yp-turn pi@ yp-n pi@ % 1 + set-new-turn announce-turn ; : dice-string (first last -- string) yp-dice p@ swap strcut pop swap 1 - strcut swap pop dup strlen dup 1 > if 1 - 1 -1 for strcut " " swap strcat strcat loop else pop then "<" swap ">" strcat strcat ; : dice-scan (dice arg -- new-dice first-to-roll 0 / 1) "" swap begin ( left to-roll arg ) dup while 1 strcut swap ( left to-roll arg-next arg-char ) 4 pick over instr dup if ( left to-roll arg-next arg-char inx ) swap pop 4 rotate swap 1 - strcut 1 strcut ( to-roll arg-next pre-left die post-left ) rot swap strcat ( to-roll arg-next die new-left ) 4 rotate rot strcat rot ( new-left new-to-roll arg-next ) else ( left to-roll arg-next arg-char 0 ) pop dup " " strcmp not if pop else "123456" over instr if dup rot strcat "Not that many " rot strcat "s available to reroll (at " strcat swap strcat ")" strcat else dup rot strcat "Unrecognized die character " rot strcat " (at " strcat swap strcat ")" strcat then pfxsay pop pop 1 exit then then loop ( left to-roll "" ) pop over swap strcat swap strlen 1 + 0 ; : score-sheet-head score-sheet-head-str pfxsay ; : score-sheet-line score-sheet-line-str pfxsay ; : score-sheet-top-sums score-sheet-top-sums-str pfxsay ; : score-sheet-top-bonus score-sheet-top-bonus-str pfxsay ; : score-sheet-bottom-sums score-sheet-bottom-sums-str pfxsay ; : score-sheet-total-sums score-sheet-total-sums-str pfxsay ; : reset-sums 1 yp-n pi@ 1 for ( pno ) 0 0 0 0 ( pno par min cur max ) 1 6 1 for ( pno par min cur max inx ) 6 pick over yp-# p@ dup if ( pno par min cur max inx sval ) atoi swap 3 * 6 rotate + swap 5 rotate over + swap 5 rotate over + swap 5 rotate + else ( pno par min cur max inx "" ) pop 5 * + then loop ( pno par min cur max ) swap 5 pick yp-top-sum pi! ( pno par min max ) yp-bonus-point < if pop "0" else yp-bonus-point >= if yp-bonus-amount intostr else "" then then 3 pick yp-top-bonus p! over yp-top-par pi! 0 ( pno sum ) over yp-3kind pi@ + over yp-4kind pi@ + over yp-fh pi@ + over yp-ss pi@ + over yp-ls pi@ + over yp-chance pi@ + over yp-yahtzee pi@ + over yp-bottom-sum pi! dup yp-top-sum pi@ over yp-top-bonus pi@ + over yp-bottom-sum pi@ + swap yp-total-sum pi! loop ; : sort-dice yp-dice p@ 1 5 1 for pop 1 strcut swap atoi swap loop 1 6 1 for ( d1 d2 d3 d4 d5 newstr die# ) 0 4 8 1 for pick 3 pick = + loop ( d1 .. d5 newstr die# count ) dup if swap intostr rot 1 4 rotate 1 for pop over strcat loop swap else pop then pop loop yp-dice p! pop pop pop pop pop ; : sum-dice 0 yp-dice p@ begin dup while 1 strcut swap atoi rot + swap loop pop ; : scorecmp (arg str -- arg 0 / 1) over strlen over strlen over < if pop pop 0 exit then strcut pop over strcmp if 0 else pop 1 then ; : scoreit (score slot) dup yp-turn pi@ intostr strcat ( score slot exact-slot ) dup p@ "" strcmp if "That score slot has already been filled!" pfxsay pop pop exit then 3 pick 1 < if "Score would be 0, are you sure?" pfxsay read-yn not if pop pop exit then then 3 pick swap pi! reset-sums ( score slot ) me @ name " scores " strcat rot intostr strcat " in " strcat swap "name" strcat p@ strcat "." strcat pfxsayhere advance-turn ; : score-as-# 0 yp-dice p@ begin dup while ( # count dice ) 1 strcut swap atoi ( # count dice die ) 4 pick = if swap 1 + swap then loop pop over * ( # score ) swap -yp-# scoreit ; : score-as-3kind sort-dice yp-dice p@ dup 3 strcut pop constant-string? over 1 strcut 3 strcut pop swap pop constant-string? or swap 2 strcut swap pop constant-string? or if sum-dice else 0 then -yp-3kind scoreit ; : score-as-4kind sort-dice yp-dice p@ dup 4 strcut pop constant-string? swap 1 strcut swap pop constant-string? or if sum-dice else 0 then -yp-4kind scoreit ; : score-as-fh sort-dice yp-dice p@ dup 2 strcut constant-string? swap constant-string? and swap 3 strcut constant-string? swap constant-string? and or if 25 else 0 then -yp-fh scoreit ; : score-as-ss sort-dice yp-dice p@ dup "1234" instr over "2345" instr or over "3456" instr or over "12234" strcmp not or over "12334" strcmp not or over "23345" strcmp not or over "23445" strcmp not or over "34456" strcmp not or swap "34556" strcmp not or if 30 else 0 then -yp-ss scoreit ; : score-as-ls sort-dice yp-dice p@ dup "12345" instr swap "23456" instr or if 40 else 0 then -yp-ls scoreit ; : score-as-chance sum-dice -yp-chance scoreit ; : score-as-yahtzee yp-dice p@ constant-string? if 50 else 0 then -yp-yahtzee scoreit ; : score-ambiguous "Ambiguous slot name - please use another name or type more of the name." pfxsay ; : doreset swap "" strcmp if "Usage: " swap strcat pfxsay exit then pop yp-open p@ not yp-turn pi@ and if "A game is in progress; are you sure?" pfxsay read-yn not if exit then then 1 begin dup yp-p p@ while "" over yp-p p! 1 6 1 for over swap yp-# "" swap p! loop "" over yp-3kind p! "" over yp-4kind p! "" over yp-fh p! "" over yp-ss p! "" over yp-ls p! "" over yp-chance p! "" over yp-yahtzee p! "" over yp-top-sum p! "" over yp-top-par p! "" over yp-top-bonus p! "" over yp-bottom-sum p! "" over yp-total-sum p! 1 + loop pop "" yp-dice p! "" yp-maxpnl p! "" yp-mps p! "" yp-max-plays p! 0 yp-plays pi! 0 yp-n pi! "yes" yp-open p! "Game reset by " me @ name strcat "." strcat pfxsayhere ; : dojoin swap "" strcmp if "Usage: " swap strcat pfxsay exit then pop yp-n pi@ 0 > if 1 yp-n pi@ 1 for yp-p pi@ dbref me @ dbcmp if "You are already playing!" pfxsay exit then loop then yp-open p@ not if "The game has already begun!" pfxsay exit then yp-n p++ yp-n pi@ dup yp-p me @ int swap pi! me @ name " has joined the game." strcat pfxsayhere ; : dobegin swap "" strcmp if "Usage: " swap strcat pfxsay exit then pop 1 yp-n pi@ 0 > if 1 yp-n pi@ 1 for yp-p pi@ dbref me @ dbcmp if pop 0 then loop then if "You are not playing!" pfxsay exit then yp-open p@ not if "The game has already begun!" pfxsay exit then yp-n pi@ 1 < if "How did this happen? No players but we're here?!" pfxsay "Please don't touch this Yahtzee set, and report this to mouse." pfxsay exit then "Game begun by " me @ name strcat "." strcat pfxsayhere "" yp-open p! yp-n pi@ 13 * yp-max-plays pi! random yp-n pi@ % 1 + set-new-turn announce-turn 5 1 yp-n pi@ 1 for p-name strlen max loop yp-maxpnl pi! "" 1 yp-maxpnl pi@ 1 for pop " " strcat loop yp-mps p! reset-sums ; : dostatus swap "" strcmp if "Usage: " swap strcat pfxsay exit then pop yp-open p@ if "Game is open to more players." pfxsay yp-n pi@ dup if "Players joined so far:" " " 1 4 rotate 1 for p-name strcat strcat ", " loop pop "." strcat else pop "No players have joined yet." then pfxsay exit then yp-turn pi@ if "Game has begun." else "Game has ended." then pfxsay "Players:" " " 1 yp-n pi@ 1 for p-name strcat strcat ", " loop pop "." strcat pfxsay yp-turn pi@ if "It is " pturn-name strcat "'s turn." strcat pfxsay yp-rolls pi@ dup if pturn-name " has rolled " strcat over intostr "?" swap "times?" strcat strcat 3 pick 1 = if pop "once" then 3 pick 2 = if pop "twice" then 3 pick 3 = if pop "thrice" then "; dice show " 1 5 dice-string "." strcat strcat strcat else pop pturn-name " has not yet rolled." then strcat pfxsay else "Final scores:" pfxsay score-sheet-head-str pfxsay score-sheet-total-sums-str pfxsay then ; : dosheet swap "" strcmp if "Usage: " swap strcat pfxsay exit then pop yp-open p@ if "The game hasn't started yet!" pfxsay exit then score-sheet-head 1 6 1 for -yp-# score-sheet-line loop score-sheet-top-sums score-sheet-top-bonus -yp-3kind score-sheet-line -yp-4kind score-sheet-line -yp-fh score-sheet-line -yp-ss score-sheet-line -yp-ls score-sheet-line -yp-chance score-sheet-line -yp-yahtzee score-sheet-line score-sheet-bottom-sums score-sheet-total-sums ; : doroll pop am-I-playing? not if "You're not playing!" pfxsay exit then still-joining? if "The game hasn't begun yet!" pfxsay exit then my-turn? not if "It's not your turn!" pfxsay exit then yp-rolls pi@ 3 >= if "You're allowed only three rolls per turn." pfxsay "At this point you must choose a place to score this roll." pfxsay exit then yp-rolls pi@ 0 > if yp-dice p@ swap dice-scan if exit then dup 5 > if pop pop "You must specify at least one number to reroll!" pfxsay exit then swap yp-dice p! pturn-name " rolls " strcat over 5 dice-string strcat " and gets " strcat swap dup 5 1 for roll-die loop 5 dice-string strcat "; dice now show " strcat 1 5 dice-string strcat "." strcat pfxsayhere else "" strcmp if "On the first roll of a turn, you can't specify dice to roll!" pfxsay exit then 1 5 1 for roll-die loop pturn-name " rolls the dice and gets " strcat 1 5 dice-string strcat pfxsayhere then yp-rolls p++ ; : doscore over not if "Usage: " swap " " strcat strcat pfxsay exit then pop am-I-playing? not if "You're not playing!" pfxsay exit then still-joining? if "The game hasn't begun yet!" pfxsay exit then my-turn? not if "It's not your turn!" pfxsay exit then yp-rolls pi@ 1 < if "You need to roll first!" pfxsay exit then tolower stripwhite "3" scorecmp if score-ambiguous exit then "4" scorecmp if score-ambiguous exit then "four" scorecmp if score-ambiguous exit then "s" scorecmp if score-ambiguous exit then "three" scorecmp if score-ambiguous exit then "1s" scorecmp if 1 score-as-# exit then "2s" scorecmp if 2 score-as-# exit then "3s" scorecmp if 3 score-as-# exit then "4s" scorecmp if 4 score-as-# exit then "5s" scorecmp if 5 score-as-# exit then "6s" scorecmp if 6 score-as-# exit then "ones" scorecmp if 1 score-as-# exit then "twos" scorecmp if 2 score-as-# exit then "threes" scorecmp if 3 score-as-# exit then "fours" scorecmp if 4 score-as-# exit then "fives" scorecmp if 5 score-as-# exit then "sixes" scorecmp if 6 score-as-# exit then "3kind" scorecmp if score-as-3kind exit then "3ofakind" scorecmp if score-as-3kind exit then "threeofakind" scorecmp if score-as-3kind exit then "4kind" scorecmp if score-as-4kind exit then "4ofakind" scorecmp if score-as-4kind exit then "fourofakind" scorecmp if score-as-4kind exit then "fh" scorecmp if score-as-fh exit then "fullhouse" scorecmp if score-as-fh exit then "ss" scorecmp if score-as-ss exit then "smallstraight" scorecmp if score-as-ss exit then "ls" scorecmp if score-as-ls exit then "largestraight" scorecmp if score-as-ls exit then "chance" scorecmp if score-as-chance exit then "yahtzee" scorecmp if score-as-yahtzee exit then "`" swap "' is not a recognized space on the score sheet!" strcat strcat pfxsay ; : dorules pop dup "" strcmp not if pop "+-----------------------------------+" pfxsay "| Mouse MUF-Yahtzee |" pfxsay "+--------+--------------------------+" pfxsay "| reset | Reset the game |" pfxsay "| join | Join in a game |" pfxsay "| begin | Begin a game |" pfxsay "| status | Show the game status |" pfxsay "| sheet | Show the score sheet |" pfxsay "| roll | Roll the dice |" pfxsay "| score | Mark a roll on the sheet |" pfxsay "| rules | Print rules |" pfxsay "+--------+--------------------------+" pfxsay "| rules gives help for . |" pfxsay "| rules example gives an example. |" pfxsay "+-----------------------------------+" pfxsay exit then dup "reset" strcmp not if pop "reset - reset the game." pfxsay "This resets the game completely. Everything starts over; players" pfxsay "must join and the game must be begun again." pfxsay exit then dup "join" strcmp not if pop "join - join the game." pfxsay "Adds you to the list of people playing the game." pfxsay exit then dup "begin" strcmp not if pop "begin - begin a game." pfxsay "Begins a game. When one of the players issues this command, no" pfxsay "further join commands are permitted, a player is chosen randomly" pfxsay "to play first, and play starts." pfxsay exit then dup "status" strcmp not if pop "status - show game status." pfxsay "Shows the game status. Describes everything about the game's status" pfxsay "except the contents of the score sheet (see `sheet' for that)." pfxsay exit then dup "sheet" strcmp not if pop "sheet - show score sheet." pfxsay "Shows the score sheet for the game. Entries that are not yet filled" pfxsay "in are shown as ---." pfxsay exit then dup "roll" strcmp not if pop "roll - roll the dice." pfxsay "Rolls the dice. The first roll of a turn is just `roll'; to reroll" pfxsay "dice, give the numbers showing on the dice. For example, if you" pfxsay "rolled <4 2 2 6 1> and want to roll the 6 and one of the 2s, you" pfxsay "would `roll 2 6' or `roll 6 2'." pfxsay "Only two rerolls (a total of three rolls) are permitted per turn." pfxsay exit then dup "score" strcmp not if pop "score - write a score on the sheet." pfxsay "When you have rolled the dice and either are happy with the roll" pfxsay "or have used both your rerolls, use this command to enter a score" pfxsay "for the roll on the score sheet. The argument is the name of the" pfxsay "item on the score sheet you wish to enter the score in. Any roll" pfxsay "may be scored in any slot; if the roll is inappropriate for the" pfxsay "slot, the score will be 0. Any score that would be 0 requires" pfxsay "confirmation from the player." pfxsay "`rules slots' gives a list of score slot names." pfxsay "`rules scoring' describes how scores are calculated." pfxsay exit then dup "rules" strcmp not if pop "rules - show rules and command info." pfxsay "By itself, gives a list of commands; with a command name, gives help" pfxsay "on that command." pfxsay exit then dup "example" strcmp not if pop "example - example of use of commands." pfxsay "This is a short example showing the use of the commands." pfxsay "It describes the beginning of a game among three players, Herman," pfxsay "Airon, and Twibbit." pfxsay "" pfxsay "Player Command Everyone sees" pfxsay "Herman reset % Game reset by Herman." pfxsay "Herman join % Herman has joined the game." pfxsay "Twibbit join % Twibbit has joined the game." pfxsay "Airon join % Airon has joined the game." pfxsay "Twibbit begin % Game begun by Twibbit." pfxsay " % It is Airon's turn." pfxsay "Airon roll % Airon rolls the dice and gets <2 2 4 3 4>" pfxsay "Airon roll 2 2 3" pfxsay " % Airon rolls <2 2 3> and gets <1 6 4>; dice now show <4 4 1 6 4>" pfxsay "Airon roll 1 6" pfxsay " % Airon rolls <1 6> and gets <4 5>; dice now show <4 4 4 4 5>" pfxsay "Airon score 4 of a kind" pfxsay " % Airon scores 21 in four of a kind." pfxsay " % It is Herman's turn." pfxsay exit then dup "slots" strcmp not if pop "slots - names of score slots." pfxsay "All whitespace in the slot name is ignored, and uppercase letters are" pfxsay "converted to lowercase. Any unambiguous abbreviation is accepted." pfxsay "The names accepted are as follows. Names inside []s are equivalent." pfxsay "[1s, ones] [3kind, 3 of a kind, three of a kind]" pfxsay "[2s, twos] [4kind, 4 of a kind, four of a kind]" pfxsay "[3s, threes] [fh, full house]" pfxsay "[4s, fours] [ss, small straight]" pfxsay "[5s, fives] [ls, large straight]" pfxsay "[6s, sixes] [chance] [yahtzee]" pfxsay exit then dup "scoring" strcmp not if pop "scoring - rules for scoring." pfxsay "For 1s, 2s, 3s, 4s, 5s, 6s, the score is simply the sum of all the" pfxsay "dice of the appropriate kind (eg, for 3s, the score is the total of" pfxsay "all the 3s in the roll). Other dice are ignored. A total of 63 or" pfxsay "higher (three of each adds up to 63) is required for the bonus." pfxsay "When earned, the bonus scores 35. The game enters 0 or 35 in this" pfxsay "field automatically as soon as it becomes impossible or certain that" pfxsay "the sum will exceed 63." pfxsay "" pfxsay "For three and four of a kind, and chance, the score is the sum of all" pfxsay "five dice. Three and four of a kind, however, score 0 unless three or" pfxsay "four of the dice are identical. Chance has no restrictions." pfxsay "" pfxsay "Full house scores 25 for any roll having three dice the same and the" pfxsay "other two also the same (though possibly different), like <2 4 2 2 4>." pfxsay "Small straight scores 30 and can be earned for any roll having four" pfxsay "dice in a numerical sequence, ie, 1 2 3 4, 2 3 4 5, or 3 4 5 6. Large" pfxsay "straight is similar, but scores 40, and all five dice must be in sequence." pfxsay "" pfxsay "Yahtzee scores 50 for any roll with all five dice the same." pfxsay exit then ; : 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 "begin" strcmp not if dobegin exit then dup "status" strcmp not if dostatus exit then dup "sheet" strcmp not if dosheet exit then dup "roll" strcmp not if doroll exit then dup "score" strcmp not if doscore exit then dup "rules" strcmp not if dorules exit then "Unrecognized command `" swap strcat "'." strcat pfxsay ; . c q