@prog boggle.muf 1 9999 d 1 i ( All props are kept on trigger @ location. Some properties are set as part of the game setup and never changed, at least not by the game code: _cubes-: For a board of size n, the cubes are labeled with letters taken from the property value. The value must contain n*n cubes, where a cube consists of either - A string not beginning with /, in which case it contains the letters on the sides of the cube, or - A string beginning with /, which is broken at /s to give the markings on the sides of the cube. [This form exists for the sake of "Qu" markings.] In either case, each cube is separated from the next by whitespace. There is no requirement that a cube have six sides, though to be an accurate model of the physical game, of course, they must. _casemap: Gives upper/lower case mappings. is a list of letters, lowercase then uppercase for each letter; it must contain every letter present in the cube markings. This is used when matching input against cube markings. Here, the list of letters must be single letters; there is no way to treat a multigraph like "Qu" as a unit here. For the English game, suitable values are: _cubes-4: AACIOT ABILTY /A/B/J/M/O/Qu ACDEMP ACELRS ADENVZ AHMORS BFIORX DKNOTU DENOSW EEFHIY EGINTV EGKLUY EHINPS ELPSTU GILRUW _cubes-5: AAAFRS AAEEEE AAFIRS ADENNN AEEEEM AEEGMU AEGMNN AFIRSY /B/J/K/Qu/X/Z CCNSTW CEIILT CEILPT CEIPST DDLNOR DHHLOR DHHNOT DHLNOR EIIITT EMOTTT ENSSSU FIPRSY GORRVW HIPRRY NOOTUW OOOTTU _casemap: aAbBcCdDeEfFgGhHiIjJkKlLmMnNoOpPqQrRsStTuUvVwWxXyYzZ The size-4 cubes were taken from NetBSD's /usr/src/games/boggle/boggle/bog.c /* $NetBSD: bog.c,v 1.15 1999/09/19 09:42:38 jsm Exp $ */ The size-5 cubes were taken from a copy of the physical game, and, since it is a Canadian version, I suspect they are designed to be a compromise between English and French letter frequencies. I don't know what the origin of the NetBSD version's cubes is; internal evidence implies it was written by a Canadian and thus it too may be a French/English compromise. Other properties are modified dynamically by the game: _lock: This property is used to prevent multiple people from colliding over access to the property list and damaging internal data structures as a result. The exact details of its value, when it is present, are specifically not documented. The locking algorithm assumes that any lock older than five minutes is stale. [If there were a way to mark properties so that they are not saved, or are deleted on load, this would be unnecessary.] _state: join _state: play _state: over Holds the state of the game. join means additional players can join. play means play has started and words are being collected. over means play has ended and unique word lists have been computed and printed [or soon will be]. _size: The board is n letters square. _minlen: Words must be at least letters long. _time: The playing time is seconds. _starttime: [Valid only if _state: is play.] The systime at which the game started. _np: n players have joined. _p-: Player n is dbref #m. Player numbers are 1-origin. _p#-: Player with dbref #m is player n. _w-#-: Player n has found m words. _w--: Player n's m'th word is . Word numbers are 1-origin. _w-t--: Player n has found word as its m'th word. _w-p-: [/[...]] List of player numbers of players who have found . _board-p--: The board cube at coordinates shows . x and y must be from 0 through n-1, where n is the _size: value. This property stores the form of the cube label suitable for printing. _board-c--: The board cube at coordinates shows . x and y must be from 0 through n-1, where n is the _size: value. This property stores the form of the cube label suitable for comparing with other strings [the lowercased form]. ) $def cubes-prefix "_cubes-" $def casemap-prop "_casemap" $def lock-prop "_lock" $def state-prop "_state" $def size-prop "_size" $def minlen-prop "_minlen" $def time-prop "_time" $def starttime-prop "_starttime" $def np-prop "_np" $def p-prefix "_p-" $def pinv-prefix "_p#-" $def w-#-prefix "_w-#-" $def w-prefix "_w-" $def w-infix "-" $def w-t-prefix "_w-t-" $def w-t-infix "-" $def w-p-prefix "_w-p-" $def w-any-prefix "_w-" $def board-p-prefix "_board-p-" $def board-c-prefix "_board-c-" $def board-any-prefix "_board-" $def board-infix "-" $def lock-stale-time 300 : max 2 copy < if swap then pop ; : min 2 copy > if swap then pop ; : pfxsay "} " swap strcat me @ swap notify ; : propobj trigger @ location ; : dorules "MUF Boggle v0.1 by Mouse, of HoloMUCK." pfxsay " " pfxsay "Commands:" pfxsay " " pfxsay "reset -> Reset the game. Can take arguments (`reset help' for more)." pfxsay "join -> Join the game." pfxsay "begin -> Begin play. Used once everyone has joined." pfxsay "status -> Show game status (board, list of players, and, if the game has" pfxsay " ended, word lists)." pfxsay " " pfxsay "To make guessing easier, when play is in progress, you can simply type" pfxsay "words. This makes it difficult to enter commands; I haven't decided how" pfxsay "I want to address that. Suggestions welcome - page Mouse. For the time" pfxsay "being, wait until the game ends or use a command not beginning with a letter" pfxsay "to leave the room." pfxsay ; : defvalue (propname defvproc -- val) propobj rot getpropstr atoi dup if swap pop else pop exec then ; : fatal-error pfxsay 0 sleep daemon kill ; : maxsize 0 cubes-prefix strlen propobj propfirst do while (v l t s) dup cubes-prefix 5 pick stringncmp not if 3 pick dup neg substr atoi rot 2 copy < if swap then pop swap else pop then propnext loop pop dup 1 < if pop "Configuration error: no cube lists set!" fatal-error then ; : setstrprop (name val -- ) propobj -rot addprop ; : setintprop (name val -- ) intostr setstrprop ; : setintpropswap (val name -- ) swap setintprop ; : intostr2 intostr dup strlen 2 < if "0" swap strcat then ; : get-str propobj swap getpropstr ; : get-num get-str atoi ; : timestr 60 /% intostr2 swap intostr 2 ":" implode ; : pad-to-3 " " swap strcat -3 3 substr ; : remove-matching-prefix (str -- ) 0 swap dup strlen propobj propfirst do while dup 5 pick 5 pick stringncmp if pop else -5 rotate 4 rotate 1 + -4 rotate then propnext loop pop pop propobj swap do dup while 1 - over 4 rotate remove_prop loop pop pop ; : badcubes "Configuration error: botched cubes list" fatal-error ; : pick-from-cube (cube -- letter) dup "/" 1 strncmp if 1 explode else "/" explode swap pop 1 - then dup 1 < if badcubes then random over % 2 + pick over 2 + neg rotate mpop ; : lowercase casemap-prop get-str 1 rexplode 2 /% if "Configuration error: odd-length case map" fatal-error then multisubst ; : roll-cubes (size cubestr -- ) dup not if "No cube set configured for that size" fatal-error then " " explode dup 2 + pick dup * over != if badcubes then do dup while random over % 2 + rotate swap 1 - swap pick-from-cube over 3 + neg rotate loop pop board-any-prefix remove-matching-prefix (letter letter ... letter size) 1 - 0 over 1 for 0 3 pick 1 for (... letter size-1 y x) over intostr board-infix rot intostr 3 "" implode board-p-prefix over strcat 5 pick setstrprop 4 rotate lowercase board-c-prefix 3 pick strcat over setstrprop pop pop loop pop loop pop ; : doreset dup "help" stringcmp not if pop "The full form of the reset command is `reset Z/L MM:SS', which resets the" pfxsay "game to use a ZxZ playing grid, a minimum word length of L letters, and" pfxsay "a playing time of MM minutes SS seconds. All the pieces are optional, and" pfxsay "if omitted default to the values for the last game. If Z is omitted and L" pfxsay "given, the slash must be present; also, if a time is given, the : must be" pfxsay "present in it. Also, the time may appear before the numbers. Examples:" pfxsay " " pfxsay "reset 5" pfxsay " Resets to play a 5x5 game, with the same minimum word length and" pfxsay " timeout as the last game played." pfxsay " " pfxsay "reset 4/3 4:00" pfxsay " Resets to play a 4x4 game with minimum word length 3 and four" pfxsay " minutes playing time." pfxsay " " pfxsay "reset" pfxsay " Resets to play a new game with all values the same as last game." pfxsay exit then casemap-prop get-str strlen 2 % if "Configuration error: odd-length case map" fatal-error then size-prop ' maxsize defvalue minlen-prop { dup 1 - dup 1 < if pop 1 then } defvalue time-prop { 180 } defvalue 4 rotate " " " " subst " " explode dup 4 + -3 roll 4 rotate do dup while 1 - 5 rotate dup if do dup ":" instr dup if strcut atoi swap atoi 60 * + rot pop swap break else pop then dup "/" instr dup if strcut else pop "" then atoi dup if 5 rotate pop -4 rotate else pop then atoi dup if 5 rotate pop -4 rotate else pop then break loop else pop then loop pop 3 pick propobj cubes-prefix 3 pick intostr strcat getpropstr roll-cubes time-prop setintpropswap minlen-prop setintpropswap size-prop setintpropswap state-prop "join" setstrprop p-prefix remove-matching-prefix pinv-prefix remove-matching-prefix w-any-prefix remove-matching-prefix np-prop 0 setintprop "Reset. Size " size-prop get-num intostr ", min length " minlen-prop get-num intostr ", time " time-prop get-num timestr "." 7 "" rimplode pfxsay ; : print-board (linefn -- ; linefn must be [s -- ]) size-prop get-num 1 - 0 over 1 for 0 swap 0 4 pick 1 for over intostr swap intostr board-infix swap board-p-prefix 4 "" implode get-str pad-to-3 rot 1 + rot loop pop "" rimplode 3 pick exec loop pop pop ; : add-to-words-line (s1 ... sN N Ltot pfn x y s -- s1 ... sN' N' Ltot pfn x y) dup 7 rotate 1 + 7 2 roll (s1 ... sN s N+1 Ltot pfn x y s) strlen 1 + 5 rotate over + dup 75 > if (s1 ... sN s N+1 pfn x y slen+1 slen+1+Ltot) pop 5 pick 5 + 4 roll (pfn x y slen+1 s1 ... sN s N+1) swap over 1 + neg rotate 1 - (pfn x y slen+1 s s1 ... sN N) " " rimplode 6 pick exec (pfn x y slen+1 s) " " swap 2 7 3 roll 7 pick strlen + (" " s 2 pfn x y newLtot) else (s1 ... sN s N+1 pfn x y slen+1 newLtot) swap pop then -4 rotate ; : show-word-lists (printfn -- ) "Words found by:" over exec np-prop get-num 1 swap 1 for intostr p-prefix over strcat get-num dbref dup player? if name else "(#" swap int intostr "?)" 3 "" rimplode then " " swap ":" 3 "" rimplode 1 over strlen 5 -2 roll w-#-prefix over strcat get-num dup if 1 swap 1 for (s1 ... sN N Ltot printfn pnostr i) intostr w-prefix 3 pick w-infix 4 pick 4 "" rimplode get-str w-p-prefix over strcat get-str "/" instr if pop else (s1 ... sN N Ltot printfn pnostr i word) add-to-words-line (s1 ... sN' N' newLtot printfn pnostr i) then pop loop else pop then (s1 ... sN N Ltot printfn pnostr) pop swap pop over 2 + neg rotate " " rimplode "." strcat over exec loop (printfn) "Found by multiple players:" 1 over strlen 4 rotate propobj propfirst do while (s1 ... sN N Ltot printfn trav pname) dup w-p-prefix dup strlen strncmp if pop else (s1 ... sN N Ltot printfn trav pname) dup get-str "/" instr if (s1 ... sN N Ltot printfn trav pname) w-p-prefix strlen dup neg substr (s1 ... sN N Ltot printfn trav word) 0 swap add-to-words-line pop (s1 ... sN' N' newLtot printfn trav) else pop then then propnext loop swap pop over 2 + neg rotate " " rimplode "." strcat over exec pop ; : dostatus pop state-prop get-str dup "join" strcmp not if pop "Waiting for players to join. Size " size-prop get-num intostr ", min length " minlen-prop get-num intostr ", time " time-prop get-num timestr "." 7 "" rimplode pfxsay np-prop get-num dup if 0 1 rot 1 for intostr p-prefix swap strcat get-num dbref dup player? if name else int intostr "(#" swap "?)" 3 "" rimplode then swap 1 + loop "Players joined so far:" swap 1 + " " implode "." strcat else "No players joined yet." then pfxsay else dup "play" strcmp not eif pop "Game is playing. Min length " minlen-prop get-num intostr strcat starttime-prop get-num time-prop get-num + systime - dup 1 < if pop ", game ending now." else ", time " swap timestr " left of " time-prop get-num timestr "." 5 "" rimplode then strcat pfxsay ' pfxsay print-board else dup "over" strcmp not eif pop "Game is over." pfxsay ' pfxsay show-word-lists then ; : take-lock propobj systime intostr 1 10 1 for pop 2 copy lock-prop swap addprop-if dup int? if pop pop pop exit then systime over atoi - lock-stale-time > if "Note: breaking stale lock" pfxsay 3 pick lock-prop rot remprop-if pop continue then pop 1 sleep loop "Sorry, lock stuck busy" fatal-error ; ($def take-lock prog "d" set take-lock prog "!d" set) : give-lock propobj lock-prop remove_prop ; : dojoin take-lock state-prop get-str "join" stringcmp if give-lock "The game is not open to more players right now." pfxsay exit then pinv-prefix me @ int intostr strcat get-str dup if p-prefix swap strcat get-num dbref me @ dbcmp then if give-lock "You have already joined the game!" pfxsay exit then np-prop get-num 1 + dup np-prop setintpropswap p-prefix over intostr strcat me @ int intostr setstrprop pinv-prefix me @ int intostr strcat over setintprop pop give-lock "Joined." pfxsay ; : pfxsay-all (s -- ) "} " swap strcat np-prop get-num 1 -1 for p-prefix swap intostr strcat get-num dbref dup player? if over notify else pop then loop pop ; : am-I-playing? ( -- n/"" ; player number if playing, "" if not) pinv-prefix me @ int intostr strcat get-str dup if p-prefix over strcat get-num dbref me @ dbcmp if atoi exit then then pop "" ; : dobegin pop take-lock state-prop get-str "join" stringcmp if give-lock "The game is not ready to begin." pfxsay exit then np-prop get-num 1 < if give-lock "The game has no players yet." pfxsay exit then am-I-playing? string? if give-lock "Only someone who's playing may begin the game." pfxsay exit then 3 1 -1 for "Beginning game. Countdown: " swap intostr "." 3 "" rimplode pfxsay-all 1 sleep loop casemap-prop get-str 2 explode dup 1 -1 for pop dup 1 + rotate 0 1 substr swap loop state-prop "play" setstrprop ";" implode trigger @ location open dup "_action" "__word" addprop dup prog addlink dup "p" set ' pfxsay-all print-board starttime-prop systime setintprop give-lock time-prop get-num sleep take-lock state-prop "over" setstrprop "Game is over." pfxsay-all give-lock ' pfxsay-all show-word-lists 2 sleep recycle ; : adj-for-setup (coord -- min max 1) dup 1 - 0 max swap 1 + size-prop get-num 1 - min 1 ; (forward s-a-t) : suffix-adjacent-to (string taken x y -- string boolean) ( 99 "suffix-adjacent-to ENTRY" pstack s-a-t 99 "suffix-adjacent-to EXIT " pstack ; : s-a-t ) (boolean is true if found, false if not) 4 pick not if 3 mpop 1 exit then (suffix taken x y) -1 1 1 for (suffix taken x y yinc) -1 1 1 for (suffix taken x y yinc xinc) 2 copy or if (suffix taken x y yinc xinc) 4 pick + 3 pick 3 pick + (suffix taken x y yinc xx yy) 2 copy intostr swap intostr (suffix taken x y yinc xx yy yys xxs) 2 copy board-infix swap board-c-prefix 4 "" implode get-str (suffix taken x y yinc xx yy yys xxs v) dup not if 5 mpop continue then dup strlen 11 pick swap strcut -rot strcmp not if (suffix taken x y yinc xx yy yys xxs uffix) -rot (suffix taken x y yinc xx yy uffix yys xxs) 2 "," implode "/" 2 copy 3 "" rimplode 9 pick swap instr if (suffix taken x y yinc xx yy uffix xxs,yys) 4 mpop continue then (suffix taken x y yinc xx yy uffix xxs,yys) 8 pick "/" -rot 3 "" rimplode (suffix taken x y yinc xx yy uffix taken+) 4 2 roll (suffix taken x y yinc uffix taken+ xx yy) suffix-adjacent-to if 5 mpop 1 exit then pop else (suffix taken x y yinc xx yy yys xxs uffix) 5 mpop then else pop then (suffix taken x y yinc) loop pop (suffix taken x y) loop 3 mpop 0 ; : word-in-grid (word -- boolean ; false on error, true on success) dup not if exit then lowercase size-prop get-num 1 - dup 0 -1 for over 0 -1 for (word size-1 y x) 2 copy intostr swap intostr swap board-infix swap board-c-prefix 4 "" implode get-str dup strlen 2 copy 8 pick swap strncmp not if (word size-1 y x v vlen) 6 pick over dup neg substr (word size-1 y x v vlen ord) 4 pick 6 pick 2 copy intostr swap intostr "/" -rot "," swap "/" 5 "" implode -rot (word size-1 y x v vlen ord /xs,ys/ x y) suffix-adjacent-to if (word size-1 y x v vlen ord) 7 mpop 1 exit then (word size-1 y x v vlen ord) pop then (word size-1 y x v vlen) 3 mpop loop (word size-1 y) pop loop pop pop 0 ; : record-word (pno word -- word msg) swap intostr w-t-prefix over w-t-infix 5 pick 4 "" rimplode get-str if pop ": already found." exit then w-#-prefix over strcat dup get-num 1 + swap over setintprop intostr (word pnostr wordnostr) w-prefix 3 pick w-infix 4 pick 4 "" rimplode 4 pick setstrprop w-t-prefix 3 pick w-t-infix 6 pick 4 "" rimplode over setstrprop w-p-prefix 4 pick strcat dup get-str dup if "/" else "" then 5 pick 3 "" rimplode setstrprop pop pop ": recorded." ; : doword take-lock state-prop get-str "play" stringcmp if give-lock "The game is not in progress." pfxsay exit then am-I-playing? dup string? if pop give-lock "You're not playing, so you can't guess." pfxsay exit then swap lowercase dup strlen minlen-prop get-num < if swap pop ": too short." else dup word-in-grid eif record-word else swap pop ": not found in grid." then give-lock strcat pfxsay ; : do__word command @ swap strcat doword ; : main trigger @ "_action" getpropstr dup not if pop trigger @ name then dup "word" stringcmp not if pop doword exit then dup "__word" stringcmp not if pop do__word exit then dup "reset" stringcmp not if pop doreset exit then dup "join" stringcmp not if pop dojoin exit then dup "begin" stringcmp not if pop dobegin exit then dup "status" stringcmp not if pop dostatus exit then dup "rules" stringcmp not if pop dorules exit then "Unrecognized command `" swap strcat "'." strcat pfxsay pop ; . c q