@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