;;;<pre><xmp>
;;;===============================================================================
;;;
;;;  Country-Mapping 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-different-match* .83)

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

(defparameter *condition* 12)
(defparameter *mappings* nil)
(defparameter *errors* 0)

(defparameter *conditions* '("1->2" "2->1"))
(defvar *runs* 50)
(defvar *v* nil)

(defparameter *data-country* '(.00 .50))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; 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 "Country-Mapping Model" 2)
        
        (:new-para)

        (:table)
        
        (:table)
        "Dissimilar-chunk mismatch: "   (:string :sy *estimated-different-match* 1.7)  (:new-row)
        "Nunber of Runs (1-250): " (:string :sy *runs* 50) 
         
        (:table-end)
        (:table)
        (:checkbox "Trace" :sy *v*  nil)         
        (:table-end)
       (:table-end)
         
       
        (:new-para)
        (:button "Show Experiment Results" "(output-tables-country *data-country* nil)")
       (:new-para)
       (:button "Run model" " 

                               (if  (and (numberp *runs*) (numberp *estimated-different-match*))
                                 (progn 
                                    (setf *estimated-different-match* (mismatch->similarity-country *estimated-different-match*))
                                     
                                    (rr-country (min 250 (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 50 runs of the model" (:new-line)
        "- The trace of 1 run is about 6k (3 pages)"
        (:new-para)))


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

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

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

(defun r-country (cnd &optional  (ct t) (act nil) (others nil))
  (setf *condition* cnd
        *mappings* nil)
  (reset)
  (sgp-fct (list :ct ct :act act :cst others :pmt others :lt others :v *v*))
  (my-set-similarities-country
   (all-pairs-country '(richer stronger more less country))
   *estimated-different-match*)
  (run)
  (let ((count (+ (count 'Barebrute *mappings* :key #'first)
                  (count 'Barebrute *mappings* :key #'second))))
    (when (zerop count) (incf *errors*))
    (max 0 (- count 1))))


(defun output-tables-country (data sim)
  (unless *conditions*
    (setf  *conditions* '( "1->2" "2->1")))
  (format *standard-output*
          "~%~A results showing the proportion choice of non-isomorphic mappings:~%~%"
          (if sim "Model" "Experiment"))
  
  (format *standard-output* "Condition     Proportion-Choice~%")
  (format *standard-output* "--------------------------------~%")
  (dotimes (i (length data))
    (format *standard-output* "~a          ~,2f~%"
            (nth i *conditions*) (nth i data)))
  (format *standard-output* "~%"))

(defun rr-country (&optional (n 50))
  (setf *condition* 12)

  (setf  *mappings* nil)
  (setf  *errors* 0)
  (setf  *conditions* '( "1->2" "2->1"))

  (reset)
 
  (let* ((conds '(12 21))
         (model (list 0 0)))

    (dotimes (i (length conds))
      (let ((result 0))
 
       (dotimes (j n)
 
          (incf result (r-country (nth i conds))))

        (setf (nth i model) (/ result n))))

    (output-tables-country *data-country* nil)
    (output-tables-country 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)))
)

(chunk-type country next mapped)

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

 (richer isa chunk) (stronger isa chunk) (more isa chunk) (less isa chunk)
 (country isa chunk))

(let ((source-role (if (= *condition* 12) 'source-role 'target-role))
      (target-role (if (= *condition* 12) 'target-role 'source-role)))
  (eval
   `(add-dm

     ;; Source
     
     (Afflu isa country next Barebrute)
     (Barebrute isa country next Compak)
     (Compak isa country)
     (p1-richer isa chunk) (p1-stronger isa chunk)
     
     (p1-richer-1 isa ,source-role
                  parent p1-richer parent-type richer
                  slot more
                  child Afflu child-type country)
     (p1-richer-2 isa ,source-role
                  parent p1-richer parent-type richer
                  slot less
                  child Barebrute child-type country)
     
     (p1-stronger-1 isa ,source-role
                    parent p1-stronger parent-type stronger
                    slot more
                    child Barebrute child-type country)
     (p1-stronger-2 isa ,source-role
                    parent p1-stronger parent-type stronger
                    slot less
                    child Compak child-type country)
     
     ;; Target
     
     (Grainwell isa country next Hungerall)
     (Hungerall isa country next Millpower)
     (Millpower isa country next Mightless)
     (Mightless isa country)
     (p2-richer isa chunk) (p2-stronger isa chunk)
     
     (p2-richer-1 isa ,target-role
                  parent p2-richer parent-type richer
                  slot more
                  child Grainwell child-type country)
     (p2-richer-2 isa ,target-role
                  parent p2-richer parent-type richer
                  slot less
                  child Hungerall child-type country)
     
     (p2-stronger-1 isa ,target-role
                    parent p2-stronger parent-type stronger
                    slot more
                    child Millpower child-type country)
     (p2-stronger-2 isa ,target-role
                    parent p2-stronger parent-type stronger
                    slot less
                    child Mightless child-type country)
     )))

(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 Childs
;;;

(chunk-type map-objects
            source-object
            target-object written)

(p subgoal-map-object
   =goal>
      isa map-objects
      source-object =source-object
      target-object nil
==>
   !output! (Mapping source child =source-object)
   =subgoal>
      isa map-object
      source-object =source-object
      target-object =target-object
   =goal>
      target-object =target-object
   !push! =subgoal)

(p map-objects
   =goal>
      isa map-objects
      source-object =source-object
      target-object =target-object
      written nil
   =target-object>
      isa country
==>
   !output! (Writing mapping =source-object to =target-object)
   !eval! (push (list =source-object =target-object) *mappings*)
   =target-object>
      mapped t
   =goal>
      written t)

(p skip-map-objects
   =goal>
      isa map-objects
      source-object =source-object
      target-object =target-object
      written nil
   =target-object>
      isa country
      mapped t
==>
   !output! (Not writing mapping =source-object to =target-object)
   =goal>
      written t)

(p goto-next-child
   =goal>
      isa map-objects
      source-object =source-object
      target-object =target-object
      written t
   =source-object>
      isa country
      next =next
==>
   =goal>
      source-object =next
      target-object nil
      written nil)

(p done-map-objects
   =goal>
      isa map-objects
      source-object =source-object
      target-object =target-object
      written t
   =source-object>
      isa country
      next nil
==>
   !output! (Done mapping childs)
   !pop!)

;;;
;;;  Main Goal
;;;

(let ((child (if (= *condition* 12) 'Afflu 'Grainwell)))
  (eval
   `(add-dm (goal isa map-objects source-object ,child))))

(goal-focus goal)