(in-package "KPML")

(defvar *not-metaphor* T)

(lexical-item :name collapse-verb :spelling "collapse" :features (LEXICAL S-D UNITARYSPELLING INFLECTABLE VERB))
(lexical-item :name bus :spelling "bus")

(LEXICAL-ITEM
    :NAME   GO-NOMINALIZATION
    :SPELLING   "going"
    :FEATURES   (NONE-OF-THATCOMP-TYPIC NONSUBSTITUTE COUNTABLE NOMINALIZATION-NOUN
                        COMMON-NOUN S NOUN)
    :PROPERTIES   ((NOMINALIZATION GO))
)

(LEXICAL-ITEM
    :NAME   COLLAPSE-NOMINALIZATION
    :SPELLING   "collapsing"
    :FEATURES   (NONE-OF-THATCOMP-TYPIC NONSUBSTITUTE COUNTABLE NOMINALIZATION-NOUN
                        COMMON-NOUN S NOUN)
    :PROPERTIES   ((NOMINALIZATION COLLAPSE))
)

(setf spl 
      '(rel / RST-Nonvolitional-Result 
	    :tense past
	    :domain (c / collapse 
		       :identifiability-q identifiable
		       :speech-act-id (t2-sa / Speech-act
					     :speaking-time-id 
					     (t2-st / time
						    :time-in-relation-to-speaking-time-id t2-et
						    :precede-q (t2-st t2-et) notprecedes))
		       :event-time (t2-et / time :precede-q (t2-et t2-st) precedes)
		       :actor (h / object :lex house))
	    :range (r / motion-process :identifiability-q identifiable 
		      :tense past 
		      :actor (b / object :lex bus) 
		      :over (b2 / object :lex bridge))))


(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-metaphor*
;	       (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 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))
      (and *not-metaphor*
	   (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 Reason-Q-Code (relation)
  "Is the relation a reason feature?"
  (if (or (term-type-p relation 'reason)
	  (term-type-p relation 'rst-nonvolitional-result))
      'reason 'nonreason))


(defun Event-Q-Code (item)
  (if (and *not-metaphor*
	   (term-type-p item 'process)) 'event 'object))





