;;;

;;;===============================================================================
;;;
;;;  Sharing Model
;;;
;;;  Dario D. Salvucci & John R. Anderson
;;;  "Integrating Analogical Mapping and General Problem Solving:
;;;   The Path-Mapping Theory"
;;;

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

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


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

        (:table)
        
        (:table)
        "Dissimilar-chunk mismatch: "   (:string :sy *estimated-different-match* 1.7)  
        (:table-end)
         
        (:table-end)
        
         (:new-para)
        (:button "Run model" " 

                               (if  (numberp *estimated-different-match*)
                                 (progn 
                                    (setf *estimated-different-match* (mismatch->similarity-sharing *estimated-different-match*))
                                     
                                    (r-sharing ))
                                 (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:"
        (:new-para)
        "- It usually takes less than 1 minute to run the model"
        (:new-para)))
;;;-------------------------------------------------------------------------------
;;;
;;;  Setup and Analysis Code
;;;

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

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

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

(defun r-sharing (&optional (ot t) (ct nil) (act nil) (others nil))
  (reset)
  (sgp-fct (list :ot ot :ct ct :act act :cst others :pmt others)); :lt others))
  (my-set-similarities-sharing
   (all-pairs-sharing '(candy toys person shares sharer sharee child))
   *estimated-different-match*)
  (setf *command-trace* ot)
  (run)
  (if (equalp (chunk-slot-value goal target-object) 'tg-toys)
      1
      0))

;;;-------------------------------------------------------------------------------
;;;

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

 (candy isa chunk) (toys isa chunk) (person isa chunk)
 (shares isa chunk) (sharer isa chunk) (sharee isa chunk) (child isa chunk)

 ;; Source

 (bs-shares isa chunk)
 (bs-Jim isa chunk) (bs-Cathy isa chunk) (bs-candy isa chunk)

 (bs-shares-Jim isa source-role
                parent bs-shares parent-type shares
                slot sharer
                child bs-Jim child-type person)
 (bs-shares-Cathy isa source-role
                  parent bs-shares parent-type shares
                  slot sharee
                  child bs-Cathy child-type person)
 (bs-shares-candy isa source-role
                  parent bs-shares parent-type shares
                  slot child
                  child bs-candy child-type candy)

 ;; Target

 (tg-shares isa chunk)
 (tg-Cindy isa chunk) (tg-toys isa chunk)

 (tg-shares-Cindy isa target-role
                  parent tg-shares parent-type shares
                  slot sharer
                  child tg-Cindy child-type person)
 (tg-shares-toys isa target-role
                 parent tg-shares parent-type shares
                 slot child
                 child tg-toys 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!)

)

;;;
;;;  Main Goal
;;;

(add-dm (goal isa map-object source-object bs-candy))

(goal-focus goal)