(in-package "PENMAN")

;;; Inquiry implementations. Mostly drawn from the inquiry implementations
;;; accompanying the Penman91 release of Nigel. Extensions and changes 
;;; include those necessary for the merged upper model and the inquiries
;;; necessary for controlling morphological systems. 
;;;
;;; Current inquiry implementations are used by both English and Dutch.
;;;
;;; General cleaning up has been begun.
;;;
;;; Last Update:
;;; 12.11.96: John: cardinal number inqcodes have been patched.
;;; May, 99: John: comparative-related inqcodes patched.
;;;            These inquiry implmeentations were in general not prepared
;;;            for complex properties coming through.
;;; Feb, 02: some random extensions for logical conditions

(defun Ability-Q-Code (modal-property process participant)
  "See if the MODAL-PROPERTY is one of ABILITY."
  (declare (ignore process participant))
  (if (term-type-p modal-property 'ability) 'ability 'nonability))

(defun Above-Ten-Type-Q-Code (number)
  "Give back NUMBER, spelled."
  (case number
    (11 'eleven)
    (12 'twelve)
    (otherwise 'ten)))

(defun Above-Twenty-Q-Code (number)
  "Test magnitude of NUMBER."
  (if (< number 20) 'below 'above))

(defun Absolute-Extent-Q-Code (reln range)
  "Depends on type of RELN."
  (declare (ignore range))
  (if (term-type-p reln 'absolute-extent) 'absolute
      (if (term-type-p reln 'relative-extent) 'nonabsolute)))

(defun Abstraction-Q-Code (conjunctive)
  "If an RST-ELABORATION, then ABSTRACTION."
  (if (term-type-p conjunctive 'rst-elaboration) 'abstraction 'notabstraction))

(defun Accompaniment-ID-Code (process)
  "Return the accompaniment feature."
  (fetch-relation-spec process 'accompaniment 'Accompaniment-ID))

(defun Accompaniment-Mod-ID-Code (process)
  "Return the accompaniment feature as a reified relation."
  (fetch-relation-spec process 'accompaniment 'ACCOMPANIMENT-MOD-ID))

(defun Accompaniment-Modification-Q-Code (process)
  "Look for an accompaniment feature."
  (if (fetch-subc-feature 'accompaniment process) 'accompanying))

(defun Accompaniment-Q-Code (process)
  "Look for an accompaniment feature."
  (if (fetch-relation 'accompaniment process) 'accompaniment))

(defun Accompaniment-Relation-Q-Code (process)
  "Is it an accompaniment relation?"
  (if (term-type-p process 'accompaniment) 'accompaniment 'notaccompaniment))

(defun Actor-ID-Code (process)
  "Return the actor feature."
  (fetch-subc-feature 'actor process))

(defun Actualization-Constrainer-ID-Code (spec process)
  "Return some appropriate role."
  (declare (ignore spec)) ;;;Which arg do we really need?
  (or ; (fetch-subc-feature 'beneficiary   process) 
      (fetch-subc-feature 'domain    process)
      (fetch-subc-feature 'range     process)
      (fetch-subc-feature 'actor     process)
      (fetch-subc-feature 'actee     process)
      (fetch-subc-feature 'senser    process)
      (fetch-subc-feature 'sayer     process)
      (fetch-subc-feature 'saying    process)
      (fetch-subc-feature 'addressee process)))

(defun Actualization-Constrainer-Q-Code (spec process)
  "ACTUALIZATIONCONSTRAINER only if there's no theme."
  (declare (ignore spec))
  (if (fetch-feature 'theme process) 'nonactualizationconstrainer))

(defun Addition-Q-Code (reln range)
  "If RELN is of type ADDITIVE."
  (declare (ignore range))
  (if (term-type-p reln 'additive) 'addition 'nonaddition))

(defun Address-Q-Code (process)
  "If there is an ADDRESSEE feature, then ADDRESS."
  (if (fetch-subc-feature 'addressee process) 'address 'nonaddress))

(defun Addressee-ID-Code (process)
  "If there is an ADDRESSEE feature, then ADDRESS."
  (fetch-subc-feature 'addressee process))

(defun Addressee-Oriented-Q-Code (process)
  "If the process type is Addressee-Oriented-Verbal-Process, then ADDRESSEEORIENTED."
  (if (term-type-p process 'addressee-oriented-verbal-process) 
      'addresseeoriented 
      'notaddresseeoriented))

(defun AddressSpecificity-Q-Code (object)
  "If it's a  date, with month/day or month/year features, to position."
  (if (or (and (term-type-p object 'date)
	       (or (fetch-subc-feature 'day object)
		   (fetch-subc-feature 'month object))
	       (or (fetch-subc-feature 'month object)
		   (fetch-subc-feature 'year object)))
	  (and (term-type-p object 'zero-d-location)
	       (fetch-subc-feature 'latitude object)
	       (fetch-subc-feature 'longitude object)))
      'ToPosition 
      'ToRegion))

(defun Affected-ID-Code (process)
  "Return the actee of a DIRECTED-ACTION and actor of a NONDIRECTED-ACTION."
  (if (term-type-p process 'nondirected-action)
      (fetch-subc-feature 'actor process)
      (fetch-subc-feature 'actee process)))

(defun Age-Modification-Q-Code (object)
  "Look for an AGE feature."
  (if (fetch-subc-feature 'age-property-ascription object) 'age))

(defun Age-Modifier-ID-Code (object)
  "Return the AGE feature."
  (fetch-subc-feature 'age-property-ascription object))

;(defun Agent-Mention-Q-Code (actee)
;  "Look for inverse speaker, creator features."
;  (if (or (fetch-subc-feature 'inverse-creator actee)
;	  (fetch-subc-feature 'inverse-speaker actee)) 'mention))

;(defun Agent-Mention-Q-Code (process)
;  "Look for an ACTOR."
;  (if (fetch-subc-feature 'actor process) 'mention))

;  Patch: mick, to allow instrument to become subject
;  see also Causer-ID-Code, Know-Manner-Q-Code 
(defun Agent-Mention-Q-Code (process)
  "Look for an ACTOR."
  (if (or (fetch-subc-feature 'actor process)
	  (fetch-subc-feature 'instrumental process))  'mention))

(defun Agent-Qualifier-ID-Code (activity)
  "Return the ACTOR."
  (fetch-subc-feature 'actor activity))

(defun Agentive-Q-Code (manner process)
  "Is MANNER an AGENTIVE?"
  (declare (ignore process))
  (if (term-type-p manner 'agentive) 'agentive))

(defun Alternative-Q-Code (reln range)
  "If RELN is of type ALTERNATIVE."
  (declare (ignore range))
  (if (term-type-p reln 'alternative) 'alternative 'nonalternative))

(defun Ambient-Q-Code (process)

  (if (term-type-p process 'ambient-process) 'ambient))

(defun Amount-Attention-Q-Code (object)
  "Who knows?"
  (if (not
	(or (eq (fetch-feature 'determiner object) 'all)
	    (eq (fetch-feature 'determiner object) 'the)
	    (eq (fetch-feature 'determiner object) 'nodet)) )
      'minimalattention))

(defun Answer-Q-Code (speech-act)
  "Is the type of the speech-act term ANSWER?"
  (if (term-type-p speech-act 'answer) 'answer 'nonanswer))

(defun Anterior-Q-Code (temporal-relation)
  "Is TEMPORAL-RELATION anterior?"
  (if (term-type-p temporal-relation 'Anterior) 'anterior 'notanterior))

(defun Anteriority-Q-Code (temporal-relation)
  "We are not sure what it means for anteriority to be specifed, (for a nonanterior relation)."
  (if (term-type-p temporal-relation 'anterior) 'anteriority 'noanteriority))

(defun Ascription-Q-Code (reln)
  "We just look to see if the variable--a relation--is an ascription."
  (if (term-type-p reln 'ascription) 'ascription 'notascription))

#+ignore
(defun Attribuend-ID-Code (reln)
  "Return the PROPERTY-ASCRIPTION feature, or look for the DOMAIN feature of the parent term."
  (if (fetch-minimal-relation 'property-ascription reln)
      (fetch-subc-feature 'domain (fetch-minimal-relation 'property-ascription reln))
      (if (and (not (term-type-p reln 'quality))
	       (not (fetch-subc-feature 'range reln)))
	  (fetch-subc-feature 'domain reln)
	  (or (fetch-subc-feature 'domain (term-graph-parent (symbol-value reln)))
	      (term-graph-parent (symbol-value reln))))))

(defun Attribuend-ID-Code (property)
  "Previously  Dimension-ID code - but works better for Attribuend-id: give the relation of which PROPERTY is the range."
  (or (when (or (term-type-p property 'quality)
		(term-type-p property 'quantity)
		(term-type-p property 'object)) 
	(term-graph-parent (symbol-value property)))
      (when (term-type-p property 'property-ascription)
	(fetch-subc-feature 'domain property))
      ;; 2.1 shouldn't just fail...
      property))

(defun Attribuend-Qualification-Q-Code (obj)
  "Look for any PROPERTY-ASCRIPTION feature, making sure you only pick out RANGEs."
  (if (or 
	(and (fetch-minimal-relation 'property-ascription obj)
	     (fetch-subc-feature 'range 
				 (fetch-minimal-relation 'property-ascription obj))
	     (eq (term-graph-symbol 
		   (symbol-value 
		     (fetch-subc-feature 'range 
					 (fetch-minimal-relation 'property-ascription obj))))
		 (term-graph-symbol (symbol-value obj))))
	(and ;(not (pledged-p obj))
	     (term-type-p obj 'two-place-relation)
	     (fetch-subc-feature 'domain obj)
	     (not (fetch-subc-feature 'range obj))))
      'attribuendqualification))

(defun Attribute-ID-Code (reln)
  "Find the RANGE feature."
  (or (fetch-subc-feature 'range reln)
      reln))

(defun Axis-Of-Orientation-Q-Code (reln range)
  "Use the type of RELN."
  (declare (ignore range))
  (if (term-type-p reln 'horizontal) 'horizontal
      (if (term-type-p reln 'vertical) 'vertical)))

(defun Behalf-Q-Code (relation)
  "Is the relation a CLIENT?"
  (if (term-type-p relation 'client) 'behalf 'nonbehalf))

(defun Behalf-ID-Code (process)
  "Return the CLIENT feature."
  (fetch-relation-spec process 'client 'Behalf-ID))

(defun Below-Hundred-Q-Code (number)
  "Just test magnitude of NUMBER."
  (if (> number 99) 'notbelowhundred 'belowhundred))

(defun Below-Ten-Q-Code (number)
  "Just test magnitude of NUMBER."
  (if (> number 9) 'notbelowten 'belowten))

; john patch 20/5/96 - did not have zero...
(defun BelowTen-Type-Q-Code (item)
  "Just give back ITEM, spelled out."    
    (Case item
	  (0 'zero)
	  (1 'one)
	  (2 'two)
	  (3 'three)
	  (4 'four)
	  (5 'five)
	  (6 'six)
	  (7 'seven)
	  (8 'eight)
	  (otherwise 'nine)))

(defun Beneficiary-ID-Code (process)
  "Return the beneficiary or recipient."
  (or (fetch-feature 'beneficiary process)
      (fetch-feature 'recipient   process)))

(defun Between-Q-Code (reln range)
  "Look for a between feature."
  (declare (ignore range))
  (if (term-type-p reln 'between ) 'between 'notbetween))

(defun Body-Of-Water-Q-Code (object)
  "Is it an ocean?"
  (if (term-type-p object 'ocean) 'bodyofwater 'notbodyofwater))

(defun Cardinal-Complexity-Q-Code (number)
  "If number is less than 20, or a multiple of ten, it's expressed by a single position."
  (if (or (< number 20)
	  (and (< number 100)
	       (eql 0 (rem number 10)))
	  (and (not (< number 100)) 
	       (< number 1000)
	       (eql 0 (rem number 100)))
	  (and (not (<= number 1000))  ;; changed for 1000 
	       (< number 10000)
	       (eql 0 (rem number 1000)))
	  (and (not (< number 10000))
	       (> number 999999)
	       (eql 0 (rem number 1000000))))
      'singleposition
      'multiplepositions))

(defun Carrier-ID-Code (reln)
  "Find the DOMAIN feature."
  (fetch-subc-feature 'domain reln))

(defun Causal-Relation-Q-Code (process)
  "Is it a causal relation?"
  (if (term-type-p process 'causal-relation) 'causalrelation 'notcausalrelation))

(defun Causation-And-Behalf-Q-Code (process)
  "Look for a client feature."
  (if (fetch-subc-feature 'client process) 'behalf))

(defun Causation-And-Concession-Q-Code (process)
  "Look for a CONCESSIVE feature."
  (if (fetch-subc-feature 'concessive process) 'concession))

(defun Causation-And-Purpose-Q-Code (process)
  "Look for a PURPOSE feature."
  (if (fetch-subc-feature 'purpose process) 'purpose))

(defun Causation-And-Reason-Q-Code (process)
  "Look for a REASON feature."
  (if (fetch-subc-feature 'reason process) 'reason))

(defun Causation-Q-Code (process)
  "Look for a causation feature, or for a beneficiary."
  (if (and (fetch-subc-feature 'causal-relation process)
	   (not (pledged-p (fetch-subc-feature 'causal-relation process))))
      'cause))

(defun Causative-Mention-Q-Code (causer activity)
  "WITHHOLD only if causer is unknown."
  (declare (ignore activity))
  (if (eq causer '?actor) 'withhold))

(defun Cause-Condition-Q-Code (part1 part2)
  "See if the parent is a CAUSE."
  (declare (ignore part2)) 
  (if (term-type-p (term-graph-parent (symbol-value part1)) 'cause-effect)
      'causecondition 
      'noncausecondition))

(defun Cause-ID-Code (process)
  "Return the causation feature."
  (or (fetch-relation-spec process 'causal-relation 'Cause-ID)
      (fetch-relation-spec process 'beneficiary 'Cause-ID)))

(defun Caused-Process-Q-Code (process)
  "Is the action directed?  If not, is it a mental activity?"
   (if (or (term-type-p process 'directed-action)
	   (term-type-p process 'mental-active)) 'caused 'independent))

;(defun Causer-ID-Code (process)
;  "Return the actor."
;  (or (fetch-subc-feature 'actor process)
;      (if (term-type-p process 'mental-active)
;	  (fetch-subc-feature 'senser process))))

;  mick patch 11/15/90 - allow instrument to become agent
;  See also Agent-Mention-Q-Code, Know-Manner-Q-Code
(defun Causer-ID-Code (process)
  "Return the actor."
  (or (fetch-subc-feature 'actor process)
      (if (term-type-p process 'mental-active)
	  (fetch-subc-feature 'senser process))
      (fetch-subc-feature 'instrumental process)))

; john patch 20/5/96 - was unprepared for numbers...
(defun Circumstance-Q-Code (arg)
  "Is its type circumstantial?"
  (cond ((numberp arg)
	 'notcircumstance)
	((or (term-type-p arg 'circumstantial)
	     (term-type-p (term-graph-parent (symbol-value arg)) 'circumstantial)
	     (when (term-graph-parent (symbol-value arg)) 
	       (term-role-p 
		(term-graph-parent (symbol-value arg)) arg 'circumstantial)))
	 'circumstance)
	(t 'notcircumstance)))

(defun Circumstantial-Domain-ID-Code (reln)
  "Return the DOMAIN feature."
  (fetch-subc-feature 'domain reln))

(defun Circumstantial-Q-Code (reln)
  "We just look to see if the variable--a relation--is a circumstantial relation."
  (if (term-type-p reln 'circumstantial) 'circumstantial 'noncircumstantial))

(defun Circumstantial-Range-ID-Code (reln)
  "Return the RANGE feature."
  (fetch-subc-feature 'range reln))

(defun Circumstantial-Relation-And-Range-ID-Code (reln)
  "Return the relation: its range comes with it."
  reln)

(defun Circumstantial-Relation-ID-Code (reln)
  "Just give the relation back."
  reln)

(defun Circumstantial-Theme-Q-Code (circumstance spec)
  "If CIRCUMSTANCE is a member of the THEME feature of spec, then CONTEXT."
  (if (fetch-feature 'theme spec) 
      (dolist (theme (term-graph-symbol (symbol-value (fetch-feature 'theme spec))))
	(if (or (term-eq-p circumstance theme)
		(term-eq-p (global-fetch-feature 'range theme) circumstance)
		(term-eq-p (fetch-subc-feature 'range circumstance) theme))
	    (return 'context)))))


;;; Was not prepared for complex ranges...
#+ignore
(defun Class-Q-Code (range)
  "If the argument is NOT a QUALITY, then return CLASS."
  (if (term-type-p range 'quality) 'nonclass 'class))

(defun Class-Q-Code (range)
  "If the argument is NOT a QUALITY, then return CLASS."
  (cond ((term-type-p range 'quality)
	 'nonclass)
	((and (term-type-p range 'um-set)
	      (loop for x in (term-graph-symbol (symbol-value range))
		  always (equal (class-q-code x) 'nonclass)))
	 'nonclass)
	(t 
	 'class)))

(defun Clause-As-Nominal-Q-Code (onus)
  "If it's a process....but not a relational-process(?)"
  (if (and (term-type-p onus 'process)
	   (not (term-type-p onus 'relational-process)) )
      'nominal-clause 
      'nonnominal-clause))

(defun Cliency-Q-Code (service )
  "look for a beneficiary--only works for CREATION."
  (if (fetch-feature 'beneficiary service) 'cliency))

(defun Client-ID-Code (service)
  "Return BENEFICIARY."
  (fetch-feature 'beneficiary service))

(defun Cognition-Q-Code (process)
  "If PROCESS is a COGNITION...."
  (if (term-type-p process 'cognition) 'cognition 'noncognition))

(defun Cognitive-Phenomenon-ID-Code (process)
  "Return the PHENOMENON feature."
   (fetch-subc-feature 'phenomenon process))

(defun Cognitive-Phenomenon-Q-Code (process) 
  "If there is a PHENOMENON feature...."
  (if (and (fetch-subc-feature 'phenomenon process)
	   (not (term-type-p (fetch-subc-feature 'phenomenon process) 'process)))
      'phenomenon))

(defun Colour-Modification-Q-Code (object)
  "Look for a COLOUR (COLOR) feature."
  (if (fetch-subc-feature 'color-property-ascription object) 'colour))

(defun Colour-Modifier-ID-Code (object)
  "Return the color feature."
  (fetch-subc-feature 'color-property-ascription object))

(defun Command-Offer-Q-Code (report)
  "If the type of the projector of REPORT is Non-Addressee-Oriented, then not command offer."
  (if (or (and (term-type-p (term-graph-parent (symbol-value report)) 'Mental-Process)
	       (not (term-type-p (term-graph-parent (symbol-value report)) 'reaction)))
	  (term-type-p (term-graph-parent (symbol-value report)) 'Non-Addressee-Oriented-Verbal-Process))
      'notcommandoffer
      'commandoffer))

(defun Command-Q-Code (speech-act)
  "Is the type of the speech-act term COMMAND?"
  (if (term-type-p speech-act 'command) 'command 'nocommand))

(defun Command-Responsible-ID-Code (speechact)
  "Pick up the HEARER feature, if any.  If not, value will default."
  (fetch-feature 'hearer speechact))

(defun COMPARISON-MODIFICATION-Q-CODE (quality dimension)
  (declare (ignore dimension))
  (if (fetch-relation 'intensify-adjective-q quality) 
      'modification))

(defun Comparison-Representative-ID-Code (concept)
  "A guess--depends on representation chosen.
   Here we return the RANGE of an expected IDENTITY involving CONCEPT as DOMAIN."
   (fetch-subc-feature 'range (term-graph-parent (symbol-value concept))))

(defun Complex-Thing-Part1-ID-Code (onus)
  "Pop the first member of the set, and use its id."
  (if (or (term-type-p onus 'conjunction)
	  (term-type-p onus 'disjunction))
      (fetch-feature 'domain onus)
      (if (symbolp (first (term-graph-symbol (symbol-value onus))))
      (first (term-graph-symbol (symbol-value onus)))
      (term-graph-id (first (term-graph-symbol (symbol-value onus)))))))

(defun Complex-Thing-Part2-ID-Code (onus)
  "Modify the spec:  the first elt is consumed.  If one only is left, give back its id."
  (if (or (term-type-p onus 'conjunction)
	  (term-type-p onus 'disjunction))
      (fetch-feature 'range onus)
      (if (< 2 (length (term-graph-symbol (symbol-value onus))))
	  (and (setf (term-graph-symbol (symbol-value onus)) 
		     (rest (term-graph-symbol (symbol-value onus))))
	       onus)
	  (if (symbolp (second (term-graph-symbol (symbol-value onus))))
	      (second (term-graph-symbol (symbol-value onus)))
	      (term-graph-id (second (term-graph-symbol (symbol-value onus)))))
	  )))

(defun ComplexCardinalDigit-Q-Code (number)
  "Is it less than 10?"
  (if (< number 10) 'simplex 'complex))

(defun Conceptual-Correlate-ID-Code (spec) spec)

;(defun Conceptual-Correlate-ID-Code (spec)
;  "Get the symbol of this term, unless it's a set."
;  (if (and (boundp spec) 
;	   (eq (type-of (symbol-value spec)) 'symbol))
;      (symbol-value spec)
;      (if (and (boundp spec)
;	       (not (term-type-p spec 'um-set))
;	       (eq (type-of (symbol-value spec)) 'term-graph))
;	  (term-graph-symbol (symbol-value spec))
;	  spec)))

(defun Concession-Q-Code (reln)
  "If the type of RELN is CONCESSIVE...."
  (if (term-type-p reln 'concessive) 'concession 'nonconcession))

(defun Concession-ID-Code (process)
  "Return the CONCESSION feature."
  (fetch-relation-spec process 'concession 'Concession-ID))

(defun Concessive-Condition-Q-Code (part1 part2)
  "See if the parent is a CONCESSIVE."
  (declare (ignore part2))
  (if (term-type-p (term-graph-parent (symbol-value part1)) 'rst-concessive)
      'concessive 
      'notconcessive))

(defun Concessive-Relation-Q-Code (reln)
  "If the type of RELN is CONCESSIVE...."
  (if (term-type-p reln 'concessive) 'concession 'notconcession))

(defun Conditional-Relation-Q-Code (reln)
  "If the type of RELN is LOGICAL....
  Or CONDITION...UM reln added 7/90" 
  (if (or (term-type-p reln 'logical)
	  (term-type-p reln 'condition))
      'condition 
      'notcondition))

(defun Conditioning-Q-Code (part1 part2)
  "Ask if the conjunctive relation governing the two parts is a conditioning relation."
  ;(declare (ignore part2)) 
  (if (and (or (term-type-p (term-graph-parent (symbol-value part1)) 'causal-relation)
	       (term-type-p (term-graph-parent (symbol-value part1)) 'logical-condition)   ;;; REUTERS
	       (term-type-p (term-graph-parent (symbol-value part1)) 'temporal-locating)   ;;; EX-SET-8
	       (term-type-p (term-graph-parent (symbol-value part1)) 'static-spatial)
	       (term-type-p (term-graph-parent (symbol-value part1)) 'generalized-means)   ;;; FINANCE DOMAIN
	       (term-eq-p part2 (fetch-subc-feature 'causal-relation part1))
	       (term-eq-p part2 (fetch-subc-feature 'temporal-locating part1))
	       (term-eq-p part2 (fetch-subc-feature 'static-spatial part1)))               ;;; EX-SET-13
	   (not (dolist (graph *plan-graphs*)
		  (if (and (consp (term-graph-symbol (symbol-value graph)))
			   (member part1 (term-graph-symbol (symbol-value graph)))
			   (or (term-type-p graph 'um-set)
			       (term-type-p graph 'disjunctive-set)))
		      (return t)))))
      'conditioning
      'nonconditioning))

(defun Conjunctive-Extension-Q-Code (initiating continuing)
  "If type of continuing is SET, or the pair are elements of a set, then conjunctive.
   Also, if INITIATING & CONTINUING are related by CONJUNCTION."
  (if (or (term-type-p continuing 'um-set)
	  (term-type-p initiating 'conjunction)
	  (dolist (graph *plan-graphs*)
	    (if (and (term-type-p graph 'um-set)
		     (not (term-type-p graph 'disjunctive-set)) ;; 2.0
		     (consp (term-graph-symbol (symbol-value graph)))
;		     (member initiating (term-graph-symbol (symbol-value graph)))
		     (member continuing (term-graph-symbol (symbol-value graph))))
		(return 't))
	    (if (and (term-type-p graph 'conjunction)
		     (term-eq-p initiating (fetch-subc-feature 'domain graph))
		     (term-eq-p continuing (fetch-subc-feature 'range graph)))
		(return 't))))
      'conjunctive 
      'nonconjunctive))

(defun Conjunctive-Relation-ID-Code (process)
  "Two cases:  when the conjunctive relation is a feature of the process, and when the 
   process is a feature (domain or range) of a rhetorical relation."
  (or (fetch-subc-feature 'rhetorical-relation process)
      (fetch-subc-feature-name 'circumstantial (term-graph-parent (symbol-value process)))
      (term-graph-parent (symbol-value process))))

(defun Conjunctive-Relation-Q-Code (process)
  "Is there a conjunctive relation feature?"
  (if (and (fetch-subc-feature 'rhetorical-relation process)
	   (not (term-role-p process 
			     (fetch-subc-feature 'rhetorical-relation process) 
			     'RST-Means)))
      'conjunctive))

(defun Consciousness-Q-Code (obj) 
  "Is it a conscious being?"
  (if (term-type-p obj 'conscious-being) 'conscious 'nonconscious))

; john - patch 6/99 was using contrastive which is not in the Upper Model, worked
;         because term-type-p used to accept anything: no longer.
(defun Contrastive-Q-Code (reln) 
  "Is RELN a CONTRASTIVE?"
  (if (term-type-p reln 'rst-contrastive) 'contrastive 'notcontrastive))

(defun Contrastive-Extension-Q-Code (initiating continuing)
  "If type of relation between initiating and continuing is RST-Contrastive"
  (declare (ignore initiating))
  (if (term-type-p (term-graph-parent (symbol-value continuing)) 'RST-Contrastive)
      'contrastive 
      'noncontrastive))

(defun Countability-Q-Code (thing)
  "COUNTABLE if not MASS."
  (if (term-type-p thing 'mass) 'mass 'countable))

(defun Current-Representative-ID-Code (obj) obj)

(defun Dependent-Beta-Theme-Q-Code (dependent spec)
  "CONTEXT, if there is a THEME feature in SPEC involving DEPENDENT."
  (if (fetch-feature 'theme spec) 
      (dolist (theme (term-graph-symbol (symbol-value (fetch-feature 'theme spec))))
	(if (term-eq-p dependent theme)
	    (return 'context)))))

(defun Destination-Process-Q-Code (locativerelation place)
  "Is the relation one of destination?"
  (declare (ignore place)) 
  (if (term-type-p locativerelation 'Destination)
      'destination
      'nondestination))

(defun Destination-Q-Code (reln process)
  "Is the relation a destination?"
  (declare (ignore process))
  (if (term-type-p reln 'destination)
      'destination 
      'notdestination))

(defun DigitValue-Q-Code (number)
  "just give it back as a word."
  (case number
    (1 'one)
    (2 'two)
    (3 'three)
    (4 'four)
    (5 'five)
    (6 'six)
    (7 'seven)
    (8 'eight)
    (9 'nine)
    (t 'zero)))

(defun Dimension-ID-Code (property)
  "Not clear:  for the time being, give the relation of which PROPERTY is the range."
  (term-graph-parent (symbol-value property)))

(defun Dimension-Relation-Q-Code (relation range)
  "Use type of RANGE."
  (declare (ignore relation))
  (let ((dimension (if (term-type-p range 'um-set)
		       (first (term-graph-symbol (symbol-value range)))
		       range)))
    (cond ((term-type-p dimension 'space-point) 'ZeroDimension)
	  ((term-type-p dimension 'one-or-two-d-location) 'OneTwoDimension)
	  ((term-type-p dimension 'three-d-location) 'ThreeDimension))))

(defun Disjunctive-Extension-Q-Code (initiating continuing)
  "If type of continuing is DISJUNCTIVE-SET (SPL) or DISJUNCTION (UM)
   or a RST-LOGICAL-CONDITION, then DISJUNCTIVE."

  (if (or (term-type-p continuing 'disjunctive-set)
	  (term-type-p continuing 'disjunction)
	  (term-type-p initiating 'rst-logical-condition) ;;JB 28.ii.02
	  (dolist (graph *plan-graphs*)
	    (if (and (term-type-p graph 'disjunctive-set)
		     (consp (term-graph-symbol (symbol-value graph)))
;	  	     (member initiating (term-graph-symbol (symbol-value graph)))
		     (member continuing (term-graph-symbol (symbol-value graph))))
		(return 't))
	    (if (and (term-type-p graph 'disjunction)
		     (term-eq-p initiating (fetch-subc-feature 'domain graph))
		     (term-eq-p continuing (fetch-subc-feature 'range graph)))
		(return 't))))
      'disjunctive 
      'nondisjunctive))

(defun Disliking-Q-Code (mentalprocess)
  "Is it of type LIKING?"
  (if (term-type-p mentalprocess 'disliking) 'disliking 'nondisliking))

(defun Dual-Process-Part1-ID-Code (onus)
  "For rhetorical relations, return DOMAIN (unless it is nil).
   For ONUS which is a set, return the next element."
  (if (or (term-type-p onus 'rhetorical-relation)
	  (term-type-p onus 'temporal-relation)                                 ;;; PRIMER-49
	  (term-type-p onus 'static-spatial)                                    ;;; EX-SET-13
	  (term-type-p onus 'logical-condition)     ;;JB 28.ii.02
	  (term-type-p onus 'conjunction)
	  (term-type-p onus 'disjunction))
      (let* ((result (fetch-feature 'domain onus)))
	(modification-specification-id-code 
	 nil 
	 (if result result
	   (fetch-feature 'range onus))))
      (if (or (term-type-p onus 'um-set)
	      (term-type-p onus 'disjunctive-set))
	  (dolist (term (term-graph-symbol (symbol-value onus)))
	    (if (not (member term *consumed-terms*))
		(return term)))
	  ;;; Default for, e.g., temporal roles: after, when, etc.
	  onus)))

(defun Dual-Process-Part2-ID-Code (onus part1)
  "For rhetorical relations, return RANGE.
   For ONUS which is a set, return either the last element or ONUS."
  (if (or (term-type-p onus 'rhetorical-relation)
	  (term-type-p onus 'temporal-relation)                                 ;;; PRIMER-49
	  (term-type-p onus 'static-spatial)   
	  (term-type-p onus 'logical-condition)   ;;JB 28.ii.02
	  (term-type-p onus 'conjunction)
	  (term-type-p onus 'disjunction))
      (modification-specification-id-code nil (fetch-feature 'range onus))
      (if (or (term-type-p onus 'um-set)
	      (term-type-p onus 'disjunctive-set))
	  (if (< (+ (position part1 (term-graph-symbol (symbol-value onus))) 2)
		 (length (term-graph-symbol (symbol-value onus))))
	      onus
	      (first (last (term-graph-symbol (symbol-value onus)))))
	  (or (fetch-subc-feature 'temporal-ordering onus)                      ;;; PRIMER-49
	      (fetch-subc-feature 'static-spatial onus)                         ;;; EX-SET-13
	      (fetch-subc-feature 'condition onus)))))

(defun Duration-Q-Code (reln range)
  "Depends on type of RELN."
  (declare (ignore range))
  (if (term-type-p reln 'exhaustive-duration) 'duration
      (if (term-type-p reln 'nonexhaustive-duration) 'nonduration)))

(defun Elaborated-Thing-ID-Code (spec)
  "Pick up the DOMAIN of the elaboration."
  (fetch-subc-feature 'domain spec))

(defun Elaborating-Thing-ID-Code (spec)
  "Pick up the RANGE of the elaboration."
  (fetch-subc-feature 'range spec))

(defun Elaboration-Q-Code (part1 part2)
  "Are PART1 and PART2 related by an ELABORATION?"
  (declare (ignore part2))
  (if (term-type-p (term-graph-parent (symbol-value part1)) 'rst-elaboration)
      'same
      'distinct)) 

(defun Empty-Gender-Multiplicity-Q-Code (obj)
  "First cut: no :favor-q feature & :express-type is NO."
  (if (not
	(or (fetch-feature 'favor-q obj)
	  (not (eq (fetch-feature 'express-type obj) 'no))))
      'empty))

(defun Empty-Number-Q-Code (obj)
  "If EITHER there are no features (or :identifiability identifiable only)
                   and the goodie has been mentioned before
                       and nothing more recently mentioned has same number & gender
                   or it has the most general type
      OR :EXPRESS-TYPE is not YES, and MULTIPLICITY-Q is given, then EMPTY."
;;; or it should have been anyway. But making this change causes 
  ;;; far too many empty's to be returned and wrecks lots of examples.
  ;;; So revert to the original definition. This entire thing should
  ;;; be overhauled sometime in any case.

  (if (or (and (or (null (term-graph-features (symbol-value obj)))
		   (equal (term-graph-features (symbol-value obj)) 
			  '((identifiability-q . identifiable))))
	       (if (eq obj (first *consumed-terms*))
		   (or (dolist (term (rest *consumed-terms*) nil)
			 (if (term-eq-p term obj)
			     (return t))
			 (if (and (term-type-p term 'object) 
				  (eq (operator-run `(gender-q ,term))
				      (operator-run `(gender-q ,obj)))
				  (eq (operator-run `(multiplicity-q ,term))
				      (operator-run `(multiplicity-q ,obj))))
			     (return nil)))
		       (eq (term-graph-type (symbol-value obj)) 'thing))))
	  (and (eq (fetch-feature 'express-type obj) 'no)
	       (fetch-feature 'multiplicity-q obj)))
      'empty))

(defun Enabling-Q-Code (manner process)
  "Is MANNER an ENABLEMENT?"
  (declare (ignore process))
  (if (term-type-p manner 'enablement) 'enabling 'nonenabling))

(defun Event-Q-Code (item)

  (if (term-type-p item 'process) 'event 'object))

(defun Example-Elaboration-Q-Code (one two)
  "If the parent is an EXEMPLIFICATION...."
  (declare (ignore two))
  (if (term-type-p (term-graph-parent (symbol-value one)) 'exemplification) 
      'example 
      'notexample))

;;; John: May99
;;; Exceed-q extended... was previously just assuming it had to compare.
;;; Actually needs to see if the two is in the standard relationship to
;;; the one, and if so, whether the one is a greater-than-comparison.
#+ignore
(defun Exceed-Q-Code (one two)
  "Depends on the kind of parent relation."
  (if (or (and (term-type-p (term-graph-parent (symbol-value one)) 'greater-than-comparison)
	       (term-role-p (term-graph-parent (symbol-value one)) one 'greater))
	  (and (term-type-p (term-graph-parent (symbol-value two)) 'less-than-comparison)
	       (term-role-p (term-graph-parent (symbol-value two)) two 'lesser)))
	  'exceed
	  'nonexceed))

(defun Exceed-Q-Code (one two)
  "Depends on the kind of parent relation."
  (if  (or
	(and 
	 (fetch-subc-feature 'standard one)
	 (equal (term-graph-symbol 
		 (symbol-value (fetch-subc-feature 'standard one)))
		(term-graph-symbol (symbol-value two)))
	 (eq (term-graph-type (symbol-value one)) 'greater-than-comparison))
	(and 
	 (fetch-subc-feature 'standard two)
	 (equal (term-graph-symbol 
		 (symbol-value (fetch-subc-feature 'standard two)))
		(term-graph-symbol (symbol-value one)))
	 (eq (term-graph-type (symbol-value two)) 'less-than-comparison))
	 )
      'exceed
    'nonexceed))


(defun Existent-ID-Code (reln)
  "Return the DOMAIN."
  (fetch-subc-feature 'participant reln))

(defun Exist-Speech-Act-Q-Code (onus)
  "SPEECHACT, if PROCESS"
  (if (or (term-type-p onus 'Process)
	  (and  (term-type-p onus 'Um-Set)
		(term-type-p (first (term-graph-symbol (symbol-value onus))) 'Process)))
      'Speechact 'nospeechact))

(defun Existential-Q-Code (reln)
  "We just look to see if the variable--a relation--is an existence."
  (if (term-type-p reln 'Existence) 'existential 'nonexistential))

(defun Exists-Focuser-Q-Code (process)
  "Look for a LOGICAL-PROPERTY-ASCRIPTION feature."
  (if (fetch-feature 'logical-property-ascription process) 'focuser-exists))

(defun Experiential-Complexity-Q-Code (arg)
  "Experientially complex if arg is a set.  Then we express each member."
  (if (and (boundp arg)
	   (typep (symbol-value arg) 'term-graph)
	   (or (and (term-type-p arg 'um-set)
		    (consp (term-graph-symbol (symbol-value arg)))              ;;; EX-SET-10
		    (not (and (eq 'included (member-set-q-code 'speaker arg))   ;;; EX-SET-13
			      (eq 'included (member-set-q-code 'hearer arg)))))
	       (term-type-p arg 'conjunction)
	       (term-type-p arg 'disjunction)
	       (term-type-p arg 'logical-condition)    ;;JB 28.ii.02
	       (term-type-p arg 'disjunctive-set)))
      'complex
      'simplex))

(defun Express-Hearer-Q-Code (hearer onus)
  "Depends on the speech-act type of ONUS."
  (declare (ignore hearer))
  (if (or (term-type-p (fetch-feature 'speech-act onus) 'question)
          (term-type-p (fetch-feature 'speech-act onus) 'yes-no-question)
          (term-type-p (fetch-feature 'speech-act-id onus) 'question)
          (term-type-p (fetch-feature 'speech-act-id onus) 'yes-no-question))
      'expresshearer
      'withholdhearer))

(defun Extent-Q-Code (reln)
  "We just look to see if the variable--a relation--is an extent."
  (if (term-type-p reln 'extent) 'extent 'nonextent))

; john patch 6/99, since the term-type-p has been cleaned up, need to correct
;   the following since it mentioned nonexistent upper model concepts.

(defun Extracted-Variable-ID-Code (process)
  "If NOT a process involved in a RHETORICAL-RELATION, get the parent term.
   If it is such a process, identify a point of overlap."
  (if (and (boundp process)
	   (typep (symbol-value process) 'term-graph))
      (if (term-type-p (term-graph-parent (symbol-value process)) 'rhetorical-relation)
	  (first 
	    (intersection 
	      (remove nil
		      (mapcar #'(lambda (a-feature) 
				  (if (or (term-type-p (first a-feature) 'participant)
					  ;; (term-type-p (first a-feature) 'place)
                                          )
				      (term-graph-symbol (rest a-feature))))
			      (term-graph-features (symbol-value process))))
	      (remove nil 
		      (mapcar #'(lambda (a-feature) 
				  (if (or (term-type-p (first a-feature) 'participant)
					  ;; (term-type-p (first a-feature) 'place)
                                          (eq (first a-feature) 'domain)
                                          (eq (first a-feature) 'range)
                                          ;;To pick up other connexions
					  (term-type-p (first a-feature) 
                                                       'relational-process))
				      (term-graph-symbol (rest a-feature))))
			      (term-graph-features 
				(symbol-value 
				  (fetch-subc-feature 
				    'domain 
				    (term-graph-parent (symbol-value process)))))))))
	  (term-graph-symbol (symbol-value (term-graph-parent (symbol-value process)))))
      (term-graph-symbol (symbol-value (term-graph-parent (get-symbol-term process))))))

(defun Favor-Q-Code (object feature)
  "Look for a name feature, or a date."
  (case feature
    (propernoun
      (if (or (fetch-feature 'name object)
	      (term-type-p object 'date))
	  'classify 'outclassify))
    (t nil)))

(defun Fearing-Q-Code (mentalprocess)
  "Is it of type FEARING?"
  (if (term-type-p mentalprocess 'fearing) 'fearing 'nonfearing))

(defun Focuser-ID-Code (process)
  "Return the LOGICAL-PROPERTY-ASCRIPTION feature."
  (fetch-feature 'logical-property-ascription process))

(defun Formal-Register-Q-Code (reln)
  "Look for a between feature."
  (if (term-type-p reln 'formal ) 'formal 'nonformal))

(defun Gender-Q-Code (obj)
  "Go by types MALE and FEMALE, otherwise NEUTRAL."
  (if (term-type-p obj 'female) 'female
      (if (term-type-p obj 'male) 'male 
	  'neutral)))

(defun General-Subclass-Q-Code (item)

  (when (fetch-feature 'class-ascription item) 'subclass))

(defun Generalization-Direction-Q-Code (conjunctive)
  "Depends on nature of CONJUNCTIVE."
  (if (term-type-p conjunctive 'elaboration) 'example 'generalization))

(defun Generalized-Modification-Q-Code (object)
  "Is there any kind of modification (ascription, possession)?"
  (if (or (fetch-relation 'property-ascription object)
	  (fetch-relation 'generalized-possession object)
	  (functional-role-p object)) 
      'possessor))

(defun Generalized-Modification-ID-Code (object)
  "identify the modification (ascription, possession)?"
  (or (fetch-relation 'property-ascription object)
      (fetch-relation 'generalized-possession object)
      (functional-role-p object)))


(defun Hearer-ID-Code (onus)
  "Return the HEARER feature?"
  (fetch-feature 'hearer onus))

(defun Horizontal-Orientation-Q-Code (reln range)
  "Use the type of RELN."
  (declare (ignore range))
  (if (term-type-p reln 'facing) 'facing
      (if (term-type-p reln 'behind) 'behind)))

(defun Hundred-Digit-ID-Code (number)
  "Return the number of hundreds."
  (floor (mod number 1000) 100))

(defun Hundred-Digit-Q-Code (number)
  "Only if greater than 99."
  (if (> number 99) 'yes 'no))

(defun Hundred-Position-ID-Code (number)
  "Return the integer part of the quotient, mod thousands."
  (floor (mod number 1000) 100))

(defun Hundred-Position-Q-Code (entity)
  "Only if greater than 99."
  (if (or (and (> entity 1000)
	       (> (- entity (* (floor entity 1000) 1000)) 99))
	  (and (< entity 1000)
	       (> entity 99)))
      'hundredposition 
      'nothundredposition))

(defun Hundred-Unit-Q-Code (entity)
  "Only if greater than 100."
  (if (>= entity 100) 'hundred 'nothundred))

(defun Identifiability-Q-Code (item &optional (recursive-limit nil))
  "Check identifiability globally as well as local feature, as well as memebership in 
   *CONSUMED-TERMS*.   Identifiability of possessed items follows that of possessor; 
   property-ascription special-cased with RECURSIVE-LIMIT to control degree of transitivity of
   identifiability."
  (if (or (fetch-feature 'identifiable item)  ;;; not in use
	  (global-fetch-feature 'identifiable item)
;	  (term-type-p item 'process)
	  (term-eq-p item 'hearer)
	  (term-eq-p item 'speaker)
	  (term-type-p item 'relative-day)
	  (if (and (not recursive-limit)
		   (fetch-relation 'generalized-possession item)
		   (or (fetch-subc-feature 'domain 
					   (fetch-relation 'generalized-possession item))
		       (fetch-relation 'generalized-possession item)))
	      (Identifiability-Q-Code 
		(or (fetch-subc-feature 'domain 
					   (fetch-relation 'generalized-possession item))
		       (fetch-relation 'generalized-possession item))
		recursive-limit))
	  (if (and (not recursive-limit)
		   (fetch-relation 'generalized-possession-inverse item)
		   (or (fetch-subc-feature 'domain 
			 (fetch-relation 'generalized-possession-inverse item))
		       (fetch-relation 'generalized-possession-inverse item)))
	      (Identifiability-Q-Code 
		(or (fetch-subc-feature 'domain 
					(fetch-relation 'generalized-possession-inverse item))
		       (fetch-relation 'generalized-possession-inverse item))
		recursive-limit))
	  (if (and (not recursive-limit) 
		   (term-type-p item 'generalized-possession)
		   (functional-role-p item))
	      (Identifiability-Q-Code (fetch-subc-feature 'domain item) recursive-limit))
	  (if (and (not recursive-limit) 
		   (term-type-p item 'generalized-possession t))
	      (dolist (term *plan-graphs*)
		(if (and (term-eq-p term item)
			 (functional-role-p term))
			 (return (Identifiability-Q-Code (fetch-subc-feature 'domain term)
							 recursive-limit)))))
	  (if (and (fetch-relation 'property-ascription item)
		   (fetch-subc-feature 'domain (fetch-relation 'property-ascription item)))
	      (Identifiability-Q-Code 
		(fetch-subc-feature 'domain (fetch-relation 'property-ascription item)) t))
	  (dolist (term *consumed-terms*)
	    (if (and (not (eq term item))
		     (term-eq-p term item))
		(return t))))
      'identifiable
      (or (global-fetch-feature 'identifiability-q item)
	  (if (and (term-type-p item 'spatio-temporal)
		   (fetch-subc-feature 'range item))
	      (global-fetch-feature 'identifiability-q (fetch-subc-feature 'range item))))))

(defun Identified-ID-Code (identity)
  "Return the domain of the IDENTITY."
  (fetch-subc-feature 'domain identity))

(defun Identifier-ID-Code (identity)
  "Return the range of the IDENTITY."
  (fetch-subc-feature 'range identity))

(defun Identity-Q-Code (reln)
  "We just look to see if the variable--a relation--is an identity."
  (if (term-type-p reln 'UM-Identity) 'identity 'nonidentity))

(defun Identity-Questioning-Q-Code (referrent)
  "Provisional:  if the parent relation is an IDENTITY, then IDENTITYQUESTIONING."
  (if (term-type-p (term-graph-parent (symbol-value referrent)) 'identity)
      'identityquestioning
      'nonidentityquestioning))



;;; John: patch May99
;;; Following was not exhaustive when it should have been, was also
;;; incorrect due to not having been multilingualized properly...
#+ignore
(defun Inflected-Form-Q-Code (quality)
  (let ((features (fetch-lexicon-info quality 'features)))
    (when features
      (when (not (member 'more-most features)) 'inflected))))

(defun Inflected-Form-Q-Code (quality)
  (let* ((lex (gethash quality lexicon))
	 (features (when lex (fetch-lexicon-info quality 'features))))
    (when lex
      (if (member 'more-most features) 'noninflected 'inflected))))


(defun Item-Value-ID-Code (item property)
  "Give back the item."
  (declare (ignore property))
  item)

(defun Joint-Regard-Q-Code (reln)
  "It is joint for contrastive and elaboration relations."
  (if (or (term-type-p reln 'rst-contrastive)
	  (term-type-p reln 'rst-elaboration)) 'joint 'notjoint))

#+ignore
(defun Know-Manner-Q-Code (process)
  "Look for a manner (means) feature."
  (if (or (fetch-subc-feature 'generalized-means process)
	  (fetch-subc-feature 'similarity process))
      'known))

; mick patch 11/15/90 - allow instrument to become agent 
;  See also Agent-Mention-Q-Code, Causer-ID-Code
(defun Know-Manner-Q-Code (process)
  "Look for a manner (means) feature.(unless it is to be an actor)"
  ;; problem: if there are other generalised means, they should become manner
  (if (or (and (fetch-subc-feature 'generalized-means process)
	       ;; following eliminates manner if instrument is to be actor
	       (not (and (fetch-subc-feature 'instrumental process)
			 (term-type-p process 'material-process)
			 (not (fetch-subc-feature 'actor process)))))
	  (fetch-subc-feature 'similarity process))
       'known))
 
(defun Latitude-Direction-Specification-Q-Code (concept)
  "Negative numbers are south latitudes."
  (if  (< concept 0) 'southwards 'northwards))

(defun Liking-Q-Code (mentalprocess)
  "Is it of type LIKING?"
  (if (term-type-p mentalprocess 'liking) 'liking 'nonliking))

(defun Location-Classification-ID-Code (object)
  "Return the spatial feature of the object."
  (fetch-relation-spec object 'static-spatial 'LOCATION-CLASSIFICATION-ID))

(defun Location-Classification-Q-Code (object)
  "Look for a spatial feature of the object."
  (if (and (fetch-subc-feature 'static-spatial object)
	   (not (pledged-p (fetch-subc-feature 'static-spatial object)))) 'location))

(defun Location-Q-Code (reln)
  "We just look to see if the variable--a relation--is a location."
  (if  (or (term-type-p reln 'locating)
	   (when (typep reln 'term-graph)
	     (term-role-p (term-graph-parent (symbol-value reln)) reln 'locating)))
       'location
       'nonlocation))

(defun Location-Relation-Specificity-Q-Code (locn)
  "This should involve all sorts of neat reasoning that includes decisions
   on the basis of the process type; location participants are less likely
   to require explicitly specified relations. Meanwhile however....
   If the RANGE of the location relation LOCN is RELATIVE, then UNSPECIFIED." 
  (if (or (term-type-p locn 'relative-spatial-temporal)
	  (term-type-p locn 'quality)
	  (and (term-type-p locn 'date)
	       (not (or (fetch-subc-feature 'day locn)
			(fetch-subc-feature 'month locn)
			(fetch-subc-feature 'year locn))))
	  (and (term-type-p locn 'temporal-locating)
	       (fetch-subc-feature 'range locn)
	       (term-type-p 
		(fetch-subc-feature 'range locn)
		'relative-spatial-temporal))
	  )
      'unspecified 
      'specified))

(defun LocationType-Q-Code (object)
  (if (term-type-p object 'date) 'temporal 'spatial))

(defun LocativeAddress-Q-Code (object)
  "Look for a date."
  (if (or (and (term-type-p object 'date)
	       (or (fetch-subc-feature 'day object)
		   (fetch-subc-feature 'month object))
	       (or (fetch-subc-feature 'month object)
		   (fetch-subc-feature 'year object)))
	  (and (term-type-p object 'zero-d-location)
	       (fetch-subc-feature 'latitude object)
	       (fetch-subc-feature 'longitude object)))
      'locativeaddress 
      'notlocativeaddress))

(defun Logical-Condition-Q-Code (part1 part2)
  "See if the parent is a LOGICAL-CONDITION.
  Or a CONDITION."
  ;(declare (ignore part2))
  (if (or (term-type-p (term-graph-parent (symbol-value part1)) 'logical-condition)
	  (term-type-p (term-graph-parent (symbol-value part1)) 'condition)
	  (if (fetch-subc-feature 'condition part1) 
	      (term-eq-p part2 (fetch-subc-feature 'condition part1))))
      'logicalcondition 
      'nonlogicalcondition))

(defun Longitude-Direction-Specification-Q-Code (concept)
  "Negative numbers are west longitudes."
  (if (< concept 0) 'westwards 'eastwards))

(defun Manipulation-Q-Code (reln range)
  "If type of RELN is INSTRUMENTAL...."
  (declare (ignore range))
  (if (term-type-p reln 'instrumental) 'manipulation 'nonmanipulation))

(defun Manner-Condition-Q-Code (part1 part2)
  "See if the parent is a MANNER-CONDITION."
  (declare (ignore part2)) 
  (if (or (term-type-p (term-graph-parent (symbol-value part1)) 'manner)
	  (term-type-p (term-graph-parent (symbol-value part1)) 'RST-Means))
      'mannercondition 
      'nonmannercondition))

(defun Manner-Q-Code (reln process)
  "If the type of RELN is MANNER...."
  (declare (ignore process))
  (if (or (term-type-p reln 'manner)
	  (term-type-p reln 'agentive)) 'manner 'nonmanner))

(defun Material-Act-Category-ID-Code (process)
  "Return the actee."
  (fetch-subc-feature 'actee process))

(defun Material-Act-Category-Q-Code (process)
  "Look for nondirectedness."
  (if (and (term-type-p process 'Nondirected-Action)
	   (fetch-subc-feature 'actee process))
      'actspecified 
      'notactspecified))

(defun Material-Class-ID-Code (obj)
  "Return the material property."
   (or (fetch-subc-feature 'material-property-ascription obj)
       (fetch-subc-feature 'domain (fetch-relation 'material-property-ascription obj))))

(defun Material-Classification-Q-Code (obj)
  "Look for a MATERIAL-PROPERTY-ASCRIPTION feature."
  (if (fetch-relation 'material-property-ascription obj) 'material))

(defun Matter-ID-Code (process)
  "Return the role feature of the entry term with its value."
  (fetch-relation-spec process 'subject-matter 'matter-ID))

(defun Matter-Q-Code (process)
  "Look for a subject matter feature."
  (if (fetch-relation 'subject-matter process) 'matter 'nonmatter))

(defun Matter-Relation-Q-Code (reln)
  "Is it a subject-Matter relation?"
  (if (term-type-p reln 'subject-matter) 'matterrelation 'notmatterrelation))

(defun Means-Of-Transportation-Q-Code (object)
  "Is it a vessel?"
  (if (term-type-p object 'ship) 'meansoftransportation 'notmeansoftransportation))

(defun Means-Q-Code (manner process)
  "Check that the feature is a (generalized) means."
  (declare (ignore process))
  (if (or (term-type-p manner 'rst-means)
	  (and (term-type-p  manner 'generalized-means)
	       (not (term-type-p manner 'manner))))
      'means
      'nonmeans))

#+ignore
(defun Medium-Mention-Q-Code (spec)
  "Just look to see if there is an ACTEE role."
  (if (fetch-subc-feature 'actee spec) 'mention))

(defun Medium-Mention-Q-Code (spec)
  "Just look to see if there is an ACTEE or ACTOR role, depending on the type of action."
  (if (or (and (term-type-p spec 'nondirected-action)
	       (fetch-subc-feature 'actor spec))
	  (and (term-type-p spec 'directed-action)
	       (fetch-subc-feature 'actee spec)))
      'mention))

;(defun Member-Set-Q-Code (thing1 thing2)
;  "The first test is EQ of term-symbol or term-id.  (Use Same-As-Q-Code)
;   Also, we look for a part/whole (thing1/thing2) relation."
;  (if (or (eq (Same-As-Q-Code thing1 thing2) 'same)
;	  (term-role-p thing1 thing2 'generalized-possession t)
;	  (if (and (symbolp thing1)
;		   (boundp thing1)
;		   (typep (symbol-value thing1) 'term-graph)) 
;	      (term-eq-p thing2 (fetch-subc-feature 'part thing1)))
;	  (if (and (symbolp thing2)
;		   (boundp thing2)
;		   (typep (symbol-value thing2) 'term-graph)
;		   (fetch-reified-relation 'part-whole thing2)) 
;	      (term-eq-p 
;		thing1 
;		(fetch-subc-feature 'domain (fetch-reified-relation 'part-whole thing2)))))
;      'included))

;(defun Member-Set-Q-Code (thing1 thing2)
;  "The first test is EQ of term-symbol or term-id.  (Use Same-As-Q-Code)
;   Also, we look for a part/whole (thing1/thing2) relation."
;  (if (or (eq (Same-As-Q-Code thing1 thing2) 'same)
;	  (term-role-p thing1 thing2 'part-whole t)
;	  (if (and (symbolp thing1)
;		   (boundp thing1)
;		   (typep (symbol-value thing1) 'term-graph)) 
;	      (term-eq-p thing2 (fetch-subc-feature 'part thing1)))
;	  (if (and (symbolp thing2)
;		   (boundp thing2)
;		   (typep (symbol-value thing2) 'term-graph)
;		   (or (fetch-reified-relation 'part-whole thing2)
;		       (fetch-reified-relation 'generalized-role-relation thing2))) 
;	      (term-eq-p 
;		thing1 
;		(fetch-subc-feature 
;		  'domain 
;		  (or (fetch-reified-relation 'part-whole thing2)
;		      (fetch-reified-relation 'generalized-role-relation thing2)))))
;;	  (dolist (plan *plan-graphs*)
;;	    ;;; A set of cases to minimaze global search....
;;	    (if (term-graph-features (symbol-value plan))
;;		(if (and (term-role-p thing1 plan 'generalized-possession t)
;;			 (term-role-p plan thing2 'generalized-possession t))
;;		    (return t))))
;	  )
;      'included))

(defun Member-Set-Q-Code (thing1 thing2)
  "The first test is EQ of term-symbol or term-id.  (Use Same-As-Q-Code)
   Also, we look for a part/whole (thing1/thing2) relation."
  (if (or (eq (Same-As-Q-Code thing1 thing2) 'same)
	  (term-role-p thing1 thing2 'part-whole t)
	  (if (and (symbolp thing1)
		   (boundp thing1)
		   (typep (symbol-value thing1) 'term-graph)) 
	      (term-eq-p thing2 (fetch-subc-feature 'part thing1)))
	  (if (and (symbolp thing2)
		   (boundp thing2)
		   (typep (symbol-value thing2) 'term-graph)
		   (or (fetch-reified-relation 'part-whole thing2)
		       (fetch-reified-relation 'generalized-role-relation thing2))) 
	      (term-eq-p 
		thing1 
		(fetch-subc-feature 
		  'domain 
		  (or (fetch-reified-relation 'part-whole thing2)
		      (fetch-reified-relation 'generalized-role-relation thing2)))))
	  (if (and (symbolp thing1)                                            ;;;  EX-SET-4, EX-SET-13
		   (boundp thing1)
		   (typep (symbol-value thing1) 'term-graph)
		   (eq (term-graph-type (symbol-value thing1)) 'um-set))
	      (dolist (elt (term-graph-symbol (symbol-value thing1)))
		(if (member-set-q-code elt thing2) (return t))))
	  (if (and (symbolp thing2)                                            ;;;  EX-SET-4, EX-SET-13                      
		   (boundp thing2)
		   (typep (symbol-value thing2) 'term-graph)
		   (eq (term-graph-type (symbol-value thing2)) 'um-set))
	      (dolist (elt (term-graph-symbol (symbol-value thing2)))
		(if (member-set-q-code elt thing1) (return t))))
;	  (dolist (plan *plan-graphs*)
;	     A set of cases to minimaze global search....
;	    (if (term-graph-features (symbol-value plan))
;		(if (and (term-role-p thing1 plan 'generalized-possession t)
;			 (term-role-p plan thing2 'generalized-possession t))
;		    (return t))))
	  )
      'included))

(defun Mental-Process-Q-Code (process)
  "Is the process mental?"
  (if (term-type-p process 'mental-process) 'mental 'nonmental))

(defun Million-Position-ID-Code (number)
  "Return the integer part of the quotient."
  (floor number 1000000))

(defun Million-Position-Q-Code (number)
  "Only if greater than 999999."
  (if (> number 999999) 'millionposition 'notmillionposition))

; john patch 20/5/96 - was just wrong I think...
(defun Million-Unit-Q-Code (entity)
  "Only if greater than 1000000."
  (if (>= entity 1000000) 'million 'notmillion))




;;; Should a set allow minimal attention?...
#+ignore
(defun Minimal-Attention-Q-Code (obj)
  "If OBJ has no features, then minimal."
  (if (and (symbolp obj)
	   (boundp obj)
	   (typep (symbol-value obj) 'term-graph)
	   (null (term-graph-features (symbol-value obj))))
      'minimal
      'nonminimal))

;;; let's say not...
(defun Minimal-Attention-Q-Code (obj)
  "If OBJ has no features, then minimal."
  (if (and (symbolp obj)
	   (boundp obj)
	   (typep (symbol-value obj) 'term-graph)
	   (null (term-graph-features (symbol-value obj)))
	   (not (term-type-p obj 'um-set)))
      'minimal
      'nonminimal))


(defun Modal-Necessity-Q-Code (modality process)
  "NECESSITY, if the type of MODALITY is."
  (declare (ignore process))
  (if (term-type-p modality 'necessity) 'necessity 'nonnecessity))

(defun Modality-Conditionality-Q-Code (modality)
  "Ask if MODALITY is CONDITIONAL."
  (if (term-type-p modality 'conditional) 
      'modalityconditional 
      'modalitynonconditional))

(defun Modality-ID-Code (process)
  "Return the modality feature."
  (fetch-subc-feature 'modal-property-ascription process))

(defun Modality-Q-Code (process)
  "Look for a modality feature."
  (if (fetch-subc-feature 'modal-property-ascription process ) 'modal))

(defun MODIFICATION-SPECIFICATION-ID-CODE (position hub)
  (specification-modification position hub))

(defun Modifying-Relation-Q-Code (concept)
  "Modifying if CONCEPT is a RELATIONAL-PROCESS."
  (if (term-type-p concept 'relational-process t) 'modifying 'nonmodifying))

(defun Multiple-Process-Q-Code (onus)
  "Check the clause-complexity feature of onus.
   Verbal and mental processes with, respectively, saying or phenomenon roles which
   are processes will be multiple.
   Also, any ONUS which is a SET (or DISJUNCTIVE-SET) will be multiple."
  (if (or (term-type-p onus 'um-set)
	  (term-type-p onus 'disjunctive-set)
	  (term-type-p onus 'temporal-ordering)                  ;;; PRIMER-49
	  (and (fetch-subc-feature 'temporal-ordering onus)      ;;; PRIMER-49
	       (or (term-type-p (fetch-subc-feature 'temporal-ordering onus) 'process)     
		   (eq 'multiple 
                       (multiple-process-q-code 
                        (fetch-subc-feature 'temporal-ordering onus))))
	       (not (pledged-p (fetch-subc-feature 'temporal-ordering onus))))
	  (and (fetch-subc-feature 'static-spatial onus)         ;;; EX-SET-13
	       (or (term-type-p (fetch-subc-feature 'static-spatial onus) 'process)
		   (eq 'multiple 
                       (multiple-process-q-code (fetch-subc-feature 'static-spatial onus))))
	       (not (pledged-p (fetch-subc-feature 'static-spatial onus))))
	  (and (fetch-subc-feature 'condition onus)
	       (or (term-type-p (fetch-subc-feature 'condition onus) 'process)
		   (multiple-process-q-code 
                    (fetch-subc-feature 'temporal-ordering onus))) ;;; PRIMER-49
	       (not (pledged-p (fetch-subc-feature 'condition onus))))
	  (term-type-p onus 'conjunction)    ;;; The logical way to form sets of processes!
	  (term-type-p onus 'disjunction)
	  (term-type-p onus 'logical-condition)  ;;JB 28.ii.02
	  (and (term-type-p onus 'verbal-process)
	       (term-type-p (fetch-subc-feature 'saying onus) 'process)
	       (not (< 1 (count onus *consumed-terms*))))   
          ;;  TO ALLOW DIRECT QUOTE:  
          ;;  ONE AND THE SAME PROCESS IS BOTH MULTIPLE AND SINGLE
	  (and (term-type-p onus 'mental-process)
	       (term-type-p (fetch-subc-feature 'phenomenon onus) 'process))
	  (and (term-type-p onus 'rhetorical-relation)
;	       (not (term-type-p onus 'generalized-means))
	       (fetch-subc-feature 'domain onus)  ;;;  Elaboration, for instance, may
	       (fetch-subc-feature 'range onus))) ;;;  have just RANGE filled, and is
      'multiple                                   ;;;  in that case not MULTIPLE.
      'single))

(defun Multiplicity-Q-Code (thing)
  "Look for number.  If THING isn't a plan, look for a plan for it.
   Even if it isn't a plan, look at other TERM-EQ-P plans for multiplicity
   (this is important for agreement in number in dependent clauses)."
  (if (and (symbolp thing)
	   (boundp thing)
	   (typep (symbol-value thing) 'term-graph))
      (if (or (eq (fetch-feature-symbol 'number thing) 'multiple)
              (and (numberp (fetch-feature 'ordination-id thing))
                   (> (fetch-feature 'ordination-id thing) 1))
	      (and (fetch-subc-feature 'quantity-ascription thing)
		   (let ((n (fetch-subc-feature 'quantity-ascription thing)))
		     (if (numberp n)
			 (< 1 n)
		       (and (term-type-p n 'number)              ;; 1.1 R3b11
			    (numberp (fetch-feature 'value n))
			    (< 1 (fetch-feature 'value n))))))
	      (term-type-p thing 'um-set)
	      (dolist (graph *plan-graphs*)
		(if (and (not (eq thing graph))
			 (term-eq-p thing graph)
			 (or (eq (fetch-feature 'multiplicity-q graph) 'multiple)
			     (eq (fetch-feature-symbol 'number graph) 'multiple)
			     (term-type-p graph 'um-set)))
		    (return t))))
	  'multiple)
      (if (null thing)
	  nil
	  (Multiplicity-Q-Code
	    (dolist (graph *plan-graphs*)
	      (if (term-eq-p graph thing)
		  (return)))))))

(defun NUMBER-VALUE-ID-CODE (spec)
  (if (and (symbolp spec)
	   (boundp spec)
	   (typep (symbol-value spec) 'term-graph)
	   (term-type-p spec 'number))
      (fetch-feature 'value spec)
    spec))

(defun NUMBER-RELATIVITY-Q-CODE (number)
  (if (or (numberp number)
	  (and (symbolp number)
	       (boundp number)
	       (typep (symbol-value number) 'term-graph)
	       (term-type-p number 'number)))
      'absolute 'relative))


(defun Necessity-Q-Code (conjunctive)
  "Provisional implementation:  a guess."
  (if (and (term-type-p conjunctive 'conjunctive)
	   (term-type-p conjunctive 'causal)) 
      'necessity 
      'nonecessity))

(defun Number-Focusing-Extent-Q-Code (numrel)
  "Depends on type of NUMREL."
  (if (term-type-p numrel 'exactly)
      'morefocused
      'lessfocused))

(defun Number-Focusing-ID-Code (number)
  "Find the appropriate feature that is filled by NUMBER."
  (dolist (graph *plan-graphs*)
	(if (term-role-p graph number 'number-focusing)
	    (return (dolist (feature (term-graph-features (symbol-value graph)))
		      (when (eq (rest feature) number)
			(return (first feature))))))))

(defun Number-Focusing-Q-Code (numrel)
  "Provisional implementation:  a guess."
  (if (dolist (graph *plan-graphs*)
	(if (term-role-p graph numrel 'number-focusing)
	    (return t)))
      'focusing
      'nonfocusing))

(defun Number-Of-Thousands-Q-Code (number)
  "Just say the right thing about the number of thousands."
  (let ((thousands (if (< number 1000)
		       number 
		       (floor number 1000))))
    (cond ((< thousands 10) 'subten)
	  ((> thousands 99) 'hundreds)
	  (t 'supraten))))

(defun Number-Range-Direction-Q-Code (numrel bogus-numrel)
  "Provisional implementation:  a guess."
  (declare (ignore bogus-numrel))
  (if (or (term-type-p numrel 'more-than)
	  (term-type-p numrel 'at-least))
      'above
      'below))

;;; john patch 6/99. experiment with making certain inquiries ignore null
;;; variables and go for the instances with content... this should actually
;;; happen as a consequence of their being KB inquiries but nothing is triggered
;;; in this case.

(defun Operand-ID-Code (reln)
  "RELN is the ID of a reified relation spec.  Return the value of its range feature."
  (let ((contentful (coreferential-term reln)))
    (or (fetch-subc-feature 'range contentful)
        contentful)))

(defun Operator-ID-Code (reln)
  "RELN is the ID of a reified relation spec.  Return its type."
  (let ((contentful (coreferential-term reln)))
    (term-graph-type (symbol-value contentful))))

(defun Orientation-Q-Code (reln range)
  "If RELN is an ORIENTING. then ORIENTED."
  (declare (ignore range)) 
  (if (term-type-p reln 'orienting) 'oriented 'nonoriented))

(defun Orientation-Specification-Q-Code (reln range)
  "If the type of RELN is Horizontal, but not facing,behind or between...."
  (declare (ignore range))
  (if (and (term-type-p reln 'horizontal)
			(or (term-type-p reln 'facing)
			    (term-type-p reln 'behind)
			    (term-type-p reln 'between)))
      'specified 
      'notspecified))

;;; Following implementation is completely off. Have not yet
;;; checked why it was done or what taking it out entails
;;; for ISI-released examples. John:IPSI:Nov94
#+ignore
(defun Paragraph-Theme-Exist-Q-Code (process)
  "Do NOT, repeat NOT Look for a THEME feature!"
  (if (fetch-feature 'theme process) 'exists))

(defun Paragraph-Theme-Exist-Q-Code (process)
  "Do NOT, repeat NOT Look for a THEME feature!"
  nil)

(defun Paragraph-Theme-ID-Code (process)
  "Return the THEME."
  (first (term-graph-symbol (symbol-value (fetch-feature 'theme process)))))

(defun Parallel-Q-Code (reln range)
  "Depends on type of RELN."
  (declare (ignore range)) 
  (if (term-type-p reln 'parallel-extent) 'parallel
      (if (term-type-p reln 'nonparallel-extent) 'nonparallel)))

(defun Participation-Q-Code (reln range)
  "If RELN is of type INCLUSIVE."
  (declare (ignore range)) 
  (if (term-type-p reln 'inclusive) 'participation 'nonparticipation))

(defun Partitive-ID-Code (ps)
  "Just get the parent term."
  (term-graph-parent (symbol-value ps)))

(defun Path-Inclusion-Q-Code (path1 path2)
  "CONTAINED if PATH1 is thematic."
  (if (eq path1 'thematic-path) 'contained 
      (if (eq path2 'thematic-path) 'notcontained)))

(defun Perception-Q-Code (mental-process)
  "If type of MENTAL-PROCESS is perception...."
  (if (term-type-p mental-process 'perception) 'perception 'notperception))

(defun Perceptive-Reactive-Phenomenon-ID-Code (mental-process)
  "Return the PHENOMENON feature."
  (fetch-subc-feature 'phenomenon mental-process))

(defun Perceptive-Reactive-Phenomenon-Q-Code (mental-process)
  "Look for a PHENOMENON feature (which is not a process)."
  (if (and (fetch-subc-feature 'phenomenon mental-process)
	   (not (term-type-p (fetch-subc-feature 'phenomenon mental-process) 'process)))
      'phenomenon 
      'notphenomenon))

(defun Period-Extremal-Q-Code (relation)
  "Is the relation extremal?"
  (if (term-type-p relation 'extremal) 'periodextremal 'notperiodextremal))

(defun Period-Modification-Part-ID-Code (obj)
  "Return the PERIOD feature."
  (fetch-subc-feature 'temporal-relation obj))

;(defun Period-Modification-Q-Code (obj)
;  "Look for a PERIOD feature."
;  (if (fetch-subc-feature 'temporal-relation obj) 'period))

(defun Period-Modification-Q-Code (obj)
  "Look for a PERIOD feature."
  (if (fetch-subc-feature 'temporal-nonordering obj) 'period))

(defun Phoric-Representative-Selection-Q-Code (concept)
  "Provisional implementation:  a guess."
  (if (term-type-p (term-graph-parent (symbol-value concept)) 'identity) 
      'phoric 
      'notphoric))

(defun Place-Qual-ID-Code (obj)
  "Return a spatial-locating relation, reifying if necessary."
  (fetch-relation-spec obj 'spatial-locating 'PLACE-QUAL-ID))

(defun Place-Qual-Q-Code (obj)
  "Look for an orientation."  ; generalized to handle more spatial mods -- BK
  (if (and (fetch-subc-feature 'spatial-locating obj)
	   (not (pledged-p (fetch-subc-feature 'spatial-locating obj)))
	   (if (fetch-subc-feature 'static-spatial obj)
	       (not (term-eq-p
		      (fetch-subc-feature 'spatial-locating obj) 
		      (fetch-subc-feature 'static-spatial obj)))
	       t))
      'place))

(defun Polarity-ID-Code (speech-act)
  "Find the polarity feature of the speech-act term."
  (or (global-fetch-feature 'polarity speech-act)
      (fetch-feature 'polarity (get-symbol-term speech-act))))

(defun Polarity-Value-Q-Code (polarity)
  "Return the type of the polarity."
  (term-graph-type (symbol-value polarity)))

(defun Polarity-Variable-Q-Code (polarity)
  "Is the polarity variable?"
  (if (term-type-p polarity 'polarity-variable)
      'polarityvariable
      'notpolarityvariable))

(defun Portion-Modification-ID-Code (obj)
  "Invert & return the reified generalized possession feature."
  (invert-reified-relation-spec 
    (fetch-reified-relation 'generalized-possession obj) 
    'portion-modification-id))

(defun Portion-Modification-Q-Code (obj)
  "Is there an inverse generalized-possession feature?"
  (if (and (fetch-reified-relation 'generalized-possession obj)
	   (eq (term-graph-symbol 
		 (symbol-value
		   (fetch-subc-feature 
		     'range (fetch-reified-relation 'generalized-possession obj))))
	       (term-graph-symbol (symbol-value obj)))
	   (dolist (graph *plan-graphs* t)
	     (if (and (term-eq-p graph 
				 (fetch-subc-feature 
			      'domain (fetch-reified-relation 'generalized-possession obj)))
		      (member graph *consumed-terms*))
		 (return nil))))
      'portion))

(defun Portion-Modification-ID-Code (obj)
  "What is the portion feature?"
  (fetch-feature 'part-of obj))

(defun Portion-Modification-ID-Code (obj)
  "What is the portion feature?"
  (or (if (fetch-feature 'part-of obj) 
	  (fetch-relation-spec obj 'part-of 'Portion-Modification-ID))
      (if (term-type-p obj 'part)
	  (fetch-relation-spec obj 'domain 'Portion-Modification-ID))
      (if (term-type-p obj 'part-of)
	  (fetch-relation-spec obj 'range 'Portion-Modification-ID))
      (if (term-type-p obj 'participant)
	  (fetch-relation-spec obj 'range 'Portion-Modification-ID))))

(defun Portion-Modification-Q-Code (obj)
  "Is there a part-of feature?"
  (if (fetch-feature 'part-of obj) 'portion))

(defun Portion-Modification-Q-Code (obj)
  "Is there a part-of feature?
   Or is OBJ a functional relation (:domain only) of type PART?"
  (if (or (and (fetch-feature 'part-of obj) 
	       (not (pledged-p (fetch-feature 'part-of obj))))
	  (and (or (term-type-p obj 'part)
		   (term-type-p obj 'part-of)
		   (term-type-p obj 'participant))
	       (functional-role-p obj)))
      'portion))

(defun Position-ID-Code (address)
  "Find day, if month/day, else find month for month/year."
  (or (fetch-feature 'day address)
      (fetch-feature 'month address)
      (fetch-feature 'longitude address)))

(defun Position-Specific-Spatial-Address-Type-Q-Code (concept)
 "Provisional implementation:  a guess."
 (if (and (term-type-p concept 'zero-d-location)
	  (fetch-subc-feature 'latitude concept)
	  (fetch-subc-feature 'longitude concept))
     'latitude-longitude
     'other))

(defun Possessed-ID-Code (relation)
  "We've already determined that RELATION is one of generalized possession, so RANGE is the 
   acceptable feature."
  (fetch-subc-feature 'range relation))

(defun Possession-Onset-Q-Code (process)
  "Is there a recipient?"
  (if (or (fetch-feature 'beneficiary process)
	  (fetch-feature 'recipient   process)) 'possessioncreated))

(defun Possessive-Q-Code (reln)
  "We just look to see if the variable--a relation--is a kind of generalized possession."
  (if (term-type-p reln 'generalized-possession) 'possessive 'notpossessive))

(defun Possessor-ID-Code (relation)
  "We've already determined that RELATION is one of generalized possession, so DOMAIN is the 
   acceptable feature."
  (fetch-subc-feature 'domain relation))

(defun Possessor-Mod-ID-Code (object)
  "Return the possessor feature."
  (or (if (fetch-reified-relation 'ownership object) 
	  (fetch-subc-feature 'domain (fetch-reified-relation 'ownership object)))
      (if (fetch-relation 'owned-by object)
	  (or (fetch-subc-feature 'range (fetch-relation 'owned-by object))
	      (fetch-relation 'owned-by object)))
      (fetch-subc-feature 'possessor object)
      (if (fetch-relation 'generalized-possession object) 
	  (fetch-subc-feature 'domain (fetch-relation 'generalized-possession object)))
      (fetch-subc-feature 'domain object)))

(defun Possessor-Modification-Q-Code (object)
  "Is there a possessor feature?
   Or is this a functional role?"
  (if (fetch-relation 'ownership object) 'possessor))

(defun Possessor-Modification-Q-Code (object)
  "Is there a possessor feature?"
  (if (or (fetch-reified-relation 'ownership object)
	  (fetch-relation 'owned-by object)
	  (fetch-minimal-relation 'generalized-role-relation object)
	  (and (not (term-type-p object 'property-ascription))
	       (fetch-subc-feature 'domain object)
	       (not (fetch-subc-feature 'range object))))
      'possessor))

(defun Possessor-REL-ID-Code (object)
  "Return the possessor relation."
  (or (fetch-reified-relation 'ownership object) 
      (fetch-relation 'owned-by object)
      (fetch-subc-feature 'possessor object)
      (fetch-relation 'generalized-possession object)))

(defun Possessor-Questioning-Q-Code (item)
  "Depends on role-relation ITEM is involved in."
  (if (term-role-p item (term-graph-parent (symbol-value item)) 'generalized-possession)
      'possessorquestioning
      'nonpossessorquestioning))

(defun Possibility-Q-Code (modality process)
  "POSSIBILITY, if the type of MODALITY is."
  (declare (ignore process))
  (when (term-type-p modality 'possibility) 'possibility))

(defun Posterior-Q-Code (time-relation)
  "Is TIME-RELATION posterior?"
  (if (term-type-p time-relation 'posterior) 'posterior 'notposterior))

(defun Potential-Representative-ID-Code (obj) obj)

(defun Precede-Q-Code (time-1 time-2)
  "Compare what is known about the times"
  (if (term-type-p time-1 'past)
      (if (not (term-type-p time-2 'past)) 'precedes)
      (if (term-type-p time-1 'present)
	  (if (term-type-p time-2 'future) 'precedes)
	  (if (not (term-type-p time-1 'future))
	      (if (term-type-p time-2 'future) 'precedes)))))

(defun Preexist-Q-Code (goal process)
  "Only in a Creative-Material-Action does GOAL follow PROCESS!"
  (declare (ignore goal))
  (if (term-type-p process 'Creative-Material-Action) 'nonexistent 'existed))

(defun Prefer-Mention-Agent-Q-Code (actor activity)
  "Mention, especially notionally in imperatives, unless actor is unknown."
  (if (and 
       (not (term-type-p (fetch-feature 'speech-act-id activity) 'command))
       (or  (term-eq-p actor '?actor)
	    (term-eq-p actor '?sayer)))
      'withhold
      'mention))

(defun Prefer-Mention-Medium-Q-Code (medium activity)
  "Mention, unless medium is unknown."
  (declare (ignore activity)) 
  (if (or (term-eq-p medium '?sayer)
	  (term-eq-p medium '?medium)
	  (term-eq-p medium '?senser))
      'withhold))

(defun Presentational-Complexity-Q-Code (arg)
  "Look for an ELABORATION type."
  (if (term-type-p arg 'elaboration)
      'complex))

(defun Presentational-Relation-Q-Code (arg)
  "Look for an ELABORATION type."
  (if (term-type-p arg 'elaboration)
      'presentational
      'notpresentational))

(defun Presuppose-Existence-Q-Code (obj)
  "Yes, if this is an assertion."
  obj ;;;we don't need the parameter?
  (if (term-type-p (fetch-feature 'speech-act  *plan*) 'assertion) 
      'presupposed 'notpresupposed))

(defun Process-ID-Code (onus)
  "Find the process feature of the entry term, 
   or find the range of a rhetorical relation, or give the entry term back."
  (or (fetch-feature 'process onus)
      (if (term-type-p onus 'rst-means) (fetch-subc-feature 'domain onus))
      (if (term-type-p onus 'rhetorical-relation) 
	  (if (term-type-p (fetch-subc-feature 'range onus) nil)
	      (first (get-top-level-terms (fetch-subc-feature 'range onus)))
	      (fetch-subc-feature 'range onus)))
      onus))

(defun Process-Manner-ID-Code (process)
  "Return the manner (means) feature, reifying if necessary."
  (if (fetch-subc-feature 'generalized-means process)
      (if (fetch-subc-feature 'manner process) 
	  (fetch-subc-feature 'manner process) ;(fetch-relation-spec process 'manner 'Process-Manner-ID)
	  (fetch-relation-spec process 'generalized-means 'Process-Manner-ID))
      (fetch-relation-spec process 'similarity 'Process-Manner-ID)))

(defun Process-Modification-ID-Code (onus)
  "Return all process features and non-minimal reified relations."
  (let ((processes 
	  (remove-duplicates 
	    (remove nil 
		    (list (fetch-feature 'process onus)
			  (fetch-non-minimal-reified-relation 'relational-process onus)
			  (fetch-non-minimal-reified-relation 'material-process onus)
			  (fetch-subc-feature 'rst-elaboration onus))))))
    (if processes
	(if (< 1 (length processes))
	    (make-term-graph-id 
	      :symbol processes :type 'um-set :id 'um-set :features nil :parent onus)
	    (first processes))
	(let ((role 
		(gentemp (symbol-name (fetch-subc-feature-name 'relational-process onus)))))
	(make-term-graph-id 
	  :symbol (gentemp "ROLE-RELATION") 
	  :type 'generalized-role-relation
	  :features `((domain . ,(symbol-value (make-term-graph-id 
				   :symbol (term-graph-symbol (symbol-value onus))
				   :id (term-graph-symbol (symbol-value onus)))))
		      (range . ,(symbol-value (fetch-subc-feature 'relational-process onus)))
		      (temporal-definiteness-specification-q . specified)
		      (temporal-definiteness-q . definite)
		      (role-playing 
			. 
			,(symbol-value 
			   (make-term-graph-id 
			     :symbol role
			     :id (fetch-subc-feature-name 'relational-process onus)
			     :type (fetch-subc-feature-name 'relational-process onus)
			     :features 
			     `((relations 
				 . 
				 ,(symbol-value
				    (make-term-graph-id 
				      :type 'um-set
				      :symbol 
				      `(,(make-term-graph-id
					   :symbol (gentemp "ROLE-RELATION")
					   :type 'generalized-role-relation
					   :features 
					   `((domain 
					       . 
					       ,(symbol-value 
						  (make-term-graph-id 
						    :symbol
						    (term-graph-symbol (symbol-value onus))
						    :id 
						    (term-graph-symbol 
						      (symbol-value onus)))))
					     (range 
					       .
					       ,(symbol-value 
						  (make-term-graph-id
						    :symbol role
						    :id (fetch-subc-feature-name 
							  'relational-process 
							  onus)))))))))))
			     ))))
	  :parent onus)))))

(defun Process-Modification-ID-Code (onus)
  "Return all process features and non-minimal reified relations."
  (let ((processes 
	  (remove-duplicates 
	    (remove nil 
		    (list (fetch-feature 'process onus)
			  (fetch-non-minimal-reified-relation 'relational-process onus)
			  (fetch-non-minimal-reified-relation 'material-process onus)
			  (fetch-subc-feature 'rst-elaboration onus))))))
    (if processes
	(if (< 1 (length processes))
	    (make-term-graph-id 
	      :symbol processes :type 'um-set :id 'um-set :features nil :parent onus)
	    (first processes))
	(let ((role 
		(gentemp (symbol-name (fetch-subc-feature-name 'relational-process onus)))))
	  (make-term-graph-id 
	    :symbol (gentemp "ROLE-RELATION") 
	    :type 'class-ascription
	    :features `((domain 
			  . 
			  ,(symbol-value 
			     (make-term-graph-id 
			       :symbol role
			       :id (fetch-subc-feature-name 'relational-process onus)
			       :type (fetch-subc-feature-name 'relational-process onus)
			       :features 
			       `((relations 
				   . 
				   ,(symbol-value
				      (make-term-graph-id 
					:type 'um-set
					:symbol 
					`(,(make-term-graph-id
					     :symbol (gentemp "ROLE-RELATION")
					     :type 'generalized-role-relation
					     :features 
					     `((domain 
						 . 
						 ,(symbol-value 
						    (make-term-graph-id 
						      :symbol
						      (term-graph-symbol (symbol-value onus))
						      :id 
						      (term-graph-symbol 
							(symbol-value onus)))))
					       (range 
						 .
						 ,(symbol-value 
						    (make-term-graph-id
						      :symbol role
						      :id (fetch-subc-feature-name 
							    'relational-process 
							    onus)))))))))))
			       )))
			(range . ,(symbol-value (fetch-subc-feature 'relational-process onus)))
			(temporal-definiteness-specification-q . specified)
			(temporal-definiteness-q . definite))
	    :parent onus)))))

(defun Process-Modification-Q-Code (onus)
  "Look for a process feature or a non-minimal reified relation or an elaboration."
  (let (process)
    (if (and (setf process 
		   (or (fetch-feature 'process onus)
		       (fetch-non-minimal-reified-relation 'relational-process onus)
		       (fetch-non-minimal-reified-relation 'material-process onus)
		       (fetch-subc-feature 'rst-elaboration onus)
		       (and 
                        ;; 2.1 can't go taking participants surely?
                        (not
                         (KB-superp (fetch-subc-feature-name 'relational-process onus) 'participant))
                        (not (KB-superp 
                              (fetch-subc-feature-name 'relational-process onus) 
                              'quantity-ascription))
                        (not (KB-superp 
                              (fetch-subc-feature-name 'relational-process onus) 
                              'element-of))
                        (not (term-role-p onus 
                                          (fetch-subc-feature 'relational-process onus)
                                          'participant))
                        (fetch-subc-feature 'relational-process onus))))
	     (not (pledged-p process)))
        'process)))

(defun Process-Q-Code (item)
  "Just go by the type of ITEM."
  (if (and (term-type-p item 'process)
	   (not (term-role-p (term-graph-parent (symbol-value item)) item 'standard)))
      'process 
      'nonprocess))

(defun Process-Regulated-Q-Code (process)
  "If it's a circumstantial...."
  (if (term-type-p process 'circumstantial) 'processregulated 'notprocessregulated))

(defun Processual-Q-Code (onus)
  "If it's a process...."
  (if (term-type-p onus 'process) 'processual 'nonprocessual))

(defun Projected-ID-Code (process)
  "Return the saying or phenomenon feature."
  (or (fetch-subc-feature 'saying process)
      (fetch-subc-feature 'phenomenon process)))

(defun Projection-Q-Code (onus)
  "Type of ONUS should indicate projection (e.g. verbal and mental processes)."
  (if (or (and (term-type-p onus 'verbal-process)
	       (term-type-p (fetch-subc-feature 'saying onus) 'process))
	  (term-type-p onus 'mental-process))
      'projected
      'notprojected))

(defun Projector-ID-Code (process)
  "Return the process."
  process)

(defun Projector-Time-ID-Code (projected)
  "Return the time of the projecting process."
  (or (fetch-feature 'reference-time-id (term-graph-parent (symbol-value projected)))
      'timenow))

(defun Prominent-Purpose-Relation-Q-Code (cause)

  (if (term-type-p (fetch-subc-feature 'range cause) 'process) 'nonprominent 'prominent))

; john patch 20/5/96 - was unprepared for numbers...
; john patch 5/99 - was unprepared for complexes...
; john patch 6/99 - how can it possibly have been correct to ignore property-ascriptions
;                   with ranges?????
#+ignore
(defun Property-Q-Code (onus)
  "Is it a quality?"
  (cond ((numberp onus)
	 'notproperty)
	((or (term-type-p onus 'quality)
	     (and (term-type-p onus 'property-ascription)
		  (fetch-subc-feature 'domain onus)
		  (not (fetch-subc-feature 'range onus)))
	     (when (term-type-p (term-graph-parent (symbol-value onus)) 'object)
	       (and (term-type-p onus 'process)
		    (fetch-subc-feature 'participant onus))))
	 'property)
	(t
	 'notproperty)))

(defun Property-Q-Code (onus)
  "Is it a quality?"
  (cond ((numberp onus)
	 'notproperty)
	((or (term-type-p onus 'quality)
	     (and (term-type-p onus 'property-ascription)
		  (fetch-subc-feature 'domain onus)
                  ;; (not (fetch-subc-feature 'range onus))  WHAT?
                  (fetch-subc-feature 'range onus))
	     (when (term-type-p (term-graph-parent (symbol-value onus)) 'object)
	       (and (term-type-p onus 'process)
		    (fetch-subc-feature 'participant onus))))
	 'property)
	((and (consp (symbol-value onus))
	      (every #'(lambda (x)
			 (equal (property-q-code X)
				'PROPERTY))
		     (symbol-value onus)))
	 'property)
	(t
	 'notproperty)))


(defun Property-Quality-Q-Code (onus)
  "Is it a quality?"
  (if (or (term-type-p onus 'manner)
	  (term-type-p onus 'quality)
	  (term-type-p (fetch-subc-feature 'range onus) 'quality))
      'property 
      'notproperty))

(defun Proposal-Q-Code (action)
  "If the type of the projector of ACTION is Non-Addressee-Oriented, then not proposal."
  (if (or (and (term-type-p (term-graph-parent (symbol-value action)) 
			    'Mental-Process)
	       (not (term-type-p (term-graph-parent (symbol-value action)) 
				 'reaction))
	       (fetch-subc-feature 'event-time action))
	  (term-type-p (term-graph-parent (symbol-value action)) 
		       'Non-Addressee-Oriented-Verbal-Process))
      'notproposal
      'proposal))

(defun Propositionality-Q-Code (onus)
  "Propositional, if it's a process and not a participant."
  (if (and (term-type-p onus 'process)
	   (term-graph-parent (symbol-value onus))
	   (if (not (term-role-p (term-graph-parent (symbol-value onus)) onus 'saying))
	       (not 
		 (or (term-role-p (term-graph-parent (symbol-value onus)) onus 'participant)
		     (term-role-p 
		       (term-graph-parent (symbol-value onus)) onus 'role-relation))) 
	       t))
      'propositional 
      'nonpropositional))

(defun Provenance-ID-Code (obj)
  "Return the feature."
  (fetch-relation-range 'provenance-property-ascription obj))

(defun Provenance-Modification-Q-Code (obj)
  "Look for a PROVENANCE feature."
  (if (fetch-minimal-relation 'provenance-property-ascription obj) 'Provenance))

(defun Purpose-Condition-Q-Code (part1 part2)
  "See if the parent is a PURPOSE."
  (declare (ignore part2))
  (if (term-type-p (term-graph-parent (symbol-value part1)) 'purpose)
      'purposecondition 
      'nonpurposecondition))

#+ignore
(defun Purpose-ID-Code (process)
  "Return the purpose feature."
  (fetch-subc-feature 'purpose process))

(defun Purpose-ID-Code (process)
  "Return the purpose feature."
  (fetch-relation-spec process 'purpose 'Purpose-ID))

(defun Purpose-Q-Code (relation)
  "Is the relation a purpose feature?"
  (if (term-type-p relation 'purpose) 'purpose 'nonpurpose))

(defun Purpose-Relation-Q-Code (relation)
  "Is the relation a purpose feature?"
  (if (term-type-p relation 'purpose) 'purpose 'notpurpose))

(defun Quantification-ID-Code (spec)
  "Return the quantity-ascription feature."
  (fetch-subc-feature 'quantity-ascription spec)
  ;(fetch-relation-spec spec 'quantity-ascription 'QUANTIFICATION-ID)
)

(defun Quantification-Q-Code (spec)
  "Is there a quantity ascription?"
  (if (fetch-subc-feature 'quantity-ascription spec) 'quantified))

(defun Quantity-Q-Code (object)
  "Is it a number?"
  (if (numberp object) 'quantity 'notquantity))

(defun Quantity-Selection-ID-Code (object)
  "Look for quantity feature."
  (fetch-subc-feature 'quantity-selection object))

(defun Quantity-Selection-Q-Code (object)
  "Look for quantity feature."
  (if (fetch-subc-feature 'quantity-selection object) 'quantity))

(defun Question-Q-Code (speech-act)
  "Is the type of the speech-act term QUESTION?"
  (if (term-type-p speech-act 'question) 'question 'nonquestion))

(defun Question-Item-ID-Code (onus)
  "Return an appropriate participant, or else give back ONUS."
  (or (fetch-subc-feature 'domain onus)
      (fetch-subc-feature 'actor onus)
      onus))

(defun Quotation-Q-Code (projected projector)
  
  (declare (ignore projected))
  (when (fetch-subc-feature 'quote projector) 'quotation))

(defun Reaction-Q-Code (mentalprocess)
  "Is it of type REACTION?"
  (if (term-type-p mentalprocess 'reaction) 'reaction 'nonreaction))

(defun Reader-Knowledge-Path-ID-Code (subject1 subject2)
  "If the subjects are the same, then identify this as the thematic path."
  (if (term-eq-p subject1 subject2) 'thematic-path 'included-path))

(defun Reason-Q-Code (relation)
  "Is the relation a reason feature?"
  (if (term-type-p relation 'reason) 'reason 'nonreason))

(defun Reason-ID-Code (process)
  "Return the REASON feature."
  (fetch-relation-spec process 'reason 'Reason-ID))

(defun ReExpression-Q-Code (conjunctive)
  "Depends on type of conjunctive."
  (if (term-type-p conjunctive 'restatement) 'reexpression 'notreexpression))

(defun Reference-Time-ID-Code (occurrence)
  "Find the event time feature of the occurrence term."
  (or (fetch-feature 'event-time occurrence)
      (fetch-feature 'event-time (get-symbol-term occurrence))))

(defun Referent-Specificity-Q-Code (reln range)
  "Look for a between feature."
  (declare (ignore range))
  (if (term-type-p reln 'specific-matter) 
      'highspecificty
      (when (term-type-p reln 'diffuse-matter) 'lowspecificity)))

(defun Region-ID-Code (address)
  "find year, if month/year, else find month for day/month."
  (or (fetch-feature 'year address)
      (fetch-feature 'month address)
      (fetch-feature 'latitude address)))

(defun Related-Conjunctive-ID-Code (conjrel)
  "If a DOMAIN role is specified, use that.  Otherwise, gensym."
  (or (fetch-feature 'domain conjrel)
      (gentemp)))

(defun Relative-Position-Q-Code (relation)
  "This first approach just asks if RELATION is a RHETORICAL-RELATION."
  (if (term-type-p relation 'rhetorical-relation) 'immediate 'notimmediate))

(defun Relative-Pronoun-Selection-Q-Code (participant)
  "See if the grand-parent of PARTICIPANT is an ELABORATION."
  (if  (and (term-graph-parent (symbol-value participant)) 
	    (term-graph-parent (symbol-value (term-graph-parent (symbol-value participant)))) 
	    (term-type-p 
	      (term-graph-parent (symbol-value (term-graph-parent (symbol-value participant))))
	      'rst-elaboration))
      'which
      'that))

(defun Report-ID-Code (process)
  "Return the SAYING feature."
  (fetch-subc-feature 'saying process))

(defun Report-Q-Code (process)
  "Use the parent of process to decide."
  (if (or (term-type-p (term-graph-parent (symbol-value process)) 'verbal-process)
	  (term-type-p (term-graph-parent (symbol-value process)) 'mental-process))
      'report
      'nonreport))

(defun Resemblance-Q-Code (manner)
  ;;; Implemented for MANNER defined by PROCESS-MANNER-ID-CODE;
  ;;; seeking SIMILARITY role.
  (if (and (fetch-feature 'domain manner) 
	   (fetch-feature 'range manner) 
	   (term-eq-p (fetch-subc-feature 'similarity (fetch-feature 'domain manner))
		 (fetch-feature 'range manner)))
      'resemblance))

(defun Restatement-Elaboration-Q-Code (one two)
  "If the parent is an EXEMPLIFICATION...."
  (declare (ignore two))
  (if (term-type-p (term-graph-parent (symbol-value one)) 'restatement) 
      'restatement 
      'notrestatement))

(defun Role-ID-Code (process)
  "Return the role-playing feature."
  (fetch-relation-spec process 'role-playing 'Role-ID))

(defun Role-Q-Code (process)
  "Look to see if there is a role-playing feature."
  (if (fetch-relation 'role-playing process) 'rolerestricted 'notrolerestricted))

(defun Role-Relation-Q-Code (reln)
  "Look to see if the variable--a relation--is a role-playing."
  (if (term-type-p reln 'role-playing) 'rolerelation 'notrolerelation))

(defun Same-As-Q-Code (first second)
  "Either first and second should be EQ, or their symbols should be."
  (or (if (and (boundp first)
	   (not (symbolp (symbol-value first))))
      (if (and (boundp second)
	       (not (symbolp (symbol-value second))))
	  (if (eq (term-graph-symbol (symbol-value first))
		  (term-graph-symbol (symbol-value second))) 'same)
	  (if (eq (term-graph-symbol (symbol-value first)) second) 'same))
      (if (and (boundp second)
	       (not (symbolp (symbol-value second))))
	  (if (eq first (term-graph-symbol (symbol-value second))) 'same)
	  (if (eq first second) 'same)))
      (if (and (boundp first)
	       (boundp second)
	       (typep (symbol-value first) 'term-graph)
	       (typep (symbol-value second) 'term-graph)
	       (eq (term-graph-type (symbol-value first)) 'um-set)
	       (eq (term-graph-type (symbol-value second)) 'um-set)
	       (not (set-difference 
		      (term-graph-symbol (symbol-value first)) 
		      (term-graph-symbol (symbol-value second)) 
		      :test 'term-eq-p)))
	  'same)))

(defun Sayer-ID-Code (process)
  "Return the SAYER feature."
  (fetch-subc-feature 'sayer process))

;;; John: May99
;;; Also need to extend the following so that a set of qualities
;;; can be checked for scalability...
#+ignore
(defun Scalability-Q-Code (dimension)
  "If the DIMENSION's range is a SCALABLE-QUALITY, then SCALABLE."
  (let ((quality (fetch-subc-feature 'range dimension)))
    (if quality
	(if (term-type-p quality 'scalable-quality) 'scalable 'nonscalable))))

(defun Scalability-Q-Code (dimension)
  "If the DIMENSION's range is a SCALABLE-QUALITY, then SCALABLE."
  (let ((quality (fetch-subc-feature 'range dimension)))
    (if quality
	(cond ((and (term-type-p quality 'um-set)
		    (loop for p 
			in (term-graph-symbol (symbol-value quality))
			always (term-type-p p 'scalable-quality)))
	       'scalable)
	      ((term-type-p quality 'scalable-quality)
	       'scalable)
	      (t 'nonscalable))
      'nonscalable)))
(defun Scaling-Q-Code (dimension)
  "If the DIMENSION is a scaled-comparison, then SCALED."
  (if (term-type-p dimension 'scaled-comparison)
      'scaled 
      'nonscaled))

(defun Selection-Particularity-Q-Code (obj1 obj2)
  "For now, if it's unique, based on determiner."
  (declare (ignore obj2))
  (if (eq (fetch-feature 'determiner obj1) 'one) 'particular))

(defun Senser-ID-Code (mentalprocess)
  "Return the senser feature."
  (fetch-subc-feature 'senser mentalprocess))

(defun Sequence-Q-Code (conjunctive)
  "Depends on type of conjunctive."
  (if (term-type-p conjunctive 'anterior) 'notsequence 'sequence))

(defun Set-Totality-Q-Code (ob1 ob2)
  "Who knows?"
  (declare (ignore ob2)) 
  (if (eq (fetch-feature 'determiner ob1) 'all) 'total))

(defun Similarity-Relation-Q-Code (reln)
  "Is it a similarity relation?"
  (if (term-type-p reln 'similarity) 'similarityrelation 'notsimilarityrelation))

(defun Singularity-Q-Code (item)
  "If (Multiplicity-Q ITEM) = MULTIPLE or type of item is QUALITY, then NONSINGULAR."
  (if (or (eq (Multiplicity-Q-code item) 'multiple)
	  (term-type-p item 'quality)
	  (term-type-p item 'substance)
	  ;(term-type-p item 'process)
	  (eq (fetch-feature-symbol 'number item) 'multiple)
          (and (numberp (fetch-feature 'ordination-id item))
               (> (fetch-feature 'ordination-id item) 1))
	  (eq (fetch-feature-symbol 'number (get-symbol-term item)) 'multiple))
      'nonsingular))

(defun Size-Modification-Q-Code (obj)
  "Look for a SIZE feature."
  (if (fetch-minimal-relation 'size-property-ascription obj) 'Size))

(defun Size-Modifier-ID-Code (obj)
  "Return the SIZE feature."
  (or (fetch-subc-feature 'size-property-ascription obj)
      (fetch-feature 'range (fetch-reified-relation 'size-property-ascription obj))))

(defun Source-Destination-Process-Q-Code (locativerelation place)
  "Is the relation one of source-destination?"
  (declare (ignore place)) 
  (if (term-type-p locativerelation 'Source-Destination)
      'sourcedestination
      'nonsourcedestination))

(defun Source-Destination-Q-Code (reln process)
  "Is the relation one of source-destination?"
  (declare (ignore process))
  (if (term-type-p reln 'source-destination)
      'sourcedestination 
      'nonsourcedestination))

(defun Source-Process-Q-Code (locativerelation place)
  "Is the relation one of source?"
  (declare (ignore place)) 
  (if (term-type-p locativerelation 'Source)
      'source
      'nonsource))

(defun Source-Q-Code (reln process)
  "Is the relation a source?"
  (declare (ignore process)) 
  (if (term-type-p reln 'source) 'source 'notsource))

(defun Space-Condition-Q-Code (part1 part2)
  "See if the parent is a SPACE-CONDITION."
  (if (or (term-eq-p part2 (fetch-subc-feature 'spatial-relation part1))
	  (and (term-type-p (term-graph-parent (symbol-value part1)) 'spatial-relation)
	       (fetch-subc-feature 'range (term-graph-parent (symbol-value part1)))
	       (term-type-p (fetch-subc-feature 'range (term-graph-parent (symbol-value part1))) 'process)))
      'spacecondition 
      'nonspacecondition))

(defun Spatial-Extent-ID-Code (process)
  "Return the spatial extent feature of the entry term with its value."
  (fetch-relation-spec process 'spatial-extent 'SPATIAL-EXTENT-ID))

(defun Spatial-Extent-Specification-Q-Code (process)
  "Look for a spatial extent feature of the entry term."
  (if (fetch-relation 'spatial-extent process) 'spatialextent))

(defun Spatial-Location-ID-Code (process)
  "Return a (possibly new) reified spatial location relation.
   Special case:  if the range is a relative location, then return it alone, eliminating the 
   relation."
  (if (or (term-type-p (or (fetch-subc-feature 'spatial-locating process)
		       (fetch-subc-feature 'range (fetch-relation 'spatial-locating process)))
		       'relative-spatial-temporal)
	  (term-type-p (or (fetch-subc-feature 'spatial-locating process)
		       (fetch-subc-feature 'range (fetch-relation 'spatial-locating process)))
		       'quality))
      (or (fetch-subc-feature 'spatial-locating process)
	  (fetch-subc-feature 'range (fetch-relation 'spatial-locating process)))
      (fetch-relation-spec process 'spatial-locating 'SPATIAL-LOCATION-ID)))

(defun Spatial-Location-Specification-Q-Code (process)
  "Look for a spatial location feature of the entry term."
  (if (and (fetch-relation 'spatial-locating process)
	   (if (fetch-subc-feature 'spatial-locating process)
	       (not (pledged-p (fetch-subc-feature 'spatial-locating process)))
	       t)
	   (if (fetch-reified-relation 'spatial-locating process)
               ;;
               ;; the pledge-p returns t on NIL which is not very useful
               ;; JB 17.3.06
               (if (fetch-feature 'range 
                                   (fetch-reified-relation 'spatial-locating process))
                   (not 
                    (pledged-p 
                     (fetch-feature 'range (fetch-reified-relation 'spatial-locating process))))
                 t)
	       t))
      'spatiallocation))

(defun Spatial-Completion-Specification-Q-Code (process)
  "Look for a spatial location feature of the entry term that serves to complete the specified process."
  (let ((relns (fetch-subc-features 'spatial-locating process)))
    (loop for r in relns
	  if (or (term-type-p r 'source-destination)
		 (term-type-p r 'spatial-ordering))
	  do (return-from Spatial-Completion-Specification-Q-Code 
			    'SPATIALLOCATION))
    'NOSPATIALLOCATION))

(defun SPATIAL-COMPLETION-ID-Code (process)
  "Look for a spatial location feature of the entry term that serves to complete the specified process."
  (let ((relns (fetch-subc-features 'spatial-locating process)))
    (loop for r in relns
	  if (or (term-type-p r 'source-destination)
		 (term-type-p r 'spatial-ordering))
	  do (return-from Spatial-Completion-id-code r))
    nil))

(defun Spatio-Temporal-Type-Q-Code (reln)
  "Classify on the basis of type."
  (if (term-type-p reln 'spatial-relation) 'spatial
      (if (term-type-p reln 'temporal-relation) 'temporal)))

(defun Speaker-ID-Code (onus)
  "Return the SPEAKER feature?"
  (fetch-feature 'speaker onus))

(defun Speech-Act-ID-Code (onus)
  "Find the speech-act feature of the entry term."
  (or (fetch-feature 'speech-act onus)
      (fetch-feature 'speech-act (get-symbol-term onus))
      (if (term-type-p onus 'relational-process)
	  (fetch-feature 'speech-act-id (fetch-subc-feature 'domain onus)))
      (if (or (term-type-p onus 'um-set)
	      (term-type-p onus 'disjunctive-set))
	  (fetch-feature 'speech-act-id (first (term-graph-symbol (symbol-value onus)))))))

(defun Speaking-Time-ID-Code (speechact)
  "Return the time of the speech-act, or else TIMENOW."
  (or (fetch-feature 'speakingtime speechact)
      (fetch-feature 'speakingtime (get-symbol-term speechact))))

(defun Standard-ID-Code (quality dimension)
  "Return the STANDARD role of DIMENSION."
  (declare (ignore quality))
  (fetch-subc-feature 'standard dimension))

(defun Standard-Mention-Q-Code (spec standard)
  "Mention, unless the special case."
  (declare (ignore spec))
  (when (term-eq-p standard '?standard) 'withhold))

(defun Standard-Value-ID-Code (standard property)
  "Let the standard speak for itself."
  (declare (ignore property))
  standard)

(defun Statement-Q-Code (speech-act)
  "Is the type of the speech-act term ASSERT?"
  (if (term-type-p speech-act 'assertion t) 'statement 'nonstatement))

(defun Static-Condition-Q-Code (process)
  "Is the process relational?"
  (if (term-type-p process 'relational-process) 'static 'nonstatic))

(defun Status-Modification-Q-Code (obj)
  "Look for any PROPERTY-ASCRIPTION feature, making sure you only pick out DOMAINs."
  (if (and (fetch-minimal-relation 'property-ascription obj)
	   (and (not  (pledged-p (fetch-minimal-relation 'property-ascription obj)))
		(if (fetch-feature 'range (fetch-minimal-relation 'property-ascription obj))
		    (not (pledged-p (fetch-feature 
				      'range 
				      (fetch-minimal-relation 'property-ascription obj))))
		    t))
	   (if (fetch-subc-feature 'domain 
			       (fetch-minimal-relation 'property-ascription obj))
	       (eq (term-graph-symbol 
		 (symbol-value 
		   (fetch-subc-feature 'domain 
				       (fetch-minimal-relation 'property-ascription obj))))
	       (term-graph-symbol (symbol-value obj)))
	       t))
      'Status))

(defun Status-Modifier-ID-Code (obj)
  "Return the feature."
  (fetch-relation-range 'property-ascription obj))

(defun Subclass-ID-Code (item)

  (fetch-feature 'class-ascription item))

(defun SubTen-Position-ID-Code (number)
  "The remainder of NUMBER when divided by ten gives the sub-ten position."
  (rem number 10))

;;; John: Apr96: this was also just wrong, failing to take account of teens.
(defun SubTen-Position-Q-Code (number)
  "If there's a remainder of NUMBER when divided by ten, there's a sub-ten position."
  (let ((supraten (supraten-position-id-code number)))
    (if (and (< supraten 20)(> supraten 10))
	'notsubtenposition
      (if (not (eql 0 (rem number 10)))
	  'subtenposition
	'notsubtenposition))))

;;; John: Apr96: this was also just wrong, failing to take account of teens.
(defun SupraTen-Position-ID-Code (number)
  "A wierd function of NUMBER gives the supra-ten position."
  (let ((tens (rem number 100)))
    (if (and (> tens 10)(< tens 20))
	tens
      (rem (- number (rem number 10)) 100))))

;;; John: Apr96: this was also just wrong, failing to take account of teens.
(defun SupraTen-Position-Q-Code (number)
  "A wierd function of NUMBER tells if there are or are not supra-ten positions."
  (if (eql (supraten-position-id-code number) 0)
      'notsupratenposition
      'supratenposition))

(defun Symbol-ID-Code (identity)
  "Return the domain of the IDENTITY."
  (fetch-subc-feature 'domain identity))

(defun Symbolization-Q-Code (reln)
  "Depends on type of RELN."
  (if (term-type-p reln 'symbolization) 'symbolization 'notsymbolization))

(defun Symbolized-ID-Code (identity)
  "Return the range of the IDENTITY."
  (or (fetch-subc-feature 'range identity)
      (term-graph-parent (symbol-value identity))))

;;; john 9/02. The following looks like a good source of problems. It should
;;   be possible to have some more general notion of taxis prominence
;;   here instead of all these individual checks...

(defun Taxis-Prominence-Q-Code (part1 part2)
  "Probably depends on the type of conjunctive relation.
   For the time being, if they are just set elements, return NOTLESS."
  (if (or (term-type-p (term-graph-parent (symbol-value part1)) 'symmetric-rhetorical-relation)
	  (term-type-p (term-graph-parent (symbol-value part1)) 'conjunction)
	  (term-type-p (term-graph-parent (symbol-value part1)) 'disjunction)
;; john, 9/02. now, why was the following added... since it messes up things and it
;;  is not true that a logical-condition is automatically paratactic. Examples where
;;  we have an if-then are impacted by the following, since if-then is not generated
;;  as a paratactic relation (should it perhaps?). Cf. reuters-1.
;; 	  (term-type-p (term-graph-parent (symbol-value part1)) 'logical-condition) ;;JB 28.ii.02
	  (and (term-type-p (term-graph-parent (symbol-value part1)) 'rhetorical-relation)
	       (term-type-p (term-graph-parent (symbol-value part1)) 'restatement))
	  (and (or (term-type-p (term-graph-parent (symbol-value part1)) 'rhetorical-relation)
		   (term-type-p (term-graph-parent (symbol-value part1)) 'temporal-ordering)  ;;; PRIMER-49
		   (term-type-p (term-graph-parent (symbol-value part1)) 'static-spatial))
	       (eq part1 
		   (fetch-subc-feature 'domain (term-graph-parent (symbol-value part1)))))
	  (and (fetch-subc-feature 'temporal-ordering part1)                                  ;;; PRIMER-49
	       (or (term-type-p (fetch-subc-feature 'temporal-ordering part1) 'process)
		   (eq 'multiple (multiple-process-q-code (fetch-subc-feature 'temporal-ordering part1)))))
	  (and (fetch-subc-feature 'static-spatial part1)                                     ;;; EX-SET-13
	       (or (term-type-p (fetch-subc-feature 'static-spatial part1) 'process)
		   (eq 'multiple (multiple-process-q-code (fetch-subc-feature 'static-spatial part1)))))
	  (and (fetch-subc-feature 'condition part1)
	       (or (term-type-p (fetch-subc-feature 'condition part1) 'process)
		   (eq 'multiple (multiple-process-q-code (fetch-subc-feature 'condition part1)))))
	  (dolist (graph *plan-graphs*)
	    (and (or (and (term-type-p graph 'um-set)
			  (not (term-type-p graph 'ordered-set)))
		     (term-type-p graph 'disjunctive-set))
		 (or (member part1 (term-graph-symbol (symbol-value graph)))
		     (term-eq-p part1 graph))
		 (or (member part2 (term-graph-symbol (symbol-value graph)))
		     (term-eq-p part2 graph))
		 (return 't))))
      'notless
      'less))

(defun Teen-Q-Code (entity)
  "Just compare to twelve."  
  (if  (> entity 12) 'teen 'notteen))

(defun Teen-Type-Q-Code (entity)
  "Just give ENTITY back, spelled out."  
  (case entity
    (13 'thirteen)
    (14 'fourteen)
    (15 'fifteen)
    (16 `sixteen)
    (17 'seventeen)
    (18 'eighteen)
    (otherwise 'nineteen)))

(defun Temporal-Definiteness-Specification-Q-Code (process)
  "Look for an event-time feature of the entry term."
  (if (or (fetch-subc-feature 'event-time process)
	  (if (get-symbol-term process) 
	      (fetch-subc-feature 'event-time (get-symbol-term process)))) 
      'specified 
      'notspecified))

(defun Temporal-Enhancement-Q-Code (alphaid betaid)
  "Depends on relation between ALPHAID and BETAID."
  (if (term-role-p alphaid betaid 'temporal-relation) 
      'temporalsuccession 
      'nottemporalsuccession))

(defun Temporal-Extent-ID-Code (process)
  "Return the temporal extent feature of the entry term and its value."
  (fetch-relation-spec process 'temporal-extent 'TEMPORAL-EXTENT-ID))

(defun Temporal-Extent-Specification-Q-Code (process)
  "Look for a temporal extent feature of the entry term."
  (if (fetch-relation 'temporal-extent process) 'temporalextent))

(defun Temporal-Location-ID-Code (process)
  "Return a (possibly new) reified temporal location relation.
   Special case:  if the range is a relative location, then return it alone, eliminating the 
   relation."
  (let ((time (or (fetch-subc-feature 'temporal-locating process)
		  (fetch-subc-feature 'range (fetch-relation 'temporal-locating process)))))
    (if (or (term-type-p time 'relative-spatial-temporal)
;	    (and (term-type-p time 'date)
;		 (not (or (fetch-subc-feature 'day time)
;			  (fetch-subc-feature 'month time)
;			  (fetch-subc-feature 'year time))))
	    )
	time
	(fetch-relation-spec process 'temporal-locating 'TEMPORAL-LOCATION-ID))))

(defun Temporal-Location-Specification-Q-Code (process)
  "Look for a temporal location feature of the entry term."
  (if (and (fetch-relation 'temporal-locating process)
	   (if (fetch-subc-feature 'temporal-locating process)
	       (not (pledged-p (fetch-subc-feature 'temporal-locating process)))
	       t)
	   (if (fetch-reified-relation 'temporal-locating process)
	       (not (pledged-p (fetch-feature 'range (fetch-reified-relation 'temporal-locating process))))
	       t))
      'temporallocation))

(defun Temporal-Qual-Q-Code (obj)
  "Look for a temporal-locating relation."  ;; Should we also find reified relations? -- BK
  (if (and (fetch-subc-feature 'temporal-locating obj)
	   (not (pledged-p (fetch-subc-feature 'temporal-locating obj))))
      'temporal))

(defun Ten-Digit-ID-Code (number)
  "Return the number of tens."
  (floor (mod number 100) 10))

(defun Ten-Digit-Q-Code (number)
  "Only if greater than 10."
  (if (> number 9) 'yes 'no))

(defun One-number-value-Q-Code (number)
  (if (= number 1) 'one 'not-one))


;;;================================================================================
;;; KOMET-PENMAN: 
;;; Lexical resolution now done by separate code module 

(defun term-resolve-id-code (concept association)
  (LEXICAL-TERM-RESOLUTION concept association))

;;;================================================================================
		      
(defun Thousand-Digit-ID-Code (number)
  "Return the number of thousands."
  (floor number 1000))

(defun Thousand-Digit-Q-Code (number)
  "Only if greater than 999."
  (if (> number 999) 'yes 'no))

(defun Thousand-Position-ID-Code (number)
  "Return the integer part of the quotient."
  (mod (floor number 1000) 1000))

(defun Thousand-Position-Q-Code (entity)
  "Only if greater than 999."
  (if (or (and (> entity 1000000)
	       (> (- entity (* (floor entity 1000000) 1000000)) 999))
	  (and (< entity 1000000)
	       (> entity 999)))
      'thousandposition 
      'notthousandposition))

;;; ----------------------------------------
;;; Hacked: john. The numbers were misbehaving.
(defun Thousand-Unit-Q-Code (number)
  "Only if greater than 1000." 
  (if (>= number 1000)  'thousand 'notthousand))

(defun thousand-unit-value-id-code (number)
  (cond ((>= number 1000)
	 (floor (/ number 1000)))
	(t 
	  number)))
;;;----------------------------------------

(defun Time-Condition-Q-Code (part1 part2)
  "See if the parent is a TIME-CONDITION.
  Or if there's a TEMPORAL-RELATION feature."
  ;(declare (ignore part2))
  (if (or (term-eq-p part2 (fetch-subc-feature 'temporal-relation part1))
	  (and (term-type-p (term-graph-parent (symbol-value part1)) 'temporal-relation)
	       (fetch-subc-feature 'range (term-graph-parent (symbol-value part1)))
	       (term-type-p (fetch-subc-feature 'range (term-graph-parent (symbol-value part1))) 'process)))
      'timecondition 
      'nontimecondition))

(defun Time-Dimension-Q-Code (temporal-relation range)
  "Depends on the type of RANGE."
  (declare (ignore temporal-relation))
  (if (term-type-p range 'one-or-two-d-time) 'onetwodimension
      (if (term-type-p range 'three-d-time) 'threedimension)))

(defun Time-Inclusion-Q-Code (reln)

  (when (term-type-p reln 'temporal-inclusive) 'included))

(defun Time-In-Relation-ID-Code (speaking-time event-time tempo1)
  "Favor event-time over speaking-time until more is needed--or understood."
  (declare (ignore speaking-time tempo1))
  event-time)

(defun Time-In-Relation-To-Speaking-Time-ID-Code (speaking-time speech-act)
  "Favor event-time over speaking-time until more is needed."
  (declare (ignore speaking-time))
  (fetch-feature 'event-time 
		     (term-graph-parent (symbol-value (if (boundp speech-act) speech-act
							  (get-symbol-term speech-act))))))

(defun Time-Ordering-Q-Code (time-relation)
  "Check if TIMERELATION is ordered."
  (if  (term-type-p time-relation 'Temporal-ordering) 'ordered 'unordered))

(defun Time-Period-Mod-ID-Code (obj)
  "Return a temporal-locating relation, reifying if necessary."
  (fetch-relation-spec obj 'temporal-locating 'TIME-QUAL-ID))

(defun Time-Point-Q-Code (temporal-relation range)
  "Depends on the type of RANGE."
  (declare (ignore temporal-relation))
  (if (term-type-p range 'time-point) 'point 'interval))

;(defun Time-Precedence-Q-Code (temporal-relation)
;  "Depends on type of relation."
;  (if (term-type-p temporal-relation 'anterior) 'precedence 'noprecedence))

(defun Time-Precedence-Q-Code (temporal-relation)
  "Depends on type of relation."
  (if (and (term-type-p temporal-relation 'temporal-ordering)
	   (not (term-type-p temporal-relation 'concurrent))) 'precedence 'noprecedence))

;(defun Time-Precede-Q-Code (temporal-relation)
;  "Depends on type of relation."
;  (if (term-type-p temporal-relation 'anterior) 'subsequent 'notsubsequent))

(defun Time-Precede-Q-Code (temporal-relation)
  "Depends on type of relation."
  (if (term-type-p temporal-relation 'posterior) 'subsequent 'notsubsequent))

(defun Time-Relation-Q-Code (temporal-relation)
  "Depends on type of relation."
  (if (term-type-p temporal-relation 'Temporal-Locating) 'timerelation 'nottimerelation))

(defun Time-Q-Code (obj)
  "Is OBJ a time (time-placement)?"
  (if (term-type-p obj 'time-placement) 'time 'notime))

(defun Type-ID-Code (ps)
  "Give back the object of the membership relation."
  (fetch-subc-feature 'element-of ps))

(defun Type-Q-Code (ps)
  "Is PS a kind of set?"
  (if (term-type-p ps 'ordered-set) 'type 'nontype))

(defun Typic-Q-Code (item)
  "Is there a membership relation?"
  (if (fetch-subc-feature 'element-of item)
      'typic 'nontypic))

(defun Umty-Type-Q-Code (entity)
  "How many times ten is it?" 
  (case (floor (/ entity 10))
    (2 'twenty)
    (3 'thirty)
    (4 'forty)
    (5 'fifty)
    (6 `sixty)
    (7 'seventy)
    (8 'eighty)
    (otherwise 'ninety)))

(defun Units-Digit-ID-Code (number)
  "This is the number MOD power-of-ten."
  (mod number 10))

(defun Unit-Value-ID-Code (number)
  "This is the basis of the Western number system (English), changing
   the base list changes the units the number system works on."
  (cond ((< number 20)
	 number)
	((>= number 1000000)
	 (floor (/ number 1000000)))
	((>= number 1000)
	 (floor (/ number 1000)))
	((>= number 100)
	 (floor (/ number 100)))
	((>= number 10)
	 number)
	(t number)))

(defun Unrealized-Situation-Q-Code (item)
  "Depends upon presence of relevant time information."
  (if (or (fetch-feature 'event-time item)
	  (fetch-feature 'reference-time-id item))
      'notunrealized 
      'unrealized))

(defun Use-Modification-ID-Code (obj)
  "Return the USE-PROPERTY-ASCRIPTION feature."
   (fetch-relation 'use-property-ascription obj))

(defun Use-Modification-Q-Code (obj)
  "Look for a USE-PROPERTY-ASCRIPTION feature."
  (if (fetch-relation 'use-property-ascription obj) 'use))

(defun Verbal-Act-Category-ID-Code (process)
  "Return the SAYING feature."
  (fetch-relation-range 'saying process))

;;; john: 6/99, following looks a bit odd, why do we need to bother
;;;  with a *range* of the thing being said...  this may have been
;;;  going through because of the weaker SPL access function definitions
;;;  prior to KPML 2.1. Changed here experimentally to check that 
;;;  nothing untoward happens. What the implementation now does is
;;;  check whether the thing being said is a process or not (actspecified).
;;;  Inquiry checks whether we generate, e.g., I understand the answer vs.
;;;  I understand that I need the answer.
;;; john: 9/02, not quite broad enough, since if we happen to be
;;;  saying a clause complex, then we do not pick this up with
;;;  subtype of process. Verbal-act-category-id also added at this
;;;  point, since this also just looked at the range for some
;;;  reason. Added with an 'or' just in case and to be very
;;;  cautious.

(defun Verbal-Act-Category-ID-Code (process)
  "Return the SAYING feature."
  (or
   (fetch-relation 'saying process)
   (fetch-relation-range 'saying process)
   ))

(defun Verbal-Act-Category-Q-Code (process)
  "Does the process have a SAYING?"
  (if (and (fetch-relation 'saying process)
           ;; was:
	   ;;  (not (term-type-p (fetch-relation-range 'saying process) 'process))
	   (not
	    (or
	     (term-type-p (fetch-relation 'saying process) 'process)
	     (term-type-p (fetch-relation 'saying process) 'logical-condition)
	     (term-type-p (fetch-relation 'saying process) 'rhetorical-relation)))
           )
      'actspecified))

(defun Verbal-Process-Q-Code (process)
  "Is the process verbal?"
  (if (term-type-p process 'verbal-process) 'verbal 'notverbal))

(defun Vertical-Orientation-Q-Code (reln range)
  "Use the type of RELN."
  (declare (ignore range))
  (if (term-type-p reln 'above) 'above
      (if (term-type-p reln 'below) 'below)))

(defun Volitionality-Q-Code (modalproperty participant)
  "See if the feature introducing the MODALPROPERTY is VOLITIONAL." 
  (declare (ignore participant))
  (if (term-type-p modalproperty 'volitional) 'volitional 'nonvolitional))

(defun Wh-Concept-Q-Code (wh)
  "Depends on type of WH."
  (cond ((term-type-p wh 'temporal wh) 'time)
	((term-type-p wh 'spatial wh) 'space)
	((term-role-p wh (term-graph-parent (symbol-value wh)) 'causal-relation) 'cause)
	(t 'manner)))


;;; The following are the morphology inquiry implementations necessary
;;; at least for English.


(defun adjective-lexical-word-class-q-code (lex-entry)
  (lexical-class-ascertainer lex-entry '(er-est r-st *er-*est)))

(defun nerb-lexical-word-class-q-code (lex-entry)
  (lexical-class-ascertainer lex-entry '(noun verb)))


(defun noun-lexical-word-class-q-code (lex-entry)
  (lexical-class-ascertainer lex-entry '(s es)))



(defun verb-lexical-regularity-q-code (lex-entry)
  (case (lexical-class-ascertainer lex-entry '(regular irr *-irr s-irr es-irr))
    (irr 'irregular)
    ((*-irr s-irr es-irr) 'semi)
    (regular 'regular)))


(defun verb-class-q-code (lex-entry)
  (lexical-class-ascertainer lex-entry '(Es-Ed S-*ed S-Ed S-d *-Irr S-irr Es-Irr)))

(defun second-final-letter-q-code (lex-entry)
  (let* ((spelling (fetch-lexicon-info lex-entry 'spelling))
	 (chopped-length (1- (length spelling))))
    (if (member (subseq spelling (1- chopped-length) chopped-length) 
		'("a" "e" "o" "u")
		:test #'string-equal)
	'aeou
	'non-aeou)))

(defun final-letter-y-q-code (lex-entry)
  (let* ((spelling (fetch-lexicon-info lex-entry 'spelling))
	 (chopped-length (1- (length spelling))))
    (if (string-equal (subseq spelling chopped-length (length spelling))
		      "y")
	'y
	'non-y)))

(defun final-letter-e-q-code (lex-entry)
  (let* ((spelling (fetch-lexicon-info lex-entry 'spelling))
	 (chopped-length (1- (length spelling))))
    (if (string-equal (subseq spelling chopped-length (length spelling))
		      "e")
	'final-e
	'non-final-e)))

(defun exist-selected-stem-q-code (function)
  (if (and *activate-word-rank-and-below* 
	   (find-association function 'term))
      'stem
      'no-stem))


;;; ----------------------------------------------------------------------
;;; Process premodification additions... added Bremen, June99

(defun PREMOD-SCOPE-INCLUDES-Q-CODE (process property)
  ;; event is the entire configuration that is being used as a premodifier, 
  ;; property is the particular property that the point of overlap is being
  ;; interrogated for... Need first to get the point of overlap therefore...
  ;; don't need to do any checks since these were done to get here and the
  ;; configuration can only be one of the mentioned process types. Ignore
  ;; complexing for present...
  (let ((poo (or (fetch-feature 'actee process)
                 (fetch-feature 'phenomenon process)
                 (fetch-feature 'saying process))))
    (if 
        (fetch-feature 
         ;; should be a nicer way to do the following...
         (case property
           (age 'age-property-ascription)
           (size 'size-property-ascription)
           (provenance 'provenance-property-ascription)
           (colour 'color-property-ascription)
           (material 'material-property-ascription))
         poo)
        'includes
      'not-includes)))

(defun Process-Pre-Modification-Q-Code (onus)
  "Look for a process feature or a non-minimal reified relation or an elaboration."
  (let* ((relations (fetch-feature 'relations onus))
         (term (if (and (symbolp relations)
                        (boundp relations)
                        (term-graph-p (symbol-value relations)))
                   (symbol-value relations)
                 nil))
         (process (if (and (term-graph-p term)
                           (equal (term-graph-type term) 'um-set)
                           (= (length (term-graph-symbol term)) 1))
                      (first (term-graph-symbol term))
                    nil)))
    (if (and process
             (not (pledged-p process))
             (or (and (term-type-p process 'directed-action)
                      (fetch-feature 'actee process)
                      (term-eq-p (fetch-feature 'actee process) onus))
                 (and (term-type-p process 'mental-process)
                      (fetch-feature 'phenomenon process)
                      (term-eq-p (fetch-feature 'phenomenon process) onus))
                 (and (term-type-p process 'verbal-process)
                      (fetch-feature 'saying process)
                      (term-eq-p (fetch-feature 'saying process) onus)))
             ;; also need to put a check in here about minimality, i.e., that the
             ;; candidate configuration fits into a premodifier, which means that
             ;; it should be minimal apart from the :actee/:phenomenon/:saying
             ;; info...
             (minimal-reified-term-p (symbol-value process))
             )
        'process
      nil)))
        
(defun Process-Pre-Modification-ID-Code (onus)
  "Look for a process feature or a non-minimal reified relation or an elaboration."
  (let* ((relations (fetch-feature 'relations onus))
         (term (if (and (symbolp relations)
                        (boundp relations)
                        (term-graph-p (symbol-value relations)))
                   (symbol-value relations)
                 nil)))
    (if (and (term-graph-p term)
             (equal (term-graph-type term) 'um-set)
             (= (length (term-graph-symbol term)) 1))
        (first (term-graph-symbol term))
      (fetch-feature 'relations onus))))



