; STANDARD.ADI -- Version 2.0 -- August 10, 1988
;
; This is an object-oriented runtime package for Advsys.
;
; Written by Brian Preble (rassilon@eddie.mit.edu) with help from the many
; people on the Advsys mailing list (advsys@eddie.mit.edu).  Most notably:
;
;    ericg@sco.com -- original carrying limits and various other mods
;    cg13+@andrew.cmu.edu -- the original events scheduler
;    msw@wega.caltech.edu -- improved daemon class and many bug fixes
;    pezzino@ipacres.bitnet -- fixed clear containers and "take all"
;    mcvax!bagron -- many, many suggestions and bug fixes
;
; Thank you, everyone.  If we keep up the good work we'll write the best
; adventure game the world has ever seen! -- Rassilon

; **************
; BUG CORRECTION
; **************

(variable
 temp
 desc
 event)

; *************
; MATH ROUTINES
; *************

(define (>= exp1 exp2)          ; Greater than or equal to
  (not (< exp1 exp2)))

(define (<= exp1 exp2)          ; Less than or equal to
  (not (> exp1 exp2)))

(define (!= value1 value2)      ; Not equal to
  (not (= value1 value2)))

(define (abs value)             ; Absolute value
  (if (< value 0)
      (* value -1)
      (value)))

; ********************
; PROPERTY DEFINITIONS
; ********************

;;; These properties will be used for connections between locations

(property
 north                  ; location north
 south                  ; location south
 east                   ; location east
 west                   ; location west
 northeast              ; location northeast
 northwest              ; location northwest
 southeast              ; location southeast
 southwest              ; location southwest
 enter                  ; location enter goes to
 exit                   ; location exit goes to
 up                     ; location above
 down)                  ; location below

;;; Description properties

(property
 initial-description    ; description when an object is
                        ;   first found
 description            ; the normal description of an object
                        ;   "There is an onion here."
 short-description      ; the "short" description of an object
                        ;   "onion"
 long-description       ; the description given by "examine"
                        ;   "Looking at the onion makes you
                        ;    want to cry."
 read-description)      ; what it says when you read it

;;; Object properties

(property
 initial-location       ; initial location of an object
 plural?                ; object is plural (for purposes of
                        ;   printing "is" or "are")
 lit?                   ; object sheds light
 worn?                  ; object is being worn
 container?             ; object may contain things
 device?                ; object is a device
 takeable?              ; object may be taken
 notake?                ; don't pick up with "take all"
 size                   ; size of an object
 capacity               ; capacity of an object
 value                 ; point value for object
 tieable?               ; object may be tied (ex: rope)
 anchor?                ; object may be tied to (ex: eyehook)
 tied-to)               ; item object is tied to

;;; Connection properties

(property
 parent                 ; the parent of an object
 sibling                ; the next sibling of an object
 child)                 ; the first child of an object

;;; Location properties

(property
 visited?               ; true if visited before
 lit?)                  ; true if location is lit

;;; Event properties

(property
 next-event             ; the next event in the list
 event-time)            ; the time to activate

;;; Portal and container properties

(property
 closed?                ; object is closed
 locked?                ; object is locked
 clear?                 ; object can be seen through
 key                    ; key to unlock the object
 other-side)            ; the other portal in a pair

;;; Device properties

(property
 on?                    ; object is on (you still have to use
                        ;    (add-device object) to activate)
 power                  ; power remaining
 power-drain)           ; power drain per turn

; **********************
; VOCABULARY DEFINITIONS
; **********************

;;; Some abbreviations for common commands

(synonym north n)
(synonym south s)
(synonym east e)
(synonym west w)
(synonym northeast ne)
(synonym northwest nw)
(synonym southeast se)
(synonym southwest sw)
(synonym up u)
(synonym down d)
(synonym look l)
(synonym take get)
(synonym inventory i inv)
(synonym wait z)
(synonym me adventurer)
(synonym all everything)

;;; Define the basic vocabulary

(conjunction and)
(article a an the that my your)
(preposition at out all from)

; ********************
; VARIABLE DEFINITIONS
; ********************

(variable
 %curloc                ; the location of the player character
 %gametime              ; turn number
 %turnlength            ; length of turn
 %verbiage              ; always short, always long, or normal
 %msgs?                 ; whether to print messages
 %actor                 ; the actor object
 %dobject               ; the direct object
 %iobject               ; the indirect object
 %score                 ; base score for player (for points
                        ;  gained by actions and exploring)
 %maxscore)             ; maximum score possible

;;; Constants for verbiage

(define BRIEF 1)        ; short descriptions only
(define NORMAL 2)       ; short descriptions for known locales
(define VERBOSE 3)      ; long descriptions only

;;; Returns true if loc contains an active light source

(define (light-here loc &aux obj)
  (setq obj (getp loc child))
  (while obj
     (if (getp obj lit?)
         (return T)
         (setq obj (getp obj sibling))))
  nil)

;;; Check if there is an active light source in the room

(define (has-light? loc)
  (or (getp loc lit?)
      (light-here loc)))

(define (seein? obj)            ; Can we see in this object?
  (or (not (getp obj closed?))
      (getp obj clear?)))

(define (open? obj)            ; Is this object open?
  (not (getp obj closed?)))

; *********************
; CONNECTION PRIMITIVES
; *********************

;;; Connect an object to a parent

(define (connect loc obj)
  (setp obj parent loc)
  (setp obj sibling (getp loc child))
  (setp loc child obj)
  T)

;;; Connect all objects to their initial parents

(define (connect-all &aux obj par)
  (setq obj 1)
  (while (<= obj $ocount)
     (if (setq par (getp obj initial-location))
         (connect par obj))
     (setq obj (+ obj 1))))

;;; Disconnect an object from its current parent

(define (disconnect obj &aux this prev)
  (setq this (getp (getp obj parent) child))
  (setq prev nil)
  (while this
     (if (= this obj)
         (progn
          (if prev
          (setp prev sibling (getp this sibling))
          (setp (getp this parent) child (getp this sibling)))
          (setp this parent nil)
          (return)))
     (setq prev this)
     (setq this (getp this sibling))))

;;; Move an object to a location

(define (move-to loc obj)
  (disconnect obj)
  (connect loc obj))

;;; Complain about a noun phrase

(define (complain head n tail)
  (if %msgs?
      (progn
       (print head)
       (print-noun n)
       (print tail)
       (abort))
      nil))

;;; Print a message containing an object description

(define (message head obj tail)
  (if %msgs?
      (progn
       (print head)
       (print (getp obj short-description))
       (print tail)))
  nil)

;;; Print a message with two objects

(define (message2 head obj1 middle obj2 tail)
  (if %msgs?
      (progn
       (print head)
       (print (getp obj1 short-description))
       (print middle)
       (print (getp obj2 short-description))
       (print tail)))
  nil)

;;; Print an error message

(define (error message)
  (if %msgs?
      (progn
       (print message)
       (abort))
      nil))

;;; Print an error message containing an object description

(define (error1 head obj tail)
  (if %msgs?
      (progn
       (print head)
       (print (getp obj short-description))
       (print tail)
       (abort)))
  nil)

;;; Print an error message with two objects

(define (error2 head obj1 middle obj2 tail)
  (if %msgs?
      (progn
       (print head)
       (print (getp obj1 short-description))
       (print middle)
       (print (getp obj2 short-description))
       (print tail)
       (abort)))
  nil)

;;; Print a message

(define (say message)
  (if %msgs?
      (print message))
  nil)

;;; Print a number

(define (say-number number)
  (if %msgs?
      (print-number number))
  nil)

;;; The magic smart-article printer!
;;; (figures out whether to print "a" or "an")

(define (smarticle string)
  (if (vowel string)
      (progn
       (say "an ")
       (say string))
      (progn
       (say "a ")
       (say string))))

;;; Figures out whether to print "is" or "are"

(define (is-are obj)
  (if (getp obj plural?)
      (say "are ")
      (say "is ")))

; *********************
; The basic-thing class
; *********************

(object basic-thing
    (property
     parent nil                 ; the parent of this object
     sibling nil                ; the next sibling of this object
     child nil                  ; the first child of this object
     next-event nil             ; the next event in the list
     event-time 0               ; time of event
     value 0                    ; point value of object
     size 1                     ; size of the object
     takeable? nil)             ; can object be taken?
    (method (take))             ; take method
    (method (drop))             ; drop method
    (method (get obj))          ; for put method
    (method (put obj)           ; put method
        (send obj get self))
    (method (m-describe))       ; description method
    (method (l-describe))       ; examine method
    (method (read)
        (if (setq temp (getp self read-description))
            (progn
             (say temp)
             (terpri))
            (message "There's nothing written on the " self ".\n"))))

;;; Print multiple spaces (since Advsys won't normally do this)

(define (spaces count &aux i)
  (setq i 1)
  (while (<= i count)
     (say " ")
     (setq i (+ i 1))))

;;; Print the contents of an object (used by "look")

(define (print-contents obj &aux desc)
  (setq obj (getp obj child))
  (while obj
     (cond ((and (= %curloc (getp obj initial-location))
             (setq desc (getp obj initial-description)))
        (say desc)
        (say " "))
           ((setq desc (getp obj description))
        (say desc)
        (say " ")))
     (if (send obj m-describe)
         (say " "))
     (setq obj (getp obj sibling)))
  (terpri))

;;; List the contents of an object (used for "inventory")

(define (list-contents obj indent &aux desc)
  (setq obj (getp obj child))
  (while obj
     (if (setq desc (getp obj short-description))
         (progn
          (spaces indent)
          (if (getp obj plural?)        ; don't print "a" or "an"
          (say desc)                    ; before plural objects
          (smarticle desc))
          (cond ((getp obj worn?)
             (say " (being worn)\n"))
            ((getp obj container?)
             (terpri)
             (if (seein? obj)
             (progn
              (spaces (+ indent 2))
              (if (getp obj child)
                  (progn
                   (message "The " obj " contains:\n")
                   (list-contents obj (+ indent 4)))
                  (message "The " obj " is empty.\n")))))
            (T (terpri)))))
     (setq obj (getp obj sibling))))

; ***********************
; MISCELLANEOUS FUNCTIONS
; ***********************

;;; Search for object in specified location -- uses noun phrase

(define (reachobject loc n &aux found next)
  (setq found nil)
  (if loc
      (progn
       (if (match loc n)
       (setq found loc))
       (setq next (reachobject (getp loc sibling) n))
       (if next
       (if found
           (complain "I don't know which " n " you mean!\n")
           (setq found next)))
       (if (open? loc)
       (setq next (reachobject (getp loc child) n))
       (setq next nil))
       (if next
       (if found
           (complain "I don't know which " n " you mean.\n")
           (setq found next)))
       found)
      nil))

(define (seeobject loc n &aux found next)
  (setq found nil)
  (if loc
      (progn
       (if (match loc n)
       (setq found loc))
       (setq next (seeobject (getp loc sibling) n))
       (if next
       (if found
           (complain "I don't know which " n " you mean!\n")
           (setq found next)))
       (if (seein? loc)
       (setq next (seeobject (getp loc child) n))
       (setq next nil))
       (if next
       (if found
           (complain "I don't know which " n " you mean.\n")
           (setq found next)))
       found)
      nil))

(define (cansee n &aux loc obj)
  (if (has-light? %curloc)
      (setq loc (getp %curloc child))
      (setq loc (getp adventurer child)))
  (if (match %curloc n)
      (setq loc %curloc))
  (if (setq obj (seeobject loc n))
      obj
      (progn
       (setq loc (getp adventurer parent))
       (if (not (has-light? %curloc))
       (error "It's too dark to see.\n"))
       (if (setq obj (seeobject loc n))
       obj
       (complain "I see no " n " here.\n")))))

(define (canreach n &aux loc obj)
  (if (has-light? %curloc)
      (setq loc (getp %curloc child))
      (setq loc (getp adventurer child)))
  (if (setq obj (reachobject loc n))
      obj
      (if (cansee n)
      (complain "You can't reach the " n "!\n"))))

;;; Search for object in specified location -- uses object number

(define (fobject-in node obj found)
  (while (and node (not found))
     (if (= node obj)
         (setq found T)
         (progn
          (if (seein? node)
          (setq found (fobject-in (getp node child) obj found)))
          (setq found (fobject-in (getp node sibling) obj found)))))
  found)

(define (findobject-in loc obj)
  (if (= (getp obj parent) nil)
      nil)
  (fobject-in (getp loc child) obj nil))

;;; Returns true if object is in location requested -- uses object number

(define (isin? loc obj)
  (and loc
       (or (= loc (getp obj parent))
       (isin? (getp obj parent) obj))))

;;; Find an object in the player's current location
;;; (or in the player's inventory) -- uses object number

(define (in-room obj)
  (isin? %curloc obj))

;;; Returns true if actor is holding object

(define (holding? obj)
  (= adventurer (getp obj parent)))

;;; Find an object in the actor's inventory -- uses noun phrase

(define (in-pocket n &aux obj)
  (if (and (setq obj (canreach n))
       (isin? %actor obj))
      obj
      (complain "You don't have any " n "!\n")))

;;; Find an object in another object -- uses noun phrase

(define (in-object loc n)
  (or (reachobject loc n)
      (complain "I see no " n " there!\n")))

; *******************
; CAPACITY PRIMITIVES
; *******************

;;; Returns the total weight of an object's contents
;;; usage: (totalweight (getp obj child))

(define (totalweight obj)
  (if obj
      (+ (getp obj size)
     (+ (totalweight (getp obj child))
        (totalweight (getp obj sibling))))
      0))

;;; Returns weight of an object plus its contents

(define (weight obj)
  (+ (getp obj size)
     (totalweight (getp obj child))))

;;; Returns free space in object

(define (space-in obj)
  (- (getp obj capacity)
     (totalweight (getp obj child))))

;;; Returns true if obj1 fits in obj2

(define (it-fits? obj1 obj2)
  (<= (weight obj1) (space-in obj2)))

; ********************
; BASIC OBJECT CLASSES
; ********************

; **************
; The fuse class
; **************

(object fuse
    (property
     next-event nil
     event-time 0)              ; game turn when event will occur
    (method (activate)          ; code for event
        nil))

(fuse event-list                ; for keeping track of events
      (property
       short-description "Event List"))

(fuse device-list               ; for keeping track of devices
      (property
       short-description "Device List"))

(fuse daemon-list               ; for keeping track of daemons
      (property
       short-description "Daemon List"))

; ******************
; The location class
; ******************

(basic-thing location
         (property
          child nil                     ; the first object in this location
          lit? T                        ; is this location lit?
          visited? nil)                 ; has the player been here yet?
         (method (knock? obj) T)        ; can we enter?
         (method (s-enter obj) T)       ; hook for entering special rooms
         (method (m-enter obj)
             (if (send self s-enter obj)
             (progn
              (move-to self obj)
              (if (not (getp self visited?))
                  (setq %score (+ %score (getp self value)))))))
         (method (leave obj dir &aux loc)
             (if (setq loc (getp self dir))
             (if (send loc knock? obj)
                 (send loc m-enter obj))
             (error "There is no exit in that direction.\n")))
         (method (search &aux desc)
             (if (setq desc (getp self long-description))
             (progn
              (say desc)
              (terpri)
              T)
             nil))
         (method (s-describe))          ; for special descriptions
         (method (m-describe)
             (if (has-light? self)
             (progn
              (say (getp self short-description))
              (terpri)
              (if (or (= %verbiage VERBOSE)
                  (and (not (getp self visited?))
                       (!= %verbiage BRIEF)))
                  (progn
                   (say (getp self description))
                   (say " ")))
              (send self s-describe)
              (print-contents self)
              (setp self visited? T))
             (say "It's too dark to see!\n")))
         (method (look)
             (if (has-light? self)
             (progn
              (say (getp self description))
              (say " ")
              (send self s-describe)
              (print-contents self))
             (say "It's too dark to see!\n"))))

; ****************
; The portal class
; ****************

(basic-thing portal
         (class-property
          closed? T
          locked? nil)
         (method (knock? obj)
             (or (open? self)
             (message "The " self " is closed.\n")))
         (method (s-enter obj) T)
         (method (m-enter obj)
             (if (send self s-enter obj)
             (send (getp (getp self other-side) parent)
                   m-enter obj)))
         (method (open)
             (cond ((open? self)
                (message "The " self " is already open.\n"))
               ((getp self locked?)
                (message "The " self " is locked.\n"))
               (T
                (setp self closed? nil)
                (message "" self " open.\n")))
             T)
         (method (close)
             (if (getp self closed?)
             (message "The " self " is already closed.\n")
             (progn
              (setp self closed? T)
              (message "" self " closed.\n")))
             T)
         (method (lock thekey)
             (cond ((open? self)
                (message "The " self " isn't closed.\n"))
               ((getp self locked?)
                (message "The " self " is already locked.\n"))
               ((!= thekey (getp self key))
                (message "The " thekey " doesn't fit the lock.\n"))
               (T
                (setp self locked? T)
                (message "" self " locked.\n")))
             T)
         (method (unlock thekey)
             (cond ((open? self)
                (message "The " self " is already open.\n"))
               ((not (getp self locked?))
                (message "The " self " isn't locked.\n"))
               ((!= thekey (getp self key))
                (message "The " thekey " doesn't fit the lock.\n"))
               (T
                (setp self locked? nil)
                (message "" self " unlocked.\n")))
             T)
         (method (l-describe)
             (if (getp self closed?)
             (message "The " self " is closed.")
             (message "The " self " is open."))
             T)
         (method (m-describe)
             (send self l-describe)))

; ***************
; The actor class
; ***************

(basic-thing actor
         (class-property
          actor? T
          capacity 6)
         (method (talk)         ; Return true if you can give
             T)                 ; this actor commands
         (method (move dir &aux obj sib)
             (setq obj (getp self child))
             (while obj
                (setq sib (getp obj sibling))
                (if (setq temp (getp obj tied-to))
                (if (and (!= (getp temp parent) self)
                     (!= temp self)
                     (getp temp takeable?))
                    (progn
                     (send (getp self parent) leave temp dir)
                     (message "You drag the " temp
                          " along with you.\n"))
                    (error2 "You'll have to drop the " obj
                        " or untie it from the " temp
                        " before you can move.\n")))
                (setq obj sib))
             (send (getp self parent) leave self dir))
         (method (take obj)
             (if (send obj take)
             (move-to self obj)
             nil))
         (method (drop obj)
             (if (send obj drop)
             (move-to (getp self parent) obj)
             nil))
         (method (receive obj)
             (send %actor drop obj)
             (send self take obj)
             (message "The " self " accepts your gift.\n")
             T)
         (method (give obj receiver)
             (send receiver receive obj))
         (method (carrying? obj)
             (= (getp obj parent) self))
         (method (inventory)
             (cond ((getp self child)
                (say "You are carrying:\n")
                (list-contents self 2))
               (T (say "You are empty-handed.\n")))))

; **************************************************************
; The "daemon" class (things that do something automatically)
; Every turn an "activate" signal is sent to all daemons
; You must declare daemons in the init handler with the command
;    (add-daemon object-name)
; Daemons may be removed with the command
;    (delete-daemon object-name)
; The following class is for daemon actors and handles movement
; **************************************************************

(actor daemon                   ; most daemons are alive
       (method (move dir &aux desc oldloc myloc)
           (setq oldloc (getp self parent))
           (setq myloc (getp adventurer parent))
           (if (send-super move dir)
           (progn
            (setq desc (getp self short-description))
            (if (= oldloc myloc)
            (progn
             (print "The ")
             (print desc)
             (print " exits ")
             (cond ((= dir north)
                (print "to the north"))
                   ((= dir south)
                (print "to the south"))
                   ((= dir east)
                (print "to the east"))
                   ((= dir west)
                (print "to the west"))
                   ((= dir northeast)
                (print "to the northeast"))
                   ((= dir northwest)
                (print "to the northwest"))
                   ((= dir southeast)
                (print "to the southeast"))
                   ((= dir southwest)
                (print "to the southwest"))
                   ((= dir up)
                (print "up"))
                   ((= dir down)
                (print "down")))
             (print ".\n")))
            (if (and (= myloc (getp self parent)) (= oldloc %curloc))
            (progn
             (print "The ")
             (print desc)
             (print " follows you.\n")))
            (if (and (= myloc (getp self parent)) (= myloc %curloc))
            (progn
             (print "The ")
             (print desc)
             (print " enters.\n"))))))
       (method (activate)))             ; what does it do?

; ********************************************
; The "thing" class (things that can be taken)
; ********************************************

(basic-thing thing
         (class-property
          takeable? T)
         (method (take) T)
         (method (drop) T))

; ****************************************
; The tieable-thing class.
; Things that can be tied to other things.
; ****************************************

(thing tieable-thing
       (class-property
    tieable? T)
       (property
    tied-to nil)
       (method (tie obj)
           (cond ((not (getp obj anchor?))
              (error1 "You can't tie anything to the " obj ".\n"))
             ((getp self tied-to)
              (error1 "It's already tied to the " obj ".\n"))
             ((setq temp (getp obj tied-to))
              (error2 "The " obj " is already tied to the " temp ".\n"))
             (T
              (if (send obj tie self)
              (progn
               (setp self tied-to obj)
               (setp obj tied-to self)
               (message2 "You deftly tie the " self " to the "
                     obj ".\n")
               T)
              nil))))
       (method (untie &aux obj)
           (setq obj (getp self tied-to))
           (if (not obj)
           (error1 "The " self " isn't tied to anything.\n"))
           (if (send obj untie self)
           (progn
            (setp obj tied-to nil)
            (setp self tied-to nil)
            (message "" self " untied.\n")
            T)
           nil))
       (method (l-describe &aux temp)
           (if (setq temp (getp self tied-to))
           (progn
            (message "It's tied to the " temp ".\n")
            T))))

; ****************************************
; The "anchor-thing" class.
; Things that other things can be tied to.
; ****************************************

(thing anchor-thing
       (class-property
    anchor? T)
       (property
    tied-to nil)
       (method (tie obj)
           T)
       (method (untie obj)
           T)
       (method (l-describe &aux temp)
           (if (setq temp (getp self tied-to))
           (progn
            (message "The " self " has ")
            (smarticle (getp temp short-description))
            (say " tied to it.")
            T))))

; *************************************************
; The "device" class (things that can be turned on)
; Devices must be declared in the init handler with
; the command (add-device object-name)
; *************************************************

(thing device
       (property
    device? T           ; object is a device
    on? nil)            ; true if object is on
       (method (turn-on)
           (if (getp self on?)
           (message "The " self " is already on.\n")
           (progn
            (message "" self " on.\n")
            (setp self on? T)))
           T)
       (method (turn-off)
           (if (not (getp self on?))
           (message "The " self " is already off.\n")
           (progn
            (message "" self " off.\n")
            (setp self on? nil)))
           T)
       (method (tick))                  ; hook for special events
       (method (empty)
           (setp self on? nil))         ; turn off device when empty
       (method (l-describe)
           (if (getp self on?)
           (message "The " self " is on.\n")
           (message "The " self " is off.\n"))
           T))

(device light-source                    ; device for creating light
    (property
     lit? nil)                          ; true if object is shedding light
    (method (turn-on)
        (send-super turn-on)
        (setp self lit? T)
        (if (not (getp %curloc lit?))
            (send %curloc m-describe))
        T)
    (method (turn-off)
        (setp self on? nil)
        (setp self lit? nil)
        (if (not (has-light? %curloc))
            (say "You are plunged into darkness.\n")
            (message "" self " off.\n"))
        T)
    (method (empty)
        (setp self on? nil)
        (setp self lit? nil)
        (if (in-room self)
            (progn
             (message "The " self " went out. ")
             (if (not (has-light? %curloc))
             (say "You are plunged into darkness."))
             (say "\n")))))

; *******************
; The container class
; *******************

(thing container
       (class-property
    container? T)
       (property
    closed? nil            ; Is it closed?
    locked? nil            ; Is it locked?
    clear? nil            ; Can we see through it?
    capacity 2)            ; Default carrying capacity
       (method (knock? obj)
           (or (open? self)
           (message "The " self " is closed.\n")))
       (method (get obj)
           (if (send self knock? obj)
           (progn
            (if (= self obj)
            (error1 "You can't put the " obj " in itself!\n"))
            (if (not (it-fits? obj self))
            (error1 "The " obj " won't fit!\n"))
            (move-to self obj)
            (say "Ok.\n")
            T)
           nil))
       (method (open)
           (cond ((open? self)
              (message "The " self " is already open.\n"))
             ((getp self locked?)
              (message "The " self " is locked.\n"))
             (T
              (setp self closed? nil)
              (message "" self " open.\n")))
           T)
       (method (close)
           (if (getp self closed?)
           (message "The " self " is already closed.\n")
           (progn
            (setp self closed? T)
            (message "" self " closed.\n")))
           T)
       (method (lock thekey)
           (cond ((open? self)
              (message "The " self " isn't closed.\n"))
             ((getp self locked?)
              (message "The " self " is already locked.\n"))
             ((!= thekey (getp self key))
              (message "The " thekey " doesn't fit the lock.\n"))
             (T
              (setp self locked? T)
              (message "" self " locked.\n")))
           T)
       (method (unlock thekey)
           (cond ((open? self)
              (message "The " self " is already open.\n"))
             ((not (getp self locked?))
              (message "The " self " isn't locked.\n"))
             ((!= thekey (getp self key))
              (message "The " thekey " doesn't fit the lock.\n"))
             (T
              (setp self locked? nil)
              (message "" self " unlocked.\n")))
           T)
       (method (l-describe)
           (if (seein? self)
           (progn
            (if (getp self child)
            (progn
             (message "The " self " contains:\n")
             (list-contents self 2))
            (message "The " self " is empty.\n"))
            T))))

; *************************
;    The clothing class
; (things that can be worn)
; *************************

(thing clothing
       (property
    worn? nil)
       (method (drop)
           (if (getp self worn?)
           (error "You'll have to take it off first!\n")
           T))
       (method (wear)
           (if (getp self worn?)
           (error1 "You're already wearing the " self "!\n"))
           (message "You put the " self " on.\n")
           (setp self worn? T))
       (method (remove)
           (if (getp %dobject worn?)
           (progn
            (message "You take off the " self ".\n")
            (setp self worn? nil)
            T)
           nil))
       (method (put obj)
           (if (getp self worn?)
           (error "You'll have to take it off first!\n")
           (send obj get self))))

; ****************************
; The "stationary-thing" class
; (things that can't be moved)
; ****************************

(basic-thing stationary-thing)

; ***************
; ACTION DEFAULTS
; ***************

(default
  (actor optional))

; ******************
; ACTION DEFINITIONS
; ******************

;;; Is the object accessible?  Currently only checks to see if the
;;; parent is "open" but may be expanded in the future.

(define (accessible obj)
  (send (getp obj parent) knock? obj))

(action a-look
    (verb look)
    (code
     (send %curloc look)))

(action a-look-in
    (verb (look in))
    (direct-object)
    (code
     (setq %dobject (cansee $dobject))
     (if (not (getp %dobject container?))
         (error "Don't be silly.\n"))
     (if (seein? %dobject)
         (if (getp %dobject child)
         (progn
          (message "The " %dobject " contains:\n")
          (list-contents %dobject 2))
         (message "The " %dobject " is empty.\n")))))

(action a-take
    (verb take (pick up))
    (direct-object)
    (preposition from)
    (indirect-object optional)
    (code
     (setq %dobject (canreach $dobject))
     (if $iobject
         (setq %iobject (canreach $iobject)))
     (if (not (getp %dobject takeable?))
         (complain "You can't take the " $dobject "!\n"))
     (if (= (getp %dobject parent) %actor)
         (complain "You are already carrying the " $dobject "!\n"))
     (if (> (weight %dobject) (getp %actor capacity))
         (complain "The " $dobject " is much too heavy to lift.\n"))
     (if (not (it-fits? %dobject %actor))
         (complain "The " $dobject " is too heavy.  You'll have to
            drop something first.\n"))
     (if (send %actor take %dobject)
         (message "" %dobject " taken.\n"))))

(action take-err
    (verb take (pick up))
    (code
     (error "Take what?\n")))

(action a-wear
    (verb wear (put on))
    (direct-object)
    (code
     (setq %dobject (in-pocket $dobject))
     (if (not (send %dobject wear))
         (error "Wouldn't you prefer a nice lampshade?\n"))))

(action wear-err
    (verb wear (put on))
    (code
     (error "Wear what?\n")))

(action a-remove
    (verb remove (take off))
    (direct-object)
    (code
     (setq %dobject (in-pocket $dobject))
     (if (not (send %dobject remove))
         (complain "You aren't wearing the " $dobject "!\n"))))

(action remove-err
    (verb remove (take off))
    (code
     (error "Take off what?\n")))

(action a-drop
    (verb drop (put down))
    (direct-object)
    (code
     (setq %dobject (in-pocket $dobject))
     (if (send %actor drop %dobject)
         (message "" %dobject " dropped.\n"))))

(action drop-err
    (verb drop (put down))
    (code
     (error "Drop what?\n")))

(action a-put
    (verb put)
    (direct-object)
    (preposition in)
    (indirect-object)
    (code
     (setq %dobject (in-pocket $dobject))
     (setq %iobject (canreach $iobject))
     (if (not (send %dobject put %iobject))
         (complain "You can't put anything in the " $iobject "!\n"))))

(action put-err
    (verb put)
    (direct-object optional)
    (code
     (if $dobject
         (complain "Put the " $dobject " where?\n")
         (error "Put what?\n"))))

(action a-inventory
    (verb inventory)
    (code
     (send %actor inventory)))

(action a-open
    (verb open)
    (direct-object)
    (code
     (setq %dobject (canreach $dobject))
     (if (not (send %dobject open))
         (complain "You can't open the " $dobject ".\n"))))

(action open-err
    (verb open)
    (code
     (error "Open what?\n")))

(action a-close
    (verb close)
    (direct-object)
    (code
     (setq %dobject (canreach $dobject))
     (if (not (send %dobject close))
         (complain "You can't close the " $dobject ".\n"))))

(action close-err
    (verb close)
    (code
     (error "Close what?\n")))

(action a-lock
    (verb lock)
    (direct-object)
    (preposition with)
    (indirect-object)
    (code
     (setq %dobject (canreach $dobject))
     (setq %iobject (in-pocket $iobject))
     (if (not (send %dobject lock %iobject))
         (complain "There's no way to lock the " $dobject ".\n"))))

(action lock-err
    (verb lock)
    (direct-object optional)
    (code
     (if $dobject
         (complain "Lock the " $dobject " with what?\n")
         (error "Lock what?\n"))))

(action a-unlock
    (verb unlock)
    (direct-object)
    (preposition with)
    (indirect-object)
    (code
     (setq %dobject (canreach $dobject))
     (setq %iobject (in-pocket $iobject))
     (if (not (send %dobject unlock %iobject))
         (complain "You can't unlock the  " $dobject ".\n"))))

(action unlock-err
    (verb unlock)
    (direct-object optional)
    (code
     (if $dobject
         (complain "Unlock the " $dobject " with what?\n")
         (error "Unlock what?\n"))))

(action a-tie
    (verb tie)
    (direct-object)
    (preposition to)
    (indirect-object)
    (code
     (setq %dobject (in-pocket $dobject))
     (setq %iobject (canreach $iobject))
     (if (getp %dobject tieable?)
         (send %dobject tie %iobject)
         (complain "You can't tie the " $dobject " to anything!\n"))))

(action tie-err
    (verb tie)
    (direct-object optional)
    (code
     (if $dobject
         (complain "Tie the " $dobject " to what?\n")
         (error "Tie what?\n"))))

(action a-untie
    (verb untie)
    (direct-object)
    (code
     (setq %dobject (canreach $dobject))
     (if (not (send %dobject untie))
         (complain "It's not tied to anything!\n"))))

(action untie-err
    (verb untie)
    (code
     (error "Untie what?\n")))

(action a-examine
    (verb examine search (look at))
    (direct-object optional)
    (code
     (if $dobject
         (progn
          (setq %dobject (cansee $dobject))
          (if (setq desc (getp %dobject long-description))
          (progn
           (say desc)
           (say " ")))
          (if (or (send %dobject l-describe) desc)
          (say "\n")
          (message "I see nothing special about the " %dobject ".\n")))
         (if (not (send %curloc search))
         (say "You don't find anything.\n")))))

(action a-give
    (verb give)
    (direct-object)
    (preposition to)
    (indirect-object)
    (code
     (setq %dobject (in-pocket $dobject))
     (setq %iobject (canreach $iobject))
     (if (not (send %actor give %dobject %iobject))
         (message2 "The " %dobject " ignores your " %iobject ".\n"))))

(action give-err
    (verb give)
    (direct-object optional)
    (code
     (if $dobject
         (complain "Give the " $dobject " to whom?\n")
         (error "Give what?\n"))))

(action a-read
    (verb read)
    (direct-object)
    (code
     (setq %dobject (cansee $dobject))
     (send %dobject read)))

(action read-err
    (verb read)
    (code
     (error "Read what?\n")))

; ****************
; SCORING ROUTINES
; ****************

(define (score-object obj score)
  (setq obj (getp obj child))
  (while obj
     (setq score (+ score (getp obj value)))
     (if (getp obj child)
         (setq score (score-object obj score)))
     (setq obj (getp obj sibling)))
  score)

(define (your-score)
  (score-object adventurer %score))

(action a-score
    (verb score)
    (code
     (if (= %maxscore 0)
         (progn
          (print "Scoring is not used in this adventure.\n")
          (abort))            ; score shouldn't cost a turn
         (progn
          (print "You have ")
          (print-number (your-score))
          (print " out of ")
          (print-number %maxscore)
          (print " points in ")
          (print-number %gametime)
          (print " turns.\n")
          (abort)))))        ; score shouldn't cost a turn

;;; Simple endgame routine

(define (endgame)
  (if (!= %maxscore 0)
      (progn
       (terpri)
       (print "In ")
       (print-number %gametime)
       (print " turns you've earned ")
       (print-number (your-score))
       (print " out of a possible ")
       (print-number %maxscore)
       (print " points.\n")))
  (terpri)
  (print "Do you want to try again? ")
  (if (yes-or-no)
      (restart)
      (exit)))

; *********************
; GAME CONTROL COMMANDS
; *********************

(action a-save
    (verb save)
    (code
     (save)))

(action a-restore
    (verb restore)
    (code
     (restore)))

(action a-restart
    (verb restart)
    (code
     (restart)))

(action a-wait
    (verb wait)
    (code
         (say "Time passes...\n")))

(action a-verbose
    (verb verbose)
    (code
     (say "From now on I will always print the long description of your
           location. You may return to normal with the \"normal\" command
           or select brief descriptions only with \"brief\".\n")
     (setq %verbiage VERBOSE)))

(action a-normal
    (verb normal)
    (code
     (say "From now on I will only print the long description of your
           location when you first enter a room or type \"look\".  Use
           the \"verbose\" command to always get long descriptions or
           select brief descriptions only with \"brief\".\n")
     (setq %verbiage NORMAL)))

(action a-brief
    (verb brief)
    (code
     (say "From now on I will only print the long description of your
           location when you type \"look\".  You may return to normal
           with the \"normal\" command or select long descriptions only
           with \"verbose\".\n")
     (setq %verbiage BRIEF)))

(action a-quit
    (verb quit)
    (code
     (if (!= %maxscore 0)
         (progn
          (say "If you were to quit now you would have ")
          (say-number (your-score))
          (say " out of a possible ")
          (say-number %maxscore)
          (say " points.\n")
          (terpri)))
     (say "Are you sure you want to quit? ")
     (if (yes-or-no)
         (exit))))

; **************
; TRAVEL ACTIONS
; **************

(action a-north
    (verb north (go north))
    (code
     (send %actor move north)))

(action a-south
    (verb south (go south))
    (code
     (send %actor move south)))

(action a-east
    (verb east (go east))
    (code
     (send %actor move east)))

(action a-west
    (verb west (go west))
    (code
     (send %actor move west)))

(action a-northeast
    (verb northeast (go northeast))
    (code
     (send %actor move northeast)))

(action a-northwest
    (verb northwest (go northwest))
    (code
     (send %actor move northwest)))

(action a-southeast
    (verb southeast (go southeast))
    (code
     (send %actor move southeast)))

(action a-southwest
    (verb southwest (go southwest))
    (code
     (send %actor move southwest)))

(action a-in
    (verb enter (go in))
    (code
     (send %actor move enter)))

(action a-out
    (verb exit (go out))
    (code
     (send %actor move exit)))

(action a-up
    (verb up (go up))
    (code
     (send %actor move up)))

(action a-down
    (verb down (go down))
    (code
     (send %actor move down)))

; ********************
; SCHEDULING FUNCTIONS
; ********************

;;; Schedule an event.
;;;
;;; Takes an object and a time.  Use negative numbers for relative time.
;;; Will send the object an ACTIVATE message at the given time.

(define (schedule obj time &aux event)
  (setq event event-list)
  (while (getp event next-event)
     (setq event (getp event next-event)))
  (setp event next-event obj)
  (if (< time 0)
      (setq time (+ (abs time) %gametime)))
  (setp obj event-time time)
  (setp obj next-event nil))

;;; Get the event that happens now.
;;; Remove events as they occur.

(define (get-event &aux event prev)
  (setq prev event-list)
  (setq event (getp event-list next-event))
  (while event
     (if (>= %gametime (getp event event-time))
         (progn
          (if prev            ; delete event from list
          (setp prev next-event (getp event next-event))
          (setp event-list next-event (getp event next-event)))
          (return event))
         (progn
          (setq prev event)
          (setq event (getp event next-event))))))

;;; Add an event to any list except (ironically) event-list

(define (add-event obj elist &aux event)
  (setq event elist)
  (while (getp event next-event)
     (setq event (getp event next-event)))
  (setp event next-event obj)
  (setp obj next-event nil))

;;; Delete an event from any list

(define (delete-event obj elist &aux prev event)
  (setq event (getp elist next-event))
  (setq prev elist)
  (while event
     (if (= obj event)
         (setp prev next-event (getp event next-event)))
     (setq prev event)
     (setq event (getp event next-event))))

; ***************
; DEVICE HANDLERS
; ***************

;;; Add a device to the device list

(define (add-device obj)
  (add-event obj device-list))

;;; Drain active devices.  Remove empty devices from list

(define (drain-devices &aux prev obj amount)
  (setq obj (getp device-list next-event))
  (setq prev device-list)
  (while obj
     (setq amount (getp obj power-drain))
     (if (> amount 0)
         (if (> (getp obj power) 0)
         (progn
          (send obj tick)    ; hook for special events, like
                    ; "Your lamp is getting dim."
          (setp obj power (- (getp obj power) amount))
          (setq prev obj))
         (progn
          (send obj empty)
          (if prev        ; delete device from active list
              (setp prev next-event (getp obj next-event))
              (setp device-list next-event (getp obj next-event))))))
     (setq obj (getp obj next-event))))

; ***************
; DAEMON HANDLERS
; ***************

;;; Add a daemon to the daemon list

(define (add-daemon obj)
  (add-event obj daemon-list))

;;; Activate daemons

(define (activate-daemons &aux obj)
  (setq obj (getp daemon-list next-event))
  (while obj
     (send obj activate)
     (setq obj (getp obj next-event))))

; ***********************************
; Do all those things we do each turn
; ***********************************

(define (next-turn)
  (setq %gametime (+ %gametime %turnlength))
  (while (setq event (get-event))    ; check events
     (send event activate))
  (setq %msgs? nil)            ; no messages for daemons
  (activate-daemons)            ; make daemons move
  (setq %msgs? T)            ; allow messages again
  (drain-devices))            ; drain active devices

; **********************
; The great "ALL" kludge
; **********************

(define (take-all loc &aux obj sib)
  (setq obj (getp loc child))
  (while obj
     (setq sib (getp obj sibling))
     (if (and (getp obj takeable?)
          (not (getp obj notake?))
          (!= obj %actor))
         (if (not (it-fits? obj %actor))
         (error "The " obj " is too heavy.  You'll have to drop
             something first.\n")
         (if (send %actor take obj)
             (progn
              (message "" obj " taken.\n")
              (next-turn)))))
     (setq obj sib))
  (abort))

(define (drop-all loc &aux obj sib)
  (setq obj (getp loc child))
  (while obj
     (setq sib (getp obj sibling))
     (if (send %actor drop obj)
         (progn
          (message "" obj " dropped.\n")
          (next-turn)))
     (setq obj sib))
  (abort))

(action a-take-all
    (verb (take all) (pick up all))
    (code
     (take-all (getp %actor parent))))

(action a-take-all-from
    (verb (take all from))
    (direct-object)
    (code
     (setq %dobject (canreach $dobject))
     (if (not (getp %dobject container?))
         (complain "You can't take anything from the " $dobject ".\n"))
     (if (send %dobject knock? %dobject)
         (take-all %dobject))))

(action a-drop-all
    (verb (drop all) (put down all))
    (code
     (drop-all %actor)))

(action a-turn-on
    (verb on (turn on))
    (direct-object)
    (code
     (setq %dobject (canreach $dobject))
     (if (getp %dobject device?)
         (if (send %dobject turn-on)
         (add-device %dobject))
         (complain "How do I turn on the " $dobject "?\n"))))

(action turn-on-err
    (verb (turn on) on)
    (code
     (error "What do you want to turn on?\n")))

(action a-light
    (verb light)
    (direct-object)
    (code
     (setq %dobject (in-pocket $dobject))
     (if (!= (class %dobject) light-source)
         (complain "I see no way to light the " $dobject ".\n"))
     (if (send %dobject turn-on)
         (add-device %dobject))))

(action light-err
    (verb light)
    (code
     (error "Light what?\n")))

(action a-turn-off
    (verb off (turn off))
    (direct-object)
    (code
     (setq %dobject (in-pocket $dobject))
     (if (getp %dobject device?)
         (complain "I don't know how to turn off the " $dobject ".\n"))
     (if (send %dobject turn-off)
         (delete-event %dobject device-list))))

(action turn-off-err
    (verb off (turn off))
    (code
     (error "What are you trying to turn off?\n")))

;;; LIMBO - Convenient location for not-yet-discovered items

(location limbo
  (noun limbo)
  (property
   short-description "Limbo."
   description "You shouldn't be here, go away!"))

; *******************
; HANDLER DEFINITIONS
; *******************

(init
 (connect-all)
 (print welcome)
 (setq %curloc nil)
 (setq %gametime 0)
 (setq %turnlength 1)
 (setq %verbiage normal)
 (setq %score 0)
 (setq %maxscore 0))

(update
 (setq %msgs? T)
 (if (!= (getp adventurer parent) %curloc)
     (progn
      (setq %curloc (getp adventurer parent))
      (send %curloc m-describe))))

(before
 (setq %actor adventurer)
 (if $actor
     (progn
      (setq %actor (cansee $actor))
      (if (not (getp %actor actor?))
      (complain "You can't talk to the " $actor "!\n"))
      (if (not (send %actor talk))
      (abort)))))

(after
 (next-turn))