@prog scrabble.muf 1 999 d 1 i ( letter/count/value a/9/1 b/2/3 c/2/3 d/4/2 e/12/1 f/2/4 g/3/2 h/2/4 i/9/1 j/1/8 k/1/5 l/4/1 m/2/3 n/6/1 o/8/1 p/2/3 q/1/10 r/6/1 s/4/1 t/6/1 u/4/1 v/2/4 w/2/4 x/1/8 y/2/4 z/1/10 blank/2/0 board: 0 1 2 3 4 5 6 7 8 91011121314 0 D . . B . . . D . . . B . . D 1 . A . . . C . . . C . . . A . 2 . . A . . . B . B . . . A . . 3 B . . A . . . B . . . A . . B 4 . . . . A . . . . . A . . . . 5 . C . . . C . . . C . . . C . 6 . . B . . . B . B . . . B . . A = double word 7 D . . B . . . A . . . B . . D B = double letter 8 . . B . . . B . B . . . B . . C = triple letter 9 . C . . . C . . . C . . . C . D = triple word 10 . . . . A . . . . . A . . . . 11 B . . A . . . B . . . A . . B 12 . . A . . . B . B . . . A . . 13 . A . . . C . . . C . . . A . 14 D . . B . . . D . . . B . . D ) ( more than 9 specials will break badly. ) : pfx "% " ; : say trigger @ location location #-1 rot notify_except ; : sayme me @ swap notify ; : sayto notify ; : pfxsay pfx swap strcat say ; : pfxsayme pfx swap strcat sayme ; : pfxsayto pfx swap strcat sayto ; : propobj trigger @ location ; : prop-prefix "_sc-" ; : p@ prop-prefix swap strcat propobj swap getpropstr ; : pi@ p@ atoi ; : p! prop-prefix swap strcat propobj swap rot dup if 0 addprop else pop remove_prop then ; : pi! swap intostr swap p! ; : min 2 copy > if swap then pop ; : initial-letter-bag "initial-letter-bag" ; : letter-values "letter-values" ; : board-size "board-size" ; : specials "specials" ; : xcoords "xcoords" ; : ycoords "ycoords" ; : board ".board" ; : spboard ".spboard" ; : state ".state" ; : #-players ".#-players" ; : letter-bag ".letter-bag" ; : turn ".turn" ; : sp intostr ".sp-" swap strcat ; : player intostr ".player-" swap strcat ; : hand intostr ".hand-" swap strcat ; : rep-clone (s n -- s) over 1 begin 3 pick over > while 2 * swap dup strcat swap loop pop over 4 pick strlen * strcut pop swap pop swap pop ; : addspaces dup strlen 1 > if "" explode 2 -1 for pop " " strcat swap strcat loop then ; : misconfigured (s -- flowsink) "This set is misconfigured: " swap strcat say 0 sleep daemon kill ; : my-player-# #-players pi@ dup not if exit then 1 swap 1 for dup player pi@ dbref me @ dbcmp if exit then pop loop 0 ; : am-I-playing? my-player-# ; : my-turn? turn pi@ player pi@ dbref me @ dbcmp ; : letter-score (letter -- score) letter-values p@ dup rot instr dup if strcut atoi swap pop else pop pop 0 then ; : get-cell (x y var -- letter) board-size pi@ rot * rot + swap p@ swap strcut 1 strcut pop swap pop ; : set-cell (x y letter var -- ) 4 2 roll board-size pi@ * + over p@ swap strcut 1 strcut swap pop 4 rotate swap strcat strcat swap p! ; : init-board board-size pi@ dup * "." swap rep-clone board p! ; : init-specials board-size pi@ dup * "0" swap rep-clone spboard p! specials p@ 1 strcut swap explode 1 -1 for ( str num ) swap 4 strcut swap 3 pick sp p! ( num coords ) " " explode dup 2 + rotate intostr swap 1 -1 for pop ( cpair numstr ) over "," explode dup 2 = if ( cpair numstr y x 2 ) pop atoi swap atoi 3 pick spboard set-cell else 1 -1 for pop pop loop "incorrect coords in specials: " rot strcat misconfigured then swap pop loop pop loop ; : shuffle "" swap dup strlen 1 -1 for random swap % strcut 1 strcut rot strcat -rot strcat swap loop pop ; : draw-letters (n -- s) letter-bag p@ swap strcut letter-bag p! ; : tell-hand (n -- ) dup hand p@ addspaces over player pi@ dbref "Your hand is <" rot strcat ">." strcat pfxsayto ; : turn-name turn pi@ player pi@ dbref name ; : announce-turn "It is " turn-name "'s turn." strcat strcat pfxsay ; : advance-turn turn pi@ 1 + dup #-players pi@ > if pop 1 then turn pi! ; : refill-hand turn pi@ hand dup p@ dup strlen 7 swap - letter-bag p@ strlen min draw-letters strcat swap p! ; : show-board xcoords p@ addspaces " " swap strcat "--" board-size pi@ rep-clone " +" swap strcat "---+" strcat over pfxsayme dup pfxsayme board-size pi@ 1 - 0 -1 for " " board-size pi@ 1 - 0 -1 for ( y line-part x ) 3 pick over over board get-cell rot rot spboard get-cell atoi ( y line-part b s ) dup if sp p@ 2 strcut pop 1 strcut rot swap strcat strcat swap 1 strcut swap pop strcat else pop " " swap strcat swap strcat then loop over ycoords p@ swap strcut 1 strcut pop swap pop swap over " | " swap strcat strcat " | " swap strcat strcat swap sp p@ dup if 1 strcut 1 strcut "word" "w" subst "letter" "l" subst "double " "2" subst "triple " "3" subst " " swap strcat strcat " " swap strcat strcat " " swap strcat strcat else pop then pfxsayme loop pfxsayme pfxsayme ; : doclear me @ wizard? me @ propobj owner dbcmp or if 0 prop-prefix "." strcat propobj propfirst begin while dup 4 pick dup strlen strncmp not if dup 5 rotate 1 + 5 2 roll then propnext loop pop propobj swap begin dup 0 > while 1 - rot 3 pick swap remove_prop loop pop pop "Done." sayme else "Permission denied." sayme then ; : doreset pop init-board init-specials "join" state p! 0 #-players pi! "Game reset by " me @ name "." strcat strcat pfxsay ; : dojoin pop state p@ "join" strcmp if "The game has already begun!" pfxsayme exit then am-I-playing? if "You have already joined!" pfxsayme exit then #-players pi@ if initial-letter-bag p@ strlen #-players pi@ 7 * / 3 < if "Maximum number of players reached." pfxsayme exit then then me @ int #-players pi@ 1 + dup #-players pi! player pi! me @ name " has joined the game." strcat pfxsay ; : doboard pop show-board ; : dostatus pop state p@ dup "join" strcmp not if pop "Game is still open to more players." pfxsayme #-players pi@ dup if "Players so far:" 1 rot 1 for player pi@ dbref name " " swap strcat strcat loop "." strcat else pop "No players have joined yet." then pfxsayme exit then dup "play" strcmp not if pop "Game has begun; it is " turn-name "'s turn." strcat strcat pfxsayme exit then "Unrecognized game state `" swap strcat "'!" strcat pfxsayme ; : dobegin pop state p@ "join" strcmp if "The game has already begun!" pfxsayme exit then am-I-playing? not if "You haven't joined!" pfxsayme exit then "Game begun by " me @ name "." strcat strcat pfxsay random #-players pi@ % 1 + turn pi! announce-turn "play" state p! initial-letter-bag p@ shuffle letter-bag p! 1 #-players pi@ 1 for 7 draw-letters over hand p! dup tell-hand pop loop ; : dohand am-I-playing? not if pop "You're not playing!" pfxsayme exit then my-player-# swap "values" stringcmp if tell-hand else dup player pi@ dbref swap hand p@ "" swap begin dup while 1 strcut swap dup letter-score intostr "(" swap ")" strcat strcat strcat rot " " strcat swap strcat swap loop pop "Your hand is <" swap strcat " >." strcat pfxsayto then ; : dovalues pop "values" dohand exit ; : doplay am-I-playing? not if pop "You're not playing!" pfxsayme exit then my-turn? not if pop "It's not your turn!" pfxsayme exit then "" " " subst "" " " subst dup "=" instr dup not if pop pop "Usage: play =" pfxsayme exit then 1 - strcut 1 strcut swap pop swap dup strlen 3 = not if "Coords take the form of an uppercase letter and a lowercase letter," pfxsayme " as shown on the edges of the board display, with a third letter" pfxsayme " a or d, for across or down, appended." pfxsayme pop pop exit then 2 strcut swap 1 strcut ycoords p@ over instr if swap then xcoords p@ swap instr 1 - swap ycoords p@ swap instr 1 - over 0 < over 0 < or if "Invalid coordinate character, must be as shown on board display." pfxsayme 4 mpop exit then rot dup "a" stringcmp if "d" stringcmp if "Invalid direction character, must be a (across) or d (down)." pfxsayme 3 mpop exit else 1 then else pop 0 then ( word x y down? ) 4 pick strlen over if 3 pick > else 4 pick + board-size pi@ >= then if "That word in that position would extend off the board." pfxsayme 4 mpop exit then "" 4 pick 4 pick 7 pick begin 1 strcut swap dup while ( word x y down? need x y wordrest char ) 4 pick 4 pick board get-cell dup "." strcmp if over stringcmp if pop pop "That play conflicts with the existing tile at " ycoords p@ rot strcut swap pop 1 strcut pop strcat xcoords p@ rot strcut swap pop 1 strcut pop strcat "!" strcat pfxsayme 5 mpop exit then pop else pop 5 rotate strcat -4 rotate then 5 pick if swap 1 - swap else rot 1 + rot rot then ( word x y down? need x y wordrest ) loop 4 mpop ( word x y down? need ) dup "*" instr if "Please indicate use of a blank by typing the corresponding letter uppercase." pfxsayme 5 mpop exit then turn pi@ hand p@ swap "" swap ( word x y down? hand "" need ) begin 1 strcut swap dup while ( word x y down? handleft donthave need ch ) dup dup tolower strcmp if pop "*" then 4 rotate over over swap instr dup if 1 - strcut 1 strcut swap pop strcat -4 rotate pop else pop -4 rotate rot strcat swap then loop pop pop dup if "That play requires <" over addspaces strcat ">, which you don't have." strcat pfxsayme over "*" instr if "To use a blank, type the corresponding letter uppercase." pfxsayme ( else dup dup tolower strcmp if "Uppercase letters indicate use of blanks." pfxsayme "Please use lowercase for all other letters." pfxsayme then ) then 6 mpop exit then pop turn pi@ hand p! ( word x y down? ) 3 pick 3 pick 6 pick begin 1 strcut swap dup while ( word x y down? x y wordleft ch ) 4 pick 4 pick board get-cell "." strcmp not if 4 pick 4 pick rot board set-cell else pop then 4 pick if swap 1 - swap else rot 1 + rot rot then loop 4 mpop ( word x y down? ) me @ name " plays \"" strcat 5 pick strcat "\" at " strcat ycoords p@ 4 pick strcut swap pop 1 strcut pop strcat xcoords p@ 5 pick strcut swap pop 1 strcut pop strcat over if ", down." else ", across." then strcat pfxsay refill-hand turn pi@ tell-hand advance-turn announce-turn ; : dohelp "reset, join, board, status, begin, hand, values, play" sayme "More help not yet implemented." sayme ; : main trigger @ "_action" getpropstr dup not if pop trigger @ name then dup "nextword" strcmp not if pop begin dup " " 1 strncmp not while 1 -1 substr loop dup " " instr dup if strcut swap 0 -1 substr else pop "" swap then dup not if pop "Use `" command @ " help' for help." 3 "" rimplode say exit then then dup "clear" strcmp not if pop doclear exit then dup "help" strcmp not if pop dohelp exit then dup "reset" strcmp not if pop doreset exit then dup "join" strcmp not if pop dojoin exit then dup "board" strcmp not if pop doboard exit then dup "status" strcmp not if pop dostatus exit then dup "begin" strcmp not if pop dobegin exit then dup "hand" strcmp not if pop dohand exit then dup "values" strcmp not if pop dovalues exit then dup "play" strcmp not if pop doplay exit then "Unrecognized command `" swap strcat "'!" strcat pfxsay ; . c q