#|<pre><xmp>
 Header:

 In Budiu & Anderson's (2001) experiment, participants read a short passage and
then had to verify whether a probe sentence was true or false based on
that passage. The probe could be either metaphoric or literal and
either true (target) or false (foil).  Metaphors were always used
anaphorically: the metaphoric word referred to some concept previously
introduced in the passage, but absent from the current sentence.
The foils could be further classified as easy or hard: the
easy foils were designed such as the participants could reject them
even without understanding the metaphor; the hard foils could not be
answered correctly without first resolving the referent of the
metaphor.  Participants were less accurate and slower on metaphoric targets
or metaphoric hard foils than on literal targets or literal hard
foils, respectively (the effects were significant); however, they
performed comparably on metaphoric and literal easy foils (the latency
effects were not significant). |#

(defvar *text* t)
(defvar *graphic* nil)
(defvar *v* nil)
(defvar *overlay* nil)

(defvar *task*)
(defparameter +VERIFICATION+ 1)
(setq *task* +VERIFICATION+)

(defvar *lf*)
(setq *lf* .05) 

(defvar *rt*)
(setq *rt*  -1.4)

(defparameter *true-met* 0.19)
(defparameter *true-lit* 0.36)

(defvar *data-learning*)

(setq *data-learning*
      '((.53 .90 1.00 .85 .73 .88) (4.5 3.59 4.18 4.46 4.41 3.80)))
      

(defvar *WWW-interface*)
(setf  *WWW-interface* 
      '((:heading "Budiu & Anderson (in press)" 2)
        (:table)
        
        (:table)
        "Latency Scale : "        (:string :sy *lf*  .05)   (:new-row)
        "Retrieval Threshold: "   (:string :sy *rt*  -1.4)  (:new-row)
        "Similarity metaphor -- referent in text: "   (:string :sy *true-met*  .19)     (:new-row)
	"Similarity literal -- referent in text: "   (:string :sy *true-lit*  .36)     (:new-row)
         (:table-end)
        
        (:table)
        (:checkbox "Trace" :sy *v*  nil)  (:new-row)
        ;(:checkbox "Text output" :sy   t) (:new-row)
        ;(:checkbox "Graphic output" :sy *graphic*  nil) (:new-row)
        ;(:checkbox "Show both simulation and experiment data" :sy *overlay*  nil) 
        (:table-end)
        
        (:table-end)
         
        
         (:new-para)
         
        (:button "Show Experimental Results" "(display-learning *data-learning* )")
           
        (:new-para)
        
        (:button "Run model" "(if (and (numberp *lf*) (numberp *rt*) (numberp *true-lit*)
                                       (numberp *true-met*)) 
                                  (predictions-all 1  *v* *lf* *rt* *true-met*  *true-lit*)
                                  (format *standard-output* \"All 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 about 2 minutes to run the model"
        (:new-line)
        "- The trace of 1 run is approximately 28 Kbytes (about 15 pages) in size"
        (:new-para)))


(defun display-learning (data)
  (format *standard-output* "~%Experimental Data")
  (dotimes (i 2)
    (format *standard-output* "~2%~[Percent Correct~;RTs (sec.)~]" i)
    (format *standard-output* "~&~16TMet~24TLit")
    (dotimes (index (length (nth i data)))
      (when (zerop (mod index 2))
	(format *standard-output* "~&~[Targets~;Easy foils~;Hard foils~]~13T" (truncate (/ index 2))))
      (format *standard-output*  "~6,2F~T" (nth index (nth i data))))))
  

(defvar *read*)				;time to read-word
(setq *read* 0.15) 

(defvar *give-up*)
(setq *give-up* 0.975)			;probability to give up searching for 
					;an interpretation if current interpretation
					;does not match
(defvar *give-up-w-ant*)
(setq *give-up-w-ant* 0.98)

(defvar *w-rt* nil)

(defvar *ans*)
(setq *ans* 0.25)


(defvar *correct-answer*)
(setq *correct-answer* 0)


;</xmp><pre><a name="model">
;</a>
;;;;; general productions


(clear-all)
(sgp :g 20  :era t  :er t :egs 0.05 :act nil)

(add-dm (none isa chunk)
	(eof isa chunk)
	(head isa chunk)
	(arg isa chunk)
	(meaning isa chunk)
	(experiment isa chunk)
	(metaphor isa chunk)
	(antecedent isa chunk))

;;;; chunk types

(chunk-type meaning (composite nil))

(chunk-type prop-link
	    type			;thematic role
	    parent
	    child
	    interpretation			;interpretation of the sentence part of
					;which this prop-link is	
	    (context none))			;where was used last			

(chunk-type word
	    lexeme			;string of letters
	    meaning
	    cat				;noun or verb etc
	    type			;type of oblique for prepositions etc
	    context)			;if it was created during the experiment

(chunk-type comprehend
	    word			;current word
	    role			;thematic role of current word
	    (task "interpretation")
	    interpretation		;candidate interpretation
	    previous-interpretation	;previous candidate interpretation
	    context			;in which context was used
	    (script none)
	    word-1			;previous word
	    word-2 )			;word before previous

(chunk-type bug
	    word			;word on which the bug was formed
	    role			;role of the word 
	    (context nil)		
	    (interpretation nil)
	    (type metaphor)		;can be metaphor or artificial
	    (used nil))			;whether it has been used for recovery

(chunk-type match			;for matching words to props
	    ;;subgoaling was used to avoid getting extra associative
	    ;;activation from other slots of the chunk of type comprehend
	    word			;word to be matched
	    role			;thematic role
	    interpretation			;prop to match
	    new-interpretation)		;should be same with interpretation if matching
					;is successful or none otherwise
(add-dm  (dummy isa bug type nil))

					;context of dummy bugs should have the value of the current goal and
; also they should have low blc (lower than other bugs)


;;;; productions


(p find-antecedent
   ;; fires only for the first word
   =goal>
    isa comprehend
    word =wd
    word-1 none
    task "interpretation"
    interpretation none
  =prop-link>
    isa prop-link
    parent =ref
    child =ch
    - type arg
    - type head
    ;; should also restrict to any other type involving a meaning
    - context experiment
    - context meaning
    context =scr
==>
  !output! Interpretation =ref script =scr
  =ref>
   isa comprehend
   word =goal
  =goal>
   script =scr
   task "check-match"
   interpretation =ref
    ;; go directly to successful matching
)

(p try-again-find-antecedent
   =goal>
    isa comprehend
    word =wd
    role =role
    word-1 none
    task "interpretation"
    interpretation none 
==>
)

(eval `(spp (try-again-find-antecedent :r ,(+ *give-up* 0.002))))

(p match-successful-antecedent
  ;; if this is the first interpretation, don't give it too much credit
  ;; for matching one word (i.e. do not update previous interpretation)
   =goal>
    isa comprehend
    task "check-match"
    interpretation =ref
    - interpretation none
    role none
    word =mn
  =sent-link>
    isa prop-link
    parent =goal
    child =mn
==>
   =sent-link>
    interpretation =ref
   =goal>
    task "interpretation"    
   !pop!)

;;;; if there is no candidate intrepretation for the current sentence,
;;;; look for one


(p find-interpretation
   =goal>
    isa comprehend
    word =wd
    role =role
    - word-1 none
    task "interpretation"
    interpretation none 
   =prop>
    isa comprehend
    - context experiment		;avoid extracting current goal 
					;or others alike
    ;; avoid looping around the same interpretation 
    - word =goal    
    script =scr
==>
  =prop>
   word =goal				
  !output! Interpretation =prop script =scr
  =goal>
   interpretation =prop
   script =scr
   previous-interpretation none)


(p give-up
   ;; if no proposition could be retrieved as a interpretation
   =goal>
    isa comprehend
    word =wd
    role =role
    task "interpretation"
    interpretation none
    previous-interpretation =ref
    word =wd
    word-1 =wd1

==>
  =bug>
   isa bug
   word =wd
   role =role
   context =goal
   interpretation =ref 
  !output! Bug created
  =goal>
   interpretation none
   previous-interpretation none
   script none
  !pop!)			  

(eval `(spp (give-up :r ,*give-up* )))

;;; match the current interpretation to the current word

(p match-interpretation
   =goal>
    isa comprehend
    word =wd
    role =role
    task "interpretation"
    - interpretation none
    interpretation =ref
==>
   =subgoal>
    isa match
    word =wd
    role =role
    new-interpretation =new-ref
    interpretation =ref
   =goal>
    task "check-match"
    interpretation =new-ref
   !push! =subgoal) 

(p matching-interpretation
   =goal>
    isa match
    role =role
    interpretation =ref
    ;word =mn
  ;; =interpr-link should get negative activation if =ch was very
  ;; dissimilar with =mn
  =interpr-link>			
    isa prop-link
    parent =ref
    child =ch
    type =role
    - context experiment
==>
  =goal>
   new-interpretation =ref
  !pop!)
        
(p interpretation-not-matching
   =goal>
    isa match
    role =role
    interpretation =ref
==>
   =goal>
    new-interpretation none
    !pop!)

(spp (interpretation-not-matching :r 0.5))

(p match-successful
   =goal>
    isa comprehend
    task "check-match"
    interpretation =ref
    - interpretation none
    role =role
    - role none
    word =mn
  =sent-link>
    isa prop-link
    parent =goal
    child =mn
    type =role
==>
   =sent-link>
    interpretation =ref
   =goal>
    previous-interpretation =ref
    task "interpretation"    
   !pop!)

(p match-unsuccessful
   =goal>
    isa comprehend
    task "check-match"
    interpretation none
==>
   =goal>
    task "interpretation")

(p match-unsuccessful-no-script 
   =goal>
    isa comprehend
    task "check-match"
    interpretation none
==>
   =goal>
    script none
    task "interpretation")

(eval `(spp match-unsuccessful-no-script :r 0.995))

;;; end of sentence productions
;;; you want the most common case (no bug) to be one of priority


(p end-of-sentence
   =goal>
    isa comprehend
    task "interpretation"
    word eof
    interpretation =ref
==>
  !eval! (setq *answer* (if (equal =ref 'none) 1 0))
  !output! Interpretation =ref 
  !output! ("Answer ~s" *answer*)
  =goal>
   task "integrate"
   word nil
   word-1 nil
   word-2 nil
   role nil
)

(p end-of-sentence-verification
   =goal>
    isa comprehend
    word eof
    interpretation =ref
    task "interpretation"
   =ref>
    isa comprehend
  !eval! (= *task* +VERIFICATION+)
==>
  ;; want to retrieve first the metaphor bugs
  =goal>
   task "check-bug"
   word metaphor
   role =goal
   word-1 metaphor
   word-2 antecedent)

(spp (end-of-sentence :r 0.7))

(p retrieve-bug
   =goal>
    isa comprehend
    task "check-bug"
    word metaphor
   =bug>
    isa bug
    used nil
    context =goal
==>
   =goal>
    word =bug)
    

(p try-again-retrieve-bug
   =goal>
    isa comprehend
    task "check-bug"
    word metaphor
==>
)

(spp try-again-retrieve-bug :r 0.5)

(p no-bug 
   =goal> 
    isa comprehend
    task "check-bug"
    word dummy
    interpretation =ref
==>
  !eval! (setq *answer* 0)
  !output! Interpretation =ref 
  !output! ("Answer ~s" *answer*)
  =goal>
   word nil
   word-1 nil
   word-2 nil
   role nil
   task "integrate")
    
(p bug
   =goal>
    isa comprehend
    task "check-bug"
    word =bug
    - word dummy
    interpretation =ref
   =bug>
    isa bug
    word =wd
==>
  =goal>
   word nil
   word-1 nil
   word-2 nil
   role nil
  !eval! (setq *answer* 1)
  !output! Interpretation =ref
  !output! ("Bug ~s on word ~s" =bug =wd)
  !output! ("Answer ~s" *answer*)
  !pop!)

(spp (bug :r 0.5))

(p integrate
   =goal>
    isa comprehend
    interpretation =ref
    - interpretation none
    task "integrate"
  =sent-link>
    isa prop-link
    parent =goal
    - interpretation =ref
    context experiment
    child =word
    type =role
==>    
  !output! Integrating word =word   with interpretation  =ref
  =sent-link>
   isa prop-link
   context none
   interpretation =ref
)

(p end-integration
   =goal>
    isa comprehend
    task "integrate"   
==>
   !pop!

)
 
(spp (end-integration :r 0.5))


;;;; specific productions


(chunk-type reevaluate prop task word)

;;; redefine some comprehension productions to make sure that they
;;; select referents only from the preceding story

(p find-antecedent
   ;; fires only for the first word
   =goal>
    isa comprehend
    word =wd
    word-1 none
    task "interpretation"
    interpretation none
  =prop-link>
    isa prop-link
    parent =ref
    child =ch
    - type arg
    - type head
    ;; should also restrict to any other type involving a meaning
    - context experiment
    - context meaning
    context =goal
==>
  !output! =ref
  =ref>
   isa comprehend
   word =goal
   =goal>
    task "check-match"
    interpretation =ref
    ;; go directly to successful matching
    previous-interpretation =ref)


(p find-interpretation
   =goal>
    isa comprehend
    word =wd
    role =role
    - word-1 none
    task "interpretation"
    interpretation none 
   =prop>
    isa comprehend
    context =goal
    - context experiment		;avoid extracting current goal 
					;or others alike
    ;; avoid looping around the same interpretation 
    - word =goal    
==>
  =prop>
   word =goal				
  !output! Interpretation =prop
  =goal>
   interpretation =prop
   previous-interpretation none)


;;; add one more give-up production to hinder proliferation of bugs

(p give-up-with-antecedent-bug
   ;; if no proposition could be retrieved as a interpretation
   =goal>
    isa comprehend
    word =wd
    role =role
    task "interpretation"
    interpretation none
    previous-interpretation =ref
    word =wd
    word-1 =wd1
   =plink> 
    isa prop-link
    child =wd
    type =role    
    - context experiment
    - parent =goal
    context =goal
==>
  =bug>
   isa bug
   word =wd
   role =role
   context =goal
   type antecedent
   interpretation =ref 
  !output! Bug created of type antecedent
  =goal>
   interpretation none
  !pop!)			  

(eval `(spp (give-up-with-antecedent-bug :r ,*give-up-w-ant*)));0.02) )))



;;; integration should happen after reevaluation and before feedback

;; replace the production bug with two productions: one that
;; reevaluates and another that goes to feedback



(p end-of-sentence-verification
   ;;;accept none, too
   =goal>
    isa comprehend
    word eof
    interpretation =ref
    task "interpretation"
    - word-1 "reevaluate"
  !eval! (= *task* +VERIFICATION+)
==>
  ;; want to retrieve first the metaphor bugs
  =goal>
   task "check-bug"
   word metaphor
   role =goal
   word-1 metaphor
   word-2 antecedent)

(p retry-antecedent
   =goal>
    isa comprehend
    task "check-bug"
    word =bug
    - word dummy
    interpretation none
   =bug>
    isa bug
    context =goal
    word =wd
    type metaphor
==>
   !output! =wd
   =bug>
    used t   
   =goal>   
    task "interpretation"
    word =wd
    word-1 none
    word-2 "antecedent"
   =goal1>
    isa reevaluate
    task "initiate"
    prop =goal
    word =wd
   !focus-on! =goal1)

(p say-false
   =goal>
    isa comprehend
    task "check-bug"
    word =bug
    - word dummy
    interpretation none
==>
  !eval! (setq *answer* 1)
  !output! Interpretation None
  !output! ("Answer ~s" *answer*)
  =goal>
   task "integrate")


(p reevaluate
   =goal> 
    isa comprehend
    task "check-bug"
    word =bug
    - word dummy
    interpretation =ref
    - interpretation none
   =bug>
    isa bug
    context =goal
    word =wd
    type metaphor
==>
   !output! =wd
   =bug>
    used t   
   =goal>   
    task "interpretation"
    word =wd
    word-1 nil
    word-2 nil
   =goal1>
    isa reevaluate
    task "initiate"
    prop =goal
    word =wd
   !focus-on! =goal1)



;; you could use the production bug if you want to play with reevaluate versus not


(p get-actual-role
   =goal>
    isa reevaluate
    word =wd
    prop =prop
    task "initiate"
   =sent-link>
    isa prop-link
    parent =prop
    child =wd
    type =role
==>   
   =prop>
    isa comprehend
    role =role
   =goal>
    task "wait"
   !push! =prop)


(p null-reevaluation-result
   =goal>
    isa reevaluate
    task "wait"
    prop =prop
   =prop>
    isa comprehend
    word-2 "antecedent"
==>
   =prop>
    word eof
    role nil
    word-2 nil
    word-1 "reevaluate"
    interpretation none
   !focus-on! =prop)

(p get-reevaluation-result
   =goal>
    isa reevaluate
    task "wait"
    prop =prop
   =prop>
    isa comprehend
    - word-2 "antecedent"
==>
   =prop>
    word eof
    role nil
    word-2 nil
    word-1 "reevaluate"
   !focus-on! =prop)


(p try-matching-harder
   =goal>
    isa match
    role =role
    interpretation =ref
    word =mn
   !eval! (>= *count* (length *sent*))   
==>
)

(p accept-non-matching
 ;; randomly accept
   =goal>
    isa match
    role =role
    interpretation =ref
    word =mn
   !eval! (>= *count* (length *sent*))   
==>
   =goal>
    new-interpretation =ref
  !pop!
)

    
(eval `(spp (try-matching-harder :r ,(+ 0.5 0.002));0.002
	    (accept-non-matching :r ,(- 0.5 0.007)))) ;0.005))))


;;;; parsing

(add-dm (funct isa chunk)
	(patient isa chunk)
	(agent isa chunk)
	(theme-oblique isa chunk)
	(part-oblique isa chunk)
	(place-oblique isa chunk)
	(time-oblique isa chunk)
	(instr-oblique isa chunk)
	(mod-oblique isa chunk)
	(purpose-oblique isa chunk)
	(recipient isa chunk)
	(comp-oblique isa chunk)

	(det isa chunk)
	(noun isa chunk)
	(adj isa chunk)
	(adv isa chunk)
	(verb isa chunk)
	(infl isa chunk)
	(prep isa chunk)
	(det-spec isa chunk)
	(comp isa chunk)

	
	(np isa chunk)
	(n1 isa chunk)
	(ip isa chunk)
	(vp isa chunk)
	(pp isa chunk)
	(advp isa chunk)
	(dp isa chunk)
	(cp isa chunk)
	(c1 isa chunk)

	(composite isa chunk)
	(lexical-decision isa chunk)
	)


(chunk-type parse
	    word type link link-type (word-role none) meaning phrase-role
	    current-meaning (stamp 0) interpretation (context experiment))
  ;; stamp says for how long you postponed the semantic processing for the current meaning

(chunk-type node)
(chunk-type syntactic-link 
	    parent child role type context)


(p read-word
    =goal>
     isa parse
     word nil
    !eval! (not (eof-p))
 ==>
    !bind! =lex (get-next-word) 
    =goal>
     word =lex
     type nil
    !output! =lex)

(eval `(spp read-word :effort ,*read*))

(p read-eof
    =goal>
     isa parse
     word nil
     meaning =mean
     stamp 0
    !eval! (eof-p)
 ==>
    !bind! =lex (get-next-word) 
  =goal>
   word eof
   type nil
  =mean>
   isa comprehend
   word eof
   role nil
  !focus-on! =mean)

(p read-eof-sem
    =goal>
     isa parse
     word nil
     meaning =mean
     stamp 1
    !eval! (eof-p)
 ==>
    !bind! =lex (get-next-word) ;; *count* is incremented
   =goal>
    word eof
    stamp 0
    type nil
   !push! =mean)


(p parse-eof
   =goal>
    isa parse
    word eof
    type nil
    meaning =mean
    stamp 0
==>
  =mean>
   isa comprehend
   word eof
   role nil
  !focus-on! =mean)

 (p extract-meaning
    =goal>
     isa parse
     word =lex
     - word eof
     type nil
    =lexeme>
     isa word
     lexeme =lex
     cat =cat
     meaning =mn
     type =word-role
 ==>
   =goal>
    word =mn
    type =cat
    word-role =word-role)    

(p try-again-extract-meaning
    =goal>
     isa parse
     word =lex
     - word eof
     type nil
 ==>
)

(spp try-again-extract-meaning :r 0.5)

(p det-no-sent
   =goal>
    isa parse
    type det
    link nil
    word =word
    meaning =mean
 ==>
   =np>
    isa node
   =ip>
    isa node
   =det-link>
    isa syntactic-link
    parent =np
    child =word
    type np
    role arg
    context =goal
   =ip-link>
    isa syntactic-link
    parent =ip
    child =np
    role arg
    type ip
    context =goal
   =np-mean>
    isa meaning
    composite t
   =sem-link>
    isa prop-link
    parent =mean
    child =np-mean
    type none 
    context experiment
   =goal>
    link =np
    link-type det
    word nil  
    word-role funct
    phrase-role none
    current-meaning =np-mean
    stamp 0
   =mean>
    isa comprehend
    word =np-mean
    task "interpretation"
    role none
 )

 (p noun-no-sent
    =goal>
     isa parse
     word =word
     type noun
     link nil
     meaning =mean
 ==>
   =np>
    isa node
   =n1>
    isa node
   =ip>
    isa node
   =n1-link>
    isa syntactic-link
    parent =n1
    child =word
    role head
    type n1
    context =goal
   =np-link>
    isa syntactic-link
    parent =np
    child =n1
    type np
    role arg
    context =goal
   =ip-link>
    isa syntactic-link
    parent =ip
    child =np
    role arg
    type ip
    context =goal
   =np-mean>
    isa meaning
    composite t
   =sem-link>
    isa prop-link
    parent =mean
    child =np-mean
    type none
    context experiment
   =np-sem-link>
    isa prop-link
    parent =np-mean
    child =word
    type head
    context experiment
   =goal>
    link =n1
    link-type n1
    word-role agent
    phrase-role none
    current-meaning =np-mean
    word nil
    stamp 1
   =mean>
    isa comprehend
    word =np-mean
    role none
    task "interpretation"
 )


(p adj-no-sent
   =goal>
     isa parse
     word =word
     type adj
     link nil
     meaning =mean
 ==>
   =np>
    isa node
   =n1>
    isa node
   =ip>
    isa node
   =n1-link>
    isa syntactic-link
    parent =n1
    child =word
    role arg
    type n1
    context =goal
   =np-link>
    isa syntactic-link
    parent =np
    child =n1
    type np
    role head
    context =goal
   =ip-link>
    isa syntactic-link
    parent =ip
    child =np
    role arg
    type ip
    context =goal
   =np-mean>
    isa meaning
    composite t
   =sem-link>
    isa prop-link
    parent =mean
    child =np-mean
    type none
    context experiment
   =np-sem-link>
    isa prop-link
    parent =np-mean
    child =word
    type arg
    context experiment
   =goal>
    link =n1
    link-type n1
    word-role agent
    phrase-role none 
    current-meaning =np-mean
    word nil
    stamp 1
   =mean>
    isa comprehend
    word =np-mean
    role none
    task "interpretation"
  ) 


 (p n-det
    =goal>
     isa parse
     type noun
     link =np
     link-type det
     word =word
     meaning =mean
     phrase-role =role
     current-meaning =np-mean
     stamp 0
 ==>
    =n1>
     isa node
    =n1-link>
     isa syntactic-link
     parent =n1
     child =word
     type n1
     role head
     context =goal
    =np-link>
     isa syntactic-link
     parent =np
     child =n1
     role head
     type np
     context =goal
   =np-sem-link>
    isa prop-link
    parent =np-mean
    child =word
    type head
    context experiment
   =goal>
    link =n1
    link-type n1
    word-role =role
    word nil
    stamp 1
)

(p n-det-sem
    =goal>
     isa parse
     type noun
     link =np
     link-type det
     word =word
     meaning =mean
     phrase-role =role
     current-meaning =np-mean
     stamp 1
 ==>
    =n1>
     isa node
    =n1-link>
     isa syntactic-link
     parent =n1
     child =word
     type n1
     role head
     context =goal
    =np-link>
     isa syntactic-link
     parent =np
     child =n1
     role head
     type np
     context =goal
   =np-sem-link>
    isa prop-link
    parent =np-mean
    child =word
    type head
    context experiment
   =goal>
    link =n1
    link-type n1
    word-role =role
    word nil
    stamp 0
  !push! =mean
)



(p n-attribute
   =goal> 
    isa parse
    word =word
    type noun
    link-type n1
    link =n1
    meaning =mean
    current-meaning =np-mean
    phrase-role =role
    stamp 0
   =old-head>
    isa syntactic-link
    parent =n1
    child =wd
    role head
    type n1
    context =goal
   =old-sem-link>
    isa prop-link
    parent =np-mean
    child =wd
    type head
==>
   =n1-link>
    isa syntactic-link
    parent =n1
    child =word
    role head
    type n1
    context =goal
   =n12>
    isa node
   =old-head>
    role arg
    child =n12
   =n12-link>
    isa syntactic-link
    parent =n12
    child =wd
    role head
    type n1
    context =goal
 =np-sem-link>
  isa prop-link
  parent =np-mean
  child =word
  type head
  context experiment
 =old-sem-link>
  type arg
 =goal>
    word nil
    link =n1
    link-type n1
    word-role =role
    stamp 1
)

(p complete-n-attribute
   =goal> 
    isa parse
    word =word
    type noun
    link-type n1
    link =n1
    meaning =mean
    current-meaning =np-mean
    phrase-role =role
    stamp 0.5
  =old-sem-link>
    isa prop-link
    parent =np-mean
    child =wd
    type head
==>
  =np-sem-link>
   isa prop-link
   parent =np-mean
   child =word
   type head
   context experiment
  =old-sem-link>
   type arg
  =goal>
    word nil
    link =n1
    link-type n1
    word-role =role
    stamp 1
)

(pdisable complete-n-attribute)

(p n-attribute-sem
   =goal> 
    isa parse
    word =word
    type noun
    link-type n1
    link =n1
    meaning =mean
    current-meaning =np-mean
    phrase-role =role
    stamp 1
   =old-head>
    isa syntactic-link
    parent =n1
    child =wd
    role head
    type n1
    context =goal
  =old-sem-link>
   isa prop-link
   parent =np-mean
   child =wd
   type head
==>
   =n1-link>
    isa syntactic-link
    parent =n1
    child =word
    role head
    type n1
    context =goal
   ;; update old link
   =n12>
    isa node
   =old-head>
    role arg
    child =n12
   =n12-link>
    isa syntactic-link
    parent =n12
    child =wd
    role head
    type n1
    context =goal
  =np-sem-link>
   isa prop-link
   parent =np-mean
   child =word
   type head
   context experiment
  =old-sem-link>
   type arg
   =goal>
    word nil
    link =n1
    link-type n1
    word-role =role
    stamp 0
   ;; need to go to semantics
   ;; no need to shift words, though (see below) 
    !push! =mean)


(p complete-n-attribute-sem
   =goal> 
    isa parse
    word =word
    type noun
    link-type n1
    link =n1
    meaning =mean
    current-meaning =np-mean
    phrase-role =role
    stamp 1.5
  =old-sem-link>
    isa prop-link
    parent =np-mean
    child =wd
    type head
==>
  =np-sem-link>
   isa prop-link
   parent =np-mean
   child =word
   type head
   context experiment
  =old-sem-link>
   type arg
  =goal>
    word nil
    link =n1
    link-type n1
    word-role =role
    stamp 0
  !push! =mean
)

(pdisable complete-n-attribute-sem)
(p adj-det
   ;;; "the <adj>.."
   =goal>
    isa parse
    word =word
    type adj
    link =np
    link-type det
    meaning =mean
    current-meaning =np-mean
==>
   =n1>
    isa node
   =n1-link>
    isa syntactic-link
    parent =n1
    child =word
    role arg
    type n1
    context =goal
   =np-link>
    isa syntactic-link
    parent =np
    child =n1
    role head
    type np
    context =goal
   =sem-link>
    isa prop-link
    parent =np-mean
    child =word
    type arg
    context experiment
   =goal>
    link =n1
    link-type n1
    word-role funct
    word nil
   ;; no need to go to semantics; wait for a complete np
)   

(p adj-pp
   ; "<prep> <adj>"
   =goal>
    isa parse
    word =word
    type adj
    link =pp
    link-type pp
    phrase-role =role
    current-meaning =pp-mean
==>
   =np>
    isa node
   =n1>
    isa node
   =n1-link>
    isa syntactic-link
    parent =n1
    child =word
    role arg
    type n1
    context =goal    
   =np-link>
    isa syntactic-link
    parent =np
    child =n1
    role head
    type np
    context =goal
  =pp-link>
    isa syntactic-link
    parent =pp
    child =np
    role arg
    type pp
    context =goal
   =pp-sem-link>
    isa prop-link
    parent =pp-mean
    child =word
    type arg
    context experiment
  =goal>
   link-type n1
   link =n1
   word-role funct
   current-meaning =pp-mean
   word nil
   ;; go to next word
)

(p noun-pp
   =goal>
    isa parse
    word =word
    type noun
    link =pp
    link-type pp
    current-meaning =pp-mean
    phrase-role =role
    meaning =mean
    stamp 0
   =meaning>
    isa comprehend
    word =np-mean
==>
   =np>
    isa node
   =n1>
    isa node
   =n1-link>
    isa syntactic-link
    parent =n1
    child =word
    role head
    type n1
    context =goal    
   =np-link>
    isa syntactic-link
    parent =np
    child =n1
    role head
    type np
    context =goal
  =pp-link>
    isa syntactic-link
    parent =pp
    child =np
    role arg
    type pp
    context =goal
  =pp-sem-link>
   isa prop-link
   parent =pp-mean
   child =word
   type head
   context experiment
  =goal>
   link-type n1
   link =n1
   word-role =role
   word nil
   stamp 1
)

(p noun-pp-sem
   =goal>
    isa parse
    word =word
    type noun
    link =pp
    link-type pp
    current-meaning =pp-mean
    phrase-role =role
    meaning =mean
    stamp 1
   =meaning>
    isa comprehend
    word =np-mean
==>
   =np>
    isa node
   =n1>
    isa node
   =n1-link>
    isa syntactic-link
    parent =n1
    child =word
    role head
    type n1
    context =goal    
   =np-link>
    isa syntactic-link
    parent =np
    child =n1
    role head
    type np
    context =goal
  =pp-link>
    isa syntactic-link
    parent =pp
    child =np
    role arg
    type pp
    context =goal
  =pp-sem-link>
   isa prop-link
   parent =pp-mean
   child =word
   type head
   context experiment
  =goal>
   link-type n1
   link =n1
   word-role =role
   word nil
   stamp 0
 !push! =mean
)


(p det-pp
   =goal>
    isa parse
    word =word
    type det
    link =pp
    link-type pp
==>
   =np>
    isa node
   =np-link>
    isa syntactic-link
    parent =np
    child =word
    role arg
    type np
    context =goal
  =pp-link>
    isa syntactic-link
    parent =pp
    child =np
    role arg
    type pp
    context =goal
  =goal>
   link-type det
   link =np
   word-role funct
   word nil
)




(p n-adj-sem
   ;; <adj> <noun>
  =goal>
    isa parse
    word =word
    type noun
    link =n1
    link-type n1
    phrase-role =role
    meaning =mean
    current-meaning =np-mean
    stamp 1
  =arg-link>
   isa syntactic-link
   parent =n1
   child =wd
   role arg
   context =goal
==>
  =n1-link>
   isa syntactic-link
   parent =n1
   child =word
   role head
   type n1
   context =goal
  =np-sem-link>
   isa prop-link
   parent =np-mean
   child =word
   type head
   context experiment
  =goal>
   link-type n1
   link =n1
   word-role =role
   word nil
   stamp 0
  !push! =mean
)

(spp (n-adj-sem :r 0.5))

(p n-adj
   ;; <adj> <noun>
  =goal>
    isa parse
    word =word
    type noun
    link =n1
    link-type n1
    phrase-role =role
    meaning =mean
    current-meaning =np-mean
    stamp 0
  =arg-link>
   isa syntactic-link
   parent =n1
   child =wd
   role arg
   context =goal
==>
  =n1-link>
   isa syntactic-link
   parent =n1
   child =word
   role head
   type n1
   context =goal
  =np-sem-link>
   isa prop-link
   parent =np-mean
   child =word
   type head
   context experiment
  =goal>
   link-type n1
   link =n1
   word-role =role
   word nil
   stamp 1
)

(spp (n-adj :r 0.5))

(p prep-n
   =goal>
   isa parse
   word =word
   type prep
   link =n1
   link-type n1
   phrase-role =role
   word-role =prep-role
   current-meaning =np-mn
   meaning =mean
   =mean>
   isa comprehend   
==>
  =pp>
   isa node
  =pp-link>
   isa syntactic-link
   parent =pp
   child =word
   role head
   type pp
   context =goal
  =n1-link>
   isa syntactic-link
   parent =n1
   child =pp
   role arg
   type n1
   context =goal
  =pp-mean>
   isa meaning
   composite t
  =np-sem-link>
   isa prop-link
   parent =np-mn
   child =pp-mean
   type =prep-role
   context experiment
  =goal>
   link =pp
   link-type pp
   word-role funct
   current-meaning =pp-mean
   phrase-role =role
   word nil
)

(p v-n1-spill-over
   =goal>
    isa parse
    word =word
    type verb
    link =n1
    link-type n1
    meaning =mean
    stamp 1
==>
   =goal>
    stamp 0
   !push! =mean 
)


(p v-n1-no-agent
   =goal>
    isa parse
    word =word
    type verb
    link =n1
    link-type n1
    meaning =mean
    stamp 0
   =sem-link>
    isa prop-link
    parent =mean
    type none
    ;child =wd
    context experiment
   =synt-link>
    isa syntactic-link
    type ip
    parent =ip
    role arg
    context =goal
   =mean>
    isa comprehend
    word =wd
    word-1 =wd1
   
==>
   =vp>
    isa node
   =v1-link>
    isa syntactic-link
    parent =vp
    child =word
    type vp
    role head
    context =goal
   =ip-link>
    isa syntactic-link
    parent =ip
    child =vp
    role head
    type ip
    context =goal
   =ip-sem-link>
    isa prop-link
    parent =mean
    child =word
    type verb
    context experiment
   =goal>
    link =vp
    link-type vp
    word-role verb
    phrase-role verb
    current-meaning =mean
    word nil
    stamp 0
   =sem-link>
    type agent
   =mean>
    isa comprehend
    role verb
    word =word
    word-1 =wd
    word-2 =wd1
    previous-interpretation none
   !push! =mean 
)

(p v-n1
   =goal>
    isa parse
    word =word
    type verb
    link =n1
    link-type n1
    meaning =mean
    stamp 0
   =synt-link>
    isa syntactic-link
    type ip
    parent =ip
    role arg
    context =goal
   =mean>
    isa comprehend
    word =wd
    word-1 =wd1   
==>
   =vp>
    isa node
   =v1-link>
    isa syntactic-link
    parent =vp
    child =word
    type vp
    role head
    context =goal
   =ip-link>
    isa syntactic-link
    parent =ip
    child =vp
    role head
    type ip
    context =goal
   =ip-sem-link>
    isa prop-link
    parent =mean
    child =word
    type verb
    context experiment
   =goal>
    link =vp
    link-type vp
    word-role verb
    phrase-role verb
    current-meaning =mean
    word nil
    stamp 0
   =mean>
    isa comprehend
    role verb
    word =word
    word-1 =wd
    word-2 =wd1
   !push! =mean 
)

(spp (v-n1 :r 0.5))

(p infl-n1
   =goal>
    isa parse
    word =word
    type infl 
    link =n1
    link-type n1
    meaning =mean
    current-meaning =np-mean
   =synt-link>
    isa syntactic-link
    type ip
    parent =ip
    role arg
    context =goal
   =mean>
    isa comprehend
    word =wd
    word-1 =wd1
==>
   =vp>
    isa node
   =vp-link>
    isa syntactic-link
    parent =vp
    child =word
    type vp
    role head
    context =goal
   =ip-link>
    isa syntactic-link
    parent =ip
    child =vp
    role head
    type ip
    context =goal
   =goal>
    link =vp
    link-type vp
    word-role funct
    current-meaning =mean
    phrase-role verb
    word nil
    stamp 0
   =mean> 
    isa comprehend
    word none
    role verb
    word-1 =wd
    word-2 =wd1)


(p infl-n1-spill-over
   =goal>
    isa parse
    word =word
    type infl 
    link =n1
    link-type n1
    meaning =mean
    current-meaning =np-mean
    stamp 1
==>
   =goal>
    stamp 0
   !push! =mean)


  ;; perhaps go back and update the agent link if necessary


(p v-infl
   =goal>
    isa parse
    word =word
    type verb
    link =vp
    link-type vp
    meaning =mean
   =synt-link>
    isa syntactic-link
    type vp
    parent =vp
    role head
    context =goal
   =subj-sem-link>
    isa prop-link
    parent =mean
    type none 
    context experiment
==>
   =vp1>
    isa node
   =vp1-link>
    isa syntactic-link
    parent =vp1
    role head
    child =word
    type vp
    context =goal
   =vp-link>
    isa syntactic-link
    parent =vp
    child =vp1
    type vp
    role arg
    context =goal
   =subj-sem-link>
    type patient
   =vp-sem-link>
    isa prop-link
    parent =mean
    child =word
    type verb
    context experiment
   =goal>
    link-type vp
    link =vp1
    word-role verb
    current-meaning =mean
    phrase-role verb
    word nil
    stamp 0
   =mean>
     isa comprehend
     word =word
   !push! =mean
)

(p n-vp
   =goal>
    isa parse
    word =word
    type noun
    link =vp
    link-type vp
    meaning =mean
   =mean>
    isa comprehend
    word =wd
    word-1 =wd1
==>
   =np>
    isa node
   =n1>
    isa node
   =vp-link>
    isa syntactic-link
    parent =vp
    child =np
    type vp
    role arg
    context =goal
   =np-link>
    isa syntactic-link
    parent =np
    child =n1
    role head
    type np
    context =goal
   =n1-link>
    isa syntactic-link
    parent =n1
    child =word
    type n1
    role head
    context =goal
   =np-mean>
    isa meaning
    composite t
   =ip-sem-link>
    isa prop-link
    parent =mean
    child =np-mean
    type patient
    context experiment
   =np-sem-link>
    isa prop-link
    parent =np-mean
    child =word
    type head
    context experiment
   =goal>
    link-type n1
    link =n1
    word-role patient
    current-meaning =np-mean
    phrase-role patient
    word nil
    stamp 1
   =mean>
    word =np-mean
    role patient
    word-1 =wd
    word-2 =wd1
)
        

(p det-vp
   =goal>
    isa parse
    word =word
    type det
    link =vp
    link-type vp
    meaning =mean
   =mean>
    isa comprehend
    word =wd
    word-1 =wd1
==>
   =np>
    isa node
   =vp-link>
    isa syntactic-link
    parent =vp
    child =np
    type vp
    role arg
    context =goal
   =np-link>
    isa syntactic-link
    parent =np
    child =word
    role arg
    type np
    context =goal
   =np-mean>
    isa meaning
    composite t
   =sem-link>
    isa prop-link
    parent =mean
    child =np-mean
    type patient
    context experiment
   =goal>
    link-type det
    link =np
    word-role funct
    phrase-role patient
    current-meaning =np-mean
    word nil
    stamp 0
   =mean>
    isa comprehend
    word =np-mean
    word-1 =wd
    word-2 =wd1
    role patient
)


(p adj-vp
   =goal>
    isa parse
    word =word
    type adj
    link-type vp
    link =vp
    meaning =mean
   =mean>
    isa comprehend
    word =wd
    word-1 =wd1
==>
   =np>
    isa node
   =n1>
    isa node
   =n1-link>
    isa syntactic-link
    parent =n1
    child =word
    role arg
    type n1
    context =goal
   =np-link>
    isa syntactic-link
    parent =np
    child =n1
    role head
    type np
    context =goal
   =vp-link>
    isa syntactic-link
    parent =vp
    child =np
    role arg
    type vp
   =np-mean>
    isa meaning 
    composite t
   =ip-sem-link>
    isa prop-link
    parent =mean
    child =np-mean
    type patient
    context experiment
   =np-sem-link>
    isa prop-link
    parent =np-mean
    child =word
    type arg
    context experiment
   =goal>
    link =n1
    link-type n1
    word-role funct
    phrase-role patient
    current-meaning =np-mean
    word nil
    stamp 0
  =mean>
   word =np-mean
   word-1 =wd
   word-2 =wd1
   role patient
)

(p prep-vp
   =goal>
    isa parse
    word =word
    type prep
    link-type vp
    link =vp
    meaning =mean
    word-role =prep-role
   =mean>
    isa comprehend
    word =wd
    word-1 =wd1
==>
   =pp>
    isa node
   =pp-link>
    isa syntactic-link
    parent =pp
    child =word
    role head
    type pp
    context =goal
   =vp-link>
    isa syntactic-link
    parent =vp
    child =pp
    role arg
    type vp
    context =goal
   =pp-mean>
    isa meaning
    composite t
   =sem-link>
    isa prop-link
    parent =mean
    child =pp-mean
    type =prep-role
    context experiment
   =goal>
    link =pp
    link-type pp
    word-role funct
    current-meaning =pp-mean
    phrase-role =prep-role
    word nil
    stamp 0
   =mean>
    word =pp-mean
    role =prep-role
    word-1 =wd
    word-2 =wd1    
)




(p adv-vp
   =goal>
    isa parse
    word =word
    type adv
    link-type vp
    link =vp
    meaning =mean
    word-role =adv-role
   =mean>
    isa comprehend
    word =wd
    word-1 =wd1
==>
   =advp>
    isa node
   =advp-link>
    isa syntactic-link
    parent =advp
    child =word
    role head
    type pp
    context =goal
   =vp-link>
    isa syntactic-link
    parent =vp
    child =advp
    role arg
    type vp
    context =goal
   =ip-sem-link>
    isa prop-link
    parent =mean
    child =word
    type =adv-role
    context experiment
   =goal>
    link =advp
    link-type advp
    word-role =adv-role
    phrase-role =adv-role
    current-meaning =mean
    word nil
    stamp 0
   =mean>
    word =word
    role =adv-role
    word-1 =wd
    word-2 =wd1    
  !push! =mean
)


;;;; productions that deal with parsing complementizer phrases (CP)
;;;; useful for "how many animals of each kind did Noah take on the ark?"


(p det-spec-no-comp
   =goal>
    isa parse
    word =word
    type det-spec
    link nil
    meaning =mean
==>
   =np>
    isa node
   =cp>
    isa node
   =dp>
    isa node
   =cp-link>
    isa syntactic-link
    parent =cp
    child =np
    role arg
    type cp
    context =goal
   =np-link>
    isa syntactic-link
    parent =np
    child =dp
    type np
    role arg
    context =goal
   =dp-link>
    isa syntactic-link
    parent =dp
    child =word
    type dp
    role arg
     context =goal
   =np-mean>
    isa meaning
    composite t
   =goal>
    link =dp
    link-type dp
    word nil
    word-role funct
    phrase-role none
    current-meaning =np-mean
    stamp 0
   =mean>
    isa comprehend
    word =np-mean
    role none 
)

(p det-det-spec
   =goal>
    isa parse
    word =word
    type det
    link =dp
    link-type dp
    phrase-role =role
==>
  =dp-link>
   isa syntactic-link
   parent =dp
   child =word
   role head
   type dp
   context =goal
  =goal>
   word nil
   word-role funct
   link-type  dp
   link =dp)

(p n-dp
   =goal>
    isa parse
    word =word
    type noun
    link-type dp
    link =dp
    meaning =mean
    phrase-role =role
    current-meaning =np-mean
    stamp 0
   =synt-link>
    isa syntactic-link
    parent =np
    child =dp
    type np
    role arg
    context =goal
==>
   =n1>
    isa node
   =n1-link>
    isa syntactic-link
    parent =n1
    child =word
    role head
    type n1
    context =goal
   =np-link>
    isa syntactic-link
    parent =np
    child =n1
    type np
    role head
    context =goal
   =sem-link>
    isa prop-link
    parent =mean
    child =np-mean
    type =role
    context experiment
   =np-sem-link>
    isa prop-link
    parent =np-mean
    child =word
    type head
    context experiment
   =goal>
    link =n1
    link-type n1
    word-role =role
    current-meaning =np-mean
    word nil
    stamp 1
  )
    
(p n-dp-sem
   =goal>
    isa parse
    word =word
    type noun
    link-type dp
    link =dp
    meaning =mean
    phrase-role =role
    current-meaning =np-mean
    stamp 1
   =synt-link>
    isa syntactic-link
    parent =np
    child =dp
    type np
    role arg
    context =goal
==>
   =n1>
    isa node
   =n1-link>
    isa syntactic-link
    parent =n1
    child =word
    role head
    type n1
    context =goal
   =np-link>
    isa syntactic-link
    parent =np
    child =n1
    type np
    role head
    context =goal
   =sem-link>
    isa prop-link
    parent =mean
    child =np-mean
    type =role
    context experiment
   =np-sem-link>
    isa prop-link
    parent =np-mean
    child =word
    type head
    context experiment
   =goal>
    link =n1
    link-type n1
    word-role =role
    current-meaning =np-mean
    word nil
    stamp 0
  !push! =mean)


(p comp-np
   =goal>
    isa parse
    word =word
    type comp
    link =n1
    link-type n1
    meaning =mean
    stamp 0
   =old-cp-link>
    isa syntactic-link
    parent =cp
    type cp
    context =goal
   =sem-link>
    isa prop-link
    parent =mean
    child =np-mean
    type none
    context experiment
 ==>
   ;; know that you do not have an agent before
   =sem-link>
    isa prop-link
    type patient
   =c1>
    isa node
   =cp-link>
    isa syntactic-link
    parent =cp
    child =c1
    type cp
    role head
    context =goal
   =c1-link>
    isa syntactic-link
    parent =c1
    child =word
    type c1
    role head
    context =goal
   =goal>
    word nil
    word-role funct
    link =c1
    link-type c1
    stamp 0
    current-meaning =mean)

(p comp-np-spill-over
   =goal>
    isa parse
    word =word
    type comp
    link =n1
    link-type n1
    meaning =mean
    stamp 1
==>
   ;; know that you do not have an agent before
   =goal>
    stamp 0
   !push! =mean)


(p n-comp
   =goal>
    isa parse
    link =c1
    link-type c1
    word =word
    type noun
    meaning =mean
   =mean>
    isa comprehend
    word =wd
    word-1 =wd1
==>
   =np>
    isa node
   =n1>
    isa node
   =ip>
    isa node
   =cp-link>
    isa syntactic-link
    parent =c1
    child =ip
    type c1
    role arg
    context =goal
   =ip-link>
    isa syntactic-link
    parent =ip
    child =np
    type ip
    role arg
    context =goal
   =np-link>
    isa syntactic-link
    parent =np
    child =n1
    type np
    role head
    context =goal
   =n1-link>
    isa syntactic-link
    parent =n1
    child =word
    type n1
    role head
    context =goal
   =np-mean>
    isa meaning
    composite t
   =sem-link>
    isa prop-link
    parent =mean
    child =np-mean
    type agent
    context experiment
   =np-sem-link>
    isa prop-link
    parent =np-mean
    child =word
    type head
    context experiment
   
   =goal>
    current-meaning =np-mean
    word-role agent
    phrase-role agent
    link =n1
    link-type n1
    word nil
    stamp 1
   =mean>
    word =np-mean
    role agent
    word-1 =wd
    word-2 =wd1
    previous-interpretation none
)


(defvar *base*)
(defvar *incr*)
(defvar *pincr*)
(defvar *self-ia*)

(defvar *overlaps* nil)
;; this is a list (meaning1 meaning2 semantic-overlap)
;; overlap is normalized (i.e. between 0 and 1)



(defvar *sent* nil)
(defvar *syntactic-roles* nil)
(defvar *count* nil)
(defvar *extras* nil)

;;;; ACT-R modifications
;;;;=======================

;;;redefine the add-dm macro to reset only the ias of the new chunk

(defmacro add-dm (&rest wmes)
  "Adds the following wmes to working memory."
  `(add-dm-fct ',wmes :reset-ia nil))

(defun my-wme-type (wme-name)
  (wme-type-name (wme-type (get-wme wme-name))))

	
(defun compute-activ-p (wme)
  (or (>  (wme-creation-time wme) 0)
      (member (wme-name wme) *extras* :test #'equal)))


(defun update-activation-spread (&key (focus *wmfocus*))
  "Updates the activation sources to be the slot values of the focus wme."
  (incf *spread-stamp* 1)
  (dolist (source *activation-sources*)
    (setf (wme-source source) nil))
  (setf *activation-sources* nil)
  (when focus
    (let ((level (first (wme-slot-wmes focus))))
      (when (> (- level (count (get-wme 'none) (wme-slot-wmes focus) :test #'equal))  0.0)
	(setq level (/ *goal-activation*
		       (- level (count (get-wme 'none) (wme-slot-wmes focus) :test #'equal)))) 
        (dolist (source (rest (wme-slot-wmes focus)))
          (cond ((equal source (get-wme 'none)))
		((wme-source source)
                 (incf (wme-source source) level))
                (t
                 (setf (wme-source source) level)
                 (push source *activation-sources*))))))))





(defun compute-spreading-activation (wmei)
  "Updates the spreading activation of wmei.  Maintains activation."
  (let ((wmej nil)
        (ia nil) (flag nil)
        (spread 0.0))
    (signal-output *activation-trace* "Chunk ~s" wmei) 
    (decf (wme-activation wmei) (wme-source-spread wmei))
    (setf (wme-source-spread wmei) 0.0)
    (when  (compute-activ-p wmei) 
      (setq flag t))
    (dolist (wme-ia (wme-ias wmei))
      (setf wmej (car wme-ia))
      (when (and (wme-source wmej) (not (compute-activ-p wmej)))
	(if flag
	    (setf ia (associate  wmei wmej))
	   (progn
	     (setf ia (cdr wme-ia))
	     (setf ia (ia-value ia wmej wmei))))
        (setf spread (* (wme-source wmej) ia))
        (signal-output *activation-trace* "   Spreading activation ~6,3F from source ~S level ~6,3F times IA ~6,3F"
                       spread wmej (wme-source wmej) ia)
        (incf (wme-source-spread wmei) spread)))
    (dolist (source-name (no-output (activation-sources)))
      (setf wmej (get-wme source-name))
      (when (compute-activ-p wmej)
	(setf ia (associate  wmei wmej))
	(setf spread (* (wme-source wmej) ia))
        (signal-output *activation-trace* "   Spreading activation ~6,3F from source ~S level ~6,3F times IA ~6,3F"
                       spread wmej (wme-source wmej) ia)
        (incf (wme-source-spread wmei) spread)))

    (setf (wme-spread-stamp wmei) *spread-stamp*)
    (incf (wme-activation wmei) (wme-source-spread wmei))
    (wme-source-spread wmei)))

(proclaim '(inline my-wme-type))


;;;; general functions
;;;;==================

(defun make-intern-symbol (str)
  "Makes an internal symbol with the name ``str''."
 (intern (string-upcase str)))

(defun flatten (list)
  ;;; flattens a list of lists
  (apply #'concatenate 'list list))

(defun rand-elem (list size &optional (init 0))
  "Removes a random element from the list; returns the element removed."
  (let* ((which (+ (random size) init))
         (elem (nth which list)))
    (values elem (remove elem list))))


(proclaim '(inline make-intern-symbol flatten))



;;;; functions dealing with chunks
;;;;==============================

(defun set-bl (chunk bl)
  (eval `(set-base-levels (,chunk ,bl))))

(defun get-bl (chunk)
  (first (eval `(no-output (get-base-level ,chunk)))))

(defun sym-add-ia (chunk1 chunk2 ia)  
  (if ia 
      (first (eval `(no-output (add-ia 
		       (,chunk1 ,chunk2 ,ia)
		       (,chunk2 ,chunk1 ,ia)))))
      0))

(defun chunk-exists (chunk)
  ;; returns the chunk if it exists or nil otherwise
  (first (eval `(no-output (dm ,chunk)))))


(proclaim '(inline set-bl get-bl sym-add-ia chunk-exists))

;;;; functions dealing with plinks
;;;; ============================

(defun plink-get-child (link)
  (eval `(chunk-slot-value ,link child)))

(defun plink-get-parent (link)
  (eval `(chunk-slot-value ,link parent)))

(defun plink-exists (prop word role)
  (first (eval `(no-output (sdm isa prop-link type ,role 
				parent ,prop child ,word)))))

(defun plink-get-type (plink)
  (eval `(chunk-slot-value ,plink type)))

(defun plink-get-context (plink)
  (eval `(chunk-slot-value ,plink context)))

(defun generate-plink-name (base link &optional (middle ""))
  (let ((dash (if (string= middle "") "" "-")))
    (new-name-fct 
     (concatenate 'string "*" (string base) "-" (string middle)  dash 
		   (string link) "*"))))

(defun dump-plinks ()
  ;; returns a list with all  plinks 
  ;; in dm
  (eval `(no-output (sdm isa prop-link))))


(defun plink-p (wme-or-name)
  (equal 'prop-link 
	 (wme-type-name 
	  (wme-type (if (wmep wme-or-name) wme-or-name (get-wme wme-or-name))))))


(proclaim '(inline plink-get-parent plink-get-type plink-get-child plink-exists
		   dump-plinks plink-p))

;;;; functions dealing with words (wlinks)
;;;;======================================


(defun wlink-exists (lexeme cat)
  (first 
   (eval `(no-output (sdm isa  word lexeme ,lexeme cat ,cat meaning 
			  ,(meaning-name lexeme))))))

(defun wlink-get-meaning (wlink)
  (eval `(chunk-slot-value ,wlink meaning)))

(defun wlink-get-lexeme (wlink)
  (eval `(chunk-slot-value ,wlink lexeme)))

(defun wlink-get-type (wlink)
  (eval `(chunk-slot-value ,wlink type)))

(defun wlink-get-cat (wlink)
  (eval `(chunk-slot-value ,wlink cat)))


(defun find-wlink (meaning)
  (first 
   (eval `(no-output (sdm isa  word meaning ,meaning)))))



(defun create-wlink(lexeme cat &optional (type 'none))
  (unless (chunk-exists lexeme)  
    (eval `(add-dm (,lexeme isa chunk))))
        
  (cond ((wlink-exists lexeme cat))
	(t (let ((word-link (generate-plink-name lexeme "wlink")) 
		 (meaning-chunk (meaning-name lexeme)))	       
	     (eval (no-output 
		    `(add-dm (,word-link isa word lexeme ,lexeme cat ,cat type ,type
					 meaning ,meaning-chunk))))))))


(defun wlink-p (wme-or-name)
  (equal 'word
	  (wme-type-name 
	   (wme-type (if (wmep wme-or-name) wme-or-name (get-wme wme-or-name))))))

      
(defun dump-wlinks ()
  (eval `(no-output (sdm isa word))))


(proclaim '(inline wlink-p wlink-exists wlink-get-lexeme wlink-get-meaning dump-wlinks))

;;;; meanings
;;;;=========

(defun atomic-p (meaning)
  (not (composite-p meaning)))


(defun composite-p (meaning)
  (eval `(no-output (chunk-slot-value ,meaning composite))))


(defun meaning-get-plinks (meaning &optional (role nil))
  (if role
      (eval `(no-output (sdm isa prop-link parent ,meaning type ,role)))
    (eval `(no-output (sdm isa prop-link parent ,meaning)))))


(defun meaning-get-children (meaning &optional (role nil))
  (mapcar #'(lambda (link)
	      (eval `(no-output (chunk-slot-value ,link child))))
	  (meaning-get-plinks meaning role)))

(defun meaning-get-nonhead-children (meaning)
  (reduce #'(lambda (list link)
	      (if (equal (plink-get-type link) 'head)
		  list
		  (push (plink-get-child link) list)))
	  (meaning-get-plinks meaning)
	  :initial-value nil))

(defun meaning-p (wme-or-name)
  ;; returns whether this wme is of type meaning
  (equal 'meaning (wme-type-name 
		   (wme-type (if (wmep wme-or-name) wme-or-name (get-wme wme-or-name))))))

(defun meaning-name(lexeme)
  ;;returns the chunk name denoting the meaning whose lexeme is the argument
  (make-intern-symbol (concatenate 'string "*" (string lexeme) "*")))

(defun encode-meaning (lexeme cat &optional (type 'none) (composite nil))
  ;;; builds a new meaning chunk and the associated wlink
  (let ((meaning (meaning-name lexeme)))
    (unless (chunk-exists meaning)
      (eval `(no-output (add-dm (,meaning isa meaning composite ,composite)))))
    ;; create a word-link
    (create-wlink lexeme cat type)))



(defun encode-composite-meaning (meaning-ls role-ls)
  (let* ((lexeme (apply #'concatenate
			(cons 'string (dash-strings meaning-ls))))
	 (comp (meaning-name lexeme)))

    (encode-meaning lexeme 'noun 'none t)

    (mapc #'(lambda (meaning role)
	      (prop-create-plink comp meaning role 'meaning))
	  (mapcar #'meaning-name  meaning-ls)
	  role-ls)
    (mapc #'(lambda (meaning)
	      (let ((ovp (meaning-meaning-overlap meaning comp)))
	      (unless (or (equal meaning comp) (zerop ovp))
		(update-meaning-overlap
		 (list meaning comp ovp))))) 
	  (dump-meanings))))


(defun dump-meanings(&optional (composite 'all))
    ;; returns a list with all meanings 
  (if (equal composite 'all)
      (eval `(no-output (sdm isa meaning)))
      (eval `(no-output (sdm isa meaning composite ,composite)))))


(defun dump-content-meanings (&optional (composite 'all))
    ;; returns a list with all meanings that do not correspond to prepositions or inflections
  (let ((meanings (dump-meanings composite)))
    (when (equal composite 'all)
      (setq meanings
	(reduce #'(lambda (list meaning)
		    (let ((wlink (find-wlink meaning)))
		      (unless (or (not wlink) (equal (wlink-get-cat wlink) 'prep) 
				  (equal (wlink-get-cat wlink) 'infl)
				  (equal (wlink-get-cat wlink) 'det))
			(push meaning list))
		      list))
		meanings
		:initial-value nil)))
    meanings))




(proclaim '(inline dump-meanings meaning-get-plinks meaning-get-children meaning-p meaning-name
		   atomic-p composite-p))

;;;; propositions
;;;;=============

(defun prop-p (wme-or-name)
  (equal 'comprehend
	 (wme-type-name 
	  (wme-type (if (wmep wme-or-name) wme-or-name (get-wme wme-or-name))))))

(defun prop-get-plinks(prop &optional (role nil))
  ;; if role is not nil return only plinks associated with that role
  (if role
      (eval `(no-output (sdm isa prop-link parent ,prop type ,role)))
    (eval `(no-output (sdm isa prop-link parent ,prop)))))
   
(defun prop-get-word (prop &optional (role nil))
  ;; if role is not nil return only the concept associated with that role
  (mapcar #'plink-get-child  (prop-get-plinks prop role)))

(defun prop-create-plink (prop word role &optional (context 'none))
  ;; if a plink exists, return it
  (cond ((plink-exists prop word role))
	(t (let ((plink (generate-plink-name prop "plink" word)))
	     (eval `(add-dm 
		     (,plink isa prop-link type ,role
			     parent ,prop
			     child ,word
			     context ,context)))))))

(defun prop-get-roles (prop)
  (remove-duplicates 
   (mapcar #'plink-get-type (prop-get-plinks prop))
   :test #'equal))

(defun prop-get-script (prop)
  (eval `(no-output (chunk-slot-value ,prop script))))

(defun dump-props ()
  (no-output (sdm isa comprehend)))


(defun encode-proposition(lexeme-ls role-ls 
			  &optional (referent nil) (context 'none) (name nil) (script 'none))
  ;;; build alll the chunks corresponding to a proposition
  ;;; assume meaning chunks  have been already built
  ;;; return the chunk corresponding to the new proposition
  (let ((prop (if name name (new-name-fct "prop"))))
    ;; make the chunk corresponding to the new proposition
    (eval `(add-dm (,prop isa comprehend interpretation ,referent context ,context
			  script ,script)))

    ;; make the link chunks for each meaning in the proposition
    (mapc #'(lambda (meaning role)
	      (prop-create-plink prop meaning role context))
	  (mapcar #'meaning-name  lexeme-ls)
	  role-ls)
    prop))

(proclaim '(inline prop-p prop-get-plinks prop-get-word prop-get-script dump-props prop-get-roles))

(defun script-get-props (script)
  (eval `(no-output (sdm isa comprehend script ,script))))

(proclaim '(inline script-get-props))

;;;; overlaps
;;;;==========

;;;; meaning to meaning

;;;; preset overlaps structure: keep meanings rather than lexemes
;;;; ((mean1 mean1 ovp)...)


(defun same-overlap-triplet (x y)
  (not (and (mismatch x y )
            (mismatch (list (second x) (first x)  (third x))
		     y ))))
(proclaim '(inline same-overlap-triplet))

(defun same-overlap-pair (x y)
  ;; compares only the first two elements of the two triplets x and y
  (let ((x2 (butlast x))
	(y2 (butlast y)))
    (not (and (mismatch x2 y2)
	      (mismatch (list (second x2) (first x2)) y2)))))

(defun meaning-overlaps (meaning)
  ;; returns a list of all triplets in *overlaps* involving meaning
  (reduce #'(lambda(list x)
	      (if (or  (equal meaning (first x))
		       (equal meaning (second x)))
		  (push x list)
		   list))
	  *overlaps* :initial-value nil))
  
(defun add-meaning-overlaps(&rest triplets)  
  ;; unions the old *overlaps* list with the new one
  ;; triplets contain meanings rather than lexemes
  (setq *overlaps* 
    (union *overlaps* triplets 
	   :test #'same-overlap-triplet)))

(defun update-meaning-overlap(triplet)  
  ;; unions the old *overlaps* list with the new one
  ;; pairs already in the list are modified
  ;; triplets contain meanings rather than lexemes
  (let ((memb (member triplet *overlaps* :test #'same-overlap-pair)))
    (if memb
	(setf (third (first memb)) (third triplet))
      (push triplet *overlaps*))))


(defun change-meaning-overlap (triplet)
  ;; modifies existing overlaps
  (let ((memb (member triplet *overlaps* :test #'same-overlap-pair)))
    (when memb
      (setf (third (first memb)) (third triplet)))))


(defun get-preset-meaning (meaning1 meaning2)
  ;;; extracts the overlap between two meanings from the overlap list
  (third
   (car 
    (member (list meaning1 meaning2) *overlaps*
	    :test #'(lambda (el triplet)
		      (let ((m-pair (butlast triplet)))
			(not (and (mismatch m-pair
					    el)
				  (mismatch (list meaning2 meaning1)
					    m-pair)))))))))


;;;; overlaps involving composite meanings

(defun composite-atomic-overlap (comp atomic)
  (let* ((children-ls (meaning-get-children  comp))
	 (n (length children-ls)))
    (if (zerop n) 0
      (/
       (apply #'+ ;max
	      (mapcar #'(lambda (child)
			  (meaning-meaning-overlap child atomic))
		      children-ls))
       n))))
	    

(defun atomic-composite-overlap (atomic comp)
  ;; here everything is symmetric
  (composite-atomic-overlap comp atomic))

(proclaim '(inline atomic-composite-overlap))

(defun meaning-meaning-overlap (meaning1 meaning2)
  (let ((preset-ovp (get-preset-meaning meaning1 meaning2)))
    (assert (and meaning1 meaning2))
    (cond ((equal meaning1 meaning2) 1)
	  (preset-ovp preset-ovp)
	  ((and (atomic-p meaning1) (atomic-p meaning2)) 0)
	  ((or (and (composite-p meaning1) (null (meaning-get-children meaning1 'head)))
	       (and (composite-p meaning2) (null (meaning-get-children meaning2 'head))))
	   0)
	  ((atomic-p meaning1)
	   (let* ((children (meaning-get-children meaning2)) 
		  (children-no (length children)))
	     (assert children)
	     (/ (apply #'+
		       (mapcar #'(lambda (child)
				   (meaning-meaning-overlap meaning1 child))
			       children))
		children-no)))
	  ((atomic-p meaning2)
	   (let* ((children (meaning-get-children meaning1)) 
		  (children-no (length children)))
	     (assert children)
	     (/ (apply #'+
		       (mapcar #'(lambda (child)
				   (meaning-meaning-overlap child meaning2))
			       children))
		children-no)))
	  (t
	   (let* ((children1 (meaning-get-children meaning1)) 
		  (children2 (meaning-get-children meaning2))
		  (div 0) 
		  (children-no1 (length children1)) 
		  (children-no2 (length children2)))

	     (assert (and children1 children2))
	     (setq div (max children-no1 children-no2))
	     (if (zerop div) 0
	       (/ 
		(apply #'+
		       (mapcar #'(lambda (arg1)
					 (apply #'+
						(mapcar #'(lambda (arg2)
							   (meaning-meaning-overlap arg1 arg2))
							children2)))
				     children1))
		div)))))))
	 


;;;; meaning to plinks and words

(defun meaning-plink-overlap (meaning plink)
 (meaning-meaning-overlap meaning
			   (plink-get-child plink)))

(defun meaning-wlink-overlap (meaning wlink)
 (meaning-meaning-overlap meaning (wlink-get-meaning wlink)))

(proclaim '(inline meaning-plink-overlap meaning-wlink-overlap))

  
;;;; meaning to proposition

(defun meaning-prop-overlap (meaning prop &optional (role nil))
  ;; compute if the meaning and the prop overlap
  ;; if role is not nil, compute whether the meaning overlaps 
  ;; with the filler of role
  (let* ((p-word-ls (prop-get-word prop role))
	 (n (length p-word-ls)))
    (if (zerop n) 0
      (/ 
       (reduce #'(lambda (result word)
		   (+ result (meaning-meaning-overlap meaning word)))
	       p-word-ls
	       :initial-value 0)
       1)))) 

;;;; proposition to proposition


(defun prop-prop-overlap (prop1 prop2) 
  ;;add overlaps for meanings in two props; the function takes into
  ;; account corresponding roles if rolewise is t, and it doesn't
  ;; otherwise
  (if (equal prop1 prop2) 1

    (let* ((p1-role-ls (prop-get-roles prop1))
	   (p2-role-ls (prop-get-roles prop2))
	   (role-ls (intersection p1-role-ls p2-role-ls :test #'equal)))
		  
      (/
       ;; sum of overlaps of meanings with the same roles in the two props
       (reduce #'(lambda(result role)
		   (let* ((p1-word-ls (prop-get-word prop1 role)))
		     (reduce #'(lambda (new-result word)
				 (+ new-result 
				    (meaning-prop-overlap word prop2 role)))
			     p1-word-ls
			     :initial-value result)))		  
	       role-ls
	       :initial-value 0)
       (length (union p1-role-ls p2-role-ls :test #'equal))))))

;;; proposition to prop-link and words

(defun prop-plink-overlap (prop plink)
  (meaning-prop-overlap (plink-get-child plink)
			 prop))

(defun prop-wlink-overlap (prop wlink)
  (meaning-prop-overlap (wlink-get-meaning wlink)
			 prop))
(proclaim '(inline prop-plink-overlap prop-wlink-overlap))

;;; prop-link to other links

(defun plink-plink-overlap (plink1 plink2)
  (meaning-meaning-overlap (plink-get-child plink1)
			    (plink-get-child plink2)))

(defun plink-wlink-overlap (plink wlink)
  (meaning-meaning-overlap (plink-get-child plink)
			    (wlink-get-meaning wlink)))

;;; wlinks to wlinks

(defun wlink-wlink-overlap (wlink1 wlink2)
  (meaning-meaning-overlap (wlink-get-meaning wlink1)
			    (wlink-get-meaning wlink2)))


(proclaim '(inline plink-plink-overlap plink-wlink-overlap wlink-wlink-overlap))

;;;; associations
;;;;=============


(defun associate-meaning-to-meaning (meaning1 meaning2)
  (sym-add-ia meaning1 meaning2
	       (ia-formula *base* *incr*
			    (meaning-meaning-overlap meaning1 meaning2))))

(defun associate-meaning-to-plink (meaning plink)
  (sym-add-ia meaning plink
	       (ia-formula *base* *incr*
			    (meaning-plink-overlap meaning plink))))
  
(defun associate-meaning-to-wlink (meaning wlink)
  (sym-add-ia meaning wlink
	       (ia-formula *base*
			   *incr*
			    (meaning-wlink-overlap meaning wlink))))

(defun associate-meaning-to-prop (meaning prop)
  (sym-add-ia meaning prop
	       (ia-formula *base* *pincr*
			    (meaning-prop-overlap meaning prop))))

(defun associate-prop-to-plink (prop plink)
  (sym-add-ia  prop plink
	       (ia-formula *base* *pincr*
			    (prop-plink-overlap prop plink))))

(defun associate-prop-to-wlink (prop wlink)
  (sym-add-ia  prop wlink
	       (ia-formula *base* *pincr*
			    (prop-wlink-overlap prop wlink))))

(defun associate-prop-to-prop (prop1 prop2)
   (sym-add-ia  prop1 prop2
		(if (equal prop1 prop2)
		    (ia-formula *base* *self-ia* 1)
		  (ia-formula *base* *pincr*
			      (prop-prop-overlap prop1 prop2)))))

(defun associate-plink-to-plink (plink1 plink2)
  (sym-add-ia  plink1 plink2
		(ia-formula *base* *incr*
			    (plink-plink-overlap plink1 plink2))))

(defun associate-wlink-to-plink (wlink plink)
  (sym-add-ia  wlink plink
		(ia-formula *base* *incr*
			    (plink-wlink-overlap plink wlink))))


(defun associate-wlink-to-wlink (wlink1 wlink2)
  (sym-add-ia  wlink1 wlink2
		(ia-formula *base* *incr*
			    (wlink-wlink-overlap wlink1 wlink2))))

(defun associate-lexeme-to-wlink (wlink)
  (sym-add-ia wlink (wlink-get-lexeme wlink) 
	       (ia-formula *base* *self-ia* 1))) 

(defun associate-script-to-prop (script prop)
  (sym-add-ia script prop 
	      (ia-formula *base* *incr* 
			  (if (equal (prop-get-script prop) script) 1 0))))

(defun associate-script-to-plink (script plink)
  (sym-add-ia script plink (ia-formula *base* *incr* 
				       (if (equal (plink-get-context plink) script) 1 0))))

(defun associate-role-to-plink (role plink)
  (when (equal (plink-get-type plink) role)
    (sym-add-ia plink role (ia-formula *base* *incr* 0.5))))

(proclaim '(inline associate-meaning-to-meaning associate-meaning-to-prop associate-meaning-to-wlink
		   associate-meaning-to-plink associate-prop-to-prop associate-prop-to-plink
		   associate-prop-to-wlink associate-plink-to-plink associate-wlink-to-plink
		   associate-wlink-to-wlink associate-lexeme-to-wlink associate-script-to-plink
		   associate-script-to-prop))

(defun role-p (wme-or-name)
  (member
   (if (wmep wme-or-name) (wme-name wme-or-name) wme-or-name)
   '(funct patient agent theme-oblique part-oblique 
	   place-oblique time-oblique instr-oblique mod-oblique
	   purpose-oblique recipient) :test #'equal))

		   
(defun associate (wmei wmej &optional (visited (list wmei wmej)))
  ;;; wmei and wmej are wme-s rather than names
  ;;; wmej spreads activation (source)
  (let (
	(default 0))
    (cond ((equal wmei wmej)
	   (ia-formula *base* *self-ia* 1))	
	  ((or (null wmei) (null wmej)) default)
	  ((or (stringp wmei) (stringp wmej)) default)
	  ((or (equal (wme-name wmei) 'none) (equal (wme-name wmej) 'none)) default)
	  ((and (<= (wme-creation-time wmei) 0) (<= (wme-creation-time wmej) default)
		(not (member (wme-name wmei) *extras* :test #'equal))
		(not (member (wme-name wmej) *extras* :test #'equal)))
	   (eval `(no-output (ia ,(wme-name wmei) ,(wme-name wmej)))))
	  ((and (role-p wmei) (plink-p wmej))
	   (associate-role-to-plink (wme-name wmei) (wme-name wmej)))
	  ((prop-p wmei)
	   (cond ((prop-p wmej)
		  (associate-prop-to-prop (wme-name wmei) (wme-name wmej)))
		 ((meaning-p wmej)
		  (associate-meaning-to-prop (wme-name wmej) (wme-name wmei)))
		 ((plink-p wmej)
		  (associate-prop-to-plink (wme-name wmei) (wme-name wmej)))
		 ((wlink-p wmej)
		  (associate-prop-to-wlink (wme-name wmei) (wme-name wmej)))
		 (t (let ((slots (rest (wme-slot-wmes wmei))))
		      (if (null slots) 0
			(apply #'max	; or +? 
			       (mapcar #'(lambda(x)
					   (if (member (list x wmej) visited :test #'equal)
					       default
					      (progn (push (list x wmej) visited)
						     (associate x wmej visited))))
				       (rest (wme-slot-wmes wmei)))))))))
	  ((meaning-p wmei)
	   (cond ((prop-p wmej)
		  (associate-meaning-to-prop (wme-name wmei) (wme-name wmej)))
		 ((meaning-p wmej)
		  (associate-meaning-to-meaning (wme-name wmei) (wme-name wmej)))
		 ((plink-p wmej)
		  (associate-meaning-to-plink (wme-name wmei) (wme-name wmej)))
		 ((wlink-p wmej)
		  (associate-meaning-to-wlink (wme-name wmei) (wme-name wmej)))
		 (t 0)))
	  ((plink-p wmei)
	   (cond ((prop-p wmej)
		  (associate-prop-to-plink (wme-name wmej) (wme-name wmei)))
		 ((meaning-p wmej)
		  (associate-meaning-to-plink (wme-name wmej) (wme-name wmei)))
		 ((plink-p wmej)
		  (associate-plink-to-plink (wme-name wmei) (wme-name wmej)))
		 ((wlink-p wmej)
		  (associate-wlink-to-plink (wme-name wmej) (wme-name wmei)))
		 ((role-p wmej)
		  (associate-role-to-plink (wme-name wmej) (wme-name wmei)))
		 (t (apply #'max	; or +?
			   (mapcar #'(lambda(x)
				       (if (member (list x wmej) visited :test #'equal)
					   default
					 (progn (push (list x wmej) visited)
						(associate x wmej visited))))
				       (rest (wme-slot-wmes wmei)))))))
	  ((wlink-p wmei)
	   (cond ((prop-p wmej)
		  (associate-prop-to-wlink (wme-name wmej) (wme-name wmei)))
		 ((meaning-p wmej)
		  (associate-meaning-to-wlink (wme-name wmej) (wme-name wmei)))
		 ((plink-p wmej)
		  (associate-wlink-to-plink (wme-name wmej) (wme-name wmei)))
		 ((wlink-p wmej)
		  (associate-wlink-to-wlink (wme-name wmei) (wme-name wmej)))
		 (t (apply #'max	; or +? 
			   (mapcar #'(lambda(x)
				       (if (member (list x wmej) visited :test #'equal)
					   default
					 (progn (push (list x wmej) visited)
						(associate x wmej visited))))
				   (rest (wme-slot-wmes wmei)))))))
	  ((null (rest (wme-slot-wmes wmei)))
	   0)
	  (t
	   (apply #'max			; or +?
		  (mapcar #'(lambda(x)
			      (if (member (list x wmej) visited :test #'equal)
				  default
				(progn (push (list x wmej) visited)
				       (associate x wmej visited))))
			  (rest (wme-slot-wmes wmei))))))))



;;;; ia

(defun ia-formula (base increment n)
  ;; can be changed
  ;;base+increment*n
  (+ base (* n increment)))

(proclaim '(inline ia-formula))

;;;; map functions
;;;; =============
  

(defun encode-propositions (prop-ls role-ls &optional (debug t) (referent nil)
							(context 'none) (script 'none))
  ;; prop-ls: a list of list of items making a proposition role-ls:
  ;; the list of roles all propositions should have the same lexical
  ;; structure; the meanings should be already created
  (mapcar #'(lambda(prop)
	    	      ;;;encode proposition
	      (let ((prop-chunk (encode-proposition prop role-ls referent context nil script)))
		(when debug
		  (format *command-trace* 
			  "~&Prop ~s stands for ~s" prop-chunk prop))
		prop-chunk))
	  prop-ls))


(defun associate-prop-to-props (prop prop-ls)
  ;;associate one proposition with the others in DM
  ;;self-ia is the value of ia with itself; if it is nil, it's the default;
  ;; if t then it is computed based by the number of overlapping features, 
  ;; if it is a number it is set to that number
  (mapcar #'(lambda(other)
	       (associate-prop-to-prop prop other)) prop-ls))

(defun associate-meaning-to-plinks (chunk &optional (plink-ls nil))
  ;; associate a chunk to plinks; chunk is a
  ;; meaning;
  (mapcar #'(lambda(link)
	      (associate-meaning-to-plink chunk link))
	  (if plink-ls plink-ls (dump-plinks))))

(defun associate-meaning-to-wlinks (chunk)
  ;; associate a chunk to wlinks; chunk can be a
  ;; meaning 
  (mapcar #'(lambda(link)
	       (associate-meaning-to-wlink chunk link))
	   (dump-wlinks)))

(defun associate-lexemes-to-wlinks ()
  ;; for each wlink, it associates it with the corresponding lexeme
  (mapcar #'(lambda(link)
	       (associate-lexeme-to-wlink link))
	   (dump-wlinks)))
 

(defun associate-prop-to-meanings (prop)
  (mapcar #'(lambda(meaning)
	      (associate-meaning-to-prop meaning prop))
	  (dump-meanings)))

(defun associate-prop-to-plinks (chunk &optional plinks-ls)
  ;; associate a prop to plinks;
  (mapcar #'(lambda(link)
	      (associate-prop-to-plink chunk link))
	  (if plinks-ls plinks-ls (dump-plinks))))

(defun associate-prop-to-wlinks (chunk &optional wlinks-ls)
  ;; associate a prop to plinks;
  (mapcar #'(lambda(link)
	      (associate-prop-to-wlink chunk link))
	  (if wlinks-ls wlinks-ls (dump-wlinks))))


(defun associate-role-to-plinks (role &optional (plink-ls nil)) 
  ;;can be modified easily if role confusion is wanted and if there
  ;; are similarities among different roles
  (mapcar #'(lambda(link)
	      (associate-role-to-plink role link))
	  (if plink-ls plink-ls (dump-plinks))))	  


(proclaim '(inline associate-role-to-plinks associate-prop-to-plinks associate-prop-to-wlinks
		   associate-lexemes-to-wlinks
		   associate-meaning-to-wlinks associate-meaning-to-plinks))

;;; former function associate-prop is approximately equivalent with
;;; the new one, but it also included associations between the plinks of
;;; prop and the overlapping meanings, but this can be done for all
;;; plinks at once by calling (associate-meaning-to-links meaning
;;; 'prop-link) for all meanings in DM

(defun associate-prop (prop)
  (associate-prop-to-meanings prop)
  (associate-prop-to-plinks prop)
  (associate-prop-to-wlinks prop))

(proclaim '(inline associate-prop))

(defun associate-meaning (meaning)
  (mapc #'(lambda(x)
	    (associate-meaning-to-meaning x meaning))
	(dump-meanings))
  (associate-meaning-to-plinks meaning)
  (associate-meaning-to-wlinks meaning)
  (mapcar #'(lambda(prop)
	       (associate-meaning-to-prop meaning prop))
	   (dump-props)))

(defun associate-script (script)
  (mapc #'(lambda(prop)
	      (associate-script-to-prop script prop)
	      (mapc #'(lambda(plink)
			(associate-script-to-plink script plink))
		    (prop-get-plinks prop)))
	(dump-props)))


(defun associate-all-meanings ()
  (maplist #'(lambda (meaning-ls)
	       (mapcar #'(lambda(m1)
			   (associate-meaning-to-meaning (first meaning-ls)
							 m1))
		       meaning-ls))
	   (dump-meanings)))

(defun associate-all-props()
  (maplist #'(lambda (prop-ls)
	      (associate-prop-to-props (first prop-ls) prop-ls))
	  (dump-props)))

(defun associate-all-meanings-to-links ()
  (mapcar #'(lambda(meaning)
	      (associate-meaning-to-plinks meaning)
	      (associate-meaning-to-wlinks meaning))
	  (dump-meanings)))

(proclaim '(inline associate-all-props associate-all-meanings-to-links))
 

;;;; helpers for running the model and for testing it
;;;;=================================================


  
(defun dash-strings (symbol-ls)
  ;;; generate a string made from symbols in the list separated by dash
  (rest (reduce #'(lambda  (symbol res)
		    (cons "-" (cons (string symbol) res)))
		symbol-ls :from-end t :initial-value nil)))




(defun get-next-word()
  (when (>= *count* 0)
	     (setf (aref *w-rt* *count*) (- (actr-time) (aref *w-rt* *count*))))
  (when  (< *count* (length *sent*)) (incf *count*))
  (setf (aref *w-rt* *count*) (actr-time))
  (if  (nth *count* *sent*) (nth *count* *sent*) 'eof))

(defun eof-p()
  (when (>= *count* (1- (length *sent*)))
    t))

;;;;;;;;;;

(defun make-chunks(chunk-ls)
  (mapc #'(lambda(chunk)
	    (unless (eval `(no-output (dm ,chunk)))
	      (eval `(add-dm (,chunk isa chunk)))))
	chunk-ls))


(defun one-trial(&optional (sentence *sent*)
			   (back-knowledge-fun nil))
  (setq *count* -1   *sent* sentence)
  (setq *answer* 0)
  (if (arrayp *w-rt*)
      (progn
	(reset-w-rt)
	(unless  (= (array-dimension *w-rt* 0) (1+ (length *sent*))) 
	  (setq *w-rt* (adjust-array *w-rt* 
				   (list (1+ (length *sent*))) 
				   :initial-contents 
				   (make-list (1+ (length *sent*)) 
					    :initial-element 0)))
	  ))
	(setq *w-rt* (make-array  (list (1+ (length *sent*)))
				  :adjustable t
				  :initial-element 0)))
    
  (when back-knowledge-fun (funcall back-knowledge-fun))
  (let ((goal (new-name-fct "goal"))
	(parse (new-name-fct "parse")))
    (eval `(no-output (add-dm (,goal isa comprehend context experiment task "interpretation")
			      (,parse isa parse meaning ,goal))
		      (goal-focus ,parse)))
    (noneize-goal goal)
    
    (associate-prop goal)
    (associate-prop-to-props goal (dump-props))
    (eval `(add-ia (,goal ,goal ,(ia-formula *base* *self-ia* 1))))
    (eval `(no-output (mod-chunk dummy context ,goal)))
    (values goal parse)))

(defun reset-w-rt ()
  (dotimes (i (array-dimension *w-rt* 0))
    (setf (aref *w-rt* i)  0)))


(defun noneize-goal(chunk)
  ;;replace some nil slots in goal with "none"
  (eval `(no-output (mod-chunk ,chunk interpretation none word none previous-interpretation none
			       word-1 none word-2 none word-3 none script none))))

(proclaim '(inline noneize-goal))

 
(defun delete-local(&optional (time 0))
  ;; delete chunks specific to one trial
  (delete-chunk-fct
   (no-output (sdm isa comprehend context experiment)))
  (delete-chunk-fct (no-output (sdm isa parse)))
  (mapc #'(lambda(chunk)
	      (if (> (wme-creation-time (get-wme chunk)) time)
		  (eval `(no-output (delete-chunk ,chunk)))))
	(no-output (sdm)))) 


;;;; specific functions

(defvar *answer*)
(setq *answer* 0)

(setq *base*  -16)
(setq *incr* 32);10;12
(setq *pincr* 21);6
(setq *self-ia* 64);4
(setq *overlaps* nil)


;;; generating predictions

(defparameter +MET+ 0)
(defparameter +LIT+ 1)

(defparameter +ORIG-TRIALS+ 8)
(defparameter +TRIALS+ 2)
(defparameter +2TRIALS+ (/ +TRIALS+ 2))



(defparameter +TRUE+ 0)
(defparameter +EASY+ 1)
(defparameter +HARD+ 2)

(defparameter *easy* 0)

(defstruct 
    (story
     (:type list))
  (text nil :type list)
  (overlaps nil :type list)		; a list of overlapping items in a story
					; containing pairs
					;(set superset nr-common-feat)
  metaphor
  literal  
  (pred nil :type list)		;only predicate
  (meanings nil :type list)
  (truth +TRUE+)
  (props nil)				;propositions corresponding to this story
  )


(defun story-subject (story cond)
  (cond ((= cond +MET+) (story-metaphor story))
	((= cond +LIT+) (story-literal story))))

;;;; all the materials in this file are for the metaphor athlete-- bear

(defparameter *roles-1* '(agent verb place-oblique))
(defparameter *roles-4* '(agent verb patient))
(defparameter *roles-5* '(agent verb purpose-oblique))

(defvar *story-1*)
(setq *story-1*
  (make-story
   :text  (list
	   (list (list '(Joe see match) '(JimSmith love applause))
		 *roles-4*)
	   (list (list '(JimSmith compete finals))
		 *roles-5*))
   :metaphor '(the bear)
   :literal '(the wrestler)
   :overlaps (list  `(*wrestler* *JimSmith* ,*true-lit*) `(*bear* *JimSmith* ,*true-met*)
		    `(*semifinals* *finals* ,*easy*))
   :pred '(compete for semifinals)
   :truth +EASY+
   :meanings '((Joe noun) (see verb) (match noun)
	       (JimSmith noun) (love verb) (applause noun)
	       (compete verb) (finals noun) (semifinals noun) 
	       (for prep purpose-oblique) (bear noun) (wrestler noun) (the det))))


(defvar *story-2*)
(setq *story-2*
  (make-story
   :text  (list
	   (list (list '(Unknown sleep class)
		       '(Unknown NotPayAttention class)) 
		 *roles-1*)
	   (list (list '(Jim notice professor))
		 *roles-4*))

   :metaphor '(the bear)
   :literal '(the linebacker)
   :pred '(notice the professor)
   :overlaps  (list `(*bear* *unknown* ,*true-met*)   `(*linebacker* *unknown* ,*true-lit*))
		    
   :truth +HARD+
   :meanings '((unknown noun) (sleep verb) (class noun) (in prep place-oblique) (NotPayAttention verb)
	       (notice verb) (professor noun) (Jim noun) (the det) (bear noun) (linebacker noun))))
	       
(defvar *story-3*)
(setq *story-3*
  (make-story
   :text  (list (list (list '(George go chalet) 
			    '(George hardwork chalet)) *roles-1*)
		(list (list   '(George carry water) 
			      '(George cutdown trees))   *roles-4*))
   :metaphor '(the bear)
   :literal '(the lumberjack)
   :pred '(hardwork at chalet)
   :truth +TRUE+
   :overlaps  (list `(*bear* *George* ,*true-met*)  `(*lumberjack* *George* ,*true-lit*))
   :meanings '((George noun) (go verb) (chalet noun) (hardwork verb) (carry verb) (water noun)
	       (cutdown verb) (trees noun) (the det) (bear noun) (lumberjack noun) (at prep place-oblique)
	       (in prep place-oblique) (city noun))))
   

(defvar *story-4*)
(setq *story-4*
  (make-story
   :text  (list  (list (list '(JohnQ pay visit) '(MrsJones  make cake)
			     '(JohnQ crack nuts)) *roles-4*))
   :metaphor '(the bear)
   :literal '(the armwrestler)
   :overlaps (list `(*bear* *JohnQ* ,*true-met*) 
		   `(*armwrestler*  *JohnQ*  ,*true-lit*))
   :pred '(crack the nuts)
   :meanings '((JohnQ noun) (pay verb) (visit noun) (MrsJones noun) (make verb) (cake noun)
	       (crack verb) (nuts noun) (the det) (bear noun) (armwrestler noun) (bed noun))
   :truth +TRUE+))
   
;;; the next four stories are the same (formally) with the first four
;;; (just made of different words)

(defvar *2story-1*)
(setq *2story-1*
  (make-story
   :text  (list
	   (list (list '(2Joe 2see 2match) '(2JimSmith 2love 2applause))
		 *roles-4*)
	   (list (list '(2JimSmith 2compete 2finals))
		 *roles-5*))
   :metaphor '(the bear)
   :literal '(the 2wrestler)
   :overlaps (list  `(*2wrestler* *2JimSmith* ,*true-lit*) `(*bear* *2JimSmith* ,*true-met*))
   :pred '(2compete for  2semifinals)
   :truth +EASY+
   :meanings '((2Joe noun) (2see verb) (2match noun)
	       (2JimSmith noun) (2love verb) (2applause noun)
	       (2compete verb) (2finals noun) (2semifinals noun)
	       (2for prep purpose-oblique) (bear noun) (2wrestler noun) (the det))))

(defvar *2story-2*)
(setq *2story-2*
  (make-story
   :text  (list
	   (list (list '(2Unknown 2sleep 2class)
		       '(2Unknown 2NotPayAttention 2class)) 
		 *roles-1*)
	   (list (list '(2Jim 2notice 2professor))
		 *roles-4*))

   :metaphor '(the bear)
   :literal '(the 2linebacker)
   :pred '(2notice the 2professor)
   :truth +HARD+
   :overlaps  (list `(*bear* *2unknown* ,*true-met*)   `(*2linebacker* *2unknown* ,*true-lit*))
   :meanings '((2unknown noun) (2sleep verb) (2class noun) (2in prep place-oblique) (2NotPayAttention verb)
	       (2notice verb) (2professor noun) (2Jim noun) (the det) (bear noun) (2linebacker noun))))
	       
(defvar *2story-3*)
(setq *2story-3*
  (make-story
   :text  (list (list (list '(2George 2go 2chalet) 
			    '(2George 2hardwork 2chalet)) *roles-1*)
		(list (list   '(2George 2carry 2water) 
			      '(2George 2cutdown 2trees))   *roles-4*))
   :metaphor '(the bear)
   :literal '(the 2lumberjack)
   :pred '(2hardwork 2at 2chalet)
   :truth +TRUE+
   :overlaps  (list `(*bear* *2George* ,*true-met*)  `(*2lumberjack* *2George* ,*true-lit*))
   :meanings '((2George noun) (2go verb) (2chalet noun) (2hardwork verb) (2carry verb) (2water noun)
	       (2cutdown verb) (2trees noun) (the det) (bear noun) (2lumberjack noun) (2at prep place-oblique)
	       (2in prep place-oblique) (2city noun))))
   

(defvar *2story-4*)
(setq *2story-4*
  (make-story
   :text  (list  (list (list '(2JohnQ 2pay 2visit) '(2MrsJones  2make 2cake)
			     '(2JohnQ 2crack 2nuts)) *roles-4*))
   :metaphor '(the bear)
   :literal '(the 2armwrestler)
   :overlaps (list `(*bear* *2JohnQ* ,*true-met*) 
		   `(*2armwrestler*  *2JohnQ*  ,*true-lit*))
   :pred '(2crack the 2nuts)
   :truth +TRUE+
   :meanings '((2JohnQ noun) (2pay verb) (2visit noun) (2MrsJones noun) (2make verb) (2cake noun)
	       (2crack verb) (2nuts noun) (the det) (bear noun) (2armwrestler noun) (2bed noun))))


(defvar *stories*)
(setq *stories*
  (list *story-1* *story-2* *story-3* *story-4*
	*2story-1* *2story-2* *2story-3* *2story-4*))

(defvar *roles*)
(setq *roles* '(agent verb place-oblique purpose-oblique patient))
    



(defvar *rt-pred* (make-array (list 2 3 +2TRIALS+) :initial-element 0))
(defvar *perc-pred* (make-array (list 2 3 +2TRIALS+) :initial-element 0))


;;;; representing stories into DM

(defun read-story(story &optional (debug t) (referent nil) (context nil))
  ;;; add to dm all the info related to the story
  ;;; returns all the props in the story
  (mapcar #'(lambda (x)
	      (apply #'encode-meaning x))
	  (story-meanings story))
  (apply #'add-meaning-overlaps (story-overlaps story))
  (let ((props (flatten (mapcar #'(lambda (pair)
				    (encode-propositions 
				     (first pair) 
				     (second pair) debug referent context))
				(story-text story)))))
     (mapcar #'associate-prop props)
    props))



(defun update-context(prop-ls context)
 ;;update the context slot of all props in the prop-ls
  (mapcar #'(lambda(prop)
	      (eval `(mod-chunk ,prop context ,context))
	      (mapcar #'(lambda(plink)
			  (eval `(mod-chunk ,plink context ,context)))
		      (PROP-GET-PLINKS prop)))
	  prop-ls))

(proclaim '(inline update-context))
   

(defun learning-back-knowledge (&optional (story *story-1*) (type +MET+) (debug t))
  ;;; for debugging mainly

  (let ((goal) (story-props))
	
    (setq *sent* 
      (append (story-subject story type)
	      (story-pred story)))
 
    (setq *correct-answer* (if (= (story-truth story) +TRUE+) 0 1))
    (setq story-props (read-story story debug))

    (associate-all-props)
    (associate-all-meanings-to-links)
    (associate-all-meanings)
    (mapcar #'associate-role-to-plinks *roles*)
    (add-ia (none none 0))
    (associate-lexemes-to-wlinks)
    (eval `(sgp :rt ,*rt*  :lf ,*lf* :ans ,*ans*))
    (setq goal (one-trial))       
    (update-context story-props goal)
    )) 
  
(defun avg(x y nr-x nr-y)
  (cond ((= nr-x 0) y)
	((= nr-y 0) x)
	(t (/ (+ x y) 2))))


(defun predictions(n  &optional (type +MET+) (debug nil))
  (let ((nr (make-array (list 3 +TRIALS+) :initial-element 0))
	(perc (make-array (list 3 +TRIALS+) :initial-element 0))
	(rt  (make-array (list 3 +TRIALS+) :initial-element 0))
	(truth) (story) (goal)  (stories) 
        (time) 
	(safe-overlaps)) 
    
    (setq *overlaps* nil)
    (reset)
    (unless debug
	(sgp-fct (list :v nil))
	(setq *command-trace* nil)
	(setq *error-output* nil)
	(setq *load-verbose* nil))
    
    
    (mapc #'(lambda(story)
	      (setf (story-props story) (read-story story debug)))
	  *stories*)
    (associate-all-props)
    (associate-all-meanings-to-links)
    (associate-all-meanings)
    (mapcar #'associate-role-to-plinks *roles*)
    (mapcar #'associate-role-to-plinks *roles*)
    (add-ia (none none 0))
    (associate-lexemes-to-wlinks)
    (eval `(sgp  :rt ,*rt* :lf ,*lf* :ans ,*ans* :act nil))
	  
    (setq safe-overlaps *overlaps*)
    (setq *random-state* (make-random-state t))

    (dotimes (subj n)
      (setq stories *stories*)
      (dotimes (trial 2) ; we are only going to use the first two trials
	  (multiple-value-bind (elem new-list)
	      (rand-elem stories (- +ORIG-TRIALS+ trial))
	    (setq story elem)
	    (setq stories new-list))
	  
	  (setq *overlaps* safe-overlaps)
	  (setq truth (story-truth story))
	  (setq *sent*
		(append (story-subject story type)
			(story-pred story)))

	  (setq goal (one-trial))
	  (update-context  (story-props story)
			   goal)
	  (setq *correct-answer* (if (= truth +TRUE+) 0 1))
	  
	  (when debug 
	      (format *command-trace* "~&~(~A~) (~[Target~;Easy foil~;Hard foil~])" *sent* truth))
	  (setq time (actr-time))
	  (run)

	  (setq time (- (actr-time) time))
	  (when (= *answer* *correct-answer*)
	    (incf (aref rt truth trial) time)	;;; 
	    (incf (aref perc truth trial)))
	  (incf (aref nr truth trial))
	  (delete-local)))
    
	    
    ;;; compute final data

    
    (dotimes (truth 3)
      (dotimes (trial +TRIALS+)
	 (unless (zerop (aref perc truth trial))
	   (setf (aref rt truth trial)
	     (/ (aref rt truth trial)
		(aref perc truth trial))))
	(unless (zerop (aref nr truth trial))
	  (setf (aref perc truth trial)
	    (/ (aref perc truth trial) 
	       (aref nr truth trial))))))

    ;;; print results
    (setq *command-trace* t)
    (setq *error-output* *standard-output*)
    (setq *load-verbose* t)
    (sgp :v t)
    
                
      (dotimes (truth 3)
	(dotimes (block (/ +TRIALS+ 2))
	  (setf (aref *rt-pred* type truth block)
		(avg (aref rt truth (* 2 block))
		     (aref rt truth (1+ (* 2 block)))
		     (* (aref nr truth (* 2 block)) (aref perc truth (* 2 block)))
		     (* (aref nr truth (1+ (* 2 block))) (aref perc truth (1+ (* 2 block))))))
	  (setf (aref *perc-pred* type truth block)
		(avg (aref perc truth (* 2 block))
		     (aref perc truth (1+ (* 2 block)))
		     (aref nr truth (* 2 block))
		     (aref nr truth (1+ (* 2 block)))))))))



    
(defun predictions-all(n &optional (debug nil) (lf *lf*) (rt *rt*) (true-met *true-met*)
			 (true-lit *true-lit*))
  (setq *lf* lf *rt* rt *true-met* true-met *true-lit* true-lit)
  (predictions n +MET+ debug)
  (predictions n +LIT+ debug)
  (format *standard-output* "~&Results of the ACT-R simulation")
  (dotimes (i 2)
    (format *standard-output* "~2%~[Percent Correct~;RTs (sec.)~]" i)
    (format *standard-output* "~&~14TMet~22TLit")
    (dotimes (truth 3)
      (format *standard-output* "~&~[Targets~;Easy foils~;Hard foils~]~13T" truth)
      (dotimes (type 2)
	(format *standard-output* "~6,2F~T" (aref (if (zerop i) *perc-pred* *rt-pred*)
						   type truth 0))))))