@q @program asys-source 1 99999 d i ( asys-source v1.2 Jessy@FurryMUCK 6/97, 11/99 asys-source is used to add, remove, and configure 'source lists'... settings that allow players to buy or sell objects at a given location. INSTALLATION: asys-source uses the standard Argo installation method: port the program and set it Wizard. Type '+install asys-source." USAGE: Type '+source' and follow prompts. asys-source may be freely ported. Please comment any changes. ) (2345678901234567890123456789012345678901234567890123456789012345678901) $def thisVersion "1.2" $define Tell me @ owner swap notify $enddef $include $lib/argo lvar scratch (* workspace var *) lvar ourCounter (* misc. counter var *) lvar ourDataObj (* dbref: object holding system-wide data *) lvar ourArg (* inital arg string, unmodified *) lvar ourCom (* string: 'official' name of command *) lvar ourBoolean (* int: misc flow control var *) lvar ourObject (* string or int: name or dbref of object handled *) lvar ourSource (* dbref: object to be source *) : DoInstall ( -- ) (* install program into Argo system *) caller program? not if (* confirm installation method *) ">> Programs must be installed via the " "+install" GetCommandName strcat " command." strcat Tell exit then prog "@a/version" getpropstr if (* confirm re-install *) ">> Reinstalling..." Tell else ">> Installing..." Tell then (* record 'official' name of prog; remove old links *) prog "@a/name" "asys-source" setprop RecOldActions (* create and register command; set default props *) #0 "+source" newexit dup scratch ! prog setlink prog "@a/version" thisVersion setprop scratch @ "@a/version" thisVersion setprop #0 "@a/comm_list/+source" scratch @ setprop #0 "@a/prog_list/" prog name strcat prog setprop scratch @ "@a/name" "+source" setprop ">> Installed." Tell ; : DoUninstall (* uninstall program from Argo *) prog "@a/name" getpropstr if #0 "@a/prog_list/" prog "@a/name" getpropstr strcat getprop not if ">> " prog name strcat " is not currently installed." strcat Tell pid kill then else ">> " prog name strcat " is not currently installed." strcat Tell pid kill then ">> Please confirm: You wish to uninstall " prog name strcat "?" strcat Tell ReadYesNo not if ">> Aborted." Tell pid kill Then background "@a/comm_list/+source" RemoveCommand #0 "@a/prog_list/" prog "@a/name" getpropstr strcat remove_prop RecOldActions ">> Uninstalled. Please edit the online manual as appropriate." Tell ; : DoHelp ( -- ) (* display help screen *) " " Tell prog name " (#" strcat prog intostr strcat ")" strcat Tell " " Tell "The $command command is used to configure locations or objects as " "places where Argo objects can be bought or sold." strcat command @ "$command" subst Tell " " Tell "Syntax: $command , " command @ "$command" subst Tell " " Tell ; : DoTimeHelp ( -- ) (* show help for time format *) "To enter a time required, combine a positvie number and a standard unit " "of time such as minutes, hours, or weeks. Valid example time strings " "would include '1 hour', '12 weeks', 'two months', etc." strcat strcat Tell " " Tell "If no time is required, enter 0." Tell ; : DoMatchObject ( -- )(* match obj in ourArg; ourBool true for suc *) ourArg @ match dup if dup #-2 dbcmp over #-3 dbcmp or if pop 0 ourBoolean ! else ourSource ! 1 ourBoolean ! then else pop 0 ourBoolean ! then ; : DoListBuyObjs ( -- ) (* show list of objs available from ourSource *) ">> OBJECTS AVAILABLE FROM $SOURCE" ourSource @ name toupper "$SOURCE" subst Tell NukeStack ourSource @ "@a/source/buy/" nextprop dup if begin dup while dup "" "@a/source/buy/" subst swap ourSource @ swap nextprop repeat pop depth 3-col else pop " " " " " " Tell Tell Tell then ; : DoListSellObjs ( -- ) (* show list of objs that can be sould at ourSource *) ">> OBJECTS THAT CAN BE SOLD AT $SOURCE" ourSource @ name toupper "$SOURCE" subst Tell NukeStack ourSource @ "@a/source/sell/" nextprop dup if begin dup while dup "" "@a/source/sell/" subst swap ourSource @ swap nextprop repeat pop depth 3-col else pop " " " " " " Tell Tell Tell then ; : DoAddBuy ( s -- ) (* add buy info for loc *) pop begin ">> What object to buy do you want to add for $source?" ourSource @ name "$source" subst Tell ">> [Enter the name of an object, .l to list choices, or .q to quit]" Tell ReadLine strip QCheck ".list" over stringpfx if #0 "@a/prog_list/asys-list" getprop dup if "objects" swap call NukeStack continue else ">> Sorry, asys-list is not installed." Tell NukeStack continue then then dup VerifyObject not if ">> Sorry, no such object has been defined." Tell pop continue then CapAll ourObject ! scratch @ "buy/$object/" strcat ourObject @ "$object" subst scratch ! break repeat begin ">> The book price for $object is $price." ourObject @ "$object" subst ourDataObj @ "@a/objects/" ourObject @ strcat "/cost" strcat getpropstr atoi ExpressLowestMoney dup not if pop "`free'" then "$price" subst Tell ">> Is this the price to be charged at $source? (y/n)" ourSource @ name "$source" subst Tell ReadYesNo not if ">> How much should $object cost at this source?" ourObject @ "$object" subst Tell ">> [Enter price in $coins, or .q to quit]" ourDataObj @ "@a/sysparms/small_coins" getpropstr "$coins" subst Tell ReadLine strip QCheck dup number? not if ">> Sorry, price must be a number." Tell pop continue then dup atoi 0 < if ">> Sorry, price must be a positive number." Tell pop continue then ourDataObj @ scratch @ "cost" strcat rot setprop break else ourDataObj @ scratch @ "cost" strcat ourDataObj @ "@a/objects/" ourObject @ strcat "/cost" strcat getpropstr setprop break then repeat ">> Is this object always available at this source? (y/n)" Tell ReadYesNo not if begin ">> What is the percent chance that $object will be at this source?" ourObject @ "$object" subst Tell ">> [Enter a number between 1 and 100, or .q to quit]" Tell ReadLine strip QCheck dup number? not if ">> Sorry, that's not a number." Tell pop continue then dup atoi 100 > over atoi 1 < or if ">> Sorry, that's outside the valid range." Tell pop continue then ourDataObj @ scratch @ "chance" strcat rot setprop break repeat begin ">> How often can $object be obtained at this source?" ourObject @ "$object" subst Tell ">> [Enter a time, or .h for help, or .q to quit]" Tell ReadLine strip QCheck ".help" over stringpfx if DoTimeHelp pop continue then ParseTimeString if ourDataObj @ scratch @ "time" strcat rot setprop break else ">> Entry not understood." Tell continue then repeat then ">> What message should be shown to players when they successfully obtain " Tell " $object from this source?" ourObject @ "$object" subst Tell ">> [Enter message, or .n for none, or .q to quit]" Tell ReadLine strip QCheck ".none" over stringpfx not if ourDataObj @ scratch @ "succ" strcat rot setprop then ">> What message should be shown to other players when someone obtains " Tell " $object from this source?" ourObject @ "$object" subst Tell ">> [Player's name will be prepended to message]" Tell ">> [Enter message, or .n for none, or .q to quit]" Tell ReadLine strip QCheck ".none" over stringpfx not if ourDataObj @ scratch @ "osucc" strcat rot setprop then ourDataObj @ scratch @ "chance" strcat getprop ourDataObj @ scratch @ "time" strcat getprop or if ">> What message should be shown to players when they fail to obtain " Tell " $object from this source?" ourObject @ "$object" subst Tell ">> [Enter message, or .n for none, or .q to quit]" Tell ReadLine strip QCheck ".none" over stringpfx not if ourDataObj @ scratch @ "fail" strcat rot setprop then ">> What message should be shown to other players when someone " "fails to obtain " strcat Tell " $object from this source?" ourObject @ "$object" subst Tell ">> [Player's name will be prepended to message]" Tell ">> [Enter message, or .n for none, or .q to quit]" Tell ReadLine strip QCheck ".none" over stringpfx not if ourDataObj @ scratch @ "ofail" strcat rot setprop then then ourDataObj @ scratch @ ourSource @ "@a/source/buy/$object/" ourObject @ "$object" subst MoveDir-r ">> $object added to $source's source list." ourObject @ "$object" subst ourSource @ name "$source" subst Tell ; : DoAddSell ( s -- ) (* add sell info for loc *) pop begin ">> What object can be sold here?" Tell ">> [Enter name of object, .l to list choices, or .q to quit]" Tell ReadLine strip QCheck ".list" over stringpfx if #0 "@a/prog_list/asys-list" getprop dup if "objects" swap call NukeStack continue else ">> Sorry, asys-list is not installed." Tell NukeStack continue then then dup VerifyObject if CapAll ourObject ! break else ">> Object not found." Tell pop continue then repeat ">> The book price for $object is $price." ourObject @ "$object" subst ourDataObj @ "@a/objects/$object/cost" ourObject @ "$object" subst getpropstr atoi ExpressLowestMoney dup not if pop "'free'" then "$price" subst Tell begin ">> What is the *most* that will be paid for $object at this source?" ourObject @ "$object" subst Tell ">> [Enter an amount in $coins, or .q to quit]" ourDataObj @ "@a/sysparms/small_coins" getpropstr "$coins" subst Tell ReadLine strip QCheck dup number? not if ">> Sorry, price must be a number." Tell pop continue then dup atoi 0 < if ">> Sorry, price must be a non-negative number." Tell pop continue then ourDataObj @ scratch @ "maxprice" strcat rot setprop break repeat begin ">> What is the *least* that will be paid for $object at this source?" ourObject @ "$object" subst Tell ">> [Enter an amount in $coins, or .q to quit]" ourDataObj @ "@a/sysparms/small_coins" getpropstr "$coins" subst Tell ReadLine strip QCheck dup number? not if ">> Sorry, price must be a number." Tell pop continue then dup atoi 0 < if ">> Sorry, price must be a non-negative number." Tell pop continue then dup atoi ourDataObj @ scratch @ "maxprice" strcat getpropstr atoi > if ">> Sorry, minimum price must be less than or equal to maximum price." Tell pop continue then ourDataObj @ scratch @ "minprice" strcat rot setprop break repeat ourDataObj @ scratch @ "maxprice" strcat getpropstr atoi ourDataObj @ scratch @ "minprice" strcat getpropstr atoi = not if " a time period for which the price is frozen? (y/n)" " the command until they get a higher price. Do you want to configure" ">> With different maximum and minimum prices, players could keep trying" Tell Tell Tell ReadYesNo if begin ">> For how long should the price stay the same?" Tell ">> [Enter a time, or .h for help, or .q to quit]" Tell ReadLine strip QCheck ".help" over stringpfx if DoTimeHelp pop continue then ParseTimeString if ourDataObj @ scratch @ "time" strcat rot setprop break else ">> Unable to parse entry." Tell NukeStack then repeat then then ">> What message should be shown to players when they sell " Tell " $object at this source?" ourObject @ "$object" subst Tell ">> [Enter message, or .n for none, or .q to quit]" ">> [Include the string '%price' where you want the price paid to appear." Tell Tell ReadLine strip QCheck ".none" over stringpfx not if ourDataObj @ scratch @ "succ" strcat rot setprop then ">> What message should be shown to other players when someone sells " Tell " $object at this source?" ourObject @ "$object" subst Tell ">> [Player's name will be prepended to message]" Tell ">> [Enter message, or .n for none, or .q to quit]" ">> [Include the string '%price' where you want the price paid to appear." Tell Tell ReadLine strip QCheck ".none" over stringpfx not if ourDataObj @ scratch @ "osucc" strcat rot setprop then ourDataObj @ scratch @ ourSource @ "@a/source/sell/$object/" ourObject @ "$object" subst MoveDir-r ">> $object added to $source's source list." ourObject @ "$object" subst ourSource @ name "$source" subst Tell ; : DoRemBuy ( s -- ) (* remove buy info for loc *) pop begin ">> What object do you want to make unavailable from $source?" ourSource @ name "$source" subst Tell ">> [Enter object name, or .l to list choices, or .q to quit]" Tell ReadLine strip QCheck ".list" over stringpfx if DoListBuyObjs continue then ourSource @ "@a/source/buy/" 3 pick strcat "/" strcat over over nextprop if RemoveDir-r ">> $object removed." swap CapAll "$object" subst Tell exit else pop pop ">> $object wasn't available from $source." swap "$object" subst ourSource @ "$source" subst Tell then repeat ; : DoRemSell ( s -- ) (* remove sell info for loc *) pop begin ">> What object do you want to stop buying at $source?" ourSource @ name "$source" subst Tell ">> [Enter object name, or .l to list choices, or .q to quit]" Tell ReadLine strip QCheck ".list" over stringpfx if DoListSellObjs continue then ourSource @ "@a/source/sell/" 3 pick strcat "/" strcat over over nextprop if RemoveDir-r ">> $object removed." swap CapAll "$object" subst Tell exit else pop pop ">> $object couldn't be sold at $source." swap "$object" subst ourSource @ "$source" subst Tell then repeat ; : DoAddSource ( s -- ) (* add source information for loc *) pop begin ">> [Enter 'buy', 'sell', or .q to quit]" ">> Do you want to add information for players to buy or sell objects?" Tell Tell ReadLine strip QCheck "buying" over stringpfx if DoAddBuy exit then "selling" over stringpfx if DoAddSell exit then ">> Sorry, invalid entry." Tell pop repeat ; : DoRemoveSource ( s -- ) (* remove source information from loc *) pop begin ">> [Enter 'buy', 'sell', or .q to quit]" ">> Do you want to remove information for players to buy or sell objects?" Tell Tell ReadLine strip QCheck "buying" over stringpfx if DoRemBuy exit then "selling" over stringpfx if DoRemSell exit then ">> Sorry, invalid entry." Tell pop repeat ; : DoSource ( -- ) begin begin ">> Do you want to add or remove an object from $source's source list ?" ourSource @ name "$source" subst Tell ">> [Enter 'add', 'remove', or .q to quit]" Tell ReadLine strip QCheck "add" over stringpfx if DoAddSource break then "remove" over stringpfx if DoRemoveSource break then ">> Sorry, invalid entry." Tell pop repeat ">> Do you want to add or remove something else for $source? (y/n)" ourSource @ name "$source" subst Tell ReadYesNo not if break then repeat ; : main "me" match me ! (* initialize *) GetDataObj ourDataObj ! strip ourArg ! trig "@a/name" getpropstr ourCom ! "@a/temp/" me @ intostr strcat "/" strcat scratch ! Update ourArg @ if ourArg @ "#" stringpfx if "#help" ourArg @ stringpfx if DoHelp else "#enable" ourArg @ stringpfx if DoEnable else "#disable" ourArg @ stringpfx if DoDisable else "#version" ourArg @ stringpfx if DoVersion else "#install" ourArg @ stringpfx if DoInstall else "#uninstall" ourArg @ stringpfx if DoUninstall else DoMatchObject ourBoolean @ not if ">> Source object not found." Tell exit then then then then then then then exit else DoMatchObject ourBoolean @ not if ">> Source object not found." Tell exit then then then me @ ArgoPermCheck Disabled? ourArg @ not if loc @ ourSource ! then DoSource ">> Done." Tell ; . c q @set asys-source=W