;;;;;;;;;;;SCI-INTERFACE.L By Brian Cole
;;;;;;;;;;;High School Computing institute 1997
;;;;;;;;;;;West Jordan High
;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File:         sci-interface.l
; Description:  This is the interface code for the sci rover.
;
; Basic Data Structures:
;	
;	Global variables and Association lists:
;
;	A lot of the global variables are association lists that make it 
;	easy to switch from one type of data to another.  For instance, Cassini
;	directions have colons on the front while the interface directions
;	do not.  All of the A list have macros that give an interface into the
;	type of data needed.  This makes it simpler to update global data
;	used in various places through out the code.  None of the global data
;	should ever be rover specific.  There are two global variables that
;	exceptions to this rule: *the-rover* and *the-rover-name*.  The former
;	is a programmers handle on to the users rover and the latter is a
;	handle on the symbol the user has named their rover.
;
;
;	Terrain-map:
;
;	The terrain map is a hash table of sci-sector objects.
;	The hash key for each sector is the coordinates of the sector,
;	a list containing (x y m).  A new sector object is created only
;	when the sector is visited by the rover.  
;
;	Most of the code in this file is devoted to keeping the map up to date.
;	The basic method of is to update the interfaces as they become known.
;	When an interface is update it fires a daemon that updates the
;	connections that are possible from the current sector to the adjoining
;	sector.  The interfaces are divided into 3 categories: simple, special
;	and impassable.  
;
;	Simple interfaces are interfaces that are the same on both sides and 
;	connect adjacent sectors.  These connections are simple once the 
;	interfaces in both sectors are known.  
;
;	Special interface require some care to update.  All of these 
;	connections can only be updated once the interface is passed through.
;	A door is a good example.  You can not make a door connection unless
;	the door knob is tweaked and you can pass through the door.  Some doors
;	can not be opened.
;	
;	Impassable interfaces cannot be connected.
;
;	An Unkown interface is always connected from the start sector to the
;	end sector because if you got from on to other you can make a
;	connection.  When the interfaces become known this connection maybe
;	changed.
;
;	Number of visits to each sector and connected sector are updated
;	by another daemon.  When a new value is asserted into the number of
;	visits slot of a sector, the daemon tries to find all of the sectors
;	that are connected and update the neighbor visits counts accordingly.
;	
;	The return path is updated by daemon as well.  It is caused by the
;	changing of an interfaces state.  The path is based on the minimal
;	cost to get home along a safe path.  The path cost takes into account
;	the costs and savings of going up and down hill.  The cost will
;	be the amount of energy it takes to get back plus a margin for error.
;	The margin for error is included in case the rover arrives at a sector
;	with no energy but has a negative cost to home.  The margin will
;	allow the rover to keep from running out of gas.
;
;	The logic for doing any of the above updates gets pretty messy.  
;	Cassini is full of lots of special cases.  This code tries to take
;	that into account.  Be cautious when making changes.
;
;
;	Known-objects:
;
;	This is a hash table that contain sci-object objects.
;	The hash key for each object is the object id given by cassini.
;	A new object is created for each new object id the rover encounters.
;	Each object has a slot for each of the possible types of information
;	that has been considered useful.  There is an update method for
;	each type of information.  All object information updates are caused
;	by the method update-object-info.  This method determines what to do
;	based on the current view and the last command.
;
;	The multiple valued slots visible-objects and collected-objects
;	are all based on the known-objects slot.
;
;	
;	Basic Operation:
;
;	The function cassini-rover-interface-function is changed to the
;	package name when the rover code is copied.  This function is 
;	called by cassini and it returns the front action on the list
;	of next actions.
;
;	The rules are fired by asserting a new value into the state slot of
;	the rover.  The new value is either the current value of next-state.
;	If next-state is undefined the current value of state is erased and
;	re-asserted.
;
;	The interface allows for the rules to assert a list of actions for the
;	rover to do.  Each time the rover function is called next action is
;	pulled off this list.  When it becomes empty the rules are made
;	caused to fire.
;
;	The interface is setup to check to the consequence of each action
;	to see if it is valid.  However, the action workings of this system
;	are unimplemented.
;
;	On each call to the function all rover information is updated.  This
;	information includes the terrain-map and known-objects. 
;
;	To run the rover, you first must issue a reset rover command and then
;	call cassini with the normal interface.  The reset rover command is
;	reset- followed by the name of the rover.  So if the name is foo,
;	the command is reset-foo.
;
;               
; Author:       Patrick Dalton
; Created:      13-Jul-92
; Modified:	18-Aug-93 by Eric Eide --- bug fixes and updates to track new
;		  changes in Cassini.
;               12-Jul-94 by Eric Eide --- bug fixes and code cleanups in the
;                 `update-object-*' methods.
;               13-Jul-94 by Eric Eide --- fix problem in new code.
;               14-Jul-94 by Eric Eide --- fix bug in `best-random-direction'.
;               19-Jul-94 by Eric Eide --- hacks to prevent map code crashes.
;
; (c) Copyright 1992, 1993, 1994, University of Utah
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Magic Incantations
;;;

(eval-when (compile load eval)
  (in-package :cole)
  (require "frobs")
  (require "cassini"))
(eval-when (compile load eval)
  (use-package "FROBS")
  (shadowing-import 'cassini::collect)
  (use-package "CASSINI"))
(eval-when (compile load eval)
  (load "/home/cs/other/hsci/accounts/bcole/cole/sci-frobs"))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Debugging Tools
;;;

(defvar *debug-rover* t)
(defmacro dbgprint (&rest args)
  `(if *debug-rover* (format t ,@args)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Local handle on the rover.  The actual rover the students use will be 
;;; dependent on the students choice of names
;;;

(defvar *the-rover*)

;;; *the-rover-name* is modified when the code is copied by the user

(defvar *the-rover-name* (quote cole))
(defvar cole)
(shadowing-import (quote (cole reset-cole)) (find-package "USER"))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; This variable is used to update the return home info only after all of the
;;; interfaces have been updated.

(defvar *re-evaluate-return-home-info*)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Emitter lists and variables.  These are mostly used in the macros below
;;;

(defvar *emitter-types* '(:vis :ir :uv :uwave :radio :audio))

(defvar *emitter-cost* 0.03)

(defvar *emitter-on-look-off-cost* (* (/ 312 3600) *emitter-cost*))

(defvar *emitter-type-slot-pairs* 
  '((:vis vis) (:ir ir) (:uv uv) (:uwave uwave) (:radio radio) (:audio audio)))

(defvar *emitter-slots*
  '((vis   vis-ss   vis-es   vis-emit-p) 
    (ir    ir-ss    ir-es    ir-emit-p)
    (uv    uv-ss    uv-es    uv-emit-p)
    (radio radio-ss radio-es radio-emit-p)
    (uwave uwave-ss uwave-es uwave-emit-p)
    (xray  xray-ss  xray-es  xray-emit-p)
    (audio audio-ss audio-es audio-emit-p)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Terrain and interface costs and lists.  These are mostly used in the macros
;;; below

(defvar *climb-cost* 0.005)

(defvar *safety-margin* 0.3)

(defvar *safe-interfaces*
  ;; Doors are not "safe" by default because the rover might not be able to
  ;; move through them (and therefore, a simple set of rules might cause the
  ;; rover to perpetually move into a closed door).
  '(:tunnel :flat :light-curtain :mud :snow :ridge))

(defvar *damaging-interfaces*
  '(:boulders :rocks :cliff))
  
(defvar *simple-interfaces* 
  '(:flat :mud :snow :ridge :light-curtain :rocks :boulders))

(defvar *special-interfaces*
  '(:tunnel :cave-entrance :cave-exit :door))

(defvar *one-way-interfaces*
  '(:cliff))

(defvar *special-interfaces-and-connections-fns*
  '((:tunnel make-tunnel-connection) (:cave-entrance make-cave-connection)
    (:cave-exit make-cave-connection) (:door make-door-connection)))

(defvar *impassable-interfaces*
  '(:wall :crevasse :gully))

(defvar *opposite-interfaces*
  '((:cave-entrance :cave-exit) (:cave-exit :cave-entrance)))

(defvar *interface-costs* '((:ridge 0.5)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; direction variables and list.  These are used mainly in the macros below
;;;

(defvar *directions* '(:north :east :south :west))

(defvar *dir-vector-pairs* 
  '((:north ( 0  1 0)) (north ( 0  1 0))
    (:east  ( 1  0 0)) (east  ( 1  0 0))
    (:south ( 0 -1 0)) (south ( 0 -1 0))
    (:west  (-1  0 0)) (west  (-1  0 0))))

(defvar *vector-dir-pairs*
  '(((0 1 0) :north) ((1 0 0) :east) ((0 -1 0) :south) ((-1 0 0) :west)))

(defvar *direction-slots* '(north east south west))

(defvar *opposite-direction-pairs*
  '((:north :south) (:east :west) (:south :north) (:west :east)
    ( north  south) ( east  west) ( south  north) ( west  east)))

(defvar *direction-slot-pairs* 
  '((:north north) (:east east) (:south south) (:west west)))

(defvar *slot-direction-pairs* 
  '((north :north) (east :east) (south :south) (west :west)))

(defvar *sector-slots*
  '((north north-visits north-cost north-sector) 
    (east  east-visits  east-cost  east-sector) 
    (south south-visits south-cost south-sector)
    (west  west-visits  west-cost  west-sector)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Macros for a simple interface into the variables above
;;;

;;; reverse-dir
;;;
;;; A macro that returns the opposite direction

(defmacro reverse-dir (dir)
  `(cadr (assoc ,dir *opposite-direction-pairs*)))

;;; get-dir-from-vector
;;; 
;;; A macro that looks at the first 2 elements of a coordinate vector and
;;; finds the direction associated with it.

(defmacro get-dir-from-vector (coord)
  `(cadr (assoc ,coord *vector-dir-pairs* 
		:test #'(lambda (x1 x2) 
			  (and (eq (car x1) (car x2))
			       (eq (cadr x1) (cadr x2)))))))

;;; get-slot-dir:
;;;
;;; A macro that gets the slot direction from a cassini direction

(defmacro get-slot-dir (dir)
  `(cadr (assoc ,dir *direction-slot-pairs*)))

;;; get-cassini-dir:
;;;
;;; A macro that gets the cassini direction from a slot direction

(defmacro get-cassini-dir (dir)
  `(cadr (assoc ,dir *slot-direction-pairs*)))

;;; get-neighbor-slot:
;;;
;;; A macro that returns the slot associated with the coordinates of a in the
;;; direction

(defmacro get-neighbor-slot (dir)
  `(cadddr (assoc ,dir *sector-slots*)))
  
;;; get-cost-slot
;;;
;;; A macro that returns the slot associate with the cost of the interface in 
;;; the direction

(defmacro get-cost-slot (dir)
  `(caddr (assoc ,dir *sector-slots*)))

;;; get-visits-slot
;;;
;;; A macro that returns the slot associated with the number of visits to the
;;; neighbor in the given direction

(defmacro get-visits-slot (dir)
  `(cadr (assoc ,dir *sector-slots*)))

;;; get-special-connection-fn
;;;
;;; A macro that returns the connection update function for the given
;;; interface

(defmacro get-special-connection-fn (interface)
  `(cadr (assoc ,interface *special-interfaces-and-connections-fns*)))

;;; get-opposite-interface
;;;
;;; A macro that returns the type of interface that is always opposite
;;; the given interface

(defmacro get-opposite-interface (interface)
  `(or (cadr (assoc ,interface *opposite-interfaces*))
       ,interface))

;;; get-emitter-slot-base
;;;
;;; A macro that given the type of an emitter will return the base emitter name

(defmacro get-emitter-slot-base (type)
  `(cadr (assoc ,type *emitter-type-slot-pairs*)))

;;; get-emitter-ss
;;;
;;; A macro that returns the symbol for the sensor status of a type of sensor

(defmacro get-sensor-status (type)
  `(cadr (assoc (get-emitter-slot-base ,type) *emitter-slots*)))

;;; get-emitter-status
;;; 
;;; A macro that returns the symbol for the emitter status of a type of emitter

(defmacro get-emitter-status (type)
  `(caddr (assoc (get-emitter-slot-base ,type) *emitter-slots*)))
  
;;; get-emitter-emit-p
;;;
;;; A macro that returns the symbol for the emitter on/off of a type of emitter

(defmacro get-emitter-emit-p (type)
  `(cadddr (assoc (get-emitter-slot-base ,type) *emitter-slots*)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Predicate macros
;;;

;;; definedp
;;;

(defmacro definedp (v) `(not (eq '*undefined* ,v)))


;;; simple-interface-p
;;;
;;; A macro that returns whether an interface is the same going both
;;; directions

(defmacro simple-interface-p(interface)
  `(member ,interface *simple-interfaces*))

;;; special-interface-p
;;;
;;; A macro that returns whether an interface is considered needs special
;;; treatment to make a connection

(defmacro special-interface-p(interface)
  `(member ,interface *special-interfaces*))

;;; safe-interface-p
;;;
;;; A macro that returns whether an interface is considered safe

(defmacro safe-interface-p(interface)
  `(member ,interface (safe-interfaces *the-rover*)))

;;; impassable-interface-p
;;;
;;; A macro that returns whether an interface is considered safe

(defmacro impassable-interface-p(interface)
  `(member ,interface *impassable-interfaces*))

;;; one-way-interface-p
;;;
;;; A macro that returns whether an interface is a one way interface.

(defmacro one-way-interface-p (interface)
  `(member ,interface *one-way-interfaces*))

;;; is-home-sector-p
;;;
;;; A macro that says whether the current sector is where the base is

(defmacro is-home-sector-p (sector)
  `(equal (coord ,sector) (get-home-coord *the-rover*)))

;;; return-home-p
;;; 
;;; A macro that returns whether the give action is a call to return home

(defmacro return-home-p (action)
  `(or (eq (car ,action) 'go-home) (eq (car ,action) 'continue-home)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Special purpose macros
;;;

;;; coord-x, coord-y, coord-m:
;;;
;;; Macros for taking apart a coordinate

(defmacro coord-x(c)     `(car ,c))
(defmacro coord-y(c)     `(cadr ,c))
(defmacro coord-m(c)     `(caddr ,c))

;;; get-elevation
;;;
;;; A macro that gets the elevation from view of the rover

(defmacro get-elevation (view)
  `(cadr (assoc :elevation ,view)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                         ;;;
;;;        B A S I C   I N T E R F A C E                                    ;;;
;;;                                                                         ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; cassini-rover-interface-function:
;;;
;;; A function that cassini calls to get the rover to issue its next command.
;;; The actual name of this function is determined when the user gets their
;;; copy of the code.

(defun cole (rover-struct base-struct)
  (let ((*package* 
         (find-package :cole)
	 ))
    (store-rover-info *the-rover* rover-struct base-struct)
    (if (not (and (allowed-consequence-p *the-rover*)
		  (next-actions *the-rover*)))
      (start-rover-thinking *the-rover*))
    (issue-next-action *the-rover*)))


;;; reset-rover-function:
;;;
;;; A function that destroys the old rover frob and creates a new one for
;;; the current execution.  The name of this function is modified when the
;;; user gets their copy of the code.

(defun reset-cole ()
  (let ((*package*
         (find-package :cole)
	 )) 
    (setf (symbol-value *the-rover-name*)
	  (initial-rover-state *the-rover-name*))))

    
;;; initial-rover-state:
;;;
;;; A function that resets all the slots in the rover to the beginning
;;; information.

(defun initial-rover-state (rover-symbol)
  (format t "Readying rover ~a~%" rover-symbol)
  (if (and (boundp rover-symbol) 
	   (frob? (symbol-value rover-symbol)) 
	   (frob-type? (symbol-value rover-symbol) {class sci-rover}))
    (let ((rover-frob (symbol-value rover-symbol)))
      (setf (symbol-value rover-symbol) nil)
      (maphash #'(lambda (key frob) (kill-frob frob)) 
	       (terrain-map rover-frob))
      (maphash #'(lambda (key frob) (kill-frob frob)) 
	       (known-objects rover-frob))
      (kill-frob rover-frob)))

  (let ((new-rover
	 (new-instance {class sci-rover}
		       :init ((nil (safe-interfaces *safe-interfaces*)
				   (favored-directions *directions*)
				   (north-visits 0)
				   (east-visits 0)
				   (south-visits 0)
				   (west-visits 0)
				   (terrain-map   
				    (make-hash-table :test #'equal))
				   (known-objects 
				    (make-hash-table :test #'equal))
				   (num-move-actions 0)
				   (next-actions nil)
				   (last-action  nil)
				   (next-state 'initialize))))))
    (setf *the-rover* new-rover)
    (setf *the-rover-name* rover-symbol)
    new-rover))
  

;;; store-rover-info
;;;
;;; These methods copy information from the Cassini rover structure into our
;;; rover Frob.  

(def-method ({class sci-rover} store-rover-info) (rover-struct base-struct)
  (setf (id $self) (rover-id rover-struct))
  (setf (m $self)  (rover-m rover-struct))
  (setf (x $self)  (rover-x rover-struct))
  (setf (y $self)  (rover-y rover-struct))
  (setf (elevation $self) (get-elevation (rover-view rover-struct)))
  (setf (battery-charge $self) (rover-battery-charge rover-struct))
  (setf (charges-left $self)   (rover-charges-left rover-struct))
  (setf (collection $self)     (rover-collection rover-struct))
  (setf (body $self) (rover-body rover-struct))
  (setf (arm $self)  (rover-arm rover-struct))
  (setf (laser $self)(rover-laser rover-struct))
  (setf (consequence $self) (rover-consequence rover-struct))
  (setf (visits $self) (rover-visits rover-struct))
  (setf (view $self)   (rover-view rover-struct))
  (setf (home-x $self) (base-x base-struct))
  (setf (home-y $self) (base-y base-struct))
  (setf (home-m $self) (base-m base-struct))
  
  (if (not (equal (get-last-coord $self) (get-coord $self)))
    (progn
      (setf (prev-x $self) (last-x $self))
      (setf (prev-y $self) (last-y $self))
      (setf (prev-m $self) (last-m $self))
      (incf (num-move-actions $self))))
      
  (store-transducer-info $self (rover-transducers rover-struct))
  (update-rover-terrain-info $self)
  (update-object-info $self)
  (dbgprint "fuel ~a fuelhome ~a~%" 
	      (fuel-remaining $self) (fuel-to-go-home $self)))


;;; store-transducer-info
;;;

(def-method ({class sci-rover} store-transducer-info) (transducers)
  ;; Each transducer (emitter-and-sensor pair) is represented by an "eqpt"
  ;; structure with fields "ss", "es", and "emit-p".  "transducers" is one
  ;; big structure containing one "eqpt" structure for each of our transducers.
  ;; Got that?
  (setf (vis-ss $self)       (eqpt-ss (freq-vis transducers)))
  (setf (vis-es $self)       (eqpt-es (freq-vis transducers)))
  (setf (vis-emit-p $self)   (eqpt-emit-p (freq-vis transducers)))

  (setf (ir-ss $self)        (eqpt-ss (freq-ir transducers)))
  (setf (ir-es $self)        (eqpt-es (freq-ir transducers)))
  (setf (ir-emit-p $self)    (eqpt-emit-p (freq-ir transducers)))

  (setf (uv-ss $self)        (eqpt-ss (freq-uv transducers)))
  (setf (uv-es $self)        (eqpt-es (freq-uv transducers)))
  (setf (uv-emit-p $self)    (eqpt-emit-p (freq-uv transducers)))

  (setf (radio-ss $self)     (eqpt-ss (freq-radio transducers)))
  (setf (radio-es $self)     (eqpt-es (freq-radio transducers)))
  (setf (radio-emit-p $self) (eqpt-emit-p (freq-radio transducers)))

  (setf (uwave-ss $self)     (eqpt-ss (freq-uwave transducers)))
  (setf (uwave-es $self)     (eqpt-es (freq-uwave transducers)))
  (setf (uwave-emit-p $self) (eqpt-emit-p (freq-uwave transducers)))

  (setf (xray-ss $self)      (eqpt-ss (freq-xray transducers)))
  (setf (xray-es $self)      (eqpt-es (freq-xray transducers)))
  (setf (xray-emit-p $self)  (eqpt-emit-p (freq-xray transducers)))

  (setf (audio-ss $self)     (eqpt-ss (freq-audio transducers)))
  (setf (audio-es $self)     (eqpt-es (freq-audio transducers)))
  (setf (audio-emit-p $self) (eqpt-emit-p (freq-audio transducers))))


;;; allowed-consequence-p
;;;
;;; A function that checks to see if the recieved consequence of an
;;; action is the one of the allowed consequences.  
;;; (It is unimplemented for now)

(def-method ({class sci-rover} allowed-consequence-p) ()
  t)


;;; start-rover-thinking
;;;
;;; A function that asserts the next-state into current state to 
;;; start the rover's rules firing.

(def-method ({class sci-rover} start-rover-thinking) ()
  (let ((new-state (if (definedp (next-state $self))
		      (next-state $self)
		      (state $self))))
    (erase $self 'state)
    (erase $self 'next-state)
    (assert-val $self 'state new-state)))


;;; issue-next-action
;;; 
;;; A function that returns to cassini the action that is going to
;;; be taken by the rover.  It also places the action returned in
;;; last-action and updates the allowed consequences for that action
;;; (consequences are currently not observed)

(def-method ({class sci-rover} issue-next-action ) ()
  (if (and (return-home-p (car (next-actions $self)))
	   (not (at-home-p $self)))
      (setf (next-actions $self) (append (get-moves-home $self)
					 (cdr (next-actions $self)))))
  (setf (last-x $self) (x $self))
  (setf (last-y $self) (y $self))
  (setf (last-m $self) (m $self))
  (setf (last-action $self) (pop (next-actions $self)))
  (if (eq (car (last-action $self)) 'move)
    (setf (last-move-action $self) (last-action $self)))
  (format t "~%~a's command: ~s~%" *the-rover-name* (last-action $self))
  (last-action $self))


;;; get-moves-home
;;; 
;;; A method that takes the path and turns it into a list of commands 
;;; saying turn off all emitters that are on, a command to move the direction
;;; that is first on the path home and go-home

(def-method ({class sci-rover} get-moves-home) ()
  (append (turn-off-emitters $self)
	  (cons (list 'move (get-cassini-dir (car (path-home $self))))
		(and (cdr (path-home $self)) '((continue-home))))))


;;; turn-off-emitters
;;;
;;; A method that makes a list of the commands to turn off all of the
;;; emitters that are on

(def-method ({class sci-rover} turn-off-emitters) ()
  (let ((emitter-off-list nil))
    (dolist (emitter *emitter-types*)
      (if (ask $self (get-emitter-emit-p emitter))
	(push `(emitter-off ,emitter) emitter-off-list)))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                         ;;;
;;;         M A P   I N T E R F A C E    C O D E                            ;;;
;;;                                                                         ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; update-rover-terrain-info
;;;
;;; A method that updates all the information that rover uses
;;; that is based on terrain

(def-method ({class sci-rover} update-rover-terrain-info) ()
  (let ((sector (or (get-sector (get-coord $self) (terrain-map $self))
		    (make-a-sector (get-coord $self) 
				   (elevation $self)
				   (terrain-map $self))))
	(interfaces (get-interfaces (view $self)))
	(*re-evaluate-return-home-info* nil))
    (if (not (definedp (at-home-p $self)))
      (progn
	(setf *re-evaluate-return-home-info* t)
	(setf (times-visited sector) 1)))
    (update-interfaces sector interfaces)
    (if (movedp $self)
      (progn
	(if (and (eq (car (last-action $self)) 'move)
		 (not (eq :gully 
			  (ask (get-sector (get-prev-coord $self)
					       (terrain-map $self))
			       (get-slot-dir (cadr (last-action $self))))))
		 (moved-expected-direction-p $self))
	  (make-forced-connection (get-coord $self)
				  (get-prev-coord $self) 
				  (last-move-action $self)))
	(if (= (times-visited sector) 0)
	  (setf *re-evaluate-return-home-info* t))
	(assert-val sector 'times-visited (1+ (times-visited sector)))))
    (update-view-info $self sector)
    (if *re-evaluate-return-home-info* 
      (progn
	(erase sector 'cost-to-home)
	(assert-val sector 'cost-to-home :unknown)))
    (update-return-home-info $self sector)))
    

;;; update-return-home-info
;;;
;;; A method that update all slots in the rover that are based on
;;; the returning home info in the current sector

(def-method ({class sci-rover} update-return-home-info) (sector)
  (setf (at-home-p $self)       (is-home-sector-p sector))
  (setf (fuel-to-go-home $self) (cost-to-home sector))
  (setf (path-home $self)       (if (definedp (path-to-home sector))
				  (mapcar #'car (path-to-home sector))))
  (setf (fuel-remaining $self)  (battery-charge $self)))

	
;;; update-interfaces
;;;
;;; A method that updates the interfaces for a map sector given
;;; the current view.  

(def-method ({class sci-sector} update-interfaces) (interfaces)
  (dolist (interface interfaces)
    (if (and (special-interface-p (cadr interface))
	     (not (definedp (ask $self 
				 (get-neighbor-slot 
				   (get-slot-dir (car interface)))))))
      (erase $self (get-slot-dir (car interface))))
    (if (not (eq (cadr interface) :unknown))
      (assert-val $self (get-slot-dir (car interface))
		  (cadr interface)))))


;;; update-view-info
;;;
;;; A method that updates the view info for the rover by
;;; copying view information for the sector

(def-method ({class sci-rover} update-view-info) (sector)
  (setf (north $self) (north sector))
  (setf (north-visits $self) (north-visits sector))
  (setf (east $self) (east sector))
  (setf (east-visits $self) (east-visits sector))
  (setf (south $self) (south sector))
  (setf (south-visits $self) (south-visits sector))
  (setf (west $self) (west sector))
  (setf (west-visits $self) (west-visits sector)))


;;; moved-expected-direction-p
;;;
;;; A method that checks to see if the rover moved the direction set by
;;; the move command and the interface.  Tunnels can come out anywhere.

(def-method ({class sci-rover} moved-expected-direction-p) ()
  (or (eq (ask (get-sector (get-prev-coord $self) (terrain-map $self))
	       (get-slot-dir (cadr (last-action $self))))
	  :tunnel)
      (eq (cadr (last-action $self))
	  (get-dir-from-vector (mapcar #'- 
				       (get-coord $self) 
				       (get-prev-coord $self))))))


;;; get-coord
;;;
;;; A method that returns a list containing the x y and m of the
;;; current location of the rover

(def-method ({class sci-rover} get-coord) ()
  (list (x $self) (y $self) (m $self)))


;;; get-home-coord
;;;
;;; A method that returns a list containing the x y and m of the
;;; home location of the rover

(def-method ({class sci-rover} get-home-coord) ()
  (list (home-x $self) (home-y $self) (home-m $self)))


;;; get-prev-coord
;;;
;;; A method that returns a list containing the x y and m of the
;;; previoius location of the rover

(def-method ({class sci-rover} get-prev-coord) ()
  (list (prev-x $self) (prev-y $self) (prev-m $self)))


;;; get-last-coord
;;;
;;; A method that returns a list containing the x y and m of the
;;; location of the rover before the last command

(def-method ({class sci-rover} get-last-coord) ()
  (list (last-x $self) (last-y $self) (last-m $self)))


;;; movedp:
;;;
;;; A method that determines whether the rover has moved by
;;; checking the current coords with the last coords

(def-method ({class sci-rover} movedp) ()
  (and (definedp (last-move-action $self))
       (not (equal (get-coord $self) (get-last-coord $self)))))


;;; get-neighbor
;;;
;;; A method that finds the neighbor associate with the direction

(def-method ({class sci-sector} get-neighbor) (dir)
  (let ((nbr-coord (get-coord-of-neighbor $self dir)))
    (if (definedp nbr-coord)
      (get-sector nbr-coord (terrain-map *the-rover*)))))


;;; get-coord-of-neighbor
;;; 
;;; A method that returns the coord of a neighbor sector in a given direction.
;;; It returns *undefined* if the neighbor hasn't been defined.

(def-method ({class sci-sector} get-coord-of-neighbor) (dir)
  (ask $self (get-neighbor-slot dir)))


;;; get-cost-to-neighbor
;;;
;;; A method that returns the cost to neigbor in a direction
;;; This method assumes the neighbor exists

(def-method ({class sci-sector} get-cost-to-neighbor) (dir)
  (ask $self (get-cost-slot dir)))


;;; guess-neighbor
;;;
;;; A method that guess where the neighbor in the give direction should be

(def-method ({class sci-sector} guess-neighbor) (dir)
  (get-sector (trans-coord dir (coord $self)) (terrain-map *the-rover*)))


;;; get-interface-by-type
;;;
;;; A method that looks in a sector to see if there is an interface of type in
;;; the direction dir

(def-method ({class sci-sector} get-interface-by-type) (type dir)
  (and (eq type (ask $self dir)) dir))


;;; get-interface-by-neighbor
;;;
;;; A method that finds an interface that connects to coordinate and returns
;;; that direction

(def-method ({class sci-sector} get-interface-by-neighbor) (nbr-coord)
  (dolist (dir *direction-slots* nil)
    (if (equal (ask $self (get-neighbor-slot dir)) nbr-coord)
      (return dir))))


;;; get-interfaces
;;;
;;; A function that returns the direction and interface information
;;; from the view information of a rover

(defun get-interfaces (view)
  (let ((interfaces nil))
    (dolist (direction *directions* interfaces)
      (push (assoc direction view) interfaces))))


;;; trans-coord
;;;
;;; A function that given a coordinate translates it in the direction given

(defun trans-coord (direction coord)
  (mapcar #'+ coord (cadr (assoc direction *dir-vector-pairs*))))


;;; get-sector
;;;
;;; A function that returns the sector from the map specified.
;;; It creates it if it doesn't exit

(defun get-sector (coord  &optional (map nil))
  (if map
    (gethash coord map)
    (gethash coord (terrain-map *the-rover*))))


;;; make-a-sector
;;;
;;; A function that returns a new map sector

(defun make-a-sector (coord elevation &optional (map nil))
  (let* ((map (or map (terrain-map *the-rover*)))
	 (sector (gethash coord map)))
    (if (not sector)
      (progn
	(setf sector (new-instance {class sci-sector}))
	(setf (coord sector) coord)
	(setf (elevation sector) elevation)
	(setf (gethash coord map) sector)))
    sector))


;;; update-sector-connection
;;;
;;; A daemon that fires after an assert into one of the direction interface 
;;; slots of a sector object.  It checks to see if the neighbor of the object
;;; in the direction is defined and has a safe interface.  If so it
;;; updates both sectors interfaces.

(define-daemon ({class sci-sector} update-sector-connection 
		       (north east south west) :after-assert)
  (let (neighbor
	sector
	interface-dir
	(rev-dir (reverse-dir $slot)))
    (cond ((and (simple-interface-p (ask $self $slot))
		(setf neighbor (guess-neighbor $self $slot))
		(not (eq (ask neighbor rev-dir) :unknown)))
	   (update-connection $self $slot neighbor)
	   (update-connection neighbor rev-dir $self))

	  ((and (special-interface-p (ask $self $slot))
		(not (definedp (ask $self (get-neighbor-slot $slot))))
		(setf sector (get-sector (get-prev-coord *the-rover*)
					 (terrain-map *the-rover*)))
		(setf interface-dir 
		      (get-interface-by-type 
		       sector 
		       (get-opposite-interface 
			(ask $self $slot))
		       (get-slot-dir (cadr (last-move-action *the-rover*)))))
		(eq interface-dir
		    (get-slot-dir (cadr (last-move-action *the-rover*)))))
	   (make-connection (coord $self)
			    (get-prev-coord *the-rover*)
			    (last-move-action *the-rover*)))
	  
	  ((and (one-way-interface-p (ask $self $slot))
		(setf neighbor (guess-neighbor $self $slot)))
	   (update-connection $self $slot neighbor))

	  ((and (impassable-interface-p (ask $self $slot))
		(definedp (ask $self (get-neighbor-slot $slot))))
	   (setf *re-evaluate-return-home-info* t)
	   (erase $self (get-neighbor-slot $slot))
	   (erase $self (get-cost-slot $slot))))))


;;; make-forced-connection
;;;
;;; A connection that is made from the last sector to the current sector
;;; regardless of the interface type.  The connection is considered to be
;;; one way since if there is more information it will be updated.

(defun make-forced-connection (current-coord last-coord last-action)
  (let* ((cur-sector  (get-sector current-coord (terrain-map *the-rover*)))
	 (last-sector (get-sector last-coord (terrain-map *the-rover*)))
	 (dir         (get-slot-dir (cadr last-action))))
    (if (not (definedp (ask last-sector (get-neighbor-slot dir))))
      (update-connection last-sector dir cur-sector))))

		     
;;; make-connection
;;;
;;; A function that setups the map connections between two sectors.

(defun make-connection (current-coord last-coord last-action)
  (let* ((cur-sector     (get-sector current-coord (terrain-map *the-rover*)))
	 (last-sector    (get-sector last-coord (terrain-map *the-rover*)))
	 (dir            (get-slot-dir (cadr last-action)))
	 (last-interface (ask last-sector dir)))
    (if (special-interface-p last-interface)
      (funcall (symbol-function (get-special-connection-fn last-interface))
	       last-sector cur-sector dir))))


;;; make-tunnel-connection
;;;
;;; A function that setup the map connections between two sectors connected
;;; by a tunnel

(defun make-tunnel-connection (start-sector end-sector dir)
  (let ((return-dir (get-interface-by-type end-sector
					   :tunnel
					   (reverse-dir dir))))
    (if return-dir
      (progn
	(update-connection start-sector dir end-sector)
	(update-connection end-sector return-dir start-sector)))))


;;; make-cave-connection
;;;
;;; A function that makes a connection between cave-entrances and cave-exits

(defun make-cave-connection (start-sector end-sector dir)
  (let ((return-dir
	 (get-interface-by-type end-sector 
				(get-opposite-interface (ask start-sector dir))
				(reverse-dir dir))))
    (if return-dir
      (progn
	(update-connection start-sector dir end-sector)
	(update-connection end-sector return-dir start-sector)))))


;;; make-door-connection
;;;
;;; A function that makes a connection through a door

(defun make-door-connection (start-sector end-sector dir)
  (let ((return-dir (get-interface-by-type end-sector
					   :door
					   (reverse-dir dir))))
    (if return-dir
      (progn
	(update-connection start-sector dir end-sector)
	(update-connection end-sector return-dir start-sector)))))


;;; update-connection
;;;
;;; A method that updates the connection in the direction dir to neighbor

(def-method ({class sci-sector} update-connection) (dir neighbor)
  (setf *re-evaluate-return-home-info* t)
  (assert-val $self (get-neighbor-slot dir) (coord neighbor))
  (assert-val $self (get-cost-slot dir) 
	      (interface-cost (ask $self dir) 
			      (elevation $self) (elevation neighbor)))
  (assert-val $self (get-visits-slot dir) (times-visited neighbor)))
	     


;;; interface-cost
;;;
;;; A function that returns the cost of going across an interface

(defun interface-cost (itype start-elevation end-elevation)
  (+ (+ 1 (or (cadr (assoc itype *interface-costs*)) 0))
     (* *climb-cost* (- end-elevation start-elevation))))


;;; update-neighbor-visits
;;;
;;; A daemon that updates the number of visits in each of the connecting
;;; sectors.

(define-daemon ({class sci-sector} 
		       update-neighbor-visits times-visited :after-assert)
  (dolist (dir *direction-slots*)
    (cond ((and (definedp (ask $self (get-neighbor-slot dir)))
		(simple-interface-p (ask $self dir)))
	   (assert-val (get-sector (ask $self (get-neighbor-slot dir))
				   (terrain-map *the-rover*))
		       (get-visits-slot (reverse-dir dir))
		       (times-visited $self)))
	  
	  ((and (definedp (ask $self (get-neighbor-slot dir)))
		(special-interface-p (ask $self dir)))
	   (let* ((neighbor (get-sector (ask $self (get-neighbor-slot dir))
					(terrain-map *the-rover*)))
		  (slot (get-visits-slot
			 (get-interface-by-neighbor neighbor (coord $self))))
		  )
	     (when slot
	       (assert-val neighbor
			   slot
			   (times-visited $self))
	       )))
	  
	  (t
	   (let ((neighbor (guess-neighbor $self dir)))
	     (if (and neighbor
		      (definedp (ask neighbor 
				     (get-neighbor-slot (reverse-dir dir))))
		      (equal (coord $self)
			     (ask neighbor
				  (get-neighbor-slot (reverse-dir dir)))))
	       (assert-val neighbor
			   (get-visits-slot (reverse-dir dir))
			   (times-visited $self))))))))


;;; calculate-cost-to-go-home
;;;
;;; A daemon that calculates the cost to go home recursively based
;;; on the information its neighbors have.

(define-daemon ({class sci-sector} 
		       calculate-cost-to-go-home cost-to-home :after-assert)
  (if (is-home-sector-p $self)
    (progn
      (setf (path-to-home $self) nil)
      (assert-val $self 'cost-to-home 0))
    (let (rev-dir nbr)
      (dolist (dir *direction-slots*)
	(setf rev-dir (reverse-dir dir))
	(if (and (or (safe-interface-p (ask $self dir))
		     (special-interface-p (ask $self dir)))
		 (setf nbr (get-neighbor $self dir)))
	  (let ((my-new-cost-to-home
		 (compute-new-cost-to-home (cost-to-home nbr) 
					   (path-to-home nbr)
					   (get-cost-to-neighbor $self dir)
					   dir))
		(nbr-new-cost-to-home
		 (compute-new-cost-to-home (cost-to-home $self)
					   (path-to-home $self)
					   (get-cost-to-neighbor nbr rev-dir)
					   rev-dir)))
	    (cond ((better-cost-home my-new-cost-to-home (cost-to-home $self))
		   (setf (path-to-home $self)
			 (cons (list dir (get-cost-to-neighbor $self dir))
			       (path-to-home nbr)))
		   (assert-val $self 'cost-to-home my-new-cost-to-home))
		  ((better-cost-home nbr-new-cost-to-home (cost-to-home nbr))
		   (setf (path-to-home nbr)
			 (cons (list rev-dir 
				     (get-cost-to-neighbor nbr rev-dir))
			       (path-to-home $self)))
		   (assert-val nbr 'cost-to-home nbr-new-cost-to-home)))))))))


;;; compute-new-cost-to-home
;;;
;;; A function that computes the cost to home from a neighbor and the
;;; cost of travelling through the interface.  It also checks to make sure
;;; that the amount of energy to travel the path is greater than the
;;; cost of the path.  If it is it returns that cost.

(defun compute-new-cost-to-home (base-cost-home base-path-home 
						interface-cost dir)
  (if (or (not (numberp base-cost-home))
	  (not (numberp interface-cost)))
      :unknown
      (compute-path-cost (cons (list dir interface-cost) base-path-home))))


;;; compute-path-cost
;;; 
;;; A function that computes a running total of the cost along a path
;;; The cost must be the maximum cost of any part of the path +
;;; the safety margin.  The necessary-cost is that cost.

(defun compute-path-cost (path)
  (compute-path-cost-aux 0 0 path))

(defun compute-path-cost-aux (running-cost necessary-cost path)
  (cond ((null path) necessary-cost)
	(t
	 (compute-path-cost-aux (+ running-cost (cadar path))
				(max (+ running-cost (cadar path) 
					*safety-margin*)
				     necessary-cost)
				(cdr path)))))


;;; better-cost-home
;;;
;;; A function that determines whether the new cost is better than
;;; the old cost

(defun better-cost-home (new-cost old-cost)
  (cond ((and (eq :unknown new-cost) (eq :unknown old-cost)) nil)
	((eq :unknown old-cost) t)
	((eq :unknown new-cost) nil)
	(t (< new-cost old-cost))))


;;; re-evaluate-all-costs-to-home
;;;
;;; A function that forces the re-calculation of the cost to home for the
;;; entire map.  It causes the re-calculation by setting all the costs to
;;; home unknown then asserting the value unknown in each of the neighbors
;;; of the home sector if they exist.

(defun re-evaluate-all-costs-to-home ()
  (let ((home-sector (get-sector (get-home-coord *the-rover*) 
				 (terrain-map *the-rover*)))
	neighbor)
    (maphash #'(lambda (key value) (setf (cost-to-home value) :unknown))
	     (terrain-map *the-rover*))
    (setf (cost-to-home home-sector) 0)
    (dolist (dir *direction-slots*)
      (if (setf neighbor (get-neighbor home-sector dir))
	(progn
	  (erase neighbor 'cost-to-home)
	  (assert-val neighbor 'cost-to-home :unknown))))))
    

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                         ;;;
;;;            O B J E C T    I N T E R F A C E   C O D E                   ;;;
;;;                                                                         ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; update-object-info
;;;
;;; A method that updates the rover's object information

(def-method ({class sci-rover} update-object-info) ()
  (let ((obj-descs (get-object-desc (view $self)))
	(last-command (car  (last-action $self)))
	(obj-id       (cadr (last-action $self)))
	(consequence  (consequence $self))
	obj)

    ;; Update object locations
    (cond ((or (eq 'look last-command)
	       (and (eq 'move last-command)
		    (intersection '(:allowed :slowed) consequence)))
	   (erase $self 'visible-objects)
	   (dolist (obj-desc obj-descs)
	     (setf obj (get-object-by-desc obj-desc (known-objects $self)))
	     (setf (location obj) (get-coord $self))
	     (setf (visible-objects $self) obj)))

	  ((and (eq 'collect last-command)
		(member :collected consequence))
	   (setf obj (get-object-by-id obj-id (known-objects $self)))
	   (setf (location obj) :collected)
	   (setf (collected-objects $self) obj)
	   (remove-val $self 'visible-objects obj))
	  
	  ((eq 'tweak last-command)
	   (if (member :tweaked consequence)
	     (setf (tweaked-p (get-object-by-id obj-id 
						(known-objects $self))) t))
	   (if (member :object-stolen consequence)
	     (progn
	       (erase $self 'collected-objects)
	       (dolist (obj-id (collection $self))
		 (setf obj (get-object-by-id obj-id (known-objects $self)))
		 (setf (location obj) :collected)
		 (setf (collected-objects $self) obj)))))

	  ((and (eq 'deliver last-command)
		(member :delivered consequence))
	   (dolist (obj (collected-objects $self))
	     (setf (location obj) :delivered))
	   (erase $self 'collected-objects))

	  ((and (eq 'drop last-command)
		(member :dropped consequence))
	   (setf obj (get-object-by-id obj-id (known-objects $self)))
	   (setf (location obj) (get-coord $self))
	   (setf (visible-objects $self) obj)
	   (remove-val $self 'collected-objects obj))
	   
	  ((and (eq 'cut-from last-command)
		(member :laser-fired consequence))
	   (setf obj (get-object-by-id obj-id (known-objects $self)))
	   (incf (times-cut obj)))

	  ((and (eq 'zap last-command)
		(member :laser-fired consequence))
	   (setf obj (get-object-by-id obj-id (known-objects $self)))
	   (setf (lasered-p obj) t)
	   (cond ((member :object-vaporized consequence)
		  (setf (location obj) :object-vaporized))
		 ((member :object-exploded consequence)
		  (setf (location obj) :object-exploded))))
		 
	  ((and (eq 'replace-part last-command)
		(not (intersection consequence 
				   '(:object-not-found
				     :no-such-component 
				     :arm-broken))))
	   (setf obj (get-object-by-id obj-id (known-objects $self)))
	   (setf (location obj) :used-as-spare)
	   (remove-val $self 'collected-objects obj)))))
	   

;;; get-object-desc
;;; 
;;; A function that takes a rover's view and returns the modified list
;;; that only contains objects.  It also removes the rover and the base.

(defun get-object-desc (view)
  (mapcar #'cdr
	  (remove-if #'(lambda (ele)
			 (or (not (eq :here (car ele)))
			     (eq :myself (cddr ele))
			     (eq :my-base (cddr ele))))
		     view)))


;;; get-object-by-desc
;;;
;;; A function that gets an object from the known objects if it
;;; exists or creates it if it does not.

(defun get-object-by-desc (desc &optional (known-objects nil))
  (let* ((known-objects (or known-objects (known-objects *the-rover*)))
	 (obj-id (car desc))
	 (obj    (gethash obj-id known-objects)))
    (if (not obj)
      (progn
	(setf obj (make-an-object obj-id))
	(setf (gethash obj-id known-objects) obj)))
    (update-object-description obj (cdr desc))
    obj))


;;; get-object-by-id
;;;
;;; A function that gets an object by its id.

(defun get-object-by-id (id &optional (known-objects nil))
  (let* ((known-objects (or known-objects (known-objects *the-rover*)))
	 (obj (gethash id known-objects)))
    (if (not obj)
      (progn
	(setf obj (make-an-object id))
	(setf (gethash id known-objects) obj)))
    obj))


;;; make-an-object
;;;
;;; A function that make a new object

(defun make-an-object (id)
  (let ((new-obj (new-instance {class sci-object} 
			       :init ((nil (color             :unknown)
					   (shape             :unknown)
					   (size              :unknown)
					   (surface-quality   :unknown)
					   (sound             :unknown)
					   (radioactive-p     :unknown)
					   (fluorescent-color :unknown)
					   (warm-p            :unknown)
					   (glow-color        :unknown)
					   (tweaked-p         nil)
					   (times-cut         0)
					   (lasered-p         nil))))))
    (setf (id new-obj) id)
    new-obj))


;;; update-object-description
;;;
;;; A method that updates an objects description give the current description.

(def-method ({class sci-object} update-object-description) (desc)
  (update-object-color $self desc)
  (update-object-shape $self desc)
  (update-object-size  $self desc)
  (update-object-surface-quality $self desc)
  (update-object-sound   $self desc)
  (update-object-radioactivity $self desc)
  (update-object-fluorescent-color $self desc)
  (update-object-warmth $self desc)
  (update-object-glow-color $self desc))


;;; update-object-color
;;;
;;; A method that updates the color if it is unknown.

(def-method ({class sci-object} update-object-color) (desc)
  (when (eq :unknown (color $self))
    (setf (color $self) (or (get-vis-attribute :color desc)
			    :unknown))))


;;; update-object-shape
;;;
;;; A method that updates the shape if it is unknown.

(def-method ({class sci-object} update-object-shape) (desc)
  (when (eq :unknown (shape $self))
    (setf (shape $self) (or (get-vis-attribute :shape desc)
			    :unknown))))


;;; update-object-size
;;;
;;; A method that updates the size if it is unknown.

(def-method ({class sci-object} update-object-size) (desc)
  (when (eq :unknown (size $self))
    (setf (size $self) (or (get-vis-attribute :size desc)
			   :unknown))))


;;; update-object-surface-quality
;;;
;;; A method that updates the quality of the surface of an object.

(def-method ({class sci-object} update-object-surface-quality) (desc)
  (when (eq :unknown (surface-quality $self))
    (let ((surface-quality (find :surface desc :key #'cadr)))
      (setf (surface-quality $self)
	    (if surface-quality
		(intern
		 (concatenate 'string
			      ;; Emission frequency (e.g., `uwave')...
			      (symbol-name (if (symbolp (car surface-quality))
					       (car surface-quality)
					       (cadr (car surface-quality))))
			      "-"
			      ;; Attribute value (e.g., `reflective')...
			      (symbol-name (caddr surface-quality)))
		 ;; NOTE that `find-package' is capitalized in order to hide it
		 ;; from the `awk' script that munges this file for each
		 ;; student.
		 (FIND-PACKAGE :keyword))
		;; Otherwise...
		:unknown))
      )))


;;; update-object-sound
;;;
;;; A method that updates the sound an object makes.  Note that there is no
;;; need for an :UNKNOWN case here, but there *is* a need to update even when
;;; the sound of the object was previously known.  Bombs start ticking only
;;; when they are jostled.

(def-method ({class sci-object} update-object-sound) (desc)
  ;; (when (eq :unknown (sound $self)) ...)
  (setf (sound $self)
	;; The attribute value of the (... :sound ...) attribute...
	(caddr (find :sound desc :key #'cadr)))
  )


;;; update-object-radioactivity
;;;
;;; A method that determines whether an object is radioactive.  Note that there
;;; is no need for an :UNKNOWN case here.

(def-method ({class sci-object} update-object-radioactivity) (desc)
  (when (eq :unknown (radioactive-p $self))
    (setf (radioactive-p $self)
	  ;; The attribute value of the ((nil :xray) ... ...) attribute...
	  (caddr (find-if #'(lambda (element)
			      (equal '(nil :xray) (car element)))
			  desc)))
    ))


;;; update-object-fluorescent-color
;;;
;;; A method that determines the color of an object when it fluoresces.

(def-method ({class sci-object} update-object-fluorescent-color) (desc)
  (when (eq :unknown (fluorescent-color $self))
    (setf (fluorescent-color $self)
	  ;; The attribute value of the ((:uv :vis) :color ...) attribute...
	  (or (caddr (find-if #'(lambda (element)
				  (and (equal '(:uv :vis) (car element))
				       (eq    :color      (cadr element))
				       ))
			      desc))
	      :unknown))
    ))


;;; update-object-warmth
;;;
;;; A method that determines whether and object is warm.  Note that there is no
;;; need for an :UNKNOWN case here.

(def-method ({class sci-object} update-object-warmth) (desc)
  (when (eq :unknown (warm-p $self))
    (setf (warm-p $self)
	  ;; The attribute value of the ((nil :ir) ... ...) attribute...
	  (caddr (find-if #'(lambda (element)
			      (equal '(nil :ir) (car element)))
			  desc)))
    ))


;;; update-object-glow-color
;;;
;;; A method that determines the color of an object when it glows.

(def-method ({class sci-object} update-object-glow-color) (desc)
  (when (eq :unknown (glow-color $self))
    (setf (glow-color $self)
	  ;; The attribute value of the ((:ir :vis) :color ...) attribute...
	  (or (caddr (find-if #'(lambda (element)
				  (and (equal '(:ir :vis) (car element))
				       (eq    :color      (cadr element))
				       ))
			      desc))
	      :unknown))
    ))


;;; get-vis-attribute
;;;
;;; A method that gets the visible attribute from an object description.

(defun get-vis-attribute (attr desc)
  (cond ((null desc) nil)
	((let ((this-attribute (car desc)))
	   (when (and (eq :vis (car  this-attribute))
		      (eq attr (cadr this-attribute)))
	     (caddr this-attribute))
	   ))
	(t
	 (get-vis-attribute attr (cdr desc)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                         ;;;
;;;            U S E F U L   F U N C T I O N S                              ;;;
;;;                                                                         ;;;
;;; These functions are designed to make the SCI students lives a little    ;;;
;;; easier.                                                                 ;;;
;;;                                                                         ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; add-action-to-front
;;;
;;; A method that adds an action to the front of the next actions list

(def-method ({class sci-rover} add-action-to-front) (action)
  (setf (next-actions $self) (cons action (next-actions $self))))


;;; add-actions-to-front
;;;
;;; A method that adds a list of actions to the front of the next actions list

(def-method ({class sci-rover} add-actions-to-front) (actions)
  (setf (next-actions $self) (append actions (next-actions $self))))


;;; add-action-to-end
;;;
;;; A method that adds an action to the end of the next actions list

(def-method ({class sci-rover} add-action-to-end) (action)
  (setf (next-actions $self) (nconc (next-actions $self) (list action))))


;;; add-actions-to-end
;;;
;;; A method that adds a list of actions to the end of the next actions list

(def-method ({class sci-rover} add-actions-to-end) (actions)
  (setf (next-actions $self) (append (next-actions $self) actions)))


;;; best-direction
;;;
;;; A function that returns the direction to travel given the interfaces
;;; and the number of visits that direction.

(def-method ({class sci-rover} best-direction) ()
  (let (best-dir num-visits)
    (dolist (dir (favored-directions $self) best-dir)
      (cond ((and (not best-dir)
		  (member (ask $self (get-slot-dir dir))
			  (safe-interfaces $self)))
	     (setf best-dir dir)
	     (setf num-visits 
		   (ask $self (get-visits-slot (get-slot-dir dir)))))
	    ((and (member (ask $self (get-slot-dir dir))
			  (safe-interfaces $self))
		  (< (ask $self (get-visits-slot (get-slot-dir dir)))
		     num-visits))
	     (setf best-dir dir)
	     (setf num-visits 
		   (ask $self (get-visits-slot (get-slot-dir dir)))))))))


;;; best-random-direction
;;;
;;; A method that returns a random direction to travel given the interfaces
;;; and the number of times visited in each direction.  The direction
;;; is always a safe direction unless there are no safe directions.  In that
;;; case nil is returned.  If there is more than one direction that has
;;; the least number of visits, it returns a random pick from among the
;;; choices.

(def-method ({class sci-rover} best-random-direction) ()
  (let (best-dirs num-visits)
    (dolist (dir *directions* (and best-dirs
				   (nth (random (length best-dirs)) best-dirs)
				   ))
      (cond ((and (not best-dirs)
		  (member (ask $self (get-slot-dir dir))
			  (safe-interfaces $self)))
	     (setf best-dirs (list dir))
	     (setf num-visits 
		   (ask $self (get-visits-slot (get-slot-dir dir)))))
	    ((and (member (ask $self (get-slot-dir dir))
			  (safe-interfaces $self))
		  (= (ask $self (get-visits-slot (get-slot-dir dir)))
		     num-visits))
	     (push dir best-dirs))
	    ((and (member (ask $self (get-slot-dir dir))
			  (safe-interfaces $self))
		  (< (ask $self (get-visits-slot (get-slot-dir dir)))
		     num-visits))
	     (setf best-dirs (list dir))
	     (setf num-visits 
		   (ask $self (get-visits-slot (get-slot-dir dir)))))))))


;;; opposite-direction
;;;
;;; A function that gives a function interface to a macro

(defun opposite-direction (dir)
  (reverse-dir dir))

;; End of file.