@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