@q @program setdoing.muf 1 99999 d i ( setdoing.muf v1.0 Jessy @ FurryMUCK 7/00 This program controls a @doing command which allows multiple stored doing strings. The stored list may be edited. Stored doing strings can be specifically or randomly selected, either at a prompt or at login. New entries are checked for length. If they are longer than can be displayed completely with the WHO command, 44 chars, they are compressed, successively removing spaces, puncutation, and 'number words'. At each level of compression, the user is prompted to select or reject the compressed version. INSTALLATION: Set setdoing.muf M3 and Link_OK. Create a global @doing action, and link it to the program: @act #0=@doing @link @doing=setdoing.muf Set the global connect queue to trigger the program at login: @propset #0=dbref:_connect/setdoing:<dbref of program> To override the default string length limit of 44 characters, set the _doing_limit property on the program: @set setdoing.muf=_doing_limit:<max chars> USAGE: @doing ....................... Display your current 'doing' string @doing <string> .............. Set 'doing' string to <string> @doing #auto ................. Automatically store new entries @doing #!auto ................ Don't automatically store; prompt instead @doing #connect .............. Set a random stored doing at login @doing #!connect ............. Don't set a random doing at login @doing #delete [<num>] ....... Delete specified stored doing string @doing #edit ................. Edit your list of stored doing strings @doing #list ................. List your stored doing strings @doing #random ............... Set a random stored doing string @doing #select [<num>] ....... Set specified stored doing string Setdoing.muf may be freely ported. Please comment any changes. ) $include $lib/reflist $include $lib/lmgr $include $lib/editor $include $lib/strings lvar ourArg lvar ourBoolean lvar ourCounter lvar ourLimit lvar ourOption lvar ourScratch lvar ourString $define Tell me @ swap notify $enddef : Pad ( s i -- s' ) (* pad string s to i characters *) " " rot swap strcat swap strcut pop ; : DoHelp ( -- ) (* show help screen *) prog name " (#" strcat prog intostr strcat ")" strcat Tell " " Tell "Sets your 'doing' string, as displayed on the WHO list. Entries are " "checked for length. If they are too long -- that is, if they will not " "display completely -- they are compressed, by removing spaces, " "punctuation, and 'number words', successively. You will be prompted " "at each compression stage, and asked if you want to select the " "compressed version. Doing strings that will display as entered are " "set without further prompts." strcat strcat strcat strcat strcat strcat Tell " " Tell " $com ....................... Display your current 'doing' string" command @ "$com" subst Tell " $com <string> .............. Set 'doing' string to <string>" command @ "$com" subst Tell " $com #auto ................. Automatically store new entries" command @ "$com" subst Tell " $com #!auto ................ Don't automatically store; prompt instead" command @ "$com" subst Tell " $com #connect .............. Set a random stored doing at login" command @ "$com" subst Tell " $com #!connect ............. Don't set a random doing at login" command @ "$com" subst Tell " $com #delete [<num>] ....... Delete specified stored doing string" command @ "$com" subst Tell " $com #edit ................. Edit your list of stored doing strings" command @ "$com" subst Tell " $com #list ................. List your stored doing strings" command @ "$com" subst Tell " $com #random ............... Set a random stored doing string" command @ "$com" subst Tell " $com #select [<num>] ....... Set specified stored doing string" command @ "$com" subst Tell " " Tell "#Options do not have to be typed completely: you may enter only the " "first one or few characters. Example: '$com #delete 3' and '$com #d " "3' would both delete your third stored string. The <num> argument is " "optional for #select and #delete: if omitted, a numbered list will be " "displayed; select a numbered entry at the prompt. When #editing, the " "ordering of entries will not necessarily be the same as when displayed" "as they are when displayed with #list or #select. You can type .quit or " ".end to quit at any prompt. You can say and pose while at a prompt." strcat strcat strcat strcat strcat strcat strcat command @ "$com" subst Tell ; : DoCapRomans ( s -- s' ) (* return s, all caps if it's a low roman *) dup "{ii|iii|iv|v|vi|vii|viii|ix}" smatch if toupper then ; : DoCapitalize ( s -- s' ) (* return s, capitalized *) 1 strcut swap toupper swap strcat DoCapRomans ; : DoCapAll ( s -- s' ) (* return s, all words upper case *) " " " " subst " " explode dup if "" begin rot DoCapitalize " " strcat strcat swap 1 - swap over while repeat swap pop dup strlen 1 - strcut pop else pop then ; : DoCleanString ( s -- s' ) (* remove spaces and punctuation from s *) strip (* spaces... *) "" "," subst (* punctuation... *) "" "'" subst "" "." subst "" "!" subst "" ":" subst "" "'" subst ; : DoNumifyString ( s -- s' ) (* replace 'for' w/ '4' in s, etc *) strip (* spaces... *) "1" "One" subst (* numbers *) "2" "Two" subst "2" "Too" subst "2" "To" subst "3" "Three" subst "4" "For" subst "4" "Four" subst "5" "Five" subst "6" "Six" subst "7" "Seven" subst "8" "Eight" subst "8" "ate" subst "9" "Nine" subst ; : DoReadLine ( -- s ) (* read keyboard input; emit poses|says and continue, else return *) begin (* begin input-scanning loop *) read (* does input begin with 'say ' or " ? Emit if so *) dup "\"" stringpfx if 1 strcut swap pop me @ name " says, \"" strcat swap strcat "\"" strcat loc @ swap 0 swap notify_exclude continue then dup "say " stringpfx if 4 strcut swap pop me @ name " says, \"" strcat swap strcat "\"" strcat loc @ swap 0 swap notify_exclude continue then (* does input begin with 'pose ' or : ? Emit if so *) dup ":" stringpfx if 1 strcut swap pop me @ name " " strcat swap strcat loc @ swap 0 swap notify_exclude continue then dup "pose " stringpfx if 5 strcut swap pop me @ name " " strcat swap strcat loc @ swap 0 swap notify_exclude continue then (* continue for strings of all spaces; i.e., treat as null *) dup strip not if pop continue then break (* it's not a pose or say; break and exit *) repeat ; : DoQCheck ( -- i ) (* wrap smatch for .q in an if, to avoid null string match error if user enters a string of all spaces, which DoReadLine would strip to a null string *) dup if dup ".quit" swap stringpfx over ".end" swap stringpfx or if pop ">> Done." Tell pid kill then then ; : DoReadYesNo ( -- i ) (* read from keyboard; accept only vars of yes|no; return 1 for yes *) begin (* begin input-scanning loop *) DoReadLine DoQCheck "yes" over stringpfx if pop 1 break then "no" over stringpfx if pop 0 break then pop ">> Please enter 'Yes' or 'No'." Tell repeat (* end input-scanning loop *) ; : DoAddListLine ( s s' -- ) (* add line s' to list s on user *) over me @ LMGR-GetCount 1 + 3 pick me @ LMGR-PutElem pop ; : DoEditLoop ( listname dbref {rng} mask currline cmdstring -- ) (* read input for list editor *) EDITORloop dup "save" stringcmp not if pop pop pop pop 3 pick 3 + -1 * rotate over 3 + -1 * rotate dup 5 + pick over 5 + pick over over LMGR-DeleteList 1 rot rot LMGR-PutRange 4 pick 4 pick LMGR-GetList dup 3 + rotate over 3 + rotate ">> List saved." Tell "" DoEditLoop exit then dup "abort" stringcmp not if ">> List not saved." Tell pop pop pop pop pop pop pop pop pop exit then dup "end" stringcmp not if pop pop pop pop pop pop dup 3 + rotate over 3 + rotate over over LMGR-DeleteList 1 rot rot LMGR-PutRange ">> List saved." Tell exit then ; : DoEditList ( d s -- ) (* edit list s on d *) swap ">> Welcome to the list editor. You can get help by entering '.h' on" Tell ">> a line by itself. '.end' will save and exit. '.abort' will abort" Tell ">> any changes. To save changes and continue editing, use '.save'." Tell over over LMGR-GetList "save" 1 ".i $" DoEditLoop ; : DoRemoveList ( d s -- ) (* remove list s from d *) "#" strcat ourString ! ourScratch ! ourScratch @ ourString @ remove_prop ourString @ "/" strcat ourString ! "1" ourCounter ! begin (* begin line-removing loop *) ourScratch @ ourString @ ourCounter @ strcat over over getpropstr while remove_prop ourCounter @ atoi 1 + intostr ourCounter ! repeat (* end line-removing loop *) pop pop ourScratch @ ourString @ dup "*/" smatch if dup strlen 1 - strcut pop strip then remove_prop ; : DoShowList ( d s -- ) (* display list s on object d *) "#/" strcat swap LMGR-GetList begin (* begin line-listing loop *) dup while dup 1 + rotate Tell 1 - repeat (* end line-listing loop *) pop ; : DoEdit ( -- ) (* edit list of stored doing strings *) me @ "_prefs/doing/stored" DoEditList ; : DoList ( -- ) (* list stored doing strings *) 1 ourCounter ! ">> Your currently stored @doing strings:" Tell me @ "_prefs/doing/stored#/" nextprop begin dup while ourCounter @ intostr ")" strcat 4 Pad me @ 3 pick getpropstr strcat Tell ourCounter @ 1 + ourCounter ! me @ swap nextprop repeat pop ourCounter @ 1 - ourCounter ! ; : DoResetDoing ( -- ) (* reset a stored doing string *) 0 ourBoolean ! 1 ourCounter ! me @ "_prefs/doing/stored#/" nextprop begin dup while ourCounter @ ourArg @ = if 1 ourBoolean ! me @ swap getpropstr break then ourCounter @ 1 + ourCounter ! me @ swap nextprop repeat me @ "_/do" rot setprop ; : DoDeleteDoing ( -- ) (* delete a stored doing string *) 0 ourBoolean ! 1 ourCounter ! me @ "_prefs/doing/stored#/" nextprop begin dup while ourCounter @ ourArg @ = if 1 ourBoolean ! me @ swap remove_prop break then ourCounter @ 1 + ourCounter ! me @ swap nextprop repeat ; : DoGetStringNumber ( -- i ) (* prompt user to get number of string *) DoList begin ">> Which doing do you want to select?" Tell ">> [Enter number from list, .l to list again, or .q to quit]" Tell DoReadLine strip DoQCheck ".list" over stringpfx if DoList pop continue then dup number? not if ">> Sorry, that's not a number." Tell pop continue then dup atoi ourCounter @ > if ">> Invalid entry. You don't have that many." Tell pop continue then atoi break repeat ; : DoSelect ( -- ) (* select and set a stored doing string *) ourArg @ if (* get string number if needed *) ourArg @ number? if ourArg @ atoi else DoGetStringNumber then else DoGetStringNumber then ourArg ! DoResetDoing (* set it *) "You are currently doing: " (* notify *) me @ "_/do" getpropstr strcat Tell ; : DoDelete ( -- ) (* select and delete a stored doing string *) ourArg @ if (* get string number if needed *) ourArg @ number? if ourARg @ atoi else DoGetStringNumber then else DoGetStringNumber then ourArg ! DoDeleteDoing (* delete it *) ">> Deleted." Tell ; : DoRandom ( -- ) (* set a random doing *) 0 ourCounter ! me @ "_prefs/doing/stored#/" nextprop begin dup while ourCounter @ 1 + ourCounter ! me @ swap nextprop repeat random ourCounter @ % 1 + intostr me @ "_prefs/doing/stored#/" rot strcat getpropstr me @ "_/do" rot setprop ; : DoSetRandom ( -- ) (* go set a random doing *) DoRandom (* go set *) "You are currently doing: " (* notify *) me @ "_/do" getpropstr strcat Tell ; : DoConnect ( -- ) (* set: new do's are automatically stored *) me @ "_prefs/doing/connect" "yes" setprop ">> Set. A doing string will be selected from your list at login." Tell ; : DoNotConnect ( -- ) (* set: new do's are not automatically stored *) me @ "_prefs/doing/connect" remove_prop ">> Set. A doing string will not be selected from your list at login." Tell ; : DoAuto ( -- ) (* set: new do's are automatically stored *) me @ "_prefs/doing/auto" "yes" setprop ">> Set. New doing strings will be automatically stored." Tell ; : DoNotAuto ( -- ) (* set: new do's are not automatically stored *) me @ "_prefs/doing/auto" remove_prop ">> Set. New doing strings will not be automatically stored." Tell ; : DoSetDo ( -- ) (* set a new doing string *) prog "_doing_limit" getpropstr dup if (* get length limit *) atoi ourLimit ! else 44 ourLimit ! then (* check: string too long? compress and discuss if so *) begin ourArg @ strlen ourLimit @ > if ">> That @doing message is too long to display completely." Tell " " Tell (* cap all words and remove spaces *) ourArg @ DoCapAll "" " " subst " " over strcat Tell " " Tell ">> Do you want to use this instead? (y/n)" Tell dup strlen ourLimit @ > if ">> (It's still too long by $num $chars.)" ourLimit @ 3 pick strlen swap - intostr "$num" subst ourLimit @ 3 pick strlen swap - intostr "1" smatch if "character" else "characters" then "$chars" subst Tell then DoReadYesNo if ourArg ! break then (* take out punctuation, if any *) dup "." instr over "," instr or over "'" instr or over ":" instr or over ";" instr or over "!" instr or if " " Tell DoCleanString " " over strcat Tell " " Tell ">> How about this? (y/n)" Tell dup strlen ourLimit @ > if ">> (It's still too long by $num $chars.)" ourLimit @ 3 pick strlen swap - intostr "$num" subst ourLimit @ 3 pick strlen swap - intostr "1" smatch if "character" else "characters" then "$chars" subst Tell then DoReadYesNo if ourArg ! break then then (* convert 'number words' to numbers, if any *) pop ourArg @ DoCleanString " " strcat " " swap strcat dup " one " instr over " two " instr or over " too " instr or over " to " instr or over " three" instr or over " for " instr or over " four " instr or over " five " instr or over " six " instr or over " seven " instr or over " eight " instr or over " ate " instr or over " nine " instr or if strip DoCapAll DoNumifyString "" " " subst " " Tell " " over strcat Tell " " Tell ">> How about this? (y/n)" Tell dup strlen ourLimit @ > if ">> (It's still too long by $num $chars.)" ourLimit @ 3 pick strlen swap - intostr "$num" subst ourLimit @ 3 pick strlen swap - intostr "1" smatch if "character" else "characters" then "$chars" subst Tell then DoReadYesNo if ourArg ! break then then pop (* try original string, truncated *) " " Tell ourArg @ ourLimit @ strcut pop dup " " swap strcat Tell " " Tell ">> Well, how about your original setting " "cut off at $num characters? (y/n)" strcat ourLimit @ intostr "$num" subst Tell DoReadYesNo if ourArg ! break else ">> OK, not setting a @doing." Tell exit then else break then repeat (* if string short enough, or user selected compressed, set *) me @ "_/do" ourArg @ setprop 0 ourBoolean ! me @ "_prefs/doing/stored#/" nextprop begin dup while me @ over getpropstr ourArg @ smatch if 1 ourBoolean ! break then me @ swap nextprop repeat pop (* check: add new entry to stored list? *) ourBoolean @ not if me @ "_prefs/doing/auto" getpropstr if 1 else ">> Do you want to add this doing to " "your stored list as well? (y/n)" strcat Tell DoReadYesNo if 1 else 0 then then if "_prefs/doing/stored" ourArg @ DoAddListLine then then ">> Set." Tell ; : main "me" match me ! dup if ourArg ! ourArg @ "Connect" smatch command @ "Queued event." smatch and if me @ "_prefs/doing/connect" getpropstr if DoRandom then exit then ourArg @ "#*" smatch if ourArg @ " " instr if ourArg @ dup " " instr strcut strip ourArg ! strip ourOption ! else ourArg @ strip ourOption ! then "#help" ourOption @ stringpfx if DoHelp exit else "#auto" ourOption @ stringpfx if DoAuto exit else "#!auto" ourOption @ stringpfx if DoNotAuto exit else "#connect" ourOption @ stringpfx if DoConnect exit else "#!connect" ourOption @ stringpfx if DoNotConnect exit else "#delete" ourOption @ stringpfx if DoDelete exit else "#edit" ourOption @ stringpfx if DoEdit exit else "#list" ourOption @ stringpfx if DoList exit else "#random" ourOption @ stringpfx if DoSetRandom exit else "#select" ourOption @ stringpfx if DoSelect exit else ">> #Option not found." Tell exit then then then then then then then then then then then DoSetDo else "You are currently doing: " me @ "_/do" getpropstr strcat Tell then ; . c q @set setdoing.muf=L