#|<pre><xmp>
Header:

Budiu & Anderson (in press) looked at word-by-word reading times for three types
of metaphoric sentences and compared them with similar literal
sentences.  They ran an experiment in which participants read passages
followed by target sentences. The target sentences had a
noun~+~verb~+~ending structure. The noun and the verb could be either
metaphoric or literal, resulting in four types of targets: 
(1) metaphoric-noun--metaphoric-verb (abbreviated as
metaphoric--metaphoric),
(2) metaphoric-noun--literal-verb (abbreviated as metaphoric--literal),
(3) literal-noun--metaphoric-verb (abbreviated as
  literal--metaphoric), and
(4)literal-noun--literal-verb (abbreviated as literal--literal).

Budiu & Anderson (in press) measured reading times for individual
noun, verb, and ending components.
|#


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


(defvar *lf*)
(setq *lf* .0025) 

(defvar *rt*)
(setq *rt*   -3.25) 

(defparameter *NOUN-MET* 0.19) 
(defparameter *NOUN-LIT* 0.34)
(defparameter *VERB-MET* 0.23)
(defparameter *VERB-LIT* 0.44)

(defvar *data-met00*)
(setq *data-met00* '((1.24 1.23 1.17 1.16) ; noun+verb RTs
		     (.79 .77 .81 .78) ; ending RTs after lit/met
		     (2.03 2.00 1.98 1.95) ; sentence
		     (.75 .81 .83 .76))) ; ending RT after relatedness
		     

(defvar *WWW-interface*)
(setf  *WWW-interface* 
      '((:heading "Budiu & Anderson (in press)" 2)
        (:table)
        
        (:table)
        "Latency Scale : "        (:string :sy *lf*  .06)   (:new-row)
        "Retrieval Threshold: "   (:string :sy *rt*  -0.35)  (:new-row)
        "Similarity met noun -- referent in text: "   (:string :sy *NOUN-MET*  .19)     (:new-row)
	"Similarity lit noun -- referent in text: "   (:string :sy *NOUN-LIT*  .34)     (:new-row)
	"Similarity met verb -- referent in text: "   (:string :sy *VERB-MET*  .23)     (:new-row)										 
	"Similarity lit verb -- referent in text: "   (:string :sy *VERB-LIT*  .44)     (:new-row)
	
         (: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 both simulation and experiment data" :sy *overlay*  nil) 
        (:table-end)
        
        (:table-end)
         
        
         (:new-para)
         
        (:button "Show Experimental Results" "(display-met00 *data-met00* )")
           
        (:new-para)
        
        (:button "Run model" "(if (and (numberp *lf*) (numberp *rt*) 
                                       (numberp *noun-met*) (numberp *VERB-MET*)
                                        (numberp *VERB-MET*) (numberp *VERB-LIT*))
                                      (predictions-all 4 *v*  *rt* *lf* *NOUN-MET* *NOUN-LIT*
                                                    *VERB-MET* *VERB-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 1 minute to run the model"
        (:new-line)
        "- The trace of 1 run is approximately 60 Kbytes (about 30 pages) in size"
        (:new-para)))


(defun display-met00 (data)
  (format *standard-output* "~&Experimental data")
  (format *standard-output* "~&Noun+Verb RTs (sec.)~&~7TMetV~15TLitV")
  (format *standard-output* "~&MetN~T~6,3F~T~6,3F" (first (first data)) (second (first data)))
  (format *standard-output* "~&LItN~T~6,3F~T~6,3F" (third (first data)) (fourth (first data)))
  (format *standard-output* "~2%Ending RTs (sec.)~&~7TMetV~15TLitV~23TUnrel~31TRel")
  (format *standard-output* "~&MetN~T ~6,3F~T ~6,3F~2T ~6,3F~T ~6,3F"
	  (first (second data)) (second (second data))
	  (first (fourth data)) (second (fourth data)))
  (format *standard-output* "~&LitN~T ~6,3F~T ~6,3F~2T ~6,3F~T ~6,3F"
	  (third (second data)) (fourth (second data))
	  (third (fourth data)) (fourth (fourth data)))
  (format *standard-output* "~2%Sentence RTs (sec.)~&~7TMetV~15TLitV")
  (format *standard-output* "~&MetN~T ~6,3F~T ~6,3F" (first (third data)) (second (third data)))
  (format *standard-output* "~&LItN~T ~6,3F~T ~6,3F" (third (third data)) (fourth (third data))))
 




;;; parameters influencing the quantitative model predictions

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

(defvar *give-up*)
(defvar *find-interpr*)

(setq *give-up*  0.975)
					;an interpretation if current interpretation
					;does not match
(setq *find-interpr* 0.996)


(defvar *w-rt* nil)

(defvar *blc*)
(setq *blc* 0)

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

;;; various flags

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

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

(defvar *ga*)
(setq *ga* 1)

(defvar *integr* 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))


;;; productions specific to this experiment


;; redefine the end of sentence productions to allow hook and interpretation
;; integration


(p end-of-sentence-with-no-interpretation
   =goal>
    isa comprehend
    task "interpretation"
    word eof
    interpretation none
   !eval! (= *task* +COMPREHENSION+)
   =bug>
    isa bug
    word =wd
    context =goal
    interpretation =ref
    - interpretation none
==>
  !eval! (setq *answer* 1 *integr* 1)
  !output! ("No interpretation; hook ~s" =ref)
  !output! Bug =bug with word =wd
  !output! ("Answer ~s" *answer*)
  =ref>
   isa comprehend
   word nil
  =goal>
   task "integrate"
   interpretation =ref)


(p end-of-sentence-with-ref
   =goal>
    isa comprehend
    task "interpretation"
    word eof
    interpretation =ref
    - interpretation none
  !eval! (= *task* +COMPREHENSION+)
==>
  !eval! (setq *integr* 1) 
  !output! Interpretation =ref 
  !output! ("Answer ~s" *answer*)
  =ref>
   isa comprehend
   word nil
  =goal>
   task "integrate"
   interpretation =ref)


(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
   interpretation =ref)

(eval `(spp (find-interpretation :r ,*find-interpr*)
	    (end-of-sentence :r 0.5)
	    (give-up :r ,*give-up*) ))

;;;;

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


;;;; general functions

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


;;;;;

(setq *extras* nil)
(setq *base*  -16)
(setq *incr* 32)
(setq *pincr* 21)
(setq *self-ia* 48)
(setq *overlaps* nil)

;;; overlap parameters


(defparameter *poss-roles* '(agent verb mod-oblique place-oblique))

(defconstant +MET+ 0)
(defconstant +LIT+ 1)


(defstruct 
    (story
     (:type list))
				 
  (props nil :type list)
  (roles nil :type list)
  (meanings nil :type list)	       
  (noun nil :type list)
  (verb nil :type list)
  (ending nil :type list)
  (probes nil :type list)
  (overlaps nil :type list)
  )

(defun story-probe (story truth)
  (nth (if truth 0 1) (story-probes story)))
  
(defparameter *story-1*
  (make-story :props (list '(linebacker pay-no-attention class)
			   '(linebacker train school)
			   '(linebacker be-tired class))
	      :meanings '((the det) (athlete noun) (bear noun) (sleep verb) (hibernate verb)
			  (quietly adv mod-oblique) (in prep place-oblique) (class noun)
			  (school noun) (linebacker noun) (man noun) (train noun) (pay-no-attention verb)
			  (be-tired verb) (doze verb) (daydream verb) (room noun))
	      :roles '(agent verb place-oblique)
	      :noun '((the bear) (the athlete))
	      :verb '((hibernate) (sleep)) 
	      :ending '((quietly) (in class)) 
              :probes '((the man doze in room) (the man daydream in room))
	      :overlaps (list  `(*bear* *linebacker* ,*NOUN-MET*)
			       `(*athlete* *linebacker* ,*NOUN-LIT*)
			       `(*be-tired* *sleep* ,*VERB-LIT*)
			       `(*be-tired* *hibernate* ,*VERB-MET*)
			       )))
			       


(defparameter *story-2*
  (make-story :props (list '(Cinderella dress elegance)
			   '(Cinderella bow gracefully)
			   '(Cinderella dance gracefully))
	      :meanings '((Cinderella noun) (dress verb) (elegance noun)
			  (bow verb) (gracefully adv mod-oblique) (dance verb) (talk verb)
			  (beautifully adv mod-oblique) (girl noun) (swan noun) (move verb)
			  (princess noun)
			  (float verb) (waltz verb) (dignity noun) (with prep mod-oblique)
			  (the det))
	      :roles '(agent verb mod-oblique)
	      :noun '((the swan) (the girl))
	      :verb '((float) (waltz))
	      :ending '((with dignity) (gracefully))
	      :probes '((the princess move beautifully) (the princess talk beautifully))
	      :overlaps (list  `(*swan* *Cinderella* ,*NOUN-MET*)
			       `(*girl* *Cinderella* ,*NOUN-LIT*)
			       `(*dance* *waltz* ,*VERB-LIT*)
			       `(*dance* *float* ,*VERB-MET*))))
	
	      

(defun met00-back-knowledge (&optional (story *story-1*) (debug t))
  (mapcar #'(lambda(x)
	      (apply #'encode-meaning x))
	  (story-meanings story))
  
  (apply #'add-meaning-overlaps (story-overlaps story))
    
  (let* ((props
	  (encode-propositions (story-props story)
			       (story-roles story)
			        debug)))
    (mapcar #'associate-prop props)
    (associate-all-props)
    (associate-all-meanings-to-links)
    (associate-all-meanings)
    (mapc #'associate-role-to-plinks *poss-roles*)
    (associate-lexemes-to-wlinks)
    (add-ia (none none 0)); (experiment experiment 27))
    (eval `(sgp :ga ,*ga* :blc ,*blc* :rt ,*rt* :lf ,*lf* :ans ,*ans*))
    (first (last  props))
    
    ))

(defun predictions (n  &optional (story *story-1*) (n-type +MET+) (v-type +MET+) (rel-type 0)
		       (probe t) (debug nil))
  (let ((integr 0)(rt 0) (nrt 0) (vrt 0) (ert 0) (safe-overlaps) (acc 0) 
	(time) (goal) (target) (target-ints 0) (verif-goal))

    (setq *overlaps* nil)
    (setq target (append
		  (nth n-type (story-noun story))
		  (nth v-type (story-verb story))
		  (nth rel-type (story-ending story))))
    (reset)
    (unless debug
      (sgp :v nil)
      (setq *command-trace* nil)
      (setq *load-verbose* nil))
    (met00-back-knowledge story debug)
    (setq safe-overlaps *overlaps*)
    
    (dotimes (trials n)
      (setq *sent* target)
      
      (setq *integr* 0)
      (setq *overlaps* safe-overlaps)
      (setq goal (one-trial))
      (when debug (format *standard-output* "~&~s ~s" *sent* goal))
      (setq time (actr-time))     
      (run)
      (setq time (- (actr-time) time))
      (incf rt time)
      (incf nrt (+ (aref *w-rt* 0) (aref *w-rt* 1)))
      (incf vrt (aref *w-rt* 2))
      (incf ert (- time (aref *w-rt* 0) (aref *w-rt* 1) (aref *w-rt* 2)))
       
      (incf integr *integr*)
      (delete-local))
     
    (unless debug
      (sgp :v t)
      (setq *command-trace* *standard-output*)
      (setq *load-verbose* *standard-output*))
    
    (values (/ rt n) (/ nrt n) (/ vrt n) (/ ert n) (/ integr n) (/ acc n) (/ target-ints n))))

(defvar *rts* )
(defvar *nrts* )
(defvar *vrts*) 
(defvar *erts*) 

(defun predictions-all (n &optional (debug nil) (rt *rt*) (lf *lf*)
			  (noun-met *NOUN-MET*) (noun-lit *NOUN-LIT*)
			  (verb-met *VERB-MET*) (verb-lit *VERB-LIT*))
  (setq *rt* rt *lf* lf
	*NOUN-MET* noun-met *NOUN-LIT* noun-lit *VERB-MET* verb-met *VERB-LIT* verb-lit)
  (setq *rts* (make-array '(2 2 2) :initial-element 0)
	*nrts* (make-array '(2 2 2) :initial-element 0)
	*vrts* (make-array '(2 2 2) :initial-element 0)
	*erts* (make-array '(2 2 2) :initial-element 0))

	
  
    (assert (and (evenp n) (evenp (/ n 2))))
    (dotimes (ntype 2)
      (dotimes (vtype 2)
	(dotimes (itype 2)
	  (dotimes (story 2)
	      (when debug
		(format *standard-output* "~& Condition: ~[Met~;Lit~] Noun, ~[Met~;Lit~] Verb, ~[Unrelated~;Related~] Ending" ntype vtype itype))
	      (multiple-value-bind  (rt nrt vrt ert int acc target-ints)
		  (predictions (/ n 4) (if (zerop story) *story-1* *story-2*)
			       ntype vtype itype nil debug)
	      (incf (aref *rts* ntype vtype itype) rt)
	      (incf (aref *nrts* ntype vtype itype) nrt)
	      (incf (aref *vrts* ntype vtype itype) vrt)
	      (incf (aref *erts* ntype vtype itype) ert)

	    ))

	    (setf (aref *rts* ntype vtype itype)
		  (/ (aref *rts* ntype vtype itype) 2))
	    (setf (aref *nrts* ntype vtype itype)
		  (/ (aref *nrts* ntype vtype itype) 2))
	    (setf (aref *vrts* ntype vtype itype)
		  (/ (aref *vrts* ntype vtype itype) 2))
	    (setf (aref *erts* ntype vtype itype)
		  (/ (aref *erts* ntype vtype itype) 2))
	    )))


      (format *standard-output* "~%Results of the ACT-R simulation")
      (dolist (var '(*nrts+vrts* *erts* *rts*))
	(cond ((equal var '*erts*)
	       (format *standard-output* "~2% Ending RTs (sec.)")
	       (format *standard-output* "~&~7tMetV~15tLitV~23tUnrel ~31tRel~&"))
	      
	      ((equal var '*nrts+vrts*)
	       (format *standard-output* "~2% Noun+Verb RTs (sec.)")
	       (format *standard-output* "~&~7tMetV~15tLitV~&"))
	      (t
	       (format *standard-output* "~2% Sentence RTs (sec.)")
	       (format *standard-output* "~&~7tMetV~15tLitV~&")
	       ))
	(dotimes (ntype 2)
	  (format *standard-output* "~&~[MetN~;LitN~]" ntype)
	  (cond ((equal var '*erts*)
		 (dotimes (vtype 2)
		   (format *standard-output* "~t ~6,3F"
			   (/ (+ (aref *erts* ntype vtype 0)
				 (aref *erts* ntype vtype 1))
			      2)))
		 (dotimes (itype 2)
		   (format *standard-output* "~t ~6,3F"
			   (/ (+ (aref *erts* ntype 0 itype)
				 (aref *erts* ntype 1 itype))
			      2)))
		 )
		((equal var '*nrts+vrts*)
		 (dotimes (vtype 2)
		   (format *standard-output* "~t ~6,3F"
			   (+ (/ (+ (aref *nrts* ntype vtype 0)
				    (aref *nrts* ntype vtype 1))
				 2)
			      (/ (+ (aref *vrts* ntype vtype 0)
				    (aref *vrts* ntype vtype 1))
				 2)))))
		(t
		 (let ((arr))
		   (setq arr (eval var))
		   (dotimes (vtype 2)
		     (cond ((equal var '*rts*) 
			    (format *standard-output* "~t ~6,3F"
				    (/ (+ (aref arr ntype vtype 0)
					  (aref arr ntype vtype 1))
				       2)))
			   (t
			     (dotimes (itype 2)
			       (format *standard-output* "~t ~6,3F"
				       (aref arr  ntype vtype itype)))))))
)))))