;;;<pre><xmp>
;;;===============================================================================
;;;
;;;  Probability-Problem Model
;;;  (Data from Ross, 1987, 1989)
;;;
;;;  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-misc-error* .98)

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

(defparameter *condition* 'pp)
(defparameter *conditions* '("+/+" "+/-" "0/+" "0/-" "0/0"))

(defparameter *data-prob-model* '(.60 .42 .54 .39 .48))

(defparameter *possible-r-pairs-prob-model*
  '((0.5 1) (0.4297569854495891 0.99) (0.3622329853874057 0.98) (0.2997417054096622 0.97)
    (0.24390820414711487 0.96) (0.19557031749304296 0.95) (0.15485012369050266 0.94)
    (0.12132960631340796 0.93) (0.09425604446442083 0.92) (0.07272368910745285 0.91)
    (0.055807219207169835 0.9) (0.042644771477401526 0.89) (0.03247996956598456 0.88)
    (0.024675599285335057 0.87) (0.0187102188088448 0.86) (0.014166035876688418 0.85)
    (0.010713457055882388 0.84) (0 0)))



(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 "Probability-Problem 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)
        "Probability of miscellaneous error [0, .5] " (:string :sy  *estimated-misc-error* .36) (:new-row) 
        "Nunber of Runs (1-300): " (: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-prob-model *data-prob-model* nil)")
       (:new-para)
       (:button "Run model" " 

                               (if  (and (numberp *runs*) 
                                         (numberp *estimated-different-match*)
                                         (numberp *estimated-similar-match*)
                                         (numberp *estimated-misc-error*))
                                 (if (and (>= *estimated-misc-error* 0) (<= *estimated-misc-error* .5))
                                   (progn 
                                    (setf *estimated-different-match* (mismatch->similarity-prob-model *estimated-different-match*))
                                    (setf *estimated-similar-match* (mismatch->similarity-prob-model *estimated-similar-match*))
                                    (setf *estimated-misc-error* (probability->r-prob-model *estimated-misc-error*)) 
                                    (rr-prob-model (min 300 (max 1 *runs*)) ))
                                   (format *standard-output* \"Probability of miscellaneous error must be in the range of 0 - .5.\"))
                                 (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 6k (4 pages)"
        (:new-para)))


(defun mismatch->similarity-prob-model (mm)
  (- 1 (/ mm 10)))



(defun probability->r-prob-model (p)
  (let ((best-diff 2) (best-r 1))
    (dolist (pair *possible-r-pairs-prob-model*)
      (let ((diff (abs (- p (first pair)))))
        (when (< diff best-diff)
          (setf best-diff diff
                best-r (second pair)))))
    best-r))




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

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

(defun r-prob-model (&optional (cnd 'pp)  (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*))
  (let* ((pair (case *condition*
               (pp '(cars mechanics))
               (pm '(mechanics cars))
               (0p '(computers students))
               (0m '(students computers))
               (00 '(students counselors))))
       (child1 (first pair))
       (child2 (second pair)))
  (eval
   `(add-dm
     (tg-assigns isa chunk)
     (tg-from isa chunk) (tg-to isa chunk)
     
     (tg-assigns-from isa target-role
                      parent tg-assigns parent-type assigns
                      slot from
                      child tg-from child-type ,child1)
     (tg-assigns-to isa target-role
                    parent tg-assigns parent-type assigns
                    slot to
                    child tg-to child-type ,child2))))

  (sdp :references 50)

  (my-set-similarities-prob-model
   (all-pairs-prob-model '(cars mechanics computers students counselors assigns from to))
   *estimated-different-match*)

  (my-set-similarities-prob-model
   '((cars computers) (mechanics students) (mechanics counselors) (students counselors))
   *estimated-similar-match*)

  (run)
  (if (equalp (chunk-slot-value goal target-object) 'tg-from)
      1
      0))


(defun output-tables-prob-model (data sim)
  (unless *conditions*
    (setf  *conditions* '( "+/+" "+/-" "0/+" "0/-" "0/0")))
  (when *text*
    (format *standard-output* "~%~A results showing the average proportion correct:~%~%"
            (if sim "Model" "Experiment"))
    (format *standard-output* "Condition     Correctness~%")
    (format *standard-output* "--------------------------~%")
    (dotimes (i (length data))
      (format *standard-output* "~a           ~,2f~%"
              (nth i *conditions*) (nth i data)))
    (format *standard-output* "~%")
    (when (and sim *overlay*)
      (format *standard-output* "~%Experiment results showing the average proportion correct:~%~%")
      (format *standard-output* "Condition     Correctness~%")
      (format *standard-output* "--------------------------~%")
      (dotimes (i (length data))
        (format *standard-output* "~a           ~,2f~%"
                (nth i *conditions*) (nth i *data-prob-model*)))
      (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 = 400 
      height = 400> 
      
      <PARAM name=\"title\" value=\"Data for Probability-Problem 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=\" ;+/+;+/-;0/+;0/-;0/0;\">
        <PARAM name=\"widestxlabel\" value=\"WWWW\">
         <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\">
      
      <PARAM name=\"xname\" value=\"Condition\">
      <PARAM name=\"yname\" value=\"Correctness\">"
            (if (and sim *overlay*) 2 1)
            (if sim 2 6553)
            (if sim "Simulation" "Experimental")
            )
    
    
    (format *standard-output*
            "<PARAM name=\"yval0\" value=\"")
    (dotimes (i (length data))
      (format *standard-output* "~4,3f;" (nth i data)))
    (format *standard-output* "\">")
    
    (when (and sim *overlay*)
      (format *standard-output* "
      <PARAM name=\"lcolor1\" value=\"0\">
        <PARAM name=\"lstyle1\" value=\"6553\">
      <PARAM name=\"xval1\" value=\"1;2;3;4;5;\">
      <PARAM name=\"name1\" value=\"Experimental data\">")
      
      (format *standard-output*
              "<PARAM name=\"yval1\" value=\"")
      (dotimes (i (length *data-prob-model*))
        (format *standard-output* "~4,3f;" (nth i *data-prob-model*)))
      (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-prob-model (&optional (n 100))
  (reset)
  (setf *condition* 'pp)
  (setf  *conditions* '( "+/+" "+/-" "0/+" "0/-" "0/0"))
  (let* ((conds '(pp pm 0p 0m 00))
         (model (list 0 0 0 0 0)))
    (dotimes (i (length conds))
      (let ((result 0))
        (dotimes (j n)
          (incf result (r-prob-model (nth i conds))))
        (setf (nth i model) (/ result n))))
    (output-tables-prob-model 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)

 (cars isa chunk) (mechanics isa chunk) (computers isa chunk)
 (students isa chunk) (counselors isa chunk)
 (assigns isa chunk) (from isa chunk) (to isa chunk)

 (bs-assigns isa chunk)
 (bs-cars isa chunk) (bs-mechanics isa chunk)

 (bs-assigns-cars isa source-role
                  parent bs-assigns parent-type assigns
                  slot from
                  child bs-cars child-type cars)
 (bs-assigns-mechanics isa source-role
                       parent bs-assigns parent-type assigns
                       slot to
                       child bs-mechanics child-type mechanics)
)




(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-or-misc-error
;;;

(chunk-type map-or-misc-error
            source-object
            target-object)

(p subgoal-map-object
   =goal>
      isa map-or-misc-error
      source-object =source-object
      target-object nil
==>
   !output! (Mapping =source-object)
   =subgoal>
      isa map-object
      source-object =source-object
      target-object =target-object
   =goal>
      target-object =target-object
   !push! =subgoal)

(p misc-error
   =goal>
      isa map-or-misc-error
      source-object =source-object
      target-object nil
==>
   !output! (Giving up)
   !pop!)

(eval `(spp misc-error :r ,*estimated-misc-error*))

(p done-map-or-misc-error
   =goal>
      isa map-or-misc-error
      source-object =source-object
      target-object =target-object
==>
   !output! (Mapped =source-object to =target-object)
   =goal>
      target-object =target-object
   !pop!)

;;;
;;;  Main Goal
;;;

(add-dm
 (goal isa map-or-misc-error source-object bs-cars))

(goal-focus goal)