@q
@program vsys-@vcreate
1 99999 d
i
( vsys-@vcreate v1.0 Jessy @ FurryMUCK 4/00
Part of the vsys vehicle system, this program handles creation and
modification of vehicles.
INSTALLATION:
Port the program, set it Wizard and -- optionally -- Link_OK. Create
a global exit with a name such as '@vcreate', and link it to the
program. Type '<action name> #install'.
Vsys-@vcreate requires lib-vsys and lib-reflist. See the header comment
of lib-vsys for more complete documentation on the vehicle system.
USE:
@vcreate <vehicle> ........... Create a vehicle named <vehicle>
@vcreate #keys ............... Create a set of keys for vehicle [A]
@vcreate #!keys .............. Recycle all existing keys to vehicle [O]
@vcreate #add ................ List available packages [A]
@vcreate #add <package> ...... Add <package> to current vehicle [A]
@vcreate #remove <package> ... Remove <package> from current vehicle [A]
@vcreate #packages ........... List available packages
@vcreate #package <name> ..... Store data for package <name> [W]
@vcreate #!package <name> .... Delete package <name> and its data [W]
@vcreate #prototypes ......... List available prototypes
@vcreate #prototype <obj> .... Store data needed to reproduce <obj> [W]
@vcreate #!prototype <name> .. Delete prototype <name> and its data [W]
@vcreate #cost <type|pack> ... Set cost for <prototype|package> [W]
@vcreate #money <string> ..... Set currency [W]
@vcreate #strict ............. Allow only prototyped vehicles [W]
@vcreate #!strict ............ Allow any type vehicles [W]
Vsys-@vcreate may be freely ported. Please comment any changes.
)
$define Tell me @ swap notify $enddef
$include $lib/vsys
$include $lib/reflist
lvar lib
lvar ourArg
lvar ourRoomCounter
lvar ourExitCounter
lvar ourExit
lvar ourName
lvar ourPlayer
lvar ourRoom
lvar ourString
lvar ourVehicle
: DoInit ( -- ) (* ensure program is W and registerd *)
LibInit
prog "W" flag? if
#0 "_reg/vsys/vcreate-prog" prog setprop
#0 "_reg/vsys/vcreate-com" trig setprop
else
prog name " must be set Wizard." strcat me @ swap notify
pid kill
then
;
: DoInstall ( -- ) (* doesn't really do anything *)
DoInit
">> $prog installed." prog name "$prog" subst Tell
;
: DoHelp ( -- ) (* show help screen *)
" " Tell
prog name " (#" strcat prog intostr strcat ")" strcat Tell " " Tell
"This program handles creation and modification of vehicles to be "
"used with the vsys vehicle system." strcat Tell " " Tell
" $com <vehicle> ............. Create a vehicle named <vehicle>"
command @ "$com" subst Tell
" $com #keys ................. Create a set of keys for vehicle (A)"
command @ "$com" subst Tell
" $com #!keys ................ Recycle all existing keys to vehicle (O)"
command @ "$com" subst Tell
" $com #add .................. List available packages (A)"
command @ "$com" subst Tell
" $com #add <package> ........ Add <package> to vehicle (A)"
command @ "$com" subst Tell
" $com #remove <package> ..... Remove <package> from vehicle (A)"
command @ "$com" subst Tell
" $com #packages ............. Store data needed to reproduce <obj> (W)"
command @ "$com" subst Tell
" $com #package <name> ....... Store data needed to reproduce
<obj> (W)"
command @ "$com" subst Tell
" $com #!package <name> ...... Delete package <name> and its data (W)"
command @ "$com" subst Tell
" $com #prototypes ........... List available prototypes"
command @ "$com" subst Tell
" $com #prototype <obj> ...... Store data needed to reproduce <obj> (W)"
command @ "$com" subst Tell
" $com #!prototype <name> .... Delete prototype <name> and its data (W)"
command @ "$com" subst Tell
" $com #cost <type|pack> ..... Set cost for <prototype|package> (W)"
command @ "$com" subst Tell
" $com #defined .............. List available prototypes and packages"
command @ "$com" subst Tell
" $com #defined prototypes ... List available prototypes"
command @ "$com" subst Tell
" $com #defined packages ..... List available packages"
command @ "$com" subst Tell
" $com #money <string> ....... Set currency (W)"
command @ "$com" subst Tell
" $com #strict ............... Allow only prototyped vehicles (W)"
command @ "$com" subst Tell
" $com #!strict .............. Allow any type vehicles (W)"
command @ "$com" subst Tell
" " Tell
"The code following each command #option lists the permission level "
"required: W = Wizard, O = Wizard or Owner, A = Wizard, Owner, or Admin"
"istrator." strcat strcat Tell " " Tell
"For complete information on the vehicle system, type '@view $lib/vsys' "
"(long)." strcat Tell
;
: DoPad ( s i -- ) (* pad s to i chars *)
" "
rot swap strcat swap strcut pop
;
: DoMoney ( -- ) (* set money system *)
ourArg @ if
ourArg @ "argo" smatch if
lib @ "@v/money" "argo" setprop
">> Set. Vehicle charges are now controlled by the Argo system."
Tell
else
ourArg @ match
dup #-1 dbcmp if
">> I don't see that here." Tell exit
then
dup #-2 dbcmp if
">> Ambiguous. I don't know which one you mean!" Tell exit
then
dup #-3 dbcmp if
">> I don't see that here." Tell exit
then
lib @ "@v/money" 3 pick setprop
">> Set. Vehicle charges are now controlled by $prog."
swap name "$prog" subst Tell
then
else
lib @ "@v/money" remove_prop
">> Money system cleared." Tell
">> Now using default (server pennies)." Tell
then
;
: DoMakeKeys (* create a set of keys for current vehicle *)
me @ "Keys" newobject
dup "@v/key" ourVehicle @ "@v/key" getpropstr setprop
"A set of keys to the $vehicle."
ourVehicle @ name "$vehicle" subst setdesc
;
: DoCloneDir ( d s -- ) (* copy dir s from library to root of obj d *)
lib @ swap nextprop
begin
dup while
lib @ over propdir? if
lib @ over 4 pick over
dup "/" rinstr strcut swap pop
CopyDir
else
over over
dup "/" rinstr strcut swap pop
lib @ 4 pick getprop setprop
then
lib @ swap nextprop
repeat
pop pop
;
: DoListTypes ( -- ) (* list available prototypes *)
0 ourRoomCounter !
">> Available Prototypes:" Tell
lib @ "@v/types/" nextprop
begin
dup while
ourString !
ourRoomCounter @ 1 + ourRoomCounter !
ourRoomCounter @ 2 % if
" "
then
ourRoomCounter @ intostr ") " strcat 4 DoPad strcat
ourString @ "" "@v/types/" subst strcat " " strcat
lib @ ourString @ "/cost" strcat getpropstr dup if
"(" swap strcat ")" strcat strcat
else
pop
then
ourRoomCounter @ 2 % if
32 DoPad
else
Tell
then
lib @ ourString @ nextprop
repeat
pop
ourRoomCounter @ 2 % if Tell then
;
: DoAddPrototype ( -- )(* record data needed to copy vehicle ourArg *)
ourArg @ not if (* list available if none specified *)
DoListTypes exit
then
me @ "W" flag? not if (* check permission *)
">> Permission denied." Tell exit
then
(* find vehicle to copy *)
ourArg @ if
ourArg @ match
dup #-1 dbcmp over #-3 dbcmp or if
">> Vehicle to prototype not found." Tell pop exit
then
dup #-2 dbcmp if
">> Ambiguous. I don't know which object you mean!" Tell exit
then
ourVehicle !
then
ourVehicle @ GetEnvForVeh dup if
ourRoom !
else
">> $object is not a vsys vehicle."
ourVehicle @ "$object" subst Tell pop exit
then
(* make prop string where we'll store data on lib *)
"@v/types/$type/" ourVehicle @ name "$type" subst ourString !
(* get confirmation if we're overwriting *)
lib @ ourString @ nextprop if
">> A prototype called $type already exists."
ourVehicle @ name CapAll "$type" subst Tell
">> Do you want to overwrite it? (y/n)" Tell
ReadYesNo not if
">> Aborted." Tell exit
then
then
(* clear any old data *)
lib @ ourString @ RemoveDir
(* initialize counters *)
"0" ourExitCounter !
"0" ourRoomCounter !
(* store vehicle env room's dbref *)
lib @ ourString @ "tmp/rms/0" strcat ourRoom @ setprop
lib @ ourString @ "tmp/rms" strcat ourRoom @ REF-add
(* copy vehicle object's props *)
ourString @ "vobj/" strcat ourString !
ourVehicle @ "/" nextprop
begin
dup while
ourVehicle @ over propdir? if
ourVehicle @ over lib @ ourString @ "props/" strcat
5 pick strcat CopyDir
else
lib @ ourString @ "props/" strcat 3 pick strcat
ourVehicle @ 4 pick getprop setprop
then
ourVehicle @ swap nextprop
repeat
pop
(* these are vehicle specific; remove *)
lib @ ourString @ "props/@v/env" strcat remove_prop
lib @ ourString @ "props/@v/key" strcat remove_prop
(* copy vehicle object's flags *)
lib @ ourString @ "flags" strcat ourVehicle @ GetFlagList setprop
(* copy vehicle env room props *)
"@v/types/$type/venv/" ourVehicle @ name "$type" subst ourString !
ourRoom @ "/" nextprop
begin
dup while
ourRoom @ over propdir? if
ourRoom @ over lib @ ourString @ "props/" strcat
5 pick strcat CopyDir
else
lib @ ourString @ "props/" strcat 3 pick strcat
ourRoom @ 4 pick getprop setprop
then
ourRoom @ swap nextprop
repeat
pop
lib @ "@v/types/$type/tmp/rms" ourVehicle @ name "$type" subst
over over ourRoom @ REF-add "/0" strcat ourRoom @ setprop
(* these are vehicle specific; remove *)
lib @ ourString @ "props/@v/id" strcat remove_prop
lib @ ourString @ "props/@v/key" strcat remove_prop
(* copy vehicle env room flags *)
lib @ ourString @ "flags" strcat ourVehicle @ GetFlagList setprop
(* copy vehicle rooms' props and flags *)
"@v/types/$type/rooms/$num/"
ourVehicle @ name "$type" subst ourString !
ourRoom @ contents
begin
dup while
dup room? if
dup ourRoom !
ourRoomCounter @ atoi 1 + intostr ourRoomCounter !
lib @ "@v/types/$type/tmp/rms/$num"
ourVehicle @ name "$type" subst
ourRoomCounter @ "$num" subst ourRoom @ setprop
lib @ "@v/types/$type/tmp/rms"
ourVehicle @ name "$type" subst ourRoom @ REF-add
lib @ ourString @ ourRoomCounter @ "$num" subst
"name" strcat ourRoom @ name setprop
lib @ ourString @ ourRoomCounter @ "$num" subst
"flags" strcat ourRoom @ GetFlagList setprop
ourRoom @ "/" nextprop
begin
dup while
ourRoom @ over propdir? if
ourRoom @ over lib @ ourString @ "props/" strcat
ourRoomCounter @ "$num" subst
5 pick strcat CopyDir
else
lib @ ourString @ "props/" strcat
ourRoomCounter @ "$num" subst 3 pick strcat
ourRoom @ 4 pick getprop setprop
then
ourRoom @ swap nextprop
repeat
pop
then
next
repeat
pop
(* record exit data *)
"0" ourRoomCounter ! (* clear counters *)
"0" ourExitCounter !
(* put vehicle obj and all rooms on stack as a range *)
lib @ "@v/types/$type/tmp/rms"
ourVehicle @ name "$type" subst REF-allrefs
ourVehicle @ swap 1 +
begin (* begin scanning stack objects for exits *)
dup while
swap ourArg !
ourArg @ exits
begin (* begin recording data for one exit *)
dup while
dup ourExit !
"@v/types/$type/exits/$num/"
ourVehicle @ name "$type" subst
ourExitCounter @ "$num" subst ourString !
(* exit name *)
lib @ ourString @ "name" strcat ourExit @ name setprop
(* exit flags *)
lib @ ourString @ "flags" strcat ourExit @ GetFlagList setprop
(* exit source *)
ourExit @ location
dup ourVehicle @ dbcmp if
pop "vobj"
else
lib @ "@v/types/$type/tmp/rms/0"
ourVehicle @ name "$type" subst getprop over dbcmp if
pop "venv"
else
lib @ "@v/types/$type/tmp/rms" ourVehicle @ name "$type" subst
3 pick REF-inlist? if
"@v/types/$type/tmp/rms/1" ourVehicle @ name "$type" subst
begin
dup while
lib @ over getprop
3 pick dbcmp if
swap pop
dup "/" rinstr strcut
"rm/" swap strcat swap
break
then
lib @ swap nextprop
repeat
pop
then then then
lib @ ourString @ "source" strcat rot setprop
(* exit destination *)
ourExit @ getlink
dup ourVehicle @ dbcmp if
pop "vobj"
else
lib @ "@v/types/$type/tmp/rms/0"
ourVehicle @ name "$type" subst getprop over dbcmp if
pop "venv"
else
lib @ "@v/types/$type/tmp/rms" ourVehicle @ name "$type" subst
3 pick REF-inlist?
if
"@v/types/$type/tmp/rms/1" ourVehicle @ name "$type" subst
begin
dup while
lib @ over getprop
3 pick dbcmp if
swap pop
dup "/" rinstr strcut
"rm/" swap strcat swap
break
then
lib @ swap nextprop
repeat
pop
then then then
lib @ ourString @ "link" strcat rot setprop
(* exit props *)
ourExit @ "/" nextprop
begin
dup while
ourExit @ over propdir? if
ourExit @ over lib @ ourString @ "props/" strcat
5 pick strcat CopyDir
else
lib @ ourString @ "props/" strcat 3 pick strcat
ourExit @ 4 pick getprop setprop
then
ourExit @ swap nextprop
repeat
pop
ourExitCounter @ atoi 1 + intostr ourExitCounter !
next
repeat
pop
1 -
repeat
pop
(* remove temp data *)
lib @ "@v/types/$type/tmp/" ourVehicle @ name "$type" subst RemoveDir
">> Prototype defined." Tell
;
: DoDelPrototype ( -- ) (* remove a stored prototype *)
ourArg @ not if (* list available if none specified *)
DoListTypes exit
then
me @ "W" flag? not if (* check permission *)
">> Permission denied." Tell exit
then
(* get confirmation *)
lib @ "@v/types/$type/" ourArg @ strip "$type" subst over over
nextprop if
">> Please confirm:" Tell
">> You wish to delete all data for prototype $type? (y/n)"
ourArg @ CapAll "$type" subst Tell ReadYesNo if
RemoveDir (* remove prototype data *)
">> Prototype deleted." Tell
else
">> Aborted." Tell pop pop
then
else
">> Prototype not found." Tell pop pop
then
;
: DoCreatePrototype ( -- ) (* create vehicle from prototype data *)
(* find global vehicle env room; make env room for this vehicle *)
#0 "_reg/env/vehicle" getprop
ourString @ " Environment Room" strcat newroom ourRoom !
(* create vehicle object *)
me @ location ourString @ newobject ourVehicle !
ourVehicle @ "V" set
ourVehicle @ "@v/key" random intostr setprop (* set key *)
ourVehicle @ "@v/env" ourRoom @ setprop (* record env room *)
ourVehicle @ "@v/tmp/rm/0" ourRoom @ setprop (* store as tmp room *)
ourVehicle @ "@v/tmp/rms" ourRoom @ REF-add
"@v/types/$type/" ourVehicle @ name "$type" subst ourString !
(* copy vehicle object flags *)
ourVehicle @ lib @ ourString @ "vobj/flags" strcat getprop SetFlagList
(* copy vehicle object props *)
ourVehicle @ ourString @ "vobj/props/" strcat DoCloneDir
(* copy env room flags *)
ourRoom @ lib @ ourString @ "venv/flags" strcat getprop SetFlagList
(* copy env room props *)
ourRoom @ ourString @ "venv/props/" strcat DoCloneDir
(* create all rooms of vehicle *)
"1" ourRoomCounter !
begin (* begin room-reading loop *)
lib @ ourString @ "rooms/$num/" ourRoomCounter @ "$num" subst strcat
nextprop while
ourRoom @
lib @ ourString @ "rooms/$num/name"
ourRoomCounter @ "$num" subst strcat
getpropstr newroom (* create next room *)
dup
lib @ ourString @ "rooms/$num/flags"
ourRoomCounter @ "$num" subst strcat
getprop SetFlagList (* set flags *)
dup ourString @ "rooms/$num/props/"
ourRoomCounter @ "$num" subst strcat
DoCloneDir (* set props *)
ourVehicle @ "@v/tmp/rms" 3 pick REF-add (* record as tmp room *)
ourVehicle @ "@v/tmp/rm/" ourRoomCounter @ strcat rot setprop
ourRoomCounter @ atoi 1 + intostr ourRoomCounter !
repeat (* end room-reading loop *)
(* create all exits of vehicle *)
"0" ourExitCounter !
begin (* begin exit-reading loop *)
lib @ ourString @ "exits/$num/" ourExitCounter @ "$num" subst strcat
nextprop while
(* get source and name to make new exit *)
lib @ ourString @ "exits/$num/source"
ourExitCounter @ "$num" subst strcat getprop
dup dbref? if intostr "#" swap strcat then
dup "vobj" smatch if
pop ourVehicle @
else
dup "venv" smatch if
pop ourVehicle @ "@v/tmp/rm/0" getprop
else
dup "rm*" smatch if
ourVehicle @ "@v/tmp/rm/" rot
dup "/" rinstr strcut swap pop strcat
getprop
ourVehicle @ "@v/tmp/rms/" nextprop
begin
dup while
ourVehicle @ over getprop
dup string? if
"" "#" subst atoi dbref
then
3 pick
dup string? if
"" "#" subst atoi dbref
then
dbcmp if
dup "/" rinstr pop
ourVehicle @ "@v/tmp/rm/" rot strcat getprop
swap break
then
ourVehicle @ swap nextprop
repeat
pop
else
"" "#" subst atoi dbref
then then then
lib @ ourString @ "exits/$num/name"
ourExitCounter @ "$num" subst strcat getprop
newexit ourExit !
(* get link of new exit; set *)
lib @ ourString @ "exits/$num/link"
ourExitCounter @ "$num" subst strcat getprop
dup dbref? if intostr "#" swap strcat then
dup "vobj" smatch if
pop ourVehicle @
else
dup "venv" smatch if
pop ourVehicle @ "@v/tmp/rm/0" getprop
else
dup "rm*" smatch if
ourVehicle @ "@v/tmp/rm/" rot
dup "/" rinstr strcut swap pop strcat
getprop
ourVehicle @ "@v/tmp/rms/" nextprop
begin
dup while
ourVehicle @ over getprop
dup string? if
"" "#" subst atoi dbref
then
3 pick
dup string? if
"" "#" subst atoi dbref
then
dbcmp if
dup "/" rinstr pop
ourVehicle @ "@v/tmp/rm/" rot strcat getprop
swap break
then
ourVehicle @ swap nextprop
repeat
pop
else
"" "#" subst atoi dbref
then then then
dup string? if
"" "#" subst atoi
dup not if
pop #-1
else
dbref
then
then
ourExit @ swap setlink
(* set exit flags *)
ourExit @ lib @ ourString @ "exits/$num/flags" strcat
ourExitCounter @ "$num" subst getpropstr SetFlagList
(* set exit props *)
ourExit @ ourString @ "exits/$num/props/" strcat
ourExitCounter @ "$num" subst DoCloneDir
ourExitCounter @ atoi 1 + intostr ourExitCounter !
repeat (* end exit-reading loop *)
random intostr (* set security data *)
ourRoom @ "@v/key" 3 pick setprop
ourVehicle @ "@v/key" rot setprop
ourRoom @ "@v/id" ourVehicle @ setprop
ourVehicle @ "@v/env" ourRoom @ setprop
ourVehicle @ "@v/type" ourVehicle @ name setprop
DoMakeKeys (* make a set of keys *)
ourVehicle @ "@v/tmp/" RemoveDir (* remove temp data *)
">> $vehicle created." (* notify *)
ourVehicle @ name "$vehicle" subst Tell
">> Type 'enter $vehicle' to enter."
ourVehicle @ name "$vehicle" subst Tell
;
: DoVcreate ( -- ) (* create a vehicle *)
(* check: do we have all the programs we'll need? *)
#0 "_reg/vsys/vbcast-prog" getprop not if
">> vsys-@vbcast not installed. Cannot create vehicle." Tell exit
then
#0 "_reg/vsys/vexit-prog" getprop not if
">> vsys-@vexit not installed. Cannot create vehicle." Tell exit
then
#0 "_reg/vsys/vforce-prog" getprop not if
">> vsys-@vforce not installed. Cannot create vehicle." Tell exit
then
#0 "_reg/vsys/vlock-prog" getprop not if
">> vsys-@vlock not installed. Cannot create vehicle." Tell exit
then
#0 "_reg/vsys/vlookout-prog" getprop not if
">> vsys-@vlookout not installed. Cannot create vehicle." Tell exit
then
(* reassemble original arg string *)
ourArg @ ourString @ and if
ourString @ " " strcat ourArg @ strcat ourString !
then
ourString @ CapAll ourString !
(* check: strict types? type defined? *)
me @ "W" flag? not if
lib @ "@v/strict" getprop
lib @ "@v/types/$type/" ourString @
"$type" subst nextprop not and if
">> Sorry, that type of vehicle has not been defined." Tell exit
then
then
(* check: user has enough quota? *)
CheckQuota not if exit then
(* check: valid name for vehicle? *)
ourString @ CheckName not if exit then
(* check: user has enough money? *)
lib @ "@v/types/$type/cost" ourString @ "$type" subst
getpropstr dup if
me @ swap atoi CheckCost if
me @ lib @ "@v/types/$type/cost"
ourString @ "$type" subst getpropstr atoi Charge pop
else
">> Sorry, you do not have enough funds for that type of vehicle."
Tell exit
then
else
pop
then
(* check: are we trying to make a vehicle in a vehicle? *)
me @ GetVehicle if
">> Please exit this vehicle and re-enter the command."
">> Sorry, you may not create a vehicle while inside a vehicle."
Tell Tell exit
then
(* if it's a prototyped vehicle, go do it that way *)
lib @ "@v/types/$type/" ourString @ "$type" subst nextprop if
DoCreatePrototype exit
then
(* create vehicle environment room *)
#0 "_reg/env/vehicle" getprop
ourName @ " Environment Room" strcat newroom
ourName @ newroom ourRoom !
ourRoom @ "V" set
(* create vehicle object *)
me @ location ourName @ newobject ourVehicle !
ourVehicle @ "V" set
(* set security data *)
ourVehicle @ "@v/key" random intostr setprop
ourVehicle @ "@v/env" ourRoom @ location setprop
ourRoom @ location "@v/id" ourVehicle @ intostr setprop
(* create vehicle entry *)
ourVehicle @ "enter $vehicle;enter;getin"
ourString @ "$vehicle" subst newexit ourExit !
ourExit @ ourRoom @ setlink
ourExit @ "V" set
(* create vehicle exit *)
ourRoom @ "Out <O>;out;ou;o" newexit ourExit !
ourExit @ #0 "_reg/vsys/vexit-prog" getprop setlink
ourExit @ "{vlookout}" setdesc
ourExit @ "D" set
(* create control action *)
ourRoom @ "Drive <D>;drive;dr;d" newexit ourExit !
ourExit @ #0 "_reg/vsys/vforce-prog" getprop setlink
ourExit @ "#$lockprog"
#0 "_reg/vsys/vlock-prog" getprop intostr "$lockprog" subst
setlockstr not if
">> Unable to set locks properly." Tell
">> Please notify a wizard." Tell
then
ourExit @ "D" set
(* create a set of keys *)
DoMakeKeys
ourRoom @ "desc#/1" " " setprop (* desc main room *)
ourRoom @ "desc#/10" " " setprop
ourRoom @ "desc#/11"
"To create additional rooms, use @dig normally, while in the vehicle."
setprop
ourRoom @ "desc#/12" " " setprop
ourRoom @ "desc#/13"
"To create additional exits leading out of the vehicle, use '@vexit <name>'." setprop
ourRoom @ "desc#/14" " " setprop
ourRoom @ "desc#/15"
"Type '@view $lib/vsys' for more information on the vehicle system."
setprop
ourRoom @ "desc#/2" "This is the primary room of the $vehicle."
ourString @ "$vehicle" subst setprop
ourRoom @ "desc#/3" " " setprop
ourRoom @ "desc#/4" "Local Commands: " setprop
ourRoom @ "desc#/5" " " setprop
ourRoom @ "desc#/6"
" drive;dr;d <string> .......... Force vehicle to do/go <string>" setprop
ourRoom @ "desc#/7"
" out;ou;o ..................... Leave the vehicle" setprop
ourRoom @ "desc#/8" " " setprop
ourRoom @ "desc#/9" "These commands can be freely renamed." setprop
ourRoom @ "desc#" "15" setprop
ourRoom @ "{list:desc}" setdesc
">> $vehicle created."
ourString @ "$vehicle" subst Tell
">> Type 'enter $vehicle' to enter."
ourString @ "$vehicle" subst Tell
;
: DoKeys ( -- ) (* check permission and make a set of keys *)
me @ GetVehicle dup if
VehicleAdmin? not if
">> Permission denied." Tell exit
then
dup ourVehicle !
"@v/key" getprop dup if
ourString !
else
">> Unable to determine key value." Tell exit
then
else
">> You are not in a vehicle." Tell
">> Unable to create keys." Tell exit
then
DoMakeKeys
">> Keys created." Tell
;
: DoNoKeys ( -- ) (* check permission and recycle all keys *)
me @ GetVehicle dup if
dup ourVehicle !
me @ ourVehicle @ controls me @ "W" flag? or not if
">> Permission denied." Tell exit
then
"@v/key" getprop dup if
dup string? not if intostr then ourString !
else
">> Unable to determine key value." Tell exit
then
else
">> You are not in a vehicle." Tell
">> Unable to recycle keys." Tell exit
then
">> Please do not create any new keys until this operation completes."
">> Recycling all outstanding keys..." Tell Tell background
#0 (* scan db; find keys; recycle *)
begin
dup dbtop dbcmp not while
dup ok? if
dup "@v/key" getprop dup if
dup string? not if intostr then
ourString @ smatch if
dup "@v/env" getpropstr not if
dup 1 + swap recycle
then
then
else
pop
then
then
1 +
repeat
pop
">> Done. All outstanding keys recycled." Tell
;
: DoStrict ( -- ) (* set: only defined types may be created *)
me @ "W" flag? if
lib @ "@v/strict" "yes" setprop
">> Set. Users may only created defined vehicle types." Tell
else
">> Permission denied." Tell
then
;
: DoNotStrict ( -- ) (* set: any type vehicle may be created *)
me @ "W" flag? if
lib @ "@v/strict" remove_prop
">> Set. Users may create any type vehicle." Tell
else
">> Permission denied." Tell
then
;
: DoListPackages ( -- ) (* list available packages *)
0 ourRoomCounter !
">> Available Packages:" Tell
lib @ "@v/packages/" nextprop
begin
dup while
ourString !
ourRoomCounter @ 1 + ourRoomCounter !
ourRoomCounter @ 2 % if
" "
then
ourRoomCounter @ intostr ") " strcat 4 DoPad strcat
ourString @ "" "@v/packages/" subst strcat " " strcat
lib @ ourString @ "/cost" strcat getpropstr dup if
"(" swap strcat ")" strcat strcat
else
pop
then
ourRoomCounter @ 2 % if
32 DoPad
else
Tell
then
lib @ ourString @ nextprop
repeat
pop
ourRoomCounter @ 2 % if Tell then
;
: DoAddPack ( -- ) (* add a package to current vehicle *)
ourArg @ not if (* list available if none specified *)
DoListPackages exit
then
me @ GetVehicle dup if (* find vehicle; check permission *)
ourVehicle !
VehicleAdmin? not if
">> Permission denied." Tell exit
then
else
">> You are not in a vehicle." Tell
">> Unable to add packages." Tell pop exit
then
ourArg @ if (* check syntax; tidy up arg string *)
ourArg @ strip CapAll ourArg !
then
ourArg @ if
lib @ "@v/packages/" nextprop dup if (* find package *)
begin (* begin package-finding loop *)
dup while
dup dup "/" rinstr strcut swap pop ourArg @ smatch if
lib @ swap "/cost" strcat getprop dup if (* check cost *)
dup int? not if atoi then
me @ over CheckCost if
me @ swap Charge pop
else
">> Sorry, you do not have enough money to add that."
Tell pop exit
then
else
pop
then
lib @ "@v/packages/$pack/props/" ourArg @ "$pack" subst
nextprop
begin (* begin prop-copying loop *)
dup while
lib @ over
ourVehicle @ over
dup "/" instr strcut swap pop
dup "/" instr strcut swap pop
dup "/" instr strcut swap pop
dup "/" instr strcut swap pop
lib @ 4 pick propdir? if
CopyDir
else
4 rotate 4 rotate getprop setprop
then
lib @ swap nextprop
repeat
pop (* end prop-copying loop *)
ourVehicle @ "@v/packages/" ourArg @ strcat ourArg @ setprop
">> $pack package added." (* notify *)
ourArg @ CapAll "$pack" subst Tell
exit
then
lib @ swap nextprop
repeat (* end package-finding loop *)
pop
">> Package '$pack' not found."
ourArg @ CapAll "$pack" subst Tell
else
">> Sorry, no packages have been set up." Tell pop
then
else
">> Available vehicle packages:" Tell
lib @ "@v/packages/" nextprop dup if
" " Tell
begin
dup while
dup dup "/" rinstr strcut swap pop
CapAll " " swap strcat Tell
lib @ swap nextprop
repeat
pop
else
" " Tell " <none>" Tell pop
then
then
;
: DoRemPack ( -- ) (* remove a package from current vehicle *)
ourArg @ if (* check syntax; tidy up arg string *)
ourArg @ strip CapAll ourArg !
else
">> Installed packages:" Tell " " Tell
ourVehicle @ "@v/packages/" nextprop dup if
begin
dup while
ourVehicle @ over getpropstr
" " swap strcat Tell
ourVehicle @ swap nextprop
repeat
pop
else
" <none>" Tell pop
then
" " Tell exit
then
me @ GetVehicle dup if (* find vehicle; check permission *)
ourVehicle !
VehicleAdmin? not if
">> Permission denied." Tell exit
then
else
">> You are not in a vehicle." Tell
">> Unable to remove packages." Tell pop exit
then
(* get confirmation *)
">> Please confirm: you wish to remove package $pack? (y/n)"
ourArg @ "$pack" subst Tell ReadYesNo not if
">> Aborted." Tell exit
then
(* remove installed package props *)
ourVehicle @ "@v/packages/" ourArg @ strcat getprop if
lib @ "@v/packages/$pack/props/" ourArg @ "$pack" subst nextprop
begin
dup while dup
dup "/" instr strcut swap pop
dup "/" instr strcut swap pop
dup "/" instr strcut swap pop
dup "/" instr strcut swap pop
ourVehicle @ over propdir? if
ourVehicle @ swap RemoveDir
else
ourVehicle @ swap remove_prop
then
lib @ swap nextprop
repeat
pop
ourVehicle @ "@v/packages/" ourArg @ strcat remove_prop
">> $pack package removed."
ourArg @ CapAll "$pack" subst Tell
else
">> The $pack package was not installed."
ourArg @ CapAll "$pack" subst Tell
then
;
: DoDefPack ( -- ) (* define a package *)
ourArg @ not if (* list available if none specified *)
DoListPackages exit
then
me @ "W" flag? not if (* check permission *)
">> Permission denied." Tell exit
then
ourArg @ if (* check syntax; tidy up arg string *)
ourArg @ strip CapAll ourArg !
"@v/packages/$pack/props/"
ourArg @ "$pack" subst ourString !
then
">> Defining package $pack..." ourArg @ "$pack" subst Tell
">> Enter property:value pairs that will make up the package." Tell
">> Example: ~flight:yes" Tell
">> Enter .q to quit." Tell
begin (* get package data *)
ReadLine QCheck
dup ":" instr if
dup ":" instr strcut
swap strip dup strlen 1 - strcut pop strip
lib @ ourString @ rot strcat rot setprop
">> Property entered." Tell
">> Enter another property:value par, or .q to quit." Tell
else
">> Syntax: <property>:[<value>]" Tell pop
then
repeat
">> Package defined." Tell
;
: DoDelPack ( -- ) (* delete data for a package *)
ourArg @ not if (* list available if none specified *)
DoListPackages exit
then
me @ "W" flag? not if (* check permission *)
">> Permission denied." Tell exit
then
ourArg @ if (* check syntax; tidy up arg string *)
ourArg @ strip CapAll ourArg !
"@v/packages/$pack/"
ourArg @ "$pack" subst ourString !
then
(* get confirmation *)
">> Please confirm: you want to delete the "
"$pack package definition? (y/n)" strcat
ourArg @ "$pack" subst Tell
ReadYesNo if
lib @ ourString @ RemoveDir
">> Package deleted." Tell
else
">> Aborted." Tell
then
;
: DoCost ( -- ) (* set cost of a prototype or package *)
me @ "W" flag? if (* check permission *)
ourArg @ if
ourArg @ "=" instr if
ourArg @ dup "=" instr strcut strip ourString !
dup strlen 1 - strcut pop strip ourArg !
ourString @ if (* check data *)
ourString @ number? not if
">> Usage: $command <prototype|package>=<cost>"
command @ "$command" subst Tell
">> The cost must be a number." Tell exit
then (* set cost *)
then
lib @ "@v/types/$type/" ourArg @ "$type" subst nextprop if
lib @ "@v/types/$type/cost"
ourArg @ "$type" subst
ourString @ setprop
">> Cost set." Tell exit
then
lib @ "@v/packages/$pack/" ourArg @ "$pack" subst nextprop if
lib @ "@v/packages/$pack/cost"
ourArg @ "$pack" subst
ourString @ setprop
">> Cost set." Tell exit
then
">> Prototype or package not found." Tell
else
">> Usage: $command <prototype|package>=<cost>"
command @ "$command" subst Tell
then
else
">> Usage: $command <prototype|package>=<cost>"
command @ "$command" subst Tell
then
else
">> Permission denied." Tell
then
;
: main
"me" match me !
"$lib/vsys" match lib !
DoInit
dup if strip
dup if
ourString !
then
then
ourString @ if
ourString @ ourName !
ourString @ " " instr if
ourString @ dup " " instr strcut
strip ourArg ! strip ourString !
then
ourString @ "#" stringpfx if
"#add" ourString @ stringpfx if DoAddPack exit then
"#cost" ourString @ stringpfx if DoCost exit then
"#help" ourString @ stringpfx if DoHelp exit then
"#install" ourString @ stringpfx if DoInstall exit then
"#keys" ourString @ stringpfx if DoKeys exit then
"#!keys" ourString @ stringpfx if DoNoKeys exit then
"#money" ourString @ stringpfx if DoMoney exit then
"#packages" ourString @ stringpfx if DoDefPack exit then
"#!packages" ourString @ stringpfx if DoDelPack exit then
"#prototypes" ourString @ stringpfx if DoAddPrototype exit then
"#!prototypes" ourString @ stringpfx if DoDelPrototype exit then
"#remove" ourString @ stringpfx if DoRemPack exit then
"#strict" ourString @ stringpfx if DoStrict exit then
"#!strict" ourString @ stringpfx if DoNotStrict exit then
">> #Option not found." Tell exit
then
DoVcreate
else
">> Usage: $command <vehicle name>"
command @ "$command" subst Tell
then
;
.
c
q