;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;
; Program: GINAS default definitions file
;
; Version 0.1, January 1994.
; Version 0.2, October 1994.
; Version 0.3, February 1995.
; Version 0.4, August 1995.
;
; Copyright 1994, 1995, Jeff Standish.  (jestandi@cs.indiana.edu)
; All rights reserved.
;
; Permission is hereby granted for unrestricted non-commercial use,
; provided full attribution of source code origin is included.
;
;
; Version 0.1
;     Basic class and action definitions given.  A simple exploration
; world is defined for testing the LISP operators and the initial class
; definitions.
;
; Version 0.2
;     The concept of regions is implemented, so that the simulated world
; and be easily subdivided, allowing for inactive regions to be saved to
; disk to reduce memory usage.  The code for automatically deactivating
; regions was not implemented.
;     This was the version given limited release over the internet via
; e-mail to a handful of interested individuals.
;
; Version 0.3
;     The objects from the initial world (an incomplete tower) were
; stripped out, since this definition file should be limited to just
; class and action prototypes, along with other generic functions useful
; to most games.
;     The code for doing regions was commented out, since regions are
; not really important to simulated environments (although they are useful).
;
; Version 0.4
;     The structures of the classes was refined, splitting poorly-defined
; classes into more reasonably defined ones (such as converting the <table>
; class into the <on-container> class).  The <root-class> was also defined
; to give some commonality to the <location> and <thing> classes.
;     The means by which actions are called was reset by defining the
; <perform-action> function, which allowed for the addition of <before> and
; <after> conditions to be added to the <do-...> methods, so that each object
; can have preconditions and postconditions to be fulfilled when an action is
; attempted.
;     With the rewriting of the built-in parser, the <player-daemon> daemon
; was written, since it is now the duty of the actor's daemon to call the
; parser.  This allowed for some pre-parsing of player's commands, such as
; the handling of pronouns and multiple commands in the same input line.
;     Extensive commenting of the code was finally done, along with
; rewritting of the actions so that textual responses were conditional upon
; whether the action is being performed by the player or some other actor
; in the game, allowing all actors to use the same methods for performing
; actions (thus enabling the existence of robots which the player can
; command to perform actions).
;     The code for doing regions was yanked out and moved to a separate
; file, since it had been commented out for some time, and is not likely to
; be used in a normal game.
;     Code for hiding objects was implemented, along with searching and
; noting found objects which are still "hidden".
;
;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-


;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;
; This file is split up into three different sections:
;	1. general-use functions
;	2. class definitions
;	3. action definitions
;
; how to use <after> and <before> methods
; need to rewrite <before> and <after> since cannot have multiple ones
; use of <scenery-objects>
;
;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-



;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;
; Here are some standard global variable initializations:
;	*collection-messages*	defaults to nil
;	*warning-messages* 	defaults to t
;	*debug*			defaults to t

; ignore whether locations are illuminated
;
(set *ignore-lighting* t)

; turn off garbage-collection messages
;
; (set *collection-messages* nil)

; turn off warning messages
;
; (set *warning-messages* nil)

; turn off debugging system
;
; (set *debug* nil)

; enable the GinaLisp action for activating the interactive LISP interpreter
;
(set *no-ginas* nil)

; initial score set to zero
;
(set score 0)


;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;
; Here are some useful global functions that can be used by any method,
; class, or action to help make some operations easier.
;


; (max x y)
;	Return the largest of the given values.
;
(function max (first . rest)
    (let ((rslt))
	 (if (null? rest)
	     (return first))
	 (set rslt (eval (cons 'max rest)))
	 (cond ((not (number? first))
		rslt)
	       ((and (number? rslt)
		     (> rslt first))
		rslt)
	       (t
		first))))


; (reverse lst)
;	Given a list, reverse the order of the members of the list.
;
(function reverse (lst)
    (let ((tally))
	 (loop (if (or (null? lst) (not (list? lst)))
		   (return tally))
	       (set tally (cons (car lst) tally))
	       (set lst (cdr lst)))))


; (yes-or-no)
;	Prompts for a yes/no response from the player, returning true if
;	it is "Yes".
;
(function yes-or-no ()
    (let ((response (car (readsentence))))
	 (or (samestring? response "y")
	     (samestring? response "yes"))))


; (player-message actor <mesg 1> ... <mesg n>)
;	Will print the given message only if the specified actor is the
;	is the player's actor (as stored in <*player*>).
;
(function player-message (actor . mesg)
    (if (= actor *player*)
	(print mesg)))


; (location-message objptr <mesg 1> ... <mesg n>)
;	Will print the message only if the player's actor, as stored in
;	<*player*>, is in the same location as the given object.
;
(function location-message (objptr . mesg)
    (if (same-location? objptr *player*)
	(print mesg)))


; (contained-in? obj par)
;	Given pointers to two objects, return true if <objptr> is a descendant
;	of <par> (i.e., if <obj> is contained in <par>).
;
(function contained-in? (objptr par)

	; make sure both pointers are non-nil object pointers
    (if (or (null? objptr) (null? par) (not (object? objptr))
	    (not (object? par)))
	(exit))

	; follow <objptr>'s parent pointers upwards until hit <par> or run
	; out of pointers
    (loop (if (null? objptr) (return nil))
	  (if (equal? objptr par) (return t))
	  (set objptr (parent objptr))))


; (valid-object? objptr actptr)
;	This function is used to limit the scope of objects that can be
;	accessed with actions.  By default it will return true if the
;	given object is a scenery object associated with the location
;	of the actor, or if it is located in the location of the actor,
;	and is not concealed inside of something.
;
(function valid-object? (objptr actptr)
    (if (and (contained-in? objptr (findobject 'scenery-objects))
	     (member (objectname (location-of actptr))
		     (getprop objptr 'found_in)))
	(return t))
    (loop (if (not (method objptr is-visible? actptr))
	      (return nil))
	  (if (or (= (parent objptr) (parent actptr))
		  (= (parent objptr) actptr))
	      (return t))
	  (if (not (subclassof? (parent objptr) 'root-class))
	      (return nil))
	  (if (not (method (parent objptr) contents-visible? actptr))
	      (return nil))
	  (set objptr (parent objptr))))



; (list-objects actptr objlist)
;	Given a list of object pointers, print out a brief description of
;	each object, separated by a comma.  Uses the <descbrief> method
;	for presenting a brief description of the objects.
;
(function list-objects (actptr objlist)
    (let ((len (length objlist))	; get the length of the list
	  (count 1))			; keep count of objects already listed
	 (loop (if (null? objlist)	; halt when run out of objects
		   (exit))
	       (if (> count 1)		; before each description print a
		   (if (> len 2)	; comma, unless is first entry or
		       (print ", ")	; there are less than three entries
		       (print " ")))
	       (if (and (= count len) (> len 1))	; put "and" before last
		   (print "and "))			; entry in list
	       (method (car objlist) descbrief actptr)	; print description
	       (set count (1+ count))		; increase count of object done
	       (set objlist (cdr objlist)))))	; move to next object in list


; (visible-contents actptr content)
;	Given a pointer to an object, return a list of pointers to it and
;	all of its siblings, including only those which are visible, using
;	the <is-visible?> method.  This is useful for excluding invisible
;	objects from descriptions.
;
(function visible-contents (actptr content)
    (let ((viscont nil))
	 (loop (if (null? content)
		   (return viscont))
	       (if (method content is-visible? actptr)
		   (set viscont (cons content viscont)))
	       (set content (sibling content)))))


; (list-getables locale)
;	Returns a list of getable objects in the given location.
;
(function list-getables (locale)
    (let ((objptr (child locale))
	  (tally))
	 (loop (if (null? objptr)
		   (return tally))
	       (if (method objptr is-getable?)
		   (set tally (cons objptr tally)))
	       (set objptr (sibling objptr)))))


; (location-of objptr)
;	Given a pointer to an object, return the location it is in by
;	searching up the parent list until hit a location.  If not in
;	a location, or not a valid object pointer, return nil.
;
(function location-of (objptr)
    (loop (if (not (object? objptr))
	      (return "not a location"))
	  (if (subclassof? objptr 'location)
	      (return objptr))
	  (set objptr (parent objptr))))


; (same-location? objptr actptr)
;	Returns true if both given objects are in the same location.
;
(function same-location? (objptr actptr)
    (= (location-of objptr) (location-of actptr)))


; (move-by-name objname locname)
;	Move the named object to the named place.
;
(function move-by-name (objname locname)
    (method (findobject objname) clear-hidden)
    (move (findobject objname) (findobject locname)))


; (move-to-location actptr place)
;	Given a pointer to an actor and a place, try to move the actor to
;	the place.  If <place> is an object pointer, then move the actor into
;	that object.  Otherwise, it is assumed to not be a valid location
;	to move to.  If <place> is a string, then it is assumed to be a
;	failure message which is printed out.  Otherwise a generic failure
;	message is printed.
;	If successfully moved to <place> the <descfull> method is used to
;	give a description of the new location.
;
(function move-to-location (actptr place)
    (cond ((object? place)
	   (let ((oldloc (location-of actptr)))
		(location-message place "\c" (method actptr get-name-def)
				" has just arrived.\n")
		(move actptr place)
		(method actptr clear-hidden)
		(method place upon-entry actptr)
		(method (location-of actptr) descfull actptr)
		(method (location-of actptr) visit actptr)
		(location-message oldloc "\c" (method actptr get-name-def)
			" has just left.\n")))
	  ((string? place)
	   (print place))
	  (t
	   (player-message actptr "You cannot move in that direction.\n"))))


; (portal-by-dir objptr dir)
;	Search through some objects, looking for a portal that exits in the
;	given direction, until either a portal with the given direction is
;	found, or until all siblings have been searched.
;
(function portal-by-dir (objptr dir)
    (loop (cond ((null? objptr)
		 (return nil))
		((and (object? objptr)
		      (subclassof? objptr 'portal)
		      (= dir (method objptr get-direction)))
		 (return (method objptr get-dir))))
	  (set objptr (sibling objptr))))


; (kill-player)
;	This function tends to killing off the player and ending the game.
;
(function kill-player ()
    (print "*** You have died ***\n")
    (terminate))


; (max-lift actptr)
;	Return the maximum amount of weight the actor can lift.
;	Defaults to returning 1000 units of weight.
;
(function max-lift (actptr)
    1000)


; (show-status)
;	Gives the current status of the player from the Status command.
;
(function show-status (actptr)
    (print "Weight carried: " (method actptr weight-contained)
	   " of " (max-lift actptr) "\n"))


; (exit-game)
;	This function takes care of any final closing messages.
;
(function exit-game ()
    (print "Game over.\n")
    (terminate))


; (perform-action actionname actptr objptr indptr)
;	This function takes care of invoking actions on the given object.
;	If the <before> method for the object returns a true value, then
;	the action can be performed, otherwise the action is aborted.  If
;	the action is performed and returns true, the <after> method is
;	invoked, in case anything special is desired, so this function will
;	only return true if all three methods return true.
;
(function perform-action (actionname actptr objptr indptr mesg)
    (and (method objptr before actptr indptr actionname)
	 (eval (list 'method objptr actionname actptr indptr 'mesg))
	 (method objptr after actptr indptr actionname)))


; (PrintObjectName objptr)
;	This function is required by the built-in parser to print out
;	the name of an object using the definite article `the'.
;
(function PrintObjectName (objptr)
    (print (method objptr get-name-def)))


; first-sentence (lst)
;	Given a list containing strings of words from (readsentence),
;	this function removes the first sentence from the list (using
;	periods and the word "then" to delimit sentences), and returns
;	a list whose car is the first sentences and whose cdr is any
;	remaining sentences.
;
(function first-sentence (lst)
    (let ((first))
	 (loop (if (null? lst)
		   (return (cons (reverse first) lst)))
	       (if (or (samestring? "." (car lst))
		       (samestring? "then" (car lst)))
		   (return (cons (reverse first) (cdr lst))))
	       (set first (cons (car lst) first))
	       (set lst (cdr lst)))))


; (and-to-comma lst)
;	Goes through a list containing strings of words from (readsentence)
;	and replaces all "and" with ",", unless there is a "," before
;	the "and".
;
(function and-to-comma (lst)
    (let ((result)
	  (prev))
	 (loop (cond ((or (null? lst)
			  (not (list? lst)))
		      (return (reverse result)))
		     ((and (or (samestring? "and" (car lst)) (= "," (car lst)))
			   (= prev ","))
		      (set lst (cdr lst)))
		     ((samestring? "and" (car lst))
		      (set result (cons "," result))
		      (set prev ",")
		      (set lst (cdr lst)))
		     (t
		      (set prev (car lst))
		      (set result (cons prev result))
		      (set lst (cdr lst)))))))


;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;
; Here are the default generic class definitions.
;

; Class: root-class
; Metaclasses:
;
; Properties:
;   ldesc
;	This is a string which is displayed to describe the object.
;
; Methods:
;   (any-child-sheds-light?)
;	Returns true if any of the object's children shed light.
;
;   (contents-visible? actptr)
;	Returns true if <actptr> can see the contents of this object.
;
;   (is-getable?)
;	Returns true if the object can be taken.
;
;   (total-weight)
;	Returns the total weight of this object, along with the weight of all
;	objects contained within it.
;
;   (weight-contained)
;	Returns the total weight of all objects contained within this object.
;
;   (do-examine actptr)
;	Print out a full description of this object using the <descfull>
;	method.
;
;   (descfull actptr)
;	Print out a full description of this object using the <ldesc> property.
;
;   (before actptr indptr actionname)
;	This method is called by the <perform-action> function, and is
;	intended to add extra functionality to action methods, so that the
;	method can be preempted by any special preconditions (such as
;	aborting the <do-get> method if the object is on fire).
;	If this method returns nil, then the action will not be performed.
;	<actionname> contains the name of the action that will be performed
;	if this method returns true.
;
;   (after actptr indptr actionname)
;	This method is called after an action is successfully performed
;	by a call from the <perform-action> function.  <actionname> is the
;	name of the action method which was called.  The result of this
;	method (either true of nil) is the result which is returned by
;	<perform-action>, and hence the return value of the built-in
;	(parser ...) function.
;	So this method could be used in the case of treasure items which
;	give points to the player when successfully taken.
;	
(class root-class ()
	()
	((any-child-sheds-light? ()
	    (let ((objptr (child self)))
		 (loop (if (null? objptr)
			   (return nil))
		       (if (method objptr sheds-light?)
			   (return t))
		       (set objptr (sibling objptr)))))
	 (contents-visible? (actptr)
	    t)
	 (is-getable? ()
	    nil)
	 (total-weight ()
	    (+ (get-weight) (weight-contained)))
	 (weight-contained ()
	    (let ((objptr (child self))
		  (tally 0))
		 (loop (if (null? objptr)
			   (return tally))
		       (set tally (+ tally (method objptr total-weight)))
		       (set objptr (sibling objptr)))))
	 (do-examine (actptr)
	    (if (= actptr *player*)
		(descfull actptr))
	    t)
	 (descfull (actptr)
	    (if (= actptr *player*)
		(if (hasprop self 'ldesc)
		    (print (getprop self 'ldesc) "\n")
		    (print "There is nothing unusual about it.\n"))))
	 (before (actptr indptr actionname)
	    t)
	 (after (actptr indptr actionname)
	    t)
	))


; Class: location
; Metaclasses: root-class
;
;	The location class contains the default methods for locations.
;
; Properties:
;   baddir
;	If defined, this property should be given a string which will be
;	displayed if the player attempts to move in any invalid direction.
;
;   light
;	If this property is defined, then the location is illuminated.  This
;	only matters if *ignore-lighting* is nil.
;
;   name
;	This is the name of the location, which is given in the description
;	of the location as displayed by the <describe-location> method.
;
;   visitors
;	This property keeps a list of all actors who have visited the current
;	location.
;
; Methods:
;   (get-dir dir)
;	Given the name of a direction (north, south, up, down, etc.),
;	return a pointer to the location which lies in that direction,
;	or nil if movement in the given direction is not possible.
;
;   (...-dir actptr)
;	Returns results of the <get-dir> method for the appropriate direction.
;
;   (upon-entry actptr)
;	This method is called when the player enters this location.  It does
;	nothing by default, but can be used to set special flags or display
;	special messages which should only be done when the player first
;	enters this location.
;
;   (do-jump actptr)
;	This action method is invoked whenever <actptr> tries to jump in the
;	current location.
;
;   (do-swim actptr)
;	This action method is invoked whenever <actptr> attempts to swim in
;	the currect location.
;
;   (do-wave-hands)
;	This action is invoked whenever <actptr> waves in the current location.
;
;   (visit actptr)
;	When invoked, is method marks the current location as having been
;	visited by the <actptr>.
;
;   (is-illuminated?)
;	Returns true if the location is illuminated.  If the *ignore-lighting*
;	global variable is true, then lighting conditions are always ignored
;	and all locations assumed to be illuminated.  Otherwise, a location
;	is only considered to be illuminated if it has the <light> property
;	or if an object within it sheds light.
;
;   (get-name)
;	Returns the name of the current object, as defined by the <name>
;	property.
;
;   (descfull actptr)
;	Give a full description of the location, along with any objects which
;	are at the location.  First looks for the <ldesc> property, which
;	should have a string description of the location.  If no such
;	property can be found, it defaults to a bland description.
;
;   (describe-location actptr)
;	Describes the location to <actptr>.
;
;   (describe-contents actptr)
;	Describes the contents of the location to <actptr>.
;
(class location (root-class)
	((baddir . "You cannot move in that direction. "))
	((get-dir (dir)
		; if want to use the regions, change the following call to
		; <findobject> with a call to <find-obj-by-region>
	    (let ((prop (or (getprop self dir)
			    (portal-by-dir (child self) dir))))
		 (cond ((string? prop)
			prop)
		       ((null? prop)
			(getprop self 'baddir))
		       (t (findobject prop)))))
	 (northeast-dir (actptr) (get-dir 'northeast))
	 (northwest-dir (actptr) (get-dir 'northwest))
	 (southeast-dir (actptr) (get-dir 'southeast))
	 (southwest-dir (actptr) (get-dir 'southwest))
	 (north-dir (actptr) (get-dir 'north))
	 (south-dir (actptr) (get-dir 'south))
	 (east-dir (actptr) (get-dir 'east))
	 (west-dir (actptr) (get-dir 'west))
	 (down-dir (actptr) (get-dir 'down))
	 (up-dir (actptr) (get-dir 'up))
	 (in-dir (actptr) (get-dir 'in))
	 (out-dir (actptr) (get-dir 'out))
	 (upon-entry (actptr) nil)
	 (do-jump (actptr)
	    (player-message actptr "Whee! Are we having fun yet?\n"))
	 (do-swim (actptr)
	    (player-message actptr "There is nothing here to swim in.\n"))
	 (do-wave-hands (actptr)
	    (player-message actptr "You wave your hands.\n"))
	 (visit (actptr)
	     (setprop self 'visitors (cons (objectname actptr)
					   (getprop self 'visitors))))
	 (visited? (actptr)
	     (member (objectname actptr) (getprop self 'visitors)))
	 (is-illuminated? ()
	    (or *ignore-lighting*
		(hasprop self 'light)
		(any-child-sheds-light?)))
	 (get-name ()
	    (getprop self 'name))
	 (descfull (actptr)
	    (cond ((is-illuminated?)
		   (describe-location actptr)
		   (describe-contents actptr))
		  (t (print "It is too dark to see. ")))
	    (print "\n"))
	 (describe-location (actptr)
	    (let ((name (get-name))
		  (desc (getprop self 'ldesc)))
		 (if name
		     (print name "\n"))
		     (print (if desc
				desc
				"A bland and boring place. "))))
	 (describe-contents (actptr)
	    (let ((contents (visible-contents actptr (child self))))
		 (loop (if (null? contents)
			   (exit))
		       (method (car contents) descpart actptr)
		       (set contents (cdr contents)))))
	))


; Class: thing
; Metaclasses: root-class
;
;	This is the default generic class of manipulatable objects.
;
; Properties:
;   adjectives
;	Hardwired property used by built-in parser for determining the
;	adjectives used to describe objects for parsing user commands.
;
;   article
;	The appropriate article for the object: a, an, some.
;	If not defined, will default to "a".
;
;   hide-behind-space
;	If this property is defined, then things can be hidden behind this
;	object.  The value of this property indicates the total size of
;	objects which can he hidden behind this object.
;
;   hide-in-space
;	If this property is defined, then things can be hidden inside of this
;	object.  The value of this property indicates the total size of
;	objects which can he hidden inside of this object.
;
;   hide-under-space
;	If this property is defined, then things can be hidden under this
;	object.  The value of this property indicates the total size of
;	objects which can he hidden under this object.
;
;   initial
;	If defined and the object has not been moved or taken (according to
;	the <istaken> property), this is used for the <descpart>.
;
;   invisible
;	If defined (whether nil or otherwise), then the object cannot be
;	seen by normal means.
;
;   istaken
;	If this property is defined, then the object is assumed to have been
;	moved or taken.  This property is actually only valid for objects
;	of the <getable-object> class, but it is used here for simplicity
;	and having only one default <descpart> method.
;
;   ldesc
;	If defined, this property should be a string description of the
;	object.  If not given, it is assumed there is no special
;	description for the object.
;
;   name 
;	The name string used for the object, without any articles.
;
;   noshow
;	if defined (whether nil or otherwise), then the object can never
;	be seen, although it can be manipulated.  Useful for objects given
;	in a location's description.
;
;   nouns
;	Hardwired property used by built-in parser for determining the
;	nouns used to name the object for parsing user commands
;
;   pluralname
;	Same as <name>, but used when the object's <quantity> is greater
;	than one.  Useful for when the object has a different plural name
;	(i.e. knife vs. knives).  If no <pluralname> is defined, then the
;	plural defaults to simply appending an "s" to <name>.
;
;   quantity
;	The quantity of an object.  Splitting up quantifiable objects is
;	not yet implemented.
;
;   weight
;	The weight of the object, for purposes of how much stuff can be
;	carried around.
;
; Methods:
;   (get-weight)
;	Returns the weight of the object, usually as defined by the <weight>
;	property.
;
;   (is-illuminated?)
;	Returns true if the location containing the object is illuminated.
;	If the *ignore-lighting* global variable is true, then lighting
;	conditions are always ignored and all locations assumed to be
;	illuminated.  Otherwise, a location is only considered to be
;	illuminated if it has the <light> property or if an object within
;	it sheds light.
;
;   (is-taken?)
;	Returns true if the object has been taken or moved (i.e., the <istaken>
;	property has been defined).
;
;   (is-visible? actptr)
;	Returns true if the object can be seen (useful for hiding objects).
;	If the property <invisible> is set, then the method returns false.
;
;   (sheds-light?)
;	Returns true if the object is a source of light, or is a transparent
;	container of a light source.
;
;   (can-hide-behind? objptr)
;	Returns true if <objptr> can be hidden behind this object.
;
;   (can-hide-in? objptr)
;	Returns true if <objptr> can be hidden inside of this object.
;
;   (can-hide-under? objptr)
;	Returns true if <objptr> can be hidden under this object.
;
;   (list-hidden locale)
;	Returns a list of objects hidden with respect to this object.  If
;	<locale> is nil, then a list of all hidden objects are returned.
;	If <locale> is not nil (i.e., behind, in, or under), then only those
;	object hidden there will be returned (so if <locale> is <behind>,
;	all objects hidden behind this object will be returned).
;
;   (do-ask actptr objptr mesg)
;	Invoked if <actptr> asks the object about something, with the
;	"something" being contained in the <mesg>, as a list of strings.
;	<objptr> is not used, but required by the argument arrangement
;	of (perform-action ...).
;
;   (do-attack actptr)
;	Invoked when <actptr> attacks the object.
;
;   (do-attack-target actptr objptr)
;	Invoked when <actptr> uses the object to attack <objptr>.
;
;   (do-catch actptr)
;	Called when <actptr> attepts to catch the object.
;
;   (do-climb actptr)
;	Invoked when <actptr> tries to climb the object.
;
;   (do-close actptr)
;	Called when <actptr> tries to close the object.
;
;   (do-cross actptr)
;	Called when <actptr> tries to cross the object (i.e., crossing a
;	bridge).
;
;   (do-drink actptr)
;	Called when <actptr tries to drink this object.
;
;   (do-drop actptr)
;	Called when <objptr> has dropped the object.  Moves it to <actptr>'s
;	location.
;
;   (do-eat actptr)
;	Called when <actptr tries to eat this object.
;
;   (do-enter actptr)
;	Called when <actptr> tries to enter this object.
;
;   (do-fasten actptr)
;	Called when <actptr> tries to fasten this object.
;
;   (do-fill actptr)
;	Called when <actptr> tries to fill this object.
;
;   (do-fill-with actptr objptr)
;	Called when <actptr> tries to fill this object with <objptr>.
;
;   (do-get actptr)
;	Called when <actptr> attempts to pick up this object.
;
;   (do-give actptr objptr)
;	Called when <actptr> attempts to give this object to <objptr>.
;
;   (do-kick actptr)
;	Called when <actptr> tries to kick this object.
;
;   (do-light actptr)
;	Called when <actptr> tries to light this object.
;
;   (do-light-with actptr objptr)
;	Called when <actptr> tries to light this object with <objptr>.
;
;   (do-lock actptr)
;	Called when <actptr> tries to lock this object.
;
;   (do-lock-with actptr objptr)
;	Called when <actptr> tries to lock this object with <objptr>.
;
;   (do-look-behind actptr)
;	Called when <actptr> tries to look behind this object.
;
;   (do-look-in actptr)
;	Called when <actptr> tries to look inside of this object.
;
;   (do-look-through actptr)
;	Called when <actptr> tries to look though this object.
;
;   (do-look-under actptr)
;	Called when <actptr> tries to look underneath this object.
;
;   (do-mention actptr)
;	Called when <actptr> types in the name of this object.
;
;   (do-oil actptr)
;	Called when <actptr> tries to oil this object.
;
;   (do-open actptr)
;	Called when <actptr> tries to open this object.
;
;   (do-order actptr objptr mesg)
;	Called when <actptr> tries to order this object to perform the
;	<mesg>, which in the case of an obedient robot means that <mesg>
;	should be passed to the parser.
;
;   (do-pull actptr)
;	Called when <actptr> tries to pull on this object.
;
;   (do-push actptr)
;	Called when <actptr> tries to push this object.
;
;   (do-put-in actptr objptr)
;	Called when <actptr> tries to put <objptr> into this object.
;
;   (do-put-on actptr objptr)
;	Called when <actptr> tries to put <objptr> on top of this object.
;
;   (do-read actptr)
;	Called when <actptr> tries to read this object.
;
;   (do-rub actptr)
;	Called when <actptr> tries to rub this object.
;
;   (do-show actptr objptr)
;	Called when <actptr> tries to show <objptr> to this object.
;
;   (do-smell actptr)
;	Called when <actptr> tries to smell this object.
;
;   (do-squeeze actptr)
;	Called when <actptr> squeezes this object.
;
;   (do-throw actptr)
;	Called when <actptr> tries to throw this object.  It defaults to
;	being the same as dropping the object.
;
;   (do-throw-at actptr objptr)
;	Called when the object is thrown at <objptr>.  This is done by calling
;	<throw-target> on <objptr>, which returns the location where <self>
;	should be moved, so this object must be moved to its new location
;	from within this method.
;
;   (do-touch actptr)
;	Called when <actptr> touches this object.
;
;   (do-turn-off actptr)
;	Called when <actptr> tries to turn off this object.
;
;   (do-turn-on actptr)
;	Called when <actptr> tries to turn on this object.
;
;   (do-unlock actptr)
;	Called when <actptr> tries to unlock this object.
;
;   (do-unlock-with actptr objptr)
;	Called when <actptr> tries to lock this object using <objptr>.
;
;   (do-water actptr)
;	Called when <actptr> tries to water this object.
;
;   (do-wave actptr)
;	Called when <actptr> tries to wave this object.
;
;   (move-into actptr objptr)
;	Attempts to move <objptr> into this object.  This should only work
;	for in-containers, and so defaults to saying it cannot be done.
;
;   (move-onto actptr objptr)
;	Attempts to move <objptr> onto this object.  This should only work
;	for on-containers, and so defaults to saying it cannot be done.
;
;   (receive actptr objptr)
;	Called when <actptr> tries to give <objptr> to this object.
;
;   (throw-target actptr objptr)
;	Called this when <objptr> is thrown at the object.  Returns the
;	location to which <objptr> must be moved.
;
;   (which-pronoun)
;	Returns the pronoun which refers to the object, as defined by the
;	<pronoun> property, which defaults to <it>.
;
;   (is-or-are)
;	Returns "is" or "are" according to which is more appropriate for
;	this object.
;
;   (get-article)
;	Return the object's article as a string, as defined by the <article>
;	property.  Defaults to "a" if no article is given.
;
;   (get-name)
;	Returns a string giving the name of the object, without any article
;	or quantity, as defined by the <name> or <pluralname> properties.
;
;   (get-name-ind)
;	Returns a list of strings and symbols which comprise the object's
;	name.  Uses the <name> property for the name, or <pluralname> if
;	<quantity> is greater than 1.  Gives the appropriate indefinite
;	article or quantity.
;
;   (get-name-def)
;	Returns a list of strings and symbols which comprise the object's
;	name, using the definite article, along with any relevant quantity.
;	Uses <name> or <pluralname> property, depending upon the quantity
;	of the object.
;
;   (descfull actptr)
;	Description given when the object is examined in full detail.
;	Will use the <ldesc> property to give a description, or defaults
;	to saying there is nothing interesting about the object if there
;	is no <ldesc>.  Presumes that the description is being given to
;	the player.
;
;   (descpart actptr)
;	Description given as part of a larger description, such as in
;	describing those objects present in a location.  If the <initial>
;	property is defined and the object has not been taken, then the
;	message contained in <initial> is displayed, otherwise this method
;	defaults to printing something like: "There is a <name> here."
;	Presumes that the desciption is being given to the player.
;
;   (descbrief actptr)
;	A very short description, which defaults to being the object's
;	name.  This method is used for inventory listings.  Presumes that
;	the description is being given to the player.
;
(class thing (root-class)
	((name . "boring little widget")
	 (pronoun . it)
	 (size . 1)
	 (weight . 1)
	 (quantity . 1))
	((found-by? (actptr)
	    (member (objectname actptr) (getprop self 'foundby)))
	 (get-size ()
	    (getprop self 'size))
	 (get-weight ()
	    (getprop self 'weight))
	 (is-hidden? ()
	    (hasprop self 'ishidden))
	 (is-illuminated? ()
	    (method (parent self) is-illuminated?))
	 (is-taken? ()
	    (hasprop self 'istaken))
	 (is-visible? (actptr)
	    (not (or (hasprop self 'invisible)
		     (hasprop self 'noshow)
		     (and (hasprop self 'ishidden)
			  (not (found-by? actptr))))))
	 (sheds-light? ()
	    (or (hasprop self 'light)
		(any-child-sheds-light?)))
	 (can-hide-behind? (objptr)
	    (let ((hidesize (getprop self 'hide-behind-space)))
		 (if (null? hidesize)
		     (return nil))
		 (if (< hidesize (getprop objptr 'size))
		     (return nil))
		 t))
	 (can-hide-in? (objptr)
	    (let ((hidesize (getprop self 'hide-in-space)))
		 (if (null? hidesize)
		     (return nil))
		 (if (< hidesize (getprop objptr 'size))
		     (return nil))
		 t))
	 (can-hide-under? (objptr)
	    (let ((hidesize (getprop self 'hide-under-space)))
		 (if (null? hidesize)
		     (return nil))
		 (if (< hidesize (getprop objptr 'size))
		     (return nil))
		 t))
	 (list-hidden (locale)
	    (let ((objptr (child self))
		  (rslt))
		 (loop (if (null? objptr)
			   (return rslt))
		       (if (and (method objptr is-hidden?)
				(or (null? locale)
				    (= locale (getprop objptr 'ishidden))))
			   (set rslt (cons objptr rslt)))
		       (set objptr (sibling objptr)))))
	 (clear-hidden ()
	    (delprop self 'ishidden)
	    (delprop self 'foundby))
	 (set-foundby (actptr)
	    (if (not (found-by? actptr))
		(setprop self 'foundby (cons (objectname actptr)
					     (getprop self 'foundby)))))
	 (look-for (actptr dir)
	    (let ((strg (cond ((= dir 'behind) "behind ")
			      ((= dir 'in) "inside of ")
			      ((= dir 'under) "under ")))
		  (hidden)
		  (objptr))
		 (cond ((hasprop self (cond ((= dir 'behind) 'hide-behind-space)
					    ((= dir 'in) 'hide-in-space)
					    ((= dir 'under) 'hide-under-space)))
			(set hidden (list-hidden dir))
			(cond ((null? hidden)
			       (player-message actptr
					"You see nothing " strg
					(get-name-def) ".\n")
			       t)
			      (t
			       (if (= actptr *player*)
				   (begin (print "\c" strg (get-name-def)
						 " you find ")
					  (list-objects actptr hidden)
					  (print ".\n")))
			       (loop (if (null? hidden)
					 (exit))
				     (set objptr (car hidden))
				     (set hidden (cdr hidden))
				     (method objptr set-foundby actptr))
			       t)
			))
		  (t
		   (player-message actptr "You can't see " strg
			(get-name-def) ".\n")
		   nil))))
	 (do-ask (actptr objptr mesg)
	    (if (= actptr *player*)
		(print "\c" (get-name-def) " ignores you.\n")
		(location-message self "\c" (method actptr get-name-def)
			" asks " (get-name-def) " something.\n"))
	    nil)
	 (do-attack (actptr)
	    (if (= actptr *player*)
		(print "Attacking the poor defenseless " (get-name)
			" accomplishes nothing.\n")
		(location-message self "\c" (method actptr get-name-def)
			" attacks " (get-name-def) ".\n"))
	    nil)
	 (do-attack-target (actptr objptr)
	    (if (= actptr *player*)
		(print "Attacking the poor defenseless "
			(method objptr get-name) " accomplishes nothing.\n")
		(location-message self "\c" (method actptr get-name-def)
			" attacks " (method objptr get-name-def) " with "
			(get-name-ind) ".\n"))
	    nil)
	 (do-catch (actptr)
	    (player-message actptr "You can't catch " (get-name-ind) ".\n")
	    nil)
	 (do-climb (actptr)
	    (player-message actptr "You can't climb " (get-name-ind) ".\n")
	    nil)
	 (do-close (actptr)
	    (player-message actptr "You can't close " (get-name-ind) ".\n")
	    nil)
	 (do-cross (actptr)
	    (player-message actptr "You can't cross " (get-name-ind) ".\n")
	    nil)
	 (do-drink (actptr)
	    (player-message actptr "You can't drink " (get-name-def) ".\n")
	    nil)
	 (do-drop (actptr)
	    (player-message actptr "You can't drop " (get-name-def) ".\n")
	    nil)
	 (do-eat (actptr)
	    (player-message actptr "You can't eat " (get-name-def) ".\n")
	    nil)
	 (do-enter (actptr)
	    (player-message actptr "You can't enter " (get-name-def) ".\n")
	    nil)
	 (do-fasten (actptr)
	    (player-message actptr "You can't fasten " (get-name-def) ".\n")
	    nil)
	 (do-fill (actptr)
	    (player-message actptr "You can't fill " (get-name-ind) ".\n")
	    nil)
	 (do-fill-with (actptr objptr)
	    (player-message actptr "You can't fill " (get-name-ind) ".\n")
	    nil)
	 (do-get (actptr)
	    (player-message actptr "You can't move " (get-name-def) ".\n")
	    nil)
	 (do-hide-behind (actptr objptr)
	    (player-message actptr "You can't hide " (get-name-def) ".\n")
	    nil)
	 (do-hide-in (actptr objptr)
	    (player-message actptr "You can't hide " (get-name-def) ".\n")
	    nil)
	 (do-hide-under (actptr objptr)
	    (player-message actptr "You can't hide " (get-name-def) ".\n")
	    nil)
	 (do-give (actptr objptr)
	    (player-message actptr "You can't move " (get-name-def) ".\n")
	    nil)
	 (do-kick (actptr)
	    (player-message actptr "Kicking " (get-name-def)
				" achieves nothing.\n")
	    nil)
	 (do-light (actptr)
	    (player-message actptr "You can't light " (get-name-def) ".\n")
	    nil)
	 (do-light-with (actptr)
	    (player-message actptr "You can't light " (get-name-def) ".\n")
	    nil)
	 (do-lock (actptr)
	    (player-message actptr "You can't lock " (get-name-ind) ".\n")
	    nil)
	 (do-lock-with (actptr objptr)
	    (player-message actptr "You can't lock " (get-name-ind) ".\n")
	    nil)
	 (do-look-behind (actptr)
	    (look-for actptr 'behind))
	 (do-look-in (actptr)
	    (look-for actptr 'in))
	 (do-look-through (actptr)
	    (player-message actptr "You can't see through "
			(get-name-def) ".\n")
	    nil)
	 (do-look-under (actptr)
	    (look-for actptr 'under))
	 (do-mention (actptr)
	    (player-message actptr "What about " (get-name-def) "?\n")
	    nil)
	 (do-oil (actptr)
	    (player-message actptr "That doesn't seem very helpful.\n")
	    nil)
	 (do-open (actptr)
	    (player-message actptr "You can't open " (get-name-ind) ".\n")
	    nil)
	 (do-order (actptr objptr mesg)
	    (player-message actptr "\c" (get-name-def) " ignores you.\n")
	    nil)
	 (do-pull (actptr)
	    (player-message actptr "You can't pull " (get-name-def) ".\n")
	    nil)
	 (do-push (actptr)
	    (player-message actptr "You can't push " (get-name-def) ".\n")
	    nil)
	 (do-put-in (actptr objptr)
	    (player-message actptr "You can't put " (get-name-def) " there.\n")
	    nil)
	 (do-put-on (actptr objptr)
	    (player-message actptr "You can't put " (get-name-def) " there.\n")
	    nil)
	 (do-read (actptr)
	    (player-message actptr "There is nothing written on it.\n")
	    nil)
	 (do-rub (actptr)
	    (player-message actptr "Rubbing " (get-name-def)
				" accomplishes nothing.\n")
	    nil)
	 (do-show (actptr objptr)
	    (player-message actptr "\c" (get-name-def) " isn't interested.\n")
	    nil)
	 (do-smell (actptr)
	    (player-message actptr "You smell nothing unusual about "
				(get-name-def) ".\n")
	    nil)
	 (do-squeeze (actptr)
	    (if (= actptr *player*)
		(print "Squeezing " (get-name-def) " accomplishes nothing.\n")
		(location-message self "\c" (method actptr get-name-def)
			" squeezes " (get-name-def) ".\n"))
	    nil)
	 (do-throw (actptr)
	    (if (contained-in? self actptr)
		(do-drop actptr)
		(print "You do not have " (get-name-def) ".\n"))
	    nil)
	 (do-throw-at (actptr objptr)
	    (if (contained-in? self actptr)
		(move objptr (method objptr throw-target actptr self))
		(method objptr clear-hidden)
		(print "You are not carrying " (get-name-def) ".\n"))
	    nil)
	 (do-touch (actptr)
	    (if (= actptr *player*)
		(print "Touching " (get-name-def) " accomplishes nothing.\n")
		(location-message self "\c" (method actptr get-name-def)
			" touches " (get-name-def) ".\n"))
	    nil)
	 (do-turn-off (actptr)
	    (player-message actptr "You can't turn off " (get-name-ind) ".\n")
	    nil)
	 (do-turn-on (actptr)
	    (player-message actptr "You can't turn on " (get-name-ind) ".\n")
	    nil)
	 (do-unlock (actptr)
	    (player-message actptr "You can't unlock " (get-name-ind) ".\n")
	    nil)
	 (do-unlock-with (actptr objptr)
	    (player-message actptr "You can't unlock " (get-name-ind) ".\n")
	    nil)
	 (do-water (actptr)
	    (player-message actptr "Water? Are ye mad?\n")
	    nil)
	 (do-wave (actptr)
	    (if (contained-in? self actptr)
		(player-message actptr "Waving " (get-name-def)
				" about achieves nothing.\n")
		(player-message actptr "You do not have " (get-name-def) ".\n"))
	    nil)

	 (move-into (actptr objptr)
	    (player-message actptr "You can't put the "
			(method objptr get-name-ind) " there.\n")
	    nil)
	 (move-onto (actptr objptr)
	    (player-message actptr "You can't put the "
			(method objptr get-name-ind) " there.\n")
	    nil)
	 (receive (actptr objptr)
	    (print "You can't give " (method objptr get-name-ind) " to "
			(get-name-def) ".\n"))
	 (throw-target (actptr objptr)
	    (do-attack-target actptr objptr)
	    (location-of actptr))	; return location where object lands

	 (which-pronoun ()
	    (getprop self 'pronoun))
	 (is-or-are ()
	    (if (or (> (getprop self 'quantity) 1)
		    (= (getprop self 'article) "some")
		    (= (getprop self 'article) "many"))
		"are" "is"))
	 (get-article ()
	    (let ((arti (getprop self 'article)))
		 (if (null? arti)
		     "a"
		     arti)))
	 (get-name ()
	    (if (> (getprop self 'quantity) 1)
		(getprop self 'pluralname)
		(getprop self 'name)))
	 (get-name-ind ()
	    (let ((quant (getprop self 'quantity))
		  (nom (getprop self 'name))
		  (pnom (getprop self 'pluralname)))
		 (if (> quant 1)
		     (list quant " " (if pnom pnom (list nom "s")))
		     (list (get-article) " " nom))))
	 (get-name-def ()
	    (let ((quant (getprop self 'quantity))
		  (nom (getprop self 'name))
		  (pnom (getprop self 'pluralname)))
		 (if (> quant 1)
		     (list "the " quant " " (if pnom pnom (list nom "s")))
		     (list "the " nom))))
	 (descfull (actptr)
	    (if (hasprop self 'ldesc)
		(print (getprop self 'ldesc))
		(print "There is nothing unusual about " (get-name-def) ".\n"))
	    (let ((hidden (list-hidden nil))
		  (objptr))
		 (loop (if (null? hidden)
			   (exit))
		       (set objptr (car hidden))
		       (set hidden (cdr hidden))
		       (if (method objptr found-by? actptr)
			   (print "Hidden " (getprop objptr 'ishidden)
				" " (get-name-def) " " (method objptr is-or-are)
				" " (method objptr get-name-ind) ". "))
		)))
	 (descpart (actptr)
	    (if (and (hasprop self 'initial) (not (is-taken?)))
		(print (getprop self 'initial))
		(print "There " (is-or-are) " " (get-name-ind) " here. ")))
	 (descbrief (actptr)
	    (print (get-name-ind)))
	))


; Class: getable-object
; Metaclasses: thing
;
;	This class is used for objects which can be taken and carried around.
;
; Properties:
;    istaken
;	This property is attached to an object once it has been taken the
;	first time by the player, so that it is possible to distinguish
;	whether an object has been found and moved yet.
;
; Methods:
;   (is-getable>)
;	Returns true if this object can be moved or taken.
;
;   (do-drop actptr)
;	Called when <actptr> tries to drop this object, which moves it to
;	his location.
;
;   (do-get actptr)
;	Called when <actptr> tries to take this object, moving it into
;	<actptr>'s inventory if successful.
;
;   (do-give actptr objptr)
;	Called when <actptr> tries to give this object to <objptr>.
;	This is done by invoking <objptr>'s <receive> method.
;
;   (do-put-in actptr objptr)
;	Called when <actptr> tries to put this object inside of <objptr>.
;	This is done by invoking <objptr>'s <move-into> method, which is
;	only valid for <in-container>s.
;
;   (do-put-on actptr objptr)
;	Called when <actptr> tries to put this object on top of <objptr>.
;	This is done by invoking <objptr>'s <move-onto> method, which is
;	only valid for <on-container>s.
;
(class getable-object (thing)
	()
	((is-getable? ()
	    t)
	 (do-drop (actptr)
	    (cond ((contained-in? self actptr)
		   (move self (location-of actptr))
		   (clear-hidden)
		   (if (= actptr *player*)
		       (print "You put down the " (get-name-def) ".\n")
		       (location-message self "\c" (method actptr get-name-def)
				" puts down " (get-name-def) ".\n"))
		   t)
		  (t
		   (player-message actptr "You are not carrying it.\n")
		   nil)))
	 (do-get (actptr)
	    (cond ((= self actptr)
		   (if (= actptr *player*)
		       (print "Picking yourself up accomplishes nothing.\n")
		       (location-message self "\c" (method actptr get-name-def)
				" tries a little bootstrap levitation.\n"))
		   nil)
		  ((contained-in? self actptr)
		   (player-message actptr "You are already carrying "
				(get-name-def) ".\n")
		   nil)
		  ((> (+ (method actptr weight-contained) (total-weight))
		      (max-lift actptr))
		   (if (= actptr *player*)
		       (print "You are carrying too much.\n")
		       (location-message self "\c" (method actptr get-name-def)
				" tries to pick up " (get-name-def)
				", but is not strong enough.\n"))
		   nil)
		  ((move self actptr)
		   (clear-hidden)
		   (setprop self 'istaken nil)
		   (if (= actptr *player*)
		       (print "You pick up " (get-name-def) ".\n")
		       (location-message self "\c" (method actptr get-name-def)
				" picks up " (get-name-def) ".\n"))
		   t)
		  (t
		   (player-message actptr "Unable to comply.\n")
		   nil)))
	 (do-give (actptr objptr)
	    (cond ((contained-in? self actptr)
		   (method objptr receive actptr self)
		   t)
		  (t
		   (player-message actptr "You don't have "
				(get-name-def) ".\n")
		   nil)))
	 (hide-it (actptr objptr dir)
	    (let ((strg (cond ((= dir 'behind) "behind ")
			      ((= dir 'in) "inside of ")
			      ((= dir 'under) "under ")))
		  (caller (list 'method objptr
				(cond ((= dir 'behind) 'can-hide-behind?)
				      ((= dir 'in) 'can-hide-in?)
				      ((= dir 'under) 'can-hide-under?))
				self)))
		 (cond ((eval caller)
			(move self objptr)
			(setprop self 'ishidden dir)
			(setprop self 'foundby (list (objectname actptr)))
			(if (= actptr *player*)
			    (print "\c" (get-name-def) " is now hidden behind "
				   (method objptr get-name-def) ".\n")
			    (location-message self "\c"
				   (method actptr get-name-def) " is hiding "
				   (get-name-def) " " strg
				   (method objptr get-name-def) ".\n"))
			t)
		       (t
			(player-message actptr "You can't hide " (get-name-def)
				" " strg (method objptr get-name-def) ".\n")
			nil))))
	 (do-hide-behind (actptr objptr)
	    (hide-it actptr objptr 'behind))
	 (do-hide-in (actptr objptr)
	    (hide-it actptr objptr 'in))
	 (do-hide-under (actptr objptr)
	    (hide-it actptr objptr 'under))
	 (do-put-in (actptr objptr)
	    (if (not (contained-in? self actptr))
		(do-get actptr))
	    (method objptr move-into actptr self))
	 (do-put-on (actptr objptr)
	    (if (not (contained-in? self actptr))
		(do-get actptr))
	    (method objptr move-onto actptr self))
	 ))


; Class: in-container
; Metaclasses: thing
;
;	In-containers are objects which can hold other objects, such as
;	boxes, tables, and most furnishings.
;
; Properties:
;   capacity
;	The maximum amount of weight that the in-container can hold.
;
; Methods:
;   (can-contain? obj)
;	Returns true if the object pointed at by <obj> can fit into this
;	in-container, given the amount of other stuff already in there.
;
;   (move-into actptr objptr)
;	Called when <actptr> attempts to move <objptr> into this object.
;
;   (descfull actptr)
;	Gives a detailed description of this object, along with any objects
;	inside of it.
;
;   (descpart actptr)
;	Gives a short description of this object, along with any objects
;	inside of it.
;
(class in-container (thing)
	((capacity . 1))
	((can-contain? (objptr)
	     (>= (getprop self 'capacity)
		 (+ (method objptr total-weight)
		    (weight-contained))))
	 (move-into (actptr objptr)
	     (cond ((can-contain? objptr)
		    (move objptr self)
		    (method objptr clear-hidden)
		    (if (= actptr *player*)
			(print "\c" (method objptr get-name-def) " is now in "
				(get-name-def) ".\n")
			(location-message self "\c" (method actptr get-name-def)
				" puts " (method objptr get-name-def)
				" in " (get-name-def) ".\n"))
		    t)
		   (t
		    (if (= actptr *player*)
			(print "There is not enough room for that in "
				(get-name-def) ".\n")
			(location-message self "\c" (method actptr get-name-def)
				" tries to put " (method objptr get-name-def)
				" into " (get-name-def)
				", but there isn't enough room.\n"))
		    nil)))
	 (descfull (actptr)
	    (if (hasprop self 'ldesc)
		(print (getprop self 'ldesc) " It ")
		(print "The " (get-name)))
	    (cond ((null? (child self))
		   (print " is empty.\n"))
		  (t (print " contains ")
		     (let ((contents (visible-contents actptr (child self))))
			  (loop (if (null? contents) (exit))
				(method (car contents) descbrief actptr)
				(set contents (cdr contents))))
		     (print ".\n"))))
	 (descpart (actptr)
	    (if (and (hasprop self 'initial) (not (is-taken?)))
		(print (getprop self 'initial))
		(begin (print "There " (is-or-are) " " (get-name-ind) " here")
		       (cond ((child self)
			      (print ", containing ")
			      (list-objects actptr (visible-contents actptr
							      (child self)))))
		       (print ". "))))
	))


; Class: on-container
; Metaclasses: thing
;
;	On-containers are objects which can hold other objects on top of it,
;	such as tables, desks, and most other furnishings.
;
; Properties:
;   capacity
;	The maximum amount of weight that the on-container can hold.
;
;   transparent
;	This property is defined, since anything on it should be in plain
;	sight.
;
; Methods:
;   (can-contain? obj)
;	Returns true if the object pointed at by <obj> can fit onto this
;	on-container, given the amount of other stuff already in there.
;
;   (move-onto actptr objptr)
;	Called when <actptr> attempts to move <objptr> on top of this object.
;
;   (descfull actptr)
;	Gives a detailed description of this object, along with any objects
;	on top of it.
;
;   (descpart actptr)
;	Gives a short description of this object, along with any objects
;	on top of it.
;
;   (descbrief actptr)
;	Gives a minimal description of this object, along with anything
;	sitting on it.
;
(class on-container (thing)
	((capacity . 1)
	 (transparent))
	((can-contain? (objptr)
	     (>= (getprop self 'capacity)
		 (+ (method objptr total-weight)
		    (weight-contained))))
	 (move-onto (actptr objptr)
	     (cond ((can-contain? objptr)
		    (move objptr self)
		    (method objptr clear-hidden)
		    (if (= actptr *player*)
			(print "\c" (method objptr get-name-def)
				" is now resting on " (get-name-def) ".\n")
			(location-message self "\c" (method actptr get-name-def)
				" puts " (method objptr get-name-def)
				" on " (get-name-def) ".\n"))
		    t)
		   (t
		    (if (= actptr *player*)
			(print "There is not enough room for that on "
				(get-name-def) ".\n")
			(location-message self "\c" (method actptr get-name-def)
				" tries to put " (method objptr get-name-def)
				" onto " (get-name-def)
				", but there isn't enough room.\n"))
		    nil)))
	 (descfull (actptr)
	    (if (hasprop self 'ldesc)
		(print (getprop self 'ldesc) " It ")
		(print "The " (get-name)))
	    (cond ((null? (child self))
		   (print " has nothing on it.\n"))
		  (t (print " has ")
		     (let ((contents (visible-contents actptr (child self))))
			  (loop (if (null? contents) (exit))
				(method (car contents) descbrief actptr)
				(set contents (cdr contents))))
		     (print " sitting atop it.\n"))))
	 (descpart (actptr)
	    (if (and (hasprop self 'initial) (not (is-taken?)))
		(print (getprop self 'initial))
		(let ((contents (visible-contents actptr (child self))))
		     (print "There " (is-or-are) " " (get-name-ind) " here")
		     (cond (contents
			    (print ", with ")
			    (list-objects actptr contents)
			    (print " sitting atop it")))
		     (print ". "))))
	 (descbrief (actptr)
	    (print (get-name-def))
	    (let ((contents (visible-contents actptr (child self))))
		 (if (null? contents)
		     (exit))
		 (print " with ")
		 (list-objects actptr contents)
		 (print " on it")))
	))


; Class: openable-object
; Metaclasses: thing
;
;	Openable objects are objects which can be opened and closed.
;
; Properties:
;   isclosed
;	If this property is defined, then the object is closed.
;
;   openmesg
;	Message printed out when successfully opened.
;
;   closemesg
;	Message printed out when successfully closed.
;
; Methods:
;   (is-closed?)
;	Returns true if the object is closed (i.e. the <isclosed> property
;	is defined).
;
;   (set-closed actptr)
;	When invoked, this method closes the object and displays a message.
;
;   (set-opened actptr)
;	When invoked, this method opens the object and displays a message.
;
;   (do-close actptr)
;	Called when <actptr> attempts to close this object.  If it is open,
;	then it is closed.
;
;   (do-open actptr)
;	Called when <actptr> attempts to open this object.  If it is closed,
;	when it will be set open.
;
;   (descfull actptr)
;	Displays the <ldesc> property and indicates whether the object is
;	open or closed.
;
;   (descpart actptr)
;	Displays the object's name, along with a note as to whether it is
;	open or closed.
;
(class openable-object (thing)
	()
	((is-closed? ()
	    (hasprop self 'isclosed))
	 (set-closed (actptr)
	    (if (= actptr *player*)
		(print "\c" (get-name-def) " is now closed.\n")
		(location-message "\c" (method actptr get-name-def) " closes "
				(get-name-def) ".\n"))
	    (setprop self 'isclosed nil))
	 (set-opened (actptr)
	    (if (= actptr *player*)
		(print "\c" (get-name-def) " is now open.\n")
		(location-message "\c" (method actptr get-name-def) " opens "
				(get-name-def) ".\n"))
	    (delprop self 'isclosed))
	 (do-close (actptr)
	    (cond ((is-closed?)
		   (player-message actptr "\c" (get-name-def)
				" is already closed.\n")
		   nil)
		  (t
		   (set-closed actptr)
		   t)))
	 (do-open (actptr)
	    (cond ((not (is-closed?))
		   (player-message actptr "\c" (get-name-def)
				" is already open.\n")
		   nil)
		  (t
		   (set-opened actptr)
		   t)))
	 (descfull (actptr)
	    (if (hasprop self 'ldesc)
		(print (getprop self 'ldesc) " It is ")
		(print "\c" (get-name-def) " is "))
	    (print (if (is-closed?) "closed" "open")
		   ". "))
	 (descpart (actptr)
	    (print "There is " (if (is-closed?) "a closed " "an open ")
		   (get-name)
		   " here. "))
	))


; Class: openable-container
; Metaclasses: container openable-object
;
;	Openable containers are those which can be opened and closed, and
;	their contents is accessible only when open.  If one is defined
;	as being transparent, then its contents will remain visible even
;	when it is closed.
;
; Properties:
;   transparent
;	If this property is defined, then the contents are visible even when
;	it is closed.
;
; Methods:
;   (contents-visible? actptr)
;	Returns true if <actptr> can see the contents of this object.
;	This is the case only when this object is open or transparent.
;
;   (is-transparent?)
;	Returns true if the <transparent> property is defined.
;
;   (sheds-light?)
;	Returns true if the object emits light, or if it contains another
;	object which emits light (and it is either open or transparent).
;
;   (move-into actptr objptr)
;	Called when <actptr> tries to put <objptr> into this object.
;	Will complain if this object is not open.
;
;   (descfull actptr)
;	Give a full description of this object, using <ldesc> if defined,
;	and telling whether the object os open or closed.  If it is open
;	or transparent, also list the object's contents.
;
;   (descpart actptr)
;	Give a partial description of the object, using <initial> if it is
;	defined, and noting whether the object is open or closed.  If the
;	object is either open or transparent, also list its contents.
;
(class openable-container (in-container openable-object)
	()
	((contents-visible? (actptr)
	    (or (not (is-closed?))
		(hasprop self 'transparent)))
	 (is-transparent? ()
	    (hasprop self 'transparent))
	 (sheds-light? ()
	    (or (hasprop self 'light)
		(and (or (hasprop self 'transparent)
			 (not (is-closed?)))
		     (any-child-sheds-light?))))
	 (move-into (actptr objptr)
	    (cond ((is-closed?)
		   (player-message actptr "\c" (get-name-def) " is closed.\n")
		   nil)
		  ((can-contain? objptr)
		   (move objptr self)
		   (method objptr clear-hidden)
		   (player-message actptr "\c" (method objptr get-name-def)
				" is now in " (get-name-def) ".\n")
		   t)
		  (t
		   (print "There is not enough room for that.\n")
		   nil)))
	 (descfull (actptr)
	    (if (hasprop self 'ldesc)
		(print (getprop self 'ldesc)) " It is ")
		(print "\c" (get-name-def) " is ")
	    (if (is-closed?)
		(print "closed")
		(print "open"))
	    (cond ((and (is-closed?) (not (is-transparent?)))
		   ())
		  ((null? (child self))
		   (print ". It is empty"))
		  (t (print ", and holds ")
		     (let ((contents (visible-contents actptr (child self))))
			  (loop (if (null? contents) (exit))
				(method (car contents) descbrief actptr)
				(set contents (cdr contents))))))
	    (print ". "))
	 (descpart (actptr)
	    (if (and (hasprop self 'initial) (not (is-taken?)))
		(print (getprop self 'initial))
		(begin (print "There is "
			      (if (is-closed?) "a closed " "an open ")
			      (get-name)
			      " here")
		       (cond ((and (child self) (or (not (is-closed?))
						    (is-transparent?)))
			      (print " which holds ")
			      (list-objects actptr (visible-contents actptr
							      (child self)))))
		       (print ". "))))
	))


; Class: key-object
; Metaclasses: thing
;
;	Keys are used to lock and unlock things of the <lockable-object>
;	class which have the matching <keynum> value.  This allows for
;	different keys in the same game, where each key can only unlock;
;	certain things.
;
; Properties:
;   keynum
;	This is the key value which is used to determine what objects this
;	key can lock or unlock.
;
(class key-object (thing)
	((keynum . 1))
	())


; Class: lockable-object
; Metaclasses: thing
;
;	Lockable objects are things which can be locked and unlocked with
;	objects of the <key-object> class which have the matching <keynum>
;	value.
;
; Properties:
;   islocked
;	If this property is defined, then the object is locked.
;
;   keynum
;	Key number for key to use in unlocking the object.
;
; Methods:
;   (is-locked?)
;	Returns true if this object is locked.
;
;   (set-locked actptr)
;	Makes this object locked for <actptr>.
;
;   (set-unlocked actptr)
;	Makes this object unlocked for <actptr>.
;
;   (do-lock actptr)
;	Called when <actptr> tries to lock this object.  This defaults to
;	failing since it is too game-specific than do-lock-with.
;
;   (do-lock-with actptr objptr)
;	Called when <actptr> tries to lock this object using <objptr>.
;
;   (do-unlock actptr)
;	Called when <actptr> tries to unlock this object.  This defaults to
;	failing since it is too game-specific than do-unlock-with.
;
;   (do-unlock-with actptr objptr)
;	Called when <actptr> tries to unlock this object with <objptr>.
;
(class lockable-object (thing)
	((keynum . 1)
	 (lockmesg . "Locked.")
	 (unlockmesg . "Unlocked."))
	((is-locked? ()
	    (hasprop self 'islocked))
	 (set-locked (actptr)
	    (if (= actptr *player*)
		(print "\c" (get-name-def) " is now locked.\n")
		(location-message "\c" (method actptr get-name-def) " locks "
			(get-name-def) ".\n"))
	    (setprop self 'islocked nil))
	 (set-unlocked (actptr)
	    (if (= actptr *player*)
		(print "\c" (get-name-def) " is now unlocked.\n")
		(location-message "\c" (method actptr get-name-def) " unlocks "
			(get-name-def) ".\n"))
	    (delprop self 'islocked))
	 (do-lock (actptr)
	    (print "You need to indicate what you want to lock it with.\n")
	    nil)
	 (do-lock-with (actptr objptr)
	    (cond ((not (subclassof? objptr 'key-object))
		   (player-message actptr "That is not a key.\n")
		   nil)
		  ((is-locked?)
		   (player-message actptr "It is already locked.\n")
		   nil)
		  ((!= (getprop self 'keynum) (getprop objptr 'keynum))
		   (player-message actptr "That key will not fit this lock.\n")
		   nil)
		  (t
		   (set-locked actptr)
		   t)))
	 (do-unlock (actptr)
	    (print "You need to indicate what you want to unlock it with.\n")
	    nil)
	 (do-unlock-with (actptr objptr)
	    (cond ((not (subclassof? objptr 'key-object))
		   (player-message actptr "That is not a key.\n")
		   nil)
		  ((not (is-locked?))
		   (player-message actptr "It is not locked.\n")
		   nil)
		  ((!= (getprop self 'keynum) (getprop objptr 'keynum))
		   (player-message actptr "That key will not fit this lock.\n")
		   nil)
		  (t
		   (set-unlocked actptr)
		   t)))
	))


; Class: openable-lockable
; Metaclasses: openable-object, lockable-object
;
;	This class is defined for objects which are both openable and
;	lockable.
;
; Methods:
;    (do-lock-with actptr objptr)
;	Uses <objptr> to lock this object, closing it if necessary.
;
;    (do-open actptr)
;	Opens this object if it is not locked.
;
;    (do-unlock-with actptr objptr)
;	Unlocks this object with <objptr>.
;
;    (descfull actptr)
;	Gives the full description according to <ldesc>, and indicates
;	whether the object is locked or closed.
;
;    (descpart actptr)
;	Lists the object's name, and indicates whether it is locked or closed.
;
(class openable-lockable (openable-object lockable-object)
	()
	((do-lock-with (actptr objptr)
	    (cond ((not (subclassof? objptr 'key-object))
		   (player-message actpr "That is not a key.\n")
		   nil)
		  ((is-locked?)
		   (player-message actptr "It is already locked.\n")
		   nil)
		  ((!= (getprop self 'keynum) (getprop objptr 'keynum))
		   (player-message actptr "That key will not fit this lock.\n")
		   nil)
		  (t
		   (cond ((not (is-closed?))
			  (player-message actptr "(first closing it)\n")
			  (set-closed actptr)))
		   (set-locked actptr)
		   (if (= actptr *player*)
		       (print "\c" (get-name-def) " is now locked.\n")
		       (location-message self "\c" (method actptr get-name-def)
				" locks " (get-name-def) ".\n"))
		   t)))
	 (do-open (actptr)
	    (cond ((not (is-closed?))
		   (player-message actptr "It is already open.\n")
		   nil)
		  ((is-locked?)
		   (player-message actptr  "It is locked.\n")
		   nil)
		  (t
		   (set-opened actptr)
		   t)))
	 (do-unlock-with (actptr objptr)
	    (cond ((not (subclassof? objptr 'key-object))
		   (print "That is not a key.\n")
		   nil)
		  ((not (is-locked?))
		   (print "It is not locked.\n")
		   nil)
		  ((!= (getprop self 'keynum) (getprop objptr 'keynum))
		   (print "That key will not fit this lock.\n")
		   nil)
		  (t
		   (set-unlocked actptr)
		   t)))
	 (descfull (actptr)
	    (if (hasprop self 'ldesc)
		(print (getprop self 'ldesc)))
	    (print "It is "
		   (if (is-locked?)
		       "locked"
		       (if (is-closed?) "closed" "open"))
		   ". "))
	 (descpart (actptr)
	    (print "There is "
		   (if (is-locked?)
		       "a locked"
		       (if (is-closed?)
			   "a closed"
			   "an open"))
		   (get-name)
		   " here. "))
	))


; Class: lockable-container
; Metaclasses: openable-lockable openable-container
;
;	This method is used for containers which can be opened and locked,
;	since they need a special description function to not whether they
;	are closed or locked.
;
; Methods:
;   (descfull actptr)
;	Give a full description of the object, noting whether it is locked
;	or closed, and what objects are in it (if it is open or transparent).
;
(class lockable-container (openable-lockable openable-container)
	()
	((descfull (actptr)
	    (print "\c" (get-name-def) " is ")
	    (if (is-locked?)
		(print "locked")
		(if (is-closed?)
		    (print "closed")
		    (print "open")))
	    (if (or (not (is-closed?)) (is-transparent?))
		(let ((contents (visible-contents actptr (child self))))
		     (if contents
			 (print ", and holds "))
		     (list-objects actptr contents)))
	    (print ". "))
	))


; Class: drawer-surface
; Metaclasses: on-container
;
;	This class designed for objects like desks which are both
;	on-containers and in-containers, since they have a top surface
;	and several drawers.  This object is defined as a on-container,
;	since it is a surface.  The <drawernames> property contains a list
;	of the names of the objects which serve as drawers for this object.
;	The drawers should be openable-containers or lockable-containers,
;	and should be defined with the <noshow> property so that they
;	will not be described twice in the object's description, since
;	everything on top of this object will be described, then all of its
;	drawers will be mentioned.
;
; Properties:
;   drawernames
;	A list of the names of the drawers contained in this object.
;
; Methods:
;   (descfull actptr)
;	Describe this object, noting first whether there is anything
;	on top of it, then mentioning all of the drawers and if anything
;	can be seen in them.
;
;   (descpart actptr)
;	List everthing on op of the object, and then all visible contents
;	of the drawers.
;
(class drawer-surface (on-container)
	()
	((descfull (actptr)
	    (if (hasprop self 'ldesc)
		(print (getprop self 'ldesc)))
	    (let ((contents (visible-contents actptr (child self)))
		  (drawernames (getprop self 'drawernames))
		  (objptr))
		 (cond ((null? contents)
			(print "There is nothing on top of " (get-name-def)))
		       (t
			(print "On top of " (get-name-def) " is ")
			(list-objects actptr contents)))
		 (print ". ")
		 (loop (if (null? drawernames)
			   (exit))
		       (set objptr (findobject (car drawernames) self))
		       (if (null? objptr)
			   (print "One of the drawers appears to be missing. ")
			   (method objptr descfull actptr))
		       (set drawernames (cdr drawernames)))))
	 (descpart (actptr)
	    (if (hasprop self 'ldesc)
		(print (getprop self 'ldesc))
		(print "There is " (get-name-ind) " here. "))
	    (let ((contents (visible-contents actptr (child self)))
		  (drawernames (getprop self 'drawernames))
		  (objptr))
		 (cond ((null? contents)
			(print "There is nothing on top of it. "))
		       (t
			(print "On top of it is ")
			(list-objects actptr contents)
			(print ". ")))
		 (loop (if (null? drawernames)
			   (exit))
		       (set objptr (findobject (car drawernames) self))
		       (if (null? objptr)
			   (print "One of the drawers appears to be missing. ")
			   (method objptr descfull actptr))
		       (set drawernames (cdr drawernames)))))
	))


; Class: portal
; Metaclasses: openable-lockable
;
;	Portals are implemented as two separate objects, with most info
;	stored in <portal>, and the matching <portal-other> object just
;	reflects everything back to the <portal>.  Thus all relevent
;	properties are stored in the <portal> object.
;
; Properties:
;    othername
;	The name of the <portal-other> object matched with this <portal>.
;
;    direction
;	The direction in which the portal leads.
;
; Methods:
;   (otherptr)
;	Returns the pointer to the other portal, usually used by
;	<portal-other> objects for referring to their mated <portal>.
;
;   (get-direction)
;	Returns the direction in which the portal leads.
;
;   (get-dir)
;	Return the direction of the portal if it is open, otherwise return
;	a string indicating that the portal is closed or otherwise not able
;	to be passed through.
;
;   (do-enter actptr)
;	If the portal is open, move the actor through it to its other end.
;
;   (do-mention actptr)
;	If the player just enters the portal's name, assume it is with the
;	intention to enter the portal.
;
(class portal (openable-lockable)
	((othername . nil))
	((otherptr ()
	    (findobject (getprop self 'othername)))
	 (get-direction ()
	    (getprop self 'direction))
	 (get-dir ()
	    (if (is-closed?)
		"It is closed.\n"
		(getprop self 'othername)))
	 (do-enter (actptr)
	    (cond ((is-locked?)
		   (player-message "It is locked.\n")
		   nil)
		  (t
		   (if (is-closed?)
		       (set-opened actptr))
		   (move-to-location actptr (location-of (otherptr)))
		   t)))
	 (do-mention (actptr)
	    (do-enter actptr))
	))


; Class: portal-other
; Metaclasses: portal
;
;	This class is just a mirror of the <portal> class, which is used
;	for defining the copy of the <portal> object at its destination.
;	See the <portal> class for more information.  All methods are
;	redirected at the real portal object, which does the main work
;	of determining whether the object is closed, locked, etc.
;
(class portal-other (portal)
	()
	((is-closed? ()
	    (method (otherptr) is-closed?))
	 (is-locked? ()
	    (method (otherptr) is-locked?))
	 (set-opened (actptr)
	    (method (otherptr) set-opened actptr))
	 (set-closed (actptr)
	    (method (otherptr) set-closed actptr))
	 (set-locked (actptr)
	    (method (otherptr) set-locked actptr))
	 (set-unlocked (actptr)
	    (method (otherptr) set-unlocked actptr))
	 (do-close (actptr)
	    (method (otherptr) do-close actptr))
	 (do-lock-with (actptr objptr)
	    (method (otherptr) do-lock-with actptr objptr))
	 (do-open (actptr)
	    (method (otherptr) do-open actptr))
	 (do-unlock-with (actptr objptr)
	    (method (otherptr) do-unlock-with actptr objptr))
	 (descfull (actptr)
	    (method (otherptr) descfull actptr))
	 (descpart (actptr)
	    (method (otherptr) descpart actptr))
	 (descbrief (actptr)
	    (method (otherptr) descbrief actptr))
	))


; Class: switchable-object
; Metaclasses: thing
;
;	This class is used for objects which can be turned on and off.
;
; Properties:
;    activated
;	This property is either yes or no, indicating whether the object is
;	on or off.
;
;    onmesg
;	If defined, this property contains the message which is displayed
;	when the object is switched on.
;
;    offmesg
;	If defined, this property contains the message which is displayed
;	when the object is switched off.
;
; Methods:
;    (is-active?)
;	Returns true if the object is currently turned on.
;
;    (set-on actptr)
;	Turns the object on, and displays a message.
;
;    (set-off actptr)
;	Turns the object off, and displays a message.
;
;    (do-turn-on actptr)
;	Called when <actptr> attempts to turn this object on.  If not already
;	on, the <set-on> method is used to activate it.
;
;    (do-turn-off actptr)
;	Called when <actptr> attempts to turn this object off.  If it is on,
;	then <set-off> is used to deactivate it.
;
(class switchable-object (thing)
	((activated . no))
	((is-active? ()
	    (= 'yes (getprop self 'activated)))
	 (set-on (actptr)
	    (if (= actptr *player*)
		(if (hasprop self 'onmesg)
		    (print (getprop self 'onmesg) "\n")
		    (print "\c" (get-name-def) " is now on.\n"))
		(location-message self "\c" (method actptr get-name-def)
			" turns on " (get-name-def) ".\n"))
	    (setprop self 'activated 'yes))
	 (set-off (actptr)
	    (if (= actptr *player*)
		(if (hasprop self 'offmesg)
		    (print (getprop self 'offmesg) "\n")
		    (print "\c" (get-name-def) " is now off.\n"))
		(location-message self "\c" (method actptr get-name-def)
			" turns off " (get-name-def) ".\n"))
	    (setprop self 'activated 'no))
	 (do-turn-on (actptr)
	    (cond ((is-active?)
		   (player-message actptr "\c" (get-name-def)
				" is already on.\n")
		   nil)
		  (t
		   (set-on actptr)
		   t)))
	 (do-turn-off (actptr)
	    (cond ((is-active?)
		   (set-off actptr)
		   t)
		  (t
		   (player-message actptr "\c" (get-name-def) " is not on.\n")
		   nil)))
	))


; Class: switchable-light
; Metaclasses: switchable-object
;
;	This class is used for light sources which can be turned on an off.
;
; Properties:
;    powerleft
;	Contains the number of turns of power left in the light.
;
;    nopower
;	If defined, this property should be a string which is displayed when
;	the player attempts to turn the light on, but finds it is out of power.
;
; Methods:
;    (sheds-light?)
;	Returns true when the light is turned on.
;
;    (power-low?)
;	Returns true when the light is low on power.
;
;    (do-turn-on actptr)
;	Called when <actptr> tries to turn on the light.  Worries about
;	whether the light is already on or if it is out of power.
;
;    (when-light-active)
;	This method is called buy the light source's daemon each turn that
;	the light is turned on, which takes care of reducing the amount of
;	power remaining in the light.
;
(class switchable-light (switchable-object)
	((powerleft . 50))
	((sheds-light? ()
	    (is-active?))
	 (power-low? ()
	    (if (< (getprop self 'powerleft) 20)))
	 (do-turn-on (actptr)
	    (cond ((is-active?)
		   (player-message actptr "\c" (get-name-def)
				" is already on.\n")
		   nil)
		  ((> (getprop self 'powerleft) 0)
		   (let ((foo (method (location-of self) is-illuminated?)))
			(set-on actptr)
			(if (and (= actptr *player*)
				 (not foo))
			    (method (location-of self) descfull actptr)))
		   t)
		  (t
		   (if (hasprop self 'nopower)
		       (player-message actptr (getprop self 'nopower))
		       (player-message actptr "\c" (get-name-def)
					" is out of power.\n"))
		   nil)))
	 (do-turn-off (actptr)
	    (cond ((is-active?)
		   (let ((foo (method (location-of self) is-illuminated?)))
			(set-off actptr)
			(if (and foo
				 (not (method (location-of self)
						is-illuminated?)))
			    (location-message self
					"It is now too dark to see.\n")))
		   t)
		  (t
		   (player-message actptr "\c" (get-name-def) " is not on.\n")
		   nil)))
	 (when-light-active ()
	    (let ((timeleft (getprop self 'powerleft)))
		 (set timeleft (1- timeleft))
		 (setprop self 'powerleft timeleft)
		 (cond ((<= timeleft 0)
			(location-message self "\c" (get-name-def)
					" has run out of power. ")
			(setprop self 'activated 'no))
		       ((<= timeleft 20)
			(location-message self "\c" (get-name-def)
					" is getting dim. ")))))
	 (descfull (actptr)
	    (print "\c" (get-name-def) " is "
		   (cond ((= (getprop self 'activated) 'no)
			  "not currently lit. ")
			 ((power-low?)
			  "glowing dimly. ")
			 (t
			  "glowing brightly. "))))
	 (descpart (actptr)
	    (print "There " (is-or-are) " " (get-name-ind) " here")
	    (if (sheds-light?)
		(print ", glowing " (if (power-low?) "dimly" "brightly")))
	    (print ". "))
	))


; (light-daemon)
;	This a simple daemon that, when spawned upon a <switchable-light>,
;	will sit in the background, each turn checking to see if the
;	<switchable-light> is turned on.  If so, then the amount of power
;	is decreased, and any appropriate messages are printed to indicate
;	waning power.  It does this by calling the <when-light-active>
;	method for the object.
;
(daemon light-daemon ()
    (if (= (getprop self 'activated) 'yes)
	(when-light-active)))


; Class: wearable-object
; Metaclasses: getable-object
;
;	This class allows for the wearing of objects, which cover parts
;	of the body in layers.  Small layers fit next to the body.  Heavier
;	layers have larger values, so that closer fitting articles of
;	clothing cannot be put on or taken off while wearing heavier layers.
;	Thus, you can't put on your socks if you're already wearing a pair
;	of boots.
;
;	The actual list of body parts which can be covered is undefined, so
;	that new body parts can be added as needed for specific subclasses
;	of <wearable-object>.  Some currently used parts are: chest, waist,
;	back, shoulder, arm, and leg. 
;
; Properties:
;    covers
;	This property is a list of the body parts which are covered by the
;	article of clothing when it is worn.
;
;    layer
;	Determines the layering level of the object.  The smaller the layer,
;	the closer to the body it can fit.
;
;    wornflag
;	If this property is defined, then the object is being worn.  If it
;	is not being worn, the property is deleted.
;
; Methods:
;    (being-worn?)
;	Returns true if the <wornflag> property is defined, meaning that
;	it is being worn.
;
;    (set-worn)
;	Defines the <wornflag> property, setting the object to being worn.
;
;    (set-unworn)
;	Deletes the <wornflag> property, indicating that the object is
;	no longer being worn, but leaves it within the actor's inventory.
;
;    (can-wear? actptr)
;	Returns true if the actor can wear this object, based upon what other
;	articles of clothing are already being worn.
;
;    (worn-over? bodypart)
;	Returns true if the object is worn over the given body part.
;
;    (get-layer)
;	Returns the layer the clothing is worn at.
;
;    (do-drop actptr)
;	Checks to make sure the object is removed when it is dropped,
;	then drops the object from the <actptr>'s grasp.
;
;    (descfull actptr)
;	Simply says whether the object is being worn or not.
;
;    (descbrief actptr)
;	Gives the normal brief description, plus an indicator of whether
;	the object is being worn or not.
;
(class wearable-object (getable-object)
	((layer . 1))
	((being-worn? ()
	    (hasprop self 'wornflag))
	 (set-worn ()
	    (setprop self 'wornflag nil))
	 (set-unworn ()
	    (delprop self 'wornflag))
	 (can-wear? (actptr)
	    (let ((coverlist (getprop self 'covers)))
		 (loop (if (null? coverlist)
			   (return t))
		       (if (>= (method actptr layer-worn (car coverlist))
			       (getprop self 'layer))
			   (return nil))
		       (set coverlist (cdr coverlist)))))
	 (worn-over? (bodypart)
	    (let ((coverlist (getprop self 'covers)))
		 (loop (if (null? coverlist)
			   (return nil))
		       (if (member bodypart coverlist)
			   (return t))
		       (set coverlist (cdr coverlist)))))
	 (get-layer ()
	    (getprop self 'layer))
	 (do-wear (actptr)
	    (cond ((not (contained-in? *subjectptr* *actorptr*))
		   (print "You do not have the "
			  (method *subjectptr* get-name) ".\n"))
		  ((method *subjectptr* being-worn?)
		   (print "You are already wearing that.\n"))
		  ((not (subclassof? *subjectptr* 'wearable-object))
		   (print "That is not something which you can wear.\n"))
		  ((not (method *subjectptr* can-wear? *actorptr*))
		   (print "You cannot put it on over what you already \
			   have on.\n"))
		  (t
		   (set-worn)
		   (print "Worn.\n"))))
	 (do-drop (actptr)
	    (cond ((not (contained-in? self actptr))
		   (print "You don't have the " (get-name) ".\n"))
		  (t
		   (if (being-worn?)
		       (begin (print "Removed.\n")
			      (set-unworn)))
		   (print "You put down the " (get-name-def) ".\n")
		   (method *subjectptr* clear-hidden)
		   (move *subjectptr* (parent actptr)))))
	 (descfull (actptr)
	    (if (being-worn?)
		(print "It is being worn. ")
		(print "There is nothing special about it. ")))
	 (descbrief (actptr)
	    (print (get-article) " " (get-name)
		   (if (being-worn?) " (worn)")))))


; Class: quantifiable-object
; Metaclasses: getable-object
(class quantifiable-object (getable-object)
	()
	())


; Class: readable-object
; Metaclasses: thing
;
(class readable-object (thing)
	()
	((do-read (actptr)
	    (if (hasprop self 'readmesg)
		(print (getprop self 'readmesg) "\n")
		(descfull actptr)))
	))


; Class: burnable-object
; Metaclasses: thing
;
(class burnable-object (thing)
	()
	((do-burn (actptr) (print "That's not nice!\n"))
	))


; Class: weapon
; Metaclasses: getable-object
;
;	basic definition for weapons
;
; Properties:
;
; Methods:
;
(class weapon (getable-object)
	((damage . 5) (weight . 10))
	((damage-value ()
	    (getprop self 'damage))))


; Class: water-object
; Metaclasses: thing
;
; Properties:
;
; Methods:
(class water-object (thing)
	((foodvalue . 0))
	((do-drink (actptr)
	    (if (= actptr *player*)
		(print "You drink " (get-name-def) ".\n")
		(location-message self "\c" (get-name-def) " drinks "
				(get-name-def) ".\n"))
	    (move self *voidptr*)
	    (clear-hidden)
	    t)
	))


; Class: food-object
; Metaclasses: thing
;
; Properties:
;
; Methods:
(class food-object (thing)
	((foodvalue . 0))
	((do-eat (actptr)
	    (if (= actptr *player*)
		(print "You eat " (get-name-def) ".\n")
		(location-message self "\c" (get-name-def) " eats "
				(get-name-def) ".\n"))
	    (move self *voidptr*)
	    (clear-hidden)
	    t)
	))


; Class: actor
; Metaclasses: thing
;
; Properties:
;   it-list, his-list, her-list
;	These are used by the <replace-pronouns> and <set-pronouns>
;	methods, which keep track of what objects each pronoun refers to
;	as a property.  So each of these three properties is always set to
;	the list of words the player typed in last for each pronoun.
;
; Methods:
;   (layer-worn bodypart)
;	Returns the heaviest layer of clothing worn on the given body part.
;
;   (do-catch actptr)
;	Called when <actptr> tries to catch this object.
;
;   (do-cross actptr)
;	Called when <actptr> tries to cross this object.
;
;   (do-inventory actptr)
;	List the objects currently being carried.
;
;   (receive actptr objtr)
;	Called when <actptr> offers <objptr> to this object.  If the actor is
;	the player, then the player is prompted as to whether or not he wants
;	the offered object.
;
;   (descfull actptr)
;	If <ldesc> property is defined, display it, otherwise print just
;	give this object's name.
;
;   (descpart actptr)
;	If this actor is not the player, state that he is here.  (Otherwise,
;	the player's actor's name would be displayed in the description of
;	the player's location, which would be redundant, and somewhat strange
;	looking.
;
;   (get-name-ind)
;	Actors normally have proper names, so there is no indefinite article.
;
;   (get-name-def)
;	Actors normally have proper names, so there is no definite article.
;
;   (replace-pronouns lst)
;	Given a list of strings, replace the pronouns with the names of
;	previously referenced objects, as set by (set-pronouns ...).
;
;   (set-pronouns)
;	If a direct object was referenced in the command (i.e., <*subjectptr*>
;	is non-nil), then get that object's pronoun and record the list stored
;	in <*subject*> as the value of that pronoun for future use in parsing.
;
(class actor (thing)
	((weight . 100)
	 (it-list)
	 (his-list)
	 (her-list))
	((layer-worn (bodypart)
	    (let ((objptr (child self))
		  (maxlayer 0))
		 (loop (if (null? objptr)
			   (return maxlayer))
		       (if (and (subclassof? objptr 'wearable-object)
				(method objptr being-worn?)
				(method objptr worn-over? bodypart))
			   (set maxlayer (max maxlayer
					     (method objptr get-layer))))
		       (set objptr (sibling objptr)))))
	 (do-catch (actptr)
	    (player-message actptr "Perhaps not.\n"))
	 (do-cross (actptr)
	    (player-message actptr "That wouldn't be a very nice thing.\n"))
	 (do-inventory (actptr)
	    (let ((contlist (visible-contents self (child self))))
		 (if contlist
		     (begin (print "You have ")
			    (list-objects self contlist)
			    (print ".\n"))
		     (print "You do not have anything.\n"))))
	 (receive (actptr objptr)
	    (cond ((= self *player*)
		   (print "\c" (method actptr get-name-def) " is offering you "
			(method objptr get-name-ind) ". Do you accept?\n")
		   (cond ((yes-or-no)
			  (move objptr self)
			  (method objptr clear-hidden)
			  (print "You take " (method objptr get-name-def)
					" from \c" (method actptr get-name-def)
					".\n"))
			 (t
			  (print "You refuse " (method objptr get-name-def)
				".\n"))))
		  ((player-message actptr "\c" (get-name-def) " does not want "
			(method objptr get-name-def) ".\n"))))
	 (descfull (actptr)
	    (if (hasprop self 'ldesc)
		(print (getprop self 'ldesc) "\n")
		(print "This is " (get-name) ". ")))
	 (descpart (actptr)
	    (if (nequal? self *player*)
		(print (get-name) " is here. ")))
	 (descbrief (actptr)
	    (print (get-name)))
	 (get-name-ind ()
	    (get-name))
	 (get-name-def ()
	    (get-name))
	 (replace-pronouns (lst)
	    (cond ((or (null? lst) (not (list? lst)))
		   nil)
		  ((samestring? "it" (car lst))
		   (if (getprop self 'it-list)
		       (append (getprop self 'it-list)
			       (replace-pronouns (cdr lst)))
		       (cons (car lst) (replace-pronouns (cdr lst)))))
		  ((samestring? "his" (car lst))
		   (if (getprop self 'his-list)
		       (append (getprop self 'his-list)
			       (replace-pronouns (cdr lst)))
		       (cons (car lst) (replace-pronouns (cdr lst)))))
		  ((samestring? "her" (car lst))
		   (if (getprop self 'her-list)
		       (append (getprop self 'her-list)
			       (replace-pronouns (cdr lst)))
		       (cons (car lst) (replace-pronouns (cdr lst)))))
		  (t
		   (cons (car lst) (replace-pronouns (cdr lst))))))
	 (set-pronouns ()
	    (if *subjectptr*
		(let ((pronoun (method *subjectptr* which-pronoun)))
		     (cond ((= 'it pronoun)
			    (setprop self 'it-list *subject*))
			   ((= 'his pronoun)
			    (setprop self 'his-list *subject*))
			   ((= 'her pronoun)
			    (setprop self 'her-list *subject*))
		     ))))
	))

; This daemon is written for the player's actor, which must prompt the
; player for input each turn.  It also takes care of preparsing the
; commands to split up seperate commands and replace occurances of pronouns.
;
(daemon player-daemon (holdover)
    (print "\n")
    (set *more* nil)
    (if (null? holdover)
	(set holdover (and-to-comma (readsentence))))
    (parser self (replace-pronouns (car (first-sentence holdover))))
    (set-pronouns)
    (set holdover (cdr (first-sentence holdover))))


; Class: robot
; Metaclasses: thing
;
; Properties:
;
; Methods:
;
(class robot (actor)
	()
	((do-order (actptr objptr mesg)
	    (setprop self 'commands mesg)
	    (location-message self "\c" (get-name-def) " nods.\n")
	    t)
	))

(daemon robot-daemon ()
    (let ((todo (getprop self 'commands)))
	 (if (null? todo)
	     (exit))
	 (parser self (car (first-sentence todo)))
	 (setprop self 'commands (cdr (first-sentence todo)))))


;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

(action North
	(("north") ("n") ("go" "north"))
	t
	(move-to-location *actorptr*
		(method (location-of *actorptr*) north-dir *actorptr*)))

(action Northeast
	(("northeast") ("ne") ("go" "northeast"))
	t
	(move-to-location *actorptr*
		(method (location-of *actorptr*) northeast-dir *actorptr*)))

(action Northwest
	(("northwest") ("nw") ("go" "northwest"))
	t
	(move-to-location *actorptr*
		(method (location-of *actorptr*) northwest-dir *actorptr*)))

(action South
	(("south") ("s") ("go" "south"))
	t
	(move-to-location *actorptr*
		(method (location-of *actorptr*) south-dir *actorptr*)))

(action Southeast
	(("southeast") ("se") ("go" "southeast"))
	t
	(move-to-location *actorptr*
		(method (location-of *actorptr*) southeast-dir *actorptr*)))

(action Southwest
	(("southwest") ("sw") ("go" "southwest"))
	t
	(move-to-location *actorptr*
		(method (location-of *actorptr*) southwest-dir *actorptr*)))

(action East
	(("east") ("e") ("go" "east"))
	t
	(move-to-location *actorptr*
		(method (location-of *actorptr*) east-dir *actorptr*)))

(action West
	(("west") ("w") ("go" "west"))
	t
	(move-to-location *actorptr*
		(method (location-of *actorptr*) west-dir *actorptr*)))

(action Up
	(("up") ("u") ("go" "up"))
	t
	(move-to-location *actorptr*
		(method (location-of *actorptr*) up-dir *actorptr*)))

(action Down
	(("down") ("d") ("go" "down"))
	t
	(move-to-location *actorptr*
		(method (location-of *actorptr*) down-dir *actorptr*)))

(action In
	(("in") ("enter"))
	t
	(move-to-location *actorptr*
		(method (location-of *actorptr*) in-dir *actorptr*)))

(action Out
	(("out") ("exit"))
	t
	(move-to-location *actorptr*
		(method (location-of *actorptr*) out-dir *actorptr*)))

(action Ask
	(("ask" *subject* "about" *rest*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-ask *actorptr* *subjectptr* nil *rest*))

(action Attack
	(("attack" *subject*) ("kill" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-attack *actorptr* *subjectptr*))

(action AttackWith
	(("attack" *subject* "with" *instrument*))
	(and (valid-object? *subjectptr* *actorptr*)
	     (contained-in? *instrumentptr* *actorptr*))
	(perform-action 'do-attack-target *actorptr* *instrumentptr*
			*subjectptr*))

(action Become
	(("become" *subject*))
	t
	(cond ((subclassof? *subjectptr* 'actor)
	       (set *player* *subjectptr*)
	       (print "You are now " (method *subjectptr* get-name-def) ".\n"))
	      (t (print "Becoming an inanimate object is foolish.\n"))))

(action Catch
	(("catch" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-catch *actorptr* *subjectptr*))

(action Climb
	(("climb" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-climb *actorptr* *subjectptr*))

(action ClimbUp
	(("climb" "up"))
	t
	(move-to-location *actorptr*
		(method (location-of *actorptr*) up-dir *actorptr*)))

(action ClimbDown
	(("climb" "down"))
	t
	(move-to-location *actorptr*
		(method (location-of *actorptr*) down-dir *actorptr*)))

(action Close
	(("close" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-close *actorptr* *subjectptr*))

(action Cross
	(("cross" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-cross *actorptr* *subjectptr*))

(action Drink
	(("drink" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-drink *actorptr* *subjectptr*))

(action Drop
	(("drop" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-drop *actorptr* *subjectptr*))

(action Eat
	(("eat" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-eat *actorptr* *subjectptr*))

(action Enter
	(("enter" *subject*) ("go" *subject*)
	 ("go" "through" *subject*) ("go" "thru" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-enter *actorptr* *subjectptr*))

(action Examine
	(("look" "at" *subject*) ("examine" *subject*)
	 ("x" *subject*) ("search" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-examine *actorptr* *subjectptr*))

(action Fasten
	(("fasten" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-fasten *actorptr* *subjectptr*))

(action Fill
	(("fill" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-fill *actorptr* *subjectptr*))

(action FillWith
	(("fill" *subject* "with" *instrument*))
	(and (valid-object? *subjectptr* *actorptr*)
	     (valid-object? *instrumentptr* *actorptr*))
	(perform-action 'do-fill *actorptr* *subjectptr* *instrumentptr*))

(action Get
	(("get" *subject*) ("get" *subject* "," *more*)
	 ("take" *subject*) ("take" *subject* "," *more*)
	 ("pick" "up" *subject*) ("pick" "up" *subject* "," *more*)
	 ("grab" *subject*) ("grab" *subject* "," *more*))
	(valid-object? *subjectptr* *actorptr*)
	(begin (perform-action 'do-get *actorptr* *subjectptr*)
	       (if *more*
		   (let ((foo (cons "get" *more*)))
			(set *more* nil)
			(parser *actorptr* foo)))))

(action GetOne
	(("get"))
	t
	(let ((getlist (list-getables (location-of *actorptr*))))
	     (cond ((null? getlist)
		    (print "There is nothing here of interest.\n"))
		   ((> (length getlist) 1)
		    (print "Please be more specific.\n"))
		   (t
		    (print "(" (method (car getlist) get-name-ind) ")\n")
		    (perform-action 'do-get *actorptr* (car getlist))))))

(action GetAll
	(("get" "all") ("get"))
	t
	(print "One thing at a time...\n"))

(action GinaLisp
	(("!" "ginas"))
	t
	(if *no-ginas*
	    (print "Interactive GINALISP interpreter is disabled.\n")
	    (ginalisp)))

(action Give
	(("give" *subject* "to" *location*))
	(and (valid-object? *subjectptr* *actorptr*)
	     (valid-object? *locationptr* *actorptr*))
	(perform-action 'do-give *actorptr* *subjectptr* *locationptr*))

(action GoTo
	(("!" "goto" *rest*))
	t
	(if *no-ginas*
	    (print "Debugging commands are disabled.\n")
	    (move-to-location *actorptr* (findobject (str2sym (car *rest*))))))

(action HindBehind
	(("hide" *subject* "behind" *location*))
	(and (valid-object? *subjectptr* *actorptr*)
	     (valid-object? *locationptr* *actorptr*))
	(perform-action 'do-hide-behind *actorptr* *subjectptr* *locationptr*))

(action HindIn
	(("hide" *subject* "in" *location*))
	(and (valid-object? *subjectptr* *actorptr*)
	     (valid-object? *locationptr* *actorptr*))
	(perform-action 'do-hide-in *actorptr* *subjectptr* *locationptr*))

(action HindUnder
	(("hide" *subject* "under" *location*))
	(and (valid-object? *subjectptr* *actorptr*)
	     (valid-object? *locationptr* *actorptr*))
	(perform-action 'do-hide-under *actorptr* *subjectptr* *locationptr*))

(action Inventory
	(("inventory") ("i"))
	t
	(perform-action 'do-inventory *actorptr* *actorptr*))

(action Jump
	(("jump"))
	t
	(perform-action 'do-jump *actorptr* (location-of *actorptr*)))

(action Kick
	(("kick" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-kick *actorptr* *subjectptr*))

(action Light
	(("light" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-light *actorptr* *subjectptr*))

(action LightWith
	(("light" *subject* "with" *instrument*))
	(and (valid-object? *subjectptr* *actorptr*)
	     (valid-object? *instrumentptr* *actorptr*))
	(perform-action 'do-light-with *actorptr* *subjectptr* *instrumentptr*))

(action Lock
	(("lock" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-lock *actorptr* *subjectptr*))

(action LockWith
	(("lock" *subject* "with" *instrument*))
	(and (valid-object? *subjectptr* *actorptr*)
	     (contained-in? *instrumentptr* *actorptr*))
	(perform-action 'do-lock-with *actorptr* *subjectptr* *instrumentptr*))

(action Look
	(("l") ("look") ("examine") ("x"))
	t
	(perform-action 'do-examine *actorptr* (location-of *actorptr*)))

(action LookBehind
	(("look" "behind" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-look-behind *actorptr* *subjectptr*))

(action LookIn
	(("look" "in" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-look-in *actorptr* *subjectptr*))

(action LookThrough
	(("look" "through" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-look-through *actorptr* *subjectptr*))

(action LookUnder
	(("look" "under" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-look-under *actorptr* *subjectptr*))

(action Mention
	((*subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-mention *actorptr* *subjectptr*))
	
(action Oil
	(("oil" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(method *subjectptr* do-oil *actorptr*))

(action Open
	(("open" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-open *actorptr* *subjectptr*))

(action Order
	((*subject* "," *rest*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-order *actorptr* *subjectptr* nil *rest*))

(action Pull
	(("pull" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-pull *actorptr* *subjectptr*))

(action Push
	(("push" *subject*) ("press" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-push *actorptr* *subjectptr*))

(action PutIn
	(("put" *subject* "in" *location*))
	(and (valid-object? *subjectptr* *actorptr*)
	     (valid-object? *locationptr* *actorptr*))
	(perform-action 'do-put-in *actorptr* *subjectptr* *locationptr*))

(action PutOn
	(("put" *subject* "on" *location*))
	(and (valid-object? *subjectptr* *actorptr*)
	     (valid-object? *locationptr* *actorptr*))
	(perform-action 'do-put-on *actorptr* *subjectptr* *locationptr*))

(action Quit
	(("quit"))
	t
	(exit-game))

(action Read
	(("read" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-read *actorptr* *subjectptr*))

(action Rub
	(("rub" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-rub *actorptr* *subjectptr*))

(action Show
	(("show" *subject* "to" *instrument*))
	(and (valid-object? *subjectptr* *actorptr*)
	     (valid-object? *instrumentptr* *actorptr*))
	(perform-action 'do-show *actorptr* *instrumentptr* *actorptr*))

(action Smell
	(("smell" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-smell *actorptr* *subjectptr*))

(action Squeeze
	(("squeeze" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-squeeze *actorptr* *subjectptr*))

(action Status
	(("status"))
	t
	(show-status *actorptr*))

(action Swim
	(("swim"))
	t
	(perform-action 'do-swim *actorptr* (location-of *actorptr*)))

(action Throw
	(("throw" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-throw *actorptr* *subjectptr*))

(action ThrowAt
	(("throw" *instrument* "at" *subject*))
	(and (valid-object? *subjectptr* *actorptr*)
	     (valid-object? *instrumentptr* *actorptr*))
	(perform-action 'do-throw-at *actorptr* *instrumentptr* *subjectptr*))

(action Touch
	(("touch" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-touch *actorptr* *subjectptr*))
	
(action TurnOn
	(("turn" "on" *subject*) ("turn" *subject* "on"))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-turn-on *actorptr* *subjectptr*))

(action TurnOff
	(("turn" "off" *subject*) ("turn" *subject* "off")
	 ("shut" "off" *subject*) ("shut" *subject* "off"))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-turn-off *actorptr* *subjectptr*))

(action Unlock
	(("unlock" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-unlock *actorptr* *subjectptr*))
	
(action UnlockWith
	(("unlock" *subject* "with" *instrument*))
	(and (valid-object? *subjectptr* *actorptr*)
	     (contained-in? *instrumentptr* *actorptr*))
	(perform-action 'do-unlock-with *actorptr* *subjectptr*
			*instrumentptr*))

(action Use
	(("use" *subjectptr*))
	(valid-object? *subjectptr* *actorptr*)
	(print "You'll have to be a bit more explicit than that.\n"))

(action Wait
	(("wait") ("z") ())
	t
	(print "Time passes...\n"))

(action Water
	(("water" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(method *subjectptr* do-water *actorptr*))

(action Wave
	(("wave" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-wave *actorptr* *subjectptr*))

(action WaveHands
	(("wave") ("wave" "hand") ("wave" "hands"))
	t
	(perform-action 'do-wave-hands *actorptr* (location-of *actorptr*)))

(action Wear
	(("wear" *subject*) ("put" "on" *subject*))
	(valid-object? *subjectptr* *actorptr*)
	(perform-action 'do-wear *actorptr* *subjectptr*))



;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

; The void for containing unused objects
;
(object the-void nil (location) nil nil)
(set *voidptr* (findobject 'the-void))


; create an empty object to hold all scenery objects found in the game
;
(object scenery-objects nil (location) nil nil)