(in-package "CL-USER")


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;;         name:  TOH
;;;;      version:  0.5.2
;;;;         date:  2.1.2005
;;;;
;;;;       author:  Sashank Varma
;;;; organization:  Vanderbilt University
;;;;        email:  sashank@vuse.vanderbilt.edu
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; History:
;;;;
;;;;   7.2001 sv: (v0.1.1) First version.  Beginning with the default Executive
;;;;                model centers, specialized the dm classes for the TOH
;;;;                domain, and wrote productions that solve problems that are
;;;;                directly solvable.  Made first attempt to layer on the
;;;;                sophisticated perceptual strategy, adding productions that
;;;;                unblock disks that are blocked from above by smaller disks.
;;;;
;;;;   7.2001 sv: (v0.1.2) Perfected the goal logic for unblocking disks that
;;;;                are blocked from above by smaller disks.
;;;;
;;;;   8.2001 sv: (v0.1.3) Perfected the running of batches of simulations and
;;;;                moved these top-level commands to a separate file
;;;;                "tohglue.lsp".
;;;;
;;;;   5.2002 sv: (v0.1.4) Fixed three bugs uncovered by Greg Sliwoski and
;;;;                Sharlene Newman.
;;;;
;;;;   5.2002 sv: (v0.1.5) Fixed bug in INTERNAL-DISK-INSERTION-POSITION
;;;;                revealed by 4-disk problems.
;;;;
;;;;  11.2004 sv: (v0.2.1) Standardized the case of comments and the
;;;;                organization of the code.
;;;;
;;;;  11.2004 sv: (v0.2.2) Standardized the General Executive model productions
;;;;                across the TOL, mental rotation, driving, and TOH models.
;;;;
;;;;  11.2004 sv: (v0.2.3) Modified the top-level simulation commands to
;;;;                output the number of cycles per move so that this could be
;;;;                compared with the Ruiz (1987) and Anderson, Kushmerick, &
;;;;                Lebiere (1993) data.  The correlations were okay, ranging
;;;;                between 0.78 and 0.90, and were as high as when the data
;;;;                were cross-correlated.
;;;;
;;;;  11.2004 sv: (v0.2.4) Renamed DM classes and their slots to be more
;;;;                informative and/or concise.  Renamed the TOP-LEVEL-GOAL
;;;;                class to TASK-GOAL in all models that instantiate the
;;;;                General Executive model.  Changed the generic FROM-* and
;;;;                TO-* slotnames to the more descriptive SOURCE-* and DEST-*.
;;;;                Shortened "POSITION" to "POS" in several slotnames. 
;;;;                Removed the superfluous SOURCE-POS slot from goals and
;;;;                moves.
;;;;
;;;;  11.2004 sv: (v0.2.5) Simplified all preferences to be unary as a prelude
;;;;                to overhauling preference adjudication and operator
;;;;                selection.  Before, would activate stub unary preferences
;;;;                with a baseline activation level and increment this through
;;;;                the firing of heuristic productions.  Now, all preferences
;;;;                are initially activated to a level commensurate with their
;;;;                suitability as determined by heuristic productions.  The
;;;;                activation levels are then incremented by a single
;;;;                production which is either additive (accumulative) or
;;;;                multiplicative (information theoretic) depending on the
;;;;                value of *ADDITIVE-SELECTION-P*.
;;;;
;;;;  11.2004 sv: (v0.2.6) Implemented and factored four selection schemes.
;;;;                Can now choose the activation accrual scheme via the
;;;;                *ACCRUAL-SCHEME* variable (additive or multiplicative) and
;;;;                the preference schemes via the *PREFERENCE-SCHEME* variable
;;;;                (absolute or relative).  Factored OPERATORs into DIRECT-
;;;;                OPERATORs and INDIRECT-OPERATORs.  This enabled all the new
;;;;                LH-Executive/contention scheduler productions to be
;;;;                expressed abstractly (i.e., in terms of operators, not
;;;;                TOH-specific moves), and thus be moved from the TOH model
;;;;                to the General Executive model.
;;;;
;;;;  12.2004 sv: (v0.2.7) Added the variable *PROPOSE-TOP-MOVES* to control
;;;;                whether promiscuous (i.e., non-hill-climbing, non-goal-
;;;;                based) moves are proposed and adjudicated.  When T, a
;;;;                production in RH-Spatial proposes such moves and
;;;;                productions in LH-Executive activate the preferences that
;;;;                enable them to participate in the selection process.  Also
;;;;                made the LH-Executive preference-handling productions more
;;;;                specific, replacing OPERATOR CEs with DIRECT-OPERATOR and
;;;;                INDIRECT-OPERATOR CEs when possible.
;;;;
;;;;  12.2004 sv: (v0.2.8) Added the variable *SUPPRESS-OLD-STATES* that
;;;;                controls which states besides the current one are
;;;;                maintained in LH-Spatial.  Possible values are NIL (i.e.,
;;;;                no old states), ALL (i.e., all old states), and ALL-BUT-
;;;;                PREV (i.e., only the previous old state, which is useful
;;;;                for implementing selection heuristics such as don't move
;;;;                the same disk twice in a row or don't make reverse moves).
;;;;                Revised existing productions of the selection schemes and
;;;;                added new productions that enable them to interact with the
;;;;                various settings of *SUPPRESS-OLD-STATES*.  Tested that the
;;;;                effects of this change are consistent with all possible
;;;;                settings of the other variables using the script at the
;;;;                bottom of the file.
;;;;
;;;;                One important side effect is that there is now a rough
;;;;                hierarchy of preferences: legal, hill-climbing, steepest-
;;;;                hill-climbing, goal, and top-goal.
;;;;
;;;;  12.2004 sv: (v0.2.9) Added the variable *TOP-GOAL-MOVES-ONLY* that
;;;;                controls whether only INDIRECT-MOVEs keyed to the the top
;;;;                goal are proposed or whether all INDIRECT-MOVEs keyed to
;;;;                all goals are proposed.
;;;;
;;;;  12.2004 sv: (v0.2.10) Defined top-level commands to simplify the
;;;;                running of simulations.
;;;;
;;;;  12.2004 sv: (v0.3.1) Renamed PREFERRED-OPERATOR to SELECTED-OPERATOR in
;;;;                a move away from the nomenclature of Soar and towards that
;;;;                of the executive function literature.  Eliminated the all
;;;;                (NOT-SOLVED-P S ES) from all but the move proposal
;;;;                productions in RH-Spatial.
;;;;
;;;;  12.2004 sv: (v0.3.2) Fit to the individual move time data.  (Required no
;;;;                modifications.)
;;;;
;;;;  12.2004 sv: (v0.4.1) Fit to the number of moves and time per move data of
;;;;                Anderson et al. (1993).
;;;;
;;;;  12.2004 sv: (v0.4.2) Fit to the number of moves data of Goel et al.
;;;;                (2001).  Also eliminated the non-reversal heuristic because
;;;;                the model performs identically regardless of its presence or
;;;;                absence.
;;;;
;;;;   1.2005 sv: (v0.4.3) Attempted to fit the Morris et al. (1997) data.  No
;;;;                real changes to the model were made.  The attempt focused
;;;;                on first lessening the heuristic value of the top goal by
;;;;                decreasing *W5* from 0.10 to 0.05, and then depleting the
;;;;                resources of each Executive center.  However, the data were
;;;;                found to be problematic -- the 5-move congruent problem is
;;;;                actually a conflict problem -- and so the effort was
;;;;                abandoned for now.
;;;;
;;;;   1.2005 sv: (v0.5.1) Fit the Carpenter et al. (1990) data.  The major
;;;;                change to the model was adding a *CONSTRAINED-P* parameter
;;;;                that indicates whether the presentation paradigm is
;;;;                unconstrained (the default) or constrained.  If constrained,
;;;;                the model's moves are corrected of they differ from the
;;;;                sequence indicated by *CONSTRAINED-MOVES*.  Error rates are
;;;;                also tabulated in a kludgy fashion.
;;;;
;;;;   1.2005 sv: (v0.5.2) Fit the Anderson et al. (2004) data.
;;;;
;;;;                Eliminated the ALL-BUT-PREV option for the *SUPPRESS-OLD-
;;;;                STATES* design decision, which has been irrelevant since
;;;;                the non-reversal heuristic was removed (because it did not
;;;;                contribute to the model's fit to the data).  Replaced it
;;;;                with a NON-GOAL option which maintains the current state
;;;;                and all states that previously spawned active goals.  This
;;;;                option should prove useful in accounting for left parietal
;;;;                activation.
;;;;
;;;;                Added a *CHUNK-TOWER* option which defaults to NIL.  When
;;;;                it is T, however, 2-disk and 3-disk towers are moved as
;;;;                chunked wholes, enabling a better fit to the Anderson et
;;;;                al. (2004) participants, who were highly practiced.  For
;;;;                example, the correlation to the individual move time data
;;;;                increases from 0.6861 to 0.8362 -- within spitting distance
;;;;                of the ACT-R model's 0.9217.
;;;;
;;;; NOTE: Added 0.95 thresholds on the absence tests of all productions in
;;;;       RH-Executive that activate new goals and indirect moves.  Hoped that
;;;;       this would make them iterate in the face of resource shortfalls
;;;;       (like the analogous LH-Executive productions), and thus improve the
;;;;       fit to the Carpenter et al. (1990) data and the patient data.  My
;;;;       first attempt was a failure.  Try again later.
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; In Progress:
;;;;
;;;;  10.1.2003 sv: (v0.1.5) Just squashed the weirdest freaking bug.  Switched
;;;;                the general Executive Model productions so that they assert
;;;;                MR-PREFERENCEs, but mistakenly left the Mental Rotation
;;;;                Model productions asserting plain PREFERENCEs.  This
;;;;                exposed a bug in the spew RHS action.  Spew takes a
;;;;                a template and spews the specified activation to all
;;;;                dmes that fit the template.  Therefore had productions
;;;;                spewing to the same unary preferenced expressed as both
;;;;                a PREFERENCE and MR-PREFERENCE, which is to say to two
;;;;                different dmes since spew does not coalesce across
;;;;                classes, even when one class is a subclass of the other.
;;;;                *Maybe* this was the right behavior, and users should
;;;;                be warned when they instantiate both a class and its
;;;;                superclass.  Or maybe this was a bug, and users should
;;;;                not be allowed to instantiate both a class and its
;;;;                superclass.
;;;;
;;;;   11.2004 sv: (v0.2) Why isn't TOH-DME called TOH-MI?  (The same holds for
;;;;                 SCM-DME, TOL-DME, MR-DME, and (?) DR-DME in the other
;;;;                 4CAPS models.)
;;;;
;;;; IMPORTANT: In v0.2.3 (8), which was finished on December 1st, 2004,
;;;;   I was able to get the LH-Executive and RH-Spatial variants to
;;;;   combine orthogonally.  This was done in part by conditionalizing some
;;;;   of the new LH-Executive productions on the value of *PROPOSE-TOP-
;;;;   MOVES*.  The productions that are defined when this variable is NIL
;;;;   could just as easily be available all of the times (i.e., regardless
;;;;   of the variables's value).  The major consequence is how long the
;;;;   model takes to make the last move when solving a puzzle -- that's it.
;;;;   May have to revisit this when fitting the model.
;;;;
;;;; May need to increase the specialization on goal dmes from the default 1
;;;;   to 2 or more to fit the fMRI data.
;;;;
;;;; Define a NOT-EQUALS LHS predicate in 4caps.lsp.  To have the right
;;;;   semantics it cannot be defined as (NOT (EQUALS ...)).
;;;;
;;;; Consider pervasive binding of PEG dmes a la the new PROPOSE-MOVE
;;;;   production.
;;;;
;;;; Try to eliminate the DEST-POS slot of moves.
;;;;
;;;; With v0.2.9, I confirmed that among the selection productions in LH-
;;;;   Executive, where it makes sense, all DIRECT-OPERATOR CEs could be
;;;;   changed to plain OPERATOR CEs and everything works fine.  This is more
;;;;   general but in the case of relative selection results in a relatively
;;;;   cumbersome number of preferences.
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Contents:
;;;;
;;;;   (1) Initialization.
;;;;   (2) DM Classes.
;;;;   (3) Centers.
;;;;   (4) The LH-Executive Center.
;;;;   (5) The RH-Executive Center.
;;;;   (6) The LH-Spatial Center.
;;;;   (7) The RH-Spatial Center.
;;;;   (8) Support Code.
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; (1) Initialization.
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;
;;; 4caps.
;;;


;; Tracing.

(set-tracing-p nil)
(set-tracing-dm-p nil)


;;

(set-default-dme-thresh 0.09)


;; Standard spew weight and rate.

(defparameter *weight* 1.0)
(defparameter *spew-rate* 1.0)



;;;
;;; Executive Model.
;;;


;; Spew weight associated with the various preference-asserting productions
;; of the General Executive model.  The magnitude represents the heuristic
;; goodness in activating the most preferred operator.

(defparameter *default-preference-weight* 0.1)



;;;
;;; TOH Model: Global Variables.
;;;


;; LH-Executive: Selection schemes.

;;; There are two different schemes for forming preferences.
;;;      absolute:       Like Shallice's contention scheduler, preferences
;;;                      reflect the absolute goodness of single operators.       
;;;      relative:       Like Soar, preferences reflect the relative goodness
;;;                      of pairs of operators.
(defvar *preference-scheme* 'absolute)

;;; There are two different schemes for accruing activation.
;;;      multiplicative: Like information theory and kind of like Hick's law,
;;;                      increase activation by a constant proportion on every
;;;                      cycle until one operator is above threshold.
;;;      additive:       Like accumulator models of selection, accumulate
;;;                      evidence on every cycle until one operator is above
;;;                      threshold.
(defvar *accrual-scheme* 'multiplicative)

#|
(setq *preference-scheme* 'absolute)
(setq *accrual-scheme* 'multiplicative)

(setq *preference-scheme* 'absolute)
(setq *accrual-scheme* 'additive)

(setq *preference-scheme* 'relative)
(setq *accrual-scheme* 'multiplicative)

(setq *preference-scheme* 'relative)
(setq *accrual-scheme* 'additive)
|#


;; RH-Executive: Indirect move promiscuity.

(defvar *top-goal-moves-only* nil)

#|
(setq *top-goal-moves-only* t)
(setq *top-goal-moves-only* nil)
|#


;; LH-Spatial: Old state maintenance.

;;; There are three different schemes for suppressing old states.

;;;^^^
;;;      non-goal: Retain the current state and all previous states that spawned goals.

;;;      all:      Retain only the current state.
;;;      nil:      Retain all states.
(defvar *suppress-old-states* 'all)

#|
;;;^^^
(setq *suppress-old-states* 'non-goal)

(setq *suppress-old-states* 'all)
(setq *suppress-old-states* nil)
|#


;; RH-Spatial: Direct move promiscuity.

(defvar *propose-top-moves* t)

#|
(setq *propose-top-moves* t)
(setq *propose-top-moves* nil)
|#


;; Multiple centers.

(defvar *chunked-tower* nil)

#|
(setq *chunked-tower* nil)
(setq *chunked-tower* t)
|#


;; Tracing.

(defvar *toh-trace-p* t)

#|
(setq *toh-trace-p* t)
(setq *toh-trace-p* nil)
|#

(defun goal-indent ()
  (dotimes (n (length (dme-list '(goal))))
    (princ #\tab))
  (values))


;;

(defvar *constrained-p* nil)

#|
(setq *constrained-p* nil)
(setq *constrained-p* t)
|#

(defvar *constrained-moves* ())

(defparameter *err0* 0)
(defparameter *tot0* 0)
(defparameter *err1* 0)
(defparameter *tot1* 0)
(defparameter *err2+* 0)
(defparameter *tot2* 0)


;; 

(defvar *max-macro-cycs* 2000)




;;;
;;; TOH Model: Support Functions.
;;;
;;; These functions, which implement the spatiality of TOH puzzle configurations,
;;; are outside the cognitive scope of the model.  Importantly, they are shared
;;; by all 4CAPS models and by the Common Lisp implementations of the various
;;; strategies.
;;;


;; Record of moves.

(defparameter *record-moves-p* t)
(defparameter *move-record* ())


;; Auxiliary functions.

(defun random-element (lis)
  (nth (random (length lis)) lis))


;; Translate between symbolic and numeric peg designators.

(defun peg-number (peg)
  (ecase peg
    (peg1 1)
    (peg2 2)
    (peg3 3)))

(defun number-peg (num)
  (ecase num
    (1 'peg1)
    (2 'peg2)
    (3 'peg3)))


;; Classic function to return the non-source, non-destination peg.

(defun other-peg (p1 p2)
  (number-peg (- 6 (peg-number p1) (peg-number p2))))


;; The class of puzzle configurations.

(defclass configuration ()
  ((disks :initarg :disks
          :initform nil
          :accessor disks)
   (peg1 :initarg :peg1
         :initform nil
         :accessor peg1)
   (peg2 :initarg :peg2
         :initform nil
         :accessor peg2)
   (peg3 :initarg :peg3
         :initform nil
         :accessor peg3)))


;

(defmethod print-object ((self configuration) str)
  (format str "~A ~A ~A" (peg1 self) (peg2 self) (peg3 self)))

(defmethod equal-configs ((c1 configuration) (c2 configuration))
  (and (equal (peg1 c1) (peg1 c2))
       (equal (peg2 c1) (peg2 c2))
       (equal (peg3 c1) (peg3 c2))))

(defmethod copy-config ((self configuration))
  (make-instance 'configuration
    :disks (disks self)
    :peg1 (copy-list (peg1 self))
    :peg2 (copy-list (peg2 self))
    :peg3 (copy-list (peg3 self))))


;

(defmethod make-move ((self configuration) n dp)
  (let ((sp (peg-of self n)))
    (setf (slot-value self sp) (delete n (slot-value self sp)))
    (setf (slot-value self dp) (nconc (slot-value self dp) (list n))))
  self)

(defmethod try-move ((self configuration) n dp)
  (make-move (copy-config self) n dp))

;;;^^^ Shouldn't this check that a larger disk is not being moved on top of
;;;^^^ a smaller disk?
(defmethod direct-move-2-p ((self configuration) n peg pos)
  (and (top-disk-p self n)
       (= (top-empty-position self peg) pos)))


;

(defmethod peg-of ((self configuration) n)
  (assert (<= n (disks self)))
  (or (find n '(peg1 peg2 peg3) :test #'(lambda (x y)
                                          (member x (slot-value self y))))
      (error "Disk ~A not on any peg of ~A." n self)))

;;; Returns first non-empty peg.
(defmethod peg-with-disks ((self configuration))
  (cond ((peg1 self)
         'peg1)
        ((peg2 self)
         'peg2)
        ((peg3 self)
         'peg3)))

(defmethod random-other-peg ((self configuration) n)
  (let ((sp (peg-of self n)))
    (random-element (remove-if #'(lambda (dp)
                                   (or (eq dp sp)
                                       (destination-blocking-disks self n dp)))
                               '(peg1 peg2 peg3)))))


;

(defmethod position-of ((self configuration) n)
  (position n (slot-value self (peg-of self n))))

(defmethod top-empty-position ((self configuration) peg)
  (length (slot-value self peg)))

(defmethod occupied-position-p ((self configuration) peg pos)
  (< pos (top-empty-position self peg)))


;

(defmethod random-top-disk ((self configuration))
  (let ((disks ()))
    (let ((disk1 (first (last (peg1 self)))))
      (when disk1
        (setq disks (nconc disks (list disk1)))))
    (let ((disk2 (first (last (peg2 self)))))
      (when disk2
        (setq disks (nconc disks (list disk2)))))
    (let ((disk3 (first (last (peg3 self)))))
      (when disk3
        (setq disks (nconc disks (list disk3)))))
    (random-element disks)))

;;;^^^ Should this be true of only the disk immediately on top or of all disks
;;;^^^ on top?
(defmethod on-top-of-p ((self configuration) n1 n2)
  (and (eq (peg-of self n1) (peg-of self n2))
       (= (position-of self n1)
          (1+ (position-of self n2)))))

(defmethod top-disk-p ((self configuration) n)
  (or (eql n (first (last (peg1 self))))
      (eql n (first (last (peg2 self))))
      (eql n (first (last (peg3 self))))))

(defmethod blocked-disk-p ((self configuration) n)
  (not (top-disk-p self n)))


;

(defmethod out-of-place-disks ((curr configuration) (end configuration))
  (let ((out-of-place-disks ()))
    (do ((disk (disks curr) (1- disk)))
        ((zerop disk))
      (unless (eq (peg-of curr disk) (peg-of end disk))
        (push disk out-of-place-disks)))
    out-of-place-disks))

(defmethod random-out-of-place-disk ((curr configuration) (end configuration))
  (random-element (out-of-place-disks curr end)))

(defmethod largest-out-of-place-disk ((curr configuration) (end configuration))
  (let ((disks (out-of-place-disks curr end)))
    (and disks (apply #'max disks))))

(defmethod buffer-peg-position ((self configuration) peg n)
  (let ((disks (slot-value self peg)))
    (or (position-if #'(lambda (disk)
                         (< disk n))
                     disks)
      (length disks))))


;

(defmethod source-blocking-disks ((self configuration) n)
  (rest (member n (slot-value self (peg-of self n)))))

(defmethod random-source-blocking-disk ((self configuration) n)
  (random-element (source-blocking-disks self n)))

(defmethod largest-source-blocking-disk ((self configuration) n)
  (first (source-blocking-disks self n)))


;

(defmethod destination-blocking-disks ((self configuration) n dp)
  (do ((disks (slot-value self dp) (rest disks)))
      ((or (null disks)
           (> n (first disks)))
       disks)))

(defmethod random-destination-blocking-disk ((self configuration) n dp)
  (random-element (destination-blocking-disks self n dp)))

(defmethod largest-destination-blocking-disk ((self configuration) n dp)
  (first (destination-blocking-disks self n dp)))


;

(defmethod blocking-disks-p ((self configuration) n dp)
  (or (source-blocking-disks self n)
      (destination-blocking-disks self n dp)))

(defmethod largest-blocking-disk ((self configuration) n dp)
  (let ((source-block (largest-source-blocking-disk self n))
        (dest-block (largest-destination-blocking-disk self n dp)))
    (if source-block
      (if dest-block
        (max source-block dest-block)
        source-block)
      dest-block)))




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; (2) DM classes.
;;;;
;;;; The DM class hierarchy is schematically represented below. "A: B" means
;;;; that class A is a superclass of class B.  "A: B (+C)" means that class A
;;;; is a superclass of class B, and is mixed with class C to produce class B.
;;;;
;;;; Mixin classes are typically suffixed with "-mi".
;;;;
;;;; Default DM classes are capilatized; TOH-specific ones are in lowercase.
;;;;
;;;; disk
;;;;
;;;; peg
;;;;
;;;; puzzle-mi
;;;;
;;;; move-mi
;;;;
;;;; toh-dme
;;;;
;;;; BASE-STATE:          STATE:              puzzle            (+ puzzle-mi toh-dme)
;;;;                      END-STATE:          end-puzzle        (+ puzzle-mi toh-dme)
;;;;
;;;; OPERATOR:            DIRECT-OPERATOR:    direct-move       (+ move-mi toh-dme)
;;;;                      INDIRECT-OPERATOR:  indirect-move     (+ move-mi toh-dme):  chunked-indirect-move
;;;;
;;;; PREFERENCE:
;;;;
;;;; SELECTED-OPERATOR
;;;;
;;;; BASE-GOAL:           TASK-GOAL:          solve-puzzle-goal (+ toh-dme)
;;;;                      GOAL:               unblock-goal      (+ toh-dme):          unblock-disk-goal:     chunked-unblock-disk-goal
;;;;                                                                                  unblock-position-goal: chunked-unblock-position-goal
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;
;;; Executive Model.
;;;


;; STATE-related classes and methods.


; The BASE-STATE class from which all others inherit.  This is a convenient
; abstraction because STATE and END-STATE classes typically share the same
; contents, which can be defined once, here.

(defdmclass base-state ()
  contents)


; The STATE class, instances of which are the bread and butter of Newell and
; Simon's (1972) view of problem solving as search through state spaces.

(defdmclass state (base-state))

(defmethod more-recent-state-p ((s1 state) (s2 state))
  (> (id s1) (id s2)))


; The END-STATE class, which encodes the state of affairs that signals task
; completion.

(defdmclass end-state (base-state))


;; STATE-related multimethods.  These methods apply across different STATE
;; classes.

;;; Are the two states C1 and C2 the same?  This method must be explicitly
;;; defined when the general Executive Model is applied to a particular domain
;;; to reflect the content of states in that domain: puzzle configurations,
;;; Shepard-Metzler figures in particular orientations, etc.
(defmethod contents-equal ((c1 t) (c2 t))
  (error "The CONTENTS-EQUAL multimethod must be specialized for the task at hand."))

;;; Is the state S, typically the current state, the same as end state ES?
;;; This determines whether the current task has been completed.
;;;
;;; NOTE: Change name to NOT-COMPLETED-P; while "solved" works for the TOH
;;;       and TOL domains, it works less well for mental rotation and driving.
(defmethod not-solved-p ((s state) (es end-state))
  (not (contents-equal (contents s) (contents es))))


;; The OPERATOR class.  In Newell and Simon's (1972) view of problem solving,
;; when an instance of this class is applied to the current state, the
;; next currrent state is generated.

(defdmclass operator ()
  state)

(defdmclass direct-operator (operator))

(defdmclass indirect-operator (operator)
  goal)


;; The PREFERENCE class.  In Newell's (1990) Soar theory, when multiple
;; operators can be applied to the current state, this ambiguity must be
;; eliminated.  Instances of this class represent local (pairwise)
;; orderings of operators.  They are combined and sorted to determine the
;; most preferred operator, which is selected for application.
;;
;;^^ NEW.  No longer binary/logical, but unary/activation drive.

(defdmclass preference ()
  operator)


;; The SELECTED-OPERATOR class.  In Newell's (1990) Soar theory, when
;; preferences have been asserted over the possible operators and the most
;; preferred operator selected, its identity must be noted in some way.
;; Instances of this class serve this purpose.

(defdmclass selected-operator ()
  operator)


;; GOAL-related classes and methods.


; The BASE-GOAL class from which all others inherit.  This is SOMETIMES
; a convenient abstraction -- when the GOAL and TASK-GOAL classes
; share structure, it can be defined once, here -- but not typically.
;
; NOTE: Eliminate this abstraction.

(defdmclass base-goal ())

(defmethod more-recent-goal-p ((bg1 base-goal) (bg2 base-goal))
  (> (id bg1) (id bg2)))


; The TASK-GOAL class, instances of which encode the task being
; performed.

(defdmclass task-goal (base-goal))


; The base GOAL class.  Instances are subgoals that are proposed to
; resolve impasses in the selection between operators and the application
; operators to states.  They can also be spawned recursively to generate
; goal-subgoal hierarchies.  They are central to Newell and Simon's (1972)
; theory of problem solving, and its revision in Soar (Newell, 1990).

(defdmclass goal (base-goal)
  operator)


;; General multimethods that apply acrosses classes.  They must be specialized
;; when the general Executive Model is applied to a particular domain to
;; reflect the specific content of representations in that domain. 

;;; Does the operator OP1 make faster progress towards the end state ES than
;;; the operator OP2?
(defmethod steeper-climbing-operator-p ((op1 operator) (op2 operator) (es end-state))
  (error "The STEEPER-CLIMBING-OPERATOR-P multimethod must be specialized for the task."))

;;; Perform the operator OP on the state S, yielding the contents of the new,
;;; successor state.
(defmethod perform-operator ((op operator) (s state))
  (error "The PERFORM-OPERATOR multimethod must be specialized for the task."))

;;; Does the state S represent satisfaction of the goal G?
(defmethod satisfied-p ((g goal) (s state))
  (error "The SATISFIED-P multimethod must be specialized for the task."))

;;;^^^ NEW.
;;;
;;; Can the operator OP be applied to the state S, or are some of its
;;; preconditions unsatisfied? 
(defmethod legal-operator-p ((s state) (op operator))
  (error "The LEGAL-OPERATOR-P multimethod must be specialized for the task."))



;;;
;;; TOH Model classes.
;;;


;; Support classes.

(defdmclass disk ()
  disk)

(defdmclass peg ()
  peg)


;; Mixin classes.  Often, two classes derived in different parts of the
;; inheritance hierarchy will share structure.  It is useful in these cases
;; to extract the shared structure into a separate "mixin" class.


;

(defdmclass puzzle-mi ())


;

(defdmclass move-mi ()
  disk
  source-peg
  dest-peg
  dest-pos)


; The base mixin class of the TOH Model.  When the generic classes of the
; general Executive Model are specialized for the TOH domain, this class is
; "mixed in" via multiple inheritance.  This will be useful in the future if
; the TOH model is ever used to model dual-task performance.

(defdmclass TOH-dme ())



;; STATE-related classes and methods.

(defdmclass puzzle (puzzle-mi state toh-dme))

(defdmclass end-puzzle (puzzle-mi end-state toh-dme))


;; OPERATOR-related classes.

(defdmclass direct-move (move-mi direct-operator toh-dme))

(defdmclass indirect-move (move-mi indirect-operator toh-dme))

(defdmclass chunked-indirect-move (indirect-move))


;; PREFERENCE-related classes.


;; PREFERED-OPERATOR-related classes.


;; GOAL-related classes.

(defdmclass solve-puzzle-goal (task-goal toh-dme))

(defdmclass unblock-goal (goal toh-dme)
  source-peg
  dest-peg
  dest-pos)

(defdmclass unblock-disk-goal (unblock-goal)
  disk)

(defdmclass chunked-unblock-disk-goal (unblock-disk-goal))

(defdmclass unblock-position-goal (unblock-goal))

(defdmclass chunked-unblock-position-goal (unblock-position-goal))



;;;
;;; TOH Model multimethods.
;;;


;; Specialize the abstract place-holder methods of the General Executive model
;; for the TOH domain.


;

(defmethod contents-equal ((c1 configuration) (c2 configuration))
  (equal-configs c1 c2))


;

(defmethod hill-climbing-operator-p ((m move-mi) (ep end-puzzle))
  (and (eql (peg-of (contents ep) (disk m))
            (dest-peg m))
       (eql (position-of (contents ep) (disk m))
            (dest-pos m))))

(defmethod steeper-climbing-operator-p ((m1 move-mi) (m2 move-mi) (ep end-puzzle))
  (and (hill-climbing-operator-p m1 ep)
       (hill-climbing-operator-p m2 ep)
       (> (disk m1) (disk m2))))


;

(defmethod perform-operator ((m move-mi) (p puzzle))
  (if *constrained-p*
    (if *constrained-moves*
      (let ((move (first *constrained-moves*)))
        (make-move (copy-config (contents p))
                   (second move)
                   (third move)))
      (error "Model continued to run, possibly after problem solved."))
    (make-move (copy-config (contents p))
               (disk m)
               (dest-peg m))))

;

(defmethod satisfied-p ((g unblock-disk-goal) (p puzzle))
  (top-disk-p (contents p) (disk g)))

(defmethod satisfied-p ((g chunked-unblock-disk-goal) (p puzzle))
  (and (= (disk g) 3)
       (eq (peg-of (contents p) 3) (dest-peg g))
       (on-top-of-p (contents p) 2 3)
       (on-top-of-p (contents p) 1 2)
       (top-disk-p (contents p) 1)))

(defmethod satisfied-p ((g unblock-position-goal) (p puzzle))
  (eql (dest-pos g)
       (top-empty-position (contents p) (dest-peg g))))

(defmethod satisfied-p ((g chunked-unblock-position-goal) (p puzzle))
  (and (eq (peg-of (contents p) 2) (buffer-peg g))
       (on-top-of-p (contents p) 1 2)
       (top-disk-p (contents p) 1)))


;

;;;^^^ NEW.
(defmethod legal-operator-p ((c configuration) (m move-mi))
  (and (top-disk-p c (disk m))
       (= (dest-pos m) (top-empty-position c (dest-peg m)))
       (or (null (slot-value c (dest-peg m)))
           (< (disk m) (first (last (slot-value c (dest-peg m))))))))


;; TOH-specific methods.

(defmethod buffer-peg ((g goal))
  (with-slots (source-peg dest-peg) g
    (if (eq source-peg dest-peg)
      
      ;;^^ Arbitrary tie-breaker.
      (if (eq source-peg 'peg1)
        'peg2
        'peg1)
      
      (other-peg source-peg dest-peg))))

(defmethod direct-move-p ((p puzzle) (m move-mi))
  (direct-move-2-p (contents p) (disk m) (dest-peg m) (dest-pos m)))




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; (3) Centers.
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;
;;; Executive Model.
;;;


;; Delete all existing centers.

(del-centers)


;; Add the centers of the Executive model.

(add-center support)

(add-center rh-executive)
(add-center lh-executive)

(add-center rh-spatial)
(add-center lh-spatial)


;; Give the centers unlimited resource capacities.

(set-caps@ (support rh-executive lh-executive rh-spatial lh-spatial) nil)


;; Set the default center specializations.

(set-specs@ lh-executive base-dme nil
                         base-state t
                         operator t
                         preference 1
                         selected-operator 1
                         base-goal t)

(set-specs@ rh-executive base-dme nil
                         base-state t
                         operator t
                         preference t
                         selected-operator t
                         base-goal 1)

(set-specs@ lh-spatial base-dme nil
                       base-state 1
                       operator t
                       preference t
                       selected-operator t
                       base-goal t)

(set-specs@ rh-spatial base-dme nil
                       base-state t
                       operator 1
                       preference t
                       selected-operator t
                       base-goal t)



;;;
;;; TOH model.
;;;


;; Set the resource capacities of the centers.

(set-caps@ support nil)

(set-caps@ lh-executive 10.0)
(set-caps@ rh-executive 10.0)

(set-caps@ lh-spatial 10.0)
(set-caps@ rh-spatial 10.0)


;; Set the TOH model specializations.

(set-specs@ support base-dme nil
                    disk 1
                    peg 1)

(set-specs@ lh-executive disk t
                         peg t)

(set-specs@ rh-executive disk t
                         peg t
                         indirect-move 1
                         solve-puzzle-goal 1

                         ;; May need to increase this to 2 or more when fitting
                         ;; the fMRI data.
                         unblock-goal 1

                         )

(set-specs@ lh-spatial disk t
                       peg t)

(set-specs@ rh-spatial disk t
                       peg t
                       direct-move 1
                       indirect-move t)




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; (4) The LH-Executive Center.
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;
;;; General Executive model productions.
;;;


;; Additive activation accrual, absolute preference assertion.

(when (and (eq *accrual-scheme* 'additive)
           (eq *preference-scheme* 'absolute))

(when *propose-top-moves*

(p@ lh-executive legal-additive-absolute ((s state)
                                          (op direct-operator))
    (equal s (state op))
    (legal-operator-p (contents s) op)
    (*no ((~s state))
      (more-recent-state-p ~s s))
    (*no ((~pr preference 0.95))
      (equal (state (operator ~pr)) s))
    (*no ((~sop selected-operator))
      (equals (state (operator ~sop)) s))
-->
    (spew t (preference :operator op)
            (* 0.125 *default-preference-weight* *spew-rate*))
)

)

(p@ lh-executive hill-climbing-additive-absolute ((s state)
                                                  (es end-state)
                                                  (op direct-operator))
    (equal s (state op))
    (hill-climbing-operator-p op es)
    (*no ((~s state))
      (more-recent-state-p ~s s))
    (*no ((~pr preference 0.95))
      (equal (state (operator ~pr)) s))
    (*no ((~sop selected-operator))
      (equals (state (operator ~sop)) s))
-->
    (spew t (preference :operator op)
            (* 0.25 *default-preference-weight* *spew-rate*))
)

(p@ lh-executive steepest-hill-climbing-additive-absolute ((s state)
                                                           (es end-state)
                                                           (op direct-operator))
    (equal s (state op))
    (hill-climbing-operator-p op es)
    (*no ((~op operator))
      (not-equal ~op op)
      (equal s (state ~op))
      (hill-climbing-operator-p ~op es)
      (steeper-climbing-operator-p ~op op es))
    (*no ((~s state))
      (more-recent-state-p ~s s))
    (*no ((~pr preference 0.95))
      (equal (state (operator ~pr)) s))
    (*no ((~sop selected-operator))
      (equals (state (operator ~sop)) s))
-->
    (spew t (preference :operator op)
            (* 0.5 *default-preference-weight* *spew-rate*))
)

(p@ lh-executive goal-additive-absolute ((s state)
                                         (g unblock-goal)
                                         (op indirect-operator))
    (equal s (state op))
    (equal g (goal op))
    (*no ((~s state))
      (more-recent-state-p ~s s))
    (*no ((~pr preference 0.95))
      (equal (operator ~pr) op))
    (*no ((~sop selected-operator))
      (equals (state (operator ~sop)) s))
-->
    (spew t (preference :operator op)
            (* 0.5 *default-preference-weight* *spew-rate*))
)

(p@ lh-executive top-goal-additive-absolute ((s state)
                                             (g unblock-goal)
                                             (op indirect-operator))
    (equal s (state op))
    (equal g (goal op))
    (*no ((~g goal))
      (more-recent-goal-p ~g g))
    (*no ((~s state))
      (more-recent-state-p ~s s))
    (*no ((~pr preference 0.95))
      (equal (operator ~pr) op))
    (*no ((~sop selected-operator))
      (equals (state (operator ~sop)) s))
-->
    (spew t (preference :operator op)
            (* 1.0 *default-preference-weight* *spew-rate*))
)

)


;; Multiplicative activation accrual, absolute preference assertion.

;;; For fitting number of moves and related measures.
(defvar *w1* 0.10)
(defvar *w2* 0.15)
(defvar *w3* 0.05)
(defvar *w4* 0.25)
(defvar *w5* 0.10)
(defvar *w6* 1.0)

#|
;;; For fitting individual move times.
(setq *w1* 0.0125)
(setq *w2* 0.025)
(setq *w3* 0.05)
(setq *w4* 0.05)
(setq *w5* 0.10)
(setq *w6* 2.0)

;;; For fitting number of moves and other error-laden data.
(setq *w1* 0.10)
(setq *w2* 0.15)
(setq *w3* 0.05)
(setq *w4* 0.25)
(setq *w5* 0.10)
(setq *w6* 1.0)
|#

(defvar *random-weights* t)

#|
;;; For fitting individual move times.
(setq *random-weights* nil)

;;; For fitting number of moves and other error-laden data.
(setq *random-weights* t)
|#

(defun random-weight ()
  (if *random-weights*
    (random 1.0)
    1))

(when (and (eq *accrual-scheme* 'multiplicative)
           (eq *preference-scheme* 'absolute))

(when *propose-top-moves*

(p@ lh-executive legal-multiplicative-absolute ((s state)
                                                (op direct-operator))
    (equal s (state op))
    (legal-operator-p (contents s) op)
    (*no ((~s state))
      (more-recent-state-p ~s s))
    (*no ((~pr preference 0.01))
      (equal (state (operator ~pr)) s))
    (*no ((~sop selected-operator))
      (equals (state (operator ~sop)) s))
-->
    (spew t (preference :operator op)
            (* *w1* (random-weight) *spew-rate*))
)

)

(p@ lh-executive hill-climbing-multiplicative-absolute ((s state)
                                                        (es end-state)
                                                        (op direct-operator))
    (equal s (state op))
    (hill-climbing-operator-p op es)
    (*no ((~s state))
      (more-recent-state-p ~s s))
    (*no ((~pr preference 0.01))
      (equal (operator ~pr) op))
    (*no ((~sop selected-operator))
      (equals (state (operator ~sop)) s))
-->
    (spew t (preference :operator op)
            (* *w2* (random-weight) *spew-rate*))
)

(p@ lh-executive steepest-hill-climbing-multiplicative-absolute ((s state)
                                                                 (es end-state)
                                                                 (op direct-operator))
    (equal s (state op))
    (hill-climbing-operator-p op es)
    (*no ((~op operator))
      (not-equal ~op op)
      (equal s (state ~op))
      (hill-climbing-operator-p ~op es)
      (steeper-climbing-operator-p ~op op es))
    (*no ((~s state))
      (more-recent-state-p ~s s))
    (*no ((~pr preference 0.01))
      (equal (operator ~pr) op))
    (*no ((~sop selected-operator))
      (equals (state (operator ~sop)) s))
-->
    (spew t (preference :operator op)
            (* *w3* (random-weight) *spew-rate*))
)

(p@ lh-executive goal-multiplicative-absolute ((s state)
                                               (g unblock-goal)
                                               (op indirect-operator))
    (equal s (state op))
    (equal g (goal op))
    (*no ((~s state))
      (more-recent-state-p ~s s))
    (*no ((~pr preference 0.01))
      (equal (operator ~pr) op))
    (*no ((~sop selected-operator))
      (equals (state (operator ~sop)) s))
-->
    (spew t (preference :operator op)
            (* *w4* (random-weight) *spew-rate*))
)

(p@ lh-executive top-goal-multiplicative-absolute ((s state)
                                                   (g unblock-goal)
                                                   (op indirect-operator))
    (equal s (state op))
    (equal g (goal op))
    (*no ((~g goal))
      (more-recent-goal-p ~g g))
    (*no ((~s state))
      (more-recent-state-p ~s s))
     (*no ((~pr preference 0.01))
      (equal (operator ~pr) op))
    (*no ((~sop selected-operator))
      (equals (state (operator ~sop)) s))
-->
    (spew t (preference :operator op)
            (* *w5* (random-weight) *spew-rate*))
)

(when *chunked-tower*

(p@ lh-executive top-chunked-goal-multiplicative-absolute ((s state)
                                                           (g unblock-goal)
                                                           (op chunked-indirect-move))
    (equal s (state op))
    (equal g (goal op))
    (*no ((~g goal))
      (more-recent-goal-p ~g g))
    (*no ((~s state))
      (more-recent-state-p ~s s))
     (*no ((~pr preference 0.01))
      (equal (operator ~pr) op))
    (*no ((~sop selected-operator))
      (equals (state (operator ~sop)) s))
-->
    (spew t (preference :operator op)
            (* 1.0 *spew-rate*))
)

)

(p@ lh-executive iteratively-activate-multiplicative-absolute ((s state)
                                                               (op operator)
                                                               (pr preference .01))
    (equal s (state op))
    (equal (operator pr) op)
    (*no ((~s state))
      (more-recent-state-p ~s s))
    (*no ((~pr preference 0.95))
      (equal (state (operator ~pr)) s))
    (*no ((~sop selected-operator))
      (equals (state (operator ~sop)) s))
-->
    (spew pr pr (* *w6* *spew-rate*))
)

)


;; Additive activation accrual, relative preference assertion.

(when (and (eq *accrual-scheme* 'additive)
           (eq *preference-scheme* 'relative))

(cond

(*propose-top-moves*

(p@ lh-executive legal-additive-relative ((s state)
                                          (op1 direct-operator)
                                          (op2 direct-operator))
    (equals s (state op1) (state op2))
    (legal-operator-p (contents s) op1)
    (*whole (not (legal-operator-p (contents s) op2)))
    (*no ((~s state))
      (more-recent-state-p ~s s))
    (*no ((~pr preference 0.95))
      (equal (state (operator ~pr)) s))
    (*no ((~sop selected-operator))
      (equals (state (operator ~sop)) s))
-->
    (spew t (preference :operator op1)
            (* 0.125 *default-preference-weight* *spew-rate*))
)

)

(t

(p@ lh-executive activate-additive-relative ((s state)
                                             (op operator))
    (equal s (state op))
    (*no ((~op operator))
      (not-equal ~op op)
      (equal s (state ~op)))
    (*no ((~s state))
      (more-recent-state-p ~s s))
    (*no ((~pr preference 0.95))
      (equal (state (operator ~pr)) s))
    (*no ((~sop selected-operator))
      (equal (state (operator ~sop)) s))
-->
    (spew t (preference :operator op)
            (* 2.0 *default-preference-weight* *spew-rate*))
)

))

(p@ lh-executive hill-climbing-additive-relative ((s state)
                                                  (es end-state)
                                                  (op1 direct-operator)
                                                  (op2 direct-operator))
    (equals s (state op1) (state op2))
    (hill-climbing-operator-p op1 es)
    (*whole (not (hill-climbing-operator-p op2 es)))
    (*no ((~s state))
      (more-recent-state-p ~s s))
    (*no ((~pr preference 0.95))
      (equal (state (operator ~pr)) s))
    (*no ((~sop selected-operator))
      (equals (state (operator ~sop)) s))
-->
    (spew t (preference :operator op1)
            (* 0.25 *default-preference-weight* *spew-rate*))
)

(p@ lh-executive steeper-hill-climbing-additive-relative ((s state)
                                                          (es end-state)
                                                          (op1 direct-operator)
                                                          (op2 direct-operator))
    (equals s (state op1) (state op2))
    (steeper-climbing-operator-p op1 op2 es)
    (*no ((~s state))
      (more-recent-state-p ~s s))
    (*no ((~pr preference 0.95))
      (equal (state (operator ~pr)) s))
    (*no ((~sop selected-operator))
      (equals (state (operator ~sop)) s))
-->
    (spew t (preference :operator op1)
            (* 0.5 *default-preference-weight* *spew-rate*))
)

(p@ lh-executive goal-additive-relative ((s state)
                                         (g unblock-goal)
                                         (iop indirect-operator)
                                         (dop direct-operator))
    (equals s (state iop) (state dop))
    (equal g (goal iop))
    (*no ((~s state))
      (more-recent-state-p ~s s))
    (*no ((~pr preference 0.95))
      (equal (state (operator ~pr)) s))
    (*no ((~sop selected-operator))
      (equals (state (operator ~sop)) s))
-->
    (spew t (preference :operator iop)
            (* 0.5 *default-preference-weight* *spew-rate*))
)

(p@ lh-executive higher-goal-additive-relative ((s state)
                                                (g1 unblock-goal)
                                                (g2 unblock-goal)
                                                (op1 indirect-operator)
                                                (op2 indirect-operator))
    (equals s (state op1) (state op2))
    (equal g1 (goal op1))
    (equal g2 (goal op2))
    (more-recent-goal-p g1 g2)
    (*no ((~s state))
      (more-recent-state-p ~s s))
    (*no ((~pr preference 0.95))
      (equal (state (operator ~pr)) s))
    (*no ((~sop selected-operator))
      (equals (state (operator ~sop)) s))
-->
    (spew t (preference :operator op1)
            (* 1.0 *default-preference-weight* *spew-rate*))
)

)


;; Multiplicative activation accrual, relative preference assertion.

(when (and (eq *accrual-scheme* 'multiplicative)
           (eq *preference-scheme* 'relative))

(cond

(*propose-top-moves*

(p@ lh-executive legal-multiplicative-relative ((s state)
                                                (op1 direct-operator)
                                                (op2 direct-operator))
    (equals s (state op1) (state op2))
    (legal-operator-p (contents s) op1)
    (*whole (not (legal-operator-p (contents s) op2)))
    (*no ((~s state))
      (more-recent-state-p ~s s))
    (*no ((~pr preference 0.01))
      (equal (state (operator ~pr)) s))
    (*no ((~sop selected-operator))
      (equals (state (operator ~sop)) s))
-->
    (spew t (preference :operator op1)
            (* 0.125 *default-preference-weight* *spew-rate*))
)

)

(t

(p@ lh-executive initially-activate-multiplicative-relative ((s state)
                                                             (op operator))
    (equal s (state op))
    (*no ((~op operator))
      (not-equal ~op op)
      (equal s (state ~op)))
    (*no ((~s state))
      (more-recent-state-p ~s s))
    (*no ((~pr preference 0.01))
      (equal (state (operator ~pr)) s))
    (*no ((~sop selected-operator))
      (equal (state (operator ~sop)) s))
-->
    (spew t (preference :operator op)
            (* 2.0 *default-preference-weight* *spew-rate*))
)

))

(p@ lh-executive hill-climbing-multiplicative-relative ((s state)
                                                        (es end-state)
                                                        (op1 direct-operator)
                                                        (op2 direct-operator))
    (equals s (state op1) (state op2))
    (hill-climbing-operator-p op1 es)
    (*whole (not (hill-climbing-operator-p op2 es)))
    (*no ((~s state))
      (more-recent-state-p ~s s))
    (*no ((~pr preference 0.01))
      (equal (state (operator ~pr)) s))
    (*no ((~sop selected-operator))
      (equals (state (operator ~sop)) s))
-->
    (spew t (preference :operator op1)
            (* 0.25 *default-preference-weight* *spew-rate*))
)

(p@ lh-executive steeper-hill-climbing-multiplicative-relative ((s state)
                                                                (es end-state)
                                                                (op1 direct-operator)
                                                                (op2 direct-operator))
    (equals s (state op1) (state op2))
    (steeper-climbing-operator-p op1 op2 es)
    (*no ((~s state))
      (more-recent-state-p ~s s))
    (*no ((~pr preference 0.01))
      (equal (operator ~pr) op1))
    (*no ((~sop selected-operator))
      (equals (state (operator ~sop)) s))
-->
    (spew t (preference :operator op1)
            (* 0.5 *default-preference-weight* *spew-rate*))
)

(p@ lh-executive goal-multiplicative-relative ((s state)
                                               (g unblock-goal)
                                               (iop indirect-operator)
                                               (dop direct-operator))
    (equals s (state iop) (state dop))
    (equal g (goal iop))
    (*no ((~s state))
      (more-recent-state-p ~s s))
    (*no ((~pr preference 0.01))
      (equal (operator ~pr) iop))
    (*no ((~sop selected-operator))
      (equals (state (operator ~sop)) s))
-->
    (spew t (preference :operator iop)
            (* 0.5 *default-preference-weight* *spew-rate*))
)

(p@ lh-executive higher-goal-multiplicative-relative ((s state)
                                                      (g1 unblock-goal)
                                                      (g2 unblock-goal)
                                                      (op1 indirect-operator)
                                                      (op2 indirect-operator))
    (equals s (state op1) (state op2))
    (equal g1 (goal op1))
    (equal g2 (goal op2))
    (more-recent-goal-p g1 g2)
    (*no ((~s state))
      (more-recent-state-p ~s s))
    (*no ((~pr preference 0.01))
      (equal (state (operator ~pr)) s))
    (*no ((~sop selected-operator))
      (equals (state (operator ~sop)) s))
-->
    (spew t (preference :operator op1)
            (* 1.0 *default-preference-weight* *spew-rate*))
)

(p@ lh-executive iteratively-activate-multiplicative-relative ((s state)
                                                               (op operator)
                                                               (pr preference .01))
    (equal s (state op))
    (equal (operator pr) op)
    (*no ((~s state))
      (more-recent-state-p ~s s))
    (*no ((~pr preference 0.95))
      (equal (state (operator ~pr)) s))
    (*no ((~sop selected-operator))
      (equals (state (operator ~sop)) s))
-->
    (spew pr pr (* 2.0 *default-preference-weight* *spew-rate*))
)

)


;; Select preferred operator given preferences.

;;; Select the best operator through consideration of unary preferences.  Such
;;; competitions are horse races, and thus the selected operator's preference
;;; must achieve an activation level above threshold.
(p@ lh-executive select-among-preferences ((s state)
                                           (es end-state)
                                           (op operator)
                                           (pr preference 0.95))
    (equal s (state op))
    (equal (operator pr) op)
    (*no ((~s state))
      (more-recent-state-p ~s s))


    ;;^^ NEW.  Resolves many (all?) of the ties that used to occur.
    (*no ((~pr preference 0.95))
      (not-equal ~pr pr)
      (equal s (state (operator ~pr)))
      (subtypep (class-of (operator ~pr)) (find-class 'direct-operator))
      (subtypep (class-of op) (find-class 'direct-operator))
      (hill-climbing-operator-p (operator ~pr) es)
      (not (hill-climbing-operator-p op es)))
    (*no ((~pr preference 0.95))
      (not-equal ~pr pr)
      (equal s (state (operator ~pr)))
      (subtypep (class-of (operator ~pr)) (find-class 'direct-operator))
      (subtypep (class-of op) (find-class 'direct-operator))
      (steeper-climbing-operator-p (operator ~pr) op es))
    (*no ((~pr preference 0.95))
      (not-equal ~pr pr)
      (equal s (state (operator ~pr)))
      (subtypep (class-of (operator ~pr)) (find-class 'indirect-operator))
      (subtypep (class-of op) (find-class 'direct-operator)))
    (*no ((~pr preference 0.95))
      (not-equal ~pr pr)
      (equal s (state (operator ~pr)))
      (subtypep (class-of (operator ~pr)) (find-class 'indirect-operator))
      (subtypep (class-of op) (find-class 'indirect-operator))
      (more-recent-goal-p (goal (operator ~pr)) (goal op)))

    (*no ((~sop selected-operator))
      (equal (state (operator ~sop)) s))
-->
    (spew t (selected-operator :operator op)
            (* *weight* *spew-rate*))
)


;; Suppress preferences after a preferred operator has been selected.

;;; Suppress preferences once an operator has been selected.
(p@ lh-executive suppress-preferrence ((sop selected-operator)
                                       (pr preference 0.001))
    (equal (state (operator sop)) (state (operator pr)))
    (*no ((~sop selected-operator))
      (> (id ~sop) (id sop)))
-->
    (spew t pr (- (* *weight* *spew-rate*)))
)


;; Suppress a preferred operator marker...

;;; ...after it is performed.
(p@ lh-executive suppress-selected-operator-marker ((sop selected-operator)
                                                    (op operator)
                                                    (bs state)
                                                    (as state))
    (equal (operator sop) op)
    (equal (state op) bs)

    ;;^^
    (more-recent-state-p as bs)

    (contents-equal (perform-operator op bs) (contents as))
-->
    (spew t sop (- (* *weight* *spew-rate*)))
)

;;;^^^
;;; ...if it cannot be performed because it is illegal.
(p@ lh-executive suppress-preempted-selected-operator-marker ((sop selected-operator)
                                                              (op operator)
                                                              (s state))
    (equal (operator sop) op)
    (equal (state op) s)
    (*whole (not (legal-operator-p (contents s) op)))
-->
    (spew t sop (- (* *weight* *spew-rate*)))
)

;;; ...if it cannot be performed, and thus caused an impasse, and thus led to
;;; the activation of a goal.
(p@ lh-executive suppress-preempted-selected-operator-marker ((g goal)
                                                              (sop selected-operator)
                                                              (op operator))
    (equals (operator g) (operator sop) op)
-->
    (spew t sop (- (* *weight* *spew-rate*)))
)


#|
;; Choose arbitrarily between multiple preferred operators.

;;; Two (or more) operators can emerge as preferred when unary preferences and
;;; pure activation dynamics are relied upon.  Must therefore choose between
;;; the contenders (again).
;;;
;;; NOTE: This production fires in some models, doesn't fire in others, and in
;;;       still others must be completely commented out.  It originated with
;;;       the Mental Rotation model and does not appear to fire when binary
;;;       preferences are used.  Need to generalize it to work in the same way
;;;       in all models.
(p@ lh-executive suppress-arbitrarily-chosen-selected-operator-marker ((sop1 selected-operator)
                                                                       (sop2 selected-operator))
   (not-equal sop1 sop2)
   (*no ((~sop selected-operator))
     (> (id (operator ~sop)) (id (operator sop1))))
-->
    (spew t sop2 (- (* *weight* *spew-rate*)))
)
|#



;;;
;;; TOH model productions.
;;;




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; (5) The RH-Executive Center.
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;
;;; General Executive model productions.
;;;


;; Suppress goals.

;;; When the most recent goal G is satisfied by the current state S, then
;;; suppress the completed goal.
(p@ rh-executive suppress-satisfied-goal ((g goal)
                                          (s state))
    (satisfied-p g s)
    (*no ((~g goal))
      (more-recent-goal-p ~g g))
    (*no ((~s state))
      (more-recent-state-p ~s s))
-->
    (spew t g (- (* *weight* *spew-rate*)))
)



;;;
;;; TOH model productions.
;;;


;; Propose goals.

(cond (*chunked-tower*

(p@ rh-executive propose-unblock-disk-goal ((p puzzle)
                                            (ep end-puzzle)
                                            (m move-mi)
                                            (sop selected-operator))
    (equal (state m) p)
    (equal (operator sop) m)
    (blocked-disk-p (contents p) (disk m))
    (*whole (not (and (not-solved-p p ep)
                      (> (largest-out-of-place-disk (contents p) (contents ep)) 3)
                      (= (disk m) 3)
                      (on-top-of-p (contents p) 2 3)
                      (on-top-of-p (contents p) 1 2)
                      (top-disk-p (contents p) 1))))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~d disk))
      (occupied-position-p (contents p) (dest-peg m) (dest-pos m))
      (equal (peg-of (contents p) (disk ~d)) (dest-peg m))
      (equal (position-of (contents p) (disk ~d)) (dest-pos m))
      (> (disk ~d) (largest-source-blocking-disk (contents p) (disk m))))
    (*no ((~udg unblock-disk-goal))
      (equal (operator ~udg) m)
      (equal (disk ~udg) (disk m))
      (equal (source-peg ~udg) (source-peg m))
      (equal (dest-peg ~udg) (dest-peg m))
      (equal (dest-pos ~udg) (dest-pos m)))
-->
    (when *toh-trace-p*
      (format t "~&")
      (goal-indent)
      (format t "Subgoal to unblock DISK~A on ~A. (~A)" (disk m) (source-peg m) *macro-cycs*))

    (spew t (unblock-disk-goal :operator m
                               :disk (disk m)
                               :source-peg (source-peg m)
                               :dest-peg (dest-peg m)
                               :dest-pos (dest-pos m))
            (* *weight* *spew-rate*))
)

(p@ rh-executive propose-unblock-position-goal ((p puzzle)
                                                (ep end-puzzle)
                                                (m move-mi)
                                                (sop selected-operator))
    (equal (state m) p)
    (equal (operator sop) m)
    (occupied-position-p (contents p) (dest-peg m) (dest-pos m))
    (*whole (not (and (not-solved-p p ep)
                      (> (largest-out-of-place-disk (contents p) (contents ep)) 2)
                      (equal (peg-of (contents p) 2) (dest-peg m))
                      (= (position-of (contents p) 2) (dest-pos m))
                      (on-top-of-p (contents p) 1 2)
                      (top-disk-p (contents p) 1))))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~d disk))
      (blocked-disk-p (contents p) (disk m))
      (equal (peg-of (contents p) (disk ~d)) (dest-peg m))
      (equal (position-of (contents p) (disk ~d)) (dest-pos m))
      (< (disk ~d) (largest-source-blocking-disk (contents p) (disk m))))
    (*no ((~upg unblock-position-goal))
      (equal (operator ~upg) m)
      (equal (source-peg ~upg) (source-peg m))
      (equal (dest-peg ~upg) (dest-peg m))
      (equal (dest-pos ~upg) (dest-pos m)))
-->
    (when *toh-trace-p*
      (format t "~&")
      (goal-indent)
      (format t "Subgoal to unblock position ~A on ~A. (~A)" (dest-pos m) (dest-peg m) *macro-cycs*))

    (spew t (unblock-position-goal :operator m
                                   :source-peg (source-peg m)
                                   :dest-peg (dest-peg m)
                                   :dest-pos (dest-pos m))
            (* *weight* *spew-rate*))
)

(p@ rh-executive propose-chunked-unblock-disk-goal ((p puzzle)
                                                    (ep end-puzzle)
                                                    (m move-mi)
                                                    (sop selected-operator))
    (equal (state m) p)
    (equal (operator sop) m)
    (blocked-disk-p (contents p) (disk m))
    (not-solved-p p ep)
    (> (largest-out-of-place-disk (contents p) (contents ep)) 3)
    (= (disk m) 3)
    (on-top-of-p (contents p) 2 3)
    (on-top-of-p (contents p) 1 2)
    (top-disk-p (contents p) 1)
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~d disk))
      (occupied-position-p (contents p) (dest-peg m) (dest-pos m))
      (equal (peg-of (contents p) (disk ~d)) (dest-peg m))
      (equal (position-of (contents p) (disk ~d)) (dest-pos m))
      (> (disk ~d) (largest-source-blocking-disk (contents p) (disk m))))
    (*no ((~udg unblock-disk-goal))
      (equal (operator ~udg) m)
      (equal (disk ~udg) (disk m))
      (equal (source-peg ~udg) (source-peg m))
      (equal (dest-peg ~udg) (dest-peg m))
      (equal (dest-pos ~udg) (dest-pos m)))
-->
    (when *toh-trace-p*
      (format t "~&")
      (goal-indent)
      (format t "CHUNKED Subgoal to unblock DISK~A on ~A. (~A)" (disk m) (source-peg m) *macro-cycs*))

    (spew t (chunked-unblock-disk-goal :operator m
                                       :disk (disk m)
                                       :source-peg (source-peg m)
                                       :dest-peg (dest-peg m)
                                       :dest-pos (dest-pos m))
            (* *weight* *spew-rate*))
)

(p@ rh-executive propose-chunked-unblock-position-goal ((p puzzle)
                                                        (ep end-puzzle)
                                                        (m move-mi)
                                                        (sop selected-operator))
    (equal (state m) p)
    (equal (operator sop) m)
    (not-solved-p p ep)
    (> (largest-out-of-place-disk (contents p) (contents ep)) 2)
    (equal (peg-of (contents p) 2) (dest-peg m))
    (= (position-of (contents p) 2) (dest-pos m))
    (on-top-of-p (contents p) 1 2)
    (top-disk-p (contents p) 1)
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~d disk))
      (blocked-disk-p (contents p) (disk m))
      (equal (peg-of (contents p) (disk ~d)) (dest-peg m))
      (equal (position-of (contents p) (disk ~d)) (dest-pos m))
      (< (disk ~d) (largest-source-blocking-disk (contents p) (disk m))))
    (*no ((~upg unblock-position-goal))
      (equal (operator ~upg) m)
      (equal (source-peg ~upg) (source-peg m))
      (equal (dest-peg ~upg) (dest-peg m))
      (equal (dest-pos ~upg) (dest-pos m)))
-->
    (when *toh-trace-p*
      (format t "~&")
      (goal-indent)
      (format t "CHUNKED Subgoal to unblock position ~A on ~A. (~A)" (dest-pos m) (dest-peg m) *macro-cycs*))

    (spew t (chunked-unblock-position-goal :operator m
                                           :source-peg (source-peg m)
                                           :dest-peg (dest-peg m)
                                           :dest-pos (dest-pos m))
            (* *weight* *spew-rate*))
)

)

(t

(p@ rh-executive propose-unblock-disk-goal ((p puzzle)
                                            (ep end-puzzle)
                                            (m move-mi)
                                            (sop selected-operator))
    (equal (state m) p)
    (equal (operator sop) m)
    (blocked-disk-p (contents p) (disk m))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~d disk))
      (occupied-position-p (contents p) (dest-peg m) (dest-pos m))
      (equal (peg-of (contents p) (disk ~d)) (dest-peg m))
      (equal (position-of (contents p) (disk ~d)) (dest-pos m))
      (> (disk ~d) (largest-source-blocking-disk (contents p) (disk m))))
    (*no ((~udg unblock-disk-goal))
      (equal (operator ~udg) m)
      (equal (disk ~udg) (disk m))
      (equal (source-peg ~udg) (source-peg m))
      (equal (dest-peg ~udg) (dest-peg m))
      (equal (dest-pos ~udg) (dest-pos m)))
-->
    (when *toh-trace-p*
      (format t "~&")
      (goal-indent)
      (format t "Subgoal to unblock DISK~A on ~A. (~A)" (disk m) (source-peg m) *macro-cycs*))

    (spew t (unblock-disk-goal :operator m
                               :disk (disk m)
                               :source-peg (source-peg m)
                               :dest-peg (dest-peg m)
                               :dest-pos (dest-pos m))
            (* *weight* *spew-rate*))
)

(p@ rh-executive propose-unblock-position-goal ((p puzzle)
                                                (ep end-puzzle)
                                                (m move-mi)
                                                (sop selected-operator))
    (equal (state m) p)
    (equal (operator sop) m)
    (occupied-position-p (contents p) (dest-peg m) (dest-pos m))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~d disk))
      (blocked-disk-p (contents p) (disk m))
      (equal (peg-of (contents p) (disk ~d)) (dest-peg m))
      (equal (position-of (contents p) (disk ~d)) (dest-pos m))
      (< (disk ~d) (largest-source-blocking-disk (contents p) (disk m))))
    (*no ((~upg unblock-position-goal))
      (equal (operator ~upg) m)
      (equal (source-peg ~upg) (source-peg m))
      (equal (dest-peg ~upg) (dest-peg m))
      (equal (dest-pos ~upg) (dest-pos m)))
-->
    (when *toh-trace-p*
      (format t "~&")
      (goal-indent)
      (format t "Subgoal to unblock position ~A on ~A. (~A)" (dest-pos m) (dest-peg m) *macro-cycs*))

    (spew t (unblock-position-goal :operator m
                                   :source-peg (source-peg m)
                                   :dest-peg (dest-peg m)
                                   :dest-pos (dest-pos m))
            (* *weight* *spew-rate*))
)

))


;;

;;;^^^
(p@ rh-executive suppress-superfluous-unblock-disk-goal ((g1 unblock-disk-goal)
                                                         (g2 unblock-disk-goal))
    (equal (disk g1) (disk g2))
    (equal (source-peg g1) (source-peg g2))
    (equal (dest-peg g1) (dest-peg g2))
    (equal (dest-pos g1) (dest-pos g2))
    (more-recent-goal-p g1 g2)
-->
    (when *toh-trace-p*
      (format t "~&")
      (goal-indent)
      (format t "Suppress superfluous unblock-disk-goal. (~A)" *macro-cycs*))

    (spew t g2 (- (* *weight* *spew-rate*)))
)

;;;^^^
(p@ rh-executive suppress-superfluous-unblock-position-goal ((g1 unblock-position-goal)
                                                             (g2 unblock-position-goal))
    (equal (source-peg g1) (source-peg g2))
    (equal (dest-peg g1) (dest-peg g2))
    (equal (dest-pos g1) (dest-pos g2))
    (more-recent-goal-p g1 g2)
-->
    (when *toh-trace-p*
      (format t "~&")
      (goal-indent)
      (format t "Suppress superfluous unblock-position-goal. (~A)" *macro-cycs*))

    (spew t g2 (- (* *weight* *spew-rate*)))
)


;; Propose goal-derived, indirect moves.

(cond

(*top-goal-moves-only*

(p@ rh-executive propose-unblock-disk-move-top-only ((p puzzle)
                                                     (g unblock-disk-goal)
                                                     (d disk))
    (blocked-disk-p (contents p) (disk g))
    (on-top-of-p (contents p) (disk d) (disk g))
    (*no ((~g goal))
      (more-recent-goal-p ~g g))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~im indirect-move))
      (equal (goal ~im) g)
      (equal (state ~im) p)
      (equal (disk ~im) (disk d))
      (equal (source-peg ~im) (source-peg g))
      (equal (dest-peg ~im) (buffer-peg g))
      (equal (dest-pos ~im) (buffer-peg-position (contents p) (buffer-peg g) (disk d))))
-->
    (spew t (indirect-move :goal g
                           :state p
                           :disk (disk d)
                           :source-peg (source-peg g)
                           :dest-peg (buffer-peg g)
                           :dest-pos (buffer-peg-position (contents p) (buffer-peg g) (disk d)))
            (* *weight* *spew-rate*))
)

(p@ rh-executive propose-unblock-position-move-top-only ((p puzzle)
                                                         (g unblock-position-goal)
                                                         (d disk))
    (occupied-position-p (contents p) (dest-peg g) (dest-pos g))
    (equal (peg-of (contents p) (disk d)) (dest-peg g))
    (equal (position-of (contents p) (disk d)) (dest-pos g))
    (*no ((~g goal))
      (more-recent-goal-p ~g g))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~im indirect-move))
      (equal (goal ~im) g)
      (equal (state ~im) p)
      (equal (disk ~im) (disk d))
      (equal (source-peg ~im) (dest-peg g))
      (equal (dest-peg ~im) (buffer-peg g))
      (equal (dest-pos ~im) (buffer-peg-position (contents p) (buffer-peg g) (disk d))))
-->
    (spew t (indirect-move :goal g
                           :state p
                           :disk (disk d)
                           :source-peg (dest-peg g)
                           :dest-peg (buffer-peg g)
                           :dest-pos (buffer-peg-position (contents p) (buffer-peg g) (disk d)))
            (* *weight* *spew-rate*))
)

)

(t

(p@ rh-executive propose-unblock-disk-move-all ((p puzzle)
                                                (g unblock-disk-goal)
                                                (d disk))
    (blocked-disk-p (contents p) (disk g))
    (on-top-of-p (contents p) (disk d) (disk g))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~im indirect-move))
      (equal (goal ~im) g)
      (equal (state ~im) p)
      (equal (disk ~im) (disk d))
      (equal (source-peg ~im) (source-peg g))
      (equal (dest-peg ~im) (buffer-peg g))
      (equal (dest-pos ~im) (buffer-peg-position (contents p) (buffer-peg g) (disk d))))
-->
    (spew t (indirect-move :goal g
                           :state p
                           :disk (disk d)
                           :source-peg (source-peg g)
                           :dest-peg (buffer-peg g)
                           :dest-pos (buffer-peg-position (contents p) (buffer-peg g) (disk d)))
            (* *weight* *spew-rate*))
)

(p@ rh-executive propose-unblock-position-move-all ((p puzzle)
                                                    (g unblock-position-goal)
                                                    (d disk))
    (occupied-position-p (contents p) (dest-peg g) (dest-pos g))
    (equal (peg-of (contents p) (disk d)) (dest-peg g))
    (equal (position-of (contents p) (disk d)) (dest-pos g))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~im indirect-move))
      (equal (goal ~im) g)
      (equal (state ~im) p)
      (equal (disk ~im) (disk d))
      (equal (source-peg ~im) (dest-peg g))
      (equal (dest-peg ~im) (buffer-peg g))
      (equal (dest-pos ~im) (buffer-peg-position (contents p) (buffer-peg g) (disk d))))
-->
    (spew t (indirect-move :goal g
                           :state p
                           :disk (disk d)
                           :source-peg (dest-peg g)
                           :dest-peg (buffer-peg g)
                           :dest-pos (buffer-peg-position (contents p) (buffer-peg g) (disk d)))
            (* *weight* *spew-rate*))
)

))

(when *chunked-tower*

(p@ rh-executive propose-unblock-disk-move-top-only-3-1 ((p puzzle)
                                                         (g chunked-unblock-disk-goal))
    (= (disk g) 3)
    (equal (peg-of (contents p) 3) (source-peg g))
    (on-top-of-p (contents p) 2 3)
    (on-top-of-p (contents p) 1 2)
    (top-disk-p (contents p) 1)
    (*no ((~g goal))
      (more-recent-goal-p ~g g))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~im indirect-move))
      (equal (goal ~im) g)
      (equal (state ~im) p)
      (equal (disk ~im) 1)
      (equal (source-peg ~im) (source-peg g))
      (equal (dest-peg ~im) (dest-peg g))
      (equal (dest-pos ~im) (top-empty-position (contents p) (dest-peg g))))
-->
    (spew t (chunked-indirect-move :goal g
                                   :state p
                                   :disk 1
                                   :source-peg (source-peg g)
                                   :dest-peg (dest-peg g)
                                   :dest-pos (top-empty-position (contents p) (dest-peg g)))
            (* *weight* *spew-rate*))
)

(p@ rh-executive propose-unblock-disk-move-top-only-3-2 ((p puzzle)
                                                         (g chunked-unblock-disk-goal))
    (= (disk g) 3)
    (equal (peg-of (contents p) 3) (source-peg g))
    (on-top-of-p (contents p) 2 3)
    (equal (peg-of (contents p) 1) (dest-peg g))
    (top-disk-p (contents p) 1)
    (*no ((~g goal))
      (more-recent-goal-p ~g g))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~im indirect-move))
      (equal (goal ~im) g)
      (equal (state ~im) p)
      (equal (disk ~im) 2)
      (equal (source-peg ~im) (source-peg g))
      (equal (dest-peg ~im) (buffer-peg g))
      (equal (dest-pos ~im) (top-empty-position (contents p) (buffer-peg g))))
-->
    (spew t (chunked-indirect-move :goal g
                                   :state p
                                   :disk 2
                                   :source-peg (source-peg g)
                                   :dest-peg (buffer-peg g)
                                   :dest-pos (top-empty-position (contents p) (buffer-peg g)))
            (* *weight* *spew-rate*))
)

(p@ rh-executive propose-unblock-disk-move-top-only-3-3 ((p puzzle)
                                                         (g chunked-unblock-disk-goal))
    (= (disk g) 3)
    (equal (peg-of (contents p) 3) (source-peg g))
    (equal (peg-of (contents p) 2) (buffer-peg g))
    (top-disk-p (contents p) 2)
    (equal (peg-of (contents p) 1) (dest-peg g))
    (top-disk-p (contents p) 1)
    (*no ((~g goal))
      (more-recent-goal-p ~g g))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~im indirect-move))
      (equal (goal ~im) g)
      (equal (state ~im) p)
      (equal (disk ~im) 1)
      (equal (source-peg ~im) (dest-peg g))
      (equal (dest-peg ~im) (buffer-peg g))
      (equal (dest-pos ~im) (top-empty-position (contents p) (buffer-peg g))))
-->
    (spew t (chunked-indirect-move :goal g
                                   :state p
                                   :disk 1
                                   :source-peg (dest-peg g)
                                   :dest-peg (buffer-peg g)
                                   :dest-pos (top-empty-position (contents p) (buffer-peg g)))
            (* *weight* *spew-rate*))
)

(p@ rh-executive propose-unblock-disk-move-top-only-3-4 ((p puzzle)
                                                         (g chunked-unblock-disk-goal))
    (= (disk g) 3)
    (equal (peg-of (contents p) 3) (source-peg g))
    (equal (peg-of (contents p) 2) (buffer-peg g))
    (on-top-of-p (contents p) 1 2)
    (top-disk-p (contents p) 1)
    (*no ((~g goal))
      (more-recent-goal-p ~g g))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~im indirect-move))
      (equal (goal ~im) g)
      (equal (state ~im) p)
      (equal (disk ~im) 3)
      (equal (source-peg ~im) (source-peg g))
      (equal (dest-peg ~im) (dest-peg g))
      (equal (dest-pos ~im) (top-empty-position (contents p) (dest-peg g))))
-->
    (spew t (chunked-indirect-move :goal g
                                   :state p
                                   :disk 3
                                   :source-peg (source-peg g)
                                   :dest-peg (dest-peg g)
                                   :dest-pos (top-empty-position (contents p) (dest-peg g)))
            (* *weight* *spew-rate*))
)

(p@ rh-executive propose-unblock-disk-move-top-only-3-5 ((p puzzle)
                                                         (g chunked-unblock-disk-goal))
    (= (disk g) 3)
    (equal (peg-of (contents p) 3) (dest-peg g))
    (equal (peg-of (contents p) 2) (buffer-peg g))
    (on-top-of-p (contents p) 1 2)
    (top-disk-p (contents p) 1)
    (*no ((~g goal))
      (more-recent-goal-p ~g g))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~im indirect-move))
      (equal (goal ~im) g)
      (equal (state ~im) p)
      (equal (disk ~im) 1)
      (equal (source-peg ~im) (buffer-peg g))
      (equal (dest-peg ~im) (source-peg g))
      (equal (dest-pos ~im) (top-empty-position (contents p) (source-peg g))))
-->
    (spew t (chunked-indirect-move :goal g
                                   :state p
                                   :disk 1
                                   :source-peg (buffer-peg g)
                                   :dest-peg (source-peg g)
                                   :dest-pos (top-empty-position (contents p) (source-peg g)))
            (* *weight* *spew-rate*))
)

(p@ rh-executive propose-unblock-disk-move-top-only-3-6 ((p puzzle)
                                                         (g chunked-unblock-disk-goal))
    (= (disk g) 3)
    (equal (peg-of (contents p) 3) (dest-peg g))
    (equal (peg-of (contents p) 2) (buffer-peg g))
    (top-disk-p (contents p) 2)
    (equal (peg-of (contents p) 1) (source-peg g))
    (top-disk-p (contents p) 1)
    (*no ((~g goal))
      (more-recent-goal-p ~g g))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~im indirect-move))
      (equal (goal ~im) g)
      (equal (state ~im) p)
      (equal (disk ~im) 2)
      (equal (source-peg ~im) (buffer-peg g))
      (equal (dest-peg ~im) (dest-peg g))
      (equal (dest-pos ~im) (top-empty-position (contents p) (dest-peg g))))
-->
    (spew t (chunked-indirect-move :goal g
                                   :state p
                                   :disk 2
                                   :source-peg (buffer-peg g)
                                   :dest-peg (dest-peg g)
                                   :dest-pos (top-empty-position (contents p) (dest-peg g)))
            (* *weight* *spew-rate*))
)

(p@ rh-executive propose-unblock-disk-move-top-only-3-7 ((p puzzle)
                                                         (g chunked-unblock-disk-goal))
    (= (disk g) 3)
    (equal (peg-of (contents p) 3) (dest-peg g))
    (on-top-of-p (contents p) 2 3)
    (top-disk-p (contents p) 2)
    (equal (peg-of (contents p) 1) (source-peg g))
    (top-disk-p (contents p) 1)
    (*no ((~g goal))
      (more-recent-goal-p ~g g))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~im indirect-move))
      (equal (goal ~im) g)
      (equal (state ~im) p)
      (equal (disk ~im) 1)
      (equal (source-peg ~im) (source-peg g))
      (equal (dest-peg ~im) (dest-peg g))
      (equal (dest-pos ~im) (top-empty-position (contents p) (dest-peg g))))
-->
    (spew t (chunked-indirect-move :goal g
                                   :state p
                                   :disk 1
                                   :source-peg (source-peg g)
                                   :dest-peg (dest-peg g)
                                   :dest-pos (top-empty-position (contents p) (dest-peg g)))
            (* *weight* *spew-rate*))
)

(p@ rh-executive propose-unblock-position-move-top-only-2-1 ((p puzzle)
                                                             (g chunked-unblock-position-goal)
                                                             (d disk))
    (equal (peg-of (contents p) 2) (dest-peg g))
    (= (position-of (contents p) 2) (dest-pos g))
    (on-top-of-p (contents p) 1 2)
    (top-disk-p (contents p) 1)
    (*no ((~g goal))
      (more-recent-goal-p ~g g))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~im indirect-move))
      (equal (goal ~im) g)
      (equal (state ~im) p)
      (equal (disk ~im) 1)
      (equal (source-peg ~im) (dest-peg g))
      (equal (dest-peg ~im) (source-peg g))
      (equal (dest-pos ~im) (top-empty-position (contents p) (source-peg g))))
-->
    (spew t (chunked-indirect-move :goal g
                                   :state p
                                   :disk 1
                                   :source-peg (dest-peg g)
                                   :dest-peg (source-peg g)
                                   :dest-pos (top-empty-position (contents p) (source-peg g)))
            (* *weight* *spew-rate*))
)

(p@ rh-executive propose-unblock-position-move-top-only-2-2 ((p puzzle)
                                                             (g chunked-unblock-position-goal)
                                                             (d disk))
    (equal (peg-of (contents p) 2) (dest-peg g))
    (top-disk-p (contents p) 2)
    (equal (peg-of (contents p) 1) (source-peg g))
    (top-disk-p (contents p) 1)
    (*no ((~g goal))
      (more-recent-goal-p ~g g))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~im indirect-move))
      (equal (goal ~im) g)
      (equal (state ~im) p)
      (equal (disk ~im) 2)
      (equal (source-peg ~im) (dest-peg g))
      (equal (dest-peg ~im) (buffer-peg g))
      (equal (dest-pos ~im) (top-empty-position (contents p) (buffer-peg g))))
-->
    (spew t (chunked-indirect-move :goal g
                                   :state p
                                   :disk 2
                                   :source-peg (dest-peg g)
                                   :dest-peg (buffer-peg g)
                                   :dest-pos (top-empty-position (contents p) (buffer-peg g)))
            (* *weight* *spew-rate*))
)

(p@ rh-executive propose-unblock-position-move-top-only-2-3 ((p puzzle)
                                                             (g chunked-unblock-position-goal)
                                                             (d disk))
    (equal (peg-of (contents p) 2) (buffer-peg g))
    (top-disk-p (contents p) 2)
    (equal (peg-of (contents p) 1) (source-peg g))
    (top-disk-p (contents p) 1)
    (*no ((~g goal))
      (more-recent-goal-p ~g g))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~im indirect-move))
      (equal (goal ~im) g)
      (equal (state ~im) p)
      (equal (disk ~im) 1)
      (equal (source-peg ~im) (source-peg g))
      (equal (dest-peg ~im) (buffer-peg g))
      (equal (dest-pos ~im) (top-empty-position (contents p) (buffer-peg g))))
-->
    (spew t (chunked-indirect-move :goal g
                                   :state p
                                   :disk 1
                                   :source-peg (source-peg g)
                                   :dest-peg (buffer-peg g)
                                   :dest-pos (top-empty-position (contents p) (buffer-peg g)))
            (* *weight* *spew-rate*))
)

)




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; (6) The LH-Spatial Center.
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;
;;; General Executive model productions.
;;;


;; Suppress old states.

(case *suppress-old-states*

(all

(p@ lh-spatial suppress-old-state ((news state)
                                   (olds state))
    (more-recent-state-p news olds)
-->
    (spew t olds (- (* *weight* *spew-rate*)))
)

)

;;;^^^
(non-goal

(p@ lh-spatial suppress-non-goal-state ((news state)
                                        (olds state))
    (more-recent-state-p news olds)
    (*no ((~g goal))
      (equal (state (operator ~g)) olds))
-->
    (spew t olds (- (* *weight* *spew-rate*)))
)

))


;;;
;;; TOH model productions.
;;;


;; Perform moves.

(p@ lh-spatial perform-move ((sop selected-operator)
                             (m move-mi)
                             (p puzzle))
    (equal (operator sop) m)
    (equal (state m) p)

    ;;^^ Used to be a call to DIRECT-MOVE-P (which can now be deleted?)
    (legal-operator-p (contents p) m)

    (*no ((~p puzzle))
      (more-recent-state-p ~p p))

    ;;^^ Newly commented out.
#|
    (*no ((~p puzzle))
      (contents-equal (contents ~p) (perform-operator m p)))
|#
-->
    (when *toh-trace-p*
      (format t "~&")
      (goal-indent)
      (format t "Move DISK~A from ~A to ~A. (~A)" (disk m) (source-peg m) (dest-peg m) *macro-cycs*))

    (when *record-moves-p*
      (setq *move-record* (nconc *move-record* (list *macro-cycs*))))

    (when *constrained-p*
      (let* ((move (first *constrained-moves*))
             (disk (second move))
             (dest-peg (third move))
             (error-p (not (and (= disk (disk m))
                                (eq dest-peg (dest-peg m))))))
        (case (fourth move)
          (0
           (incf *tot0*)
           (when error-p
             (incf *err0*)))
          (1
           (incf *tot1*)
           (when error-p
             (incf *err1*)))
          (t
           (incf *tot2*)
           (when error-p
             (incf *err2+*))))))

    (spew t (puzzle :contents (perform-operator m p))
            (* *weight* *spew-rate*))
)




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; (7) The RH-Spatial Center.
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;
;;; General Executive Model productions.
;;;


;; Suppress operators if...

;;; ...they are not selected.
(p@ rh-spatial suppress-unselected-operator ((sop selected-operator)
                                             (op1 operator)
                                             (op2 operator))
    (equal (operator sop) op1)
    (not-equal op1 op2)
    (equal (state op1) (state op2))
-->
    (spew t op2 (- (* *weight* *spew-rate*)))
)

;;; ...they are selected and performed successfully.
(p@ rh-spatial suppress-performed-selected-operator ((sop selected-operator)
                                                     (op operator)
                                                     (bs state)
                                                     (as state))
    (equal (operator sop) op)
    (equal (state op) bs)

    ;;^^
    (more-recent-state-p as bs)

    (contents-equal (perform-operator op bs) (contents as))
-->
    (spew t op (- (* *weight* *spew-rate*)))

    (when *constrained-p*
      (pop *constrained-moves*))
)



;;;^^^
;;; ...they cannot be performed because they are illegal.
(p@ lh-executive suppress-preempted-selected-operator-marker ((sop selected-operator)
                                                              (op operator)
                                                              (s state))
    (equal (operator sop) op)
    (equal (state op) s)
    (*whole (not (legal-operator-p (contents s) op)))
-->
    (spew t op (- (* *weight* *spew-rate*)))
)

;;; ...they cannot be performed, causing an impasse (which leads to a goal
;;; to resolve the impasse).
(p@ rh-spatial suppress-preempted-selected-operator ((g goal)
                                                     (sop selected-operator)
                                                     (op operator))
    (equals (operator g) (operator sop) op)
-->
    (spew t op (- (* *weight* *spew-rate*)))
)



;;;
;;; TOH model productions.
;;;


;; Propose perceptually-triggered direct moves.

;;; This production proposes direct moves that place out-of-place disks at
;;; their peg position in the ending configuration without regard to
;;; preconditions.
(p@ rh-spatial propose-ending-move ((g solve-puzzle-goal)
                                    (p puzzle)
                                    (ep end-puzzle)
                                    (d disk))
    (id g)
    (not-solved-p p ep)
    (not-equal (peg-of (contents p) (disk d)) (peg-of (contents ep) (disk d)))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~dm direct-move))
      (equal (state ~dm) p)
      (equal (disk ~dm) (disk d))
      (equal (source-peg ~dm) (peg-of (contents p) (disk d)))
      (equal (dest-peg ~dm) (peg-of (contents ep) (disk d)))
      (equal (dest-pos ~dm) (position-of (contents ep) (disk d))))
-->
    (spew t (direct-move :state p
                         :disk (disk d)
                         :source-peg (peg-of (contents p) (disk d))
                         :dest-peg (peg-of (contents ep) (disk d))
                         :dest-pos (position-of (contents ep) (disk d)))
            (* *weight* *spew-rate*))
)

(when *propose-top-moves*

(p@ rh-spatial propose-top-move ((g solve-puzzle-goal)
                                 (p puzzle)
                                 (ep end-puzzle)
                                 (d disk)
                                 (dp peg))
    (id g)
    (not-solved-p p ep)
    (top-disk-p (contents p) (disk d))
    (not-equal (peg-of (contents p) (disk d)) (peg dp))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~dm direct-move))
      (equal (state ~dm) p)
      (equal (disk ~dm) (disk d))
      (equal (source-peg ~dm) (peg-of (contents p) (disk d)))
      (equal (dest-peg ~dm) (peg dp))
      (equal (dest-pos ~dm) (top-empty-position (contents p) (peg dp))))
-->
    (spew t (direct-move :state p
                         :disk (disk d)
                         :source-peg (peg-of (contents p) (disk d))
                         :dest-peg (peg dp)
                         :dest-pos (top-empty-position (contents p) (peg dp)))
            (* 0.5 *weight* *spew-rate*))
)

)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; (8) Support Code.
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;
;;;
;;;


;;

(defmacro sim (&rest args)
  `(impl-sim ,@args))

(defun impl-sim (disks start end &key (max-macro-cycs *max-macro-cycs*))
  (reset)
  (when *record-moves-p*
    (setq *move-record* ()))
  (spew t (solve-puzzle-goal) *weight*)
  (do ((n 1 (1+ n)))
      ((> n disks))
    (spew t (disk :disk n)
            *weight*))
  (spew t (peg :peg 'peg1)
          *weight*)
  (spew t (peg :peg 'peg2)
          *weight*)
  (spew t (peg :peg 'peg3)
          *weight*)
  (spew t (puzzle :contents (make-instance 'configuration
                                :disks disks
                                :peg1 (first start)
                                :peg2 (second start)
                                :peg3 (third start)))
          *weight*)
  (spew t (end-puzzle :contents (make-instance 'configuration
                                  :disks disks
                                :peg1 (first end)
                                :peg2 (second end)
                                :peg3 (third end)))
          *weight*)
  (run max-macro-cycs))


;;

(defun summ ()
  (when *record-moves-p*
    (format t "~&~%NUM~ADELTA~ATOTAL" #\tab #\tab)
    (do* ((num 1 (1+ num))
          (prev-cycs 0 (first cycs))
          (cycs *move-record* (rest cycs)))
         ((null cycs))
      (let* ((first-cycs (first cycs))
             (delta-cycs (- first-cycs prev-cycs)))
      (format t "~%~D~A~D~A~D" num #\tab delta-cycs #\tab first-cycs))))
  (format t "~%")
  (history@ (lh-executive rh-executive lh-spatial rh-spatial)
            :combination avg
            :measure act)
  (format t "~&~%")
#|
  (dm base-state
      operator
      preference
      selected-operator
      base-goal)
|#
  )


;;

(defun test3 ()
  (reset)
  (sim 3 '((3 2 1) () ()     )
         '(()      () (3 2 1)))
  (summ)
  (values))

(defun test4 ()
  (reset)
  (sim 4 '((4 3 2 1) () ()       )
         '(()        () (4 3 2 1)))
  (summ)
  (values))

(defun test5 ()
  (reset)
  (sim 5 '((5 4 3 2 1) () ()         )
         '(()          () (5 4 3 2 1)))
  (summ)
  (values))


;; Test script that runs the model under all possible variable settings on
;; the standard tower-to-tower problems.

#|
(let ((model-file-path (choose-file-dialog))
      (*toh-trace-p* nil)
      (*max-macro-cycs* 2000))
  (dolist (*preference-scheme* '(absolute relative))
    (dolist (*accrual-scheme* '(multiplicative additive))
      (dolist (*propose-top-moves* '(t nil))
        (dolist (*top-goal-moves-only* '(t nil))

          ;;^^
          (dolist (*suppress-old-states* '(non-goal all nil))

            (dolist (*reward-non-reversals* (t nil))
              (let ((*standard-output* (make-broadcast-stream)))
                (load model-file-path))
              (format t "~2%*preference-scheme*: ~A" *preference-scheme*)
              (format t "~%*accrual-scheme*: ~A" *accrual-scheme*)
              (format t "~%*propose-top-moves*: ~A" *propose-top-moves*)
              (format t "~%*top-goal-moves-only*: ~A" *top-goal-moves-only*)
              (format t "~%*suppress-old-states*: ~A" *suppress-old-states*)
              (format t "~%*reward-non-reversals*: ~A" *reward-non-reversals*)
              (format t "~2%")
              (test3)
              (test4)
              (test5)
              )  ; *reward-non-reversals*
            )    ; *suppress-old-states*
          )      ; *top-goal-moves-only*
        )        ; *propose-top-moves*
      )          ; *accrual-scheme*
    )            ; *preference-scheme*
  )
|#