(in-package "CL-USER")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;;         Name:  Sentence Comprehension model (SCM)
;;;;      Version:  1.1.11
;;;;         Date:  10.4.2004
;;;; 
;;;;       Author:  Sashank Varma
;;;;        Email:  sashank.varma@vanderbilt.edu
;;;; Organization:  Center for Cognitive Brain Imaging
;;;;                Carnegie Mellon University
;;;;
;;;; TO DO (v2.0.10.*):
;;;;
;;;; EXECUTIVE SUMMARY: Need to revise the clause, relative clause, and
;;;;                    reduced relative clause productions.
;;;;
;;;; Centers:
;;;; Redesign ASSOCIATE and STRUCTURE so that the former really produces
;;;;   unlabeled associations and the latter articulates and structures them.
;;;;
;;;; Phrases:
;;;; Do we really want determiner phrases?  Maybe not, although they may be
;;;;   necessary for handling the focus operator "only" and negations (e.g.,
;;;;   Sedivy, 2002).  They may also be necessary for handling adverb
;;;;   modification (e.g., Cooke et al., 2001).
;;;; The model already handles adverbs in the sense of bundling them into
;;;;   adverb phrases.  Is this sufficient for handling adjectival modification
;;;;   of adjectives (e.g., Cooke et al., 2001), of verbs (e.g., Michael et
;;;;   al., 2001), and predicate adjectives (e.g., Grossman et al., 2002b)?
;;;; The model appears capable of handling adverbial modification of verbs,
;;;;   but the generality of this is unclear.  Examine further.
;;;; Check how the model handles a chain of PPs modifying an NP.
;;;; The choice between multiple expansions of the NP and VP categories is
;;;;   hand-coded to not be greedy.  See if there is a general principle here.
;;;;
;;;; Clauses:
;;;; Write productions that recognize conjoined NPs and conjoined clauses in
;;;;   addition to conjoined VPs.
;;;; The model already appears to handle predicate adjectives.  Check that it
;;;;   works in this regard and extend it to handle predicate nominatives.
;;;; Check that the handling of auxiliary verbs generally handles tense
;;;;   separately from verb content, and implement the ability handle
;;;;   infinitive forms and infinitival complements.
;;;; The model handles the copula; check that it does so correctly.
;;;; The model handles predicate nominatives and predicate prepositions; check
;;;;   that it does so correctly.
;;;; See if the model can handle implicitly center-embedded object-relatives of
;;;;   the forms "The senator the reporter...".
;;;;
;;;; Thematic Processing:
;;;; Decide whether it is okay that theta-role designs are never suppressed
;;;;   or whether such productions should be written.
;;;; Sift out the thematic productions in the "Clause designs" section.
;;;; Check that thematic role expectations are generated in a way that meets
;;;;   what is known about arguments (complements) versus non-arguments
;;;;   (adjuncts).
;;;; Check that the model does thematic processing in a general and constraint-
;;;;   based way.  One important case is when selecting outstanding thematic
;;;;   role expectations that can be matched in multiple ways.  Another case
;;;;   is the integration of thematic representations at the end of a
;;;;   sentence.  One index of generality is that ease with which new
;;;;   constraints can be added.
;;;;
;;;; Ambiguity:
;;;; A number of productions handle the suppression of the incorrect
;;;;   interpretation at the point of disambiguation.  Check that they are
;;;;   correct, generalize to all the MV/RR sentences, and do so in a general
;;;;   and constraint-based way that supports the addition of new constraints.
;;;;
;;;; Modeling Data:
;;;; Generalize the handling of word position (i.e., START and END) to handle
;;;;   phonetically empty elements as may be needed to model the Friedmann et al.
;;;;   sentences.
;;;;
;;;; Simulation Environment:
;;;; Move the many alternate cap settings and the functions to fit specific
;;;;   data sets to other files.
;;;; Integrate the printing of DMEs ("trees") with the Common Lisp printer.
;;;; Make the SIM command respect the new 4CAPS facility for defining and
;;;;   and running models.
;;;; Develop a more general template for simulating event-related studies.
;;;;
;;;; Miscellaneous:
;;;; Don't need both FORM and ORTHO slots.
;;;; Sentence-ending thematic integration is currently "turned off" in a
;;;;   hacky way, by deleting the percept of the punctuation mark.  Need to
;;;;   add a HALT action to 4CAPS. 
;;;; The grammar deviates from X-bar in the way it handles internal phrases,
;;;;   i.e., with bar number 1.  In X-bar, these are used to absorb the
;;;;   recursion of attributes and adjuncts.  The SCM dispenses with these,
;;;;   e.g. placing the recursion within a single attribute.  Take for example
;;;;   the case of two adjectives modifying a noun.  For "bright red ballon",
;;;;   the SCM's deviation works well, for the first asjective is really
;;;;   modifying the second adjective, which is modifying the noun.  For "large
;;;;   red balloon", the SCM gives an incorrect parse; both adjective are
;;;;   directly modifying the noun.  More generally, the interpretation of
;;;;   multiple attributes (or adjuncts) is ambiguous and must be resolved
;;;;   semantically, if at all.  This is beyond the scope of the current model,
;;;;   so the errors the model makes are within its theoretical tolerance, so
;;;;   to speak.  Personally, I find the X-bar account of attributes and adjuncts
;;;;   unsatisfying.  The obvious correction is to continue to shun 1-bar
;;;;   phrases and to allow the value of a phrase's attribute to be a *list* of
;;;;   other phrases.  Future work will be necessary to verify this.
;;;;
;;;; DONE (v2.0):
;;;;
;;;; Eliminate the centers that are no longer part of the model.
;;;;   Eliminate the lexical features that are no longer part of the model.
;;;; Change INTERPRET to ASSOCIATE and CONSTRUCT to STRUCTURE.
;;;; Simplify the definition of words in the lexicon.  Strip the by-word
;;;;   specializing and the definition of productions in now-defunct lexical
;;;;   centers.
;;;;   Get rid of the relative specialization scheme and replace the generic
;;;;   names *SPEC1* with *HIGH-SPEC*, *SPEC2* with *MED-SPEC*, and *SPEC3*
;;;;   with *LOW-SPEC*.
;;;; Make all DM classes inherit from SCM-DME so that the model will work
;;;;   in dual-task mode.
;;;;   Rename the few remaining occurrences of the DM class THEMATIC-ROLE-
;;;;   EXPECTATION to THETA-ROLE-EXPECTATION to be consistent.
;;;;   Removed the FORM attribute from all phrases, where it is unused.  It
;;;;   is now found only in the LEXICAL-FEATURE class.
;;;;   Eliminated the HARD-START and HARD-END attributes of PHRASE, letting
;;;;   these computations be done solely through recursion.
;;;;   Replaced the "needs" and "takes" nomenclature for theta role
;;;;   expectations with "receives" and "assigns".
;;;; Re-organized the code by linguistic function (i.e., lexical,
;;;;   syntactic:phrase, syntactic:clause, expectation, theta-role, and
;;;;   quantifier) rather than by center.
;;;;   Changed the names of predicates used on production LHSs to end in
;;;;   "?" instead of "-p", making the code more readable to non-lispers.
;;;; Converted the production that designs DPs.
;;;;   Converted the productions that design APs.
;;;;   Converted the productions that design AdvPs.
;;;;   Added the syntactic rule: AP --> AdvP A.
;;;;   Converted the productions that design NPs.
;;;;   Added a flag *SCM-TRACE-PHRASES-P* that controls whether productions
;;;;   print short trace messages when they fire.
;;;;   Added the syntactic rule: AdvP --> AdvP Adv.
;;;;   Converted the production that designs PPs.
;;;;   Converted the productions that design VPs.
;;;;   Remove almost all direct tests of the CAT and BAR attributes in
;;;;   production LHSs.  These are now hidden in a new set of predicates:
;;;;   NOUN?, NP?, etc.
;;;; Rewrote the productions that suppress the various kinds of phrases
;;;;   so that they're more recursive, and thus elegant.  The previous
;;;;   versions had huge, clumsy RHSs that attempted (poorly) to suppress
;;;;   all the subordinate phrases of a phrase being suppressed.
;;;; Divided the non-lexical, non-syntactic productions into "conventional"
;;;;   and "uncoventional" sections.
;;;;   Systematized naming of all conventional expectation productions and
;;;;   theta role productions.
;;;;   Replaced explicit tests of of word position with a new CURRENT-WORD?
;;;;   predicate on production LHSs.
;;;; Changed the attribute names of expectations and of theta roles to
;;;;   to more accurately and consistently reflect their values.  This
;;;;   necessitated adding a kludge to the already kludgy production
;;;;   ACTIVATE-RECEIVES-EXPECTATION-AT-VP.
;;;; Defined a number of predicates on expectations, theta roles, and
;;;;   clauses to make more concise the LHS tests of productions dealing
;;;;   with expectation and theta role designs and constituents.
;;;;   Removed a number of the absence tests on productions handling lexical
;;;;   features designs, phrases and their designs, theta role expectations
;;;;   and their designs, and theta role designs.  This was possible because
;;;;   I previously systematized when these elements are suppressed -- on
;;;;   the word following their activation, at the earliest.
;;;;   Removed all hard-coded 0.9 thresholds on LHS absence tests.  These
;;;;   might be reinstated later to get the model to run properly when
;;;;   resources are scarce.
;;;; With productions in the "conventional" sections.  Now time to tackle
;;;;   those in the "clause" and "unconventional" sections.
;;;; Clause numbering changed to be purely sequential in the order in
;;;;   which clauses are encountered an integral in value.
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; initialization.
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;
;;; 4caps.
;;;


;;

(set-default-dme-thresh 0.1)


;;

(set-tracing-p nil)
(set-tracing-dm-p nil)



;;;
;;; sentence model.
;;;


;; Control the verbosity with which individual productions are traced.

(defparameter *scm-trace-phrases-p* nil)
;(defparameter *scm-trace-phrases-p* t)

(defparameter *scm-trace-clauses-p* nil)
;(defparameter *scm-trace-clauses-p* t)

(defparameter *scm-trace-expectations-p* nil)
;(defparameter *scm-trace-expectations-p* t)

(defparameter *scm-trace-theta-roles-p* nil)
;(defparameter *scm-trace-theta-roles-p* t)


;; control the target activation level of new dmes and the rate at which
;; this is achieved, i.e., the iterativeness of the model.

(defparameter *weight* 1.0)
(defparameter *spew-rate* 1.0)


;; control the lateral inhibition process that consolidates the various
;; thematic roles present at the end of sentence comprehension into a set
;; that satisfies the theta role criterion, i.e., each noun phrase is
;; assigned a thematic role and each verb assigns all of the thematic roles
;; in its argument frame.

(defparameter *integration-weight* 0.1)


;; control the lateral inhibition process that governs which of the available
;; thematic role expectations is selected when there is ambiguity, i.e., when
;; the verb of an object-relative clause is processed.

(defparameter *selection-winner* 1.0)
(defparameter *selection-loser* 0.95)
(defparameter *selection-threshold* 0.5)


;; offsets that determine the relative specilizations of different centers
;; specialized to different degrees for the same function.

(defparameter *high-spec* 1)
(defparameter *med-spec* 2)
(defparameter *low-spec* 3)


;; the terminal punctuation mark known to the model, which triggers end of
;; sentence processing such as suppression of superfluous representations.

(defparameter *punctuation* '(period))


;; thematic role.

(defparameter *thematic-roles* '(agent patient recipient theme time place))




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; dm classes.
;;;;
;;;; the dm class hierarchy is schematically represented below. "A: B" means
;;;; that class A is a superclass of class B.  "A: B (+C)" means that class A
;;;; is a superclass of class B, and is mixed with class C to produce class B.
;;;; in this case, class C is called a "mixin" class, and it is common to
;;;; suffix mixin class names with "-mi".
;;;;
;;;; scm-dme:  mixin:        delimited-mi
;;;;
;;;;                         lexical-mi:          lexical-features-mi
;;;;
;;;;                         syntax-mi:           phrase-mi                      (+ lexical-features-mi
;;;;                                                                                delimited-mi)
;;;;                                              clause-mi
;;;;
;;;;                         thematic-mi:         theta-role-mi
;;;;
;;;;                         expectation-mi:      theta-role-expectation-mi      (+ theta-role-mi)
;;;;
;;;;           control:      current-position
;;;;
;;;;                         percept                                             (+ delimited-mi)
;;;;
;;;;           design:       lexical-design:      lexical-features-design        (+ lexical-features-mi)
;;;;
;;;;                         syntax-design:       phrase-design                  (+ phrase-mi)
;;;;                                              clause-design                  (+ clause-mi)
;;;;
;;;;                         thematic-design:     theta-role-design              (+ theta-role-mi)
;;;;
;;;;                         expectation-design:  theta-role-expectation-design  (+ theta-role-expectation-mi)
;;;;
;;;;           constituent:  lexical:             lexical-features               (+ lexical-features-mi)
;;;;
;;;;                         syntax:              phrase                         (+ phrase-mi)
;;;;                                              clause                         (+ clause-mi)
;;;;
;;;;                         thematic:            theta-role                     (+ theta-role-mi)
;;;;
;;;;                         expectation:         theta-role-expectation         (+ theta-role-expectation-mi)
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;
;;; SCM-DME class.
;;;


;; The base SCM-DME class.
;;
;; All sentence comprehension model DM classes inherit from this class,
;; providing a convenient ancestry when running in dual-task mode.

(defdmclass scm-dme ())




;;;
;;; Mixin classes.
;;;


;; The base MIXIN class.

(defdmclass mixin (scm-dme))


;; This mixin class specifies the protocol by which representations map to
;; physical properties of the sentential stimulus being processed,
;; specifically the boundaries of words and phrases.

(defdmclass delimited-mi (mixin))

(defmethod before? ((x delimited-mi) (y delimited-mi))
  (< (end x) (end y)))

(defmethod adjacent? ((x delimited-mi) (y delimited-mi))
  (= (end x) (start y)))


;; These mixin classes specify the content of lexical representations.

(defdmclass lexical-mi (mixin))

(defdmclass lexical-features-mi (lexical-mi)
  percept
  form
  cat
  tense
  frame
  aux
  tool
  pro)


;; These mixin classes specifiy the content of syntactic representations.

(defdmclass syntax-mi (mixin))


; Phrases.

(defdmclass phrase-mi (syntax-mi lexical-features-mi delimited-mi)
  head
  bar
  spec
  att
  comp)

(defmethod start ((self phrase-mi))
  (cond ((spec self)
         (start (spec self)))
        ((att self)
         (start (att self)))
        (t
         (start (head self)))))

(defmethod end ((self phrase-mi))
  (if (comp self)
    (end (comp self))
    (end (head self))))

(defmethod noun? ((self phrase-mi))
  (and (equal (cat self) 'n)
       (equal (bar self) 0)))

(defmethod np? ((self phrase-mi))
  (and (equal (cat self) 'n)
       (equal (bar self) 2)))

(defmethod verb? ((self phrase-mi))
  (and (equal (cat self) 'v)
       (equal (bar self) 0)))

(defmethod vp? ((self phrase-mi))
  (and (equal (cat self) 'v)
       (equal (bar self) 2)))

(defmethod preposition? ((self phrase-mi))
  (and (equal (cat self) 'p)
       (equal (bar self) 0)))

(defmethod pp? ((self phrase-mi))
  (and (equal (cat self) 'p)
       (equal (bar self) 2)))

(defmethod adjective? ((self phrase-mi))
  (and (equal (cat self) 'a)
       (equal (bar self) 0)))

(defmethod ap? ((self phrase-mi))
  (and (equal (cat self) 'a)
       (equal (bar self) 2)))

(defmethod adverb? ((self phrase-mi))
  (and (equal (cat self) 'adv)
       (equal (bar self) 0)))

(defmethod advp? ((self phrase-mi))
  (and (equal (cat self) 'adv)
       (equal (bar self) 2)))

(defmethod determiner? ((self phrase-mi))
  (and (equal (cat self) 'd)
       (equal (bar self) 0)))

(defmethod dp? ((self phrase-mi))
  (and (equal (cat self) 'd)
       (equal (bar self) 2)))

(defmethod complementizer? ((self phrase-mi))
  (and (equal (cat self) 'c)
       (equal (bar self) 0)))

(defmethod conjunction? ((self phrase-mi))
  (and (equal (cat self) 'j)
       (equal (bar self) 0)))


; Clauses.

(defdmclass clause-mi (syntax-mi)
  number
  for*
  parent
  by
  tense
  voice)

(defmethod active? ((self clause-mi))
  (eq (voice self) 'active))

(defmethod passive? ((self clause-mi))
  (eq (voice self) 'passive))

(defmethod copula? ((self clause-mi))
  (eq (voice self) 'copula))


;; These mixin classes specify the content of thematic representations.

(defdmclass thematic-mi (mixin))

(defdmclass theta-role-mi (thematic-mi)
  role
  receiver
  assigner
  number)

(defmethod agent? ((self theta-role-mi))
  (eq (role self) 'agent))

(defmethod patient? ((self theta-role-mi))
  (eq (role self) 'patient))

(defmethod recipient? ((self theta-role-mi))
  (eq (role self) 'recipient))

(defmethod theme? ((self theta-role-mi))
  (eq (role self) 'theme))

(defmethod time? ((self theta-role-mi))
  (eq (role self) 'time))

(defmethod place? ((self theta-role-mi))
  (eq (role self) 'place))


;; These mixin classes specify the content of expectation representations.

(defdmclass expectation-mi (mixin))

(defdmclass theta-role-expectation-mi (expectation-mi theta-role-mi))

(defmethod thematic-role? ((self theta-role-expectation-mi))
  (member (role self) *thematic-roles*))

(defmethod needs-role? ((self theta-role-expectation-mi))
  (eq (role self) 'needs-role))



;;;
;;; Control classes.
;;;


;; The base CONTROL class.

(defdmclass control (scm-dme))


;; The physical position being perceptually fixed, i.e., the position of the
;; word being processed.

(defdmclass current-position (control)
  pos)

(defmethod current-word? ((d delimited-mi) (cp current-position))
  (equal (end d) (pos cp)))


;; The orthographic content of a word that has been perceptuall fixed.  note
;; that the delimited-mi protocol is directly implemented by attributes.

(defdmclass percept (control delimited-mi)
  ortho
  start
  end)

(defmethod punctuation? ((self percept))
  (member (ortho self) *punctuation*))



;;;
;;; Constituent classes.
;;;


;; The base CONSTIUTENT class.

(defdmclass constituent (scm-dme))


;; Lexical constituent classes.

(defdmclass lexical (constituent))

(defdmclass lexical-features (lexical lexical-features-mi))


;; Syntactic constituent classes.

(defdmclass syntax (constituent))


; Phrases.  Following X-bar grammar, words are 0-bar phrases and conventional
; phrases have bar values of 2.  Note that the DELIMITED-MI protocol is
; implemented indirectly, by passing queries down to constituent phrases and
; eventually percepts, which encode positions explicitly.  Further note that
; the slew of methods that provide a LHS-friendly path to features stored at
; phrasal heads. 

(defdmclass phrase (syntax phrase-mi))

(defmethod ortho ((self phrase))
  (ortho (head self)))

(defmethod subordinate? ((xp1 phrase) (xp2 phrase) &key strict)
  (or (and (not strict)
           (eq xp1 xp2))
      (and (spec xp2)
           (or (eq xp1 (spec xp2))
               (subordinate? xp1 (spec xp2))))
      (and (att xp2)
           (or (eq xp1 (att xp2))
               (subordinate? xp1 (att xp2))))
      (and (head xp2)
           (or (eq xp1 (head xp2))
               (and (subtypep (type-of (head xp2)) 'phrase)
                    (subordinate? xp1 (head xp2)))))
      (and (comp xp2)
           (or (eq xp1 (comp xp2))
               (subordinate? xp1 (comp xp2))))))

(defmethod get-feature-value ((self phrase) feature)
  (or (slot-value self feature)
      (get-feature-value (head self) feature)))

(defmethod pro? ((self phrase))
  (eq (get-feature-value self 'pro) '+))

(defmethod receives-role? ((self phrase))
  (not (eq (get-feature-value self 'pro) '+)))

(defmethod present? ((self phrase))
  (eq (get-feature-value self 'tense) 'present))

(defmethod past? ((self phrase))
  (eq (get-feature-value self 'tense) 'past))

(defmethod past-participle? ((self phrase))
  (eq (get-feature-value self 'tense) 'past-participle))

(defmethod aux? ((self phrase))
  (eq (get-feature-value self 'aux) '+))

(defmethod assigns-agent? ((self phrase))
  (let ((frame (get-feature-value self 'frame)))
    (and (listp frame) (member 'agent frame))))

(defmethod assigns-patient? ((self phrase))
  (let ((frame (get-feature-value self 'frame)))
    (and (listp frame) (member 'patient frame))))

(defmethod assigns-recipient? ((self phrase))
  (let ((frame (get-feature-value self 'frame)))
    (and (listp frame) (member 'recipient frame))))

(defmethod assigns-theme? ((self phrase))
  (let ((frame (get-feature-value self 'frame)))
    (and (listp frame) (member 'theme frame))))

(defmethod assigns-time? ((self phrase))
  (let ((frame (get-feature-value self 'frame)))
    (and (listp frame) (member 'time frame))))

(defmethod assigns-place? ((self phrase))
  (let ((frame (get-feature-value self 'frame)))
    (and (listp frame) (member 'place frame))))


; Clauses.  

(defdmclass clause (syntax clause-mi))

(defmethod more-current-or-specific? ((cl1 clause) (cl2 clause))
  (and (not (eq cl1 cl2))
       (>= (number cl1) (number cl2))
       (null (parent cl2))
       (null (by cl2))
       (null (tense cl2))
       (null (voice cl2))))

(defmethod not-copula? ((self clause))
  (not (eq (voice self) 'copula)))

(defmethod no-voice? ((self clause))
  (null (voice self)))

(defmethod main-verb? ((xp phrase) (cl clause))
  (equal xp (by cl)))

(defmethod next-clause ((self clause))
  (1+ (number self)))


;; Thematic constituent classes.

(defdmclass thematic (constituent))

(defdmclass theta-role (thematic theta-role-mi))


;; Expectation constituent classes.

(defdmclass expectation (constituent))

(defdmclass theta-role-expectation (expectation theta-role-expectation-mi))




;;;
;;; Design classes.
;;;


;; The base DESIGN class.

(defdmclass design (scm-dme))


;; Lexical design classes.

(defdmclass lexical-design (design))

(defdmclass lexical-features-design (lexical-design lexical-features-mi))


;; Syntactic design classes.

(defdmclass syntax-design (design))

(defdmclass phrase-design (syntax-design phrase-mi))

(defdmclass clause-design (syntax-design clause-mi))



;; Thematic design classes.

(defdmclass thematic-design (design))

(defdmclass theta-role-design (thematic-design theta-role-mi))


;; Expectation design classes.

(defdmclass expectation-design (design))

(defdmclass theta-role-expectation-design (expectation-design theta-role-expectation-mi))




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Centers.
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;
;;; Centers.
;;;


;; Delete existing centers.

(del-centers)


;; Define model centers.


; Define a center to perform (e.g., perceptual) processing and hold control
; representations outside the scientific scope of the model.

(add-center support)


; Define the primary language centers corresponding Wernicke's area, Broca's
; area, and their right-hemisphere homologs.

(add-center associate)
(add-center rh-associate)

(add-center structure)
(add-center rh-structure)


;; Define the default resource capacities of the centers.

(set-caps@ support nil)

(set-caps@ (associate rh-associate structure rh-structure) 100.0)


;; Define the relative functional specializations of the centers.  This list
;; may  seem, but it is not.  Because DM classes inherit the specializations
;; of their ancestor classes, the only time the specialization of a center
;; for a class must be explicitly defined is when it overrides the
;; specialization of the class' parent class.

(set-specs@ support base-dme nil
                    control 1)

(set-specs@ (associate rh-associate) base-dme nil
                                     control t
                                     constituent t)

(set-specs@ (structure rh-structure) base-dme nil
                                     control t
                                     design t)

;;; Setting the specialization of Associate from 1.0 to 1.01 for
;;; clause-designs, expectation-designs, or both causes the model to
;;; lose these first when multicenter constraints kick in, degrading
;;; parsing into a surface (lexical and syntactic) affair.
(cond ((and (boundp '*dual-task*) *dual-task*)
       (set-specs@ associate    design 1
                                clause-design 1
                                expectation-design 1.01)  ; 1.01
       (set-specs@ rh-associate design t
                                clause-design t
                                expectation-design t)
       (set-specs@ structure    constituent 1
                                clause 1
                                expectation 1)
       (set-specs@ rh-structure constituent t
                                clause t
                                expectation t))
      (t
       (set-specs@ associate    design *high-spec*
                                clause-design *med-spec*
                                expectation-design *med-spec*)
       (set-specs@ rh-associate design *med-spec*
                                clause-design *low-spec*
                                expectation-design *low-spec*)
       (set-specs@ structure    constituent *high-spec*
                                clause *med-spec*
                                expectation *med-spec*)
       (set-specs@ rh-structure constituent *med-spec*
                                clause *low-spec*
                                expectation *low-spec*)))




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; The Lexicon.
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;
;;; Design lexical features.
;;;


;; top-level commands to define lexical entrries.  defines new lexical-design
;; dm classes specific to the word, sets center specializations for these
;; classes based on the word's frequency, and creates productions in the
;; associate and lexical centers to activate lexical-designs when the word
;; is perceived.  (like all designs, these are turned into constituent
;; representations by the structure center.)

;;; top-level command to define an unambiguous word.
(defmacro def-lexeme (ortho freq cat . features)
  `(def-lexeme-2 ,ortho ,freq ,cat ,features))

;;; top-level command to define an ambiguous word, specifically verbs with the
;;; same orthorgraphic form that map to different lexical entries for each
;;; sense, one for each tense.
(defmacro def-ambiguous-word (ortho . lexemes)
  `(progn
     ,@(mapcar #'(lambda (lexeme)
                   (destructuring-bind (freq cat . features) lexeme
                     `(def-lexeme-2 ,ortho
                        ,freq
                        ,cat
                        ,features
                        ,(intern (format nil "~A-~A" ortho (second (assoc 'tense features)))))))
               lexemes)))

;;; helper function that supports the top-level command.  given a word with
;;; a specific orthographic form, a log lexical frequency of occurrence
;;; scaled by a transformation described in a separate file, a grammatical
;;; category, a set of lexical features, and optionally, an internal "name".
;;; the name is specialized for each unique sense of the word; it is simply
;;; the orthographic form for unmabiguous words and the contatenation of the
;;; orthographic form and tense for ambiguous verbs.
;;;
;;; defines a set of dm classes for the word: subclasses of each of the four
;;; lexical design classes, subclasses of each of the four lexical constituent
;;; classes, sublcasses of the phrase design and phrase constituent classes,
;;; subclasses of the theta-role design and theta-role constituent classes,
;;; and subclasses of the theta-role-expectation design and theta-role-
;;; expectation constituent classes.  each relevant center is specialized
;;; for each new sublcass in ways that reflect the underlying word's log
;;; frequency of occurrence (i.e., the greater this number, the greater the
;;; center specializations, and thus the more efficiently the word is
;;; processed) and the center's inherent compentencies (i.e., the associate
;;; center is more specialized for representational design than its
;;; right-hemisphere homolog rh-associate).
;;;
;;; also defines productions in associate and the lexical centers that
;;; actually function like a lexicon.  upon seeing a percept that matches
;;; the orthographic form of the word they represent, these productions fire
;;; to design representations of the word's lexical content: it's grammatical
;;; class (e.g., noun), semantic category (e.g., person), etc.

#|
(defmacro def-lexeme-2 (ortho freq cat features &optional (name ortho))
  (declare (ignore freq))
  (let ((tense (or (second (assoc 'tense features)) '-))
        (frame (or (second (assoc 'frame features)) '-))
        (aux (or (second (assoc 'aux features)) '-))
        (pro (or (second (assoc 'pro features)) '-))
        (lex-p-name (intern (format nil "DESIGN-LEXICAL-FEATURES<~A>" name))))
    (copy-tree
      `(p@ (associate rh-associate) ,lex-p-name ((p percept)
                                                 (cp current-position))
           (equal (ortho p) ',ortho)
           (current-word? p cp)
           (*no ((~d lexical-features-design))
             (equal (percept ~d) p)
             (equal (form ~d) ',name)
             (equal (cat ~d) ',cat)
             (equal (tense ~d) ',tense)
             (equal (frame ~d) ',frame)
             (equal (aux ~d) ',aux)
             (equal (pro ~d) ',pro))
       -->
           (spew t (lexical-features-design :percept p
                                            :form ',name
                                            :cat ',cat
                                            :tense ',tense
                                            :frame ',frame
                                            :aux ',aux
                                            :pro ',pro)
                   (* *weight* *spew-rate*))
       )
      )))

|#

;; tools-addes

(defmacro def-lexeme-2 (ortho freq cat features &optional (name ortho))
  (declare (ignore freq))
  (let ((tense (or (second (assoc 'tense features)) '-))
        (frame (or (second (assoc 'frame features)) '-))
        (aux (or (second (assoc 'aux features)) '-))
        (pro (or (second (assoc 'pro features)) '-))
	(tool (or (second (assoc 'tool features)) '-))
        (lex-p-name (intern (format nil "DESIGN-LEXICAL-FEATURES<~A>" name))))
    (copy-tree
      `(p@ (associate rh-associate) ,lex-p-name ((p percept)
                                                 (cp current-position))
           (equal (ortho p) ',ortho)
           (current-word? p cp)
           (*no ((~d lexical-features-design))
             (equal (percept ~d) p)
             (equal (form ~d) ',name)
             (equal (cat ~d) ',cat)
	     (equal (tool ~d) ',tool)
             (equal (tense ~d) ',tense)
             (equal (frame ~d) ',frame)
             (equal (aux ~d) ',aux)
             (equal (pro ~d) ',pro))
       -->
           (spew t (lexical-features-design :percept p
                                            :form ',name
                                            :cat ',cat
                                            :tense ',tense
                                            :frame ',frame
                                            :aux ',aux
		                            :tool ',tool
                                            :pro ',pro)
                   (* *weight* *spew-rate*))
       )
      )))


;;;
;;; The lexicon.
;;;
;;; The frequency numbers were obtained by running the Kucera and Francis
;;; (1967) estimates through a logarithmic transformation detailed in a
;;; separate file.
;;;
;;; Grammatical classes: complementizer  (c)
;;;                      conjunction     (j)
;;;                      determiner      (d)
;;;                      preposition     (p)
;;;                      adjective       (a)
;;;                      adverb          (adv)
;;;                      noun            (n)
;;;                      verb            (v)
;;;
;;; Features:            pronoun         (pro)
;;;                      auxiliary verb  (aux)
;;;                      tense           (tense)
;;;                      frame           (frame)
;;;


;; Complementizers (i.e., relative pronouns).

(def-lexeme that 1 c)
(def-lexeme who 2 c)


;; Conjunctions.

(def-lexeme and 1 j)


;; Determiners.

(def-lexeme the 1 d)
(def-lexeme an 2 d)


;; Prepositions.

(def-lexeme to 1 p)
(def-lexeme by 2 p)
(def-lexeme about 2 p)
(def-lexeme before 2 p)
(def-lexeme at 2 p)


;; Adjectives.

(def-lexeme experienced 4 a)
(def-lexeme midnight 4 a)


;; Adverbs.
;;
;; Note: The frequency is bogus; this exists solely to test the grammar.

(def-lexeme very 4 adv)


;; Pronouns.

(def-lexeme it 2 n (pro +))


;; Nouns.

(def-lexeme senator 4 n)
(def-lexeme reporter 4 n)
(def-lexeme error 4 n)
(def-lexeme writer 3 n)
(def-lexeme king 3 n)
(def-lexeme mistake 4 n)
(def-lexeme pundit 5 n)
(def-lexeme regent 5 n)
(def-lexeme gaffe 5 n)
(def-lexeme editor 3 n)
(def-lexeme interview 4 n)
(def-lexeme meeting 3 n)
(def-lexeme conclave 5 n)
(def-lexeme soldiers 3 n)
(def-lexeme dangers 4 n)
(def-lexeme raid 4 n)
(def-lexeme floods 4 n)


;; Verbs.


; Auxiliary.

(def-lexeme was 2 v
  (aux +)
  (tense past))

(def-lexeme were 2 v
  (aux +)
  (tense past))


; Unambiguous.

(def-lexeme attacked 4 v
  (tense past)
  (frame (agent patient)))

(def-lexeme admitted 4 v
  (tense past)
  (frame (agent patient)))

(def-lexeme fingered 5 v
  (tense past)
  (frame (agent patient)))

(def-lexeme gave 3 v
  (tense present)
  (frame (agent patient recipient)))

(def-lexeme given 3 v
  (tense past)
  (frame (agent patient recipient)))

(def-lexeme spoke 3 v
  (tense present)
  (frame (agent theme time)))

(def-lexeme told 3 v
  (tense past)
  (frame (patient theme)))

(def-lexeme conducted 3 v
  (tense past)
  (frame (agent patient)))


; Ambiguous.

(def-ambiguous-word warned
  (4 v (tense past)
   (frame (agent theme time)))
  (5 v (tense past-participle)
   (frame (patient theme))))


;; New entries.

;;; Gordon et al. (2001)
(def-lexeme banker 1 n)
(def-lexeme barber 1 n)
(def-lexeme mountain 1 n)
(def-lexeme lawyer 1 n)
(def-lexeme lot 1 n)
(def-lexeme praised 1 v
  (tense past)
  (frame (agent patient)))
(def-lexeme climbed 1 v
  (tense past)
  (frame (agent patient)))
(def-lexeme saw 1 v
  (tense past)
  (frame (agent patient place)))
(def-lexeme in 1 p)
(def-lexeme parking 1 a)

;;; Traxler et al. (2001A)
;(def-lexeme lawyer 1 n)
;(def-lexeme banker 1 n)
(def-lexeme lawsuit 1 n)
(def-lexeme irritated 1 v
  (tense past)
  (frame (agent patient)))
(def-lexeme filed 1 v
  (tense past)
  (frame (agent patient)))
(def-lexeme hefty 1 a)

;;; Stromswold et al. (1996)
(def-lexeme limmerick 1 n)
(def-lexeme boy 1 n)
(def-lexeme priest 1 n)
(def-lexeme biographer 1 n)
(def-lexeme story 1 n)
(def-lexeme queen 1 n)
(def-lexeme recited 1 v
  (tense past)
  (frame (agent patient)))
(def-lexeme appalled 1 v
  (tense past)
  (frame (agent patient)))
(def-lexeme omitted 1 v
  (tense past)
  (frame (agent patient)))
(def-lexeme insulted 1 v
  (tense past)
  (frame (agent patient)))

;;; Caplan et al. (1998)
(def-lexeme juice 1 n)
(def-lexeme child 1 n)
(def-lexeme rug 1 n)
(def-lexeme spilled 1 v
  (tense past)
  (frame (agent patient)))
(def-lexeme stained 1 v
  (tense past)
  (frame (agent patient)))

;;; Caplan et al. (1999)
#|
(def-lexeme juice 1 n)
(def-lexeme child 1 n)
|#
(def-lexeme enjoyed 1 v
  (tense past)
  (frame (agent patient)))

;;; Caplan et al. (2000)
#|
(def-lexeme juice 1 n)
(def-lexeme child 1 n)
(def-lexeme rug 1 n)
(def-lexeme enjoyed 1 v
  (tense past)
  (frame (agent patient)))
(def-lexeme stained 1 v
  (tense past)
  (frame (agent patient)))
|#

;;; Grodner et al. (2002)
(def-lexeme witness 1 n)
(def-lexeme evidence 1 n)
;(def-lexeme lawyer 1 n)
;(def-lexeme very 1 adv)
(def-lexeme nervous 1 a)

(def-ambiguous-word examined
  (1 v (tense past)
   (frame (agent theme)))
  (1 v (tense past-participle)
   (frame (patient theme))))
(def-lexeme implicated 1 v
  (tense past)
  (frame (agent patient)))

#|
(def-lexeme was 2 v
  (aux +)
  (tense past))
|#

;;; Traxler et al. (2001B)
(def-lexeme director 1 n)
(def-lexeme movie 1 n)
(def-lexeme prize 1 n)
(def-lexeme festival 1 n)
(def-lexeme watched 1 v
  (tense past)
  (frame (agent patient)))
(def-lexeme pleased 1 v
  (tense past)
  (frame (agent patient)))
(def-lexeme received 2 v
  (tense past)
  (frame (agent patient place)))
(def-lexeme film 1 a)

;;; Caplan et al. (2001)

(def-lexeme carefully 1 adv)
(def-lexeme big 1 a)
(def-lexeme story 1 n)
(def-lexeme covering 1 v
  (tense past)
  (frame (agent patient)))




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Lexical Processing.
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;
;;; Lexical designs.
;;;


;; Activate lexical-features designs.
;;
;; These productions defined, one for each word-sense, by the DEF-LEXEME macro.


;; Suppress lexical-features designs.

(p@ (associate rh-associate) suppress-lexical-features-design ((d lexical-features-design)
                                                               (p percept)
                                                               (cp current-position))
    (before? (percept d) p)
    (current-word? p cp)
    (*no ((~lf lexical-features))
      (equal (percept ~lf) (percept d))
      (equal (form ~lf) (form d))
      (equal (cat ~lf) (cat d))
      (equal (tense ~lf) (tense d))
      (equal (frame ~lf) (frame d))
      (equal (aux ~lf) (aux d))
      (equal (pro ~lf) (pro d)))
-->
    (spew t d (- (* *weight* *spew-rate*)))
)



;;;
;;; Lexical constiutents.
;;;


;; Activate lexical-features constituents.

(p@ (structure rh-structure) activate-lexical-features ((d lexical-features-design)
                                                        (cp current-position))
    (current-word? (percept d) cp)
    (*no ((~lf lexical-features))
      (equal (percept ~lf) (percept d))
      (equal (form ~lf) (form d))
      (equal (cat ~lf) (cat d))
      (equal (tense ~lf) (tense d))
      (equal (frame ~lf) (frame d))
      (equal (aux ~lf) (aux d))
      (equal (pro ~lf) (pro d)))
-->
    (spew t (lexical-features :percept (percept d)
                              :form (form d)
                              :cat (cat d)
                              :tense (tense d)
                              :frame (frame d)
                              :aux (aux d)
                              :pro (pro d))
            (* *weight* *spew-rate*))
)


;; Suppress lexical-features consituents.

(p@ (structure rh-structure) suppress-lexical-features ((lf lexical-features)
                                                        (p percept)
                                                        (cp current-position))
    (before? (percept lf) p)
    (current-word? p cp)
-->
    (spew t lf (- (* *weight* *spew-rate*)))
)




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Syntactic Processing: Phrases
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;
;;; Phrase designs.
;;;


;; Activate designs for new 0-bar phrases (i.e., words) from existing
;; lexical-features.

(p@ (associate rh-associate) lexical-access ((lf lexical-features)
                                             (p percept)
                                             (cp current-position))
    (current-word? p cp)
    (equal p (percept lf))
    (cat lf)
    (*no ((~d phrase-design))
      (equal (cat ~d) (cat lf))
      (equal (tense ~d) (tense lf))
      (equal (frame ~d) (frame lf))
      (equal (aux ~d) (aux lf))
      (equal (pro ~d) (pro lf))
      (equal (bar ~d) 0)
      (equal (head ~d) p))
-->
    (spew t (phrase-design :cat (cat lf)
                           :tense (tense lf)
                           :frame (frame lf)
                           :aux (aux lf)
                           :pro (pro lf)
                           :bar 0
                           :head p)
            (* *weight* *spew-rate*))
)


;; Activate designs for new 2-bar phrases from existing phrases.


; DPs.
;
; (1) DP --> D

;;; (1) DP --> D
(p@ (associate rh-associate) design-dp ((det phrase)
                                        (cp current-position))
    (determiner? det)
    (current-word? det cp)
    (*no ((~d phrase-design))
      (dp? ~d)
      (equal (head ~d) det))
-->
    (spew t (phrase-design :cat 'd
                           :bar 2
                           :head det)
            (* *weight* *spew-rate*))
    (when *scm-trace-phrases-p*
      (format t "~&~A~AACTIVATE DESIGN DP --> D" *cycles* #\tab))
)

; APs.
;
; (1) AP --> AP A
; (2) AP --> AdvP A
; (3) AP --> A
;
; Note: These productions are hand-written to be "greedy", so that the
; model attempts to build a more complex AP (1) before settling for the
; less complex AP (2).

;;; (1) AP --> AP A
(p@ (associate rh-associate) design-ap1 ((ap phrase)
                                         (adj phrase)
                                         (cp current-position))
    (ap? ap)
    (adjacent? ap adj)
    (adjective? adj)
    (current-word? adj cp)
    (*no ((~d phrase-design))
      (ap? ~d)
      (equal (att ~d) ap)
      (equal (head ~d) adj))
-->
    (spew t (phrase-design :cat 'a
                           :bar 2
                           :att ap
                           :head adj)
            (* *weight* *spew-rate*))
    (when *scm-trace-phrases-p*
      (format t "~&~A~AACTIVATE DESIGN AP --> AP A" *cycles* #\tab))
)

;;; (2) AP --> AdvP A
(p@ (associate rh-associate) design-ap2 ((advp phrase)
                                         (adj phrase)
                                         (cp current-position))
    (advp? advp)
    (adjacent? advp adj)
    (adjective? adj)
    (current-word? adj cp)
    (*no ((~d phrase-design))
      (ap? ~d)
      (equal (att ~d) advp)
      (equal (head ~d) adj))
-->
    (spew t (phrase-design :cat 'a
                           :bar 2
                           :att advp
                           :head adj)
            (* *weight* *spew-rate*))
    (when *scm-trace-phrases-p*
      (format t "~&~A~AACTIVATE DESIGN AP --> AdvP A" *cycles* #\tab))
)

;;; (3) AP --> A
(p@ (associate rh-associate) design-ap3 ((adj phrase)
                                         (cp current-position))
    (adjective? adj)
    (current-word? adj cp)
    (*no ((~ap phrase))
      (ap? ~ap)
      (adjacent? ~ap adj))
    (*no ((~advp phrase))
      (advp? ~advp)
      (adjacent? ~advp adj))
    (*no ((~d phrase-design))
      (ap? ~d)
      (equal (head ~d) adj))
-->
    (spew t (phrase-design :cat 'a
                           :bar 2
                           :head adj)
            (* *weight* *spew-rate*))
    (when *scm-trace-phrases-p*
      (format t "~&~A~AACTIVATE DESIGN AP --> A" *cycles* #\tab))
)


; AdvPs.
;
; (1) AdvP --> AdvP Adv
; (2) AdvP --> Adv

;;; (1) AdvP --> AdvP Adv
(p@ (associate rh-associate) design-advp1 ((advp phrase)
                                           (adv phrase)
                                           (cp current-position))
    (advp? advp)
    (adjacent? advp adv)
    (adverb? adv)
    (current-word? adv cp)
    (*no ((~d phrase-design))
      (advp? ~d)
      (equal (att ~d) advp)
      (equal (head ~d) adv))
-->
    (spew t (phrase-design :cat 'adv
                           :bar 2
                           :att advp
                           :head adv)
            (* *weight* *spew-rate*))
    (when *scm-trace-phrases-p*
      (format t "~&~A~AACTIVATE DESIGN AdvP --> AdvP Adv" *cycles* #\tab))
)

;;; (2) AdvP --> Adv
(p@ (associate rh-associate) design-advp2 ((adv phrase)
                                           (cp current-position))
    (adverb? adv)
    (current-word? adv cp)
    (*no ((~advp phrase))
      (advp? ~advp)
      (adjacent? ~advp adv))
    (*no ((~d phrase-design))
      (advp? ~d)
      (equal (head ~d) adv))
-->
    (spew t (phrase-design :cat 'adv
                           :bar 2
                           :head adv)
            (* *weight* *spew-rate*))
    (when *scm-trace-phrases-p*
      (format t "~&~A~AACTIVATE DESIGN AdvP --> Adv" *cycles* #\tab))
)


; NPs.
;
; (1) NP -> DP AP N
; (2) NP -> AP N
; (3) NP -> DP N
; (4) NP -> N
;
; Note: These productions are hand-written to be "greedy", so that the
; model attempts to build more complex NPs (e.g., (1)) before less complex
; ones (e.g., (4)).

;;; (1) NP -> DP AP N
(p@ (associate rh-associate) design-np1 ((dp phrase)
                                         (ap phrase)
                                         (noun phrase)
                                         (cp current-position))
    (dp? dp)
    (adjacent? dp ap)
    (ap? ap)
    (adjacent? ap noun)
    (noun? noun)
    (current-word? noun cp)
    (*no ((~d phrase-design))
      (np? ~d)
      (equal (spec ~d) dp)
      (equal (att ~d) ap)
      (equal (head ~d) noun))
-->
    (spew t (phrase-design :cat 'n
                           :bar 2
                           :spec dp
                           :att ap
                           :head noun)
            (* *weight* *spew-rate*))
    (when *scm-trace-phrases-p*
      (format t "~&~A~AACTIVATE DESIGN NP -> DP AP N" *cycles* #\tab))
)

;;; (2) NP -> AP N
(p@ (associate rh-associate) design-np2 ((ap phrase)
                                         (noun phrase)
                                         (cp current-position))
    (ap? ap)
    (adjacent? ap noun)
    (noun? noun)
    (current-word? noun cp)
    (*no ((~dp phrase))
      (dp? ~dp)
      (adjacent? ~dp ap))
    (*no ((~d phrase-design))
      (np? ~d)
      (equal (att ~d) ap)
      (equal (head ~d) noun))
-->
    (spew t (phrase-design :cat 'n
                           :bar 2
                           :att ap
                           :head noun)
            (* *weight* *spew-rate*))
    (when *scm-trace-phrases-p*
      (format t "~&~A~AACTIVATE DESIGN NP -> AP N" *cycles* #\tab))
)

;;; (3) NP -> DP N
(p@ (associate rh-associate) design-np3 ((dp phrase)
                                         (noun phrase)
                                         (cp current-position))
    (dp? dp)
    (adjacent? dp noun)
    (noun? noun)
    (current-word? noun cp)
    (*no ((~d phrase-design))
      (np? ~d)
      (equal (spec ~d) dp)
      (equal (head ~d) noun))
-->
    (spew t (phrase-design :cat 'n
                           :bar 2
                           :spec dp
                           :head noun)
            (* *weight* *spew-rate*))
    (when *scm-trace-phrases-p*
      (format t "~&~A~AACTIVATE DESIGN NP -> DP N" *cycles* #\tab))
)

;;; (4) NP -> N
(p@ (associate rh-associate) design-np4 ((noun phrase)
                                         (cp current-position))
    (noun? noun)
    (current-word? noun cp)
    (*no ((~dp phrase))
      (dp? ~dp)
      (adjacent? ~dp noun))
    (*no ((~ap phrase))
      (ap? ~ap)
      (adjacent? ~ap noun))
    (*no ((~d phrase-design))
      (np? ~d)
      (equal (head ~d) noun))
-->
    (spew t (phrase-design :cat 'n
                           :bar 2
                           :head noun)
            (* *weight* *spew-rate*))
    (when *scm-trace-phrases-p*
      (format t "~&~A~AACTIVATE DESIGN NP -> N" *cycles* #\tab))
)


; PPs.
;
; (1) PP -> P NP

(p@ (associate rh-associate) design-pp ((prep phrase)
                                        (np phrase)
                                        (cp current-position))
    (preposition? prep)
    (adjacent? prep np)
    (np? np)
    (current-word? np cp)
    (*no ((~d phrase-design))
      (pp? ~d)
      (equal (head ~d) prep)
      (equal (comp ~d) np))
-->
    (spew t (phrase-design :cat 'p
                           :bar 2
                           :head prep
                           :comp np)
            (* *weight* *spew-rate*))
    (when *scm-trace-phrases-p*
      (format t "~&~A~AACTIVATE DESIGN PP -> P NP" *cycles* #\tab))
)


; VPs.
;
; (1) VP --> AdvP V
; (2) VP --> V
;
; Note: These productions are hand-written to be "greedy", so that the
; model attempts to build a more complex VP (1) before settling for the
; less complex VP (2).

;;; (1) VP --> AdvP V
(p@ (associate rh-associate) design-vp1 ((advp phrase)
                                         (verb phrase)
                                         (cp current-position))
    (advp? advp)
    (adjacent? advp verb)
    (verb? verb)
    (current-word? verb cp)
    (*no ((~d phrase-design))
      (vp? ~d)
      (equal (att ~d) advp)
      (equal (head ~d) verb))
-->
    (spew t (phrase-design :cat 'v
                           :bar 2
                           :att advp
                           :head verb)
            (* *weight* *spew-rate*))
    (when *scm-trace-phrases-p*
      (format t "~&~A~AACTIVATE DESIGN VP --> AdvP V" *cycles* #\tab))
)

;;; (2) VP --> V
(p@ (associate rh-associate) design-vp2 ((verb phrase)
                                         (cp current-position))
    (verb? verb)
    (current-word? verb cp)
    (*no ((~advp phrase))
      (advp? ~advp)
      (adjacent? ~advp verb))
    (*no ((~d phrase-design))
      (vp? ~d)
      (equal (head ~d) verb))
-->
    (spew t (phrase-design :cat 'v
                           :bar 2
                           :head verb)
            (* *weight* *spew-rate*))
    (when *scm-trace-phrases-p*
      (format t "~&~A~AACTIVATE DESIGN VP --> V" *cycles* #\tab))
)


;; Suppress phrase designs.

(p@ (associate rh-associate) suppress-phrase-design ((d phrase-design)
                                                     (p percept)
                                                     (cp current-position))
    (before? d p)
    (current-word? p cp)
    (*no ((~phr phrase))
      (equal (cat ~phr) (cat d))
      (equal (tense ~phr) (tense d))
      (equal (frame ~phr) (frame d))
      (equal (aux ~phr) (aux d))
      (equal (pro ~phr) (pro d))
      (equal (bar ~phr) (bar d))
      (equal (head ~phr) (head d))
      (equal (spec ~phr) (spec d))
      (equal (att ~phr) (att d))
      (equal (comp ~phr) (comp d)))
-->
    (spew t d (- (* *weight* *spew-rate*)))
    (when *scm-trace-phrases-p*
      (if (zerop (bar d))
        (format t "~&~A~ASUPPRESS DESIGN ~A" *cycles* #\tab (cat d))
        (format t "~&~A~ASUPPRESS DESIGN ~AP" *cycles* #\tab (cat d))))
)



;;;
;;; Phrase constiutents.
;;;


;; Activate phrase constituents.

(p@ (structure rh-structure) activate-new-phrase ((d phrase-design)
                                                  (cp current-position))
    (current-word? d cp)
    (*no ((~phr phrase))
      (equal (cat ~phr) (cat d))
      (equal (tense ~phr) (tense d))
      (equal (frame ~phr) (frame d))
      (equal (aux ~phr) (aux d))
      (equal (pro ~phr) (pro d))
      (equal (bar ~phr) (bar d))
      (equal (head ~phr) (head d))
      (equal (spec ~phr) (spec d))
      (equal (att ~phr) (att d))
      (equal (comp ~phr) (comp d)))

-->
    (spew t (phrase :cat (cat d)
                    :tense (tense d)
                    :frame (frame d)
                    :aux (aux d)
                    :pro (pro d)
                    :bar (bar d)
                    :head (head d)
                    :spec (spec d)
                    :att (att d)
                    :comp (comp d))
            (* *weight* *spew-rate*))
)


;; Suppress phrases.


; After they have spawned thematic roles.

(p@ (structure rh-structure) suppress-np-subordinate ((tr theta-role)
                                                      (np phrase)
                                                      (vp phrase)
                                                      (xp phrase)
                                                      (p percept)
                                                      (cp current-position))
    (np? np)
    (before? np p)
    (vp? vp)
    (before? vp p)
    (equal (receiver tr) np)
    (equal (assigner tr) vp)
    (subordinate? xp np)
    (current-word? p cp)
-->
    (spew t xp (- (* *weight* *spew-rate*)))
    (when *scm-trace-phrases-p*
      (if (zerop (bar xp))
        (format t "~&~A~ASUPPRESS (NP SUB) PHRASE ~A" *cycles* #\tab (cat xp))
        (format t "~&~A~ASUPPRESS (NP SUB) PHRASE ~AP" *cycles* #\tab (cat xp))))
)

(p@ (structure rh-structure) suppress-vp-subordinate ((tr theta-role)
                                                      (vp phrase)
                                                      (xp phrase)
                                                      (p percept)
                                                      (cp current-position))
    (vp? vp)
    (before? vp p)
    (equal (assigner tr) vp)
    (subordinate? xp vp)
    (current-word? p cp)
    (*no ((~tr theta-role))
      (equal (assigner ~tr) vp)
      (> (id ~tr) (id tr)))
-->
    (spew t xp (- (* *weight* *spew-rate*)))
    (when *scm-trace-phrases-p*
      (if (zerop (bar xp))
        (format t "~&~A~ASUPPRESS (VP SUB) PHRASE ~A" *cycles* #\tab (cat xp))
        (format t "~&~A~ASUPPRESS (VP SUB) PHRASE ~AP" *cycles* #\tab (cat xp))))
)


; One word after their completion.

(p@ (structure rh-structure) suppress-pp-subordinate ((pp phrase)
                                                      (xp phrase)
                                                      (p percept)
                                                      (cp current-position))
    (pp? pp)
    (before? pp p)
    (subordinate? xp pp)
    (current-word? p cp)
-->
    (spew t xp (- (* *weight* *spew-rate*)))
    (when *scm-trace-phrases-p*
      (if (zerop (bar xp))
        (format t "~&~A~ASUPPRESS (PP SUB) PHRASE ~A" *cycles* #\tab (cat xp))
        (format t "~&~A~ASUPPRESS (PP SUB) PHRASE ~AP" *cycles* #\tab (cat xp))))
)

(p@ (structure rh-structure) suppress-aux-vp-subordinate ((vp phrase)
                                                          (xp phrase)
                                                          (adj-p percept)
                                                          (p percept)
                                                          (cp current-position))
    (vp? vp)
    (aux? vp)
    (adjacent? vp adj-p)
    (adjacent? adj-p p)
    (subordinate? xp vp)
    (current-word? p cp)
-->
    (spew t xp (- (* *weight* *spew-rate*)))
    (when *scm-trace-phrases-p*
      (if (zerop (bar xp))
        (format t "~&~A~ASUPPRESS (AUX VP SUB) PHRASE ~A" *cycles* #\tab (cat xp))
        (format t "~&~A~ASUPPRESS (AUX VP SUB) PHRASE ~AP" *cycles* #\tab (cat xp))))
)

(p@ (structure rh-structure) suppress-complementizer-subordinate ((comp phrase)
                                                                  (xp phrase)
                                                                  (p percept)
                                                                  (cp current-position))
    (complementizer? comp)
    (adjacent? comp p)
    (subordinate? xp comp)
    (current-word? p cp)
-->
    (spew t xp (- (* *weight* *spew-rate*)))
    (when *scm-trace-phrases-p*
      (if (zerop (bar xp))
        (format t "~&~A~ASUPPRESS (COMP SUB) PHRASE ~A" *cycles* #\tab (cat xp))
        (format t "~&~A~ASUPPRESS (COMP SUB) PHRASE ~AP" *cycles* #\tab (cat xp))))
)

(p@ (structure rh-structure) suppress-conjunction-subordinate ((conj phrase)
                                                               (xp phrase)
                                                               (p percept)
                                                               (cp current-position))
    (conjunction? conj)
    (adjacent? conj p)
    (subordinate? xp conj)
    (current-word? p cp)
-->
    (spew t xp (- (* *weight* *spew-rate*)))
    (when *scm-trace-phrases-p*
      (if (zerop (bar xp))
        (format t "~&~A~ASUPPRESS (CONJ SUB) PHRASE ~A" *cycles* #\tab (cat xp))
        (format t "~&~A~ASUPPRESS (CONJ SUB) PHRASE ~AP" *cycles* #\tab (cat xp))))
)

(p@ (structure rh-structure) suppress-phrase-at-punctuation ((xp phrase)
                                                             (p percept)
                                                             (cp current-position))
    (id xp)
    (punctuation? p)
    (current-word? p cp)
-->
    (spew t xp (- (* *weight* *spew-rate*)))
    (when *scm-trace-phrases-p*
      (if (zerop (bar xp))
        (format t "~&~A~ASUPPRESS PHRASE ~A AT PUNCTUATION" *cycles* #\tab (cat xp))
        (format t "~&~A~ASUPPRESS PHRASE ~AP AT PUNCTUATION" *cycles* #\tab (cat xp))))
)




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Expectation Processing
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;
;;; Expectation designs.
;;;


;; Activate expectation designs.


; Design a theta role expectation that an NP will receive a thematic role from
; the verb of the current clause.

(p@ (associate rh-associate) activate-receives-expectation-design ((cl clause)
                                                                   (np phrase)
                                                                   (cp current-position))
    (np? np)
    (receives-role? np)
    (current-word? np cp)
    (not-copula? cl)
    (*no ((~cl clause))
      (more-current-or-specific? ~cl cl))
    (*no ((~d theta-role-expectation-design))
      (needs-role? ~d)
      (equal (receiver ~d) np)
      (equal (number ~d) (number cl)))
-->
    (spew t (theta-role-expectation-design :role 'needs-role
                                           :receiver np
                                           :number (number cl))
            (* *weight* *spew-rate*))
    (when *scm-trace-expectations-p*
      (format t "~&~A~AACTIVATE DESIGN RECEIVES EXPECTATION" *cycles* #\tab))
)


; Design theta role expectations that a verb will assign all of the theta
; roles in its argument frame.

(p@ (associate rh-associate) activate-assigns-agent-expectation-design ((cl clause)
                                                                        (vp phrase)
                                                                        (cp current-position))
    (vp? vp)
    (assigns-agent? vp)
    (current-word? vp cp)
    (main-verb? vp cl)
    (*no ((~d theta-role-expectation-design))
      (agent? ~d)
      (equal (assigner ~d) vp)
      (equal (number ~d) (number cl)))
-->
    (spew t (theta-role-expectation-design :role 'agent
                                           :assigner vp
                                           :number (number cl))
            (* *weight* *spew-rate*))
    (when *scm-trace-expectations-p*
      (format t "~&~A~AACTIVATE DESIGN ASSIGNS AGENT EXPECTATION" *cycles* #\tab))
)

(p@ (associate rh-associate) activate-assigns-patient-expectation-design ((cl clause)
                                                                          (vp phrase)
                                                                          (cp current-position))
    (vp? vp)
    (assigns-patient? vp)
    (current-word? vp cp)
    (main-verb? vp cl)
    (*no ((~d theta-role-expectation-design))
      (patient? ~d)
      (equal (assigner ~d) vp)
      (equal (number ~d) (number cl)))
-->
    (spew t (theta-role-expectation-design :role 'patient
                                           :assigner vp
                                           :number (number cl))
            (* *weight* *spew-rate*))
    (when *scm-trace-expectations-p*
      (format t "~&~A~AACTIVATE DESIGN ASSIGNS PATIENT EXPECTATION" *cycles* #\tab))
)

(p@ (associate rh-associate) activate-assigns-recipient-expectation-design ((cl clause)
                                                                            (vp phrase)
                                                                            (cp current-position))
    (vp? vp)
    (assigns-recipient? vp)
    (current-word? vp cp)
    (main-verb? vp cl)
    (*no ((~d theta-role-expectation-design))
      (recipient? ~d)
      (equal (assigner ~d) vp)
      (equal (number ~d) (number cl)))
-->
    (spew t (theta-role-expectation-design :role 'recipient
                                           :assigner vp
                                           :number (number cl))
            (* *weight* *spew-rate*))
    (when *scm-trace-expectations-p*
      (format t "~&~A~AACTIVATE DESIGN ASSIGNS RECIPIENT EXPECTATION" *cycles* #\tab))
)

(p@ (associate rh-associate) activate-assigns-theme-expectation-design ((cl clause)
                                                                        (vp phrase)
                                                                        (cp current-position))
    (vp? vp)
    (assigns-theme? vp)
    (current-word? vp cp)
    (main-verb? vp cl)
    (*no ((~d theta-role-expectation-design))
      (theme? ~d)
      (equal (assigner ~d) vp)
      (equal (number ~d) (number cl)))
-->
    (spew t (theta-role-expectation-design :role 'theme
                                           :assigner vp
                                           :number (number cl))
            (* *weight* *spew-rate*))
    (when *scm-trace-expectations-p*
      (format t "~&~A~AACTIVATE DESIGN ASSIGNS THEME EXPECTATION" *cycles* #\tab))
)

(p@ (associate rh-associate) activate-assigns-time-expectation-design ((cl clause)
                                                                       (vp phrase)
                                                                       (cp current-position))
    (vp? vp)
    (assigns-time? vp)
    (current-word? vp cp)
    (main-verb? vp cl)
    (*no ((~d theta-role-expectation-design))
      (time? ~d)
      (equal (assigner ~d) vp)
      (equal (number ~d) (number cl)))
-->
    (spew t (theta-role-expectation-design :role 'time
                                           :assigner vp
                                           :number (number cl))
            (* *weight* *spew-rate*))
    (when *scm-trace-expectations-p*
      (format t "~&~A~AACTIVATE DESIGN ASSIGNS TIME EXPECTATION" *cycles* #\tab))
)

(p@ (associate rh-associate) activate-assigns-place-expectation-design ((cl clause)
                                                                        (vp phrase)
                                                                        (cp current-position))
    (vp? vp)
    (assigns-place? vp)
    (current-word? vp cp)
    (main-verb? vp cl)
    (*no ((~d theta-role-expectation-design))
      (place? ~d)
      (equal (assigner ~d) vp)
      (equal (number ~d) (number cl)))
-->
    (spew t (theta-role-expectation-design :role 'place
                                           :assigner vp
                                           :number (number cl))
            (* *weight* *spew-rate*))
    (when *scm-trace-expectations-p*
      (format t "~&~A~AACTIVATE DESIGN ASSIGNS PLACE EXPECTATION" *cycles* #\tab))
)


;; Suppress expectation designs.

(p@ (associate rh-associate) suppress-receives-expectation-design ((d theta-role-expectation-design)
                                                                   (tr theta-role)
                                                                   (p percept)
                                                                   (cp current-position))
    (needs-role? d)
    (equal (receiver d) (receiver tr))
    (equal (number d) (number tr))
    (before? (receiver tr) p)
    (before? (assigner tr) p)
    (current-word? p cp)
-->
    (spew t d (- (* *weight* *spew-rate*)))
    (when *scm-trace-expectations-p*
      (format t "~&~A~ASUPPRESS DESIGN RECEIVES EXPECTATION" *cycles* #\tab))
)

(p@ (associate rh-associate) suppress-assigns-expectation-design ((d theta-role-expectation-design)
                                                                  (tr theta-role)
                                                                  (p percept)
                                                                  (cp current-position))
    (thematic-role? d)
    (equal (role d) (role tr))
    (equal (assigner d) (assigner tr))
    (equal (number d) (number tr))
    (before? (receiver tr) p)
    (before? (assigner tr) p)
    (current-word? p cp)
-->
    (spew t d (- (* *weight* *spew-rate*)))
    (when *scm-trace-expectations-p*
      (format t "~&~A~ASUPPRESS DESIGN ASSIGNS ~A EXPECTATION" *cycles* #\tab (role d)))
)

(p@ (associate rh-associate) suppress-expectation-design-at-punctuation ((tr theta-role)
                                                                         (trd theta-role-design)
                                                                         (p percept)
                                                                         (cp current-position))
    (equal (role tr) (role trd))
    (equal (receiver tr) (receiver trd))
    (equal (assigner tr) (assigner trd))
    (equal (number tr) (number trd))
    (punctuation? p)
    (current-word? p cp)
-->
    (spew t trd (- (* *weight* *spew-rate*)))
    (when *scm-trace-expectations-p*
      (format t "~&~A~ASUPPRESS DESIGN ~A EXPECTATION" *cycles* #\tab (role trd)))
)



;;;
;;; Expectation constiutents.
;;;


;; Activate expectation constituents.

(p@ (structure rh-structure) activate-receives-expectation ((d theta-role-expectation-design)
                                                            (cp current-position))
    (needs-role? d)
    (current-word? (receiver d) cp)
    (*no ((~tre theta-role-expectation))
      (equal (receiver ~tre) (receiver d))
      (equal (number ~tre) (number d)))
-->
    (spew t (theta-role-expectation :role (role d)
                                    :receiver (receiver d)
                                    :number (number d))
            (* *weight* *spew-rate*))
    (when *scm-trace-expectations-p*
      (format t "~&~A~AACTIVATE RECEIVES EXPECTATION" *cycles* #\tab))
)

(p@ (structure rh-structure) activate-assigns-expectation ((d theta-role-expectation-design))
    (thematic-role? d)
    (*no ((~tre theta-role-expectation))
      (equal (role ~tre) (role d))
      (equal (assigner ~tre) (assigner d))
      (equal (number ~tre) (number d)))
-->
    (spew t (theta-role-expectation :role (role d)
                                    :assigner (assigner d)
                                    :number (number d))
            (* *weight* *spew-rate*))
    (when *scm-trace-expectations-p*
      (format t "~&~A~AACTIVATE ASSIGNS ~A EXPECTATION" *cycles* #\tab (role d)))
)


;; Suppress expectation consituents.

(p@ (structure rh-structure) suppress-receives-expectation ((rtre theta-role-expectation)
                                                            (tr theta-role)
                                                            (p percept)
                                                            (cp current-position))
    (needs-role? rtre)
    (equal (receiver tr) (receiver rtre))
    (equal (number tr) (number rtre))
    (before? (receiver tr) p)
    (before? (assigner tr) p)
    (current-word? p cp)
-->
    (spew t rtre (- (* *weight* *spew-rate*)))
    (when *scm-trace-expectations-p*
      (format t "~&~A~ASUPPRESS RECEIVES EXPECTATION" *cycles* #\tab))
)

(p@ (structure rh-structure) suppress-assigns-expectation ((atre theta-role-expectation)
                                                           (tr theta-role)
                                                           (p percept)
                                                           (cp current-position))
    (thematic-role? atre)
    (equal (role tr) (role atre))
    (equal (assigner tr) (assigner atre))
    (equal (number tr) (number atre))
    (before? (receiver tr) p)
    (before? (assigner tr) p)
    (current-word? p cp)
-->
    (spew t atre (- (* *weight* *spew-rate*)))
    (when *scm-trace-expectations-p*
      (format t "~&~A~ASUPPRESS ASSIGNS ~A EXPECTATION" *cycles* #\tab (role atre)))
)




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Theta Role Processing
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;
;;; Theta role designs.
;;;


;; Activate theta role designs.
;;
;; Some of these productions are special-cased to specific words.


; Agents.

(p@ (associate rh-associate) activate-active-agent-design ((cl clause)
                                                           (rtre theta-role-expectation)
                                                           (atre theta-role-expectation))
    (needs-role? rtre)
    (agent? atre)
    (equals (number cl) (number rtre) (number atre))
    (active? cl)

    ;;^^
    (*no ((~rtre theta-role-expectation))
      (needs-role? ~rtre)
      (equal (number ~rtre) (number cl))
      (before? (head (receiver rtre)) (head (receiver ~rtre))))    
    (*no ((~rtre theta-role-expectation))
      (needs-role? ~rtre)
      (equal (number ~rtre) (number cl))
      (before? (head (receiver ~rtre)) (head (receiver rtre)))
      (<= (abs (- (act ~rtre) (act rtre))) *selection-threshold*))

    (*no ((~d theta-role-design))
      (equal (receiver ~d) (receiver rtre))
      (equal (number ~d) (number cl)))
    (*no ((~d theta-role-design))
      (agent? ~d)
      (equal (assigner ~d) (assigner atre))
      (equal (number ~d) (number cl)))
-->
    (spew t (theta-role-design :role 'agent
                               :receiver (receiver rtre)
                               :assigner (assigner atre)
                               :number (number cl))
            (* *weight* *spew-rate*))
    (when *scm-trace-theta-roles-p*
      (format t "~&~A~AACTIVATE DESIGN AGENT" *cycles* #\tab))
)

(p@ (associate rh-associate) activate-passive-agent-design ((cl clause)
                                                            (rtre theta-role-expectation)
                                                            (atre theta-role-expectation)
                                                            (tr theta-role)
                                                            (pp phrase))
    (needs-role? rtre)
    (agent? atre)
    (patient? tr)
    (equals (number cl) (number rtre) (number atre) (number tr))
    (pp? pp)
    (equal (comp pp) (receiver rtre))
    (equal (ortho pp) 'by)
    (passive? cl)
    (*no ((~d theta-role-design))
      (equal (receiver ~d) (receiver rtre))
      (equal (number ~d) (number cl)))
    (*no ((~d theta-role-design))
      (agent? ~d)
      (equal (assigner ~d) (assigner atre))
      (equal (number ~d) (number cl)))
-->
    (spew t (theta-role-design :role 'agent
                               :receiver (receiver rtre)
                               :assigner (assigner atre)
                               :number (number cl))
            (* *weight* *spew-rate*))
    (when *scm-trace-theta-roles-p*
      (format t "~&~A~AACTIVATE DESIGN AGENT" *cycles* #\tab))
)


; Patients.

(p@ (associate rh-associate) activate-active-patient-design ((cl clause)
                                                             (rtre theta-role-expectation)
                                                             (atre theta-role-expectation)
                                                             (tr theta-role))
    (needs-role? rtre)
    (patient? atre)
    (agent? tr)
    (equal (assigner tr) (by cl))
    (equals (number cl) (number rtre) (number atre) (number tr))
    (active? cl)
    (*no ((~d theta-role-design))
      (equal (receiver ~d) (receiver rtre))
      (equal (number ~d) (number cl)))
    (*no ((~d theta-role-design))
      (patient? ~d)
      (equal (assigner ~d) (assigner atre))
      (equal (number ~d) (number cl)))
-->
    (spew t (theta-role-design :role 'patient
                               :receiver (receiver rtre)
                               :assigner (assigner atre)
                               :number (number cl))
            (* *weight* *spew-rate*))
    (when *scm-trace-theta-roles-p*
      (format t "~&~A~AACTIVATE DESIGN PATIENT" *cycles* #\tab))
)

(p@ (associate rh-associate) activate-passive-patient-design ((cl clause)
                                                              (rtre theta-role-expectation)
                                                              (atre theta-role-expectation))
    (needs-role? rtre)
    (patient? atre)
    (equals (number cl) (number rtre) (number atre))
    (passive? cl)

    ;;^^
    (*no ((~rtre theta-role-expectation))
      (needs-role? ~rtre)
      (equal (number ~rtre) (number cl))
      (before? (head (receiver rtre)) (head (receiver ~rtre))))
    (*no ((~rtre theta-role-expectation))
      (needs-role? ~rtre)
      (equal (number ~rtre) (number cl))
      (before? (head (receiver ~rtre)) (head (receiver rtre)))
      (<= (abs (- (act ~rtre) (act rtre))) *selection-threshold*))

    (*no ((~d theta-role-design))
      (equal (receiver ~d) (receiver rtre))
      (equal (number ~d) (number cl)))
    (*no ((~d theta-role-design))
      (patient? ~d)
      (equal (assigner ~d) (assigner atre))
      (equal (number ~d) (number cl)))
-->
    (spew t (theta-role-design :role 'patient
                               :receiver (receiver rtre)
                               :assigner (assigner atre)
                               :number (number cl))
            (* *weight* *spew-rate*))
    (when *scm-trace-theta-roles-p*
      (format t "~&~A~AACTIVATE DESIGN PATIENT" *cycles* #\tab))
)


; Recipients.

(p@ (associate rh-associate) activate-recipient-design ((cl clause)
                                                        (rtre theta-role-expectation)
                                                        (atre theta-role-expectation)
                                                        (pp phrase))
    (needs-role? rtre)
    (recipient? atre)
    (pp? pp)
    (equal (comp pp) (receiver rtre))
    (equal (ortho pp) 'to)
    (equals (number cl) (number rtre) (number atre))
    (voice cl)
    (*no ((~d theta-role-design))
      (equal (receiver ~d) (receiver rtre))
      (equal (number ~d) (number cl)))
    (*no ((~d theta-role-design))
      (recipient? ~d)
      (equal (assigner ~d) (assigner atre))
      (equal (number ~d) (number cl)))
-->
    (spew t (theta-role-design :role 'recipient
                               :receiver (receiver rtre)
                               :assigner (assigner atre)
                               :number (number cl))
            (* *weight* *spew-rate*))
    (when *scm-trace-theta-roles-p*
      (format t "~&~A~AACTIVATE DESIGN RECIPIENT" *cycles* #\tab))
)


; Themes.

(p@ (associate rh-associate) activate-theme-design ((cl clause)
                                                    (rtre theta-role-expectation)
                                                    (atre theta-role-expectation)
                                                    (pp phrase))
    (needs-role? rtre)
    (theme? atre)
    (pp? pp)
    (equal (comp pp) (receiver rtre))
    (equal (ortho pp) 'about)
    (equals (number cl) (number rtre) (number atre))
    (voice cl)
    (*no ((~d theta-role-design))
      (equal (receiver ~d) (receiver rtre))
      (equal (number ~d) (number cl)))
    (*no ((~d theta-role-design))
      (theme? ~d)
      (equal (assigner ~d) (assigner atre))
      (equal (number ~d) (number cl)))
-->
    (spew t (theta-role-design :role 'theme
                               :receiver (receiver rtre)
                               :assigner (assigner atre)
                               :number (number cl))
            (* *weight* *spew-rate*))
    (when *scm-trace-theta-roles-p*
      (format t "~&~A~AACTIVATE DESIGN THEME" *cycles* #\tab))
)


; Time.

(p@ (associate rh-associate) activate-time-design ((cl clause)
                                                   (rtre theta-role-expectation)
                                                   (atre theta-role-expectation)
                                                   (pp phrase))
    (needs-role? rtre)
    (time? atre)
    (pp? pp)
    (equal (comp pp) (receiver rtre))
    (equal (ortho pp) 'before)
    (equals (number cl) (number rtre) (number atre))
    (voice cl)
    (*no ((~d theta-role-design))
      (equal (receiver ~d) (receiver rtre))
      (equal (number ~d) (number cl)))
    (*no ((~d theta-role-design))
      (time? ~d)
      (equal (assigner ~d) (assigner atre))
      (equal (number ~d) (number cl)))
-->
    (spew t (theta-role-design :role 'time
                               :receiver (receiver rtre)
                               :assigner (assigner atre)
                               :number (number cl))
            (* *weight* *spew-rate*))
    (when *scm-trace-theta-roles-p*
      (format t "~&~A~AACTIVATE DESIGN TIME" *cycles* #\tab))
)


; Places.

(p@ (associate rh-associate) activate-place-design ((cl clause)
                                                    (rtre theta-role-expectation)
                                                    (atre theta-role-expectation)
                                                    (pp phrase))
    (needs-role? rtre)
    (place? atre)
    (pp? pp)
    (equal (comp pp) (receiver rtre))
    (member (ortho pp) '(below in at))
    (equals (number cl) (number rtre) (number atre))
    (voice cl)
    (*no ((~d theta-role-design))
      (equal (receiver ~d) (receiver rtre))
      (equal (number ~d) (number cl)))
    (*no ((~d theta-role-design))
      (place? ~d)
      (equal (assigner ~d) (assigner atre))
      (equal (number ~d) (number cl)))
-->
    (spew t (theta-role-design :role 'place
                               :receiver (receiver rtre)
                               :assigner (assigner atre)
                               :number (number cl))
            (* *weight* *spew-rate*))
    (when *scm-trace-theta-roles-p*
      (format t "~&~A~AACTIVATE DESIGN PLACE" *cycles* #\tab))
)



;;;
;;; Theta-role constiutents.
;;;


;; Activate theta role constituents.

(p@ (structure rh-structure) activate-theta-role ((d theta-role-design))
    (number d)
    (*no ((~tr theta-role))
      (equal (role ~tr) (role d))
      (equal (receiver ~tr) (receiver d))
      (equal (assigner ~tr) (assigner d))
      (equal (number ~tr) (number d)))
-->
    (spew t (theta-role :role (role d)
                        :receiver (receiver d)
                        :assigner (assigner d)
                        :number (number d))
            (* *weight* *spew-rate*))
    (when *scm-trace-theta-roles-p*
      (format t "~&~A~AACTIVATE ~A" *cycles* #\tab (role d)))
)




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Syntactic Processing: Clauses
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;
;;; Clause designs.
;;;


;; Activate clause designs.


; Design copula and cleft clauses.

;;;^^^ What about adverbs as the xp-phr?
(p@ (associate rh-associate) design-clause-copula ((cl clause)
                                                   (np phrase)
                                                   (vp phrase)
                                                   (xp-phr phrase)
                                                   (cp current-position))
    (np? np)
    (pro? np)
    (adjacent? np vp)
    (vp? vp)
    (aux? vp)
    (adjacent? vp xp-phr)
    (not-equal (cat xp-phr) 'v)
    (equal (bar xp-phr) 0)
    (current-word? xp-phr cp)
    (no-voice? cl)
    (*no ((~cl clause))
      (more-current-or-specific? ~cl cl))
    (*no ((~d clause-design))
      (equal (parent ~d) cl)
      (equal (by ~d) vp)
      (copula? ~d)
      (equal (number ~d) (number cl)))
    (*no ((~cl clause))
      (equal (parent ~cl) cl)
      (equal (by ~cl) vp)
      (copula? ~cl)
      (equal (number ~cl) (number cl)))
-->
    (spew t (clause-design :parent cl
                           :by vp
                           :voice 'copula
                           :number (number cl))
            (* *weight* *spew-rate*))
    (when *scm-trace-clauses-p*
      (format t "~&~A~ADESIGN CLAUSE (COPULA)" *cycles* #\tab))
)

(p@ (associate rh-associate) design-clause-cleft ((cl clause)
                                                         (np phrase)
                                                         (comp phrase)
                                                         (cp current-position))
    (np? np)
    (adjacent? np comp)
    (complementizer? comp)
    (current-word? comp cp)
    (not-equal comp (for* cl))
    (copula? cl)
    (*no ((~cl clause))
      (more-current-or-specific? ~cl cl))
    (*no ((~d clause-design))
      (equal (for* ~d) comp))
    (*no ((~cl clause))
      (equal (for* ~cl) comp))
-->
    (spew t (clause-design :for* comp
                           :number (next-clause cl))
            (* *weight* *spew-rate*))
    (spew t (theta-role-expectation-design :role 'needs-role
                                           :receiver np
                                           :number (next-clause cl))
            (* *weight* *spew-rate*))
    (when *scm-trace-clauses-p*
      (format t "~&~A~ADESIGN CLAUSE (CLEFT) ~A" *cycles* #\tab cl))
)


; Relative clauses.

(p@ (associate rh-associate) design-clause-center-embedded ((cl clause)
                                                            (np phrase)
                                                            (comp phrase)
                                                            (cp current-position))
    (np? np)
    (adjacent? np comp)
    (complementizer? comp)
    (current-word? comp cp)
    (not-equal comp (for* cl))
    (no-voice? cl)
    (*no ((~cl clause))
      (more-current-or-specific? ~cl cl))
    (*no ((~d clause-design))
      (equal (for* ~d) comp))
    (*no ((~cl clause))
      (equal (for* ~cl) comp))
-->
    (spew t (clause-design :for* comp
                           :number (next-clause cl))
            (* *weight* *spew-rate*))
    (spew t (theta-role-expectation-design :role 'needs-role
                                           :receiver np
                                           :number (next-clause cl))
            (* *weight* *spew-rate*))
    (when *scm-trace-clauses-p*
      (format t "~&~A~ADESIGN CLAUSE (CENTER-EMBEDDED) ~A" *cycles* #\tab cl))
)

(p@ (associate rh-associate) design-clause-right-branching ((cl clause)
                                                            (tr theta-role)
                                                            (comp phrase)
                                                            (cp current-position))
    (equal (number cl) (number tr))
    (adjacent? (receiver tr) comp)
    (complementizer? comp)
    (not-equal comp (for* cl))
    (current-word? comp cp)
    (*no ((~verb phrase))
      (verb? ~verb)
      (current-word? ~verb cp))
    (*no ((~cl clause))
      (more-current-or-specific? ~cl cl))
    (*no ((~d clause-design))
      (equal (for* ~d) comp)
      (equal (number ~d) (next-clause cl)))
    (*no ((~cl clause))
      (equal (for* ~cl) comp)
      (equal (number ~cl) (next-clause cl)))
-->
    (spew t (clause-design :for* comp
                           :number (next-clause cl))
            (* *weight* *spew-rate*))
    (spew t (theta-role-expectation-design :role 'needs-role
                                           :receiver (receiver tr)
                                           :number (next-clause cl))
            (* *weight* *spew-rate*))
    (when *scm-trace-clauses-p*
      (format t "~&~A~ADESIGN CLAUSE (RIGHT-BRANCHING)" *cycles* #\tab))
)


; Conjoined clauses.

(p@ (associate rh-associate) design-clause-conjoined ((cl clause)
                                                      (conj phrase)
                                                      (tr theta-role)
                                                      (cp current-position))
    (conjunction? conj)
    (current-word? conj cp)
    (agent? tr)
    (equal (number cl) (number tr))
    (not-equal conj (for* cl))
    (*no ((~cl clause))
      (more-current-or-specific? ~cl cl))
    (*no ((~d clause-design))
      (equal (for* ~d) conj)
      (equal (number ~d) (next-clause cl)))
    (*no ((~cl clause))
      (equal (for* ~cl) conj)
      (equal (number ~cl) (next-clause cl)))
-->
    (spew t (clause-design :for* conj
                           :number (next-clause cl))
            (* *weight* *spew-rate*))
    (spew t (theta-role-expectation-design :role 'needs-role
                                           :receiver (receiver tr)
                                           :number (next-clause cl))
            (* *weight* *spew-rate*))
    (when *scm-trace-clauses-p*
      (format t "~&~A~ADESIGN CLAUSE (CONJOINED)" *cycles* #\tab))
)


; Design center-embedded clauses for the reduced interpretation of ambiguous
; sentences.

(p@ (associate rh-associate) design-clause-center-embedded-reduced ((cl clause)
                                                                    (np phrase)
                                                                    (vp phrase)
                                                                    (cp current-position))
    (np? np)
    (adjacent? np vp)
    (vp? vp)
    (current-word? vp cp)
    (past-participle? vp)
    (not-equal vp (for* cl))
    (*no ((~cl clause))
      (more-current-or-specific? ~cl cl))
    (*no ((~d clause-design))
      (equal (for* ~d) vp)
      (equal (by ~d) vp)
      (equal (tense ~d) 'past)
      (passive? ~d)
      (equal (number ~d) (next-clause cl)))
    (*no ((~cl clause))
      (equal (for* ~cl) vp)
      (equal (by ~cl) vp)
      (equal (tense ~cl) 'past)
      (passive ~cl)
      (equal (number ~cl) (next-clause cl)))
-->
    (spew t (clause-design :number (next-clause cl))
            (* *weight* *spew-rate*))
    (spew t (clause-design :for* vp
                           :by vp
                           :tense 'past
                           :voice 'passive
                           :number (next-clause cl))
            (* *weight* *spew-rate*))
    (spew t (theta-role-expectation-design :role 'needs-role
                                           :receiver np
                                           :number (next-clause cl))
            (* *weight* *spew-rate*))
    (when *scm-trace-clauses-p*
      (format t "~&~A~ADESIGN CLAUSE (REDUCED CENTER-EMBEDDED)" *cycles* #\tab))
)


; Design new clauses that elaborate the current clause, filling in its
; tense and voice. 

(p@ (associate rh-associate) design-clause-present-active ((cl clause)
                                                           (vp phrase)
                                                           (cp current-position))
    (vp? vp)
    (present? vp)
    (current-word? vp cp)
    (no-voice? cl)
    (*no ((~cl clause))
      (more-current-or-specific? ~cl cl))
    (*no ((~d clause-design))
      (equal (parent ~d) cl)
      (equal (by ~d) vp)
      (equal (tense ~d) 'present)
      (active? ~d)
      (equal (number ~d) (number cl)))
    (*no ((~cl clause))
      (equal (parent ~cl) cl)
      (equal (by ~cl) vp)
      (equal (tense ~cl) 'present)
      (active? ~cl)
      (equal (number ~cl) (number cl)))
-->
    (spew t (clause-design :parent cl
                           :by vp
                           :tense 'present
                           :voice 'active
                           :number (number cl))
            (* *weight* *spew-rate*))
    (when *scm-trace-clauses-p*
      (format t "~&~A~ADESIGN CLAUSE (PRESENT, ACTIVE)" *cycles* #\tab))
)

(p@ (associate rh-associate) design-clause-past-active ((cl clause)
                                                        (vp phrase)
                                                        (cp current-position))
    (vp? vp)
    (past? vp)
    (current-word? vp cp)
    (no-voice? cl)
    (*no ((~vp phrase))
      (vp? ~vp)
      (aux? ~vp)
      (adjacent? ~vp vp))
    (*no ((~vp phrase))
      (vp? ~vp)
      (aux? ~vp)
      (equal (start ~vp) (start vp))
      (equal (end ~vp) (end vp)))
    (*no ((~cl clause))
      (more-current-or-specific? ~cl cl))
    (*no ((~d clause-design))
      (equal (parent ~d) cl)
      (equal (by ~d) vp)
      (equal (tense ~d) 'past)
      (active? ~d)
      (equal (number ~d) (number cl)))
    (*no ((~cl clause))
      (equal (parent ~cl) cl)
      (equal (by ~cl) vp)
      (equal (tense ~cl) 'past)
      (active? ~cl)
      (equal (number ~cl) (number cl)))
-->
    (spew t (clause-design :parent cl
                           :by vp
                           :tense 'past
                           :voice 'active
                           :number (number cl))
            (* *weight* *spew-rate*))
    (when *scm-trace-clauses-p*
      (format t "~&~A~ADESIGN CLAUSE (PAST, ACTIVE)" *cycles* #\tab))
)

(p@ (associate rh-associate) design-clause-passive ((cl clause)
                                                    (vp1 phrase)
                                                    (vp2 phrase)
                                                    (cp current-position))
    (vp? vp1)
    (aux? vp1)
    (adjacent? vp1 vp2)
    (vp? vp2)
    (past? vp2)
    (current-word? vp2 cp)
    (no-voice? cl)
    (*no ((~cl clause))
      (more-current-or-specific? ~cl cl))
    (*no ((~d clause-design))
      (equal (parent ~d) cl)
      (equal (by ~d) vp2)
      (equal (tense ~d) 'past)
      (passive? ~d)
      (equal (number ~d) (number cl)))
    (*no ((~cl clause))
      (equal (parent ~cl) cl)
      (equal (by ~cl) vp2)
      (equal (tense ~cl) 'past)
      (passive? ~cl)
      (equal (number ~cl) (number cl)))
-->
    (spew t (clause-design :parent cl
                           :by vp2
                           :tense 'past
                           :voice 'passive
                           :number (number cl))
            (* *weight* *spew-rate*))
    (when *scm-trace-clauses-p*
      (format t "~&~A~ADESIGN CLAUSE (PAST, PASSIVE)" *cycles* #\tab))
)

(p@ (associate rh-associate) design-clause-passive-past-participle ((cl clause)
                                                                    (vp1 phrase)
                                                                    (vp2 phrase)
                                                                    (cp current-position))
    (vp? vp1)
    (aux? vp1)
    (equal (start vp1) (start vp2))
    (equal (end vp1) (end vp2))
    (vp? vp2)
    (past-participle? vp2)
    (current-word? vp2 cp)
    (no-voice? cl)
    (*no ((~cl clause))
      (more-current-or-specific? ~cl cl))

    (*no ((~d clause-design))
      (equal (parent ~d) cl)
      (equal (by ~d) vp2)
      (equal (tense ~d) 'past)
      (passive? ~d)
      (equal (number ~d) (number cl)))
    (*no ((~cl clause))
      (equal (parent ~cl) cl)
      (equal (by ~cl) vp2)
      (equal (tense ~cl) 'past)
      (passive ~cl)
      (equal (number ~cl) (number cl)))
-->
    (spew t (clause-design :parent cl
                           :by vp2
                           :tense 'past
                           :voice 'passive
                           :number (number cl))
            (* *weight* *spew-rate*))
    (when *scm-trace-clauses-p*
      (format t "~&~A~ADESIGN CLAUSE (PAST-PARTICIPLE, PASSIVE)" *cycles* #\tab))
)


; Design other kinds of clauses.

(p@ (associate rh-associate) design-predicate-adjective-clausal-complement ((cl clause)
                                                                            (ap phrase)
                                                                            (comp phrase)
                                                                            (cp current-position))
    (ap? ap)
    (adjacent? ap comp)
    (complementizer? comp)
    (current-word? comp cp)
    (not-equal comp (for* cl))
    (*no ((~cl clause))
      (more-current-or-specific? ~cl cl))
    (*no ((~d clause-design))
      (equal (for* ~d) comp))
    (*no ((~cl clause))
      (equal (for* ~cl) comp))
-->
    (spew t (clause-design :for* comp
                           :number (next-clause cl))
            (* *weight* *spew-rate*))
    (when *scm-trace-clauses-p*
      (format t "~&~A~ADESIGN CLAUSE (PREDICATE ADJECTIVE CLAUSAL COMPLEMENT)" *cycles* #\tab))
)


;

(p@ (associate rh-associate) design-clause-predicate-nom/pp ((cl clause)
                                                             (np phrase)
                                                             (vp phrase)
                                                             (xp-phr phrase)
                                                             (cp current-position))
    (np? np)
    (receives-role? np)
    (adjacent? np vp)
    (vp? vp)
    (aux? vp)
    (adjacent? vp xp-phr)
    (not-equal (cat xp-phr) 'v)
    (equal (bar xp-phr) 0)
    (current-word? xp-phr cp)
    (no-voice? cl)
    (*no ((~cl clause))
      (more-current-or-specific? ~cl cl))
    (*no ((~d clause-design))
      (equal (parent ~d) cl)
      (equal (by ~d) vp)
      (equal (tense ~d) (if (present? vp)
                          'present
                          'past))
      (active? ~d)
      (equal (number ~d) (number cl)))
    (*no ((~cl clause))
      (equal (parent ~cl) cl)
      (equal (by ~cl) vp)
      (equal (tense ~cl) (if (present? vp)
                           'present
                           'past))
      (active? ~cl)
      (equal (number ~cl) (number cl)))
-->
    (spew t (clause-design :parent cl
                           :by vp
                           :tense (if (present? vp)
                                    'present
                                    'past)
                           :voice 'active
                           :number (number cl))
            (* *weight* *spew-rate*))
    (when *scm-trace-clauses-p*
      (format t "~&~A~ADESIGN CLAUSE (PREDICATE NOMINATIVE/PP)" *cycles* #\tab))
)


;; Suppress clause designs.


;

(p@ (associate rh-associate) suppress-clause-design-1 ((d clause-design)
                                                       (cl clause)
                                                       (p percept)
                                                       (cp current-position))
    (equal (for* cl) (for* d))
    (equal (number cl) (number d))
    (before? (for* cl) p)
    (current-word? p cp)
-->
    (spew t d (- (* *weight* *spew-rate*)))
)

(p@ (associate rh-associate) suppress-clause-design-2 ((d clause-design)
                                                       (cl clause)
                                                       (p percept)
                                                       (cp current-position))
    (equal (parent cl) (parent d))
    (equal (number cl) (number d))
    (before? (by cl) p)
    (current-word? p cp)
-->
    (spew t d (- (* *weight* *spew-rate*)))
)



;;;
;;; Clause constituents.
;;;


;; Activate clause constituents.

(p@ (structure rh-structure) activate-new-clause ((d clause-design))
    (number d)
    (*no ((~cl clause))
      (equal (parent ~cl) (parent d))
      (equal (for* ~cl) (for* d))
      (equal (by ~cl) (by d))
      (equal (tense ~cl) (tense d))
      (equal (voice ~cl) (voice d))
      (equal (number ~cl) (number d)))
-->
    (spew t (clause :for* (for* d)
                    :by (by d)
                    :parent (parent d)
                    :tense (tense d)
                    :voice (voice d)
                    :number (number d))
            (* *weight* *spew-rate*))
)


;; Suppress clauses that have been completed and are thus no longer current.

(p@ (structure rh-structure) suppress-clause-superordinate ((sup-sup-cl clause)
                                                            (sup-cl clause)
                                                            (sub-cl clause))
    (by sub-cl)
    (not-equal sup-cl sub-cl)
    (< (number sup-sup-cl) (number sup-cl))
    (equal (number sup-cl) (number sub-cl))
    (not-copula? sub-cl)
    (*no ((~cl clause))
      (not-equal ~cl sub-cl)
      (by sub-cl)
      (by ~cl)
      (equal (ortho (by ~cl)) (ortho (by sub-cl))))
    (*no ((~tre theta-role-expectation))
      (equal (number ~tre) (number sub-cl)))
-->
    (spew t sup-cl (- (* *weight* *spew-rate*)))
)

(p@ (structure rh-structure) suppress-clause-subordinate ((sup-cl clause)
                                                          (sub-cl clause))
    (by sub-cl)
    (not-equal sup-cl sub-cl)
    (equal (number sup-cl) (number sub-cl))
    (not-copula? sub-cl)
    (*no ((~cl clause))
      (not-equal ~cl sub-cl)
      (by sub-cl)
      (by ~cl)
      (equal (ortho (by ~cl)) (ortho (by sub-cl))))
    (*no ((~tre theta-role-expectation))
       (equal (number ~tre) (number sub-cl)))
-->
    (spew t sub-cl (- (* *weight* *spew-rate*)))
)




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Relative Clauses.
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;
;;; Unreduced relative clauses.
;;;


;; Activate expectation constituents.

(p@ (structure rh-structure) activate-receives-expectation-at-complementizer ((d theta-role-expectation-design)
                                                                              (comp phrase)
                                                                              (cp current-position))
    (needs-role? d)
    (complementizer? comp)
    (current-word? comp cp)
    (*no ((~tre theta-role-expectation))
      (equal (receiver ~tre) (receiver d))
      (equal (number ~tre) (number d)))
-->
    (spew t (theta-role-expectation :role (role d)
                                    :receiver (receiver d)
                                    :number (number d))
            (* *weight* *spew-rate*))
)

(p@ (structure rh-structure) activate-receives-expectation-at-conjunction ((d theta-role-expectation-design)
                                                                           (conj phrase)
                                                                           (cp current-position))
    (needs-role? d)
    (conjunction? conj)
    (current-word? conj cp)
    (*no ((~tre theta-role-expectation))
      (equal (receiver ~tre) (receiver d))
      (equal (number ~tre) (number d)))
-->
    (spew t (theta-role-expectation :role (role d)
                                    :receiver (receiver d)
                                    :number (number d))
            (* *weight* *spew-rate*))
)

(defun foobar? (d)
  (and (receiver d)
       (typep (receiver d) 'phrase-mi)
       (noun? (receiver d))))

(p@ (structure rh-structure) activate-receives-expectation-at-vp ((d theta-role-expectation-design)
                                                                  (cl clause)
                                                                  (vp phrase)
                                                                  (cp current-position))
    (needs-role? d)
    (vp? vp)
    (current-word? vp cp)
    (equal (number d) (number cl))
    (by cl)
    (equal (by cl) vp)

    ;;^^ symmetrical hack to one in restructure-incomplete-clause-
    ;;^^ theta-role-expectation.  this one ensures that this production
    ;;^^ fires only at the disambiguating (second, main-clause) verb of
    ;;^^ a reduced-relative sentence.
    ;;^^
    ;;^^ mysteriously, the former single test condition stopped working
    ;;^^ with the revision that changed the attribute names of expectations
    ;;^^ and theta-roles.  it used to be: 
    ;;^^      (not-equal (bar (receiver d)) 2)
    ;;^^ and there was no need to bind NP separately.  breaking this tes
    ;;^^ out into a separate predicate testing D alone didn't help.  i
    ;;^^ think this may reveal a flaw in the way 4CAPS compiles production
    ;;^^ LHSs.  the current fix stops the program from crashing, but
    ;;^^ leads to erroneous results for reduced relatives.
    (foobar? d)

    (*no ((~tre theta-role-expectation))
      (equal (receiver ~tre) (receiver d))
      (equal (number ~tre) (number d)))
-->
    (spew t (theta-role-expectation :role (role d)
                                    :receiver (receiver d)
                                    :number (number d))
            (* *weight* *spew-rate*))
)

;; Select between competing theta role expectations.
;;
;; When there are two theta-role-expectations for noun phrases to receive
;; theta-roles and there is a theta-role-expectation for a verb to assign
;; an agent role, the two receivers compete via lateral inhibition to see to
;; which it is assigned.  The competition stops when the difference in their
;; activation levels exceeds a threshold.  The selection process is
;; heavily parameterized.

(p@ (structure rh-structure) select-between-two-receivers ((cl clause)
                                                           (rtre1 theta-role-expectation)
                                                           (rtre2 theta-role-expectation)
                                                           (atre theta-role-expectation))
    (needs-role? rtre1)
    (needs-role? rtre2)
    (before? (head (receiver rtre1)) (head (receiver rtre2)))
    (agent? atre)
    (equals (number cl) (number rtre1) (number rtre2) (number atre))
    (active? cl)
    
    ;; elim?
    (*no ((~cl clause))
      (> (number ~cl) (number cl)))
    
    (*no ((~d theta-role-design))
      (agent? ~d)
      (equal (receiver ~d) (receiver rtre1)))
    (*no ((~tr theta-role))
      (agent? ~tr)
      (equal (receiver ~tr) (receiver rtre1)))
    (*no ((~d theta-role-design))
      (agent? ~d)
      (equal (receiver ~d) (receiver rtre2)))
    (*no ((~tr theta-role))
      (agent? ~tr)
      (equal (receiver ~tr) (receiver rtre2)))
    
    (*always (< (abs (- (act rtre1) (act rtre2))) *selection-threshold*))
-->
    ;; self-activation.
    (spew t rtre1 *selection-loser*)
    (spew t rtre2 *selection-winner*)

    ;; lateral inhibition.
    (spew t rtre1 (- *selection-winner*))
    (spew t rtre2 (- *selection-loser*))

)



;;;
;;; Reduced relative clauses.
;;;


;; Activate expectation constituents.

(p@ (structure rh-structure) activate-receives-expectation-during-ambiguity ((d theta-role-expectation-design)
                                                                             (vp1 phrase)
                                                                             (vp2 phrase)
                                                                             (cp current-position))
    (needs-role? d)
    (not-equal vp1 vp2)
    (vp? vp1)
    (vp? vp2)
    (past-participle? vp1)
    (past? vp2)
    (current-word? vp1 cp)
    (current-word? vp2 cp)
    (*no ((~tre theta-role-expectation))
      (equal (receiver ~tre) (receiver d))
      (equal (number ~tre) (number d)))
-->
    (spew t (theta-role-expectation :role (role d)
                                    :receiver (receiver d)
                                    :number (number d))
            (* *weight* *spew-rate*))
)


;; Restructure when an ambiguous sentence is disambiguated to the reduced-relative interpretation.

(p@ (associate rh-associate) restructure-clause-incomplete-theta-role-expectation ((cl clause)
                                                                                   (tre theta-role-expectation)
                                                                                   (vp phrase)
                                                                                   (cp current-position)
                                                                                   (tr theta-role))
    (vp? vp)
    (current-word? vp cp)
    (by cl)
    (not-equal (by cl) vp)
    (equals (number cl) (number tre) (number tr))
    (before? (receiver tr) (by cl))
    (*no ((~d clause-design))
      (equal (number ~d) (number cl)))
-->
    (spew t (theta-role-expectation-design :role 'needs-role

                                           ;;^^ cheat.  now that we want the unselected interpretation
                                           ;;^^ of an ambiguous sentence to linger, to be disambiguated
                                           ;;^^ at question-answer time, we need to ensure the incorrect
                                           ;;^^ assignment of a main-clause theta-role role to the first
                                           ;;^^ np of the sentence does not shadow/block the generation
                                           ;;^^ of the correct assignment, so we make the correct
                                           ;;^^ assignment trivially different -- the for* is the head
                                           ;;^^ of the np as opposed to the np itself.  (sv 02.28.2000)
                                           :receiver (head (receiver tr))
                                           
                                           :number (number tr))
            (* *weight* *spew-rate*)))


;; Suppress clauses and other representations when an ambiguous sentence is
;; disambiguated to...


; ...the main-verb interpretation.

(p@ (structure rh-structure) suppress-clause-prematurely-complete ((cl1 clause)
                                                                   (cl2 clause)
                                                                   (prep phrase)
                                                                   (cp current-position))
    (by cl1)
    ; (for* cl1)
    (null (by cl2))
    (null (for* cl2))
    (equal (number cl1) (number cl2))
    (preposition? prep)
    (current-word? prep cp)
    (*no ((~tre theta-role-expectation))
      (thematic-role? ~tre)
      (equal (number ~tre) (number cl1)))
    (*no ((~d clause-design))
      (equal (number ~d) (number cl1)))
    (*no ((~d theta-role-expectation-design))
      (equal (number ~d) (number cl1)))
-->
    (spew t cl1 (- (* *weight* *spew-rate*)))
    (spew t cl2 (- (* *weight* *spew-rate*)))
)


; ...the reduced-relative interpretation.

(p@ (structure rh-structure) suppress-clause-incomplete ((cl clause)
                                                         (tre theta-role-expectation)
                                                         (vp phrase)
                                                         (cp current-position))
    (vp? vp)
    (current-word? vp cp)
    (by cl)
    (not-equal (by cl) vp)
    (equal (number cl) (number tre))
    (*no ((~d clause-design))
      (equal (number ~d) (number cl)))
-->
    (spew t cl (- (* *weight* *spew-rate*)))
)


;; Suppress unselected theta role constituents.
;;
;; After processing a sentence, a number of theta roles will be active.
;; If the sentence was ambiguous, these theta roles may be inconsistent
;; with one another.  The selected one must be associated and the unselected
;; ones suppressed.  This is done by mutual excitation by related and/or
;; complementary thematic roles and lateral inhibition of inconsistent ones.

(p@ (structure rh-structure) same-head-same-number ((tr1 theta-role)
                                                    (tr2 theta-role)
                                                    (p percept)
                                                    (cp current-position))
    (< (id tr1) (id tr2))
    (equal (assigner tr1) (assigner tr2))
    (equal (number tr1) (number tr2))
    (punctuation? p)
    (current-word? p cp)
-->
    (spew t tr1 *integration-weight*)
    (spew t tr2 *integration-weight*)
)

(p@ (structure rh-structure) same-head-diff-number ((tr1 theta-role)
                                                    (tr2 theta-role)
                                                    (p percept)
                                                    (cp current-position))
    (< (id tr1) (id tr2))
    (equal (receiver tr1) (receiver tr2))
    (equal (ortho (assigner tr1)) (ortho (assigner tr2)))
    (not-equal (number tr1) (number tr2))
    (punctuation? p)
    (current-word? p cp)
-->
    (spew t tr1 (* 2 (- *integration-weight*)))
    (spew t tr2 (* 2 (- *integration-weight*)))
)

(p@ (structure rh-structure) diff-head-same-number ((tr1 theta-role)
                                                    (tr2 theta-role)
                                                    (p percept)
                                                    (cp current-position))
    (< (id tr1) (id tr2))
    (equal (ortho (receiver tr1)) (ortho (receiver tr2)))
    (not-equal (ortho (assigner tr1)) (ortho (assigner tr2)))
    (equal (number tr1) (number tr2))
    (punctuation? p)
    (current-word? p cp)
-->
    (spew t tr1 (* 2 (- *integration-weight*)))
    (spew t tr2 (* 2 (- *integration-weight*)))
)

;;; Hacky way of stopping consolidation of the thematic representation.
;;; Need to add an explicit HALT command to 4CAPS.
(p@ (structure rh-structure) stop-integration ((p percept)
                                               (cp current-position))
    (punctuation? p)
    (current-word? p cp)
    (*no ((~tr theta-role))
      (< (act ~tr) 0.99))
    (*no ((~tr1 theta-role) (~tr2 theta-role))
      (< (id ~tr1) (id ~tr2))
      (equal (receiver ~tr1) (receiver ~tr2))
      (equal (ortho (assigner ~tr1)) (ortho (assigner ~tr2)))
      (not-equal (number ~tr1) (number ~tr2)))
    (*no ((~tr1 theta-role) (~tr2 theta-role))
      (< (id ~tr1) (id ~tr2))
      (equal (ortho (receiver ~tr1)) (ortho (receiver ~tr2)))
      (not-equal (ortho (assigner ~tr1)) (ortho (assigner ~tr2)))
      (equal (number ~tr1) (number ~tr2)))
-->
    (spew p p -1.0)
)




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Support Code.
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;
;;;
;;;


;;

(defun print-model-gap ()
  (format t "~&~2%"))

(defun print-model-separator ()
  (format t "~&################################################################################")
  (format t "~&################################################################################"))



;;;
;;; pretty-print dm.
;;;


;; top-level commands to pretty-print the contents of declarative memory as
;; less-verbose "trees."

;;; (trees [dm-classes])
(defmacro trees (&rest class-filter-list)
  `(impl-trees ',class-filter-list))

(defun impl-trees (class-filter-list)
  (format t "~&TREES")
  (when class-filter-list
    (format t " filtered by~{ ~A~}" class-filter-list))
  (format t ":~%")
  (dolist (dme (dme-list class-filter-list))
    (pprint (tree dme))
    (format t ": ~,2F" (act dme)))
  (values))

;;; (trees@ center-name [dm-classes])
(defmacro trees@ (center-name &rest class-filter-list)
  `(impl-trees@ ',center-name ',class-filter-list))

(defun impl-trees@ (center-name-or-list class-filter-list)
  (when (symbolp center-name-or-list)
    (setq center-name-or-list (list center-name-or-list)))
  (format t "~&TREES")
  (when class-filter-list
    (format t " ~{~A ~}filtered by~{ ~A~}" center-name-or-list class-filter-list))
  (format t ":~%")
  (dolist (dme (dme-list class-filter-list))
    (when (some #'(lambda (center-name)
                    (center-dme-spec (get-center center-name) dme))
                center-name-or-list)
      (pprint (tree dme))
      (format t ": ~,2F" (act dme))))
  (values))


;; methods for each dm-class that return its succint, "tree" rendering.

(defmethod tree ((self base-dme))
  `(,(class-name (class-of self))))

(defmethod tree ((self current-position))
  `(current-position ,(pos self)))

(defmethod tree ((self percept))
  `(percept ,(ortho self)))

(defmethod tree ((self lexical))
  `(,(class-name (class-of self))
    ,(ortho (percept self))))

(defmethod tree ((self phrase))
  `(,(intern (format nil "~A~A" (cat self) (bar self)))
    ,@(when (spec self)
       (list (tree (spec self))))
    ,@(when (att self)
       (list (tree (att self))))
    ,(tree (head self))
    ,@(when (comp self)
       (list (tree (comp self))))))

(defmethod tree ((self clause))
  `(clause ,(number self)
           ,@(when (tense self)
               (list (tense self)))
           ,@(when (voice self)
               (list (voice self)))))

(defmethod tree ((self theta-role))
  `(,(class-name (class-of self))
    ,(number self)
    ,(ortho (receiver self))
    ,(role self)))

(defmethod tree ((self theta-role-expectation))
  `(,(class-name (class-of self))
    ,(number self)
    ,(role self)))

(defmethod tree ((self lexical-design))
  `(,(class-name (class-of self))
    ,(ortho (percept self))))

(defmethod tree ((self phrase-design))
  `(,(class-name (class-of self))
    ,(intern (format nil "~A~A" (cat self) (bar self)))))

(defmethod tree ((self clause-design))
  `(clause-design ,(number self)
                  ,@(when (tense self)
                      (list (tense self)))
                  ,@(when (voice self)
                      (list (voice self)))))

(defmethod tree ((self theta-role-design))
  `(,(class-name (class-of self))
    ,(number self)
    ,(role self)))

(defmethod tree ((self theta-role-expectation-design))
  `(,(class-name (class-of self))
    ,(number self)
    ,(role self)))



;;;
;;; run simulations.
;;;


;; top-level command to reset the model and simulate comprehension of a sentence.

;;; (sim {word}*)
(defmacro sim (&rest sent)
  `(impl-sim ',sent))

(defun impl-sim (sent)
  (reset)
  (format t "~&SENTENCE:~{ ~A~}" sent)
  (unless (or (tracing-p) (tracing-dm-p))
    (format t "~%WORD~ADELTA~ATOTAL" #\tab #\tab))
  (spew t (clause :number 1) *weight*)
  (impl-sim-helper sent))


;; top-level command to simulate comprehension of a question.  assumes that a sentence has
;; just been comprehended, and thus (1) does not reset the system and (2) chooses a clause
;; number that will not interfere with the representations still in declarative memory. 

;;; (qsim {word}*)
(defmacro qsim (&rest sent)
  `(impl-qsim ',sent))

(defun impl-qsim (sent)
  (format t "~&QUESTION:~{ ~A~}" sent)
  (unless (or (tracing-p) (tracing-dm-p))
    (format t "~%WORD~ADELTA~ATOTAL" #\tab #\tab))
  (spew t (clause :number 10) *weight*)
  (impl-sim-helper sent))


;; helper function for simulations.

(defun impl-sim-helper (sent)
  (let ((pos 0))
    (dolist (words sent)
      (when (symbolp words)
        (setq words (list words)))
      (dolist (word words)
        (when (or (tracing-p) (tracing-dm-p))
          (print-model-gap)
          (print-model-separator)
          (format t "~%                                WORD ~A: ~A" (1+ pos) word)
          (print-model-separator))
        (spew t (percept :ortho word
                         :start pos
                         :end (1+ pos))
              *weight*)
        (let ((cur-pos-dme (first (dme-list '(current-position)))))
          (if cur-pos-dme
            (modify cur-pos-dme :pos (1+ pos))
            (spew t (current-position :pos (1+ pos)) *weight*)))
        (run 25)
        (incf pos))
      (let ((segment-name (intern (format nil "~A~{-~A~}" (first words) (rest words)))))
        (end-segment segment-name)
        (unless (or (tracing-p) (tracing-dm-p))
          (let ((segment (first *segment-history*)))
            (format t "~%~A~A~A~A~A" (shorten segment-name)
                    #\tab (1+ (- (third segment) (second segment)))
                    #\tab *cycles*))))))
  (unless (or (tracing-p) (tracing-dm-p))
    (format t "~&~A:~A~A~A~A" (shorten 'total)
            #\tab *cycles*
            #\tab *cycles*))
  (values))


;; top-level command that prints summary information about a completed simulation.

;;; (summ)
(defun summ ()
  (format t "~&")
  (format t "~%")
  (trees theta-role)
  (format t "~%")
  (history@ (associate structure rh-associate rh-structure)
            :combination avg
            :measure prop)
  (format t "~%")
  (history@ (associate structure rh-associate rh-structure)
            :combination avg
            :measure prop
            :time segment)
  (format t "~%")
  (values))



;;;
;;;
;;;


; settings suitable for simulating the Science results (just, carpenter,
; keller, eddy, & thulborn, 1996).

#|
;;; in general, there is a rise with syntactic complexity in the CUs of the
;;; associate, structure, rh-associate, and rh-structure centers.
;;;
;;; constraints: (1) CU(associate) is slightly less than CU(structure) for
;;;                  conjoined actives, about equal for subject relatives,
;;;                  and slightly less than for object relatives.
;;;              (2) CU(associate) / 3.4 = CU(rh-associate)  (on OR sentence)
;;;              (3) CU(structure) / 4.5 = CU(rh-structure)  (on OR sentence)
(set-caps@ associate 15.0)
(set-caps@ rh-associate 10.0)
(set-caps@ structure 18.0)
(set-caps@ rh-structure 10.0)
|#


; settings suitable for simulating the syntactic ambiguity results (mason,
; just, keller, & carpenter, under review).

#|
;;; for producing gamma-transformed proportional CUs that mimic event-related
;;; fmri results.
(set-caps@ associate 83.0)
(set-caps@ rh-associate 100.0)
(set-caps@ structure 111.0)
(set-caps@ rh-structure 100.0)
|#


; settings suitable for simulating the Stroke results (thulborn, just,
; & carpenter, 1999).

#|
(set-caps@ associate 27.0)
(set-caps@ rh-associate 27.0)
(set-caps@ structure 34.0)
(set-caps@ rh-structure 45.0)

(set-caps@ structure 0.0)
|#

#|
(set-caps@ associate 9.5)
(set-caps@ rh-associate 9.5)
(set-caps@ structure 10.0)
(set-caps@ rh-structure 22.0)

(set-caps@ structure 0.0)
|#



;;;
;;; top-level commands that facilitate running simulations of all of the sentential stimuli of
;;; particular studies:
;;;


;; old behavioral studies.

;;; top-level command to simulate the "caplan" sentences.
;;;
;;; (haarmann1997 [t | nil])
(defun haarmann1997 (&optional (summ-p t))
  (format t "ACTIVE")
  (sim the senator attacked the (reporter period))
  (when summ-p
    (summ))
  (format t "~2%PASSIVE")
  (sim the senator was attacked by the (reporter period))
  (when summ-p
    (summ))
  (format t "~2%DATIVE")
  (sim the senator gave an interview to the (reporter period))
  (when summ-p
    (summ))
  (format t "~2%PASSIVE DATIVE")
  (sim the interview was given to the reporter by the (senator period))
  (when summ-p
    (summ))
  (format t "~2%CLEFT-SUBJECT")
  (sim it was the senator that attacked the (reporter period))
  (when summ-p
    (summ))
  (format t "~2%CLEFT-OBJECT")
  (sim it was the senator that the reporter (attacked period))
  (when summ-p
    (summ))
  (format t "~2%RIGHT-BRANCHING SUBJECT-RELATIVE")
  (sim the senator attacked the reporter that admitted the (error period))
  (when summ-p
    (summ))
  (format t "~2%RIGHT-BRANCHING OBJECT-RELATIVE")
  (sim the senator attacked the reporter that the editor (fingered period))
  (when summ-p
    (summ))
  (format t "~2%")
  (just1996 summ-p))

;;; top-level command to simulate the king & just (1991) sentences.
;;;
;;; king1991 [t | nil])
(defun king1991 (&optional (summ-p t))
  (format t "SUBJECT-RELATIVE")
  (sim the (senator that attacked the) reporter admitted (the error period))
  (when summ-p
    (summ))
  (format t "~2%OBJECT-RELATIVE")
  (sim the (senator that the reporter) attacked admitted (the error period))
  (when summ-p
    (summ))
  (values))

;;; top-level command to simulate the macdonald, just, & carpenter (1992) sentences.
;;;
;;; (macdonald1992 [t | nil])
(defun macdonald1992 (&optional (summ-p t))
  (format t "UNAMBIGUOUS PREFERRED")
  (sim (the experienced soldiers) (spoke about the dangers) (before the midnight) (raid period))
  (when summ-p
    (summ))
  (format t "~2%UNAMBIGUOUS UNPREFERRED")
  (sim (the experienced soldiers who were) (told about the dangers) (conducted the midnight) (raid period))
  (when summ-p
    (terpri)
    (summ))
  (format t "~2%AMBIGUOUS PREFERRED")
  (sim (the experienced soldiers) (warned about the dangers) (before the midnight) (raid period))
  (when summ-p
    (terpri)
    (summ))
  (format t "~2%AMBIGUOUS UNPREFERRED")
  (sim (the experienced soldiers) (warned about the dangers) (conducted the midnight) (raid period))
  (when summ-p
    (terpri)
    (summ))
  (values))


;; new fmri studies.

;;; top-level command to simulate the just, carpenter, keller, eddy, & thulborn (1996)
;;; sentences.
;;;
;;; (just1996 [t | nil])
(defun just1996 (&optional (summ-p t))
  (format t "CONJOINED ACTIVES")
  (sim the senator attacked the reporter and admitted the (error period))
  (when summ-p
    (summ))
  (format t "~2%SUBJECT-RELATIVE")
  (sim the senator that attacked the reporter admitted the (error period))
  (when summ-p
    (summ))
  (format t "~2%OBJECT-RELATIVE")
  (sim the senator that the reporter attacked admitted the (error period))
  (when summ-p
    (summ))
  (values))

(defun thulborn1999 (&optional (summ-p t))
  (format t "SIMPLE ACTIVE")
  (sim the senator attacked the (reporter period))
  (when summ-p
    (summ))
  (format t "~2%SIMPLE PASSIVE")
  (sim the senator was attacked by the (reporter period))
  (when summ-p
    (summ))
  (values))

;;; top-level command to simulate the fmri activations found across entire trials (i.e.,
;;; both the sentence comprehension and question answering phases as well as the intervening
;;; fixation intervals) of the mason, just, keller, & carpenter (submitted) study.
;;;
;;; note that the *gamma-conversion* parameter takes on a value of 13 macrocycles of model
;;; time per second of behavioral time.  this was estimated by dividing the macrocycles
;;; required to process the unpreferred ambiguous sentence by the corresponding behavioral rt.
;;;
;;; note that the intervals parameter is 16, as in the experiment.
;;;
;;; (mason2003 [t | nil])
(defun mason2003 (&optional (question-p t))
  (flet ((the-rest ()
           (when question-p
             (run-to (* 10 *gamma-conversion*))
             (end-segment 'fix12003)
             (unless (or (tracing-p) (tracing-dm-p))
               (let ((segment (first *segment-history*)))
                 (format t "~%F1:~A~A" #\tab (1+ (- (third segment) (second segment))))))
             (mapc #'(lambda (dme)
                       (make-spew dme (- (act dme))))
                   (dme-list '(clause percept)))
             (format t "~%")
             (qsim the soldiers conducted the (raid period)))
           (mapc #'(lambda (dme)
                     (make-spew dme (- (act dme))))
                 (dme-list))
           (run-to (* 26 *gamma-conversion*))
           (end-segment 'fix2)
           (unless (or (tracing-p) (tracing-dm-p))
             (let ((segment (first *segment-history*)))
               (format t "~%F2:~A~A" #\tab (1+ (- (third segment) (second segment))))))
           (fmri-history)
           (format t "~&~%associate INTERVALIZED CU:")
           (format t "~{ ~,6F~}" (coerce (intervalize (cu-array (get-center 'associate)) 16) 'list))
           (format t "~&~%structure INTERVALIZED CU:")
           (format t "~{ ~,6F~}" (coerce (intervalize (cu-array (get-center 'structure)) 16) 'list))
           (summ)))
    (format t "~&UNAMBIGUOUS PREFERRED")
    (sim the experienced soldiers spoke about the dangers before the midnight (raid period))
    (the-rest)
    (format t "~2%UNAMBIGUOUS UNPREFERRED")
    (sim the experienced soldiers who were told about the dangers conducted the midnight (raid period))
    (the-rest)
    (format t "~2%AMBIGUOUS PREFERRED")
    (sim the experienced soldiers warned about the dangers before the midnight (raid period))
    (the-rest)
    (format t "~2%AMBIGUOUS UNPREFERRED")
    (sim the experienced soldiers warned about the dangers conducted the midnight (raid period))
    (the-rest))
  (values))

;;; Top-level command to simulate the fMRI activations found across entire trials  of the 
;;; Caplan et al. (2001) study.  Note that the *gamma-conversion* parameter takes on a value
;;; of 17.43 macrocycles of model time per second of behavioral time.  This was estimated by
;;; dividing the macrocycles required to process the center-embedded object-relative (122)
;;; by the corresponding behavioral time allowed by RSVP (0.5 s per word, or 7 s total).
;;;
;;; Note that the intervals parameter is 8, as in the experiment.  This is because there was
;;; initially 1 s of blank screen, 7 s of sentence presentations, and 10 s of blank screen
;;; (during which an unmodelled plausibility judgment was made by participants).
;;;
;;; (caplan2001 [t | nil])
(defun caplan2001 ()
  (let* ((*gamma-conversion* 17.43)
         (*intervals* 12))
    (labels ((print-last-segment ()
               (unless (or (tracing-p) (tracing-dm-p))
                 (let ((segment (first *segment-history*)))
                   (format t "~%~A:~A~A~A~A" (first segment)
                                             #\tab (1+ (- (third segment) (second segment)))
                                             #\tab *cycles*))))
             (begin-trial ()
               (reset)
               (unless (or (tracing-p) (tracing-dm-p))
                 (format t "~%WORD~ADELTA~ATOTAL" #\tab #\tab))
               (run-to (round (* 4 *gamma-conversion*)))
               (end-segment 'pre)
               (print-last-segment)
               (run-to (round (* 4.5 *gamma-conversion*)))
               (end-segment 'fix)
               (print-last-segment)
               (run-to (round (* 5 *gamma-conversion*)))
               (end-segment 'blank1)
               (print-last-segment)
               (spew t (clause :number 1) *weight*))
             (end-trial ()
               (mapc #'(lambda (dme)
                         (make-spew dme (- (act dme))))
                     (dme-list))
               (run-to (round (* 22 *gamma-conversion*)))
               (end-segment 'blank2)
               (print-last-segment)
               (format t "~&~%ASSOCIATE PREDICTED ACTIVATION TIME SERIES:")
               (format t "~{~%~,6F~}" (coerce (intervalize (fmri (intervalize (cu-array (get-center 'associate)) 22)) *intervals*)
                                              'list))
#|
               (format t "~&~%STRUCTURE PREDICTED ACTIVATION TIME SERIES:")
               (format t "~{~%~,6F~}" (coerce (intervalize (fmri (intervalize (cu-array (get-center 'structure)) 22)) *intervals*)
                                              'list))
|#
               ))
      (format t "~&CENTER-EMBEDDED OBJECT-RELATIVE")
      (begin-trial)
      (impl-sim-helper '(the senator carefully covering the big story who the reporter attacked admitted the (error period)))
      (end-trial)
      (format t "~2%CENTER-EMBEDDED SUBJECT-RELATIVE")
      (begin-trial)
      (impl-sim-helper '(the senator carefully covering the big story who attacked the reporter admitted the (error period)))
      (end-trial)))
  (values))


;;

;;; top-level command to simulate all sentences from new fmri studies.
;;;
;;; (all [t | nil])
(defun all (&optional (summ-p t))
  (haarmann1997 summ-p)
  (format t "~2%")
  (macdonald1992 summ-p)
  (format t "~2%")
  (mason2003))