@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
ourCounter @ ourArg !
1 ourCounter !
random ourArg @ % 1 + ourArg !
me @ "_prefs/doing/stored#/" nextprop
begin
dup while
ourCounter @ ourArg @ = not while
ourCounter @ 1 + ourCounter !
me @ swap nextprop
repeat
dup if
me @ swap getpropstr
else
pop
me @ dup "_prefs/doing/stored#/" nextprop getpropstr
then
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