@prog cmd-morph
1 9999 d
1 i
( cmd-morph ver. 1.0  written 12/7/92 for MUCK fb4.2 with FB libraries.
  
COMMANDS:
  morph                         List current morph name.
  morph <morphname>             Morph to the given morph name.
  morph <formname>=<mesg>       Morph to given form, showing given message.
  morph <formname>=/            Morph to given form silently.
  morph #help                   Get help on the morph program.
  morph #list                   List the available morph forms.
  morph #list <morphname>       List the props and mesgs related to a morph
  morph #edit <morphname>       Lets you create a new form or edit an old one.
  morph #kill <morphname>       Removes the given morph form's relevant data.
  morph #obj <object>=<cmd>     Lets you use morph on objects you own.  Ex.:
                                 morph #obj bluebird=#edit happy      or
                                 morph #obj #1234=bird
  
PROPERTIES:
  _morph/current:<current form>
  _morph/f-<morphname>/from/<lastmorphname>:<morphing message>
  _morph/f-<morphname>/props#/<number>:<propname>:<value to set>
  
EXAMPLE:
  _morph/f-helf/from/demon:shimmers and loses her wings and scales...
  _morph/f-helf/props#/1:_/de:@$desc %list[_desc/half-elf]
  
)
  
$include $lib/lmgr
$include $lib/strings
$include $lib/edit
$include $lib/editor
  
lvar srcobj
lvar dstobj
  
  
: setpropstr (d s s -- )
   dup if 0 addprop else pop remove_prop then
;
  
: get-proploc ( -- )
   dstobj @ srcobj !
   dstobj @ "_morph/proploc" getpropstr
   dup if
      atoi dbref dup owner dstobj @ owner dbcmp if
         srcobj !
      else pop
      then
   else pop
   then
;
  
: get-currmorph ( -- s)
   srcobj @ "_morph/current" getpropstr
;
  
: set-currmorph (s -- )
   srcobj @ "_morph/current" rot 0 setpropstr
;
  
: issuch-morph? (form -- exists?)
   "_morph/f-" swap strcat
   srcobj @ swap propdir?
;
  
: kill-morphprops (form -- )
   "_morph/f-" swap strcat
   srcobj @ swap remove_prop
;
  
: get-morphmesg (formfrom formto -- morphmesg)
   "_morph/f-" swap strcat
   "/from/" strcat swap strcat             (make propname of desired mesg)
   srcobj @ swap getpropstr               (get the message)
;
  
: set-morphmesg (formfrom formto morphmesg -- )
   "_morph/f-" rot strcat
   "/from/" strcat rot strcat             (make propname of desired mesg)
   srcobj @ swap rot setpropstr
;
  
  
: get-morphforms ( -- s)
   "" srcobj @ "_morph/"
   begin (s d s)
      over swap nextprop
      dup while
      dup tolower "f-" 2 strncmp if continue then
      dup 2 strcut swap pop
      " " strcat 4 rotate strcat
      -3 rotate
   repeat
   pop pop strip
;
  
  
: get-morphprops (s -- sx..s1 i)
   "_morph/f-" swap strcat "/props" strcat
   srcobj @ .lmgr-getlist
;
  
: set-morphprops (sx..s1 i s -- )
   1 "_morph/f-" rot strcat
   "/props" strcat srcobj @
   .lmgr-putrange
;
  
  
  
  
: morph-setprops  (formto -- )
   get-morphprops
   begin
      dup 0 > while 1 - swap              (check if done.  if not, dec. cntr)
      strip dup not if pop continue then  (if blank, ignore.)
      ":" .split
      dup not if
         pop dstobj @ swap remove_prop         (if no val, remove the prop.)
      else
         dstobj @ -3 rotate 0 addprop          (otherwise, set prop to value.)
      then
   repeat
   pop
;
  
  
: choose-a-an (s -- s)
   1 strcut pop tolower
   "aeiou" swap instr
   if "an" else "a" then
;
  
  
: comma-collate (sx...s1 i -- s)
   "" begin
      over while
      over 1 = if
         rot strcat
      else
         over 2 = if
            rot strcat " and " strcat
         else
            rot strcat ", " strcat
         then
      then
      swap 1 - swap
   repeat
   swap pop
;
  
  
: morph-showmesg (formfrom formto message -- )
   dup not if
      pop swap over get-morphmesg
      dup not if
         pop "suddenly changes into "        (make a default message)
         over choose-a-an strcat
         " " strcat swap strcat
         "!" strcat
      else
         swap pop
      then
   else
      -3 rotate pop pop
   then
   dup "/" strcmp not if pop exit then
   dstobj @ swap pronoun_sub strip
   dup "'" 1 strncmp if
      " " swap strcat
   then
   dstobj @ name swap strcat
   dstobj @ location #-1 rot notify_except
;
  
  
: proptomesg (s -- s)
   dup tolower " " swap over strcat strcat
   " _/de  _/sc  _/fl  _/dr  _/osc _/ofl _/odr " swap instr
   dup if swap pop else pop exit then
   "@Desc @Succ @Fail @Drop @Osucc@Ofail@Odrop"
   swap strcut swap pop
   6 strcut pop strip
;
  
  
: mesgtoprop (s -- s)
   dup tolower " " swap over strcat strcat
   " @desc  @succ  @fail  @drop  @osucc @ofail @odrop" swap instr
   dup if swap pop else pop exit then
   "_/de _/sc _/fl _/dr _/osc_/ofl_/odr"
   swap 7 / 5 *
   strcut swap pop
   5 strcut pop strip
;
  
  
: get-morphprops-translated (s -- sx..s1 i)
   get-morphprops
   dup begin
      dup while 1 -
      dup 3 + pick
      dup ":" instr not if
         "Warning:  property setting rejected:  \""
         swap strcat "\"" strcat .tell
         dup 3 + rotate pop swap 1 - swap
         continue
      then
      ":" .split strip swap strip proptomesg
      ":" strcat swap strcat
      over 3 + put
   repeat pop
   ( 0 1 EDITsort )
;
  
  
: set-morphprops-translated (sx..s1 i s -- )
   over 2 + -1 * rotate
   dup begin
      dup while 1 -
      dup 3 + pick
      dup ":" instr not if
         "Warning:  property setting rejected:  \""
         swap strcat "\"" strcat .tell
         dup 3 + rotate pop swap 1 - swap
         continue
      then
      ":" .split strip swap strip mesgtoprop
      ":" strcat swap strcat
      over 3 + put
   repeat pop
   ( 0 1 EDITsort )
   dup 2 + rotate
   set-morphprops
;
  
  
: show-morphmesgs (form -- )
   "Morphing messages for the \"" over
   strcat "\" morph form." strcat .tell
   get-morphforms
   " " explode
   dup 2 + rotate
   begin
      over 0 > while swap 1 - swap rot
      dup not if pop continue then
      over over stringcmp not if pop continue then
      dup 3 pick get-morphmesg
      dup not if pop "*Default message*" then
      "From \"" 3 pick strcat "\" form: " strcat
      swap strcat .tell
      over over get-morphmesg
      dup not if pop "*Default message*" then
      "To \"" rot strcat "\" form: " strcat
      swap strcat .tell
   repeat
   pop pop
;
  
  
  
: kill-morphmesgs (form -- )
   get-morphforms
   " " explode dup 2 + rotate
   begin
      dup 0 > while swap 1 - swap rot
      dup not if pop continue then
      over over stringcmp not if pop continue then
      over swap "" set-morphmesg
   repeat
   pop pop
;
  
  
: show-morphprops (form -- )
   "Things to set for the /"" over strcat
   "/" morph form:" strcat .tell
   get-morphprops-translated
   begin
      dup while 1 -
      dup 2 + rotate .tell
   repeat
;
  
  
  
: edit-morphmesg (formfrom formto -- )
   over over stringcmp not if pop pop exit then (silly!)
  
   "What message should show when morphing from \""
   3 pick strcat "\" to \"" strcat
   over strcat "\" form?" strcat .tell
  
   over over get-morphmesg
   dup if
      "The old message was: " swap strcat .tell
      "Enter '-' keep the current message.  "
      "Enter a space by itself to clear it."
      strcat .tell
   else
      pop "Enter '-' to leave this message blank." .tell
   then
   "Enter '/' to make this transformation silent." .tell
  
   (formfrom formto)
   read strip
   dup "-" strcmp not if
      pop pop pop "Message unchanged." .tell exit
   then
   dup not if
      "Message cleared." .tell
   else
      dup ":" 1 strncmp not if
         1 strcut swap pop
      else
         dup tolower dstobj @ name tolower
         dup strlen strncmp not if
            dstobj @ name strlen
            strcut swap pop strip
         then
      then
      "Message set." .tell
   then
   set-morphmesg
;
  
  
: edit-morphmesgs (form -- )
   get-morphforms
   " " explode
   dup 2 + rotate
   begin
      dup 0 > while swap 1 - swap rot
      dup not if pop continue then
      over over edit-morphmesg
      over edit-morphmesg
   repeat
   pop pop
;
  
  
: edit-morphprops (form -- save?)
"Please enter the properties to change for this form using the text editor."
.tell
"Each line should be of the format: \"propname:newvalue\".  @desc, @succ,"
.tell
"@fail, @drop, @osucc, @ofail, and @odrop are acceptable propnames."
.tell
   dup get-morphprops-translated
   .sedit_std "abort" stringcmp not if
      "Aborting changes to this morph form." .tell
      pop pop 0 exit
   then
   dup 2 + rotate
   set-morphprops-translated 1
;
  
  
  
  
: do-morphto (formto message -- )   (morph <morphname>)
   swap get-currmorph
   over set-currmorph
   over morph-setprops
   swap rot morph-showmesg
;
  
  
: show-currmorph ( -- )     (morph)
   "Current morph form is \""
   get-currmorph strcat
   "\"" strcat .tell
;
  
  
: show-morphforms ( -- )    (morph #list)
   get-morphforms
   " " explode comma-collate
   "Forms defined for "
   swap strcat "." strcat .tell
;
  
  
: show-morphlisting (form -- )  (morph #list <morphname>)
   dup show-morphmesgs
   show-morphprops
   "Listing complete." .tell
;
  
  
: edit-morph (form -- )  (morph #edit <morphform>)
   dup issuch-morph? not if
      "There is no \"" over strcat
      "\" morph form.  Would you like to create it? [ny]"
      strcat .tell read strip tolower
      "y" 1 strncmp if
         pop "Aborting morph form edit." .tell exit
      then
   then
   edit-morphprops
   if edit-morphmesgs then
   "Morph form editing complete." .tell
;
  
  
: kill-morph (form -- )  (morph #kill <morphform>)
   dup issuch-morph? not if
      "There is no \"" swap strcat
      "\" morph form." strcat .tell exit
   then
   dup kill-morphprops
   kill-morphmesgs
   "Form cleared." .tell
;
  
  
: show-help ( -- )
   "_ FB Morph v1.0 _________  ______________________________________________"
   "morph                      List current morph form."
   "morph <formname>           Morph to the given morph form."
   "morph <formname>=<mesg>    Morph to given form, showing given message."
   "morph <formname>=/         Morph to given form silently."
   "morph #help                Get help on the morph program. (This screen)"
   "morph #list                List the available morph forms."
   "morph #list <formname>     List the props and mesgs related to a form."
   "morph #edit <formname>     Lets you create a new form or edit an old one."
   "morph #kill <formname>     Clears the given morph form."
   "morph #obj <object>=<cmd>  Lets you use morph on objects you own.  Ex.:"
   "                            morph #obj #1234=bird        or"
   "                            morph #obj bluebird=#edit happy"
   13
  
   begin
      dup while 1 -
      dup 3 + rotate .tell
   repeat
   pop
;
  
  
  
  
: clean-formname (s -- s)
   "_" " " subst
   16 strcut pop
;
  
: main-interface
   me @ dstobj !
   strip
  
   dup tolower "#obj " 5 strncmp not if
      5 strcut swap pop
      strip "=" .split strip swap strip
      dup not if
         "Syntax:  morph #obj <object>=<morph-command>" .tell
         "Example:  morph #obj bluebird=#edit happy" .tell
         pop pop exit
      then
      .match_controlled
      dup not if pop pop exit then
      dstobj !
   then
  
   get-proploc
  
   dup not if pop show-currmorph exit then
  
   dup "#" 1 strncmp if
      "=" .split strip swap strip
      clean-formname
      swap do-morphto exit
   then
  
   " " .split strip swap strip
   dup "#help" stringcmp not if
      pop pop show-help exit
   then
  
   dup "#list" stringcmp not if
      pop dup not if
         pop show-morphforms exit
      then
      clean-formname show-morphlisting exit
   then
  
   dup "#edit" stringcmp not if
      pop dup not if
         pop "Syntax:  morph #edit <form>" .tell exit
      then
      clean-formname edit-morph exit
   then
  
   dup "#kill" stringcmp not if
      pop dup not if
         pop "Syntax:  morph #kill <form>" .tell exit
      then
      clean-formname kill-morph exit
   then
  
   "Syntax error:  Unknown morph command.  Type 'morph #help' for help."
   .tell pop pop
;
.
c
q
@set cmd-morph=Link_OK
@action morph=#0=tmp/exit1
@link $tmp/exit1=cmd-morph
