;;;<pre><xmp>
;;;===============================================================================
;;;
;;;  Soap-Opera Model
;;;  (Data from Spellman & Holyoak, 1996)
;;;
;;;  Dario D. Salvucci & John R. Anderson
;;;  "Integrating Analogical Mapping and General Problem Solving:
;;;   The Path-Mapping Theory"
;;;

;;;-------------------------------------------------------------------------------
;;;
;;;  Parameters
;;;

(defparameter *estimated-similar-match* .99)
(defparameter *estimated-different-match* .83)

(defparameter *estimated-pragmatic-boost* 50)

;;;-------------------------------------------------------------------------------
;;;
;;;  Setup and Analysis Code
;;;

(defparameter *condition* 'hi)
(defparameter *conditions* '("CP-CC" "CP-IC" "IP-CC" "IP-IC" "Other"))
(defvar *v* nil)
(defvar *runs* 1)

(defparameter *data-soap* '(.42 .38 .02 .00 .18 .30 .18 .14 .08 .30))

(defvar *text* t)
(defvar *graphic* nil)
(defvar *overlay* nil)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; This section contains the interface for the WWW using the
;;; ACT-R on the Web application by Elmar Schwarz

(defvar *WWW-interface*)

(setf  *WWW-interface* 
      '((:heading "Soap-Opera Model" 2)
        
        (:new-para)

        (:table)
        
        (:table)
        "Similar-chunk mismatch: "   (:string :sy *estimated-similar-match* .1)  (:new-row)
        "Dissimilar-chunk mismatch: "   (:string :sy *estimated-different-match* 1.7)  (:new-row)
        "Pragmatic boost:" (:string :sy *estimated-pragmatic-boost* 50) (:new-row)
        "Nunber of Runs (1-400): " (:string :sy *runs* 100) 
        (:table-end)
        (:table)
        (:checkbox "Trace" :sy *v*  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 one graph" :sy *overlay*  nil) 
            
        (:table-end)
       (:table-end)
         
        
        (:new-para)
        (:button "Show Experiment Results" "(output-tables-soap *data-soap* nil)")
       (:new-para)
       (:button "Run model" " 

                               (if  (and (numberp *runs*) 
                                         (numberp *estimated-different-match*)
                                         (numberp *estimated-similar-match*)
                                         (numberp *estimated-pragmatic-boost*))
                                 (progn 
                                    (setf *estimated-different-match* (mismatch->similarity-soap *estimated-different-match*))
                                    (setf *estimated-similar-match* (mismatch->similarity-soap *estimated-similar-match*))
                                     
                                    (rr-soap (min 400 (max 1 *runs*)) ))
                                 (format *standard-output* \"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 less than 1 minute for 100 runs of the model" (:new-line)
        "- The trace of 1 run is about 2k (2 pages)"
        (:new-para)))


(defun mismatch->similarity-soap (mm)
  (- 1 (/ mm 10)))



(defun all-pairs-soap (lst)
  (when lst
    (append (mapcar #'(lambda (x) (list (first lst) x)) (rest lst))
            (all-pairs-soap (rest lst)))))

(defun my-set-similarities-soap (pairs value)
  (dolist (pair pairs)
    (set-similarities-fct (list (list (first pair) (second pair) value)))))

(defun my-set-references-soap (chunks value)
  (dolist (chunk chunks)
    (sdp-fct (list (list chunk :references value)))))

(defun r-soap (&optional (cnd 'hi)  (ct nil) (act nil) (others nil))
  (setf *condition* cnd)
  (reset)
  
  (sgp-fct (list  :ct ct :act act :cst others :pmt others :lt others :v *v*))

  (my-set-references-soap
   '(p1-bosses-Peter p1-bosses-Mary
     p2-bosses-Nancy p2-bosses-John p2-bosses-David p2-bosses-Lisa)
   (+ 50 *estimated-pragmatic-boost*))

  (my-set-similarities-soap
   (all-pairs-soap '(bosses boss bossed loves lover loved cheats cheater cheated person))
   *estimated-different-match*)
  
  (case *condition*
    (hi (add-dm (goal isa map-both source-object1 Peter source-object2 Mary
                      source-relation p1-bosses)))
    (t  (add-dm (goal isa map-both source-object1 Peter source-object2 Mary))))
  
  (goal-focus goal) 

  (run)
  
  (let ((peter (chunk-slot-value goal target-object1))
        (mary (chunk-slot-value goal target-object2)))
    (cond ((and (equalp peter 'nancy) (equalp mary 'john)) 0)
          ((and (equalp peter 'david) (equalp mary 'lisa)) 1)
          ((and (equalp peter 'lisa)  (equalp mary 'david)) 2)
          ((and (equalp peter 'john)  (equalp mary 'nancy)) 3)
          (t 4))))


(defun output-tables-soap (data sim)
  (unless *conditions*
    (setf *conditions* '("CP-CC" "CP-IC" "IP-CC" "IP-IC" "Other")))
  (when *text*
    (format *standard-output* "~%~A results...~%~%"
            (if sim "Model" "Experiment"))
    (let ((data-hi (butlast data 5))
          (data-lo (last data 5)))
      
      (format *standard-output* "Choices for the plot-extension task:~%~%")
      (format *standard-output* "Choice     Proportion-Choice~%")
      (format *standard-output* "-----------------------------~%")
      (dotimes (i (length data-hi))
        (format *standard-output* "~a      ~,2f~%"
                (nth i *conditions*) (nth i data-hi)))
      (format *standard-output* "~%")
      
      (format *standard-output* "Choices for the mapping task:~%~%")
      (format *standard-output* "Choice     Proportion-Choice~%")
      (format *standard-output* "-----------------------------~%")
      (dotimes (i (length data-lo))
        (format *standard-output* "~a      ~,2f~%"
                (nth i *conditions*) (nth i data-lo)))
      (format *standard-output* "~%"))
    
    (when (and sim *overlay*)
      (format *standard-output* "~%Experiment results...~%~%")
      (let ((data-hi (butlast *data-soap* 5))
            (data-lo (last *data-soap* 5)))
        
        (format *standard-output* "Choices for the plot-extension task:~%~%")
        (format *standard-output* "Choice     Proportion-Choice~%")
        (format *standard-output* "-----------------------------~%")
        (dotimes (i (length data-hi))
          (format *standard-output* "~a      ~,2f~%"
                  (nth i *conditions*) (nth i data-hi)))
        (format *standard-output* "~%")
        
        (format *standard-output* "Choices for the mapping task:~%~%")
        (format *standard-output* "Choice     Proportion-Choice~%")
        (format *standard-output* "-----------------------------~%")
        (dotimes (i (length data-lo))
          (format *standard-output* "~a      ~,2f~%"
                  (nth i *conditions*) (nth i data-lo)))
        (format *standard-output* "~%")))
               
    (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 = 410 
      height = 500> 
      
      <PARAM name=\"title\" value=\"Data for Soap-Opera Model\">
      <PARAM name=\"longestline\" value=\"5\">
      <PARAM name=\"numlines\" value=\"~S\">
      <PARAM name=\"xmin\" value=\"0\">
      <PARAM name=\"xmax\" value=\"5\">
      <PARAM name=\"ymax\" value=\"1.00\">
      <PARAM name=\"ymin\" value=\"0\">
      <PARAM name=\"ydiv\" value=\".05\">
      <PARAM name=\"yspacing\" value=\".10\">
      <PARAM name=\"numxlabels\" value=\"6\">
      <PARAM name=\"xlabels\" value=\" ;CP-CC;CP-IC;IP-CC;IP-IC;Other;\">
      <PARAM name=\"widestxlabel\" value=\"WWWWW\">
      <PARAM name=\"lcolor0\" value=\"0\">
      <PARAM name=\"lstyle0\" value=\"~s\">
      <PARAM name=\"xval0\" value=\"1;2;3;4;5;\">
      <PARAM name=\"name0\" value=\"~a data plot-extension task\">
      <PARAM name=\"lcolor1\" value=\"1\">
      <PARAM name=\"lstyle1\" value=\"~s\">
      <PARAM name=\"xval1\" value=\"1;2;3;4;5;\">
      <PARAM name=\"name1\" value=\"~a data mapping task\">
      
      <PARAM name=\"xname\" value=\"Choice\">
      <PARAM name=\"yname\" value=\"Proportion\">"
            (if (and sim *overlay*) 4 2)
            (if sim 2 6553)
            (if sim "Simulation" "Experimental")
            (if sim 2 6553)
            (if sim "Simulation" "Experimental")
            )
    
    
    (format *standard-output*
            "<PARAM name=\"yval0\" value=\"")
    (dotimes (i 5)
      (format *standard-output* "~4,3f;" (nth i data)))
    (format *standard-output* "\">")
    (format *standard-output*
            "<PARAM name=\"yval1\" value=\"")
    (dotimes (i 5)
      (format *standard-output* "~4,3f;" (nth (+ 5 i) data)))
    (format *standard-output* "\">")
   
    (when (and sim *overlay*)
      (format *standard-output* "
      <PARAM name=\"lcolor2\" value=\"0\">
      <PARAM name=\"lstyle2\" value=\"6553\">
      <PARAM name=\"xval2\" value=\"1;2;3;4;5;\">
      <PARAM name=\"name2\" value=\"Experimental data plot-extension task\">
      <PARAM name=\"lcolor3\" value=\"1\">
      <PARAM name=\"lstyle3\" value=\"6553\">
      <PARAM name=\"xval3\" value=\"1;2;3;4;5;\">
      <PARAM name=\"name3\" value=\"Experimental data mapping task\">")
      
      (format *standard-output*
              "<PARAM name=\"yval2\" value=\"")
      (dotimes (i 5)
        (format *standard-output* "~4,3f;" (nth i *data-soap*)))
      (format *standard-output* "\">")
      (format *standard-output*
              "<PARAM name=\"yval3\" value=\"")
      (dotimes (i 5)
        (format *standard-output* "~4,3f;" (nth (+ 5 i) *data-soap*)))
      (format *standard-output* "\">")
      )
    
    (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 rr-soap (&optional (n 100))
  (reset)
  (setf *condition* 'hi)
  (setf *conditions* '("CP-CC" "CP-IC" "IP-CC" "IP-IC" "Other"))
  
  (let* ((model-hi (list 0 0 0 0 0))
         (model-lo (list 0 0 0 0 0)))
    (dotimes (i n)
      (let ((result (r-soap 'hi)))
        (incf (nth result model-hi))))
    (dotimes (i n)
      (let ((result (r-soap 'lo)))
        (incf (nth result model-lo))))
    (dotimes (i 5)
      (setf (nth i model-hi) (/ (nth i model-hi) n)))
    (dotimes (i 5)
      (setf (nth i model-lo) (/ (nth i model-lo) n)))
    (let ((model (append model-hi model-lo)))
      
      (output-tables-soap model t))))

;;;-------------------------------------------------------------------------------
;;;</xmp><pre><a name="model">
;;;</a>
;;;
;;;  ACT-R Model
;;;

(clear-all)

(sgp :era t
     :er  t
     :pm  t
     :mp  10
     :bll .5
     :ans .5
     :egs .5
     :ga  0
     :lt  nil)

(progn
(chunk-type role parent parent-type slot child child-type)
(chunk-type (source-role   (:include role)))
(chunk-type (target-role (:include role)))
)

(add-dm
 (none isa chunk) (failure isa chunk)

 (bosses isa chunk) (boss isa chunk) (bossed isa chunk)
 (loves isa chunk) (lover isa chunk) (loved isa chunk)
 (cheats isa chunk) (cheater isa chunk) (cheated isa chunk)
 (person isa chunk)
 
 ;; story 1
 
 (p1-bosses isa chunk) (p1-loves isa chunk) (p1-cheats isa chunk)
 (Peter isa chunk) (Mary isa chunk) (Bill isa chunk)

 (p1-bosses-Peter isa source-role
                  parent p1-bosses parent-type bosses
                  slot boss
                  child Peter child-type person)
 (p1-bosses-Mary isa source-role
                 parent p1-bosses parent-type bosses
                 slot bossed
                 child Mary child-type person)

 (p1-loves-Peter isa source-role
                 parent p1-loves parent-type loves
                 slot lover
                 child Peter child-type person)
 (p1-loves-Mary isa source-role
                parent p1-loves parent-type loves
                slot loved
                child Mary child-type person)

 (p1-cheats-Peter isa source-role
                  parent p1-cheats parent-type cheats
                  slot cheater
                  child Peter child-type person)
 (p1-cheats-Mary isa source-role
                 parent p1-cheats parent-type cheats
                 slot cheated
                 child Bill child-type person)

 ;; story 2
 
 (p2-bosses1 isa chunk) (p2-loves1 isa chunk) (p2-cheats1 isa chunk)
 (p2-bosses2 isa chunk) (p2-loves2 isa chunk) (p2-cheats2 isa chunk)
 (Nancy isa chunk) (John isa chunk) (David isa chunk) (Lisa isa chunk)
 
 (p2-bosses-Nancy isa target-role
                  parent p2-bosses1 parent-type bosses
                  slot boss
                  child Nancy child-type person)
 (p2-bosses-John isa target-role
                 parent p2-bosses1 parent-type bosses
                 slot bossed
                 child John child-type person)
 (p2-bosses-David isa target-role
                  parent p2-bosses2 parent-type bosses
                  slot boss
                  child David child-type person)
 (p2-bosses-Lisa isa target-role
                 parent p2-bosses2 parent-type bosses
                 slot bossed
                 child Lisa child-type person)
 
 (p2-loves-John isa target-role
                 parent p2-loves1 parent-type loves
                 slot lover
                 child John child-type person)
 (p2-loves-Nancy isa target-role
                parent p2-loves1 parent-type loves
                slot loved
                child Nancy child-type person)
 (p2-loves-Lisa isa target-role
                 parent p2-loves2 parent-type loves
                 slot lover
                 child Lisa child-type person)
 (p2-loves-David isa target-role
                parent p2-loves2 parent-type loves
                slot loved
                child David child-type person)

 (p2-cheats-Nancy isa target-role
                  parent p2-cheats1 parent-type cheats
                  slot cheater
                  child Nancy child-type person)
 (p2-cheats-David isa target-role
                 parent p2-cheats1 parent-type cheats
                 slot cheated
                 child David child-type person)
 (p2-cheats-Lisa isa target-role
                  parent p2-cheats2 parent-type cheats
                  slot cheater
                  child Lisa child-type person)
 (p2-cheats-John isa target-role
                 parent p2-cheats2 parent-type cheats
                 slot cheated
                 child John child-type person)
 )

(sdp :references 50)


(progn

;;;
;;;  map-object
;;;

(chunk-type map-object
            source-object source-role target-role
            target-object void
            source-relation target-relation parent-type slot child-type)

(p Retrieve-Previous-Mapping
   =goal>
      isa map-object
      source-object =source-object
      source-role nil
      target-object nil
   =oldgoal>
      isa map-object
      source-object =source-object
      target-object =target-object
      - target-object failure
      void nil
==>
   !output! (Retrieved previous mapping =source-object to =target-object)
   =goal>
      target-object =target-object
   !pop!)

(p Retrieve-Source-Role
   =goal>
      isa map-object
      source-object =source-object
      source-role nil
      target-object nil
   =source-role>
      isa source-role
      child =source-object
==>
   !output! (Set source role to =source-role)
   =goal>
      source-role =source-role)

(spp Retrieve-Source-Role :r .6)

(p Reached-Source-Path-Root
   =goal>
      isa map-object
      source-object =source-object
      source-role nil
      target-object nil
==>
   !output! (Reached root relation =source-object)
   =goal>
      target-object failure
   !pop!)

(spp Reached-Source-Path-Root :r .2)

(p Retrieve-Components
   =goal>
      isa map-object
      source-role =source-role
      source-relation nil
      parent-type nil
      slot nil
      child-type nil
   =source-role>
      isa source-role
      parent =source-relation
      parent-type =parent-type
      slot =slot
      child-type =child-type
==>
   !output! (Set source relation to =source-relation "," parent type to =parent-type ",")
   !output! (slot to =slot "," and child type to =child-type)
   =goal>
      source-relation =source-relation
      parent-type =parent-type
      slot =slot
      child-type =child-type)

(spp Retrieve-Components :r .6)

(p Map-Source-Relation
   =goal>
      isa map-object
      source-relation =source-relation
      target-relation nil
==>
   !output! (Mapping =source-relation)
   =subgoal>
      isa map-object
      source-object =source-relation
      target-object =target-relation
   =goal>
      target-relation =target-relation
   !push! =subgoal)

(p Retrieve-Analog-At-Root
   =goal>
      isa map-object
      source-object =source-object
      source-relation =source-relation
      target-relation failure
      parent-type =parent-type
      slot =slot
      child-type =child-type
      target-role nil
   =target-role>
      isa target-role
      parent =target-relation
      parent-type =parent-type
      slot =slot
      child-type =child-type
      child =target-object
==>
   !output! (Retrieved analogous role =target-role)
   !output! (Mapped =source-relation to =target-relation)
   !output! (Mapped =source-object to =target-object)
   =subgoal>
      isa map-object
      source-object =source-relation
      target-object =target-relation
   =goal>
      target-object =target-object
   !focus-on! =subgoal)

(p Retrieve-Analog-Below-Root
   =goal>
      isa map-object
      source-object =source-object
      target-relation =target-relation
      - target-relation failure
      parent-type =parent-type
      slot =slot
      child-type =child-type
      target-role nil
   =target-role>
      isa target-role
      parent =target-relation
      parent-type =parent-type
      slot =slot
      child-type =child-type
      child =target-object
==>
   !output! (Retrieved analogous role =target-role)
   !output! (Mapped =source-object to =target-object)
   =goal>
      target-object =target-object
   !pop!)

(p Retrieve-Specific-Target-Role
   =goal>
      isa map-object
      source-object =source-object
      source-relation =source-relation
      parent-type =parent-type
      slot =slot
      child-type =child-type
      target-role =target-role
   =target-role>
      isa target-role
      parent-type =parent-type
      slot =slot
      child-type =child-type
      child =target-object
==>
   !output! (Retrieved specific role =target-role)
   !output! (Mapped =source-object to =target-object)
   =subgoal>
      isa map-object
      source-object =source-relation
      target-object =target-relation
   =goal>
      target-object =target-object
   !focus-on! =subgoal)

(p Done-Map-Object
   =goal>
      isa map-object
      source-object =source-object
      target-object =target-object
==>
   !pop!)

)

;;;
;;;  map-both
;;;

(chunk-type map-both
            source-object1 source-object2 source-relation
            target-object1 target-object2)

(p subgoal-map-object1-with-parent
   =goal>
      isa map-both
      source-object1 =source-object
      source-relation =source-relation
      target-object1 nil
   =source-role>
      isa source-role
      parent =source-relation
      child =source-object
==>
   !output! (Mapping =source-object with parent =source-relation)
   =subgoal>
      isa map-object
      source-object =source-object
      source-role =source-role
      target-object =target-object
   =goal>
      target-object1 =target-object
   !push! =subgoal)

(p subgoal-map-object1-without-parent
   =goal>
      isa map-both
      source-object1 =source-object
      source-relation nil
      target-object1 nil
==>
   !output! (Mapping =source-object)
   =subgoal>
      isa map-object
      source-object =source-object
      source-relation =source-relation
      target-object =target-object
   =goal>
      source-relation =source-relation
      target-object1 =target-object
   !push! =subgoal)

(p subgoal-map-object2-with-parent
   =goal>
      isa map-both
      source-object2 =source-object
      source-relation =source-relation
      target-object2 nil
      - target-object1 nil
   =source-role>
      isa source-role
      parent =source-relation
      child =source-object
==>
   !output! (Mapping =source-object with parent =source-relation)
   =subgoal>
      isa map-object
      source-object =source-object
      source-role =source-role
      target-object =target-object
   =goal>
      target-object2 =target-object
   !push! =subgoal)

(p subgoal-map-object2-without-parent
   =goal>
      isa map-both
      source-object2 =source-object
      target-object2 nil
      - target-object1 nil
==>
   !output! (Mapping =source-object)
   =subgoal>
      isa map-object
      source-object =source-object
      target-object =target-object
   =goal>
      target-object2 =target-object
   !push! =subgoal)

(spp subgoal-map-object2-without-parent :r .5)

(p done-map-both
   =goal>
      isa map-both
      - target-object1 nil
      - target-object2 nil
==>
   !pop!)