1 8
admins
'(#13)
/
players
'(#13)
/
guests
'()
/
init
0
/
destroy
0
/
boot
;; this method is called at every restart of the server ... just once.
(method ()
(if (private-ok? caller)
(begin
(set connected '())
(foreach (i guests) (i:destroy))
(if (not (#13:is-password-set?))
(#13:set-password "trauma"))
(set guests '()))
(raise E_PERM "only #0 can call 'boot'")))
/
list-admins
(method () admins)
/
add-admin
(method (new-wiz)
(if (not (write-ok? caller))
(raise E_PERM "only administrators can call add-admin")
(begin (setparents new-wiz (tolist $admin))
(set admins ($utils:set-add new-wiz admins)))))
/
remove-admin
(method (ex-wiz)
(if (not (write-ok? caller))
(raise E_PERM "only administrators can call remove-admin")
(begin (setparents ex-wiz (tolist $coder))
(set admins ($utils:set-remove ex-wiz admins)))))
/
intersize
(method ()
(+ "Interlude code is now " (before "\n" (run-script "intersize"))
" lines\n"))
/
create-guest
(method () (var i
(begin (set i ($guest:copy))
(set guests ($utils:set-add i guests))
i)))
/
remove-guest
(method () (set guests ($utils:set-remove caller guests)))
/
remove-player
(method () (set players ($utils:set-remove caller players)))
/
connect
;; whenever a socket hits the MU*, this gets called and the socket connects
;; to #0. this has to figure out where to reconnect it to.
(method () (var i
(begin (set i (create-guest))
(set connected ($utils:set-add i connected))
(reconnect #0 i)
(i:welcome))))
/
reconnect-me
;; reconnects the caller to the object in the first parameter.
(method (to-obj pass-string)
(if (to-obj:accept-connect caller pass-string)
(begin
(reconnect caller to-obj)
(to-obj:welcome))
(raise E_PERM
(+ "object " (tostr to-obj)
" rejects a connection from " (tostr caller)))))
/
remove-connection
(method () (set connected ($utils:set-remove caller connected)))
/
list-connected
(method () connected)
/
log-message
(method (msg)
(if (write-ok? caller)
(log msg)))
/
call-me-out
(method (addr)
(if (not (search caller connected))
(connect-out caller addr)))
/
parse
;; sometimes output gets sent before the server has reconnected to a
;; guest... the danger of multi-threading.
(method (unused) (echo "Sorry ... waiting for reconnect.\n"))
/
list-players
(method () players)
/
find-player
(method (instring)
(or (foreach (p players)
(if (p:name-match instring) (return p)))
(foreach (p guests)
(if (p:name-match instring) (return p)))))
/
find-connected-player
(method (instring)
(foreach (c connected)
(if (p:name-match instring) (return p))))
/
guest-to-player
(method (pname ppass)
(if (caller:has-parent? $guest)
(if (find-player pname)
(player:tell (+ "Sorry, the name " pname " is already in use.\n"))
(begin
(player:tell (+ "Creating player " pname " with password " ppass "\n"))
(set guests ($utils:set-remove caller guests))
(set players ($utils:set-add caller players))
(setparents caller (tolist $builder))
(caller:set-password ppass)
(call (caller:get-location) announce
(+ (caller:get-name) " creates a new player: " pname "\n"))
(caller:set-name pname)
(player:tell "Creation successful.\n")
(player:welcome)))
(player:tell "Sorry, only a guest can create a new player.\n")))
/
recycle-this
;; when an object wants to delete itself, it should call ($system:recycle-this)
(method () (begin
(setparents caller (tolist $recycler))
($recycler:add-recycled caller)
(caller:~wipe-clean)))
/
force-recycle
;; kind of the hammer of god destroying offending objects.
(method (obj)
(if (write-ok? player)
(begin
(setparents obj (tolist $recycler))
($recycler:add-recycled obj)
(obj:~wipe-clean))))
/
addparent
(method (new-p) (if (new-p : accept-child caller)
(setparents caller (cons new-p (caller:list-parents)))
(raise E_PERM
(+ (tostr new-p) " doesn't accept child "
(tostr caller)))))
/
rmparent
(method (new-p) (setparents caller
($utils : set-remove new-p (caller:list-parents))))
/
set-parents
(method (obj new-p)
(if (and (obj:write-ok? caller) (new-p:read-ok? caller))
(setparents obj (tolist new-p))
(raise E_PERM
(+ "cannot parent " (tostr obj) " to " (tostr new-p)))))
/
force-shutdown
(method ()
(if (write-ok? caller)
(shutdown)))
/
connect-me-to
(method (to passwd)
(if (to:accept-connection caller passwd)
(begin
(reconnect caller to)
(set connected ($utils:set-add to ($utils:set-remove caller connected)))
(to:welcome))
(begin
(player:tell (+ (to:get-name) " didn't accept connection.\n"))
0)))
/
/
/+++++++++ end of object #0 ... no lines after this ++++++++++
public
;; whether the object is readable to all
1
/
owners
;; generally, the owner of an object is usually allowed to change it.
;; #13 is the generic wizard parent.
'( #13 )
/
~write-ok?
(method (who) (or (= who this)
(= who #0)
(search who owners)
(search who (#0:list-admins))))
/
write-ok?
(method (who) (~write-ok? who))
/
~read-ok?
(method (who) (or public
(write-ok? who)))
/
read-ok?
(method (who) (~read-ok? who))
/
private-ok?
(method (who) (= caller this))
/
publish
(method () (set public 1))
/
unpublish
(method () (set public 0))
/
public?
(method () public)
/
~wipe-clean
;; once an object is parented to the recycler, this method is used to
;; remove all vestiges of what it once was: variables and commands.
;; notice, you can't use this method on any core object.
(method ()
(if (~write-ok? caller)
(if (< (tonum this) 17)
(raise E_PERM "cannot wipe a core object clean")
(var s
(begin (purge-cmds)
(foreach (i (vars))
(rmvar i)))))))
/
init
(method () (if (not (or (search caller (parents)) (write-ok? caller)))
(raise E_PERM "cannot call 'init' on that object")
(begin
(set owners (tolist player))
this)))
/
copy
(method () (if (not (read-ok? caller))
(raise E_PERM "cannot copy objects that you can't read")
(var i
(begin
(set i (or ($recycler:get-free this) (clone)))
(call i init)
i))))
/
destroy
(method () (if (write-ok? caller)
($system:recycle-this)
(raise E_PERM "cannot destroy objects that you can't write to")))
/
add-parent
(method (new-parent) (if (write-ok? caller)
(#0:addparent new-parent)
(raise E_PERM "cannot change parents on that object")))
/
add-command
(method (regex sym)
(if (write-ok? caller)
(addcmd regex sym)))
/
remove-command
(method (instring)
(if (write-ok? caller)
(rmcmd instring)))
/
accept-child
(method (child) (or (read-ok? caller)
(search player owners)
(search player (#0:admins))))
/
remove-parent
(method (the-parent) (if (or (write-ok? caller) (= caller the-parent))
(#0:rmparent the-parent)
(raise E_PERM)))
/
set-variable
;; asks 'this' to add a variable whose name is passed in as the first
;; parameter, and value in the second.
(method (sym val) (if (not (write-ok? caller))
(raise E_PERM "cannot set a variable on that object")
(sets sym val)))
/
rm-variable
;; asks 'this' to permanently remove a variable
(method (sym) (if (not (write-ok? caller))
(raise E_PERM "cannot write to that object")
(rmvar sym)))
/
list-variables
(method () (if (not (read-ok? caller))
(raise E_PERM "cannot read this object")
(vars)))
/
list-owners
(method () owners)
/
list-parents
(method () (parents))
/
list-method
(method (symname)
(if (read-ok? player)
(ignore E_VAR_NOT_FOUND
(if (and (= (typeof (typeof (eval symname))) 'SYMBOL)
(= (typeof (eval symname)) 'ERROR))
(+ (tostr this) " doesn't have that variable")
(format (eval symname) 78)))
"You don't have permission to view that."))
/
add-owner
(method (new-owner)
(if (not (write-ok? caller))
(raise E_PERM "cannot write to this object")
(set owners ($utils : set-add new-owner owners))))
/
remove-owner
(method (old-owner) (if (not (write-ok? caller))
(raise E_PERM "cannot write to this object")
(set owners ($utils : set-remove old-owner owners))))
/
dump-to-string
(method () (+ (+ "Object ID: " (tostr this) "\n")
(+ "Parents: " (tostr (parents)) "\n")
(if (not (read-ok? caller))
"The rest of the object is not available\n"
(+ "Vars: " (tostr (vars)) "\n"
"Commands: " (tostr (commands)) "\n"))))
/
~show-this
(method ()
(begin
(player:tell (+ "Object " (tostr this) ":\n"))
(player:tell (+ "Parents: "
(after "'(" (before ")" (tostr (parents)))) "\n"))
(if (not (~read-ok? caller))
(player:tell "The rest of the object is not available\n")
(begin
(player:tell "Variables:\n")
(foreach (v (vars))
(player:tell (+ " " (tostr v) "\n")))
(player:tell "Commands:\n")
(foreach (c (commands))
(player:tell (+ " \"" (tostr (index 2 c)) "\" --> "
(tostr (car c)) "\n")))
(player:tell "------ end of object ------\n")))))
/
has-parent?
(method (anc) (foreach (parent (parents))
(if (= parent anc) (return 1))))
/
descends-from?
;; returns whether 'this' descends from the argument given as a parent
(method (anc) (foreach (parent (parents))
(if (or (= parent anc) (parent:descends-from? anc))
(return 1))))
/
E_INVALID_REGEXP
10
/
E_OVERRIDE
11
/
E_TYPE
12
/
E_INCOMPATIBLE_TYPES
13
/
E_RANGE
14
/
E_VAR_NOT_FOUND
15
/
E_TOO_MANY_ARGUMENTS
16
/
E_TOO_FEW_ARGUMENTS
17
/
E_INVALID_FUNCTION
18
/
E_DIV_BY_ZERO
19
/
E_SYSTEM_ONLY
20
/
E_INVALID_OBJECT
21
/
E_PARSE_ERROR
22
/
E_INVALID_PAIR
23
/
E_UNINITIALIZED
24
/
E_CMD_NOT_FOUND
25
/
E_NOT_CONNECTED
26
/
E_BAD_SEPARATOR
27
/
E_CANNOT_PASS
28
/
E_PERM
29
/
E_BAD_FILE
30
/
E_NO_MATCH
31
/
E_SEMAPHORE
32
/
$root
#1
/
$system
#0
/
$located
#2
/
$exit
#3
/
$thing
#4
/
$container
#5
/
$area
#6
/
$room
#7
/
$connected
#8
/
$guest
#9
/
$player
#10
/
$builder
#11
/
$coder
#12
/
$admin
#13
/
$utils
#14
/
$recycler
#15
/
$editor
#16
/
/
/+++++++++ end of object #1 ... no lines after this ++++++++++
1
name
"Generic Located, Described Object"
/
aliases
'()
/
description
"You see nothing special."
/
location
#7
/
x-coordinate
;; the user is, of course, free to use these as
;; polar values.
1
/
y-coordinate
1
/
init
(method () (if (not (read-ok? caller)) (raise E_PERM)
(begin (set home player)
(set owners (tolist player))
(go-home))))
/
go-home
(method () (if (or (write-ok? caller)
(= caller location)
(= player (location:get-owner)))
(begin
(location:announce (+ name " goes home.\n"))
(move-to home)
(home:announce (+ name " has arrived.\n")))
(raise E_PERM
(+ (tostr caller) " cannot force " (tostr this) " to move"))))
/
tell
;; default behavior is to ignore things you are told
(method (instring) 0)
/
destroy
(method () (begin
(location:announce (+ name " disappears\n"))
(location:remove this)
(pass)))
/
get-name
(method () name)
/
set-name
(method (newname)
(if (write-ok? caller)
(set name newname)
(raise E_PERM "cannot write to this object")))
/
set-description
(method (newdesc)
(if (write-ok? caller)
(set description newdesc)
(raise E_PERM "cannot write to this object")))
/
get-location
(method () location)
/
get-description
(method () description)
/
contained-by?
(method (container) (or (= container location)
(contained-by? (container:get-location))))
/
full-name-match
(method (instring)
(if (or (= name instring)
(= (tostr this) instring)
(and (= player this) (= instring "me"))
(and (= (player:get-location) this) (= instring "here"))
(foreach (nm aliases)
(if (= nm instring) (return this))))
this))
/
partial-name-match
(method (instring)
(var loc
(if (and (set loc (search instring name))
(or (= loc 1)
(= " " (range (- loc 1) (- loc 1) name))))
this)))
/
name-match
(method (instring)
(or (full-name-match instring)
(if (partial-name-match instring)
(begin
(foreach (c (location:get-contents))
(if (c:full-name-match instring) (return '())))
this))))
/
alias-list
(method ()
(if (= (player:get-location) this)
(cons "here" (cons name aliases))
(if (= player this)
(cons "me" (cons name aliases))
(cons name aliases))))
/
add-alias
(method (new-alias)
(if (write-ok? caller)
(if (= (typeof new-alias) 'STRING)
(set aliases ($utils:set-add new-alias aliases))
(player:tell "Aliases must be STRING to be added\n"))
(raise E_PERM "cannot write to this object")))
/
rm-alias
(method (old-alias)
(if (write-ok? caller)
(if (= (typeof old-alias) 'STRING)
(if (search old-alias aliases)
(begin (set aliases ($utils:set-remove old-alias aliases))
old-alias)))
(raise E_PERM "cannot write to this object")))
/
move-to
;; used to move an object from one location to another.
;; either returns the object number of the destination or a false value.
(method (dest)
(ignore E_VAR_NOT_FOUND
(if (dest:accept-move)
(if (not (= location dest))
(begin (location:remove this)
(set location dest)))
'())))
/
std-match
(method (mname)
(set mname ($utils:strip-spaces mname)
(or (and (reg-split "^#[0-9]+$" mname)
(compile mname))
(name-match mname)
(location:match-content mname)
(location:name-match mname)
(foreach (conick core-nicks)
(if (= conick mname)
(return (toobj (- (search conick core-nicks) 1)))))
($system:find-player mname))))
/
try-command
;; allows objects to try to do some command on this
(method (instring)
(foreach (i (matchcmd instring))
(if ((car i) (index 2 i)) (return 1))))
/
look-at
(method ()
(player:tell-line (get-description)))
/
/
/+++++++++ end of object #2 ... no lines after this ++++++++++
2
name
"generic exit"
/
arrive-msg
" has arrived."
/
oleave-msg
" has left."
/
leave-msg
"You leave."
/
destination
#17
/
link
(method (dest)
(if (dest:accept-exit this)
(set destination dest)
(raise E_PERM "cannot change this exit")))
/
tell-leave
(method (obj-to)
(begin (obj-to:tell (+ leave-msg "\n"))
obj-to))
/
tell-oleave
(method (obj-to)
(begin (location:announce (+ (obj:get-name) oleave-msg "\n"))
obj-to))
/
tell-arrive
(method (obj-to)
(begin
(destination:announce-but
(+ (obj:get-name) arrive-msg "\n")
obj-to)
obj-to))
/
activate
(method (obj)
(if (or (= location (obj:get-location))
(obj:write-ok? player))
(if (obj:move-to destination)
(begin
(tell-leave obj)
(tell-oleave obj)
(destination:look-at)
(tell-arrive obj)
1)
(obj:tell "You can't go that way\n"))))
/
/
/+++++++++ end of object #3 ... no lines after this ++++++++++
2
home
#7
/
name
"thing"
/
init
(method () (begin
(set home (player:get-home))
(move-to player)
(pass)))
/
/
/+++++++++ end of object #4 ... no lines after this ++++++++++
4
name
"generic container"
/
contents
'()
/
init
(method ()
(begin (set contents '())
(pass)))
/
destroy
(method ()
(begin (foreach (i contents) (i:go-home))
(pass)))
/
accept-move
;; whenever an object tries to move into this, it asks this if it's ok by
;; using the 'accept-move' method
;; for now, this is a move-free-for-all ...
;; make sure that an object will always accept something it owns.
(method ()
(begin (set contents ($utils:set-add caller contents))
1))
/
std-match
(method (mname)
(set mname ($utils:strip-spaces mname)
(or (foreach (c contents)
(if (c:name-match mname) (return c)))
(pass mname))))
/
accept-exit
(method (exit) 1)
/
remove
(method (obj)
(if (or (write-ok? caller) (= obj caller))
(set contents ($utils:set-remove obj contents))
(raise E_PERM
(+ "cannot remove " (tostr obj) " from " (tostr this)))))
/
get-contents
(method () contents)
/
non-exit-contents
;; have to give it contents as a parameter
(method (c)
(if c (if (call (car c) descends-from? $exit)
(non-exit-contents (cdr c))
(cons (car c) (non-exit-contents (cdr c))))
'()))
/
list-exits
;; have to give it the contents as a parameter
(method (c)
(if c (if (call (car c ) descends-from? $exit)
(cons (car c) (list-exits (cdr c)))
(list-exits (cdr c)))
'()))
/
get-exits-string
(method ()
(var ex (var es
(if (set ex (list-exits contents))
(set es "Exits: "
(foreach (e ex)
(set es (+ es " " (e:get-name) " ")))
es)
"No obvious exits\n"))))
/
get-visible-contents
(method () (non-exit-contents (get-contents)))
/
get-contents-string
(method ()
(var c (begin (set c (get-visible-contents))
(if c
(if (> (length c) 1)
(+ (get-rest-contents (cdr c))
"and " (call (car c) get-name))
(call (car c) get-name))
""))))
/
get-rest-contents
(method (clist)
(if clist
(+ (get-rest-contents (cdr clist))
(call (car clist) get-name) ", ")
""))
/
match-exit-content
(method (instring)
(foreach (c contents)
(if (and (c:descends-from? $exit)
(c:name-match instring))
(return c))))
/
match-non-exit
(method (instring)
(foreach (c contents)
(if (and (not (c:descends-from? $exit))
(c:name-match instring))
(return c))))
/
get-internal-description
(method () (get-description))
/
match-content
(method (instring)
(foreach (c contents)
(if (c:name-match instring) (return c))))
/
announce
(method (instring)
(ignore E_VAR_NOT_FOUND
(begin
(foreach (c contents)
(c:tell instring))
instring)))
/
announce-but
(method (instring except)
(ignore E_VAR_NOT_FOUND
(foreach (c contents)
(if (not (= c except))
(c:tell instring)))))
/
try-command-in
;; this is called when an object is trying to find a command inside of a room.
;; it searches the command list on this, then asks the contents to respond,
;; and finally it checks for exits with the right name.
(method (instring)
(or (foreach (c (matchcmd instring))
(if ((car c) (index 2 c)) (return 1)))
(foreach (c contents)
(if (and (not (= c caller)) (c:try-command instring))
(return 1)))
(var exit
(if (set exit (match-exit-content instring))
(call exit activate caller)
0))))
/
look-at
(method ()
(begin
(player:tell-line name)
(player:tell-line (get-internal-description))
(if (player:tell (get-contents-string))
(player:tell "\n")
"No contents to tell")))
/
/
/+++++++++ end of object #5 ... no lines after this ++++++++++
5
name
"generic area"
/
move-to
;; can't move an area, silly.
(method (dest) '())
/
/
/+++++++++ end of object #6 ... no lines after this ++++++++++
6
name
"generic room"
/
description
"You see the inside of an undescribed room"
/
/
/+++++++++ end of object #7 ... no lines after this ++++++++++
1
parse
(method (instring)
(echo instring))
/
tell
(method (instring)
(ignore E_NOT_CONNECTED
(or (echo instring) "")))
/
tell-line
(method (instring)
(tell (+ instring "\n")))
/
quit
;; the quit method must also be on EVERY connectable object
(method () (begin (#0:remove-connection)
(echo "*** DISCONNECTING ***\n")
(location:announce
(+ (tostr this) " has disconnected\n"))
(disconnect)))
/
get-address
(method ()
(if (read-ok? caller)
(address)
""))
/
accept-connect
;; default is no reconnection.
(method (from-obj password-string) 0)
/
welcome
;; right now, the DB is set up so this will get called on any object
;; after it has been reconnected to.
(method () (echo (+ "Connecting to " (tostr this) "\n")))
/
/
/+++++++++ end of object #8 ... no lines after this ++++++++++
8 5
init
(method ()
(begin
(set contents '())
(set home #17)
(set name (+ "guest_" (tostr this)))
(go-home)))
/
name
"generic guest"
/
core-nicks
'("$system" "$root" "$located" "$exit" "$thing" "$container" "$area"
"$room" "$connected" "$guest" "$player" "$builder" "$coder"
"$admin" "$utils" "$recycler" "$editor")
/
destroy
(method ()
(if (write-ok? caller)
(begin
(if (has-parent? $guest)
(#0:remove-guest))
(pass))
(raise E_PERM "cannot destroy this object")))
/
announce
(method (instring)
(tell instring))
/
get-home
(method () home)
/
get-description
(method ()
(if contents
(var desc
(set desc (+ (pass) "\nCarrying:")
(foreach (con contents)
(set desc (+ desc "\n" (con:get-name))))))
(pass)))
/
look-at
(method ()
(player:tell-line (get-description)))
/
say-method
(method (inline)
(if (write-ok? player)
(location:announce (+ name " says, \"" (index 2 inline) "\"\n"))))
/
pose-method
(method (inline)
(if (write-ok? player)
(location:announce (+ name " " (index 2 inline) "\n"))))
/
welcome
(method ()
(if (write-ok? caller)
(begin
(tell (+ "Welcome to Interlude.\n"
"Connecting you to " name ".\n"
"Have an interesting time.\n\n"))
(location:announce-but (+ name " has connected\n") this)
(tell (+ (location:get-name) "\n"
(location:get-internal-description) "\n"
(location:get-contents-string) "\n")))))
/
parse
(method (instring)
(if (write-ok? player)
(if (search $editor (parents))
(edit-parse instring)
(if (not
(or (not instring)
(foreach (i (matchcmd instring))
(if ((car i) (index 2 i)) (return 1)))
(foreach (i contents)
(if (i:try-command instring) (return 1)))
(location:try-command-in instring)
(var pair
(and (set pair (reg-split "#[0-9]+" instring)
(call (compile (index 2 pair)) try-command instring))))))
(echo "I don't understand that\n")))))
/
quit
(method ()
(if (write-ok? player)
(begin (#0:remove-guest)
(disconnect)
(#0:remove-connection)
(location:announce (+ name " has disconnected.\n"))
(destroy))))
/
quit-command
(method (unused)
(if (write-ok? player)
(quit)))
/
inventory-command
(method (unused)
(if (read-ok? caller)
(tell
(if contents
(var cntstring
(set cntstring "You are carrying:\n"
(foreach (cnt contents)
(set cntstring (+ cntstring (cnt:get-name) "\n")))))
"You are not carrying anything\n"))))
/
look-cmd
(method (inline)
(if (= player this)
(if (index 4 inline) ;; empty string "" is logically false
(var match
(if (set match (std-match (index 4 inline)))
(match:look-at)
(tell "I don't see that here\n")))
(location:look-at))))
/
help-command
(method (inline)
(if (index 2 inline)
(ignore E_BAD_FILE
(tell (or (filetext (+ "help/" (index 2 inline)))
"There is no help available on that topic.\n")))
(tell (filetext "help/help"))))
/
who-command
(method (ignored)
(if (write-ok? player)
(foreach (c (#0:list-connected))
(tell (+ (c:get-name) " "
(call (c:get-location) get-name) " "
(c:get-address) "\n")))))
/
home-command
(method (unused)
(if (or (search player (location:list-owners)) (write-ok? player))
(begin (go-home)
(location:look-at))))
/
editor-alias
"$$"
/
send-whisper-method
(method (sym)
(if (write-ok? caller)
(whisper-to whispering-to (eval sym))))
/
whisper-method
(method (to msg)
(if (write-ok? player)
(if (= msg editor-alias)
(begin
(tell-line ">> Editing the text of the message to whisper...")
(set whispering-to to)
(enter-edit
'whisper-txt
'send-whisper-method
'()))
(whisper-to to msg))))
/
whisper-to
(method (to msg)
(if (write-ok? player)
(if (search "\n" msg)
(begin
(tell-line (+ "You whisper your message to " (to:get-name)))
(if (to:tell-line (+ name " whispers to you:"))
(tell-line (+ " " (implode "\n " (explode "\n" msg))))
(tell-line (+ (to:get-name) " isn't awake, though."))))
(begin
(tell-line (+ "You whisper, \"" msg "\" to " (to:get-name)))
(if (to:tell-line (+ name " whispers, \"" msg "\" to you."))
name
(tell-line (+ (to:get-name) " isn't awake, though.")))))))
/
whisper-to-command
(method (inline)
(if (write-ok? player)
(var w-to
(if (= (index 4 inline) "to") ;; then it's Moo syntax
(if (set w-to (std-match (index 5 inline)))
(whisper-method w-to (index 3 inline))
(tell (+ "I don't see " (index 5 inline) " here\n")))
(if (set w-to (std-match (index 3 inline)))
(whisper-method w-to (index 5 inline))
(tell (+ "I don't see " (index 3 inline) " here\n")))))))
/
whisper-syntax
(method (unused)
(if (write-ok? player)
(tell "Syntax: whisper <msg> to <player>\n")))
/
connect-syntax
(method (unused)
(if (write-ok? player)
(tell "Syntax: connect <player name> <password>\n")))
/
connect-command
(method (inline)
(if (write-ok? player)
(var play-to
(if (search " " (index 4 inline))
(connect-syntax inline)
(if (set play-to (#0:find-player (index 3 inline)))
(if (#0:connect-me-to play-to (index 4 inline))
(quit)
1)
(tell "Can't locate that player\n"))))))
/
move-to
(method (dest)
(if (or (write-ok? caller)
(caller:descends-from? $exit)
(= player this))
(pass dest)))
/
get-cmd
(method (inline)
(if (= player this)
(var match
(if (set match (location:match-non-exit (index 2 inline)))
(if (match:move-to this)
(begin
(location:announce-but
(+ name " gets " (match:get-name) "\n") this)
(tell (+ "You get " (match:get-name) "\n")))
(tell "You can't get that!\n"))
(get-syntax)))))
/
get-syntax
(method (unused)
(if (= this player)
(tell "I don't see that here\n")))
/
drop-syntax
(method (unused)
(if (= player this)
(tell "You are not carrying that.\n")))
/
drop-cmd
(method (inline)
(if (= player this)
(var match
(if (set match (match-content (index 2 inline)))
(if (match:move-to location)
(begin
(location:announce-but
(+ name " drops " (match:get-name) "\n") this)
(tell (+ "You drop " (match:get-name) "\n")))
(tell "You can't drop that here!\n"))
(drop-syntax inline)))))
/
create-syntax
(method (unused)
(if (write-ok? player)
(tell "Syntax: create <player name> <password>\n")))
/
create-command
(method (inline)
(if (write-ok? player)
(if (search " " (index 3 inline))
(create-syntax inline)
(#0:guest-to-player (index 2 inline) (index 3 inline)))))
/
enter-edit
(method (prop after-call starting-list)
(begin (tell ">> type '.help' to get help on the editor\n")
(#0:addparent $editor)
(set editing-list starting-list)
(set edit-insert-at 1)
(set edit-save-prop prop)
(set edit-after-call after-call)))
/
leave-edit
(method () (#0:rmparent $editor))
/
quit-save
(method (saved-to)
(tell (+ ">> quitting editor, saving to property "
(tostr saved-to) "\n")))
/
/
'("say" REST)
say-method
'("\"" REST)
say-method
'("pose" REST)
pose-method
'(":" REST)
pose-method
'("quit")
quit-command
'("@quit")
quit-command
'("QUIT")
quit-command
'("l" (or "ook" "") (or " at " "") REST)
look-cmd
'("help" REST)
help-command
'("who" REST)
who-command
'("@who" REST)
who-command
'("WHO" REST)
who-command
'("home" REST)
home-command
'("HOME" REST)
home-command
'("wh" (or "isper" " ") (or (before "=") (before " to ") WORD) (or "=" "to" "") REST)
whisper-to-command
'("wh" (or "isper" ""))
whisper-syntax
'("con" (or "nect" " ") WORD REST)
connect-command
'("con" (or "nect" ""))
connect-syntax
'("create" WORD REST)
create-command
'("create")
create-syntax
'("i" (or "nventory" ""))
inventory-command
'("get" REST)
get-cmd
'("drop")
drop-syntax
'("drop" REST)
drop-cmd
/+++++++++ end of object #9 ... no lines after this ++++++++++
9
name
"generic player"
/
password
"no-login"
/
destroy
(method ()
(if (write-ok? caller)
(begin (#0:remove-player) (pass))
(raise E_PERM "cannot destroy this object")))
/
set-password
(method (newpass)
(if (write-ok? caller)
(set password (crypt newpass))
(raise E_PERM "cannot destroy this object")))
/
password-cmd
(method (cmdline)
(if (not (= player this))
(player:tell "Only an player can change its own password.\n")
(if (not (= (crypt (index 3 cmdline)) password))
(tell "Syntax: @password <oldpassword> <newpassword>\n")
(begin (set-password (index 4 cmdline))
(tell "Password changed\n")))))
/
quit
(method () (begin (disconnect)
(#0:remove-connection)
(location:announce (+ name " has disconnected.\n"))
(leave-edit)))
/
accept-connection
(method (from passwd)
(and (= (crypt passwd) password) (not (= this from))))
/
describe-syntax
(method (ignored)
(if (= player this)
(tell "Syntax: @describe <object> as <description>\n")))
/
describe-cmd
(method (inline)
(if (= PLAYER THIS)
(if (set DESCRIBE-ONTO (STD-MATCH (index 3 INLINE)))
(begin
(set DESCRIPTION-TXT (index 5 INLINE))
(if (= DESCRIPTION-TXT EDITOR-ALIAS)
(begin
(TELL-line ">> Editing description-txt")
(ENTER-EDIT
'DESCRIPTION-TXT
'DESCRIBE-METHOD
(explode "\n" (DESCRIBE-ONTO:GET-DESCRIPTION))))
(DESCRIBE-METHOD (quote DESCRIPTION-TXT))))
(TELL "I don't see that here\n"))
(DESCRIBE-SYNTAX INLINE)))
/
describe-method
(method (SYM)
(if (= player this)
(ignore E_PERM
(if (DESCRIBE-ONTO:SET-DESCRIPTION (eval SYM))
(TELL "Description changed\n")
(TELL "You cannot change that object\n")))))
/
paste-cmd
(method (inline)
(if (= player this)
(begin
(tell-line ">> Editing a message to paste.")
(enter-edit 'paste-txt
'paste-method
'()))))
/
paste-method
(method (sym)
(if (= player this)
(begin
(location:announce (+ "-------- " name " pastes: ---------------\n"))
(location:announce (+ (eval sym) "\n"))
(location:announce "------------------------------------------\n"))))
/
/
'("@pass" (or "word" " ") WORD WORD)
password-cmd
'("@setpass" (or "word" " ") WORD WORD)
password-cmd
'("pass" (or "word" " ") WORD WORD)
password-cmd
'("@desc" (or "ribe" ""))
describe-syntax
'("@paste")
paste-cmd
'("@desc" (or "ribe" " ") (or (before "=") (before " as ") WORD) (or "=" "as" "") REST)
describe-cmd
/+++++++++ end of object #10 ... no lines after this ++++++++++
10
name
"Generic builder"
/
clone-object-cmd
(method (inline)
(if (= player this)
(ignore E_PERM
(var ob
(if (set ob (std-match (index 2 inline)))
(if (set ob (ob:copy))
(tell (+ "Successfully cloned to make object "
(tostr ob) ": " (ob:get-name) "\n"))
(tell "That object refuses to be cloned\n"))
(tell "I don't see that here!\n"))))))
/
clone-syntax
(method (ignored)
(if (= player this)
(tell-line "Syntax: @clone <object>")))
/
exit-syntax
(method (inline)
(if (= player this)
(tell-line "Syntax: @exit <name> to <destination>")))
/
exit-cmd
(method (inline)
(if (= player this)
(var new-exit
(if (set new-exit ($exit:copy))
(begin
(new-exit:set-name (index 2 inline))
(if (new-exit:move-to location)
(var dest
(if (set dest (std-match (index 4 inline)))
(ignore E_PERM
(if (new-exit:link dest)
(tell "Exit created, linked\n")
(begin
(new-exit:destroy)
(tell "You can't link an exit to there\n"))))
(begin
(new-exit:destroy)
(tell "I don't see that destination\n"))))
(begin
(new-exit:destroy)
(tell "This room doesn't allow the new exit\n"))))
(tell "You cannot create a new exit\n")))))
/
dig-syntax
(method (inline)
(if (= player this)
(tell-line "Syntax: @dig <roomname>")))
/
dig-cmd
(method (inline)
(if (= player this)
(var new-room
(if (= (typeof (set new-room ($room:copy))) 'OBJECT)
(tell (+ "Room " (tostr new-room) " dug, named "
(new-room:set-name (index 2 inline)) "\n"))
(tell "Sorry, you can't create a new room\n")))))
/
rename-syntax
(method (ignored)
(if (= player this)
(tell-line "Syntax: @rename <object> to <name>")))
/
rename-cmd
(method (inline)
(if (= player this)
(var match
(if (set match (std-match (index 2 inline)))
(ignore E_PERM
(if (match:set-name (index 4 inline))
(tell "Name changed\n")
(tell "You cannot change that object\n")))
(tell "I don't see that here\n")))
(rename-syntax inline)))
/
set-name
(method (newname)
(if (std-match newname)
(begin
(player:tell-line "That name is already in use.")
'())
(pass newname)))
/
alias-syntax
(method (ignored)
(if (= player this)
(tell-line "Syntax: @alias <object> to <name>")))
/
alias-cmd
(method (inline)
(if (= player this)
(var match
(if (set match (std-match (index
(if (= (index 3 inline) "=") 4 2)
inline)))
(ignore E_PERM
(if (match:add-alias (index
(if (= (index 3 inline) "=") 2 4)
inline))
(tell "Alias added\n")
(tell "You cannot change that object\n")))
(tell "I don't see that here\n")))
(alias-syntax inline)))
/
rmalias-syntax
(method (ignored)
(if (= player this)
(tell-line "Syntax: @rmalias <name> on <object>")))
/
rmalias-cmd
(method (inline)
(if (= player this)
(var match
(if (set match (std-match (index
(if (= (index 3 inline) "=") 2 4)
inline)))
(ignore E_PERM
(if (match:rm-alias (index
(if (= (index 3 inline) "=") 4 2)
inline))
(tell-line "Alias removed")
(tell-line "You cannot change that object")))
(tell-line "I don't see that here")))
(rmalias-syntax inline)))
/
recycle-syntax
(method (ignored)
(if (= player this)
(tell-line "Syntax: @recycle <object>")))
/
recycle-cmd
(method (inline)
(if (= player this)
(var match
(if (set match (std-match (index 2 inline)))
(handle E_PERM
(method (en es)
(tell-line "You cannot recycle that object"))
(begin
(match:destroy)
(tell-line "Object recycled")))
(tell-line "I don't see that here")))))
/
list-helper
(method (objname pname)
(var on
(if (set on (std-match objname))
(tell-line (on:list-method (tosym pname)))
(tell "I don't see that here\n"))))
/
list-command
(method (inline)
(if (write-ok? caller)
(if (= (index 3 inline) "=")
(list-helper (index 2 inline) (index 4 inline))
(if (= (index 3 inline) "on")
(list-helper (index 4 inline) (index 2 inline))
(ignore E_VAR_NOT_FOUND
(if (eval (set inline (tosym (index 4 inline))))
(tell (list-method inline))
(tell "That variable does not exist on you.\n")))))))
/
list-syntax
(method (unused)
(if (= player this)
(tell "Syntax: @list <variable name> [on <object>]\n")))
/
show-syntax
(method (unused)
(if (= player this)
(tell "Syntax: @show <object>\n")))
/
show-command
(method (inline)
(if (= player this)
(var match
(if (set match (std-match (index 2 inline)))
(match:~show-this)
(tell "I don't see that here.\n")))))
/
/
'("@clone" SOME)
clone-object-cmd
'("@clone")
clone-syntax
'("@rename")
rename-syntax
'("@name")
rename-syntax
'("@rename" (or (before "=") (before " as ") (before " to ") WORD) (or "=" "as" "to" "") REST)
rename-cmd
'("@name" (or (before "=") (before " as ") (before " to ") WORD) (or "=" "as" "to" "") REST)
rename-cmd
'("@addalias")
alias-syntax
'("@addalias" (or (before "=") (before " to ") WORD) (or "=" "to" "") SOME)
alias-cmd
'("@alias")
alias-syntax
'("@alias" (or (before "=") (before " to ") WORD) (or "=" "to" "") SOME)
alias-cmd
'("@rmalias" (or (before "=") (before " on ") (before " from ") WORD) (or "=" "on" "from" "") SOME)
rmalias-cmd
'("@rmalias")
rmalias-syntax
'("@recycle")
recycle-syntax
'("@recycle" SOME)
recycle-cmd
'("@dig")
dig-syntax
'("@dig" SOME)
dig-cmd
'("@exit")
exit-syntax
'("@exit" (or (before "=") (before " to ")) (or "=" "to") SOME)
exit-cmd
'("@list")
list-syntax
'("@list" (or (before "=") (before " on ") "") (or "=" "on" "") SOME)
list-command
'("@show")
show-syntax
'("@show" REST)
show-command
/+++++++++ end of object #11 ... no lines after this ++++++++++
11
name
"Generic Coder"
/
eval-command
(method (inline)
(if (= player this)
(player:tell (+ "--> "
(tostr ((compile (+ "(method () "
(index 3 inline)
"]\n"))))
"\n"))))
/
program-syntax
(method (inline)
(if (= player this)
(tell "Syntax: @program <variable name> on <object>\n")))
/
start-program
(method (objname pname)
(if (= player this)
(if (set compile-onto (std-match objname))
(var prop
(set prop (+ pname "-txt")
(tell (+ ">> Programming " prop " from scratch\n"))
(enter-edit (tosym prop) 'compile-program '())
1))
(tell "I don't see that here\n"))))
/
program-cmd
(method (inline)
(if (= player this)
(if (= (index 4 inline) "on")
(start-program (index 5 inline) (index 3 inline))
(if (= (index 4 inline) "=")
(start-program (index 3 inline) (index 5 inline))
(program-syntax inline)))))
/
compile-program
(method (saved-to)
(if (write-ok? caller)
(begin
(tell (+ ">> compiling '" (tostr saved-to) "' into variable '"
(before "-TXT" (tostr saved-to)) "' :\n"))
(var temp
(if (set temp (compile (eval saved-to)))
(if (compile-onto:set-variable
(tosym (before "-TXT" (tostr saved-to)))
temp)
(begin
(tell ">> compilation successful\n")
(rmvar saved-to))
(tell (+ ">> unable to compile onto object "
(tostr compile-onto)
"\n>> still in editor: .xit to abort edit\n"))))))))
/
edit-syntax
(method (inline)
(if (= player this)
(tell-line "Syntax: @edit <variable name> on <object>")))
/
start-edit
(method (objname pname)
(if (= player this)
(if (set compile-onto (std-match objname))
(var prop
(set prop (+ pname "-txt")
(tell (+ ">> Editing existing version of " prop " at line one:\n"))
(enter-edit (tosym prop) 'compile-program
(explode "\n" (compile-onto:list-method (tosym pname))))
1))
(tell "I don't see that here\n"))))
/
edit-cmd
(method (inline)
(if (= player this)
(if (= (index 3 inline) "on")
(start-edit (index 4 inline) (index 2 inline))
(if (= (index 3 inline) "=")
(start-edit (index 2 inline) (index 4 inline))
(edit-syntax inline)))))
/
mutate-syntax
(method (unused)
(if (= player this)
(tell "Syntax: @mutate <object> to <object>\n")))
/
mutate-cmd
(method (inline)
(if (= player this)
(var match (var match2
(if (set match (std-match (index 2 inline)))
(if (set match2 (std-match (index 4 inline)))
(ignore E_PERM
(if (#0:set-parents match match2)
(tell "Object has been mutated\n")
(tell (+ "You cannot mutate " (index 2 inline)
" to " (index 4 inline) "\n"))))
(tell (+ "I don't see " (index 4 inline) " here\n")))
(tell (+ "I don't see " (index 2 inline) " here\n")))))
(mutate-syntax)))
/
addcommand-syntax
(method (in)
(if (= player this)
(tell "Syntax: @addcommand <symbol> on <object> with <template>\n")))
/
addcommand-creator
(method (inline)
(if (= player this)
(var obj
(if (set obj (std-match (index 4 inline)))
(var cmd-list
(if (= (typeof (set cmd-list (compile (index 6 inline))))
'LIST)
(if (obj:add-command cmd-list (tosym (index 2 inline)))
(tell "Command added\n")
(tell "Unable to add command\n"))
(tell "Command must be in the form of a list\n")))
(tell (+ "I don't see " (index 4 inline) " here.\n"))))))
/
rmcommand-syntax
(method (unused)
(if (= player this)
(tell "Syntax: @rmcommand on <object> matching <line>\n")))
/
rmcommand-cmd
(method (inline)
(if (= player this)
(var obj
(if (set obj (std-match (index 3 inline)))
(if (obj:remove-command (index 5 inline))
(tell "Command removed\n")
(tell "That line does not match a command you can remove\n"))
(tell "I can't find that object here\n")))))
/
rmvariable-syntax
(method (unused)
(if (= player this)
(tell "Syntax: @rmvariable <symbol> from <object>\n")))
/
rmvariable-cmd
(method (inline)
(if (= player this)
(if (= (index 4 inline) "=")
(rmvar-helper (index 3 inline) (index 5 inline))
(rmvar-helper (index 5 inline) (index 3 inline)))))
/
rmvar-helper
(method (obj prop)
(if (set obj (std-match obj))
(if (obj:rm-variable (tosym prop))
(tell "Variable removed\n")
(tell "You cannot remove that variable\n"))
(tell "I can't find that object\n")))
/
/
'("@prog" (or "ram" ""))
program-syntax
'("@prog" (or "ram" "") (or (before "=") (before " on ") "") (or "=" "on" "") SOME)
program-cmd
'("@edit")
edit-syntax
'("@edit" (or (before "=") (before " on ") "") (or "=" "on" "") SOME)
edit-cmd
'("eval" (or "uate" "") REST)
eval-command
'(";" "" SOME)
eval-command
'("@list")
mutate-syntax
'("@mutate" (or (before "=") (before " to ")) (or "=" "to") REST)
mutate-cmd
'("@rmvar" (or "iable" "") (or (before "=") (before " from ")) (or "=" " from ") SOME)
rmvariable-cmd
'("@rmvar" (or "iable" ""))
rmvariable-syntax
'("@addcommand")
addcommand-syntax
'("@addcommand" WORD " on " (before " with ") "with" SOME)
addcommand-creator
'("@rmcommand" " on " (before "matching") "matching" SOME)
rmcommand-cmd
'("@rmcommand")
rmcommand-syntax
/+++++++++ end of object #12 ... no lines after this ++++++++++
12
name
"admin"
/
owners
'(#13)
/
location
#17
/
home
#17
/
password
""
/
is-password-set?
(method ()
(and password 1))
/
description
"This is the generic administrator. its default password is 'trauma'"
/
destroy
(method ()
(if (write-ok? caller)
(begin
(#0:remove-admin)
(pass))
(raise E_PERM "cannot destroy this object")))
/
shutdown-method
(method (unused)
(if (= player this)
(#0:force-shutdown)))
/
wiz-player
(method (inline)
(if (= player this)
(if (not
(foreach (pl (#0:list-players))
(if (pl:name-match (index 3 inline))
(begin (#0:add-admin pl)
(return (player:tell "Administrator added.\n"))))))
(player:tell "Cannot find that player...\n"))))
/
/
'("@wiz" (or "ard" "") SOME)
wiz-player
'("shutdown")
shutdown-method
/+++++++++ end of object #13 ... no lines after this ++++++++++
1
set-add
(method (elem inlist)
(if (not (search elem inlist)) (insert elem inlist 1) inlist))
/
set-remove
(method (elem inlist)
(var i (begin
(set i (search elem inlist))
(if (not i) inlist
(+ (before i inlist) (after i inlist))))))
/
strip-surrounding
(method (char instring)
(begin
(while (= (search char instring) 1)
(set instring (after 1 instring)))
(while (= (range (length instring)
(length instring) instring) char)
(set instring (range 1
(- (length instring) (length char))
instring)))
instring))
/
strip-spaces
(method (instring) (strip-surrounding " " instring))
/
accept-child
(method (inchild) (search inchild list-connected))
/
ext-range
(method (p q s)
(if (and (<= p q)
(<= 1 p)
(<= q (length s)))
(range p q s)
""))
/
spaces
(method (nums)
(if (> nums 0)
(if (< nums 40)
(range 1 nums " ")
(+ (spaces (- nums 40)) " "))
""))
/
list-to-string
(method (inlist)
(implode "\n" inlist))
/
maximum
(method (num1 num2)
(if (> num1 num2) num1 num2))
/
minimum
(method (num1 num2)
(if (< num1 num2) num1 num2))
/
square
(method (innum) (* innum innum))
/
pro-search
(method (pronoun wlist)
(var in-quote (begin
(set in-quote 0)
(dotimes (word (length wlist))
(var tempstring (begin
(set tempstring (index word wlist))
(while (search "\"" tempstring)
(begin
(set tempstring (after "\"" tempstring))
(set in-quote (not in-quote))))
(if (and (not in-quote) (= pronoun tempstring))
(return word)))))
0)))
/
move-to
(method (dest) '())
/
/
/+++++++++ end of object #14 ... no lines after this ++++++++++
14
free-pile
'()
/
add-recycled
;; this is used to register the object with the recyclery so it can be given
;; out later.
(method (obj) (set free-pile (set-add obj free-pile)))
/
add-parent
(method (p) (if (and (= caller $recycler) (not (= this $recycler)))
(#0:addparent p)
(raise E_PERM "cannot change that object's parents")))
/
get-free
;; this checks to see if there are any available recycled object to re-use
(method (parent) (if (not free-pile) 0
(var i (begin
(set i (car free-pile))
(set free-pile (cdr free-pile))
(i:add-parent parent)
(i:remove-parent this)
i))))
/
/
/+++++++++ end of object #15 ... no lines after this ++++++++++
14
editing-list
'()
/
edit-insert-at
1
/
accept-child
(method (inchild) (search inchild (#0:list-connected)))
/
edit-parse
(method (inline)
(if (write-ok? player)
(if (not
(and
(or (= 1 (search ":" inline))
(= 1 (search "\"" inline))
(= 1 (search "." inline))
(= 1 (search ";" inline)))
(foreach (c (matchcmd inline))
(if ((car c) (index 2 c)) (return 1)))))
(begin
(set editing-list (insert inline editing-list edit-insert-at))
(set edit-insert-at (+ edit-insert-at 1))))))
/
edit-insert-cmd
(method (inline)
(if (write-ok? caller)
(if (index 4 inline)
(tell ">> Syntax: .insert <line-number>\n")
(var linenum
(if (or (< (set linenum (tonum (index 3 inline))) 1)
(> linenum (+ 1 (length editing-list))))
(tell (+ ">> line " (tostr inline) " is out of range\n"))
(tell-line (+ ">> Inserting at line "
(tostr (set edit-insert-at linenum)))))))))
/
edit-list-cmd
(method (inline)
(if (read-ok? caller)
(if (index 5 inline)
(tell-line ">> Syntax: .list [<line-number>] [<line-number>]")
(var start-at (var end-at
(if (index 3 inline)
(set start-at (tonum (index 3 inline)))
(set start-at 1))
(if (index 4 inline)
(set end-at (tonum (index 4 inline)))
(if (index 3 inline)
(set end-at start-at)
(set end-at (length editing-list))))
(list-range start-at end-at))))))
/
list-range
(method (starting ending)
(handle E_RANGE (method (n s) (tell ">> Line(s) out of range\n"))
(begin
(tell ">> Listing...\n")
(foreach (line (range starting ending editing-list))
(tell (+ line "\n")))
(tell ">> Listing completed\n"))))
/
edit-delete-cmd
(method (inline)
(if (write-ok? caller)
(if (index 5 inline)
(tell ">> Syntax: .delete [<line-number>] [<line-number>]\n")
(var start-at (var end-at
(if (index 3 inline)
(set start-at (tonum (index 3 inline)))
(set start-at 1))
(if (index 4 inline)
(set end-at (tonum (index 4 inline)))
(if (index 3 inline)
(set end-at start-at)
(set end-at (length editing-list))))
(delete-range start-at end-at))))))
/
delete-range
(method (start-at end-at)
(handle E_RANGE (method (n s) (tell ">> Line(s) out of range\n"))
(if (or (< start-at 1)
(> end-at (length editing-list))
(> start-at end-at))
(tell ">> Invalid lines to delete\n")
(begin (tell (+ ">> Deleting lines " (tostr start-at)
" through " (tostr end-at) "\n"))
(set editing-list (+ (before start-at editing-list)
(after end-at editing-list)))
(if (> edit-insert-at end-at)
(set edit-insert-at
(- edit-insert-at (- (+ end-at 1) start-at)))
(if (> edit-insert-at (- start-at 1))
(set edit-insert-at start-at)
start-at))))))
/
edit-quit-cmd
(method (ignored)
(begin
(set (eval 'edit-save-prop)
(implode "\n" editing-list))
(edit-after-call edit-save-prop)
(leave-edit)))
/
edit-exit-cmd
(method (ignored)
(begin
(tell ">> Leaving editor without saving\n")
(leave-edit)))
/
edit-help-cmd
(method (ignored)
(help-command '("help" "editor")))
/
handler
(method (errnum errstring)
(tell-line (+ ">> editor error: " errstring
">> still in editor: .x to exit without compiling")))
/
/
'(".d" (or "elete" "") (or NUMBER "") (or NUMBER "") REST)
edit-delete-cmd
'(".i" (or "nsert" "") (or NUMBER "") (or "" REST))
edit-insert-cmd
'(".l" (or "ist" "") (or NUMBER "") (or NUMBER "") REST)
edit-list-cmd
'(".q" (or "uit" ""))
edit-quit-cmd
'(".x" (or "it" ""))
edit-exit-cmd
'(".exit")
edit-exit-cmd
'(".h" (or "elp" ""))
edit-help-cmd
'(".")
edit-help-cmd
/+++++++++ end of object #16 ... no lines after this ++++++++++
7
contents
'(#18 #13)
/
name
"starter room"
/
public
1
/
description
"Not much to see here. 'out' will take you to the other room."
/
/
/+++++++++ end of object #17 ... no lines after this ++++++++++
3
name
"out"
/
description
"looks like the way out."
/
arrive-msg
" comes in from the main room."
/
oleave-msg
" goes out."
/
location
#17
/
destination
#19
/
/
/+++++++++ end of object #18 ... no lines after this ++++++++++
7
contents
'(#20 #22)
/
name
"the other room"
/
public
1
/
description
"This is the other room in the core db. 'in' will take you back."
/
/
/++++++++++++ end of object #19 +++++++++++++++++++
3
name
"in"
/
description
"looks like the way in."
/
leave-msg
"You flee to the safety of the main room."
/
oleave-msg
" has left for the main room."
/
arrive-msg
" has arrived through the 'out' door"
/
location
#19
/
destination
#17
/
/
/+++++++++++ end of object #20 ++++++++++++++++++
14
name
"coordinate type"
/
instantiate
(method (xcoord ycoord)
(class this (tolist xcoord ycoord)))
/
distance
;; this allows you to do things like (call {#21 '(1 2)} distance {#21 '(9 4)})
;; ... it looks more elegant when the values are saved to symbols, since you
;; can then say (coordinate:distance other-coordinate)
(method (this-val to-coord)
(if (and (= (typeof (typeof to-coord)) 'OBJECT)
(= (typeof to-coord) this))
(to-coord:distance-private (index 1 this-val) (index 2 this-val))
(raise E_PERM
"Invalid attempt to find distance to non-coordinate value")))
/
distance-private
;; this is the private implementation of 'distance' ... the end-user should
;; never call it.
(method (this-val to-x to-y)
(if (= caller this)
(square-root (+ (square (- to-x (index 1 this-val)))
(square (- to-y (index 2 this-val)))))
(raise E_PERM "distance-private is a private method to this object")))
/
/
/+++++++++++++++++++++++ end of object 21 ++++++++++++++++++++++++++++++++
8 4
name
"waldo"
/
description
"it's an odd little device with a keyboard, high-resolution monitor, and a pair of heavily-instrumented powergloves. A little post-it next to the monitor reads:\n TO ACTIVATE, TYPE 'call lambda'\n TO DISCONNECT, TYPE 'hang up waldo'\n TO CONTROL, TYPE 'waldo <cmd>'\n TO LIST SITES, TYPE 'sites'"
/
location
#19
/
addresses
'(("lambda" "13.2.116.36 8888" "connect guest\n")
("media" "18.85.0.48 8888" "connect guest\n")
("jayshouse" "129.10.10.59 1709" "connect guest\n"))
/
find-address
(method (instr)
(foreach (addr addresses)
(if (= (car addr) instr)
(return addr))))
/
call-out
(method (inline)
(var addr
(if (set addr (find-address (index 2 inline)))
(if (#0:call-me-out (index 2 addr))
(begin
(location:announce
(+ name "'s screen flashes the 'Connection established' message\n"))
(echo (index 3 addr)))
(location:announce
(+ name "'s screen flashes the 'Could not connect' message\n")))
(location:announce
(+ name "'s screen flashes 'Invalid destination'\n")))))
/
parse
(method (inline)
(location:announce (+ name ":> " inline "\n")))
/
list-sites
(method (unused)
(begin (location:announce
(+ name "'s screen prints 'call <sitename>' to connect\n"))
(foreach (addr addresses)
(location:announce (+ (index 1 addr) "\n")))))
/
tell
(method (instring)
0)
/
command-waldo
(method (inline)
(if (echo (+ (index 3 inline) "\n"))
(location:announce (+ (player:get-name) " types on " name "'s keyboard: "
(index 3 inline) "\n"))
(location:announce (+ (player:get-name) " vainly taps on " name
"'s unconnected keyboard\n"))))
/
hang-up-waldo
(method (inline)
(if (name-match (index 3 inline))
(begin
(quit)
(location:announce (+ (player:get-name) " hangs up " name "\n")))))
/
/
'("call" SOME)
call-out
'("wal" (or "do" "") REST)
command-waldo
'("hang" "up" SOME)
hang-up-waldo
'("sites")
list-sites
/+++++++++++++++++++++++++ end of object #22 ++++++++++++++++++++++++++++++