;;;<pre><xmp>
;;;===============================================================================
;;;
;;;  Attribute-Mapping Model
;;;  (Data from Keane, Ledgeway, & Duff, 1994)
;;;
;;;  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)

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

(defparameter *condition* 'sf)
(defparameter *mappings* nil)
(defparameter *success* nil)
(defparameter *runs* 0)
(defparameter *reruns* 0)
(defvar *v* nil)
(defvar *model-runs* 20)
(defparameter *conditions* '("all-similar" "one-similar" "singleton-first"
                               "none-similar / singleton-last"))

(defparameter *data-attrib* '(70 160 180 285))

(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 "Attribute-Mapping 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)
        "Nunber of Runs (1-100): " (:string :sy *model-runs* 20) 
         
        (: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-attrib *data-attrib* nil)")
       (:new-para)
       (:button "Run model" " 

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


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


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

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

(defun r-attrib (cnd &optional  (ct nil) (act nil) (others nil))
  (setf *condition* cnd
        *mappings* nil
        *success* nil)
  (reset)
  (sgp-fct (list  :ct ct :act act :cst others :pmt others :lt others :v *v*))
  
  (if (member *condition* '(ns-sl os as))
      
      (add-dm
       (p1-relation-1 isa source-relation pos i1 name smart)
       (p1-relation-2 isa source-relation pos i2 name tall)
       (p1-relation-3 isa source-relation pos i3 name timid)
       (p1-relation-4 isa source-relation pos i4 name tall)
       (p1-relation-5 isa source-relation pos i5 name smart)
       (p1-object-1 isa source-object pos i1 name Bill)
       (p1-object-2 isa source-object pos i2 name Bill)
       (p1-object-3 isa source-object pos i3 name Tom)
       (p1-object-4 isa source-object pos i4 name Tom)
       (p1-object-5 isa source-object pos i5 name Steve)
       (p1-role1 isa source-role
                 parent p1-relation-1 parent-type smart slot thing
                 child p1-object-1 child-type name)
       (p1-role2 isa source-role
                 parent p1-relation-2 parent-type tall slot thing
                 child p1-object-2 child-type name)
       (p1-role3 isa source-role
                 parent p1-relation-3 parent-type timid slot thing
                 child p1-object-3 child-type name)
       (p1-role4 isa source-role
                 parent p1-relation-4 parent-type tall slot thing
                 child p1-object-4 child-type name)
       (p1-role5 isa source-role
                 parent p1-relation-5 parent-type smart slot thing
                 child p1-object-5 child-type name))
      (add-dm
       (p1-relation-1 isa source-relation pos i1 name smart)
       (p1-relation-2 isa source-relation pos i2 name tall)
       (p1-relation-3 isa source-relation pos i3 name smart)
       (p1-relation-4 isa source-relation pos i4 name tall)
       (p1-relation-5 isa source-relation pos i5 name timid)
       (p1-object-1 isa source-object pos i1 name Steve)
       (p1-object-2 isa source-object pos i2 name Bill)
       (p1-object-3 isa source-object pos i3 name Bill)
       (p1-object-4 isa source-object pos i4 name Tom)
       (p1-object-5 isa source-object pos i5 name Tom)
       (p1-role1 isa source-role
                 parent p1-relation-1 parent-type smart slot thing
                 child p1-object-1 child-type name)
       (p1-role2 isa source-role
                 parent p1-relation-2 parent-type tall slot thing
                 child p1-object-2 child-type name)
       (p1-role3 isa source-role
                 parent p1-relation-3 parent-type smart slot thing
                 child p1-object-3 child-type name)
       (p1-role4 isa source-role
                 parent p1-relation-4 parent-type tall slot thing
                 child p1-object-4 child-type name)
       (p1-role5 isa source-role
                 parent p1-relation-5 parent-type timid slot thing
                 child p1-object-5 child-type name)))
  
  (cond ((member *condition* '(ns-sl sf))
         (add-dm
          (p2-relation-1 isa target-relation pos i1 name hungry)
          (p2-relation-2 isa target-relation pos i2 name friendly)
          (p2-relation-3 isa target-relation pos i3 name frisky)
          (p2-relation-4 isa target-relation pos i4 name hungry)
          (p2-relation-5 isa target-relation pos i5 name friendly)
          (p2-object-1 isa target-object pos i1 name Fido)
          (p2-object-2 isa target-object pos i2 name Blackie)
          (p2-object-3 isa target-object pos i3 name Blackie)
          (p2-object-4 isa target-object pos i4 name Rover)
          (p2-object-5 isa target-object pos i5 name Rover)
          (p2-role1 isa target-role
                    parent p2-relation-1 parent-type hungry slot thing
                    child p2-object-1 child-type name)
          (p2-role2 isa target-role
                    parent p2-relation-2 parent-type friendly slot thing
                    child p2-object-2 child-type name)
          (p2-role3 isa target-role
                    parent p2-relation-3 parent-type frisky slot thing
                    child p2-object-3 child-type name)
          (p2-role4 isa target-role
                    parent p2-relation-4 parent-type hungry slot thing
                    child p2-object-4 child-type name)
          (p2-role5 isa target-role
                    parent p2-relation-5 parent-type friendly slot thing
                    child p2-object-5 child-type name)))
        ((equalp *condition* 'os)
         (add-dm
          (p2-relation-1 isa target-relation pos i1 name clever)
          (p2-relation-2 isa target-relation pos i2 name friendly)
          (p2-relation-3 isa target-relation pos i3 name frisky)
          (p2-relation-4 isa target-relation pos i4 name clever)
          (p2-relation-5 isa target-relation pos i5 name friendly)
          (p2-object-1 isa target-object pos i1 name Fido)
          (p2-object-2 isa target-object pos i2 name Blackie)
          (p2-object-3 isa target-object pos i3 name Blackie)
          (p2-object-4 isa target-object pos i4 name Rover)
          (p2-object-5 isa target-object pos i5 name Rover)
          (p2-role1 isa target-role
                    parent p2-relation-1 parent-type clever slot thing
                    child p2-object-1 child-type name)
          (p2-role2 isa target-role
                    parent p2-relation-2 parent-type friendly slot thing
                    child p2-object-2 child-type name)
          (p2-role3 isa target-role
                    parent p2-relation-3 parent-type frisky slot thing
                    child p2-object-3 child-type name)
          (p2-role4 isa target-role
                    parent p2-relation-4 parent-type clever slot thing
                    child p2-object-4 child-type name)
          (p2-role5 isa target-role
                    parent p2-relation-5 parent-type friendly slot thing
                    child p2-object-5 child-type name)))
        ((equalp *condition* 'as)
         (add-dm
          (p2-relation-1 isa target-relation pos i1 name clever)
          (p2-relation-2 isa target-relation pos i2 name big)
          (p2-relation-3 isa target-relation pos i3 name shy)
          (p2-relation-4 isa target-relation pos i4 name clever)
          (p2-relation-5 isa target-relation pos i5 name big)
          (p2-object-1 isa target-object pos i1 name Fido)
          (p2-object-2 isa target-object pos i2 name Blackie)
          (p2-object-3 isa target-object pos i3 name Blackie)
          (p2-object-4 isa target-object pos i4 name Rover)
          (p2-object-5 isa target-object pos i5 name Rover)
          (p2-role1 isa target-role
                    parent p2-relation-1 parent-type clever slot thing
                    child p2-object-1 child-type name)
          (p2-role2 isa target-role
                    parent p2-relation-2 parent-type big slot thing
                    child p2-object-2 child-type name)
          (p2-role3 isa target-role
                    parent p2-relation-3 parent-type shy slot thing
                    child p2-object-3 child-type name)
          (p2-role4 isa target-role
                    parent p2-relation-4 parent-type clever slot thing
                    child p2-object-4 child-type name)
          (p2-role5 isa target-role
                    parent p2-relation-5 parent-type big slot thing
                    child p2-object-5 child-type name))))
  
  (sdp :references 50)
  
  (my-set-similarities-attrib
   (all-pairs-attrib '(smart clever tall big timid shy hungry friendly frisky name thing))
   *estimated-different-match*)
  
  (my-set-similarities-attrib
   '((smart clever) (tall big) (timid shy))
   *estimated-similar-match*)
  
  (run)
  (incf *runs*)
  (if *success*
      (actr-time)
      (progn
        (incf *reruns*)
        (when (< *reruns* 500) (r-attrib cnd ct act others)))))


(defun output-tables-attrib (data sim)
  (unless *conditions*
    (setf  *conditions* '( "all-similar" "one-similar" "singleton-first"
                             "none-similar / singleton-last")))
  
  (when *text*
    (format *standard-output* "~%~A results showing the average latency in seconds:~%~%"
            (if sim "Model" "Experiment"))
    
    (format *standard-output* "Condition                         Latency~%")
    (format *standard-output* "------------------------------------------~%")
    (dotimes (i (length data))
      (format *standard-output* "~30a    ~d~%"
              (nth i *conditions*) (nth i data)))
    (format *standard-output* "~%")
    
    (when sim
      (format *standard-output* "[ Failed runs: ~a/~a (~,1f%) ]~%~%"
              *reruns* (+ (* 4 *runs*) *reruns*)
              (* 100 (/ *reruns* (+ (* 4 *runs*) *reruns*)))))
    
    (when (and sim *overlay*)
      
      
      (format *standard-output* "~%Experiment results showing the average latency in seconds:~%~%")
      
      (format *standard-output* "Condition                         Latency~%")
      (format *standard-output* "------------------------------------------~%")
      (dotimes (i (length data))
        (format *standard-output* "~30a    ~d~%"
                (nth i *conditions*) (nth i *data-attrib*)))
      (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 = 500 
      height = 400> 
      
      <PARAM name=\"title\" value=\"Data for Attribute-Mapping Model\">
      <PARAM name=\"longestline\" value=\"4\">
      <PARAM name=\"numlines\" value=\"~S\">
      <PARAM name=\"xmin\" value=\"0\">
      <PARAM name=\"xmax\" value=\"3\">
      <PARAM name=\"ymax\" value=\"400\">
      <PARAM name=\"ymin\" value=\"0\">
      <PARAM name=\"ydiv\" value=\"50\">
      <PARAM name=\"yspacing\" value=\"100\">
      <PARAM name=\"numxlabels\" value=\"4\">
        <PARAM name=\"xlabels\" value=\"all-similar;one-similar;singleton-first;n-s/s-l;\">
        <PARAM name=\"widestxlabel\" value=\"WWWWWWWWWWWWWWW\">
         <PARAM name=\"lcolor0\" value=\"0\">
      <PARAM name=\"lstyle0\" value=\"~s\">
      <PARAM name=\"xval0\" value=\"0;1;2;3;\">
      <PARAM name=\"name0\" value=\"~a data\">
      
      <PARAM name=\"xname\" value=\"Condition\">
      <PARAM name=\"yname\" value=\"Latency (ms)\">"
            (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* "~6,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=\"0;1;2;3;\">
      <PARAM name=\"name1\" value=\"Experimental data\">")
      
      (format *standard-output*
              "<PARAM name=\"yval1\" value=\"")
      (dotimes (i (length *data-attrib*))
        (format *standard-output* "~6,3f;" (nth i *data-attrib*)))
      (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-attrib (&optional (n 20))
  (reset)
  (setf *condition* 'sf)
  (setf  *mappings* nil)
  (setf  *success* 0)
  (setf  *reruns* 0)
  (setf  *runs* 0)
  (setf  *conditions* '( "all-similar" "one-similar" "singleton-first"
                           "none-similar / singleton-last"))
  (setf *runs* 0 *reruns* 0)
  (let* ((conds '(as os sf ns-sl))
         (model (list 0 0 0 0)))
    (dotimes (i (length conds))
      (let ((result 0))
        (dotimes (j n)
          (incf result (r-attrib (nth i conds))))
        (setf (nth i model) (round (/ result n)))))
    
    (output-tables-attrib model t)))

;;;-------------------------------------------------------------------------------
;;;
;;;  Visual Interface Routines
;;;

(defun vi-read-relation-attrib (story pos)
  (if (equalp story 'i1)
      (case pos
        (i1 'p1-relation-1) (i2 'p1-relation-2) (i3 'p1-relation-3)
        (i4 'p1-relation-4) (i5 'p1-relation-5))
      (case pos
        (i1 'p2-relation-1) (i2 'p2-relation-2) (i3 'p2-relation-3)
        (i4 'p2-relation-4) (i5 'p2-relation-5))))

(defun vi-read-object-attrib (story pos)
  (if (equalp story 'i1)
      (case pos
        (i1 'p1-object-1) (i2 'p1-object-2) (i3 'p1-object-3)
        (i4 'p1-object-4) (i5 'p1-object-5))
      (case pos
        (i1 'p2-object-1) (i2 'p2-object-2) (i3 'p2-object-3)
        (i4 'p2-object-4) (i5 'p2-object-5))))

(defun vi-push-mapping-attrib (o1 o2)
  (let ((n1 (chunk-slot-value-fct o1 'name))
        (n2 (chunk-slot-value-fct o2 'name)))
    (push (list n1 n2) *mappings*)))

(defun vi-mapping-conflicts-attrib (o1 o2)
  (let ((n1 (chunk-slot-value-fct o1 'name))
        (n2 (chunk-slot-value-fct o2 'name)))
    (some #'(lambda (mapping)
              (or (and (equalp n1 (first mapping))
                       (not (equalp n2 (second mapping))))
                  (and (not (equalp n1 (first mapping)))
                       (equalp n2 (second mapping)))))
          *mappings*)))

(defun vi-pop-mapping-attrib ()
  (pop *mappings*))

;;;-------------------------------------------------------------------------------
;;;</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 relation pos name)
(chunk-type (source-relation (:include relation)))
(chunk-type (target-relation (:include relation)))

(chunk-type object pos name)
(chunk-type (source-object (:include object)))
(chunk-type (target-object (:include object)) tried)

(chunk-type position next)

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

 (Steve isa chunk) (Bill isa chunk) (Tom isa chunk)
 (Fido isa chunk) (Blackie isa chunk) (Rover isa chunk)

 (smart isa chunk) (clever isa chunk)
 (tall isa chunk) (big isa chunk)
 (timid isa chunk) (shy isa chunk)
 (hungry isa chunk) (friendly isa chunk) (frisky isa chunk)
 (name isa chunk) (thing isa chunk)
 
 (i1 isa position next i2) (i2 isa position next i3) (i3 isa position next i4)
 (i4 isa position next i5) (i5 isa position next nil)
)







(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!)

)

;;;
;;;  Create Mappings
;;;

(chunk-type create-mappings
            source-pos target-pos
            result
            source-object target-object source-relation target-relation)

(p create-retrieve-source-object-and-parent
   =goal>
      isa create-mappings
      source-pos =pos
      source-object nil
      source-relation nil
   !bind! =source-object (vi-read-object-attrib 'i1 =pos)
   !bind! =source-relation (vi-read-relation-attrib 'i1 =pos)
==>
   =goal>
      source-object =source-object
      source-relation =source-relation)

(p create-retrieve-target-object-and-parent
   =goal>
      isa create-mappings
      target-pos =pos
      target-object nil
      target-relation nil
   !bind! =target-object (vi-read-object-attrib 'i2 =pos)
   !bind! =target-relation (vi-read-relation-attrib 'i2 =pos)
==>
   =goal>
      target-object =target-object
      target-relation =target-relation)

(p child-mapping-conflicts
   =goal>
      isa create-mappings
      source-object =source-object
      target-object =target-object
   !eval! (vi-mapping-conflicts-attrib =source-object =target-object)
==>
   !output! (Found conflicting mapping for =source-object to =target-object)
   =goal>
      result failure
   !pop!)

(p parent-mapping-conflicts
   =goal>
      isa create-mappings
      source-relation =source-relation
      target-relation =target-relation
   !eval! (vi-mapping-conflicts-attrib =source-relation =target-relation)
==>
   !output! (Found conflicting mapping for =source-relation to =target-relation)
   =goal>
      result failure
   !pop!)

(p write-mappings
   =goal>
      isa create-mappings
      source-relation =source-relation
      source-object =source-object
      target-relation =target-relation
      target-object =target-object
==>
   !output! (Mapping =source-object to =target-object)
   !output! (Mapping =source-relation to =target-relation)
   !eval! (vi-push-mapping-attrib =source-object =target-object)
   !eval! (vi-push-mapping-attrib =source-relation =target-relation)
   =goal>
      result success
   !pop!)

(spp write-mappings :r .5)

;;;
;;;  Erase Mappings
;;;

(chunk-type erase-mappings
            source-pos target-pos
            
            source-relation source-object target-relation target-object)

(p erase-retrieve-source-object-and-parent
   =goal>
      isa erase-mappings
      source-pos =pos
      source-object nil
      source-relation nil
   !bind! =source-object (vi-read-object-attrib 'i1 =pos)
   !bind! =source-relation (vi-read-relation-attrib 'i1 =pos)
==>
   =goal>
      source-object =source-object
      source-relation =source-relation)

(p erase-retrieve-target-object-and-parent
   =goal>
      isa erase-mappings
      target-pos =pos
      target-object nil
      target-relation nil
   !bind! =target-object (vi-read-object-attrib 'i2 =pos)
   !bind! =target-relation (vi-read-relation-attrib 'i2 =pos)
==>
   =goal>
      target-object =target-object
      target-relation =target-relation)

(p erase-mappings
   =goal>
      isa erase-mappings
      source-relation =source-relation
      source-object =source-object
      target-relation =target-relation
      target-object =target-object
==>
   !output! (Erasing mapping =source-object to =target-object)
   !output! (Erasing mapping =source-relation to =target-relation)
   !eval! (vi-pop-mapping-attrib)
   !eval! (vi-pop-mapping-attrib)
   !pop!)

;;;
;;;  Void Mappings
;;;

(chunk-type void-mappings
            )

(p void-mapping
   =goal>
      isa void-mappings
   =map>
      isa map-object
      source-object =source-object
      target-object =target-object
      void nil
==>
   !output! (Voided mapping =source-object to =target-object)
   =map>
      void t)

(p done-void-mappings
   =goal>
      isa void-mappings
==>
   !pop!)

(spp done-void-mappings :r .5)

;;;
;;;  Find Analog Position
;;;

(chunk-type find-analog-position
            source-pos
            target-pos
            source-object target-object)

(p retrieve-source-role2
   =goal>
      isa find-analog-position
      source-pos =pos
      source-object nil
   !bind! =source-object (vi-read-object-attrib 'i1 =pos)
==>
   =goal>
      source-object =source-object)

(p subgoal-map-object
   =goal>
      isa find-analog-position
      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 find-analog-position-success
   =goal>
      isa find-analog-position
      target-object =target-object
   =target-object>
      isa target-object
      pos =pos
      tried nil
==>
   !output! (Trying analog position =pos)
   !eval! (vi-read-object-attrib 'i2 =pos)
   =target-object>
      tried t
   =subgoal>
      isa void-mappings
   =goal>
      target-pos =pos
   !focus-on! =subgoal)

(p find-analog-position-failure
   =goal>
      isa find-analog-position
      target-object =target-object
   =target-object>
      isa target-object
      pos =pos
      tried t
==>
   !output! (Failed to retrieve untried analog)
   =subgoal>
      isa void-mappings
   =goal>
      target-pos failure
   !focus-on! =subgoal)

;;;
;;;  Try Mappings
;;;

(chunk-type try-mappings
            source-pos
            result
            reset done-retrievals target-pos created more-result)

(p start-try-mappings
   =goal>
      isa try-mappings
      source-pos =source-pos
      reset nil
      target-pos nil
==>
   !output! (Starting mapping process for source-pos =source-pos)
   =goal>
      reset t)

(p get-analog-position-by-retrieval
   =goal>
      isa try-mappings
      source-pos =source-pos
      reset t
      done-retrievals nil
==>
   !output! (Getting analog position by retrieval)
   =subgoal>
      isa find-analog-position
      source-pos =source-pos
      target-pos =target-pos
   =goal>
      reset nil
      target-pos =target-pos
   !push! =subgoal)

(p get-analog-position-by-retrieval-failure
   =goal>
      isa try-mappings
      target-pos failure
==>
   !output! (Failed to get analog position by retrieval)
   =goal>
      done-retrievals t
      target-pos i1)

(p get-analog-position-by-next-1
   =goal>
      isa try-mappings
      source-pos =source-pos
      reset t
      done-retrievals t
      target-pos =target-pos
   =target-pos>
      isa position
      next =next
==>
   !output! (Getting analog position by next)
   =goal>
      reset nil
      target-pos =next)

(p subgoal-create-mappings
   =goal>
      isa try-mappings
      source-pos =source-pos
      reset nil
      target-pos =target-pos
      - target-pos failure
      created nil
==>
   !output! (Creating mappings for =source-pos =target-pos)
   =subgoal>
      isa create-mappings
      source-pos =source-pos
      target-pos =target-pos
      result =result
   =goal>
      created =result
   !push! =subgoal)

(p create-mappings-failure
   =goal>
      isa try-mappings
      source-pos =source-pos
      target-pos =target-pos
      created failure
==>
   =goal>
      reset t
      created nil)

(p create-mappings-success-1
   =goal>
      isa try-mappings
      source-pos =source-pos
      created success
      more-result nil
   =source-pos>
      isa position
      next =next
==>
   =subgoal>
      isa try-mappings
      source-pos =next
      result =result
   =goal>
      more-result =result
   !push! =subgoal)

(p create-mappings-success-2
   =goal>
      isa try-mappings
      source-pos i5
      created success
      more-result nil
==>
   !output! (Success!!!)
   !eval! (setf *success* t)
   =goal>
      result success
   !pop!)

(p try-more-mappings-failure
   =goal>
      isa try-mappings
      source-pos =source-pos
      target-pos =target-pos
      created success
      more-result failure
==>
   =subgoal>
      isa erase-mappings
      source-pos =source-pos
      target-pos =target-pos
   =goal>
      reset t
      created nil
      more-result nil
   !push! =subgoal)

(p try-more-mappings-success
   =goal>
      isa try-mappings
      target-pos =target-pos
      created success
      more-result success
==>
   =goal>
      result success
   !pop!)

;;;
;;;  Final
;;;

(add-dm (goal isa try-mappings source-pos i1))

(goal-focus goal)