;;;

;;;===============================================================================
;;;
;;;  Solar-System / Atom 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 "Solar System / Atom 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-ss-atom *estimated-different-match*))
                                     
                                    (r-ss-atom ))
                                 (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-ss-atom (mm)
  (- 1 (/ mm 10)))

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

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

(defun r-ss-atom (&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-ss-atom
   (all-pairs-ss-atom '(causes cause effect attracts attractor attracted
                        revolves revolver center sun planet nucleus electron))
   *estimated-different-match*)
  (setf *command-trace* ot)
  (run)
  (when ot (format t "~%~%Time: ~,2f s~%~%" (actr-time)))
  (if (and (equalp (chunk-slot-value goal1 target-object) 'at-electron)
           (equalp (chunk-slot-value goal2 target-object) 'at-nucleus))
      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)
 
 (causes isa chunk) (cause isa chunk) (effect isa chunk)
 (attracts isa chunk) (attractor isa chunk) (attracted isa chunk)
 (revolves isa chunk) (revolver isa chunk) (center isa chunk)
 (sun isa chunk) (planet isa chunk) (moon isa chunk)
 (nucleus isa chunk) (electron isa chunk)
 
 ;; solar system
 
 (ss-causes isa chunk)
 (ss-attracts isa chunk)
 (ss-revolves isa chunk)
 (ss-sun isa chunk)
 (ss-planet isa chunk)
 
 (ss-cause isa source-role
           parent ss-causes parent-type causes
           slot cause
           child ss-attracts child-type attracts)
 (ss-attractor isa source-role
               parent ss-attracts parent-type attracts
               slot attractor
               child ss-sun child-type sun)
 (ss-attracted isa source-role
               parent ss-attracts parent-type attracts
               slot attracted
               child ss-planet child-type planet)
 (ss-effect isa source-role
            parent ss-causes parent-type causes
            slot effect
            child ss-revolves child-type revolves)
 (ss-revolver isa source-role
              parent ss-revolves parent-type revolves
              slot revolver
              child ss-planet child-type planet)
 (ss-center isa source-role
            parent ss-revolves parent-type revolves
            slot center
            child ss-sun child-type sun)
 
 ;; atom
 
 (at-causes isa chunk)
 (at-attracts isa chunk)
 (at-revolves isa chunk)
 (at-nucleus isa chunk)
 (at-electron isa chunk)
 
 (at-cause isa target-role
           parent at-causes parent-type causes
           slot cause
           child at-attracts child-type attracts)
 (at-attractor isa target-role
               parent at-attracts parent-type attracts
               slot attractor
               child at-nucleus child-type nucleus)
 (at-attracted isa target-role
               parent at-attracts parent-type attracts
               slot attracted
               child at-electron child-type electron)
 (at-effect isa target-role
            parent at-causes parent-type causes
            slot effect
            child at-revolves child-type revolves)
 (at-revolver isa target-role
              parent at-revolves parent-type revolves
              slot revolver
              child at-electron child-type electron)
 (at-center isa target-role
            parent at-revolves parent-type revolves
            slot center
            child at-nucleus child-type nucleus)
 )

(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
 (goal1 isa map-object source-object ss-planet)
 (goal2 isa map-object source-object ss-sun))

(goal-focus goal2)
(push-goal goal1)