@program SuperMorph.muf
1 1000 d
i
$include $lib/alynna
$def REPOSITORY prog
$def MORPHDIR "/_morph#/"
$def MX "/_morph#/" swap strcat
$def SEXPROP "sex"
$def SPECIESPROP "species"
$author Alynna
$version 1.3
$note The morph program to end all morph programs
$def PNAMEVER "Alynna's Morph v" prog "_version" getpropstr strcat

$def tm "Morph" pretty tellme
$def th quiet @ not if tellhere else "Morph/Silent" pretty tellme then
 
$ifdef __fuzzball__
$include $lib/cp-mv
$def copyprops pop cp-prop
$endif

$def nameEx dup me @ swap controls if unparseobj else name then
 
lvar cmd
lvar param
 
lvar props
lvar rprops
lvar dprops

lvar quiet

: retarget[ str:target -- retarget ]
target @ not if me @ exit then
target @ resolve target !
target @ int 0 < if "Invalid or unresolvable reference." tm pid kill then
target @ "_prefs/morph/public" getprop if target @ exit then
( this allows us to endow morphs onto puppets and for wizzes to control all morphs )
    me @ target @              controls if target @ exit then
( if all else fails, tell them )
"^RED^Permission denied.^NORMAL^" tm pid kill
;
 
: morph.repository.get
;
 
: morph.repository.put
;
  
: morph.repository.set
;
  
: morph.repository.search
;
 
: morph.repository.remove
;
 
: morph.auto.connect
var morphid
param @ morphid !

morphid @ if
 me @ { morphdir morphid @ "#/" }join propdir? not if
  { "A morph of that ID was not found on you." }cat tm exit then
 me @ "_prefs/morph/connect" morphid @ setprop
 { "Your connect morph is now set to: " morphid @ }cat tm
else
 me @ "_prefs/morph/connect" 0 setprop
 { "Your connect morph is now cleared." }cat tm
then
;
 
: morph.auto.disconnect
var morphid
param @ morphid !

morphid @ if
 me @ { morphdir morphid @ "#/" }join propdir? not if
  { "A morph of that ID was not found on you." }cat tm exit then
 me @ "_prefs/morph/disconnect" morphid @ setprop
 { "Your disconnect morph is now set to: " morphid @ }cat tm
else
 me @ "_prefs/morph/connect" 0 setprop
 { "Your disconnect morph is now cleared." }cat tm
then
;
 
: morph.share.offer
var target
var morphid

param @ split morphid ! target !

;
 
: morph.share.accept
;
 
: morph.personal.list
var target
param @ retarget target !
{ "Morphs on " target @ nameEx }cat header tellme
target @ morphdir array_get_propdirs " " array_join 
"" "#" subst " " explode_array wrap_items_variable atellme
{ PNAMEVER }cat footer tellme
;
 
: morph.personal.add
var item
var value
var morphid
var morphname
var morphmessage
var defflag



param @ not if { "Syntax: " command @ " " cmd @ " <morphid>[=<morphname>[=<morphmessage>]]" }cat tm exit then
param @ "=" split morphname ! morphid !
morphname @ "=" split morphmessage ! morpname !
morphid @ " " instr if
 { "Error: The morphid cannot have any spaces in it." }cat tm exit then

READ_WANTS_BLANKS
morphname @ not if
 { "Please enter a name for this morph.  This is not the ID but a short description of it." }cat
 { "If none is entered (by pressing enter) the default will be '" me @ sexprop getprop " " me @ speciesprop "'" }cat
 read dup not if { me @ sexprop getprop " " me @ speciesprop }join morphname !
then 

morphmessage @ not if
 { "Please enter a message for this morph.  This will be displayed when you morph, unless " }cat
 { "If none is entered (by pressing enter) the default will be '" me @ sexprop getprop " " me @ speciesprop "'" }cat
 read dup not if { me @ sexprop getprop " " me @ speciesprop }join morphmessage !
then 


props @ foreach value ! item !
 me @ { morphdir morphid @ "#/" value @ }join me @ item @ getprop setprop
repeat 

me @ "_/de" getprop "{eval:{list:redesc,this}}" stringcmp if
 me @ { morphdir morphid @ "#/desc" }join me @ "/redesc" array_get_proplist array_put_proplist
 me @ "_/de" "{eval:{list:redesc,this}}" setprop
else
 me @ { morphdir morphid @ "#/desc" }join me @ "_/de" getprop setprop
then
  
{ me @ " " me @ { morphdir morphid @ "#/message" }join getprop }cat tm

;
 
: morph.personal.del
;
 
: morph.personal.hide
me @ "_prefs/morph/public" 0 setprop
{ "You are now set so that your morphs ^RED^are not^NORMAL^ visible to the public." }cat tm
;
 
: morph.personal.show
me @ "_prefs/morph/public" 1 setprop
{ "You are now set so that your morphs ^GREEN^are^NORMAL^ visible to the public." }cat tm
;

: morph.personal.change
var item
var value
var morphid
cmd @ morphid !

morphid @ not if { "Syntax: " command @ " <morphid>" }cat tm exit then

me @ { morphdir morphid @ "#/" }join propdir? not if
 { "A morph of that ID was not found on you." }cat tm exit then

props @ foreach value ! item !
 me @ item @ me @ { morphdir morphid @ "#/" value @ }join getprop setprop
repeat 

me @ { morphdir morphid @ "#/desc#/" }join propdir? if
 me @ "/redesc" me @ { morphdir morphid @ "#/desc#/" }join array_get_proplist array_put_proplist
 me @ "_/de" "{eval:{list:redesc,this}}" setprop
else
 me @ "_/de" me @ { morphdir morphid @ "#/desc" }join getprop setprop
then
  
{ me @ " " me @ { morphdir morphid @ "#/message" }join getprop }cat th

me @ "_prefs/morph/last" me @ "_prefs/morph/current" getprop setprop
me @ "_prefs/morph/current" morphid @ setprop
;

: morph.personal.view
var target
var morphid
var item
var value
var validity
param @ "=" split morphid ! target !
morphid @ not if target @ morphid ! "me" target ! then
target @ retarget target !
target @ { morphdir morphid @ "#/" }join propdir? not if
 { "A morph of that ID was not found on " target @ "." }cat tm exit then

{ "Morph " morphid @ " on " target @ nameEx }cat header tellme
target @ { morphdir morphid @ "#/desc#/" }join propdir? if
 target @ { morphdir morphid @ "#/desc#/" }join array_get_proplist atellme
else
 target @ { morphdir morphid @ "#/desc" }join "Morph" 0 parseprop tellme
then
{ "Properties " morphid @ " on " target @ nameEx }cat header tellme
{ "{" dprops @ "|" array_join "}" }join validity !
target @ { morphdir morphid @ "#/" }join array_get_propvals foreach value ! item !
 item @ validity @ smatch if
  { "^GREEN^" item @ capitalize 20 lj "^YELLOW^" value @ "^NORMAL^" }cat tellme
 then
repeat
{ PNAMEVER }cat footer tellme
;
  
: morph.configure
prog "_initialized" getprop not if
 
prog "_props" {
{ SEXPROP ":sex" }join
{ SPECIESPROP ":species" }join
"_/de:desc" 
"/redesc#/:/desc#/"
"_flight?:flight"
"_say/def/say:say" 
"_say/def/osay:osay" 
"_say/def/quote:quote" 
"_say/commas?:commas?"
"_say/parseout?:parseout?" 
"_scent:scent" 
"_taste:taste"
"_feel:feel" 
"ride/_mode:ridemode" 
"%a:%a"
"%p:%p"
"%o:%o"
"%r:%r"
"%s:%s"
"%n:%n" 
"_tel/succ:telsucc"
"_tel/osucc:telosucc"
"_tel/drop:teldrop" 
"_ui/m:uim"
"_prefs/whatis/custom:wicustom"
"_prefs/whatis/flags:wiflags" 
"_prefs/witf/custom:witfcustom"
"_prefs/witf/flags:witfflags" 
"_page/formats/f-page:f-page"
"_page/formats/f-pose:f-pose" 
"_page/formats/o-page:o-page"
"_page/formats/o-pose:o-pose"
}array array_put_proplist
 
prog "_rprops" {
{ SEXPROP ":sex" }join
{ SPECIESPROP ":species" }join
"_/de:desc"
"/redesc#/:/desc#/"
"_flight?:flight"
"_say/def/say:say"
"_say/def/osay:osay"
"_scent:scent"
"_taste:taste"
"_feel:feel" 
"ride/_mode:ridemode" 
"%a:%a"
"%p:%p"
"%o:%o"
"%r:%r"
"%s:%s"
"%n:%n" 
}array array_put_proplist

prog "_dprops" {
"name"
"message"
"sex" 
"species" 
"flight"
"say"
"osay"
"scent"
"taste"
"feel" 
"ridemode" 
}array array_put_proplist
 
prog "_initialized" 1 setprop
then
 
me @ "_prefs/morph/props" array_get_proplist
prog "_props"             array_get_proplist
array_union props !
{ props @ foreach swap pop ":" split repeat }dict props !
prog "_rprops"            array_get_proplist rprops !
{ rprops @ foreach swap pop ":" split repeat }dict rprops !
prog "_dprops"            array_get_proplist dprops !
;

: morph.status
{ "Morph status of " me @ nameEx }cat header tellme
{
{ "Current morph"            25 lj "^GREEN^" me @ "_prefs/morph/current" getpropstr dup not if pop "^RED^None" then "^NORMAL^" }cat 
{ "Last morph"               25 lj "^GREEN^" me @ "_prefs/morph/last" getpropstr dup not if pop "^RED^None" then "^NORMAL^" }cat 
{ "Connect morph"            25 lj "^GREEN^" me @ "_prefs/morph/connect" getpropstr dup not if pop "^RED^None" then "^NORMAL^" }cat 
{ "Disconnect morph"         25 lj "^GREEN^" me @ "_prefs/morph/disconnect" getpropstr dup not if pop "^RED^None" then "^NORMAL^" }cat 
{ "Morphs are public?"       25 lj me @ "_prefs/morph/public" getprop if "^GREEN^Yes" else "^RED^No^" then "^NORMAL^" }cat 
{ "Morph being offered"      25 lj
  me @ "_prefs/morph/givemorph" getprop if
   "^GREEN^" me @ "_prefs/morph/givemorph" getprop " by " me @ "_prefs/morph/giveplayer" getprop "^NORMAL^"
  else
   "^RED^None^NORMAL^"  
  then 
}cat 
{ "Morph you are offering"    25 lj
  me @ "_prefs/morph/takemorph" getprop if
   "^GREEN^" me @ "_prefs/morph/takemorph" getprop " by " me @ "_prefs/morph/takeplayer" getprop "^NORMAL^"
  else
   "^RED^None^NORMAL^"  
  then 
}cat 
}array atellme
{ PNAMEVER }cat footer tellme
;

: morph.propqueue.connect
me @ "_prefs/morph/connect" getprop cmd ! morph.personal.change
;

: morph.propqueue.disconnect
me @ "_prefs/morph/disconnect" getprop cmd ! morph.personal.change
;

: morph.help
{
"Supermorph v1.1 (C) 2003 Alynna Trypnotk"
"   The no-holds-barred morph program    "
"   For Fuzzball 6 and ProtoMUCK 1.8     "
" "
"Syntaxii:"
" "
"Help:"
" morph #help"
"  You're looking at it"
" morph #status"
"  Look at various morph status info"
" "
"Personal morph commands:"
" morph <morphid>"
"  Change to the specified morph"
" morph #last"
"  Change to the last morph you were"
" morph #random [<pattern>]"
"  Change to a random morph in your list"
" morph #list [<person>]"
"  Get a list of your morphs, or someone with their morphs public"
" morph #add <morphid>[=<desc>[=<change msg>]]"
"  Turn your current form into a morph"
" morph #del <morphid>"
"  Delete the specified morph"
" morph #rename <morphid>=<newid>"
"  Change a morph ID to a new ID"
" morph #show"
"  Allow your morphs to be viewed"
" morph #hide"
"  (Default) Disallow your morphs to be viewed"
" "
"Automatic morph commands:"
" morph #connect <morphid>"
"  Set your default connect morph"
" morph #disconnect <morphid>"
"  Set your default disconnect morph"
" "
"Morph repository commands:"
" morph #search <pattern>"
"  Search the repository for morphs"
" morph #put <morphid>=<repid>"
"  Submit one of your morphs to the repository"
" morph #get <repid>=<morphid>"
"  Get a morph from the repository"
" morph #set <repid>=<morphid>"
"  Get a morph from the repository, and morph to it immediately"
" morph #remove <morphid>"
"  Remove a morph that *you* added to the repository"
" * The <morphid> is the morph as its listed in your morph #list."
" * The <repid> is the name you want to give it in the registry,"
"   which must be unique."
" "
"Morph sharing commands:"
" morph #offer <person>=<morphid>"
"  Offer one of your morphs to someone"
" morph #accept <person>=<morphid>"
"  Accept an offered morph"
" * When offering a morph, the <morphid> is the morph name as its"
"   given in morph #list."
" * When accepting a morph, the <morphid> is the morph name you want"
"   to give it in your list."
" "
" All morph commands, can be replaced with 'qmorph' to supress any room notifies."
}array atellme
;

: main 
" " split param ! cmd !
morph.configure

command @ "Queued Event." smatch if
cmd @ case
 "Connect" smatch when morph.propqueue.connect end
 "Disconnect" smatch when morph.propqueue.disconnect end
endcase 
then

command @ "*morph" smatch if
command @ "qmorph" smatch if 1 quiet ! then
cmd @ case
 "#hel*" smatch when morph.help end
 "#lis*" smatch when morph.personal.list end
 "#add*" smatch when morph.personal.add end
 "#del*" smatch when morph.personal.del end
 "#sho*" smatch when morph.personal.show end
 "#hid*" smatch when morph.personal.hide end
 "#vie*" smatch when morph.personal.view end
 "#sta*" smatch when morph.status end
 "#con*" smatch when morph.auto.connect end
 "#dis*" smatch when morph.auto.disconnect end
 "#sea*" smatch when morph.repository.search end
 "#put*" smatch when morph.repository.put end
 "#get*" smatch when morph.repository.get end
 "#set*" smatch when morph.repository.set end
 "#rem*" smatch when morph.repository.remove end
 "#off*" smatch when morph.share.offer end
 "#acc*" smatch when morph.share.accept end
 default pop        morph.personal.change end
endcase 
then
;
.
c
q