(in-package "CL-USER")


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;;        name:   tol
;;;;     version:   1.2
;;;;        date:   8.1.2001
;;;;
;;;;      author:   sashank varma
;;;;       email:   sashank@vuse.vanderbilt.edu
;;;; organization:  center for cognitive brain imaging (ccbi)
;;;;                carnegie mellon university
;;;;
;;;; bugs:
;;;;
;;;; notes:
;;;;
;;;;   6.2001 sv: (v0.2.2) should i split preferences into separate unary
;;;;                and binary dm classes?  should i eliminate preferences
;;;;                altogether and have preference productions heuristically
;;;;                increment and decrement a "goodness" measure for each
;;;;                move?
;;;;
;;;;   7.2001 sv: (v0.4.1) two of the productions of the tol-specific portion
;;;;                of the model, PROPOSE-UNBLOCK-POCKET-GOAL and PERFORM-
;;;;                MOVE, could be generalized and moved into the default
;;;;                portion of the model if an additional mechanism was
;;;;                available in 4caps.  the rhs actions of these productions
;;;;                activate new tol-specific dmes (UNBLOCK-POCKET-GOALs,
;;;;                UNBLOCK-BALL-GOALs, and PUZZLEs).  but if these
;;;;                productions were moved into the default portion of the
;;;;                model, they would create default classes: GOALs and
;;;;                STATEs.  thus, need a mechanism for class specializations
;;;;                to migrate from the condition to the action sides of
;;;;                productions.
;;;;
;;;;   7.2001 sv: (v0.4.2) if the above problem is solved, it will probably
;;;;                also solve a symmetric problem that has cropped up.
;;;;                currently, the defaultPREFERENCE and PREFERRED-OPERATOR
;;;;                classes are not specialized by the tol model (i.e., into
;;;;                MOVE-PREFERNECE and PREFERRED- MOVE) because there is
;;;;                no way for default productions to know to create these
;;;;                specific classes with a 'migration' mechanism.
;;;;
;;;; history:
;;;;
;;;;   3.2001 sv: (v0.1.1) first version complete.  solves problems that
;;;;                can be done "directly", i.e., without goals.  this is
;;;;                done solely using the spatial component.
;;;;
;;;;   5.2001 sv: (v0.1.2) eliminated start-puzzle element as it was
;;;;                superfluous.  working on solving problems that require
;;;;                indirect moves, and thus the invocation of the executive
;;;;                component.
;;;;
;;;;   5.2001 sv: (v0.1.3) solves linear problems, whether they require
;;;;                direct or indirect moves.  doesn't solve nonlinear
;;;;                problems yet.  also, doesn't clean up after itself by
;;;;                suppressing satisfied goals.
;;;;
;;;;   5.2001 sv: (v0.2.1) major reworking of the code to include a Soar-like
;;;;                deliberation cycle.  also began abstracting out the
;;;;                general problem solving elements of the code from the
;;;;                TOL-specific elements.
;;;;
;;;;   6.2001 sv: (v0.2.2) now handles some indirection.  when a direct move
;;;;                cannot be performed because its preconditions are unmet,
;;;;                now establishes goals to meet them by either unblocking
;;;;                the ball to be moved or the pocket to where it is to be
;;;;                moved.  these goals generate moves which are ordered via
;;;;                new preference-asserting productions.
;;;;
;;;;  6.2001 sv: (v0.3.1) proposes using a buffer while trying to unblock a
;;;;               a pocket in some general situations, and prefers this
;;;;               proposed move when appropriate.
;;;;
;;;;  6.2001 sv: (v0.3.2) now handles nearly all of the problems of the old
;;;;               and new studied.
;;;;
;;;;  6.2001 sv: (v0.3.3) divided the executive and spatial components into
;;;;               left and right hemispheres, and made an initial
;;;;               distribution of productions and specializations over the
;;;;               four components.  set capacities for the components in
;;;;               ways that provide a reasonable fit to the behavioral and
;;;;               fmri data -- see 'tolfit2.doc' and 'tolfit2.xls'.
;;;;
;;;;  7.2001 sv: (v0.3.4) tackled the outstanding problems.  fixed bug in
;;;;               more-reversed-p to allow the solution of old problem
;;;;               2-->19.  added the production immediately-suppress-
;;;;               redundant-selection, which improved the general operator
;;;;               selection logic, albeit in a kludgy way, to solve old
;;;;               problem 7-->1.  generalized the production lookahead-to-
;;;;               prefer-consistent-with-end somewhat so that it now handles
;;;;               the old problem 1-->23. bifurated the production lookahead-
;;;;               to-prefer-consistent-with-end and redefined the generic
;;;;               function predicate on which it is based to properly handle
;;;;               the old problem 24-->2.  finally, added the production
;;;;               propose-blocking-move-when-canntt-unblock to properly
;;;;               handle old problem 11-->18 and new problems 3-->24, and
;;;;               17-->15.  all that remains is new problem 33->3.
;;;;
;;;;  7.2001 sv: (v0.3.5) after some investigation, shifted specialization
;;;;               for the PREFERENCE dm class from the RH-EXECUTIVE component
;;;;               to the LH-EXECUTIVE component.  re-adjusted the capacities
;;;;               of the various components accordingly.  the model new
;;;;               provides more reasonable cu predictions (i.e., strictly
;;;;               monotonically increasing) for the LH-EXECUTIVE component
;;;;               on the problems of the new study.
;;;;
;;;;  7.2001 sv: (v0.4.1) extensive generalization and re-organization of the
;;;;               model.  first, effectively split the model into two.  the
;;;;               first portion is a general model of executive function.
;;;;               it includes default components, dm classes, productions,
;;;;               and specializations.  the second portion is a tol model.
;;;;               it relies, through inheritance, on the constituents of the
;;;;               default executive model.  it complements these with tol-
;;;;               specific logic.
;;;;
;;;;  7.2001 sv: (v0.4.2) pruned the backing layers of the tol model.  it is
;;;;               composed of three levels.  the first are first-class
;;;;               constituents of 4caps model: components, dm classes, and
;;;;               productions.  the second is a set of methods defined on
;;;;               the dm classes and called by the productions.  they are the
;;;;               vocabulary of the model, but their implementations are
;;;;               beyond (or rather, beneath) the scope of the model.  the
;;;;               third layer are the general lisp functions that implement
;;;;               the intermediate, vocabulary layer.  they are just
;;;;               engineering with no psychological content.  with this
;;;;               clean-up, the default portion consists of 216 lines of
;;;;               code, the tol portion of 708.
;;;;
;;;;  8.2001 sv: (v1.0) more finely discriminated functionality between the
;;;;               the general executive portion and the tol-specific portion.
;;;;               chose components capacities and specializations that
;;;;               resulted in a nice fit to the "old" (reichle-collected)
;;;;               behavioral and fmri data.  main change here was to make
;;;;               shift responsibility for indirect (i.e.m, goal-generated)
;;;;               moves from the rh-spatial component to the rh-executive
;;;;               component, which is the seat of the goals themselves.
;;;;               this left the rh-spatial component with responsibility for
;;;;               direct moves.
;;;;
;;;; 11.2.2004: Standardize General Executive model productions across the
;;;;            TOL, mental rotation, driving, and TOH models.  Renamed the
;;;;            TOP-LEVEL-GOAL class to TASK-GOAL.
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;





;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; default initialization.
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



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


;; parameter setting.

(set-default-dme-thresh 0.1)



;;;
;;; global variables.
;;;


;; spewing parameters.

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




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; default dm classes.
;;;;
;;;; the notation 'A:  B' means that A is a superclass (or B is a subclass of
;;;; A).
;;;;
;;;; BALL
;;;;
;;;; PEG
;;;;
;;;; BASE-STATE:          STATE
;;;;                      END-STATE
;;;;
;;;; OPERATOR
;;;;
;;;; PREFERENCE
;;;;
;;;; PREFERRED-OPERATOR
;;;;
;;;; BASE-GOAL:           TASK-GOAL
;;;;                      GOAL
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;
;;; base-state dm classes.
;;;


;; 

(defdmclass base-state ()
  contents)


;; 

(defdmclass state (base-state))

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


;;

(defdmclass end-state (base-state))


;; base-state multimethods.

(defmethod contents-equal ((c1 t) (c2 t))
  (error "The CONTENTS-EQUAL multimethod must be specialized for the task."))

(defmethod not-solved-p ((s state) (es end-state))
  (not (contents-equal (contents s) (contents es))))



;;;
;;; the operator dm class.
;;;


;;

(defdmclass operator ()
  state)



;;;
;;; the preference dm class.
;;;


;;

(defdmclass preference ()
  better-operator
  worse-operator)



;;;
;;; the preferred-operator dm class.
;;;


;;

(defdmclass preferred-operator ()
  operator)



;;;
;;; the base-goal dm classes.
;;;


;;

(defdmclass base-goal ())

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


;;

(defdmclass task-goal (base-goal))


;;

(defdmclass goal (base-goal)
  operator)



;;;
;;; mixed dm class multimethods.
;;;


;;

#|
;;;^^^ Commented out this method.  The General Executive model only uses it
;;;^^^ in a production that also calls STEEPER-HILL-CLIMBING-OPERATOR-P,
;;;^^^ which means that its logic can be shifted wlog to that method.  I have
;;;^^^ done this; let's see if it works for this model and for the other
;;;^^^ instantations of the General Executive Model.

(defmethod hill-climbing-operator-p ((op operator) (es end-state))
  (error "The HILL-CLIMBING-OPERATOR-P multimethod must be specialized for the task."))
|#

(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."))


;;

(defmethod perform-operator ((op operator) (s state))
  (error "The PERFORM-OPERATOR multimethod must be specialized for the task."))


;;

(defmethod satisfied-p ((g goal) (s state))
  (error "The SATISFIED-P multimethod must be specialized for the task."))




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; default components
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;
;;; define components.
;;;


;;

(del-comps)


;;

(add-comp support)

(add-comp rh-executive)
(add-comp lh-executive)

(add-comp rh-spatial)
(add-comp lh-spatial)


;;

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

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

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

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




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; default component productions.
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;
;;; The LH-Executive center.
;;;


;; Assert preferences among operators.

;;; When an operator has been proposed, asserts a so-called unary preference,
;;; likely in LH-Executive, that serves as its proxy during contention
;;; scheduling.  It will accumulate activation via the assertion of preferences
;;; by other productions, and if it reaches threshold first, it will be
;;; selected as the preferred-operator.
(p@ lh-executive unary-preference ((s state)
                                   (es end-state)
                                   (op operator))
    (not-solved-p s es)
    (equal s (state op))
    (*no ((~s state))
      (more-recent-state-p ~s s))
    (*no ((~pop preferred-operator))
      (equal (operator ~pop) op))
    (*no ((~pr preference))
      (equal (better-operator ~pr) op)
      (null (worse-operator ~pr)))
-->
    (spew t (preference :better-operator op)
            (* *weight* *spew-rate*))
)

;;; When two operators are being considered and, if applied to the current
;;; state, one would bring us close to the end-state than the other, then
;;; prefer this operator.
;;;
;;; NOTE: Whether this production fires in the a model depends on whether
;;;       contention scheduling is through Soar-like binary selection or
;;;       through connectionist-like activation accrual.
#|
;;; NOTE: THIS PRODUCTION FORMERLY ASSUMED MORE ORDER IN PREFERENCE
;;;       ADJUDICATION AND PREFERRED OPERATOR SELECTION THAN CAN NOW BE
;;;       GUARANTEED.  A NEGATIVE CONDITION HAS BEEN GENERALIZED SUCH THAT
;;;       THE PRODUCTION "TURNS OFF" WHEN *ANY* OPERATOR HAS BEEN DETERMINED
;;;       TO BE PREFERRED FOR THE CURRENT STATE.
|#
(p@ lh-executive binary-preference ((s state)
                                    (es end-state)
                                    (op1 operator)
                                    (op2 operator))
    (not-solved-p s es)
    (equals s (state op1) (state op2))

#|
    ;; Commented out because I think that HILL-CLIMBING-OPERATOR-P can be
    ;; folded into STEEPER-HILL-CLIMBING-OPERATOR-P in this and the other
    ;; instantiations of the General Executive model.
    (hill-climbing-operator-p op1 es)
    (hill-climbing-operator-p op2 es)
|#

    (steeper-climbing-operator-p op1 op2 es)
    (*no ((~s state))
      (more-recent-state-p ~s s))
#|
    ;;^^
    (*no ((~pop preferred-operator))
      (equals (state (operator ~pop)) s))
|#
    (*no ((~pr preference))
      (equal (better-operator ~pr) op1)
      (equal (worse-operator ~pr) op2))
-->
    (spew t (preference :better-operator op1
                        :worse-operator op2)
            (* *weight* *spew-rate*))
)


;; Select preferred operator among contenders given preferences.
;;
;; NOTE: Consider subclassing the PREFERENCE class into separate
;;       UNARY-PREFERENCE and BINARY-PREFERENCE classes.

;;; 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.
;;;
;;; NOTE: This production sneaks in the assumption that binary preferences
;;;       also exist in its second absence test.
(p@ lh-executive select-among-unary-preferences ((s state)
                                                 (es end-state)
                                                 (op operator)
                                                 (pr preference #|0.95|#))
    (not-solved-p s es)
    (equal s (state op))
    (equal (better-operator pr) op)
    (*whole (null (worse-operator pr)))
    (*no ((~s state))
      (more-recent-state-p ~s s))
    (*no ((~pr preference))
      (equal (worse-operator ~pr) op))
    (*no ((~pop preferred-operator))
      (equal (operator ~pop) op))
-->
    (spew t (preferred-operator :operator op)
            (* *weight* *spew-rate*))
)

#|
;;; Select the best operator through consideration of binary preferences.
;;;
;;; NOTE: This production fires in some models, doesn't fire in others, and in
;;;       still others must be completely commented out.  Need to document its
;;;       exact status in each model and, down the road, generalize it to work
;;;       in the same way in each one.
(p@ lh-executive select-among-binary-preferences ((s state)
                                                  (es end-state)
                                                  (op1 operator)
                                                  (op2 operator)
                                                  (pr preference))
    (not-solved-p s es)
    (equal s (state op1))
    (equal (better-operator pr) op1)
    (equal (worse-operator pr) op2)
    (*no ((~s state))
      (more-recent-state-p ~s s))
    (*no ((~pr preference))
      (equal (worse-operator ~pr) op1))
    (*no ((~pr preference))
      (equal (better-operator ~pr) op1)
      (worse-operator ~pr)
      (> (id (worse-operator ~pr)) (id op2)))
    (*no ((~pop preferred-operator))
      (equal (operator ~pop) op1))
-->
    (spew t (preferred-operator :operator op1)
            (* *weight* *spew-rate*))
)
|#

;;; This production is necessary because Soar requires multiple macrocycles
;;; to fully elaborate all preferences, but in early versions of the Executive
;;; model, which used binary preferences rather than graded unary preferences,
;;; only one macrocycle was available for the decision procedure.  However,
;;; this production will likely prove useful for the more general case when
;;; multiple preferred operators arise at the same time (through parallel
;;; processing), and must be reconciled.
;;;
;;; NOTE: For the TOL model, which asserts all binary preferences in a single
;;; macrocycle, this production is necessary to solve the old problem 7-->1.
;;;
;;; NOTE: This production fires in some models, doesn't fire in others, and in
;;;       still others must be completely commented out.  Need to generalize it
;;;       to work in the same way in each one.
(p@ lh-executive suppress-redundant-selection ((s state)
                                               (es end-state)
                                               (op1 operator)
                                               (pr1 preference)
                                               (op2 operator)
                                               (pr2 preference))
    (not-solved-p s es)
    (equals s (state op1) (state op2))
    (< (id op1) (id op2))
    (equal (better-operator pr1) op1)
    (equal (better-operator pr2) op2)
    (*whole (null (worse-operator pr1)))
    (*whole (null (worse-operator pr2)))
    (*no ((~s state))
      (more-recent-state-p ~s s))
    (*no ((~pr preference))
      (equal (worse-operator ~pr) op1))
    (*no ((~pr preference))
      (equal (worse-operator ~pr) op2))
    (*no ((~pop preferred-operator))
      (equal (operator ~pop) op1))
-->
    (spew t (preferred-operator :operator op2)
            (- (* *weight* *spew-rate*)))
)


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

;;; Suppress preferences once an operator has been selected.
#|
;;; NOTE: This production has changed substantiatially since its origination
;;;       in this model.  An absence test is needed because multipler operators
;;;       can be selected as preferred, and this production must be sensitive
;;;       to (i.e., guard against) this boundary condition.  The newer argument
;;;       structure and condition side have been inserted as a comment.  Need
;;;       to test whether the TOL model will run with this form of the
;;;       production.
|#
(p@ lh-executive suppress-preferrence ((pop preferred-operator)
                                       (pr preference)
                                       (s state))
    (equals (state (operator pop)) (state (better-operator pr)) s)
#|
                                      ((pop preferred-operator)
                                       (pr preference))
    (equal (state (operator pop)) (state (better-operator pr)))
    (*no ((~pop preferred-operator))
      (> (id ~pop) (id pop)))
|#
-->
    (spew t pr (- (* *weight* *spew-rate*)))
)


;; Suppress a preferred operator marker...

;;; ...after it is performed.
(p@ lh-executive suppress-preferred-operator-marker ((pop preferred-operator)
                                                     (op operator)
                                                     (bs state)
                                                     (as state))
    (equal (operator pop) op)
    (equal (state op) bs)
    (contents-equal (perform-operator op bs) (contents as))
-->
    (spew t pop (- (* *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-preferred-operator-marker ((g goal)
                                                               (pop preferred-operator)
                                                               (op operator))
    (equals (operator g) (operator pop) op)
-->
    (spew t pop (- (* *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-preferred-operator-marker ((pop1 preferred-operator)
                                                                        (pop2 preferred-operator))
   (not-equal pop1 pop2)
   (*no ((~pop preferred-operator))
     (> (id (operator ~pop)) (id (operator pop1))))
-->
    (spew t pop2 (- (* *weight* *spew-rate*)))
)



;;;
;;; The RH-Executive center.
;;;


;;

;;; 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*)))
)



;;;
;;; The LH-Spatial center.
;;;



;;;
;;; The RH-Spatial center.
;;;


;; Suppress operators if...

;;; ...they are not selected.
#|
;;; NOTE: In the Mental Rotation model, where unary preferences and activation
;;;       dynamics are used to select operators, it is often the case that
;;;       multiple operators can emerge as preferred, and therefore two
;;;       absence tests need to be inserted so that this production behaves
;;;       properly when this occurs.  Must test whether this breaks the TOL
;;;       model and, if it does, must generalize the production accordingly.
|#
(p@ rh-spatial suppress-unpreferred-operator ((pop preferred-operator)
                                              (op1 operator)
                                              (op2 operator))
    (equal (operator pop) op1)
    (not-equal op1 op2)
    (equal (state op1) (state op2))
#|
    (*no ((~pop preferred-operator))
      (> (id ~pop) (id pop)))
    (*no ((~pop preferred-operator))
      (equal (operator ~pop) op2))
|#
-->
    (spew t op2 (- (* *weight* *spew-rate*)))
)

;;; ...they are selected and performed successfully.
(p@ rh-spatial suppress-performed-preferred-operator ((pop preferred-operator)
                                                      (op operator)
                                                      (bs state)
                                                      (as state))
    (equal (operator pop) op)
    (equal (state op) bs)
    (contents-equal (perform-operator op bs) (contents as))
-->
    (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-preferred-operator ((g goal)
                                                      (pop preferred-operator)
                                                      (op operator))
    (equals (operator g) (operator pop) op)
-->
    (spew t op (- (* *weight* *spew-rate*)))
)




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; tol model initialization.
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



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


;; tracing.

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



;;;
;;; global variables.
;;;


;;

(defparameter *tol-trace-p* nil)


;; problem size.

(defparameter *size* 3)



;;;
;;; support functions, outside the cognitive scope of the model, that
;;; query and manipulate puzzle configurations.
;;;


;;

(defun make-pockets ()
  (make-array (list *size* *size*) :initial-element nil))

(defun copy-pockets (old-pockets)
  (let ((new-pockets (make-pockets)))
    (dotimes (row *size*)
      (dotimes (col *size*)
        (setf (aref new-pockets row col) (aref old-pockets row col))))
    new-pockets))


;;

(defun internal-pockets-equal (p1 p2)
  (dotimes (row *size*)
    (dotimes (col *size*)
      (unless (equal (aref p1 row col) (aref p2 row col))
        (return-from internal-pockets-equal nil))))
  t)


;;

(defun remove-ball (ball peg pockets)
  (dotimes (row *size*)
    (when (equal (aref pockets row peg) ball)
      (setf (aref pockets row peg) nil)
      (return-from remove-ball))))

(defun add-ball (ball peg pockets)
  (do ((row (- *size* peg 1) (1- row)))
      ((minusp row))
    (unless (aref pockets row peg)
      (setf (aref pockets row peg) ball)
      (return-from add-ball))))


;;

(defun find-ball (ball pockets)
  (dotimes (row *size*)
    (dotimes (col *size*)
      (when (equal (aref pockets row col) ball)
        (return-from find-ball (values row col)))))
  (values nil nil))

(defun internal-peg-of (ball pockets)
  (nth-value 1 (find-ball ball pockets)))

(defun internal-pocket-of (ball pockets)
  (nth-value 0 (find-ball ball pockets)))


;;

(defun internal-top-ball-p (ball pockets)
  (multiple-value-bind (row col) (find-ball ball pockets)
    (do ((row2 (1- row) (1- row2)))
        ((minusp row2))
      (when (aref pockets row2 col)
        (return-from internal-top-ball-p nil))))
  t)

(defun internal-full-p (peg pockets)
  (aref pockets 0 peg))

(defun internal-on-top-of-p (b1 b2 pockets)
  (and (= (internal-peg-of b1 pockets)
          (internal-peg-of b2 pockets))
       (< (internal-pocket-of b1 pockets)
          (internal-pocket-of b2 pockets))))


;;

(defun internal-not-in-place-p (pocks epocks ball)
  (flet ((pegs-equal-below-pocket-p (target-row target-col)
           (do ((trow (1+ target-row) (1+ trow)))
               ((= trow *size*))
             (unless (equal (aref pocks trow target-col)
                            (aref epocks trow target-col))
               (return-from pegs-equal-below-pocket-p nil)))
           t))
  (multiple-value-bind (pock peg) (find-ball ball pocks)
    (multiple-value-bind (epock epeg) (find-ball ball epocks)
      (not (and (= pock epock)
                (= peg epeg)
                (pegs-equal-below-pocket-p epock epeg)))))))

(defun internal-deeper-move-p (b1 b2 epockets)
  (flet ((code-position (pocket peg)
           (+ (* pocket *size*) (- *size* peg 1))))
    (> (multiple-value-call #'code-position (find-ball b1 epockets))
       (multiple-value-call #'code-position (find-ball b2 epockets)))))


;;

(defun internal-blocked-pocket-p (to-pocket to-peg pockets)
  (aref pockets to-pocket to-peg))


;;

(defun buffer-pocket-num ()
  0)

(defun buffer-peg-num ()
  (1- *size*))




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; tol model dm classes.
;;;;
;;;; the notation 'A:  B' means that A is a superclass (or B is a subclass of
;;;; A).
;;;;
;;;; default dm classes are capilatized; tol specific ones are in lowercase.
;;;;
;;;; BALL
;;;;
;;;; PEG
;;;;
;;;; PUZZLE-MIXIN
;;;;
;;;; BASE-STATE:          STATE:             puzzle          (+ puzzle-mixin)
;;;;                      END-STATE:         end-puzzle      (+ puzzle-mixin)
;;;;
;;;; OPERATOR:            move:              direct-move
;;;;                                         indirect-move:  unblock-ball-move
;;;;                                                         unblock-pocket-move*:  unblock-pocket-move
;;;;                                                                                buffer-unblock-pocket-move
;;;;
;;;; PREFERENCE
;;;;
;;;; PREFERRED-OPERATOR
;;;;
;;;; BASE-GOAL:           TASK-GOAL:         solve-puzzle-goal
;;;;                      GOAL:              unblock-goal:      unblock-ball-goal
;;;;                                                            unblock-pocket-goal
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;




;;;
;;; support classes.
;;;


;;

(defdmclass ball ()
  ball)


;;

(defdmclass peg ()
  peg)

(defmethod buffer-peg-p ((pg peg))
  (equal (peg pg) (1- *size*)))


;;

(defdmclass puzzle-mixin ())



;;;
;;; puzzle classes.
;;;


;;

(defdmclass puzzle (state puzzle-mixin))

(defmethod filled-buffer-pocket-p ((p puzzle))
  (aref (contents p) 0 (1- *size*)))

(defmethod unfilled-buffer-pocket-p ((p puzzle))
  (not (aref (contents p) 0 (1- *size*))))


;;

(defdmclass end-puzzle (end-state puzzle-mixin))



;;;
;;; the move classes.
;;;


;;

(defdmclass move (operator)
  ball
  from-peg
  from-pocket
  to-peg
  to-pocket)

(defmethod leaves-unfilled-buffer-pocket-p ((m move))
  (not (and (zerop (to-pocket m))
            (= (to-peg m) (1- *size*)))))

(defmethod fills-buffer-pocket-p ((m move))
  (and (zerop (to-pocket m))
       (= (to-peg m) (1- *size*))))


;;

(defdmclass direct-move (move))


;;

;

(defdmclass indirect-move (move)
  goal)


;

(defdmclass unblock-ball-move (indirect-move))

(defdmclass unblock-pocket-move* (indirect-move))

(defdmclass unblock-pocket-move (unblock-pocket-move*))

(defdmclass buffer-unblock-pocket-move (unblock-pocket-move*))



;;;
;;; base-goal classes.
;;;


;;

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


;;

(defdmclass unblock-goal (goal)
  ball
  from-pocket
  from-peg
  to-pocket
  to-peg)



;;

(defdmclass unblock-ball-goal (unblock-goal))

(defdmclass unblock-pocket-goal (unblock-goal))



;;;
;;; mixed dm class multimethods.
;;;


;; specializes abstract, default methods.


;

(defmethod contents-equal ((p1 array) (p2 array))
  (internal-pockets-equal p1 p2))


;

(defmethod hill-climbing-operator-p ((m move) (ep end-puzzle))
  (multiple-value-bind (epocket epeg) (find-ball (ball m) (contents ep))
    (and (eql (to-pocket m) epocket)
         (eql (to-peg m) epeg))))

;;;^^^ Changed this method so that it also calls HILL-CLIMBING-OPERATOR-P
;;;^^^ on is two move arguments.  This is a first step to seeing whether
;;;^^^ that operator can be removed from the General Executive model and
;;;^^^ defined only for those domain-specific instantiations where it makes
;;;^^^ sense.
(defmethod steeper-climbing-operator-p ((m1 move) (m2 move) (ep end-puzzle))
  (and (hill-climbing-operator-p m1 ep)
       (hill-climbing-operator-p m2 ep)
       (internal-deeper-move-p (ball m1) (ball m2) (contents ep))))


;

(defmethod perform-operator ((m move) (p puzzle))
  (let ((new-pockets (copy-pockets (contents p))))
    (remove-ball (ball m) (from-peg m) new-pockets)
    (add-ball (ball m) (to-peg m) new-pockets)
    new-pockets))


;

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

(defmethod satisfied-p ((g unblock-pocket-goal) (p puzzle))
  (not (internal-blocked-pocket-p (to-pocket g) (to-peg g) (contents p))))


;; general accessors.

(defmethod peg-of ((b ball) (p puzzle-mixin))
  (internal-peg-of (ball b) (contents p)))

(defmethod pocket-of ((b ball) (p puzzle-mixin))
  (internal-pocket-of (ball b) (contents p)))


;; moves.

(defmethod direct-move-p ((m move) (p puzzle))
  (flet ((empty-pocket-p (pocket peg pockets)
           (do ((row2 pocket (1- row2)))
               ((minusp row2))
             (when (aref pockets row2 peg)
               (return-from empty-pocket-p nil)))
           t))
  (and (internal-top-ball-p (ball m) (contents p))
       (empty-pocket-p (to-pocket m) (to-peg m) (contents p)))))


;; pockets.

(defmethod empty-pocket ((pg number) (p puzzle))
  (unless (aref (contents p) 0 pg)
    (do ((curr-pocket 1 (1+ curr-pocket)))
        ((= curr-pocket *size*)
         (- *size* pg 1))
      (when (aref (contents p) curr-pocket pg)
        (return-from empty-pocket (1- curr-pocket))))))

(defmethod stuffed-pocket-p ((g unblock-pocket-goal) (p puzzle))
  (let ((balls 0))
    (dotimes (row (1+ (to-pocket g)))
      (when (aref (contents p) row (to-peg g))
        (incf balls)))
    (>= balls (1- *size*))))

(defmethod blocked-pocket-p ((m move) (p puzzle-mixin))
  (internal-blocked-pocket-p (to-pocket m) (to-peg m) (contents p)))

(defmethod unblocked-pocket-p ((m move) (p puzzle-mixin))
  (not (internal-blocked-pocket-p (to-pocket m) (to-peg m) (contents p))))

(defmethod blocked-pocket-p ((g unblock-pocket-goal) (p puzzle))
  (internal-blocked-pocket-p (to-pocket g) (to-peg g) (contents p)))

(defmethod unblocked-pocket-p ((g unblock-pocket-goal) (p puzzle))
  (not (internal-blocked-pocket-p (to-pocket g) (to-peg g) (contents p))))


;; pegs.

(defmethod full-p ((pg peg) (p puzzle))
  (internal-full-p (peg pg) (contents p)))

(defmethod not-full-p ((pg number) (p puzzle))
  (not (internal-full-p pg (contents p))))


;; balls.

(defmethod not-in-place-p ((p puzzle) (ep end-puzzle) (b ball))
  (internal-not-in-place-p (contents p) (contents ep) (ball b)))

(defmethod on-top-of-p ((b1 ball) (b2 number) (p puzzle))
  (internal-on-top-of-p (ball b1) b2 (contents p)))

(defmethod top-ball-p ((ball number) (p puzzle))
  (internal-top-ball-p ball (contents p)))

(defmethod top-ball-of-peg-p ((ball number) (peg number) (p puzzle))
  (and (internal-top-ball-p ball (contents p))
       (= (internal-peg-of ball (contents p)) peg)))

(defmethod blocked-ball-p ((m move) (p puzzle))
  (not (internal-top-ball-p (ball m) (contents p))))


;; buffers.

(defmethod not-buffer-pocket-filled-p ((g unblock-pocket-goal) (p puzzle))
  (not (eql (internal-peg-of (ball g) (contents p)) (buffer-peg-num))))

(defmethod buffer-move-p ((m move) (p puzzle))
  (and (eql (to-pocket m) (buffer-pocket-num))
       (eql (to-peg m) (buffer-peg-num))))


;; esoteric.

;;; returns T if making this move puts one in the impossible situation
;;; of, in remaining moves, having to find room for M blocking balls
;;; in N empty pockets where M>N.
(defmethod bad-lookahead-p ((m move) (g unblock-pocket-goal) (p puzzle))
  ;; if this move is blocked and will therefore trample an existing ball,
  ;; then the rest of this function makes no sense, so return nil.
  (when (aref (contents p) (to-pocket m) (to-peg m))
    (return-from bad-lookahead-p nil))
  (let ((new-pockets (perform-operator m p))
        (remaining-balls 0)
        (remaining-pockets 0))
    ;; count the balls remaining to unblock after this move.
    (do ((pock (to-pocket g) (1- pock)))
        ((minusp pock))
      (when (aref new-pockets pock (to-peg g))
        (incf remaining-balls)))
    ;; count the number of pockets to put these pending balls.
    (dotimes (peg *size*)
      (unless (or (= peg (to-peg g))
                  (= peg (internal-peg-of (ball g) new-pockets)))
        (do ((pock (- *size* peg 1) (1- pock)))
            ((minusp pock))
          (unless (aref new-pockets pock peg)
            (incf remaining-pockets)))))

    ;; if there are more balls than pockets, this is a bad move.
    (> remaining-balls remaining-pockets)))

;;; returns T if making this move puts one in a solvable situation
;;; of, in remaining moves, having to find room for M blocking balls
;;; in N empty pockets where M<=N.
(defmethod good-lookahead-p ((m move) (g unblock-pocket-goal) (p puzzle))
  ;; the opposite of bad.
  (not (bad-lookahead-p m g p)))

(defmethod lookahead-consistency ((m move) (p puzzle) (ep end-puzzle))
  (let ((new-pockets (perform-operator m p))
        (consistency 0))
    (dotimes (ball *size*)
      (multiple-value-bind (epock epeg) (find-ball ball (contents ep))
        (let ((contents (aref new-pockets epock epeg)))
          (cond ((eql contents ball)
                 (incf consistency))
                (contents
                 (decf consistency))))))
    consistency))

;;; returns T if M1 is heuristically better lookahead than M2.
;;; the heuristic says not to move balls into places where other
;;; balls need to be in the end puzzle.  this helps solve problems
;;; like 27-->17.
(defmethod more-consistent-with-end-p ((m1 move) (m2 move)
                                       (p puzzle) (ep end-puzzle))
  (let ((lc1 (lookahead-consistency m1 p ep))
        (lc2 (lookahead-consistency m2 p ep)))
    (and (not (minusp lc1))
         (> lc1 lc2))))

;;;^^^ bit of a kludge.
;;;
;;; like MORE-CONSISTENT-WITH-END-P above, returns T of M1 has
;;; heuristicall better lookahead than M2.  the only difference
;;; is that this is a special case where the moves are non-buffer
;;; moves, and thus of type UNBLOCK-POCKET-MOVE.  in this case,
;;; negative LOOKAHEAD-CONSISTENTY values can be compared.  this
;;; helps solve 1-->23, which the above production cannot handle.
(defmethod more-consistent-with-end-p2 ((m1 unblock-pocket-move)
                                        (m2 unblock-pocket-move)
                                        (p puzzle) (ep end-puzzle))
  (> (lookahead-consistency m1 p ep)
     (lookahead-consistency m2 p ep)))

;;; returns T if M1 is heuristically better lookahead than M2.
;;; the heuristic says to prefer moves that set up reversed
;;; pegs of balls that can be 'unpopped' in order to reach the
;;; end state.  this helps solve problems like 6-->15.
(defmethod more-reversed-p ((m1 move) (m2 move)
                            (g unblock-pocket-goal)
                            (p puzzle) (ep end-puzzle))
  (flet ((reversed-balls (m)
           (let ((new-pockets (perform-operator m p))
                 (new-balls '()))
             (do ((pock (- *size* (to-peg m) 1) (1- pock)))
                 ((or (minusp pock)
                      (null (aref new-pockets pock (to-peg m)))))
               (push (aref new-pockets pock (to-peg m)) new-balls))
             (when (> (length new-balls) 1)
               (let ((return-code 'neutral))
                 (do* ((rem-balls new-balls (rest rem-balls))
                       (top-ball (first rem-balls) (first rem-balls))
                       (bot-ball (second rem-balls) (second rem-balls)))
                      ((null bot-ball))
                   (when (internal-on-top-of-p top-ball bot-ball (contents ep))
                     (return-from reversed-balls 'fail))
                   (when (internal-on-top-of-p bot-ball top-ball (contents ep))
                     (setq return-code 'succ)))
                 (return-from reversed-balls return-code))))
           'neutral))
    (and (eq (reversed-balls m1) 'succ)
         (not (eq (reversed-balls m2) 'succ)))))

;;; necessary for solving problems like 4-->19 and 5-->19.
(defmethod deepest-displaced-ball-p ((b ball) (p puzzle) (ep end-puzzle))
  (when (not-in-place-p p ep b)
    (dotimes (b2 *size*)
      (when (and (internal-not-in-place-p (contents p) (contents ep) b2)
                 (internal-deeper-move-p b2 (ball b) (contents ep)))
        (return-from deepest-displaced-ball-p nil)))
    t))

(defmethod requires-buffer-because-cannot-unblock-p ((b ball)
                                                     (p puzzle)
                                                     (ep end-puzzle))
  (let ((source-peg (peg-of b p))
        (target-peg (peg-of b ep)))
    (unless (= source-peg target-peg)
      (let ((extra-balls 0)
            (third-peg (- 3 source-peg target-peg))
            (pocks (contents p)))
                ;; count balls in and above the target pocket.
        (do ((pock (pocket-of b ep) (1- pock)))
            ((minusp pock))
          (when (aref pocks pock target-peg)
            (incf extra-balls)))
        ;; count balls above the source ball.
        (do ((pock (1- (pocket-of b p)) (1- pock)))
            ((minusp pock))
          (when (aref pocks pock source-peg)
            (incf extra-balls)))
        ;; count balls on the third peg.
        (do ((pock (- *size* third-peg 1) (1- pock)))
            ((minusp pock))
          (when (aref pocks pock third-peg)
            (incf extra-balls)))
        ;; compute whether the third peg has too few pockets to hold
        ;; all of the extra balls that must be placed there before
        ;; moving the ball to its target location.
        (< (- *size* third-peg) extra-balls)))))




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; tol model components.
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;
;;; tol model component specializations.
;;;


;; Center activation capacities.

(set-caps@ support nil)

#|
;;; activation capacities that fit original Newman et al. () Neuropsychologia
;;; study.
(set-caps@ lh-executive 14.0)
(set-caps@ rh-executive 20.0)

(set-caps@ lh-spatial 12.0)
(set-caps@ rh-spatial 2.5)
|#

;;; activation capacities that fit the new, unpublished TOL study.
(set-caps@ lh-executive 9.0)
(set-caps@ rh-executive 12.0)

(set-caps@ lh-spatial 18.0)
(set-caps@ rh-spatial 5.0)


;; specializations.

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

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

(set-specs@ rh-executive ball t
                         peg t
                         indirect-move 1
                         task-goal 1
                         goal 2)

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

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




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; tol model component productions.
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;
;;; lh-executive component.
;;;


;; assert preferences among moves.

;;; necessary for solving problems like 4-->19 and 5-->19.
(p@ lh-executive buffer-preference ((p puzzle)
                                    (ep end-puzzle)
                                    (m1 move)
                                    (m2 move)
                                    (b ball))
    (not-solved-p p ep)
    (equals p (state m1) (state m2))
    (buffer-move-p m1 p)
    (hill-climbing-operator-p m2 ep)
    (equal (ball m1) (ball b))
    (deepest-displaced-ball-p b p ep)
    (requires-buffer-because-cannot-unblock-p b p ep)
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~pr preference))
      (equal (better-operator ~pr) m1)
      (equal (worse-operator ~pr) m2))
-->
    (when *tol-trace-p*
      (format t "~&~A~Abuffer-preference "
              *macro-cycs* #\tab))

    (spew t (preference :better-operator m1
                        :worse-operator m2)
            (* *weight* *spew-rate*))
)


;; Combine these two? Both deal with one-step lookahead.

(p@ lh-executive lookahead-to-prefer-blocked ((g unblock-pocket-goal)
                                              (p puzzle)
                                              (ep end-puzzle)
                                              (m1 move)
                                              (m2 move))
    (not-solved-p p ep)
    (equals p (state m1) (state m2))
    (equals (ball g) (ball m1) (ball m2))
    (top-ball-of-peg-p (ball g) (from-peg g) p)
    (blocked-pocket-p m1 p)
    (unblocked-pocket-p m2 p)
    (bad-lookahead-p m2 g p)
    (*no ((~g goal))
      (more-recent-goal-p ~g g))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~pr preference))
      (equal (better-operator ~pr) m1)
      (equal (worse-operator ~pr) m2))
-->
    (when *tol-trace-p*
      (format t "~&~A~Aunblock-pocket-lookahead-preference "
              *macro-cycs* #\tab))

    (spew t (preference :better-operator m1
                        :worse-operator m2)
            (* *weight* *spew-rate*))
)

(p@ lh-executive lookahead-to-prefer-unblocked ((g unblock-pocket-goal)
                                                (p puzzle)
                                                (ep end-puzzle)
                                                (m1 unblock-pocket-move*)
                                                (m2 unblock-pocket-move*))
    (not-solved-p p ep)
    (equals p (state m1) (state m2))
    (equals g (goal m1) (goal m2))
    (unblocked-pocket-p m1 p)
    (unblocked-pocket-p m2 p)
    (good-lookahead-p m1 g p)
    (bad-lookahead-p m2 g p)
    (*no ((~g goal))
      (more-recent-goal-p ~g g))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~pr preference))
      (equal (better-operator ~pr) m1)
      (equal (worse-operator ~pr) m2))
-->
    (when *tol-trace-p*
      (format t "~&~A~Alookahead-to-prefer-unblocked "
              *macro-cycs* #\tab))

    (spew t (preference :better-operator m1
                        :worse-operator m2)
            (* *weight* *spew-rate*))
)


;;^^ The strategic versions of binary-preference.

(p@ lh-executive lookahead-to-prefer-consistent-with-end ((g unblock-pocket-goal)
                                                          (p puzzle)
                                                          (ep end-puzzle)
                                                          (m1 move)
                                                          (m2 move))
    (not-solved-p p ep)
    (equals p (state m1) (state m2))
    (equal (ball m1) (ball m2))
    (top-ball-of-peg-p (ball m1) (from-peg g) p)
    (unblocked-pocket-p m1 p)
    (unblocked-pocket-p m2 p)
    (more-consistent-with-end-p m1 m2 p ep)
    (*no ((~g goal))
      (more-recent-goal-p ~g g))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~pr preference))
      (equal (better-operator ~pr) m1)
      (equal (worse-operator ~pr) m2))
-->
    (when *tol-trace-p*
      (format t "~&~A~Alookahead-to-prefer-consistent-with-end "
              *macro-cycs* #\tab))

    (spew t (preference :better-operator m1
                        :worse-operator m2)
            (* *weight* *spew-rate*))
)

(p@ lh-executive lookahead-to-prefer-consistent-with-end2 ((g unblock-pocket-goal)
                                                           (p puzzle)
                                                           (ep end-puzzle)
                                                           (m1 unblock-pocket-move)
                                                           (m2 unblock-pocket-move))
    (not-solved-p p ep)
    (equals p (state m1) (state m2))
    (equal (ball m1) (ball m2))
    (top-ball-of-peg-p (ball m1) (from-peg g) p)
    (unblocked-pocket-p m1 p)
    (unblocked-pocket-p m2 p)
    (more-consistent-with-end-p2 m1 m2 p ep)
    (*no ((~g goal))
      (more-recent-goal-p ~g g))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~pr preference))
      (equal (better-operator ~pr) m1)
      (equal (worse-operator ~pr) m2))
-->
    (when *tol-trace-p*
      (format t "~&~A~Alookahead-to-prefer-consistent-with-end2 "
              *macro-cycs* #\tab))

    (spew t (preference :better-operator m1
                        :worse-operator m2)
            (* *weight* *spew-rate*))
)


;; Prefer when in the midst of a particularly sweet "macro move".

(p@ lh-executive lookahead-to-prefer-reversals ((g unblock-pocket-goal)
                                                (p puzzle)
                                                (ep end-puzzle)
                                                (m1 move)
                                                (m2 move))
    (not-solved-p p ep)
    (equals p (state m1) (state m2))
    (equals (ball g) (ball m1) (ball m2))
    (top-ball-of-peg-p (ball g) (from-peg g) p)
    (unblocked-pocket-p m1 p)
    (unblocked-pocket-p m2 p)
    (more-reversed-p m1 m2 g p ep)
    (*no ((~g goal))
      (more-recent-goal-p ~g g))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~pr preference))
      (equal (better-operator ~pr) m1)
      (equal (worse-operator ~pr) m2))
-->
    (when *tol-trace-p*
      (format t "~&~A~Alookahead-to-prefer-reversals "
              *macro-cycs* #\tab))

    (spew t (preference :better-operator m1
                        :worse-operator m2)
            (* *weight* *spew-rate*))
)



;;;
;;; rh-executive component.
;;;


;;

(p@ rh-executive propose-unblock-pocket-goal ((p puzzle)
                                              (ep end-puzzle)
                                              (m move)
                                              (pop preferred-operator))
    (not-solved-p p ep)
    (equal (state m) p)
    (equal (operator pop) m)
    (blocked-pocket-p m p)
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~ubp unblock-pocket-goal))
      (equal (operator ~ubp) m)
      (equal (ball ~ubp) (ball m))
      (equal (from-pocket ~ubp) (from-pocket m))
      (equal (from-peg ~ubp) (from-peg m))
      (equal (to-pocket ~ubp) (to-pocket m))
      (equal (to-peg ~ubp) (to-peg m)))
-->
    (spew t (unblock-pocket-goal :operator m
                                 :ball (ball m)
                                 :from-pocket (from-pocket m)
                                 :from-peg (from-peg m)
                                 :to-pocket (to-pocket m)
                                 :to-peg (to-peg m))
            (* *weight* *spew-rate*))
)

(p@ rh-executive propose-unblock-ball-goal ((p puzzle)
                                            (ep end-puzzle)
                                            (m move)
                                            (pop preferred-operator))
    (not-solved-p p ep)
    (equal (state m) p)
    (equal (operator pop) m)
    (unblocked-pocket-p m p)
    (blocked-ball-p m p)
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~ubg unblock-ball-goal))
      (equal (operator ~ubg) m)
      (equal (ball ~ubg) (ball m))
      (equal (from-pocket ~ubg) (from-pocket m))
      (equal (from-peg ~ubg) (from-peg m))
      (equal (to-pocket ~ubg) (to-pocket m))
      (equal (to-peg ~ubg) (to-peg m)))
-->
    (spew t (unblock-ball-goal :operator m
                               :ball (ball m)
                               :from-pocket (from-pocket m)
                               :from-peg (from-peg m)
                               :to-pocket (to-pocket m)
                               :to-peg (to-peg m))
            (* *weight* *spew-rate*))
)



;;;
;;; lh-spatial component.
;;;


;;

(p@ lh-spatial perform-move ((p puzzle)
                             (ep end-puzzle)
                             (m move)
                             (pop preferred-operator))
    (not-solved-p p ep)
    (equal (state m) p)
    (equal (operator pop) m)
    (direct-move-p m p)
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~p puzzle))
      (contents-equal (contents ~p) (perform-operator m p)))
-->
    (spew t (puzzle :contents (perform-operator m p))
            (* *weight* *spew-rate*))
)



;;;
;;; rh-spatial component.
;;;


;; direct move.
;;^^^ perceptual move.

;;;^^^ propose-perceptual-move.
(p@ rh-spatial propose-move ((g solve-puzzle-goal)
                             (p puzzle)
                             (ep end-puzzle)
                             (b ball))
    (id g)
    (not-solved-p p ep)
    (not-in-place-p p ep b)
    (*no ((~g goal))
      (more-recent-goal-p ~g g))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~m direct-move))
      (equal (state ~m) p)
      (equal (ball ~m) (ball b))
      (equal (from-peg ~m) (peg-of b p))
      (equal (from-pocket ~m) (pocket-of b p))
      (equal (to-peg ~m) (peg-of b ep))
      (equal (to-pocket ~m) (pocket-of b ep)))
-->
    (spew t (direct-move :state p
                         :ball (ball b)
                         :from-peg (peg-of b p)
                         :from-pocket (pocket-of b p)
                         :to-peg (peg-of b ep)
                         :to-pocket (pocket-of b ep))
            (* *weight* *spew-rate*))
)


;; indirect moves.
;;;^^^ strategic move.
;;;^^^ should be part of RH-EXECUTIVE.


;

(p@ rh-spatial propose-unblock-pocket-move ((g unblock-pocket-goal)
                                            (p puzzle)
                                            (ep end-puzzle)
                                            (b1 ball)
                                            (b2 ball)
                                            (pg peg))
    (not-solved-p p ep)
    (blocked-pocket-p g p)
    (top-ball-of-peg-p (ball b2) (to-peg g) p)
    (equal (ball g) (ball b1))
    (not-equal (peg-of b1 p) (peg pg))
    (not-equal (to-peg g) (peg pg))
    (not-full-p (peg pg) p)
    (*no ((~g goal))
      (more-recent-goal-p ~g g))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~m unblock-pocket-move))
      (equal (goal ~m) g)
      (equal (state ~m) p)
      (equal (ball ~m) (ball b2))
      (equal (from-peg ~m) (to-peg g))
      (equal (from-pocket ~m) (pocket-of b2 p))
      (equal (to-peg ~m) (peg pg))
      (equal (to-pocket ~m) (empty-pocket (peg pg) p)))
-->
    (spew t (unblock-pocket-move :goal g
                                 :state p
                                 :ball (ball b2)
                                 :from-peg (to-peg g)
                                 :from-pocket (pocket-of b2 p)
                                 :to-peg (peg pg)
                                 :to-pocket (empty-pocket (peg pg) p))
            (* *weight* *spew-rate*))
)


;
;;;^^^ Most consolidate or systematize these three productions.

(p@ rh-spatial propose-use-buffer-to-unblock-pocket-move ((g unblock-pocket-goal)
                                                          (p puzzle)
                                                          (ep end-puzzle)
                                                          (buffer peg)
                                                          (b ball))
    (not-solved-p p ep)
    (stuffed-pocket-p g p)
    (equal (ball g) (ball b))
    (top-ball-p (ball b) p)
    (not-equal (from-peg g) (peg buffer))
    (not-equal (to-peg g) (peg buffer))
    (buffer-peg-p buffer)
    (not-buffer-pocket-filled-p g p) 
    (*no ((~g goal))
      (more-recent-goal-p ~g g))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~m buffer-unblock-pocket-move))
      (equal (goal ~m) g)
      (equal (state ~m) p)
      (equal (ball ~m) (ball b))
      (equal (from-peg ~m) (from-peg g))
      (equal (from-pocket ~m) (pocket-of b p))
      (equal (to-peg ~m) (peg buffer))
      (equal (to-pocket ~m) (buffer-pocket-num)))
-->
    (when *tol-trace-p*
      (format t "~&~A~Apropose-use-buffer-to-unblock-pocket-move "
              *macro-cycs* #\tab)
      )

    (spew t (buffer-unblock-pocket-move :goal g
                                        :state p
                                        :ball (ball b)
                                        :from-peg (from-peg g)
                                        :from-pocket (pocket-of b p)
                                        :to-peg (peg buffer)
                                        :to-pocket (buffer-pocket-num))
            (* *weight* *spew-rate*))
)

;;; need to find a way to have this production obsolete the previous one.
(p@ rh-spatial propose-buffer-because-cannot-unblock ((g solve-puzzle-goal)
                                                      (p puzzle)
                                                      (ep end-puzzle)
                                                      (b ball))
    (id g)
    (not-solved-p p ep)
    (not-in-place-p p ep b)
    (deepest-displaced-ball-p b p ep)
    (requires-buffer-because-cannot-unblock-p b p ep)
    (*no ((~g goal))
      (more-recent-goal-p ~g g))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~m buffer-unblock-pocket-move))
      (equal (state ~m) p)
      (equal (ball ~m) (ball b))
      (equal (from-peg ~m) (peg-of b p))
      (equal (from-pocket ~m) (pocket-of b p))
      (equal (to-peg ~m) (buffer-peg-num))
      (equal (to-pocket ~m) (buffer-pocket-num)))
-->
    (when *tol-trace-p*
      (format t "~&~A~Apropose-buffer-because-cannot-unblock "
              *macro-cycs* #\tab)
      )

    (spew t (buffer-unblock-pocket-move :state p
                                        :ball (ball b)
                                        :from-peg (peg-of b p)
                                        :from-pocket (pocket-of b p)
                                        :to-peg (buffer-peg-num)
                                        :to-pocket (buffer-pocket-num))
            (* *weight* *spew-rate*))
)

;;; necessary for solving problems 11-->18, 3-->24, and 17-->15.
;;;
;;; these are problems where the first move is highly nonlinear,
;;; moving a ball from peg A to its target peg B, although not
;;; in the correct position because it is blocked, all because
;;; the buffer peg C is full.
;;;^^^ This production differs from the previous two because it
;;;^^^ applies when the buffer pocket is too jam-packed to use.
(p@ rh-spatial propose-blocking-move-when-cannot-unblock ((g solve-puzzle-goal)
                                                          (p puzzle)
                                                          (ep end-puzzle)
                                                          (b ball)
                                                          (buffer peg))
    (id g)
    (not-solved-p p ep)
    (not-in-place-p p ep b)
    (deepest-displaced-ball-p b p ep)
    (requires-buffer-because-cannot-unblock-p b p ep)

    (top-ball-p (ball b) p)
    (not-equal (peg-of b p) (peg buffer))
    (buffer-peg-p buffer)
    (full-p buffer p)
    (not-equal (peg-of b p) (peg-of b ep))
    (not-full-p (peg-of b ep) p)
    (not-equal (peg buffer) (peg-of b ep))
    (internal-blocked-pocket-p (pocket-of b ep)
                               (peg-of b ep)
                               (contents ep))
    (*no ((~g goal))
      (more-recent-goal-p ~g g))
    (*no ((~p puzzle))
      (more-recent-state-p ~p p))
    (*no ((~m buffer-unblock-pocket-move))
      (equal (state ~m) p)
      (equal (ball ~m) (ball b))
      (equal (from-peg ~m) (peg-of b p))
      (equal (from-pocket ~m) (pocket-of b p))
      (equal (to-peg ~m) (peg-of b ep))

      (equal (to-pocket ~m) (empty-pocket (peg-of b ep) p)))
-->
    (when *tol-trace-p*
      (format t "~&~A~A*** propose-blocking-move-when-cannot-unblock "
              *macro-cycs* #\tab)
      )

    (spew t (buffer-unblock-pocket-move :state p
                                        :ball (ball b)
                                        :from-peg (peg-of b p)
                                        :from-pocket (pocket-of b p)
                                        :to-peg (peg-of b ep)
                                        :to-pocket (empty-pocket (peg-of b ep) p))
            (* *weight* *spew-rate*))
)


;;

(p@ rh-spatial propose-unblock-ball-move ((g unblock-ball-goal)
                                          (p puzzle)
                                          (ep end-puzzle)
                                          (m move)
                                          (b ball)
                                          (pg peg))
   (not-solved-p p ep)
   (equal (operator g) m)
   (on-top-of-p b (ball m) p)
   (top-ball-p (ball b) p)
   (not-equal (from-peg m) (peg pg))
   (not-equal (to-peg m) (peg pg))
   (not-full-p (peg pg) p)
   (*no ((~g goal))
     (more-recent-goal-p ~g g))
   (*no ((~p puzzle))
     (more-recent-state-p ~p p))
   (*no ((~m unblock-ball-move))
     (equal (goal ~m) g)
     (equal (state ~m) p)
     (equal (ball ~m) (ball b))
     (equal (from-peg ~m) (from-peg m))
     (equal (from-pocket ~m) (pocket-of b p))
     (equal (to-peg ~m) (peg pg))
     (equal (to-pocket ~m) (empty-pocket (peg pg) p)))
-->
    (when *tol-trace-p*
      (format t "~&~A~Apropose-unblock-ball-move "
              *macro-cycs* #\tab)
      )

   (spew t (unblock-ball-move :goal g
                              :state p
                              :ball (ball b)
                              :from-peg (from-peg m)
                              :from-pocket (pocket-of b p)
                              :to-peg (peg pg)
                              :to-pocket (empty-pocket (peg pg) p))
           (* *weight* *spew-rate*))
)




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; tol model test code.
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;
;;;
;;;


;;

(defun initialize-model ()
  (spew t (solve-puzzle-goal)
          *weight*)
  (dotimes (ball *size*)
    (spew t (ball :ball ball)
            *weight*))
  (dotimes (peg *size*)
    (spew t (peg :peg peg)
            *weight*))
  (values))


;;

(defun test1 ()
  (format t "~2%Unblock ball.")
  (reset)
  (initialize-model)
  (spew t (puzzle :contents #2A((0   nil nil)
                                (1   nil nil)
                                (2   nil nil)))
          *weight*)
  (spew t (end-puzzle :contents #2A((nil nil 0)
                                    (nil 1   nil)
                                    (2   nil nil)))
          *weight*)
  (run 15)
  (dm)
  )

(defun test2 ()
  (format t "~2%Unblock pocket.")
  (reset)
  (initialize-model)
  (spew t (puzzle :contents #2A((nil nil nil)
                                (1   0   nil)
                                (2   nil nil)))
          *weight*)
  (spew t (end-puzzle :contents #2A((nil nil 0)
                                    (nil 1   nil)
                                    (2   nil nil)))
          *weight*)
  (run 15)
  (dm)
  )

(defun test3 ()
  (format t "~2%Unblock ball and pocket.")
  (reset)
  (initialize-model)
  (spew t (puzzle :contents #2A((nil nil nil)
                                (1   0   nil)
                                (2   nil nil)))
          *weight*)
  (spew t (end-puzzle :contents #2A((nil 1   0)
                                    (nil 2   nil)
                                    (nil nil nil)))
          *weight*)
  (run 10)
  (dm)
  )

(defun test4 ()
  (format t "~2%Move 1 ball.")
  (reset)
  (initialize-model)
  (spew t (puzzle :contents #2A((0   nil nil)
                                (1   nil nil)
                                (2   nil nil)))
          *weight*)
  (spew t (end-puzzle :contents #2A((nil nil 0)
                                    (1   nil nil)
                                    (2   nil nil)))
          *weight*)
  (run 10)
  (dm)
  (format t "~2%Move 2 balls.")
  (reset)
  (initialize-model)
  (spew t (puzzle :contents #2A((0   nil nil)
                                (1   nil nil)
                                (2   nil nil)))
          *weight*)
  (spew t (end-puzzle :contents #2A((nil 1   nil)
                                    (nil 0   nil)
                                    (2   nil nil)))
          *weight*)
  (run 10)
  (dm)
  (format t "~2%Move 3 balls.")
  (reset)
  (initialize-model)
  (spew t (puzzle :contents #2A((0   nil nil)
                                (1   nil nil)
                                (2   nil nil)))
          *weight*)
  (spew t (end-puzzle :contents #2A((nil 1   2)
                                    (nil 0   nil)
                                    (nil nil nil)))
          *weight*)
  (run 20)
  (dm)
  )

(defun test5 ()
  (format t "~2%PSYCH REVIEW PAPER EXAMPLE PROBLEM.")
  (reset)
  (initialize-model)
  (spew t (puzzle :contents #2A((0   nil nil)
                                (1   nil nil)
                                (2   nil nil)))
          *weight*)
  (spew t (end-puzzle :contents #2A((nil 0   nil)
                                    (nil 1   nil)
                                    (2   nil nil)))
          *weight*)
  (run 10)
  (history@ (lh-executive rh-executive lh-spatial rh-spatial)
            :measure prop
            :combination avg
            :time 1)
  )