;;;;;;;;;;;;;;;;;;;;;;;;<pre><xmp>
;;;
;;;  Word Problem Solving Model
;;;  for "Atomic Components of Thought"
;;;  Dario Salvucci & John Anderson
;;;

;;; ACT-R 4.0 model
;;; to run the model call:
;;; (ppiece-initialize-variables)

;;; then
;;; (ppiece-run)

;;;=========================================================
;;;
;;;  Web Interface
;;;

(defvar *ppiece-base-level-decay* 0.5)
(defvar *ppiece-activation-noise* 0.1)
(defvar *ppiece-gain-noise* 0.2)
(defvar *ppiece-nruns* 1)
(defvar *ppiece-ct* nil)
(defvar *ppiece-rt* 0)
(defvar *text*)
(defvar *graphic*)
(defvar *overlay*)
(setf *text* t)
(setf *graphic* nil)
(setf *overlay* nil)


(defparameter *ppiece-all-exp-data*
  '((1.73 1.98) (2.03 2.45)))

#|
	1	2
Data 1	1.73	1.98
Data 2	2.03	2.45
Model 1	1.74	2.03
Model 2	2.03	2.29
|#

(defun ppiece-unified-output (data sim)
  (when sim
    (format *standard-output* "~%~%Parameters for run: (~S ~S ~S ~S)~%~%"
            *ppiece-base-level-decay*  *ppiece-activation-noise*  *ppiece-gain-noise*  *ppiece-nruns*))
  (when *text*
    (ppiece-output-tables data sim)
    
    (when (and sim *overlay*)
      (ppiece-output-tables *ppiece-all-exp-data* nil))
    
    (unless *graphic* (format *standard-output* 
                              "~%</pre>If your browser supports JAVA, you 
                               can display the data in a graph by checking 
                               the Graphic output box on the interface page.<pre>~%~%")))
  (when *graphic*
    (format *standard-output* " 
        <applet 
        code = \"DansGraphs.class\" 
        width = 400 
        height = 450> 

        <PARAM name=\"title\" value=\"People-Piece Latencies\">
        <PARAM name=\"longestline\" value=\"2\">
        <PARAM name=\"numlines\" value=\"~S\">
        <PARAM name=\"xmin\" value=\"1\">
        <PARAM name=\"xmax\" value=\"2\">
        <PARAM name=\"ymax\" value=\"3.0\">
        <PARAM name=\"ymin\" value=\"1\">
        <PARAM name=\"ydiv\" value=\"0.25\">
        <PARAM name=\"yspacing\" value=\"0.5\">
        <PARAM name=\"xspacing\" value=\"1\">
        <PARAM name=\"xval0\" value=\"1;2;\">
        <PARAM name=\"xval1\" value=\"1;2;\">
        <PARAM name=\"lcolor0\" value=\"0\">
        <PARAM name=\"lcolor1\" value=\"1\">
        <PARAM name=\"lstyle0\" value=\"~s\">
        <PARAM name=\"lstyle1\" value=\"~s\">
        <PARAM name=\"name0\" value=\"~a 1 Difference, A-C\">
        <PARAM name=\"name1\" value=\"~a 2 Differences, A-C\">
        <PARAM name=\"xname\" value=\"Differences, A-B\">
        <PARAM name=\"yname\" value=\"Latency (s)\">"
            (if (and sim *overlay*) 4 2)
            (if sim 2 6553)
            (if sim 2 6553)
            (if sim "Model" "Experiment")(if sim "Model" "Experiment"))
    
    
      (format *standard-output* "<PARAM name=\"yval0\" value=\"~S;~S;\">"
              (first (first data)) (second (first data)))
      
      (format *standard-output* "<PARAM name=\"yval1\" value=\"~S;~S;\">"
              (first (second data)) (second (second data)))
    
    (when (and sim *overlay*)
      
      (format *standard-output*
              "<PARAM name=\"xval2\" value=\"1;2;\">
        <PARAM name=\"xval3\" value=\"1;2;\">
        <PARAM name=\"lcolor2\" value=\"0\">
        <PARAM name=\"lcolor3\" value=\"1\">
        <PARAM name=\"lstyle2\" value=\"6553\">
        <PARAM name=\"lstyle3\" value=\"6553\">
         <PARAM name=\"name2\" value=\"Experiment 1 Difference, A-C\">
        <PARAM name=\"name3\" value=\"Experiment 2 Differences, A-C\">")
      (format *standard-output* "<PARAM name=\"yval2\" value=\"~S;~S;\">"
              (first (first *ppiece-all-exp-data*)) (second (first *ppiece-all-exp-data*)))
      
      (format *standard-output* "<PARAM name=\"yval3\" value=\"~S;~S;\">"
              (first (second *ppiece-all-exp-data*)) (second (second *ppiece-all-exp-data*)))
   
      
      
      
      )
    
    
    
    
    (format *standard-output* "
             <HR> Either your browser does not support JAVA or this graph has scrolled off the top of the display.~%
             </HR></applet>")
    
    
    
    ))


(defun ppiece-output-tables (data sim)
  (format *standard-output* "~A results showing the average problem latency in seconds.~%~%"
          (if sim "Model" "Experiment"))
  (let ((c1 (first data))
        (c2 (second data)))
    (format *standard-output* "                        Differences, A-B~%")
    (format *standard-output* "  Differences, A-C         1        2~%")
    (format *standard-output* "  ---------------------------------------~%")
    (format *standard-output* "         1          :")
    (dolist (x c1) (format *standard-output* "~9,2f" x))
    (format *standard-output* "~%         2          :")
    (dolist (x c2) (format *standard-output* "~9,2f" x))
    (format *standard-output* "~%~%~%")))


(defun ppiece-experiment (&optional (condition 'c11))
  "Condition should be one of {c11,c12,c21,c22}."
  (case condition
    (c11
     (add-dm
      (person-a isa person tag a sex male   color black height tall  weight thin)
      (person-b isa person tag b sex female color black height tall  weight thin)
      (person-c isa person tag c sex male   color black height short weight thin)
      (person-d isa person tag d sex female color black height short weight thin)))
    (c12
     (add-dm
      (person-a isa person tag a sex male   color black height tall  weight thin)
      (person-b isa person tag b sex female color black height tall  weight thin)
      (person-c isa person tag c sex male   color black height short weight fat)
      (person-d isa person tag d sex female color black height short weight fat)))
    (c21
     (add-dm
      (person-a isa person tag a sex male   color black height tall  weight thin)
      (person-b isa person tag b sex female color white height tall  weight thin)
      (person-c isa person tag c sex male   color black height short weight thin)
      (person-d isa person tag d sex female color white height short weight thin)))
    (c22
     (add-dm
      (person-a isa person tag a sex male   color black height tall  weight thin)
      (person-b isa person tag b sex female color white height tall  weight thin)
      (person-c isa person tag c sex male   color black height short weight fat)
      (person-d isa person tag d sex female color white height short weight fat))))
  (sdp-fct '(:references 1000)))


(defun ppiece-run ()
  (let ((results (list (list 0 0) (list 0 0))))

    (unless (<= *ppiece-nruns* 20)
      (format *standard-output* "Sorry, server can only execute up to 20 simulations.~%"))

    (when (<= *ppiece-nruns* 20)
      
      (dotimes (n *ppiece-nruns*)
        (dolist (condition '(c11 c12 c21 c22))
          (reset)
          (ppiece-experiment condition)
          (sgp-fct (list :bll *ppiece-base-level-decay*  :an *ppiece-activation-noise*
                         :egn *ppiece-gain-noise*        :v  *ppiece-ct*
                         :ct  *ppiece-ct*))
          (run)
          (case condition
            (c11 (incf (first (first results)) *ppiece-rt*))
            (c12 (incf (second (first results)) *ppiece-rt*))
            (c21 (incf (first (second results)) *ppiece-rt*))
            (c22 (incf (second (second results)) *ppiece-rt*)))))
      (unless (zerop *ppiece-nruns*)
        (setf results
              (mapcar #'(lambda (lst) (mapcar #'(lambda (x) (/ x *ppiece-nruns*)) lst))
                      results)))
      
      (ppiece-unified-output results t))))


(defvar *www-interface*)
(setf *WWW-interface*  
      '((:heading "People-Piece Model" 2)
        (:table)
          (:table)
            "Base-level decay: "      (:string :sy *ppiece-base-level-decay* 0.5) (:new-row)
            "Activation noise: "      (:string :sy *ppiece-activation-noise* 0.1) (:new-row)
            "Expected gain noise: "   (:string :sy *ppiece-gain-noise*       0.2) (:new-row)
            "Number of simulations (1-20): " (:string :sy *ppiece-nruns* 10)              
           
          (:table-end)
          (:table)
            (:checkbox "Trace model"   :sy *ppiece-ct*        nil)  (:new-row)
            (:checkbox "Text output" :sy *text*  t) (:new-row)
            (:checkbox "Graphic output" :sy *graphic*  nil) (:new-row)
            (:checkbox "Show simulation and experiment data on same graph" :sy *overlay*  nil) 
      (:table-end)
        (:table-end)
        (:new-para)
        (:button "Show Experiment Results" "(ppiece-unified-output *ppiece-all-exp-data* nil)")
        (:new-para)
        (:button "Run model" "(if (and (numberp *ppiece-base-level-decay*) (numberp *ppiece-activation-noise*)
                                           (numberp *ppiece-gain-noise*) (numberp *ppiece-nruns*))
                                     (progn (ppiece-initialize-variables)
                                         
                                        (ppiece-run))
                                     (format *standard-output* \"All parameters must be numbers~%\"))")
        
        (:reset "Default values")
        (:button "Production rules" "(let ((prods (no-output (pp))))
                                       (dolist (x prods)
                                         (pp-fct (list x))
                                         (spp-fct (list x))
                                         (format *standard-output* \"~%\")))")
        (:button "Chunk types" "(chunk-type)")
        (:button "Chunks" "(dm)")
        (:new-para)
        "TIME and SIZE:"
        (:new-para)
        "- It usually takes about 1 minute for 10 model simulations."
        (:new-line)
        "- The trace of 1 run is approximately 15k (10 pages) in size."
        (:new-para)
        ))

(defun ppiece-initialize-variables ()
  (setf *ppiece-action-trace* nil)
  (setf *ppiece-action-traces* nil)
  (setf *ppiece-stimuli* nil)
  (setf *ppiece-mouse-loc* nil)
  (setf *ppiece-short-move-latency* 0.3)
  (setf *ppiece-long-move-latency* 0.8)
  (setf *ppiece-long-move-threshold* 50)
  (setf *ppiece-short-attend-latency* 0)
  (setf *ppiece-long-attend-latency* 1.0)
  (setf *ppiece-type-latency* 1.0))


;;;</xmp><pre><a name="model">
;;;</a>
;;;=========================================================
;;;
;;;  Sternberg People-Piece ACT-R Model
;;;  for "Atomic Components of Thought"
;;;  Dario Salvucci & John Anderson
;;;

;;;
;;;  Sternberg Analogy Model
;;;  for "Atomic Components of Thought"
;;;  Dario Salvucci & John Anderson
;;;

(clear-all)

(sgp :era t
     :bll 0.5
     :er t
     :ct nil
     :lt nil
     :cst nil
     :act nil
     :an 0.1
     :egn 0.2
)

(chunk-type person tag sex color height weight)
(chunk-type attribute opposite)
(chunk-type tag)
(chunk-type integer value next)

;=============================================================================
;;;
;;;  Declarative Memory
;;;

(add-dm

 (t isa chunk)
 (success isa chunk)
 (failure isa chunk)
 (nothing isa chunk)
 (a-b isa chunk)
 (a-c isa chunk)
 
 (a isa tag)
 (b isa tag)
 (c isa tag)
 (d isa tag)

 (male   isa attribute opposite female)
 (female isa attribute opposite male)
 (white  isa attribute opposite black)
 (black  isa attribute opposite white)
 (tall   isa attribute opposite short)
 (short  isa attribute opposite tall)
 (thin   isa attribute opposite fat)
 (fat    isa attribute opposite thin)

 (i1 isa integer value 1 next i2)
 (i2 isa integer value 2 next i3)
 (i3 isa integer value 3 next i4)
 (i4 isa integer value 4 next i5)
 (i5 isa integer value 5 next i6)
 (i6 isa integer value 6 next i7)
 (i7 isa integer value 7 next i8)
 (i8 isa integer value 8 next i9)
 (i9 isa integer value 9 next nil)
)

;=============================================================================
;;;
;;;  mapping and map types
;;;

(chunk-type mapping type)
(chunk-type map mapping pos index)

(p pop-mapping
   =goal>
      isa mapping
==>
   !pop!)

(p pop-map
   =goal>
      isa map
==>
   !pop!)

;=============================================================================
;;;
;;;  recall-or-create-mapping
;;;

(chunk-type recall-or-create-mapping type result)

(p subgoal-mapping
   =goal>
      isa recall-or-create-mapping
      type =type
      result nil
==>
   =mapping>
      isa mapping
      type =type
   =goal>
      result t
   !push! =mapping)

(p return-mapping
   =goal>
      isa recall-or-create-mapping
      type =type
      result t
   =mapping>
      isa mapping
      type =type
==>
   =goal>
      result =mapping
   !pop!)

;=============================================================================
;;;
;;;  recall-or-create-map
;;;

(chunk-type recall-or-create-map mapping pos index result)

(p subgoal-map
   =goal>
      isa recall-or-create-map
      mapping =mapping
      pos =pos
      index =index
      result nil
==>
   =map>
      isa map
      mapping =mapping
      pos =pos
      index =index
   =goal>
      result t
   !push! =map)

(p return-map
   =goal>
      isa recall-or-create-map
      mapping =mapping
      pos =pos
      index =index
      result t
   =map>
      isa map
      mapping =mapping
      pos =pos
      index =index
==>
   =goal>
      result =map
   !pop!)

;=============================================================================
;;;
;;;  study-maps
;;;

(chunk-type study-maps mapping pos from to a b mpos
            asex bsex acolor bcolor aheight bheight aweight bweight)

(p encode-a
   =goal>
      isa study-maps
      from =from
      a nil
   =a>
      isa person
      tag =from
==>
   =goal>
      a =a
      mpos i1)

(p encode-b
   =goal>
      isa study-maps
      to =to
      b nil
   =b>
      isa person
      tag =to
==>
   =goal>
      b =b)

(p retrieve-attributes
   =goal>
      isa study-maps
      from =from
      to =to
      a =a
      b =b
      asex nil
   =a> isa person sex =asex color =acolor height =aheight weight =aweight
   =b> isa person sex =bsex color =bcolor height =bheight weight =bweight
==>
   =goal>
      asex =asex acolor =acolor aheight =aheight aweight =aweight
      bsex =bsex bcolor =bcolor bheight =bheight bweight =bweight)

(p map-same-sex
   =goal>
      isa study-maps
      pos i1
      asex =sex
      bsex =sex
==>
   =goal>
      pos i2)

(p map-diff-sex
   =goal>
      isa study-maps
      mapping =mapping
      pos i1
      asex =sex
      - bsex =sex
      mpos =mpos
   =mpos>
      isa integer
      next =next
==>
   =subgoal1>
      isa recall-or-create-map
      mapping =mapping
      pos =mpos
      index i1
   =goal>
      pos i2
      mpos =next
   !push! =subgoal1)

(p map-same-color
   =goal>
      isa study-maps
      pos i2
      acolor =color
      bcolor =color
==>
   =goal>
      pos i3)

(p map-diff-color
   =goal>
      isa study-maps
      mapping =mapping
      pos i2
      acolor =color
      - bcolor =color
      mpos =mpos
   =mpos>
      isa integer
      next =next
==>
   =subgoal1>
      isa recall-or-create-map
      mapping =mapping
      pos =mpos
      index i2
   =goal>
      pos i3
      mpos =next
   !push! =subgoal1)

(p map-same-height
   =goal>
      isa study-maps
      pos i3
      aheight =height
      bheight =height
==>
   =goal>
      pos i4)

(p map-diff-height
   =goal>
      isa study-maps
      mapping =mapping
      pos i3
      aheight =height
      - bheight =height
      mpos =mpos
   =mpos>
      isa integer
      next =next
==>
   =subgoal1>
      isa recall-or-create-map
      mapping =mapping
      pos =mpos
      index i3
   =goal>
      pos i4
      mpos =next
   !push! =subgoal1)

(p map-same-weight
   =goal>
      isa study-maps
      mapping =mapping
      pos i4
      aweight =weight
      bweight =weight
      mpos =mpos
==>
   =subgoal1>
      isa map
      mapping =mapping
      pos =mpos
      index nothing
   !focus-on! =subgoal1)

(p map-diff-weight
   =goal>
      isa study-maps
      mapping =mapping
      pos i4
      aweight =weight
      - bweight =weight
      mpos =mpos
   =mpos>
      isa integer
      next =next
==>
   =subgoal1>
      isa recall-or-create-map
      mapping =mapping
      pos =mpos
      index i4
   =subgoal2>
      isa map
      mapping =mapping
      pos =next
      index nothing
   !focus-on! =subgoal2
   !push! =subgoal1)

;=============================================================================
;;;
;;;  get-attribute
;;;

(chunk-type get-attribute person index result)

(p get-person-sex
   =goal>
      isa get-attribute
      person =person
      index i1
   =person>
      isa person
      sex =value
==>
   =goal>
      result =value
   !pop!)

(p get-person-color
   =goal>
      isa get-attribute
      person =person
      index i2
   =person>
      isa person
      color =value
==>
   =goal>
      result =value
   !pop!)

(p get-person-height
   =goal>
      isa get-attribute
      person =person
      index i3
   =person>
      isa person
      height =value
==>
   =goal>
      result =value
   !pop!)

(p get-person-weight
   =goal>
      isa get-attribute
      person =person
      index i4
   =person>
      isa person
      weight =value
==>
   =goal>
      result =value
   !pop!)

;=============================================================================
;;;
;;;  set-attribute
;;;

(chunk-type set-attribute person index value)

(p set-person-sex
   =goal>
      isa set-attribute
      person =person
      index i1
      value =value
   =person>
      isa person
==>
   =person>
      sex =value
   !pop!)

(p set-person-color
   =goal>
      isa set-attribute
      person =person
      index i2
      value =value
   =person>
      isa person
==>
   =person>
      color =value
   !pop!)

(p set-person-height
   =goal>
      isa set-attribute
      person =person
      index i3
      value =value
   =person>
      isa person
==>
   =person>
      height =value
   !pop!)

(p set-person-weight
   =goal>
      isa set-attribute
      person =person
      index i4
      value =value
   =person>
      isa person
==>
   =person>
      weight =value
   !pop!)

;=============================================================================
;;;
;;;  apply-map
;;;

(chunk-type apply-map index c d2 cval applied)

(p get-c-value
   =goal>
      isa apply-map
      index =index
      c =c
      cval nil
==>
   =subgoal1>
      isa get-attribute
      person =c
      index =index
      result =result
   =goal>
      cval =result
   !push! =subgoal1)

(p set-d2-value
   =goal>
      isa apply-map
      index =index
      cval =cval
      d2 =d2
      applied nil
   =cval>
      isa attribute
      opposite =opposite
==>
   =subgoal1>
      isa set-attribute
      person =d2
      index =index
      value =opposite
   =goal>
      applied t
   !push! =subgoal1)

(p done-apply-map
   =goal>
      isa apply-map
      applied t
==>
   !pop!)

;=============================================================================
;;;
;;;  apply-mapping
;;;

(chunk-type apply-mapping from to c d d2 mapping pos
            index applied result)

(p encode-c
   =goal>
      isa apply-mapping
      from =from
      c nil
   =c>
      isa person
      tag =from
==>
   =goal>
      c =c)

(p encode-d
   =goal>
      isa apply-mapping
      to =to
      d nil
   =d>
      isa person
      tag =to
==>
   =goal>
      d =d)

(p set-d2
   =goal>
      isa apply-mapping
      c =c
      d2 nil
      mapping =mapping
   =c> isa person sex =sex color =color height =height weight =weight
==>
   =d2> isa person sex =sex color =color height =height weight =weight
   =goal>
      d2 =d2
      pos i1)

(p retrieve-map-index
   =goal>
      isa apply-mapping
      mapping =mapping
      - d2 nil
      pos =pos
      index nil
      applied nil
   =map>
      isa map
      pos =pos
      index =index
==>
   =goal>
      index =index)

(p subgoal-apply-map
   =goal>
      isa apply-mapping
      index =index
      - index nothing
      c =c
      d2 =d2
      applied nil
==>
   =subgoal1>
      isa apply-map
      index =index
      c =c
      d2 =d2
   =goal>
      applied t
   !push! =subgoal1)

(p try-next-map
   =goal>
      isa apply-mapping
      pos =pos
      applied t
   =pos>
      isa integer
      next =next
==>
   =goal>
      pos =next
      index nil
      applied nil)

(p respond-true
   =goal>
      isa apply-mapping
      d =d
      d =d2
      index nothing
   =d>  isa person sex =sex color =color height =height weight =weight
   =d2> isa person sex =sex color =color height =height weight =weight
==>
   !eval! (setf *ppiece-rt* (actr-time))
   =goal>
      result success
   !pop!)

(p respond-false
   =goal>
      isa apply-mapping
      index nothing
==>
   !eval! (setf *ppiece-rt* (actr-time))
   =goal>
      result failure
   !pop!)
(spp respond-false :r .8)

;=============================================================================
;;;
;;;  main analogy subgoals
;;;

(chunk-type study-mapping mapping type result)
(chunk-type solve-problem mapping pos type result)
(chunk-type goto-next-screen)

(p subgoal-study-mapping-a-b
   =goal>
      isa study-mapping
      mapping =mapping
   =mapping>
      isa mapping
      type a-b
==>
   =subgoal1>
      isa study-maps
      mapping =mapping
      pos i1
      from a
      to b
   !focus-on! =subgoal1)

(p subgoal-study-mapping-a-c
   =goal>
      isa study-mapping
      mapping =mapping
   =mapping>
      isa mapping
      type a-c
==>
   =subgoal1>
      isa study-maps
      mapping =mapping
      pos i1
      from a
      to c
   !focus-on! =subgoal1)

(p subgoal-apply-mapping-a-b
   =goal>
      isa solve-problem
      mapping =mapping
      result nil
   =mapping>
      isa mapping
      type a-b
==>
   =subgoal1>
      isa apply-mapping
      mapping =mapping
      from c
      to d
      result =result
   =goal>
      result =result
   !push! =subgoal1)

(p subgoal-apply-mapping-a-c
   =goal>
      isa solve-problem
      mapping =mapping
      result nil
   =mapping>
      isa mapping
      type a-c
==>
   =subgoal1>
      isa apply-mapping
      mapping =mapping
      from b
      to d
      result =result
   =goal>
      result =result
   !push! =subgoal1)

(p done-solve-problem
   =goal>
      isa solve-problem
      - result nil
==>
   !pop!)

(p goto-next-screen
   =goal>
      isa goto-next-screen
==>
   !pop!
   !pop!)

;=============================================================================
;;;
;;;  main analogy productions
;;;

(chunk-type solve-by-analogy stage mapping type result)

(p choose-a-b-map
   =goal>
      isa solve-by-analogy
      stage i1
==>
   =goal>
      stage i3
      type a-b)

(p choose-a-c-map
   =goal>
      isa solve-by-analogy
      stage i1
==>
   =goal>
      stage i3
      type a-c)

;;; the next two productions are taken from the
;;; simple physics model, save parameters

(p stage3-study-mapping
   =goal>
      isa solve-by-analogy
      stage i3
      type =type
==>
   =subgoal1>
      isa recall-or-create-mapping
      type =type
      result =result
   =subgoal2>
      isa study-mapping
      mapping =result
   !push! =subgoal2
   !push! =subgoal1)
(spp stage3-study-mapping :a 2.0)

(p stage3-retrieve-mapping
   =goal>
      isa solve-by-analogy
      stage i3
      type =type
   =mapping>
      isa mapping
      type =type
==>
   =goal>
      stage i4
      mapping =mapping)
(spp stage3-retrieve-mapping :r .99)

;;; done copying

(p move-to-solution
   =goal>
      isa solve-by-analogy
      stage i4
==>
   =goal>
      stage i6)

;;; the next production is copied directly from the
;;; simple physics model

(p stage6-solve-problem
   =goal>
      isa solve-by-analogy
      stage i6
      mapping =mapping
==>
   =subgoal1>
      isa solve-problem
      mapping =mapping
      pos i1
   =subgoal2>
      isa goto-next-screen
   =goal>
      stage i7
      mapping nil
   !push! =subgoal2
   !push! =subgoal1)

;;; done copying

(add-dm (goal isa solve-by-analogy stage i1))
(sdp :references 1000)

(spp :strength 3.5)

(goal-focus goal)