;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: Eyehand -*-

;;; Microworld implementation

;;; [This file was inspired by Ramstad's implementation of Drescher's
;;; system, but Ramstad's version has by now been 80% or more rewritten.]

;;; This file implements a simple software simulation of a world
;;; it contains variables, definitions and functions for:
;;; Objects in the world and their characteristics.
;;; 140+ functions which can be called to get the status of each
;;;   primitive item.
;;; 17 functions which correspond to the primitive actions.
;;; CLOCK-TICK (a function which randomizes object position, 
;;;   opens the hand after 3 time units of being closed, 
;;;   and increments the clock).
;;; Keeping the state of the world, initializing it, and loading/saving
;;;   the random number generator seed.
;;; [Actually, many of these have been eliminated or moved out of this file.  -- Foner]

;;; Note:  the state of the microworld is kept internally.  Nothing
;;; other than t/nil/status messages are returned by any function.

(in-package :eyehand)

(proclaim '(fixnum *hp-x*   *hp-y*
                   *vp-x*   *vp-y*
                   *clock*  *grip-expiration*))

(proclaim '(atom   *hcl*    *hgr*))
                   
;;; Build the macros we'll need.
(def-microworld EYEHAND)

;;; Note on coordinate systems:
;;; There are three coordinate systems which are used within this
;;; file: microspace, body and glance relative coordinates.
;;; In each case, the X axis (first position in the coordinate pair)
;;; runs left to right while the Y axis (second position) runs bottom
;;; to top, i.e. traditional mathematical notation.

;;; Microspace relative coordinates reference the 7x7 world array
;;; directly where the lower left hand corner is position (0,0) and
;;; the lower right hand corner is position (6,0).

;;; Body relative coordinates are often used when referring to the
;;; center 3x3 area in the microworld.
;;; The lower left corner of this area is microspace coordinate (2,2)
;;; which is defined as body relative coordinate (0,0).

;;; Glance relative coordinates are used when referring to the 5x5
;;; area centered around the current glance orientation.
;;; The current glance orientation is stored as microspace relative
;;; coordinates in *VP-X* and *VP-Y*.
;;; The center of the 5x5 glance relative area is defined as glance
;;; relative coordinate (2,2) with the lower left corner of this area
;;; defined as glance relative coordinate (0,0).

;;; The world is modeled as a 7x7 "microspace" which is 
;;; represented as a 2D array, with indices 0 through 6.

;;; NOTE!  If you change this value, you MUST also change the PROCLAIM
;;; below.  Since *WORLD-DIAMETER* isn't defined until load-time, but
;;; the optimization must be known at compile-time, this is somewhat
;;; problematic unless I arranged to have *WORLD-DIAMETER* in some
;;; previous file just for the PROCLAIM's benefit.
(deflimit *WORLD-DIAMETER* 7 7)

(defvar *WORLD*
  (make-array (list *world-diameter* *world-diameter*)
	      :initial-element nil))

;;; &&& VARIABLE-PROCLAIMATION PROBLEM.  Temporarily commented out.  --- Well, not really, but must fix this case!
;;; The values here must stay in sync with the DEFLIMIT *WORLD-DIAMETER* above!
(proclaim '(type (simple-array t (7 7))
		 *world*))

;;; Brief accessor for readability.
(defmacro GET-OBJECT (x y)
  `(aref *world* ,x ,y))

;;;; World-object datatype.

;;; World objects have three sets of characteristics:
;;; visual, tactile and taste, each of which is represented as
;;; an array of t or nil elements.
;;; In addition, objects can be marked either movable or not.
;;; Currently, only the body and hand are considered to be immovable
;;; objects.
;;; Movable objects can be moved by the hand, and if not currently
;;; grasped will be randomly moved occasionally by the CLOCK-TICK
;;; function in a direction indicated by the current cycle value.
;;; 0 indicates the next move is to the right, 1 down, 2 left, 3 up.
;;; i.e. the objects move in a clockwise direction over time.

(defstruct WORLD-OBJECT
  (visual
   (make-array 16 :initial-element nil)
   :type (simple-array atom (16)))
  (tactile
   (make-array 4 :initial-element nil)
   :type (simple-array atom (4)))
  (taste
   (make-array 4 :initial-element nil)
   :type (simple-array atom (4)))
  (movable t :type atom)
  (cycle 0 :type fixnum))

;;; Brief accessors for readability.

(defmacro GET-VISUAL (object index)
  (declare (fixnum index))
  `(the atom (svref (world-object-visual ,object) ,index)))

(defmacro GET-TACTILE (object index)
  (declare (fixnum index))
  `(the atom (svref (world-object-tactile ,object) ,index)))

(defmacro GET-TASTE (object index)
  (declare (fixnum index))
  `(the atom (svref (world-object-taste ,object) ,index)))

(defmacro GET-MOVABLE (object)
  `(the atom (world-object-movable ,object)))

;;; This definition seems to give SETF the willies, at least in HCL.
; (defmacro GET-CYCLE (object)
;   `(the fixnum (world-object-cycle ,object)))

(defmacro GET-CYCLE (object)
  `(world-object-cycle ,object))

;;;; Defining the body and hand objects.

(defvar *BODY*
  (make-world-object
   :visual   (make-array 16
                         :initial-contents
                         '(t   t   t   t
                           t   nil nil t
                           t   nil nil t
                           t   t   t   t))
   :tactile  (make-array 4
                         :initial-contents
                         '(t   t   nil nil))
   :taste    (make-array 4
                         :initial-contents
                         '(t   nil nil nil))
   :movable nil))

(defvar *HAND*
  (make-world-object
   :visual   (make-array 16
                         :initial-contents
                         '(t   t   t   t
                           t   t   t   t
                           nil nil t   t
                           t   t   t   t))
   :tactile  (make-array 4
                         :initial-contents
                         '(t   nil t   nil))
   :taste    (make-array 4
                         :initial-contents
                         '(t   t   t   nil))
   :movable nil))

;;;; Defining the left and right hand objects.

(defvar *OBJECT-1*
  (make-world-object
   :visual   (make-array 16
                         :initial-contents
                         '(nil t   t   nil
                           t   nil nil t
                           t   nil nil t
                           nil t   t   nil))
   :tactile  (make-array 4
                         :initial-contents
                         '(nil nil t   t))
   :taste    (make-array 4
                         :initial-contents
                         '(nil t   t   nil))
   :movable t  :cycle 0))

(defvar *OBJECT-2*
  (make-world-object
   :visual   (make-array 16
                         :initial-contents
                         '(t   t   nil nil
                           nil t   t   nil
                           nil nil t   t
                           nil nil nil t))
   :tactile  (make-array 4
                         :initial-contents
                         '(nil t   nil nil))
   :taste    (make-array 4
                         :initial-contents
                         '(nil t   nil t  ))
   :movable t  :cycle 1))

(defun COMPARE-DETAILS (&key (objects (list *body* *hand* *object-1* *object-2*))
			(accessor #'world-object-visual))
  (mapcar #'(lambda (object)
	      (listarray
		(funcall accessor object)))
	  objects))

(defun SHOW-COMPARE-DETAILS (&key (objects (list *body* *hand* *object-1* *object-2*))
			     (accessor #'world-object-visual))
  (let ((details (compare-details :objects objects :accessor accessor)))
    (loop for detail in details
	  do (format t "~&~S~&"
		     (mapcar #'(lambda (value)
				 (if value 1 0))
			     detail))))
  (values))

;;; Note on the body relative coordinate system:
;;; body relative coordinates are often used when referring to the
;;; center 3x3 area in the microworld.
;;; The lower left corner of this area is defined as body relative
;;; coordinate (0,0) which corresponds to microspace coordinate (2,2).

;;; The position of the body in body relative coordinates is (1,-1)
;;; which corresponds to microspace coordinate (3,1).

(defconstant *BODY-X* 1)
(defconstant *BODY-Y* -1)

;;; *CLOCK* is incremented with each call to the function CLOCK-TICK.
;;; *GRIP-EXPIRATION* is used by the CLOCK-TICK function to ensure
;;; that the hand is not closed for more than 3 consecutive time units.

(defvar *CLOCK* 0)
(defvar *GRIP-EXPIRATION* -1)

;;;;  *** start of primitive item definitions ***
;;;  The primitive items are implemented as functions which return
;;;  values which indicate the current state of a particular item.
;;;  The value T indicates the item is currently on.
;;;  The value NIL indicates the item is currently off.
;;;  Collectively, they indicate those states of the microworld
;;;  which the simulated robot is currently able to sense.

;;; I'd like to make the four macros below usable across packages without just
;;; copying their code, a la what I did with DEF-DEFITEM, but, unlike the four
;;; macros defined by DEF-DEFITEM, each macro requires the one before it
;;; to expand correctly, and this means I can't just make a form that expands into a
;;; bunch of DEFMACRO forms, since those would be expanded in parallel.  I could
;;; probably find a way around this, but it seems like too much work right now.

;;; Note that the ERROR-CHECKING-FORM used by DEF-ITEMS-INTERNAL via
;;; DEF-ITEM-GENERATOR (and hence available in generators defined by DEF-ITEMS-1D
;;; and DEF-ITEMS-2D) is presumably some ASSERT form which will fail if, for
;;; example, a limit is set wrong.  We evaluate it _after_ doing the internal DEFLIMIT
;;; (since otherwise we really don't have an appropriate scope for the form to use
;;; in checking anything---the limit variable isn't set yet, and CURRENT-LIMIT isn't
;;; bound here), which means that, if the assertion blows out, the limit has
;;; _already_ been changed (possibly propagating changes to other limits, too).  This
;;; shouldn't be a problem if limit initialization forms don't have side-effects (which
;;; it is documented that they shouldn't), and if you eventually fix whatever problem
;;; caused the assertion to blow out and reevaluate the DEF-ITEMS-2D (or whatever)
;;; form (which you presumably will, since it blew out in the middle of compiling it).
;;;
;;; Note that we _also_ pass the ERROR-CHECKING-FORM to DEFLIMIT itself to check.
;;; So if that inner check blows out, we won't wind up making any other
;;; side-effects.  (Although it's certainly possible to write some assertion that
;;; doesn't check the inner use of DEFLIMIT at all, but still blows out in the outer
;;; check, after other things have been done---though I expect this to be rather
;;; unlikely.  But just in case, we also check in DEF-ITEMS-INTERNAL as well as giving
;;; the form to DEFLIMIT.)

;;; Used by DEF-ITEM-GENERATOR below.
(defmacro-definer DEF-ITEMS-INTERNAL (limit-name current-limit historical-limit base-name error-checking-form &body builder-body)
  `(progn
     (deflimit ,limit-name ,current-limit ,historical-limit ,error-checking-form)
     (def-simple-item-naming-function ,base-name)
     ,(when error-checking-form
	error-checking-form)
     ,@builder-body))

;;; Builds a macro named GENERATOR-NAME whose arglist is as shown by the line with
;;; the "***" comment below.  The body therefore gets those particularly-named
;;; args to work with.
(defmacro-definer DEF-ITEM-GENERATOR (generator-name &body generator-body)
  `(defmacro ,generator-name (limit-name current-limit historical-limit base-name item-fn &optional error-checking-form); *** Generator's arglist.
     (let* ((namer 
	      (intern-format "simple-item-naming-function-~A" base-name))	; Hmm.  I don't like have to mention it explicitly like this...
	    (forms 
	      ,@generator-body))
       `(progn
	  (def-items-internal ,limit-name ,current-limit ,historical-limit ,base-name ,error-checking-form
	    ,@forms)))))

;;; Note that it's actually possible to recompile a DEF-ITEMS-1D or DEF-ITEMS-2D
;;; form without destroying the state of the world, subject to a few conditions:
;;;  The new number of items generated by the form is not less than the old number.
;;;   (This is because nothing will remove the no-longer-generated items from the list
;;;   in *PRIMITIVE-ITEMS*, so they'll continue to exist in *ITEM-ARRAY* and get called
;;;   by the schema mechanism.)
;;;  You make sure that the next run you do starts a new run (rather than continuing
;;;   an old one), so MAKE-ALL-ITEMS runs, which will properly update various datastructures,
;;;   such as *NUMBER-OF-PRIMITIVE-ITEMS*.

;;; To solve the problem in the first limitation above, I suppose that I could make a
;;; form that zaps all the items with names "similar to" those generated by the
;;; simple-item-naming-function, to be used before recompiling one of these forms
;;; in a way that would try to decrease the number of items generated, for use in
;;; patch files.  I don't feel comfortable having _every_ use of one of these
;;; generators calling it, though (hence I shouldn't make it part of the
;;; macroexpansion of the generator).
;;;
;;; To solve the problem in the second limitation above, I suppose I could make any
;;; use of these forms set a global variable that warns and/or forces a new run
;;; (unless I happen to be clever & careful enough to know that what I've done is no
;;; cause for a new run, and reset it).  This might be justified.

(def-item-generator DEF-ITEMS-1D
  (loop for index from 0 below current-limit
	collect `(defitem-built ,item-fn ,namer ,index)))

(def-item-generator DEF-ITEMS-2D 
  (loop for x from 0 below current-limit
	append (loop for y from 0 below current-limit
		     collect `(defitem-built ,item-fn ,namer ,x ,y))))

;;;; Haptic-proprioceptive items hp00-hp22
;;; The variables *HP-X* and *HP-Y* store the current body relative
;;; hand position - each ranges from 0-2.

(defvar *HP-X* 1)
(defvar *HP-Y* 0)

;;; HP-CHECK returns T if X and Y give the current hand position.

(defmacro HP-CHECK (x y)
  (declare (fixnum x y))
  `(and
    (fix= *hp-x* ,x)
    (fix= *hp-y* ,y)))

;;; Definition of the HP item functions via the HP-CHECK macro.

(def-items-2d *HP-DIAMETER* 3 3 hp hp-check)

;;;; Visual-proprioceptive items vp00-vp22.
;;; The variables *VP-X* and *VP-Y* store the current glance
;;; orientation - each ranges from 0-2.
;;; They are microspace relative coordinates which designate the
;;; center of the 5x5 visual field.

(defvar *VP-X* 1)
(defvar *VP-Y* 1)

;;; VP-CHECK returns T if X and Y give the current glance orientation.

(defmacro VP-CHECK (x y)
  (declare (fixnum x y))
  `(and
    (fix= *vp-x* ,x)
    (fix= *vp-y* ,y)))

;;; Definition of the VP item functions via the VP-CHECK macro.

(def-items-2d *VP-DIAMETER* 3 3 vp vp-check)

;;; Note on the glance relative coordinate system:
;;; glance relative coordinates are used when referring to the 5x5
;;; area centered around the current glance orientation.
;;; The center of this area is defined as glance relative coordinate
;;; (2,2) with the lower left corner of this area defined as glance
;;; relative coordinate (0,0).
;;; The current glance orientation is stored as microspace relative
;;; coordinates in *VP-X* and *VP-Y*.

;;;; Coarse visual-field items vf00-vf44.

;;; VF-CHECK returns T if an object is at the given
;;; glance relative position - if empty, returns NIL.

(defmacro VF-CHECK (x y)
  (declare (fixnum x y))
  `(if (get-object (fix+ *vp-x* ,x) (fix+ *vp-y* ,y))
       t nil))

;;; Definition of the vf item functions via the VF-CHECK macro.

(def-items-2d *VF-DIAMETER* 5 5 vf vf-check
	      (assert (oddp *vf-diameter*)))	; Otherwise, we don't know where to center the fovea!

;;;; Visual detail items:
;;;; fovf00-33, fovb00-33, fovl00-33, fovr00-33, fovx00-33.

;;; Each FOV-CHECK returns one of the visual details
;;; associated with the object found at the given foveal
;;; area - each detail is either T or NIL.
;;; Note that the foveal areas are determined by the current
;;; microspace relative glance orientation.

;;; Note that the 2D items are kept internally in a 1D array so it is
;;; necessary to translate between the two representations when
;;; referencing the get-visual macro.
;;; Further note that this translation happens at compile time, not
;;; run time, so it doesn't slow down the execution of the code.

(defmacro FOVF-CHECK (x y)
  (declare (fixnum x y))
  `(let ((foo (get-object (fix+ 2 *vp-x*) (fix+ 3 *vp-y*))))
     (and foo (get-visual foo ,(+ (* x 4) y)))))

(defmacro FOVB-CHECK (x y)
  (declare (fixnum x y))
  `(let ((foo (get-object (fix+ 2 *vp-x*) (fix1+ *vp-y*))))
     (and foo (get-visual foo ,(+ (* x 4) y)))))

(defmacro FOVL-CHECK (x y)
  (declare (fixnum x y))
  `(let ((foo (get-object (fix1+ *vp-x*) (fix+ 2 *vp-y*))))
     (and foo (get-visual foo ,(+ (* x 4) y)))))

(defmacro FOVR-CHECK (x y)
  (declare (fixnum x y))
  `(let ((foo (get-object (fix+ 3 *vp-x*) (fix+ 2 *vp-y*))))
     (and foo (get-visual foo ,(+ (* x 4) y)))))

(defmacro FOVX-CHECK (x y)
  (declare (fixnum x y))
  `(let ((foo (get-object (fix+ 2 *vp-x*) (fix+ 2 *vp-y*))))
     (and foo (get-visual foo ,(+ (* x 4) y)))))

(def-items-2d *FOVF-DIAMETER* 4 4 fovf fovf-check)
(def-items-2d *FOVB-DIAMETER* 4 4 fovb fovb-check)
(def-items-2d *FOVL-DIAMETER* 4 4 fovl fovl-check)
(def-items-2d *FOVR-DIAMETER* 4 4 fovr fovr-check)
(def-items-2d *FOVX-DIAMETER* 4 4 fovx fovx-check)

;;;; Coarse tactile items for each side of the hand:
;;;; tactf, tactb, tactr, tactl.

;;; Return T if an object is present, NIL if not.
;;; T or NIL is returned explicitly so the user cannot 'accidentally'
;;; get an object structure.

;;; Note that the object positions checked are the microspace
;;; coordinates indicated by the current body relative position of the
;;; hand.

(defitem TACTF
  (if (get-object (fix+ 2 *hp-x*) (fix+ 3 *hp-y*))
      t nil))

(defitem TACTB
  (if (get-object (fix+ 2 *hp-x*) (fix1+ *hp-y*))
      t nil))

(defitem TACTR
  (if (get-object (fix+ 3 *hp-x*) (fix+ 2 *hp-y*))
      t nil))

(defitem TACTL
  (if (get-object (fix1+ *hp-x*) (fix+ 2 *hp-y*))
      t nil))

;;;; Coarse tactile items for each side of the body;
;;;; bodyf, bodyb, bodyr, bodyl.

;;; Again, return T if an object is present, NIL if not.
;;; T or NIL is returned explicitly so the user cannot 'accidentally'
;;; get an object structure.

;;; Note that the object positions checked are the microspace
;;; coordinates indicated by the current body relative position of the
;;; body.

(defitem BODYF
  (if (get-object (fix+ 2 *body-x*) (fix+ 3 *body-y*))
      t nil))

(defitem BODYB
  (if (get-object (fix+ 2 *body-x*) (fix1+ *body-y*))
      t nil))

(defitem BODYR
  (if (get-object (fix+ 3 *body-x*) (fix+ 2 *body-y*))
      t nil))

(defitem BODYL
  (if (get-object (fix1+ *body-x*) (fix+ 2 *body-y*))
      t nil))

;;;; Detailed tactile items for objects touching the left edge (i.e.
;;;; "fingers") of the hand:  text0-3.

;;; Each detail is T or NIL.

;;; Note that the position checked is the microspace coordinate
;;; indicated as the position to the left of the current body relative
;;; position of the hand.

(defmacro TEXT-CHECK (x)
  (declare (fixnum x))
  `(let ((foo (get-object (fix1+ *hp-x*) (fix+ 2 *hp-y*))))
     (when foo
       (get-tactile foo ,x))))

(def-items-1d *TEXT-DIAMETER* 4 4 text text-check)

;;;; Detailed taste items for objects touching the front (i.e. "mouth")
;;;; of the body:  taste0-3.

;;; Each detail is T or NIL.

;;; Note that the position checked is the microspace coordinate
;;; indicated as the position to the front of the current body relative
;;; position of the body.

(defmacro TASTE-CHECK (x)
  (declare (fixnum x))
  `(let ((foo (get-object (fix+ 2  *body-x*) (fix+ 3 *body-y*))))
     (when foo
       (get-taste foo ,x))))

(def-items-1d *TASTE-DIAMETER* 4 4 taste taste-check)

;;;; Hand closed item:  hcl.

(defvar *HCL* nil)

(defitem HCL
  *hcl*)

;;;; Hand closed and grasping something item:  hgr.

(defvar *HGR* nil)

(defitem HGR
  *hgr*)

;;;;  *** start of primitive action definitions ***
;;;  The primitive actions are implemented as functions which may or
;;;  may not change the microworld state.
;;;  These functions do not return meaningful values.

;;;; Hand motion functions:  handf, handb, handr, handl.

;;; Each function first checks the new position for conflicts
;;; (out of the 3x3 range, object already occupying new position)
;;; and if none, moves the hand by first moving any grasped object,
;;; and then moving the hand.
;;; Note that the destination square for both the hand and any grasped
;;; object must be empty for the hand movement to take place
;;; (however, when the hand is closed and grasping an object and moves
;;; left, the hand will occupy the former position of the grasped
;;; object so only the position left of the object needs to be empty,
;;; and similarly for moving right with a grasped object, the object
;;; will occupy the former position of the hand so only the position
;;; to the right of the hand needs to be empty).

;;; Stolen from SCHEMA::FAKE-NEW-LOCATION.  I probably shouldn't have two copies
;;; of the code, but the SCHEMA version is a hack anyway.
;;;
;;; Computes where the new location will be.
(defun DIRECTION->NEW-LOCATION (direction x y)
  #+Genera (declare (values new-x new-y))
  (ecase direction
    (:up    (values x      (1+ y)))
    (:down  (values x      (1- y)))
    (:left  (values (1- x) y))
    (:right (values (1+ x) y))))

;;; %%% Where to go from here:  (This comment written 6 Nov, but it's about
;;; code I wrote in early Oct...)  use DIRECTION->NEW-LOCATION to compute where
;;; things are for HANDx stuff.  Test using the world-state-shower I wrote, whatever
;;; its name is.  Make sure objects move correctly as well as the hand.
;;;
;;; Then, emit opcodes for hand & object motion.  Do same for eye.  Do same for
;;; grasp/ungrasp.  Make a meter to hold all this stuff.  Probably should put all
;;; events that happen in one action in same cluster (e.g., hand motion and object
;;; motion), since I can always flatten it out later, and this way the meter's entries
;;; map one-to-one with clock ticks.
;;;
;;; Note also that we define a meter below (*INANIMATE-OBJECT-MOTIONS*) and
;;; use it in CLOCK-TICK-MAYBE-MOVE-OBJECTS for the circular object motions.
;;; Should flush that meter and just add such motions to the meter we define
;;; for dealing with this stuff here.

;;; Need to compute new coords and store them in the meter!
(defaction HANDF
  (unless (or (fix> *hp-y* 1)
	      (get-object (fix+ 2 *hp-x*) (fix+ 3 *hp-y*))
	      (and *hgr* (get-object (fix1+ *hp-x*) (fix+ 3 *hp-y*))))
    (when *hgr*
      (setf (get-object (fix1+ *hp-x*)  (fix+ 3 *hp-y*)) (get-object (fix1+ *hp-x*)  (fix+ 2 *hp-y*))
	    (get-object (fix1+ *hp-x*)  (fix+ 2 *hp-y*)) nil))
    (setf   (get-object (fix+ 2 *hp-x*) (fix+ 3 *hp-y*)) (get-object (fix+ 2 *hp-x*) (fix+ 2 *hp-y*))
	    (get-object (fix+ 2 *hp-x*) (fix+ 2 *hp-y*)) nil
  	    *hp-y* (fix1+ *hp-y*))))

(defaction HANDB
  (unless (or (fix< *hp-y* 1)
	      (get-object (fix+ 2 *hp-x*) (fix1+ *hp-y*))
	      (and *hgr* (get-object (fix1+ *hp-x*) (fix1+ *hp-y*))))
    (when *hgr*
      (setf (get-object (fix1+ *hp-x*)  (fix1+ *hp-y*))  (get-object (fix1+ *hp-x*)  (fix+ 2 *hp-y*))
	    (get-object (fix1+ *hp-x*)  (fix+ 2 *hp-y*)) nil))
    (setf   (get-object (fix+ 2 *hp-x*) (fix+ 1 *hp-y*)) (get-object (fix+ 2 *hp-x*) (fix+ 2 *hp-y*))
	    (get-object (fix+ 2 *hp-x*) (fix+ 2 *hp-y*)) nil
	    *hp-y* (fix1- *hp-y*))))

(defaction HANDR
  (unless (or (fix> *hp-x* 1)
	      (get-object (fix+ 3 *hp-x*) (fix+ 2 *hp-y*)))
    (setf (get-object (fix+ 3 *hp-x*) (fix+ 2 *hp-y*))
	  (get-object (fix+ 2 *hp-x*) (fix+ 2 *hp-y*)))
    (cond (*hgr*
	   (setf (get-object (fix+ 2 *hp-x*) (fix+ 2 *hp-y*)) (get-object (fix1+ *hp-x*) (fix+ 2 *hp-y*))
		 (get-object (fix1+ *hp-x*)  (fix+ 2 *hp-y*)) nil))
	  (t
	   (setf (get-object (fix+ 2 *hp-x*) (fix+ 2 *hp-y*)) nil)))
    (setf *hp-x* (fix1+ *hp-x*))))

(defaction HANDL
  (unless (or (fix< *hp-x* 1)
	      (and *hgr* (get-object *hp-x* (fix+ 2 *hp-y*)))
	      (and (not *hgr*)
		   (get-object (fix1+ *hp-x*) (fix+ 2 *hp-y*))))
    (when *hgr*
      (setf (get-object *hp-x*          (fix+ 2 *hp-y*)) (get-object (fix1+ *hp-x*)  (fix+ 2 *hp-y*))))
    (setf   (get-object (fix+ 1 *hp-x*) (fix+ 2 *hp-y*)) (get-object (fix+ 2 *hp-x*) (fix+ 2 *hp-y*))
	    (get-object (fix+ 2 *hp-x*) (fix+ 2 *hp-y*)) nil
	    *hp-x* (fix1- *hp-x*))))

;;;; Glance orientation functions:  eyef, eyeb, eyer, eyel.

;;; Each function merely checks to make sure that the glance
;;; orientation variable will still be in the range 0-2 inclusive
;;; after modification, and then performs the modification.

;;; This is the "clearance" between the diameter of the course visual retina and the
;;; diameter of the microworld itself (the former is nested inside the latter like a
;;; planetary gear).  Thus, we cannot move the retina more than this clearance from
;;; the 0,0 point without having it hang off an edge.
(deflimit *WORLD-VF-CLEARANCE* (- *world-diameter* *vf-diameter*) 2
	  ;; VF must be no larger than the world.  (If it's the same size, we can't
	  ;; shift our gaze at all---'cause there's no where else to look---but
	  ;; that's okay, if pathological.  But having it larger means we're looking
	  ;; past the edges of the universe!)
	  (assert (not (minusp *world-vf-clearance*))))
  
(defaction EYEF
  (when (fix< *vp-y* *world-vf-clearance*)
    (setf *vp-y* (fix1+ *vp-y*))))

(defaction EYEB
  (when (fix> *vp-y* 0)
    (setf *vp-y* (fix1- *vp-y*))))

(defaction EYER
  (when (fix< *vp-x* *world-vf-clearance*)
    (setf *vp-x* (fix1+ *vp-x*))))

(defaction EYEL
  (when (fix> *vp-x* 0)
    (setf *vp-x* (fix1- *vp-x*))))

;;;; Hand closing and opening functions:  grasp, ungrasp.

;;; This function closes the hand, grasping any movable object
;;; touching the left edge of the hand (unless hand was already closed).
;;; The hand stays closed until 3 time units pass or until explicitly
;;; opened.

(defaction GRASP
  (unless *hcl*
    (let ((object (get-object (fix1+ *hp-x*) (fix+ 2 *hp-y*))))
      (when (and object
		 (get-movable object))
	(setf *hgr* t)))
    (setf *hcl* t
	  *grip-expiration* (fix+ 3 *clock*))))

;;; This function opens the hand.
(defaction UNGRASP
  (setf *hcl* nil
        *hgr* nil
        *grip-expiration* -1))

;;;; Time-keeping function CLOCK-TICK

;;; Each time unit should correspond to one primitive action taken.
;;; This function should be called after each primitive action and
;;; before the schema mechanism takes the statistics for this time
;;; step - it returns the new value of *CLOCK*.
;;; The grip expires and the hand automatically opens after 3 time
;;; units from when it was first closed
;;; (i.e. if grasp is the action selected at time x, the hand will
;;; remain closed for time x+1, time x+2 and time x+3, unless
;;; explicitly opened during one of these time steps.  If it is not
;;; explicitly opened, after the action is executed for time x+3, the
;;; following call to clock-tick will open the hand and set the time
;;; equal to x+4).
;;; On average, every 200 calls to this function randomly moves all of
;;; the non-grasped movable objects in the world (unless moving a
;;; particular object would result in a collision with another object).
;;; (1:200 -> 1,000:200,000 for additional randomness.)
;;; The direction moved is indicated by the current cycle value for
;;; the object in question.
;;; 0 indicates the next move is to the right, 1 down, 2 left, 3 up.
;;; I.e., the objects move in a clockwise direction over time.

;;; The stuff on this page was totally rewritten on 28 Sep 93 to break out the logic
;;; for object motions and record it for later playback in an animation.

(schema::def-vector-metering-counter *inanimate-object-motions*)

;;; Unbelievably enough, an individual object has no idea what it is!  So we'll look it
;;; up, erring if it's nothing we know.  *sigh*  I could fix this, but then dumped
;;; worlds couldn't be reloaded, probably.  We can't use EQ to check, either, because
;;; the act of restoring a snapshot creates a _copy_ of the object which is no longer
;;; EQ to the original.  So taste them instead.  (This depends on them tasting different,
;;; of course, but happens to be true here.  A new cut at this, or any other microworld,
;;; would explicitly represent object identities, not for use by items [that'd be cheating],
;;; but for use by monitoring, metering, and debugging code, which is what we have here.
(defun IDENTIFY-OBJECT (object)
  (let ((taste (world-object-taste object)))
    (loop for object in (list *object-1* *object-2* *hand* *body*)	; This conses four words per test.  So sue me.
	  for name in '(:object-1 :object-2 :hand :body)
	  when (equalp taste (world-object-taste object))
	    do (return name))))

;;; A paranoid version that'll blow out if not handed one of *OBJECT-1* or *OBJECT-2*.
(defun IDENTIFY-INANIMATE-OBJECT-ONLY (object)
  (let ((id (identify-object object)))
    (unless (member id '(:object-1 :object-2))
      (error "~S is identified as ~S, but it must be one of :OBJECT-1 or :OBJECT-2."
	      object id))
    id))

;;; &&& Yuck!  This apparently just scans the entire world looking for objects.
;;; &&& Surely, as I scale up the world, this should be replaced by something
;;; &&& that tracks the objects directly, since otherwise it gets O(n^2) slower.
(defun CLOCK-TICK-MAYBE-MOVE-OBJECTS ()
  (flet ((do-move (object old-x old-y new-x new-y)
	   (setf (get-object new-x new-y) object)
	   (setf (get-object old-x old-y) nil)
	   (setf (get-cycle object) (mod (1+ (get-cycle object)) 4))
	   (push (list (identify-inanimate-object-only object) *clock* new-x new-y)
		 *inanimate-object-motions*))
	 (compute-move (cycle x y)
	   #+Genera (declare (values new-x new-y move-legal?))
	   (ecase cycle
	     (0 (values (fix1+ x) y         (< x *world-diameter*)))
	     (1 (values x         (fix1- y) (> y 0)))
	     (2 (values (fix1- x) y         (> x 0)))
	     (3 (values x         (fix1+ y) (< y *world-diameter*))))))
    (dotimes (x *world-diameter*)
      (declare (fixnum x))
      (dotimes (y *world-diameter*)
	(declare (fixnum y))
	(let ((object (get-object x y)))
	  (when (and object
		     ;; &&& I'd like to fix this to call random AFTER we check whether we can move the object,
		     ;; but I can't do that until I re-evolve where all the objects are in a run for the demo animation.
		     ;; (This would run a whole lot faster if we didn't call random every loop, but only when necessary.)
		     ;; It would also mean that all simulations after that point would pick different actions, depending on
		     ;; how the world ran that time, hence things might diverge on the action front anyway.  (And it's
		     ;; for sure that runs before & after this change would pick different actions, since we wouldn't be
		     ;; calling RANDOM 4 times (here---see COUNT-OBJECTS-IN-WORLD) in between each call to it to pick
		     ;; an action.  *sigh*
		     (fix< (random 200000) 1000)
		     (not (and (fix= x (fix1+  *hp-x*))
			       (fix= y (fix+ 2 *hp-y*))
			       *hgr*))
		     (get-movable object))
	    (multiple-value-bind (new-x new-y legal?)
		(compute-move (get-cycle object) x y)
	      (when (and legal?			; Won't move it past the end of the world.
			 (not (get-object new-x new-y)))	; Won't land on some other object.
		(do-move object x y new-x new-y)))))))))

(defun CLOCK-TICK ()
  (clock-tick-maybe-move-objects)
  (when (and *hcl*
	     (fix= *clock* *grip-expiration*))
    (ungrasp))
  (setf *clock* (fix1+ *clock*)))

;;; +++ Debugging function only from here to the end of the page.

;;; OBJECT-1 should be the left object (from inspection of the ancient code's init-world stuff).

;;; Restores ONLY the microworld state, not the schema state.
;;; [This would be better written as SCHEMA::(...), but Harlequin apparently
;;; chokes if a newline or a paren follows a colon.  So do it the hard way...]
(defun SCHEMA::RESTORE-EYEHAND-ONLY (snapshot-spec)
  (let ((snapshot (schema::snapshot-from-spec snapshot-spec)))
    (schema::with-snapshot-destructuring snapshot
      schema::schema-system-version schema::timestamp schema::clock-tick
      schema::metering-state schema::schema-state schema::random-state schema::comment	; Ignored.
      (eyehand::safe-restore-eyehand-state schema::microworld-state))))

(defun TICKER-RESET ()
  (schema::restore-eyehand-only 0)
  (setf *inanimate-object-motions* nil)
  (values))

(defun COUNT-OBJECTS-IN-WORLD ()
  (let ((count 0))
    (dotimes (x *world-diameter*)
      (dotimes (y *world-diameter*)
	(when (get-object x y)
	  (incf count))))
    count))

(defun IDENTIFY-OBJECTS-IN-WORLD ()
  (terpri)
  (loop for y from (1- *world-diameter*) downto 0
	do (loop for x from 0 below *world-diameter*
		 do (let ((object (get-object x y)))
		      (if object
			  (format t "~9A" (identify-object object))
			  (format t "........ "))))
	   (terpri))
  (values))

(defun TEST-TICKER ()
  (loop for counter from 0
	until *inanimate-object-motions*
	do (clock-tick)
	finally (return counter)))

(defun SHOW-SOME-TICKS (&optional (n 100))
  (identify-objects-in-world)
  (loop with initial-length = (length *inanimate-object-motions*)
	until (zerop n)
	do (clock-tick)
	   (let ((new-length (length *inanimate-object-motions*)))
	     (unless (= initial-length new-length)
	       (setf initial-length new-length)
	       (decf n)
	       (identify-objects-in-world))))
  (values))

;;;; Random number generator seed saving function
;;;; NEW-INITIAL-RANDOM-STATE

;;; This function writes a new random-state seed
;;; to the disk file "state.dat" .
;;; This seed will be used the next time the world is initialized.

(defun NEW-INITIAL-RANDOM-STATE
  (&optional (filename "state.dat"))
  
  (with-open-file (out-file filename
                            :direction :output
                            :if-exists :supersede)
   (print (make-random-state t) out-file)
   (terpri out-file))
  'new-initial-random-state-written-to-disk)

;;;; Microworld initialization function INIT-WORLD.

;;; This function loads the current random seed from disk and resets
;;; all the world variables appropriately.
;;; The hand is placed at body relative coordinate (1,0) which is
;;; microspace relative coordinate (3,2).
;;; The center of the visual field is oriented at body relative
;;; coordinate (1,1) which is microspace relative coordinate (3,3).
;;; The hand is left open.
;;; The world is recreated from scratch, with the hand, body and two
;;; objects placed in the appropriate places, and the cycle values
;;; (used by clock-tick for randomly moving objects) reset.
;;; Finally, it resets and returns the value of *CLOCK*.

(defun INIT-WORLD (&optional (filename "state.dat"))
;  (with-open-file (in-file filename
;                           :direction :input
;                           :if-does-not-exist :error)
;   (setf *random-state* (read in-file nil nil nil)))
  filename					; Ignored for now.  --- Foner.
  (setf *grip-expiration* -1
        *hp-x* 1
        *hp-y* 0
        *vp-x* 1
        *vp-y* 1
        *hcl* nil
        *hgr* nil
        *world* (make-array (list *world-diameter* *world-diameter*)	 ; &&& Um, why do we bother setting it in a DEFVAR and here?
			    :initial-element nil)
        (get-object (fix+ 2 *body-x*) (fix+ 2 *body-y*)) *body*	    ; E.g., at 3,1.  Why it doesn't do it more directly, I dunno.
        (get-object (fix+ 2 *hp-x*)   (fix+ 2 *hp-y*))   *hand*	    ; E.g., at 3,2.
        (get-object 1 5) *object-1* ; cycle 0 moves right
        (get-cycle *object-1*) 0
        (get-object 5 5) *object-2* ; cycle 1 moves down
        (get-cycle *object-2*) 1
        *clock* 0))

;;;; Saving and restoring the state of the microworld.

(defparameter *EYEHAND-STATE-SCALARS*
	      '(
		*clock*
		*grip-expiration*
		*hp-x*
		*hp-y*
		*vp-x*
		*vp-y*
		*hcl*
		*hgr*))

(defparameter *EYEHAND-STATE-NONSCALARS*
	      '(
		*world*
		*body*
		*hand*
		*object-1*
		*object-2*))

(defparameter *EYEHAND-STATE-NONSCALAR-COPIERS*
	      '(
		(*world*                   safe-copy-world)
		(*body*                    safe-copy-world-object)
		(*hand*                    safe-copy-world-object)
		(*object-1*                safe-copy-world-object)
		(*object-2*                safe-copy-world-object)))

(defvar *EYEHAND-STATE-VARIABLES*
	(append *eyehand-state-scalars*
		*eyehand-state-nonscalars*))

(defun SAFE-COPY-WORLD-OBJECT (o)
  (let ((new (copy-world-object o)))
    (setf (world-object-visual new)  (copy-seq (world-object-visual new))
	  (world-object-tactile new) (copy-seq (world-object-tactile new))
	  (world-object-taste new)   (copy-seq (world-object-taste new)))
    new))

(defun SAFE-COPY-WORLD (w)
  ;; We assume that the array is 2D.  If I wanted to be Genera-specific, I could
  ;; use the SYS:ARRAY-REGISTER-1D declaration to force them into a 1D framework.
  ;; Alternately, if I really cared about generality, I could use a displaced array to do
  ;; the same thing.  But this is a tiny array, and known to be 2D, so what the hell...
  (let* ((old w)
	 (new (make-array (array-dimensions old)
			  :element-type (array-element-type old))))
    (dotimes (x (array-dimension old 0))
      (dotimes (y (array-dimension old 1))
	(let ((elt (aref old x y)))
	  (when elt
	    (setf (aref new x y)
		  (safe-copy-world-object elt))))))
    new))

(defun EYEHAND-COPIER-FROM-SYMBOL (symbol)
  (second (assoc symbol *eyehand-state-nonscalar-copiers*)))

(defun SAFE-COPY-EYEHAND-STATE ()
  (append
    (loop for scalar-symbol in *eyehand-state-scalars*
	  collect (symbol-value scalar-symbol))
    (loop for nonscalar-symbol in *eyehand-state-nonscalars*
	  for copier = (eyehand-copier-from-symbol nonscalar-symbol)
 	  collect (funcall copier (symbol-value nonscalar-symbol)))))

(defun SAFE-RESTORE-EYEHAND-STATE (snapshot)	; This is NOT an entire snapshot, but only the MICROWORLD-STATE part of it!
  (loop for state-symbol in *eyehand-state-variables*
	for item in snapshot
	for item-is-nonscalar? = (member state-symbol *eyehand-state-nonscalars*)
	for restore-fn = (and item-is-nonscalar?
			      (eyehand-copier-from-symbol state-symbol))
	do (set state-symbol
		(if item-is-nonscalar?
		    (funcall restore-fn item)
		    item)))
  (values))

;;; End of file.