@prog listctl.muf 1 9999 d 1 i : maybe-pstack me @ #1363 dbcmp me @ "@listctl-dbg" prop-exists? and if 99 swap pstack else pop then ; : pmatch dup "#" 1 strncmp if "*" swap strcat match else 1 strcut swap pop atoi dbref dup player? not if pop #-1 then then ; : global-env #0 ; : tctl-obj me @ "* listctl obj" ; : propname trigger @ ".prop" getpropstr dup not if pop me @ wizard? tctl-obj getpropstr atoi dbref player? and if ".t_filter" else ".player-list" then then ; : filterprop tctl-obj getpropstr atoi dbref propname ; : tmp-prop tctl-obj getpropstr atoi dbref "* tctl tmp" ; : say me @ swap notify ; : pop-N dup if 1 swap 1 for pop pop loop else pop then ; : atoi-dbref atoi dbref ; : dbref-name me @ unparse_object ; : str-to-player dup 1 strcut swap "#" strcmp not if atoi dbref swap pop exit then pop dup atoi dup intostr 3 pick strcmp not if dbref swap pop exit then pop dup pmatch dup if swap pop else pop "I can't turn `" swap "' into a player!" strcat strcat say #-1 then ; : verb-name me @ ".last" getpropstr dup " " instr dup if 1 - strcut pop else pop then ; : merge over 4 pick + -4 rotate begin over 4 pick and while over 4 pick + 4 + pick 3 pick 5 + pick 3 pick exec if rot 1 - -3 rotate else over 4 + rotate 4 pick 4 pick + 4 + -1 * rotate swap 1 - swap then loop pop pop pop ; : sort (x1 ... xN N fn -- x1 ... xN N) (fn is x1 x2 -- i and returns true if the things are correctly ordered.) over 2 < if pop exit then over 2 / rot over - over 3 + -1 * rotate over over 3 + -1 * rotate swap sort dup 2 + pick over 4 + pick 3 pick + 4 + 3 pick 2 + roll sort dup 3 + rotate swap dup 3 + rotate merge ; : maplist (x1 ... xN N fn -- y1 ... yN N) 3 3 pick 2 + 1 for dup 1 + pick 3 pick exec swap put loop pop ; : strip-falses begin dup if over not else 0 then while swap pop 1 - loop ; : chk-player dup player? not if pop #-1 then ; : dbref-cmp int swap int < ; : del-one dup int intostr tmp-prop getpropstr strcmp not if pop #-1 then ; : getlist filterprop getpropstr dup if " " explode ' atoi-dbref maplist ' chk-player maplist ' dbref-cmp sort strip-falses else pop 0 then ; : setlist dup if "" 1 rot 1 for pop " " strcat swap int intostr strcat loop 1 strcut swap pop filterprop rot 0 addprop else pop filterprop remove_prop then ; : getliststr getlist dup if "" swap 1 + 2 -1 for rotate dbref-name ", " swap strcat strcat loop 2 strcut swap pop else pop "" then ; : do-list swap if "No argument allowed to " swap strcat "!" strcat say exit then pop getliststr dup if "." strcat else pop "Your list is empty." then say ; : do-add pop ' str-to-player maplist getlist dup 2 + rotate + ' dbref-cmp sort strip-falses setlist getliststr dup not if pop "empty" then "List now: " swap strcat "." strcat say ; : do-del pop ' str-to-player maplist ' dbref-cmp sort strip-falses getlist begin dup 2 + pick while dup 2 + dup 1 + pick 1 - swap put dup 3 + rotate int intostr tmp-prop rot 0 addprop ' del-one maplist loop ' dbref-cmp sort strip-falses setlist pop tmp-prop remove_prop getliststr dup not if pop "empty" then "List now: " swap strcat "." strcat say ; : do-clear swap if "No argument allowed to " swap strcat "!" strcat say exit then pop "Your list is now empty." say 0 setlist ; : do-help-list verb-name " list -- list players" strcat say "This prints your current list of players." say ; : do-help-add verb-name " add -- add players" strcat say "This takes one or more player names or dbref numbers (with or" say "without the #) and adds them to your list of players." say ; : do-help-del verb-name " del -- delete players" strcat say "This takes one or more player names or dbref numbers (with or" say "without the #) and removes them from your list of players." say ; : do-help-clear verb-name " clear -- clear list" strcat say "This empties your list, as if you had used the del command to" say "delete each of the entries in it individually." say ; : do-help-help verb-name " " strcat over strcat " -- get help" strcat say "This gives access to on-line help." say ; : do-help-[cmd] "The [cmd] notation means that the command part is optional." say "You could type \"" verb-name " help\" for general help, or, for example," strcat strcat say "\"" verb-name " help add\" for help with \"" verb-name " add\"." strcat strcat strcat strcat say ; : do-help-x (bool str fn) rot pop 0 -rot exec ; : do-help pop dup not if verb-name dup " list -- print list" strcat say dup " add ... -- add players" strcat say dup " del ... -- remove players" strcat say dup " clear -- clear list" strcat say dup " help -- print this help" strcat say dup " help ... -- print help on s" strcat say dup " ? -- same as " over " help" strcat strcat strcat say pop pop exit then 1 swap 1 for pop 1 swap dup "list" strcmp not if ' do-help-list do-help-x then dup "add" strcmp not if ' do-help-add do-help-x then dup "del" strcmp not if ' do-help-del do-help-x then dup "clear" strcmp not if ' do-help-clear do-help-x then dup "help" strcmp not if ' do-help-help do-help-x then dup "?" strcmp not if ' do-help-help do-help-x then dup "[cmd]" strcmp not if ' do-help-[cmd] do-help-x then swap if " -- not recognized, no help available." strcat say else pop then loop ; : do-usage pop pop-N "Usage: " verb-name " list" strcat strcat say " " verb-name " add ..." strcat strcat say " " verb-name " del ..." strcat strcat say " " verb-name " clear" strcat strcat say " " verb-name " help [cmd]" strcat strcat say " " verb-name " ? [cmd]" strcat strcat say ; : main- tctl-obj me @ int intostr 0 addprop "top" maybe-pstack " " explode 1 - swap "after explode-swap" maybe-pstack over 1 >= over 1 strcut pop dup "#" strcmp swap "*" strcmp and not and if me @ true-wizard? if 1 strcut swap "#" strcmp if pmatch int else atoi then tctl-obj rot intostr 0 addprop 1 - swap then then "after if" maybe-pstack tctl-obj getpropstr atoi dbref dup player? swap global-env dbcmp or not if "can't" maybe-pstack "You can't " verb-name strcat " that." strcat say exit then "cmd tests" maybe-pstack dup "list" strcmp not if do-list exit then dup "add" strcmp not if do-add exit then dup "del" strcmp not if do-del exit then dup "clear" strcmp not if do-clear exit then dup "help" strcmp not if do-help exit then dup "?" strcmp not if do-help exit then do-usage ; : main "me" match me ! main- "done" maybe-pstack tctl-obj remove_prop ; . c q