@program ProtoArchive.MUF
1 10000 d
i
( (C) 2000-2003 Alynna Trypnotk - alynna@animaltracks.net
  Release terms: GNU GPL v2
  http://www.gnu.org/copyleft/gpl.html
  Just tell me where you got me, where your using this program (host/port)
  and distribute your changes under the same terms as you got them [GNU GPL v2] )
( Commands:
  BEGIN     script    version                                    - Begin a script
  OBJECT    #         flags     loc       link      name         - Define new object
  PROP      #         type      prop:value                       - Set a property
  CODE      #                                                    - Wipe and insert code into program
  .                                                              - Exit from program insert mode
  END       script    version                                    - End a script
)
$author Alynna
$version 1.1
$def verbose prog "?" flag?
$def pubtell prog "J" flag?
$def }tell }cat pubtell if me @ #-1 rot ansi_notify_except else me @ swap ansi_notify then
$def }otell }cat me @ #-1 rot ansi_notify_except 
$def l10 1 array_make array_interpret "          " strcat 9 strcut pop " " strcat
$def lowver 1.0
$def highver 1.9
$def autoconfirm me @ "_stupid" getprop
lvar param
lvar ptarget
lvar options
lvar objects
lvar props

: setobj[ int:target str:prop value -- ]
me @ { "/~arc/obj/" target @ "/" prop @ }cat value @ setprop
;

: getobj[ int:target str:prop -- value ]
me @ { "/~arc/obj/" target @ "/" prop @ }cat getprop
;

: findmlevel[ str:flags -- int:level ]
flags @ case
 "1" instr when 1 end
 "2" instr when 2 end
 "3" instr when 3 end
 "4" instr when 4 end
 "5" instr when 5 end
 "6" instr when 6 end
 "7" instr when 7 end
 "8" instr when 8 end
 "9" instr when 9 end
 default 0 end
endcase
;

: setobjprop[ int:target str:prop value -- ]
me @ { "/~arc/obj/" target @ "/props/" prop @ }cat value @ setprop
;

: getobjprop[ int:target str:prop -- value ]
me @ { "/~arc/obj/" target @ "/props/" prop @ }cat getprop
;

: dblookup[ dbref:target -- mindnumbingly depressed, its great ]
target @ #-1 dbcmp if 0 exit then
target @ "$nothing" match dbcmp if -1 exit then
target @ "$nil" match dbcmp if -1 exit then
objects @ target @ array_findval array_explode not if 0 else swap pop then
;

: flags-nobits[ dbref:target -- str:flags ]
target @ unparseobj "" target @ name subst "" target @ int intostr subst "" "(#" subst "" ")" subst ":" split pop
"" "M" subst "" "W" subst "" "1" subst "" "2" subst "" "3" subst "" "4" subst "" "5" subst
target @ thing? if "T" swap strcat then
;

: flags-mlevel[ dbref:target -- str:flags ]
target @ unparseobj "" target @ name subst "" target @ int intostr subst "" "(#" subst "" ")" subst ":" split pop
"" "M" subst "" "W" subst "" "1" subst "" "2" subst "" "3" subst "" "4" subst "" "5" subst
target @ mlevel intostr strcat
target @ thing? if "T" swap strcat then
;

: propconv[ dbref:target str:prop -- Hi, its Mr. Zoo! ]
var item
var value
var curdir

prop @ "/" "//" subst prop !
prop @ "/" smatch if { }array props ! then
target @ prop @ array_get_propvals foreach value ! item !
 value @ case
  int?    when { "PROP" l10 target @ dblookup l10 "INT" l10 { prop @ "/" item @ }cat "/" "//" subst ":" value @ intostr }cat end
  float?  when { "PROP" l10 target @ dblookup l10 "FLT" l10 { prop @ "/" item @ }cat "/" "//" subst ":" value @ ftostrc }cat end
  string? when { "PROP" l10 target @ dblookup l10 "STR" l10 { prop @ "/" item @ }cat "/" "//" subst ":" value @ }cat end
  dbref?  when { "PROP" l10 target @ dblookup l10 "REF" l10 { prop @ "/" item @ }cat "/" "//" subst ":#" value @ int intostr }cat end
  default "" end
 endcase
 dup if props @ array_appenditem props ! else pop then 
repeat
target @ prop @ array_get_propdirs foreach curdir ! pop
 target @ { prop @ "/" curdir @ }cat "/" "//" subst propconv
repeat
;
 
: env_contents_array[ dbref:target -- array:contents ]
( fast search for all objects in this environment )
var cur
{ }array var! objarr
target @ player? if
 target @ "*" "" find_array
else
target @ "~arc/liberate-tutame" 1 setprop
2 dbtop int 1 - 1 for dbref cur ! 
 cur @ "~arc/liberate-tutame" envprop swap pop if cur @ objarr @ array_appenditem objarr ! then
repeat 
target @ "~arc/liberate-tutame" 0 setprop
objarr @
then
;

: filter[ arr:objs -- arr:tmpobjs ]
var item
var value
objs @ var! tmpobjs
( if NOTHING specified, dont archive things. )
options @ toupper "NOTHING" instr if 
 objs @ foreach value ! pop
  value @ thing? if 
   tmpobjs @ value @ array_findval array_explode dup if pop swap pop tmpobjs @ swap array_delitem tmpobjs ! else pop then
  then
 repeat
then
( program_getlines is broken, so assume noprog )
( options @ toupper "NOPROG" instr if )
 objs @ foreach value ! item ! 
  value @ program? if 
   tmpobjs @ value @ array_findval array_explode dup if pop swap pop tmpobjs @ swap array_delitem tmpobjs ! else pop then
  then
 repeat
( then )
( Dont archive players )
 objs @ foreach value ! item ! 
  value @ player? if 
   tmpobjs @ value @ array_findval array_explode dup if pop swap pop tmpobjs @ swap array_delitem tmpobjs ! else pop then
  then
 repeat
( Or anything they are holding )
 objs @ foreach value ! item ! 
  value @ location player? if 
   tmpobjs @ value @ array_findval array_explode dup if pop swap pop tmpobjs @ swap array_delitem tmpobjs ! else pop then
  then
 repeat
( Return cleaned array )
tmpobjs @
;

: extrude[ str:parameter int:position -- str:result ]
parameter @ position @ 1 - 10 * strcut swap pop 10 strcut pop strip
;

: extrude2end[ str:parameter int:position -- str:result ]
parameter @ position @ 1 - 10 * strcut swap pop strip
;

: targetlist
var target
{ "Gathering all targets..." }tell
ptarget @ env_contents_array filter objects !
me @ "~arc/objects" objects @ array_put_reflist
objects @ foreach swap pop ansi_unparseobj me @ swap ansi_notify repeat
{ objects @ array_count " objects found." }tell
;

: purge_env
var target
{ "Gathering all targets..." }tell
ptarget @ env_contents_array filter objects !
objects @ foreach target ! pop
  target @ ok? if 
   me @ target @ controls if
    { "Destroying " target @ ansi_unparseobj }tell
    target @ recycle
   else
    { "Skipping out of control action " target @ ansi_unparseobj }tell
   then
  then
repeat
{ objects @ array_count " objects found." }tell
;

: backup
var target
var tgtnum
var curtype
var count

{ "Gathering all targets..." }tell
ptarget @ env_contents_array filter objects !
me @ "~arc/objects" objects @ array_put_reflist
{ "@restore" }tell
{ "BEGIN     Foxscript 1.0" }tell
objects @ foreach target ! tgtnum !
target @ ok? if me @ target @ controls if
 target @ case
  player? when 
   { "OBJECT" l10 
     tgtnum @ l10 
     target @ flags-nobits l10 
     target @ location dblookup l10 
     target @ getlink dblookup l10 
     target @ name }tell
  end
  room? when 
   { "OBJECT" l10 
     tgtnum @ l10 
     target @ flags-nobits l10 
     target @ location dblookup l10 
     target @ getlink dblookup l10 
     target @ name }tell
  end
  exit? when 
   { "OBJECT" l10 
      tgtnum @ l10 
      target @ flags-nobits l10 
      target @ location dblookup l10 
      target @ getlink dblookup l10 
      target @ name }tell
  end
  thing? when
   { "OBJECT" l10 
     tgtnum @ l10 
     target @ flags-nobits 
     l10 target @ location dblookup l10 
     target @ getlink dblookup l10 
     target @ name }tell
  end
(
  program? when
   { "OBJECT" l10 tgtnum @ l10 target @ flags-mlevel l10 target @ location dblookup l10                         0 l10 target @ name }tell
   { "CODE      " tgtnum @ }tell
   target @ 0 999999 program_getlines me @ 1 array_make array_notify
    me @ "." notify
   else
    pop
   then
  end
)
endcase
target @ "/" propconv
props @ me @ 1 array_make array_notify
then then
repeat
{ "END       Foxscript 1.0" }tell
{ objects @ array_count " objects found." }tell
;

: restore
var temp
var line
var cmd
var vtarget
var vlocation
var vlink
var vitem
var vvalue
var vflags
var vtype
var vscript
var vname
var ver
var target
var nothing
var nothingdependancy
var cur

-1 var! defparent
0 var! neednothing
0 var! highest
0 var! done
{ }array var! finishscript

me @ "/~arc/obj/" remove_prop
{ "Stage 1; furball parse: Ready to read foxscript, please upload now." }tell
begin
read line !
line @ 1 extrude cmd !
cmd @ case
 "BEGIN" smatch when
  line @ 2 extrude vscript !  line @ 3 extrude strtof ver !
  vscript @ "Foxscript" smatch not if { "Incompatible script." }tell exit then
  ver @ lowver < if { "Version too low, found " ver @ " need " lowver "." }tell exit then
  ver @ highver > if { "Version too high, found " ver @ " need " highver "." }tell exit then
  { "Begin processing " vscript @ " " ver @ "..." }tell
 end
 "OBJECT" smatch when
  line @ 2 extrude     atoi vtarget !
  line @ 3 extrude          vflags !
  line @ 4 extrude     atoi vlocation !
  line @ 5 extrude     atoi vlink !
  line @ 6 extrude2end      vname !
  vflags @ case
   "E" instr when vtarget @ "type" "EXIT"      setobj end
   "T" instr when vtarget @ "type" "THING"     setobj end
   "R" instr when vtarget @ "type" "ROOM"      setobj end
   "F" instr when vtarget @ "type" "PROGRAM"   setobj end
  endcase
  vtarget @ "flags" vflags @    setobj
  vtarget @ "loc"   vlocation @ setobj
  vtarget @ "link"  vlink @     setobj
  vtarget @ "name"  vname @     setobj
  me @ "/~arc/obj/high" getprop vtarget @ < if 
   me @ "/~arc/obj/high" vtarget @ setprop
  then
 end
 "PROP" smatch when
  line @ 2 extrude     atoi vtarget !
  line @ 3 extrude          vtype !
  line @ 4 extrude2end      ":" split vvalue ! vitem !
  vtype @ case
   "INT" instr when vvalue @ atoi                    vvalue ! end
   "FLT" instr when vvalue @ strtof                  vvalue ! end
   "REF" instr when vvalue @ "" "#" subst atoi dbref vvalue ! end
   "STR" instr when                                           end
  default { "warning(obj " vtarget @ "): unknown datatype is defaulting to STRING" }tell end
  endcase
  vtarget @ vitem @ vvalue @ setobjprop
 end
 "END" smatch when
  { "End processing " vscript @ " " ver @ "..." }tell
  1 done !
 end
endcase
done @ until 
{ "Stage 2; furball scan: Script sanity check" }tell
"$nothing" match nothing !
nothing @ not if
 { "warning(precompile): $nothing does not match an object, a $nothing program will be created for MPI actions if needed" }tell
 1 neednothing !
else
 { "notice(precompile): $nothing appears to be " nothing @ unparseobj }tell
 1 neednothing !
then
me @ me @ location controls not if
 { "error(obj " target @ "): current location not controlled by you, would not be able to make default parent.  Please go elsewhere." }tell
 { "make: error 3" }tell
 3 exit
then
0 me @ "/~arc/obj/high" getprop 1 for target !
( general checks )
target @ "name" getobj name-ok? not if
 { "error(obj " target @ "): name '" target @ "name" getobj "' is not ok" }tell
 { "make: error 1" }tell
 1 exit
then
target @ "type" getobj 1 array_make array_interpret "{EXIT|PROGRAM|ROOM|THING}" smatch not if
 { "error(obj " target @ "): object '" target @ "name" getobj "' is of unknown type " target @ "type" getobj }tell
 { "make: error 2" }tell
 2 exit
then
target @ "flags" getobj "Q" instr if 
 { "warning(obj " target @ "): object '" target @ "name" getobj "' has unsettable flag Q, moving to finishing script" }tell
 target @ "flags" over over getobj "" "Q" subst setobj
 target @ "finish" over over getobj dup not if pop "@set #REF#=Q;" else "@set #REF#=Q;" strcat then setobj
then
target @ "flags" getobj "X" instr if 
 { "warning(obj " target @ "): object '" target @ "name" getobj "' has unsettable flag X, moving to finishing script" }tell
 target @ "flags" over over getobj "" "X" subst setobj
 target @ "finish" over over getobj dup not if pop "@set #REF#=X;" else "@set #REF#=X;" strcat then setobj
then
target @ "flags" getobj "+" instr if 
 { "warning(obj " target @ "): cowardly refusing to export MUFCOUNT from '" target @ "name" getobj "'" }tell
 target @ "flags" over over getobj "" "+" subst setobj
then
target @ "flags" getobj "!" instr if 
 { "warning(obj " target @ "): cowardly refusing to export LOGWALL from '" target @ "name" getobj "'" }tell
 target @ "flags" over over getobj "" "!" subst setobj
then
target @ "flags" getobj "*" instr if 
 { "warning(obj " target @ "): cowardly refusing to export PROTECT from '" target @ "name" getobj "'" }tell
 target @ "flags" over over getobj "" "*" subst setobj
then
target @ "flags" getobj "#" instr if 
 { "warning(obj " target @ "): cowardly refusing to export HIDDEN from '" target @ "name" getobj "'" }tell
 target @ "flags" over over getobj "" "#" subst setobj
then
target @ "flags" getobj findmlevel dup temp ! if 
 { "warning(obj " target @ "): object '" target @ "name" getobj "' has mlevel specified, moving to finishing script" }tell
 target @ "flags" over over getobj "" temp @ intostr subst setobj
 target @ "finish" over over getobj dup not if pop { "@set #REF#=" temp @ ";" }cat else { "@set #REF#=" temp @ ";" }cat strcat then setobj
then
( specific type checks )
target @ "type" getobj case
 "EXIT" smatch when
  target @ "loc" getobj not if
   { "warning(obj " target @ "): exits location does not exist, will be attached to the default parent" }tell
  then
  target @ "link" getobj -1 = if
   { "notice(obj " target @ "): object appears to link to $nothing, possible MPI action" }tell
   nothingdependancy ++
  then
  target @ "link" getobj 0 = if
   { "warning(obj " target @ "): cowardly refusing to make an exit that has nothing to link to" }tell
   me @ { "/~arc/obj/" target @ "/" }cat remove_prop
  then
 end
 "PROGRAM" smatch when
  target @ "link" getobj if
   { "warning(obj " target @ "): ignoring script request to link a program to something" }tell
   target @ "link" 0 setobj
  then
  target @ "loc" getobj not if
   { "warning(obj " target @ "): program location does not exist, will be placed in the default parent" }tell
  then
 end
 "ROOM" smatch when
  defparent @ -1 = if target @ "loc" getobj not if
   { "notice(obj " target @ "): first room without a location found, is being set as the default parent" }tell
   { "notice(obj " target @ "): room is " target @ "name" getobj }tell
   target @ defparent !
  then then
  target @ defparent @ = not if target @ "loc" getobj not if
   { "warning(obj " target @ "): room doesnt belong anywhere, will be dropped in the default parent" }tell
  then then
 end
 "THING" smatch when
  target @ "link" getobj not if
   { "warning(obj " target @ "): object's home not in the known grid, will be HOMEd to default parent" }tell
  then
  target @ "loc" getobj not if
   { "warning(obj " target @ "): object location does not exist, will be placed in the default parent" }tell
  then
 end
endcase
repeat
{ "Stage 3; furball processing: Ready to recreate objects" }tell
{ "Enter YES to confirm, anything else to abort" }tell
autoconfirm not if read "YES" smatch not if { "Aborted" }tell exit then then
{ "Begin object creation..." }tell
{ "Default parent (" defparent @ ") being created..." }tell
me @ location defparent @ "name" getobj newroom cur ! 
defparent @ "object" cur @ setobj
{ "Stage 4; furball unravel: Creating all rooms..." }tell
0 me @ "/~arc/obj/high" getprop 1 for target !
 me @ { "/~arc/obj/" target @ "/" }cat propdir? if
 0 cur !
 target @ "type" getobj "ROOM" smatch if
 verbose if { "Creating " target @ "type" getobj " " target @ ": " target @ "name" getobj }tell then
  target @ defparent @ = not if
   defparent @ "object" getobj target @ "name" getobj newroom cur !
  then
  cur @ if target @ "object" cur @ setobj then
  verbose if { "Created " target @ "object" getobj ansi_unparseobj }tell then
  then
 then
repeat
{ "Stage 5; furball unravel: Creating all things..." }tell
0 me @ "/~arc/obj/high" getprop 1 for target !
 me @ { "/~arc/obj/" target @ "/" }cat propdir? if
 0 cur !
 target @ "type" getobj "THING" smatch if
 verbose if { "Creating " target @ "type" getobj " " target @ ": " target @ "name" getobj }tell then
  target @ "loc" getobj "object" getobj target @ "name" getobj newobject cur !
  cur @ if target @ "object" cur @ setobj then
  verbose if { "Created " target @ "object" getobj ansi_unparseobj }tell then
  then
 then
repeat
{ "Stage 6; furball unravel: Creating all exits..." }tell
0 me @ "/~arc/obj/high" getprop 1 for target !
 me @ { "/~arc/obj/" target @ "/" }cat propdir? if
 0 cur !
 target @ "type" getobj "EXIT" smatch if
 verbose if { "Creating " target @ "type" getobj " " target @ ": " target @ "name" getobj }tell then
  target @ "loc" getobj "object" getobj target @ "name" getobj newexit cur !
  cur @ if target @ "object" cur @ setobj then
  verbose if { "Created " target @ "object" getobj ansi_unparseobj }tell then
  then
 then
repeat
{ "Stage 7; furball unravel: Creating all programs..." }tell
0 me @ "/~arc/obj/high" getprop 1 for target !
 me @ { "/~arc/obj/" target @ "/" }cat propdir? if
 0 cur !
 target @ "type" getobj "PROGRAM" smatch if
 verbose if { "Creating " target @ "type" getobj " " target @ ": " target @ "name" getobj }tell then
  target @ "loc" getobj "object" getobj target @ "name" getobj newprogram cur !
  cur @ if target @ "object" cur @ setobj then
  verbose if { "Created " target @ "object" getobj ansi_unparseobj }tell then
  then
 then
repeat
{ "Stage 8; furball tailbrush: Moving objects to their proper locations..." }tell
0 me @ "/~arc/obj/high" getprop 1 for target !
 me @ { "/~arc/obj/" target @ "/" }cat propdir? if
  target @ "loc" getobj dup temp ! if
   verbose if { "Moving " target @ "object" getobj ansi_unparseobj " to " temp @ "object" getobj ansi_unparseobj }tell then
   target @ "object" getobj temp @ "object" getobj moveto 
  then  
 then
repeat
{ "Stage 9; furball tailbrush: Linking objects together..." }tell
0 me @ "/~arc/obj/high" getprop 1 for target !
 me @ { "/~arc/obj/" target @ "/" }cat propdir? if
  target @ "link" getobj dup temp ! if
   temp @ -1 = if
    nothing @ if
     verbose if { "Linking " target @ "object" getobj ansi_unparseobj " to " nothing @ ansi_unparseobj }tell then
     target @ "object" getobj nothing @ setlink
    else
     verbose if { "Creating $nothing..." }tell then
     "cmd-devnull.muf" newprogram nothing !
     #0 "/_reg/nothing" nothing @ setprop
     nothing @ 1 { ": main ;" }array program_insertlines
     nothing @ 0 compile
     target @ "object" getobj nothing @ setlink
    then
   else
    verbose if { "Linking " target @ "object" getobj ansi_unparseobj " to " temp @ "object" getobj ansi_unparseobj }tell then
    target @ "object" getobj temp @ "object" getobj setlink
   then
  then       
 then
repeat
{ "Stage 10; furball setting: Setting flags..." }tell
0 me @ "/~arc/obj/high" getprop 1 for target !
 me @ { "/~arc/obj/" target @ "/" }cat propdir? if
  target @ "flags" getobj dup temp ! if
   1 temp @ strlen 1 for temp @ swap 1 midstr cur !
    "ETPFR" cur @ instr not if
     cur @ "PARENT" "%" subst "MOBILE" "?" subst cur !
     verbose if { "Setting " cur @ " bit on " target @ "object" getobj ansi_unparseobj }tell then
     target @ "object" getobj cur @ set
    then
   repeat
  then
 then
repeat
{ "Stage 11; furball styling: Copying props..." }tell
0 me @ "/~arc/obj/high" getprop 1 for target !
 me @ { "/~arc/obj/" target @ "/" }cat propdir? if
  me @ { "/~arc/obj/" target @ "/props/" }cat propdir? if
   verbose if { "Copying props to " target @ "object" getobj ansi_unparseobj }tell then
   me @ { "/~arc/obj/" target @ "/props/" }cat 
   target @ "object" getobj "/" 1 copyprops pop
  then
 then
repeat
{ "Stage 12; furball drying: Preparing finishing script..." }tell
0 me @ "/~arc/obj/high" getprop 1 for target !
 me @ { "/~arc/obj/" target @ "/" }cat propdir? if
  target @ "finish" getobj dup temp ! if
   temp @ temp @ strlen 1 - strcut pop temp !
   temp @ "#" target @ "object" getobj int intostr strcat "#REF#" subst
   ";" explode_array finishscript @ array_union finishscript !
  then
 then
repeat
{ "---- Notice, cut and paste these commands in to finish ----" }tell
finishscript @ dup if me @ 1 array_make array_notify else pop then
{ "-----------------------------------------------------------" }tell
{ "Script finished, returncode 0 (Successful)" }tell
;

: undo
var target
{ "DANGER WILL ROBINSON: This will remove everything you last restored!" }tell
{ "Type YES to confirm this action." }tell
autoconfirm not if read "YES" smatch not if { "Aborted" }tell exit then then
0 me @ "/~arc/obj/high" getprop 1 for target !
 me @ { "/~arc/obj/" target @ "/" }cat propdir? if
  target @ "object" getobj ok? if 
   me @ target @ "object" getobj controls if
    { "Destroying " target @ "object" getobj ansi_unparseobj }tell
    target @ "object" getobj recycle
   else
    { "Skipping out of control action " target @ "object" getobj ansi_unparseobj }tell
   then
  then
 then
repeat
{ "Done." }tell
;

: help
{
"Alynna's Proto @backup/@restore v1.0"
" "
" @backup <obj>=<options>       - Backup something and everything in its environment."
" @restore                      - Restore something from a generated foxscript."
" "
"Foxscript commands:"
" BEGIN     script    version                                    - Begin a script"
" OBJECT    #         flags     loc       link      name         - Define new object"
" PROP      #         type      prop:value                       - Set a property"
" CODE      #                                                    - Wipe and insert code into program"
" .                                                              - Exit from program insert mode"
" END       script    version                                    - End a script"
}array me @ 1 array_make array_notify
;

: main
param !
command @ "{@backup|@targetlist|@purgeenv}" smatch if
 param @ not if help exit then
 param @ "=" instr not if
  param @ match ptarget !
  ptarget @ int 0 < if { "Target not found." }tell exit then
  "" options !
 else
  param @ "=" split options ! ptarget !
  ptarget @ match ptarget !
  ptarget @ int 0 < if { "Target not found." }tell exit then
 then
then
command @ tolower case
 "@backup" smatch when backup end
 "@restore" smatch when restore end
 "@undo" smatch when undo end
 "@purgeenv" smatch when purge_env end
 "@targetlist" smatch when targetlist end
 default help end
endcase
;
.
c
q