(in-package "KPML")

;;; File: spls.lisp
;;; 
;;; Contains definition of the linguistic object: spl terms.
;;; Mostly only lightly adapted from the original SPL specification
;;; in Penman/plan-macs, etc.
;;; Contains many several additions and alterations specific for KPML.
;;; Original copyright (C) University of Southern California.
;;; This file now has the additions of Licheng Zeng and their 
;;; updates/extensions for KPML fully folded in.
;;;
;;; 2.1 information status slot added and :contextual-boundness keyword.
;;;     grammatical features may also be stated for SPL terms.
;;;     also :features and :language keywords added.
;;; 3.2 clisp use out.
;;; 4.0 a few specific mentions to UM-set had found their way in 
;;;     again rather than to a global that might change depending
;;;     on ontology. Corrected. 
;;;
;;; ......................................................................
;;;     Note that in the penman-versions of this code, there is some
;;; upper model dependency built in. Certain term-graphs are created
;;; with types that must be appropriately defined in either the upper
;;; model, or the inquiry implementations, or both. This might lead to
;;; unexpected results if not prepared for.

;;; These dependencies are now picked out here and made into globally
;;; available variables. The dependencies should be made even more
;;; explicit at some stage. For present, a note has been added to
;;; the documentation.
;;;                                              John: Kyoto: 7 Aug 94.
;;;
;;; (John: Aug09: if you want to change these, for example 
;;; for using a different KR system, then this must be done by a previous 
;;; defvar in, for example, selected-kpml-kr... These are now added
;;; to here to cover changes made in modification-specification
;;; and term-resolution (uncommented!) by Niels in 2008)
;;;
(defvar *spl-set-type* 'um-set)
(defvar *spl-disjunctive-set-type* 'disjunctive-set)

(defvar *rhetorical-relation-name* 'rhetorical-relation)
(defvar *range-name* 'range)
(defvar *domain-name* 'domain)
(defvar *thing-name* 'thing)
(defvar *upper-model-thing-name* 'um-thing)

;;; -------------------------------------------------------------------------------------------


;;; Note: also relies on two-place-relation and relation in spl-keyword-type.
;;; 1.1 the notional relational types in the following list are used when
;;;     parsing the SPL. It needs to be able to distinguish entities of 
;;;     these types as defining attributes. There absolute package of
;;;     these things depends on the package in which the upper model
;;;     is maintained however. This can be found from the kr-interface
;;;     function (kb-package). So, whenever we setup spl we now redo
;;;     the initialization of this global in case we're working with a
;;;     new upper model in a new package...

;;;niels 28.5.08 Ontology specific terms ('range, 'domain etc) were
;;externalized and are now defined in selected-kpml-kr.lisp
;;; john Aug 09: can't do it this way, since it then will fail to compile
;;;    unless these are *also* defined previously: better to leave as
;;;    it was and to make sure that the selected-kpml-kr makes
;;;   previous defvars in the cases that are necessary).

(defvar *spl-relational-types* '(two-place-relation relation))

(defun SETUP-SPL-RELATIONAL-TYPES ()
  (setf *spl-relational-types*
    (mapcar #'(lambda (type) (intern (string type) (kb-package)))
	    *spl-relational-types*)))

;;; ----------------------------------------------------------------------
;;; The basic SPL term graph structure...

(defstruct term-graph
  "Data structure to encode plan terms."
  (symbol nil :type (or atom list ))
  (id nil :type atom)
  (type nil :type (or atom list))
  (features nil :type list)
  (parent nil :type atom)
  (annotation nil)                      ;; 2.1
  (information-status nil :type list)   ;; 2.1
  (grammatical-features nil :type list) ;; 2.1
  (language nil :type atom)             ;; 2.1
  )

;;; ----------------------------------------------------------------------
;;; 4.0 following macro was not allowing the setting of the
;;;     new slots that have been introduced since KPML2.1

(defmacro MAKE-TERM-GRAPH-ID 
  (&key symbol id type features parent annotation information-status 
	language grammatical-features)
  "Returns a symbol which evaluates to a term-graph structure after entering that symbol
   as the term-graph-id."
  `(let ((term-graph-id 
	   (if ,id 
	       (intern 
		 (symbol-name 
		   (gensym 
		     (concatenate 'string (string-upcase (symbol-name ,id)) "-")))
		 (find-package 'penman))
	       (intern (symbol-name (gensym "ID")) (find-package "KPML")))))
     (set term-graph-id 
	  (make-term-graph
	    :symbol ,symbol
	    :id term-graph-id
	    :type ,type
	    :features ,features
	    :parent ,parent
	    ;;
	    ;; 4.0 -- added --
	    ;;
	    :annotation ,annotation
	    :information-status ,information-status
	    :language ,language
	    :grammatical-features ,grammatical-features))
     term-graph-id))

;;;
;;;  Macros for accessing information in term-graph structures.
;;;

(defmacro fetch-feature (feature term)
  "Produce the term-graph id of the term associated with the given feature of the given term."
  (let ((f (intern-feature feature)))
    `(if (and (symbolp ,term)
	      (boundp ,term)
	      (typep (symbol-value ,term) 'term-graph)
	      (assoc ,f (term-graph-features (symbol-value ,term))))
	 (term-id (rest (assoc ,f (term-graph-features (symbol-value ,term))))))))

(defmacro fetch-atomic-feature (feature term)
  "Produce the (expected) symbol associated with the given feature of the given term."
  (let ((f (intern-feature feature)))
    `(if (and (symbolp ,term) 
	      (boundp ,term)
	      (typep (symbol-value ,term) 'term-graph)
	      (assoc ,f (term-graph-features (symbol-value ,term))))
	 (rest (assoc ,f (term-graph-features (symbol-value ,term)))))))

(defmacro global-fetch-feature (feature term)
  "Look at all terms for the feature, not just the given term."
  `(or (fetch-feature ,feature ,term)
       (dolist (graph *plan-graphs*)
	 (if (and (not (eq graph ,term))
		  (eq (term-graph-symbol (symbol-value graph))
		      (term-graph-symbol (symbol-value ,term)))
		  (fetch-feature ,feature graph))
	     (return (fetch-feature ,feature graph))))))

;;; ----------------------------------------------------------------------
;;; 2.1 the following was regularly used in inquiry implementations, and
;;;     yet it does not respect the basic SPL notational variation of
;;;     allowing both features and reified relations in :relations slots
;;;     to be equivalent. The SPL-access function that should therefore
;;;     be used is actually fetch-relation which does both.
;;;     This means that almost everywhere that fetch-subc-feature is
;;;     used in an inquiry implementation, the proper thing to do would
;;;     have been fetch-relation. 
;;;     
;;;     This would clearly be a pain to change at this stage... so we
;;;     add in here the other disjunct of fetch-relation which uses
;;;     (fetch-reified-relation relation term) instead. 
;;;
;;;     Macro definition also tidied up considerably at this point.
;;;
;;; 4.0 The above, although necessary, is still not quite enough, as it
;;;     does not reach *inside* relations slots in the case that they
;;;     are just using variables rather than the full SPL spec at
;;;     that point. See: definition of fetch-reified-relation.
;;; ----------------------------------------------------------------------

(defmacro fetch-subc-feature (feature term)
  "Produce the symbolic id of the term associated with the given feature of the given term,
   or any feature which is a subc of the given feature.  If the term is not bound, look for
   the feature in some term having that symbol."
  (let ((f (intern-feature feature)))
    `(if (numberp ,term)
         nil
       (let ((search-space 
              (if (and (symbolp ,term) 
                       (boundp ,term)
                       (typep (symbol-value ,term) 'term-graph))
                  (symbol-value ,term)
                (symbol-value (get-symbol-term ,term)))))
         (or (dolist (a-feature (term-graph-features search-space))
               (if (or (eq (first a-feature) ,f)
                       (KB-superp (first a-feature) ,f))
                   (return (term-id (rest a-feature)))))
             (fetch-reified-relation ,f ,term))))))
       
(defmacro global-fetch-subc-feature (feature term)
  "Look at all terms for the feature, not just the given term."
  `(or (fetch-subc-feature ,feature ,term)
       (dolist (graph *plan-graphs*)
	 (if (and (not (eq graph ,term))
		  (eq (term-graph-symbol (symbol-value graph))
		      (term-graph-symbol (symbol-value ,term)))
		  (fetch-subc-feature ,feature graph))
	     (return (fetch-subc-feature ,feature graph))))))

(defmacro fetch-feature-symbol (feature term)
  "Produce the term-graph symbol of the term associated 
   with the given feature of the given term."
  (let ((f (intern-feature feature)))
  `(if (and (symbolp ,term) 
	    (boundp ,term)
	    (typep (symbol-value ,term) 'term-graph)
	    (assoc ,f (term-graph-features (symbol-value ,term))))
       (term-graph-symbol 
	(rest (assoc ,f 
		     (term-graph-features (symbol-value ,term))))))))

(defmacro fetch-subc-feature-name (feature term)
  "Produce the name of the feature which is the subc of the given feature of the given term."
  `(if (and (symbolp ,term) 
	    (boundp ,term)
	    (typep (symbol-value ,term) 'term-graph))
       (dolist (a-feature (term-graph-features (symbol-value ,term)))
	 (if (or
	      (eq (first a-feature) ,feature)  ;; 1.1 added (strict super)
	                                       ;; seems Bob did this already
	                                       ;; in the previous function...
	      (KB-superp (first a-feature) ,feature))
	     (return (first a-feature))))))


(defmacro get-symbol-term (symbol)
  "Look through *plan-graphs* for a graph whose symbol is SYMBOL."
  `(dolist (graph *plan-graphs*)
     (if (and (symbolp graph) 
	      (boundp graph)
	      (typep (symbol-value graph) 'term-graph)
	      (eq (term-graph-symbol (symbol-value graph)) ,symbol)) 
	 (return graph))))

(defmacro get-global-terms (term)
  "Get all terms in *plan-graphs* that are coreferential with term."
  (let ((good-terms (gensym)))
    `(let (,good-terms)
       (dolist (graph *plan-graphs*)
	 (if (and (not (eq graph ,term))
		  (eq (term-graph-symbol (symbol-value graph))
		      (term-graph-symbol (symbol-value ,term))))
	     (push graph ,good-terms)))
       ,good-terms)))

(defmacro get-top-level-terms (term)
  "Get all terms in *plan-graphs* that are coreferential with term."
  (let ((good-terms (gensym)))
    `(let (,good-terms)
       (dolist (graph *plan-graphs*)
	 (if (and (not (eq graph ,term)) 
		  (not (term-graph-parent (symbol-value graph)))
		  (eq (term-graph-symbol (symbol-value graph))
		      (term-graph-symbol (symbol-value ,term))))
	     (push graph ,good-terms)))
       ,good-terms)))

;;; ----------------------------------------------------------------------
;;; 2.1 with the extension to fetch-subc-feature to ignore differences 
;;;     between :relations and abbreviated forms need also now to check
;;;     explicitly that some fetch-sub-feature branches are minimal... although
;;;     this is compatible with the previous definition are should have
;;;     been I would have thought... In any case, provide the explicit
;;;     function for performing this check. Several of the fetch-subc-feature
;;;     calls in functions concerned with minimal relations below now use
;;;     the new function.
;;; ----------------------------------------------------------------------

(defun FETCH-MINIMAL-SUBC-FEATURE (relation term)
  (let ((feature (fetch-subc-feature relation term)))
    (and feature                                        ;; 2.1 the normal set of 
         (symbolp feature)                              ;;     extra-cautious type
         (boundp feature)                               ;;     checks...
         (term-graph-p (symbol-value feature))
         (minimal-reified-term-p (symbol-value feature))
         ;; 2.1 next bit is unpleasant... when we have a proper minimal domain
         ;;     and range, then give back the range, otherwise give back the
         ;;     entire thing... We expect the identifying inquiries to know
         ;;     which they want and what they want to do with it. Needs a 
         ;;     rework with the next SPL revision.
         (or 
          (fetch-subc-feature *range-name* feature)
          feature))))


(defvar *merged-terms* 
    nil "A list of sets of terms made to be equivalent in parsing.")

(defvar *merge-failure* nil "Indicates whether an incompatibility occurred when merging terms.")

;;; ----------------------------------------------------------------------
;;;  Keyword processing:
;;;  A hash table, some routines to initialize it, and a routine to access it
;;;  (together with hierarchy relations).
;;; ----------------------------------------------------------------------

;;; 0.8.19 Make the special keywords more accessible...
;;; 2.1    Annotations moved to meta.
(defvar *SPL-SPECIAL-KEYWORDS* 
  '(event-time express-type lex process relations theme 
    speech-act              ;; BK: redefine as macro?
    kpml::pattern           ;; for KPML templates
    value                   ;; for KPML-style numbers
    ))

;;; 2.1   Meta keywords added. These influence various slots of the term-graph.
;;;       June-Aug 99, John.
(defvar *SPL-META-KEYWORDS* 
  '(contextual-boundness    ;; for experiments with Prague
    annotation              ;; for KPML markup
    features                ;; for passing on grammatical feature constraints
    language                ;; for setting current language just for a specific term
    ))                            

(defvar *spl-keyword-table* (make-hash-table))

;;; The function SETUP-SPL must be called after the SPL system is loaded,
;;; and before any sentence plans are parsed.
;;; KPML 0.8: AND, when any new inquiries are loaded!
;;;           Furthermore, in merging mode, macros definitions and
;;;           default activation is *cumulative*. It is up to the user
;;;           using different defaults to explicitly begin and end
;;;           them in the appropriate places. This has to be done
;;;           in the switch-language files. Otherwise, a call to
;;;           setup-spl has as a side effect that all activedefaults
;;;           are reset and all open environments are closed.
;;;
;;; KPML 4+ : the above behaviour can be confusing to users, since
;;;           they can suddenly have their defaults reset and will
;;;           not know why sentences stop generating. Not quite
;;;           clear what the correct behaviour should be however.
;;;           Perhaps making initialize a little more case
;;;           dependent helps: for example, when new inquiries
;;;           are defined, only updating keyword types ...?
;;;           No action taken as yet, but this should be watched.

(declaim (special *merging-active*))

(defun SETUP-SPL ()
  (setup-spl-relational-types)
  (set-grammar-keyword-types)
  (unless *merging-active*
	  (initialize-spl-defaults)))


;;; 0.8.19
;;; 2.1 meta keywords added.
;;; 4.1+ Niels trampled through here using some of the new variables
;;;         that contain names rather than allowing the names themselves
;;;         to appear (for KR dependencies). This was not, however,
;;;         done correctly: changed but will need watching.

(defun SET-GRAMMAR-KEYWORD-TYPES ()
  "To initialize the keyword table independently of ASKOPERATOR, IDENTIFYOPERATOR, and SYSTEM."
  (dolist (type *spl-special-keywords*)
    (setf (gethash type *spl-keyword-table*) 'special))
  (dolist (type *spl-meta-keywords*)
    (setf (gethash type *spl-keyword-table*) 'meta))
  (dolist (op (list *domain-name* *range-name* 'standard)) ;; was hacked by Niels: now OK?
    (setf (gethash op *spl-keyword-table*) 
	  'relation))
  (dolist (op inquiry-operators)
    (setf (gethash op *spl-keyword-table*) 
	  (if (branching-inquiry-p op) 'askoperator 'identifyoperator)))
  (dolist (sys systems)
    ;; 1.1 multilingualized, although we don't use this still...
    ;; 2.1 superceded in any case by :features keyword.
    (setf (gethash (first sys) *spl-keyword-table*) 'system)))


;;; 0.7.38: Was not previously using the parameterized
;;; *spl-relational-types* for recognizing relations in the SPL.
;;; (Note that we are not using *SPL-SPECS-PACKAGE* here, should we?)
;;; 1.1 also was assuming the upper model package is accessible
;;;     from KPML - unnecessary.

(defun SPL-KEYWORD-TYPE (word)
  "Returns one of ASKOPERATOR, IDENTIFYOPERATOR, SYSTEM, RELATION, SPECIAL, or NIL."
  (or (gethash (intern (symbol-name word) (find-package "KPML"))
	       *spl-keyword-table*)
      
      (if (loop for relation in *spl-relational-types*
	      thereis (KB-superp 
		       (intern (symbol-name word) (kb-package)) relation))
	  'relation)))


;;; ----------------------------------------------------------------------
;;;  To parse a plan, which should be a list of terms, submit it to 
;;;  MAKE-PLAN-TERM-GRAPH. TERM-TO-GRAPH provides the basic structure
;;;  of the parsing for different types of constituents, PROCESS-FEATURES
;;;  handles the manifold complexities of feature lists.
;;;
;;; 2.1
;;; It appears that usage of SPLs and the originally foreseen definitions
;;; have moved apart somewhat wrt how complex terms are expressed. The
;;; following might have been considered as somehow equivalent...
;;;
;;; ((S / SAIL :ACTOR (S2 / SHIP))(S3 / SAIL :ACTOR (S4 / OBJECT :LEX BOAT)))
;;;
;;; ((S S3)
;;;  (S / SAIL :ACTOR (S2 / SHIP))(S3 / SAIL :ACTOR (S4 / OBJECT :LEX BOAT)))
;;; 
;;; But this also needs to be considered wrt flat SPLs of the form:
;;;
;;; ((S / SAIL :ACTOR S2)
;;;  (S2 / SHIP))
;;;
;;; This is not structurally distinguishable from the first case unless
;;; we do a lot of internal analysis to see that the roots of the two
;;; terms are disjoint. This is a motivation for the original Penman
;;; idiom of putting such complexes inside yet another pair of brackets.
;;; This is logical (given the interpretation of the first element as
;;; giving the head described in a moment), but not perspicuous---especially
;;; to the non-Lisp user. It also had stopped working because of 
;;; multilinguality, which tended to strip out the outer level of parentheses
;;; in case they were there to indicate multilingual conditionalization...
;;; What in fact worked was then THREE lots of parentheses!
;;;
;;; Now the previous (original?) definition of MAKE-PLAN-TERM-GRAPH 
;;; is happy about the latter case above but appears somehow to now be not
;;; so happy about the middle case. Progressive changes made elsewhere
;;; about the interpretation and construction of SPL terms may have got
;;; us to this state.  This all boils down to the fact that the
;;; SPL interpretation is not as straightforward as it sometimes is
;;; presented. The *first* element of an SPL is either a symbol, in which
;;; case we have a simple SPL, *or* it is a list of symbols, that 
;;; represents the complex head of a unit to be generated (middle case),
;;; *or* it is a list of simple SPLs, in which case we
;;; have a list of SPL terms that should be considered as a complex and not
;;; as a list of terms that may be in some other dependency relationship. 
;;; I suggest that the special treatment of the first element be properly
;;; accepted, so the first element always identifies the intended head
;;; of the phrase.
;;;
;;; The following redefinition explicitly deals with these various
;;; possibilities...

(defun MAKE-PLAN-TERM-GRAPH (plan)
  "Takes a plan (a term or list of terms) and converts each 
   term to a structure."
  (let (root)
    (setf *merged-terms* nil)
    (setf root 
          (cond ((symbolp (first plan))
                 ;; simple SPL term...
                 (term-to-graph plan))
                ((and (consp (first plan))
                      (loop for term in (first plan)
                            always (symbolp term)))
                 ;; the special explicit complex head form...
                 (let ((head-list (first plan))
                       (head-complex nil)
                       (dependents nil))
                   (loop for term in (rest plan)
                         do
                         (if (member (first term) head-list)
                             (push term head-complex)
                           (push term dependents))
                         finally 
                         (dolist (dep-term dependents)
                           (term-to-graph dep-term))
                         (return (term-to-graph 
                                  (reverse head-complex))))))
                (t
                 ;; the old complex case...
                 (dolist (term (rest plan)) (term-to-graph term))
                 (term-to-graph (first plan)))))
    (unify-merged-terms)
    root))


;;; The original for comparison in case problems turn up...
#+ignore
(defun make-plan-term-graph (plan)
  "Takes a plan (a term or list of terms) and converts each term to a structure."
  (let (root)
    (setf *merged-terms* nil)
    (setf root (if (symbolp (first plan))
		   (term-to-graph plan)
		   (or (dolist (term (rest plan)) (term-to-graph term))
		       (term-to-graph (first plan)))))
    (unify-merged-terms)
    root))

;;; ----------------------------------------------------------------------

(defun unify-merged-terms ()
  "Make replacements, as appropriate, in the symbol field of all graphs."
  (dolist (graph *plan-graphs*)
    (replace-term-graph-symbols graph)))


(defun replace-term-graph-symbols (graph)
  "Make replacements, as appropriate, in the symbol field of graph."
  (if (and (symbolp graph) 
	   (boundp graph)
	   (typep (symbol-value graph) 'term-graph))
      (if (and (typep (symbol-value graph) 'term-graph)
	       (symbolp (term-graph-symbol (symbol-value graph))) 
	       (find (term-graph-symbol (symbol-value graph)) *merged-terms* :test #'member))
	  (setf (term-graph-symbol (symbol-value graph))
		(first (find (term-graph-symbol (symbol-value graph)) 
			     *merged-terms* :test #'member)))
	  (if (consp (term-graph-symbol (symbol-value graph)))
	      (setf (term-graph-symbol (symbol-value graph)) 
		    (mapcar 
		      #'(lambda (elt) (if (find elt *merged-terms* :test #'member)
					  (first (find elt *merged-terms* :test #'member))
					  elt)) (term-graph-symbol (symbol-value graph))))))))


(defun replace-all-graph-symbols (graph)
  "Make replacements, as appropriate, in the symbol field of graph,
   and all graphs embedded within graph."
  (replace-term-graph-symbols (term-id graph))
  (if (or (typep graph 'term-graph)
	  (and (symbolp graph)
	       (boundp graph)
	       (typep (symbol-value graph) 'term-graph)))			    
      (dolist (feature (if (symbolp graph)
			   (term-graph-features (symbol-value graph))
			   (term-graph-features graph)))
	(replace-all-graph-symbols (rest feature)))))


;;; ----------------------------------------------------------------------
;;; ML-Penman version folded in here, numerously patched for KPML.
;;;
;;; 2.0.12 
;;; KPML was not ready to accept embedded SPLs of the form
;;;        (6 / number).
;;;
;;; This means that the following are all interchangeable:
;;;   (n / object :lex idea :quantity 6)
;;;   (n / object :lex idea :quantity (6 / number))
;;;   (n / object :lex idea :quantity (d / number :value 6))
;;;
;;; Only the latter allows further inquiries to be added to the number
;;; specification however; this is because otherwise there is not a 
;;; proper SPL-term available to pass those inquiries as parameter.
;;; ----------------------------------------------------------------------

(defun TERM-TO-GRAPH (term &optional parent-term inquiry-operator)
  "Converts a term in s-expression form into a term structure, 
   and sets THIS-TERM (a gensym similar to the term's name) to that structure.
   These symbols are stored in *plan-graphs*. 
   Terms which are symbols divide into constants and variables, depending on 
   the governing keyword feature.  Constants are represented as symbols, 
   variables by term-graph structures.   Numbers are unchanged, and 
   regarded as self-referential."
  (typecase term
    (number term)
    (atom 
     (first 
      (push (make-term-graph-id :id term :symbol term :parent parent-term) 
	    *plan-graphs*)))
    (list
     (if (numberp (first term))
	 (first term)
       (let (this-term)
	 (if (eq (second term) '/)
	     (progn
	       (setq this-term
		 (make-term-graph-id
		  :id  (first term)
		  :symbol (first term)
		  :type   (third term)
		  :parent parent-term))
	       (setf (term-graph-features (symbol-value this-term))
		 (process-features (rest (rest (rest term))) this-term)))
	   (if (branching-inquiry-p inquiry-operator)
	       (let ((answer-set 
		      (fetch-inquiry-info inquiry-operator 'answerset)))
		 (when (loop for x in term
			   never (member x answer-set))
		   (warning "In default definition for inquiry " 
			    inquiry-operator 
			    " legal inquiry response not found."))
		 (setq this-term
		   (make-term-graph-id 
		    :id  inquiry-operator
		    :symbol (mapcar 
			     #'(lambda (elt) 
				 (if (member elt answer-set)
				     elt 
				   (term-to-graph elt)))
			     term)
		    :type 'inquiry-response
		    :parent parent-term)))
	     (setq this-term
	       (make-term-graph-id
		       :id (if inquiry-operator 
			       inquiry-operator 
			       (if (eq (first term) ':or)
				   *SPL-DISJUNCTIVE-SET-TYPE*
				   *SPL-SET-TYPE*))
		       :symbol (if (or (eq (first term) ':or)
				       (eq (first term) ':and))
				   (mapcar #'(lambda (elt) (term-to-graph elt parent-term)) 
					   (rest term))
				   (mapcar #'(lambda (elt) (term-to-graph elt parent-term))
					   term))
		       :type (if inquiry-operator 
				 'inquiry-response
				 (if (eq (first term) ':or)
				     *SPL-DISJUNCTIVE-SET-TYPE*
				     *SPL-SET-TYPE*)) 
		       :parent parent-term))))
	 
	 (push this-term *plan-graphs*)
	 this-term)))))

;;; ----------------------------------------------------------------------
;;; 0.8.19 spl annotations added to syntax.
;;; 1.0.21 added :pattern interpretation for templates.
;;; 1.1 added :value slot for numbers.
;;; 2.1 added :contextual-boundness slot for information status.
;;;     annotations moved to meta keyword status
;;;     added :features slot for grammatical feature constraints.
;;;     added :language slot
;;; 4.0 language slot use cleaned up.
;;; ----------------------------------------------------------------------

(defun PROCESS-FEATURES (feature-s-exp parent-term)
  "This function applied to that part of an SPL term following the type 
   designator. We look for keywords--values and the processing of them 
   depend on the keyword type--and perform a bit of syntactic/semantic 
   validation.  The function returns a dotted pair appropriate to the
   a-list structure of the term-graph-features."
  (let (feature-list new-feature)
    (dolist (feature 
		(nreverse 
		 (reparse-features feature-s-exp)) 
	      (nreverse feature-list))
      ;; 2.1 first break out the meta keywords... these do not have 
      ;;     any effect on the features
      ;;     slot but instead side-effect the definition of the entire term-graph.
      (if (equal (spl-keyword-type (first feature)) 'meta) 
          (case (first feature)
            (:annotation
             ;; 0.8.19, 2.1 moved to meta keyword...
             (setf (term-graph-annotation (symbol-value parent-term)) (second feature)))
            (:contextual-boundness               
             ;; 2.1 for Prague experiments
             (pushnew 
              (cons :cb (second feature)) 
              (term-graph-information-status (symbol-value parent-term))))
            (:features
             ;; 2.1 for more complete test suites independent of semantic specs...
             (setf (term-graph-grammatical-features (symbol-value parent-term))
                   (second feature)))
            (:language
             ;; 2.1 for curious mixed language generation should someone think of 
	     ;;     something to do with it!
	     ;; 4.0 avoid keyword names in the SPL because they are of course
	     ;;     misinterpreted as language conditionalizations!
             (setf (term-graph-language (symbol-value parent-term))
		   (let ((language (intern (string (second feature)) "KEYWORD")))
		     (if (member language all_languages)
			 language
		       (warning "Language requested in SPL " 
				language " not currently defined."))))
             ))
        (progn
          (setf new-feature 
	        (cons 
                 (intern (symbol-name (first feature)) (find-package "KPML"))
                 (case (spl-keyword-type (first feature))
                   (relation
		      (symbol-value-or-number
			(if (< 2 (length feature))
			    (term-to-graph 
			      (rest feature)
			      parent-term)
			    (term-to-graph 
			      (second feature) 
			      parent-term))))
		    (identifyoperator
		      (symbol-value-or-number
			(if (< 2 (length feature))
			    (term-to-graph 
			      (append (second feature) 
				      (list (third feature)))
			      parent-term 
			      (intern (symbol-name (first feature)) 
				      (find-package "KPML")))
			    (term-to-graph 
			      (second feature) 
			      parent-term))))
		    (askoperator
		      (if (< 2 (length feature))
			  (symbol-value
			    (term-to-graph 
			      (append (second feature) 
				      (list (third feature)))
			      parent-term 
			      (intern (symbol-name (first feature)) 
				      (find-package "KPML"))))
			  (second feature)))
		    (system (warning 
			     "System feature selection not supported:  " 
			     (second feature))
			    (second feature))
		    (special 
		      (case (first feature)
			(:value (second feature))              ;; 1.1
			(:lex (second feature))
			(:express-type 
			  (if (not (member (second feature) '(yes no)))
			      (warning "Invalid value for :EXPRESS-TYPE:  " 
				       (second feature)))
			  (second feature))
			((:event-time :speaking-time :speech-act :process)
			 (symbol-value
			   (term-to-graph (second feature) parent-term)))
			(:pattern                            ;; 1.0.21
			 (if (consp (second feature))
			     (mapcar 
			      #'(lambda (x)
				  (typecase x
				    (string x)
				    (otherwise 
				     (symbol-value 
				      (term-to-graph x parent-term)))))
			      (second feature))
			   (second feature)))
			((:relations :theme)
			 (symbol-value
			   (term-to-graph
			     (if (atom (second feature))
				 (list (second feature))
				 (if (eq (second (second feature)) '/)
				     (list (second feature))
				     (second feature)))
			     parent-term)))))
		    (otherwise 
		     (warning "Invalid keyword:  " (first feature))
		     (symbol-value 
		      (term-to-graph (second feature) parent-term))))))
          (setf feature-list (merge-feature new-feature feature-list)))))))
  

;;; ----------------------------------------------------------------------
;;; ML-Penman version folded in here...

(defun merge-feature (new-feature feature-list)
  "If NEW-FEATURE's first is EQ to the first of some element of FEATURE-LIST 
   then attempt, in the right circumstances, to merge NEW-FEATURE with the
   existing element."
  (if (null feature-list)
      (list new-feature)
      (if (dolist (feature feature-list t)
	    (if (eq (first new-feature) (first feature))
		(if (symbolp (rest feature))
		    (progn (when (not (eq (rest new-feature) (rest feature)))
			     (warning "Incompatible specifications for feature " 
					(first feature) "; value " (rest feature) 
					" will be used.")
			     (setq *merge-failure* t))
			   (return nil))
		    (case (term-graph-type (rest feature))
		      
		      (inquiry-response ;;; This case requires matching parameter sets.
			(if 
			  (and (typep (rest new-feature) 'term-graph)
			       (term-type-p (term-graph-id (rest new-feature)) 
					    'inquiry-response)
			       (dotimes 
				 (n (length (fetch-inquiry-info (first feature) 'parameters))
				    t)
				 (if (not 
				       (eq (nth n (term-graph-symbol (rest feature)))
					   (nth n (term-graph-symbol (rest new-feature)))))
				     (return nil))))
			    (progn (merge-terms 
				     (rest (last (term-graph-symbol (rest feature))))
				     (rest (last (term-graph-symbol (rest new-feature)))))
				   (return nil))))
		      
		      ((nil) ;;; If type is NIL for each term, no features to merge when 
		             ;;; symbols are EQ.
		             ;;; Identifying inquiries with distinct symbols get merged.
		             ;;; Role features with distinct symbols form sets.
		       (when (null (term-graph-type (rest new-feature)))
			 (when (not (eq (term-graph-symbol (rest feature))
					(term-graph-symbol (rest new-feature))))
			   (if (identifying-inquiry-p (first feature))
			       (merge-terms (rest feature) (rest new-feature))
			       (or (setf (term-graph-type (rest feature)) *SPL-SET-TYPE*)
                                   (setf (term-graph-symbol (rest feature))
				     (list (term-graph-symbol (rest feature))
					   (term-graph-symbol (rest new-feature))))))
			 (return nil)))
		       ;;; Prefer the value with more information.  Should the terms merge?
		       (when (identifying-inquiry-p (first feature)) 
			 (when (not (eq (term-graph-symbol (rest feature))
					(term-graph-symbol (rest new-feature))))
			   (warning "Incompatible specifications for feature " 
				    (first feature) "; value " 
				    (term-graph-symbol (rest new-feature))
				    " will be used.")
			   (setq *merge-failure* t))
			 (merge-terms (rest feature) (rest new-feature))
			 (return nil))
		       ;;; Form set from distinct values for non-inquiry feature.
		       (setf (term-graph-type (rest feature)) *SPL-SET-TYPE*) 
		       (setf (term-graph-symbol (rest feature))
				     (list (term-graph-symbol (rest feature))
					   (term-graph-symbol (rest new-feature))))
		       (return nil))
		       
		      (set ;;; Pairs of sets result in set union.
			   ;;; Should atomic features add to the set, or signal an error?
			(if (eq (term-graph-type (rest new-feature)) *SPL-SET-TYPE*)
			       (setf (term-graph-symbol (rest feature))
				     (union (term-graph-symbol (rest feature))
					    (term-graph-symbol (rest new-feature))))
			       (push (term-graph-symbol (rest new-feature))
				     (term-graph-symbol (rest feature))))
			   (return nil))
		      
		      (otherwise   
			(if (identifying-inquiry-p (first feature))
			    (progn (merge-terms (rest feature) (rest new-feature))
				   (return nil))
			    (if (eq (term-graph-symbol (rest feature))
				    (term-graph-symbol (rest new-feature)))
				(progn (merge-terms (rest feature) (rest new-feature))
				       (return nil))
				(return t))))))))
	  (push new-feature feature-list)
	  feature-list)))

;;; ----------------------------------------------------------------------
;;; 4.0 John. Sep 2003
;;;     While running with Loom4  an error was suddenly thrown
;;;     because of an inquiry implementation getting an expected list of
;;;     semantic types instead of a single type. This list was coming from
;;;     a unification of identical terms (the SPL specified and the SPL
;;;     default) resulting in a list of two identical types instead of
;;;     a single unified one. Questions are horrible: why did it just
;;;     cause a problem now and not before? What will the change now
;;;     made here do to other examples? In any case, the change was
;;;     already present here (presumably from Bob Kasper in the original
;;;     code but was *commented out*... why? 
;;;
;;;     However, merging is often necessary to get the defaults into
;;;     the right place. So we compromise and replace lists of identiccal
;;;     semantic terms by single symbol terms. This gets us through
;;;     those inquiries that are unpleasantly surprised when a list
;;;     comes through... although there is no principled reason why
;;;     a list should *not* come through actually...

(defun merge-terms (term new-term)
  "Modify TERM to reflect information in NEW-TERM."
  (if (or (numberp term)
	  (symbolp term))
      (progn 
	(unless (eq term new-term)
	  (warning "Incompatible atomic terms " term " and " new-term " for same feature.")
	  (setq *merge-failure* t)))
      (prog ()
         ;;; Before doing anything, detect disjoint types, and fail if necessary.
	(if (disjoint-types-p (term-graph-type term) (term-graph-type new-term)) 
	    (progn (setq *merge-failure* t) (return nil)))
	 ;;; First, combine types.  (Could be improved by deleting SuperCs.
         ;;;                         Have attempted to do this at comment-line.)
	;;   4.0                     Have removed the comment and activated it...
	(if (symbolp (term-graph-type term))
	    ;;
	    ;; the old term's type is a symbol...
	    ;;
	    (if (symbolp (term-graph-type new-term))
		;;
		;; the new term's type is a symbol too...
		;; check if new is a supertype of old
		;;   if it is a supertype the old is more specific and can
		;;   be kept...
		;;
		(if (not (KB-superp (term-graph-type term) (term-graph-type new-term)))
		    ;;
		    ;; if we are here, then new is not a supertype of old
		    ;; so there is work to be done...
		    ;; 4.0 following line not activated but duplicates picked
		    ;;     up below instead
		    ;;
		    (unless (equal (term-graph-type term) (term-graph-type new-term))
			;;
			;; if they are not equal, then need to combine
			;; them and make that the type of the old term...
			;; if they are equal, leave them alone...
			;;
			(setf (term-graph-type term) 
			  (list (term-graph-type term) (term-graph-type new-term)))))
	      ;;
	      ;; the new term's type is not a symbol...
	      ;; so we push the old term onto this list...
	      ;;
	      (setf (term-graph-type term)
		(pushnew (term-graph-type term) (term-graph-type new-term))))
	  ;;
	  ;; the old term's type is not a symbol...
	  ;;
	  (if (atom (term-graph-type new-term))
	      ;;
	      ;; but the new term's is, so we push the new term onto the 
	      ;; old term list...
	      ;;
	      (pushnew (term-graph-type new-term) (term-graph-type term))
	    ;;
	    ;; otherwise we just append the two lists...
	    ;;
	    (setf (term-graph-type term)
	      (append (term-graph-type term) (term-graph-type new-term)))))
	
	(if (consp (term-graph-type term))
	    (setf (term-graph-type term) (remove nil (term-graph-type term))))
	 ;;; Second, combine features.
	(setf (term-graph-features term)
	      (let ((feature-list (term-graph-features term)))
		(dolist (feature (term-graph-features new-term))
		  (setf feature-list (merge-feature feature feature-list)))
		feature-list))
	 ;;; Third, migrate parent-term down to features
	(dolist (feature (term-graph-features term))
	  (if (typep (rest feature) 'term-graph)
	      (setf (term-graph-parent (rest feature)) (term-graph-id term))))
	 ;;; Finally, retain association of merged symbols for globally consistent coreference.
	(identify-terms (term-graph-symbol term) (term-graph-symbol new-term)))))


(defun disjoint-types-p (type1 type2)
  "TYPEn may be an atom or a list of atoms.  ANY disjointness is detected."
  (if (atom type1)
      (if (atom type2)
	  (if (KB-ConceptDisjoint? type1 type2)
;	    (and (KB-GetNamedConcept (intern (symbol-name type1) (kb-package))) 
;		   (KB-GetNamedConcept (intern (symbol-name type2) (kb-package))) 
;		   (KB-ConceptDisjoint? 
;		     (KB-GetNamedConcept (intern (symbol-name type1) (kb-package)))
;		     (KB-GetNamedConcept (intern (symbol-name type2) (kb-package)))))
	      t)
	  (dolist (type type2)
	    (if (disjoint-types-p type1 type) (return t))))
      (dolist (type type1)
	(if (disjoint-types-p type type2) (return t)))))

(defun identify-terms (term1 term2)
  "Manages *MERGED-TERMS*."
  (let ((class1 (find term1 *merged-terms* :test #'member))
	(class2 (find term2 *merged-terms* :test #'member)))
  (if (null *merged-terms*)
      (push (list term1 term2) *merged-terms*)
      (if class1
	  (if class2
	      (push (union class1 class2) *merged-terms*)
	      (push (cons term2 class1) *merged-terms*))
	  (if class2
	      (push (cons term1 class2) *merged-terms*)
	      (push (list term1 term2) *merged-terms*))))))




;;; --------------------------------------------------------------------
;;; GRAPH-TO-TERM is supposed to produce, from a term-graph structure, a 
;;; term in s-expression
;;; form which is EQUAL to the original, i.e. that which yielded the 
;;; structure to begin with.
;;; not maintained lately:  potential problems with order of 
;;; features, macro expansion. (John: Sep96: partially fixed up).
;;;
;;; John: Aug94: also the reliance on upper model set and disjunctive-set.
;;; ----------------------------------------------------------------------

(defun GRAPH-TO-TERM (graph)
  "Converts a term-graph structure into a term in s-expression form."
  (labels
      ((graph-to-term-descent (graph)
	 (if (or (numberp graph)
		 (symbolp graph))
	     graph
	   (case (term-graph-type graph) 
	     ((um-set set)                                        ;; 0.9.55
	      (mapcar #'(lambda (elt) (graph-to-term-descent elt)) 
		      (term-graph-symbol graph)))
	     (disjunctive-set
	      (list ':or 
		    (mapcar #'(lambda (elt) (graph-to-term-descent elt)) 
			    (term-graph-symbol graph))))
	     (conjunctive-set
	      (list ':and 		  
		    (mapcar #'(lambda (elt) (graph-to-term-descent elt))
			    (term-graph-symbol graph))))
	     (inquiry-response 
	      ;; 0.9.55 as Bob noted, was not quite right
	      ;;        --need to group args as list before the last elt
	      ;;        also--there may be no args & no list! 
	      ;;  mildy problematic, as the i/o-structures are in this
	      ;;  case not isomorphic. Fix with a hack postprocessor.
	      (make-internal-inq-response
	       :contents
	       (mapcar #'(lambda (elt) (graph-to-term-descent elt))
		       (term-graph-symbol graph))))
	     (t 
	      (if (term-graph-features graph)
		  (append
		   (list (term-graph-symbol graph) '/ (term-graph-type graph))
		   (let (features)
		     (dolist (feature.value (term-graph-features graph))
		       (if feature.value
			   (and (push 
				 (graph-to-term-descent 
				  (rest feature.value)) features)
				(push (intern 
				       (symbol-name (first feature.value)) 
				       (find-package 'keyword))
				      features))))
		     features))
		(if (term-graph-type graph)
		    (list (term-graph-symbol graph) '/ (term-graph-type graph))
		  (term-graph-symbol graph))))))))
    (separate-inq-responses
     (graph-to-term-descent graph))))

(defun get-plan-term (plan term)
  "Given a plan, find the first instance of an embedded term
   --a list whose first element is the term"
  (if (and (consp plan)
	   (eq (first plan) term))
      plan
      (loop for elt in plan collect (get-plan-term elt term))))

(defun symbol-value-or-number (term)
  "Covers the case where numbers--which are not symbols--may be passed through from 
   TERM-TO-GRAPH."
  (if (numberp term) term (symbol-value term)))

;;; ----------------------------------------------------------------------
;;;  Functions for accessing information in term-graph structures.
;;; ----------------------------------------------------------------------

(defun term-id (term)
  "A symbol's id is itself; that of a term-graph comes from the structure."
  (if (typep term 'term-graph) 
      (term-graph-id  term)
      term))

(defun term-eq-p (term1 term2)
  "True if two terms (or their ids) have the same symbol.
   We also consider 'naked' (unbound) atomic terms."
  (cond 
    ((and (typep term1 'term-graph)
	  (typep term2 'term-graph))
     (eq (term-graph-symbol term1)
	 (term-graph-symbol term2)))
    ((and (typep term1 'number)
	  (typep term2 'number))
     (eql term1 term2))
    ((and (typep term1 'symbol)
	  (typep term2 'symbol)
	  (boundp term1)
	  (boundp term2)
	  (typep (symbol-value term1) 'term-graph)
	  (typep (symbol-value term2) 'term-graph))
     (eq (term-graph-symbol (symbol-value term1))
	 (term-graph-symbol (symbol-value term2))))
    ((and (typep term1 'symbol)
	  (typep term2 'symbol)
	  (not (boundp term1))
	  (not (boundp term2)))
     (eq term1 term2))
    ((and (typep term1 'symbol)
	  (not (boundp term1))
	  (typep term2 'symbol)
	  (boundp term2)
	  (typep (symbol-value term2) 'term-graph))
     (eq term1 (term-graph-symbol (symbol-value term2))))
    ((and (typep term2 'symbol)
	  (not (boundp term2))
	  (typep term1 'symbol)
	  (boundp term1)
	  (typep (symbol-value term1) 'term-graph))
     (eq term2 (term-graph-symbol (symbol-value term1))))
    (t (eq term1 term2))))

(defun term-type (term)
  "Return a list of type symbols--usually just one."
  (let ((type? (if (and (symbolp term)
			(boundp term)
			(typep (symbol-value term) 'term-graph))
		   (term-graph-type (symbol-value term)))))
    (or (if type?
	    (if (symbolp type?)
		(list type?)
		type?))
	(let (type-list)
	  (dolist (trm (get-top-level-terms term))
	    (if (atom (term-graph-type (symbol-value trm)))
		(pushnew (term-graph-type (symbol-value trm)) type-list)
		(setq type-list (append (term-graph-type (symbol-value trm)) type-list))))
	  type-list))))


;;; ----------------------------------------------------------------------
;;; 1.1    new function kb=superp used to simplify a bit...
;;; 2.0.56 behaviour when used with an undefined concept cleaned up.
;;; 4.0    there is an old patch from 1999 done for the more
;;;        complicated NPs that extends term-type-p to be happy
;;;        with lists of terms. This is now added experimentally
;;;        here to see if any problems are caused... This is
;;;        particularly used when we are dealing with whole 
;;;        lists of possible relations, as in :relations slots,
;;;        instead of one.
;;; ----------------------------------------------------------------------

(defun TERM-TYPE-p (term type &optional (non-local-test? t))
  "Is the given TYPE the type of or a superc of the type of the given TERM?
   (The TYPE field of a TERM may be a list of concepts.)
   When NON-LOCAL-TEST?, check all terms of the same symbol.  
   (Type information distributed globally should not require this.)"
  (if (consp term)                                                     ;; 2.1 + 4.0
      (loop for conjunct in term                                       ;; =========
	    thereis (term-type-p conjunct type non-local-test?))       ;;
    ;;
    ;; old definition continues here...
    ;;
    (if (and (kb-concept-p type) ;; 2.0.56
	   (symbolp term)) ;;; To weed out numbers
      (if (and term (boundp term) (typep (symbol-value term) 'term-graph))
	  (if (atom (term-graph-type (symbol-value term)))
	      (if (eq (term-graph-type (symbol-value term)) 
		      'identifying-inquiry-response)
		  (KB=superp (term-graph-symbol (symbol-value term)) type)
		(or (KB=superp (term-graph-type (symbol-value term)) type)
		    (if non-local-test?
			(dolist (graph *plan-graphs*)
			  (if (and (eq (term-graph-symbol (symbol-value graph))
				       (term-graph-symbol (symbol-value term)))
				   (not (eq graph term))
				   (term-type-p graph type nil))
			      (return t))))))
	    (dolist (typ (term-graph-type (symbol-value term)))
	      (if (KB=superp typ type)
		  (return t))))
	(KB=superp term type))
    nil))
  )



(defun term-role-p (first second role &optional (non-local-test? nil))
  "See if SECOND stands to FIRST in the given role (or a subc of it).
   When NON-LOCAL-TEST?, check all terms with the same symbols."
  (or (if (boundp first)
	  (or (and (term-type-p (term-graph-parent (symbol-value first)) role)
		   (term-eq-p 
		     second 
		     (fetch-subc-feature *range-name* (term-graph-parent (symbol-value first)))))
	      (dolist (a-feature (term-graph-features (symbol-value first)))
		(if (and (KB-superp (first a-feature) role)
			 (term-eq-p (if (or (numberp (rest a-feature))
					    (symbolp (rest a-feature)))
					(rest a-feature) 
					(term-graph-symbol (rest a-feature)))
				    second))
		    (return t)))))
      (when non-local-test?
	(dolist (plan *plan-graphs*)
	  (if (term-graph-features (symbol-value plan))
	      (progn
		(if (and (term-eq-p first (fetch-subc-feature *domain-name* plan))
			 (or (term-eq-p second (fetch-subc-feature *range-name* plan))
			     (and (functional-role-p plan)
				  (term-eq-p second plan)))
			 (term-type-p plan role))
		    (return t))
		(if (and (term-eq-p first plan)
			 (or (and (fetch-subc-feature role plan)
				  (term-eq-p second (fetch-subc-feature role plan)))
			     (and (fetch-reified-relation role plan)
				  (term-eq-p 
				    second 
				    (fetch-subc-feature 
				      *range-name* 
				      (fetch-reified-relation role plan))))))
		    (return t))
		(if (and (term-eq-p second plan)
			 (fetch-reified-relation role plan)
			 (term-eq-p 
			   first 
			   (fetch-subc-feature *range-name* (fetch-reified-relation role plan))))
		    (return t))))))))


;;; ----------------------------------------------------------------------
;;; Relation fetching functions.
;;;
;;; 4.0
;;
;; Following functions were not setting the
;; relations package properly ... Need to decide once
;; and for all what the packages of these are so that
;; they work consistently... As far as I can see at
;; present there is no reason why these are not always
;; in either KPML or the ideation-base package...
;;
;;; Also, the older definitions do 
;;; not reach *inside* relations slots in the case that they
;;; are just using variables rather than the full SPL spec at
;;; that point. 
;;; ----------------------------------------------------------------------

(defun fetch-relation (unpackaged-relation term)
  "Look for RELATION as a feature in TERM or as a reified entity in :RELATIONS.
   Caller will not know whether returned value is relation's range or reified relation."
  (let ((relation (intern (symbol-name unpackaged-relation) "KPML")))
    (or (fetch-subc-feature relation term)
	(fetch-reified-relation relation term))))


;;; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;; BEWARE!!  patch40b-001
;;;
;;; Added into the main code at 2004-11-08 as it seems so
;;; obviously correct and the old code seems so obviously
;;; wrong. Keep alert for curious errors!

(defun fetch-reified-relation (relation term)
  "Look for RELATION as a reified entity in :RELATIONS."
  (let ((relations (symbol-value (fetch-feature 'relations term))))
    (when relations 
      (when (equal (term-graph-type relations) *spl-set-type*)
	;;
	;; if we have a set of variables, here use the list of
	;; variables instead of the um-set that groups them in the term-graph
	;; (*) But this must then be a list and the definition that
        ;;     was in there was just giving the car of the list and,
        ;;     even worse, evaluating it. This is very odd. The
        ;;     reason why such code was placed here needs to be
        ;;     found...
	(setf relations
              (term-graph-symbol relations))
        ;;
        ;; 4.0 make sure that we jump over possibly null textual instances
        ;;     of the term in the SPL to get the content... 
        ;;
        (loop for potential-reif-rel in relations
	      as reif-rel = (coreferential-term potential-reif-rel)
	      when (term-type-p reif-rel relation)
	      do (return reif-rel))))))

#+ignore
(defun fetch-reified-relation (relation term)
  "Look for RELATION as a reified entity in :RELATIONS."
  (let ((relations (symbol-value (fetch-feature 'relations term))))
    (when relations 
      (when (equal (term-graph-type relations) 'um-set)
	;;
	;; if we have a set of variables, here use the list of
	;; variables instead of the um-set that groups them in the term-graph
	;;
	(setf relations
	      (symbol-value 
	       (car 
		(term-graph-symbol relations)))))
      
      ;;
      ;; 4.0 make sure that we jump over possibly null textual instances
      ;;     of the term in the SPL to get the content...
      ;;
      (loop for potential-reif-rel in (term-graph-symbol relations)
	    as reif-rel = (coreferential-term potential-reif-rel)
	    when (term-type-p reif-rel relation)
	    do (return reif-rel)))))

;;; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

;;; ----------------------------------------------------------------------
;;; 2.0 added for Renate...
;;; An extra SPL access function that allows the user to specify the type
;;; of the created relation...
;;; ----------------------------------------------------------------------

(defun FETCH-EXPLICITLY-TYPED-RELATION-SPEC (process type feature id)
  "Return a reified relation of the type denoted by feature,
   reifying a non-reified relation if necessary."
  ;; Replaces fetch-operator-operand-pair.  -- BK
  (let ((rel (fetch-reified-relation feature process)))
    (if rel
	rel
      (let ((value (fetch-subc-feature 
		    (intern (symbol-name feature) "KPML")
		    process))
	    reltype range)
	(when value
	  (setq reltype type)
	  (setq range (if (numberp value) value (symbol-value value)))
	  (make-term-graph-id
	      :id id 
	      :type reltype
	      :features `((,*domain-name* . ,process)
			  (,*range-name*. ,range))))))))


;;; ----------------------------------------------------------------------
;;; Functions concerned with so-called minimal relations...
;;; "For the time being, if DOMAIN and RANGE are the only features, it's minimal."
;;; 2.1 there are other slots that can be present without making the relation
;;;     nonminimal as far as the grammar is concerned, e.g., :lex, 
;;;     :pattern, :value, etc. There will also be inquiries that concern
;;;     the semantics that might not be sufficient to make the relation
;;;     nonminimal. Nonminimality is a notion that corresponds to how much
;;;     'stuff' is it possible to put inside a grammatical unit of a given
;;;     rank, and as such would need more work theoretically...
;;;     
;;;     Note that we start helping this by moving some of the non-linguistic
;;;     slots out of the feature list, e.g., :annotation. The existence of these
;;;     meta keywords should never influence an SPL semantic intepretation.
;;; ----------------------------------------------------------------------

(defun MINIMAL-REIFIED-TERM-P (relation)
  "For the time being, if DOMAIN and RANGE are the only features, it's minimal."
  (dolist (a-feature (term-graph-features relation) t)
     (if (and (not (member
                    (first a-feature) 
		    ;;4.1+ Niels missed the commas necessary in the next line ...
                    `(,*domain-name* ,*range-name* lex value kpml::pattern 
                             ;; perhaps minimals can also be of other process types?
                             actee saying phenomenon)
                    :test #'equal))
              (not (inquiry-defined-for-lg-p (first a-feature) curlan)))
	 (return nil)
       t)))

(defun fetch-minimal-relation (relation term)
  "Look for RELATION as a feature in TERM or as a minimal reified entity in :RELATIONS.
   Caller will not know whether returned value is relation's range or reified relation."
  (or (fetch-minimal-subc-feature relation term)  ;; 2.1
      (fetch-minimal-reified-relation relation term)))

(defun fetch-minimal-reified-relation (relation term)
  "Look for RELATION as a minimal reified entity in :RELATIONS."
  (let ((relations (symbol-value (fetch-feature 'relations term))))
    (if relations 
	(dolist (reif-rel (term-graph-symbol relations))
	  (if (and (term-type-p reif-rel relation)
		   (minimal-reified-term-p (symbol-value reif-rel)))
	      (return reif-rel))))))

(defun fetch-non-minimal-reified-relation (relation term)
  "Look for RELATION as a non-minimal reified entity in :RELATIONS."
  (let ((relations (symbol-value (fetch-feature 'relations term))))
    (if relations 
	(dolist (reif-rel (term-graph-symbol relations))
	  (if (and (term-type-p  reif-rel relation)
		   (not (minimal-reified-term-p (symbol-value reif-rel))))
	      (return reif-rel))))))

(defun fetch-relation-range (relation term)
  "Return RELATION feature or RANGE of RELATION in REATIONS feature."
  (or (fetch-minimal-subc-feature relation term)            ;; 2.1
      (and (fetch-minimal-reified-relation relation term )  ;; 2.1 type check
           (fetch-subc-feature 
	    *range-name* 
	    (fetch-minimal-reified-relation relation term )))))

(defun fetch-operator-operand-pair (process feature id)
  "Return a new term structure with :OPERATOR-ID & :OPERAND-ID features."
  (let ((range (fetch-subc-feature feature process))
	operator operand)
    (if range
	(progn
	  (setq operator (fetch-subc-feature-name feature process))
	  (setq operand (symbol-value range)))
	(let ((rel (fetch-reified-relation feature process)))
	  (setq operator (term-graph-type (symbol-value rel)))
	  (setq operand (symbol-value (fetch-subc-feature *range-name* rel)))))
    (make-term-graph-id 
      :id id 
      :type 'operator.operand
      :features (list (cons 'operator-id
			    (symbol-value
			      (make-term-graph-id
				:id operator
				:symbol operator
				:type 'identifying-inquiry-response)))
		      (cons 'operand-id operand)))))


(defun fetch-relation-spec (process unpackaged-feature id)
  "Return a reified relation of the type denoted by feature,
   reifying a non-reified relation if necessary."
  ;; Replaces fetch-operator-operand-pair.  -- BK
  (let ((feature (intern (symbol-name unpackaged-feature) "KPML")))
  (let ((rel (fetch-reified-relation feature process)))
    (if rel
	rel
      (let ((value (fetch-subc-feature feature process))
	    reltype range)
	(when value
	  (setq reltype (fetch-subc-feature-name feature process))
	  (setq range (if (numberp value) value (symbol-value value)))
	  (make-term-graph-id
	      :id id 
	      :type reltype
	      :features `((,*domain-name* . ,process)
			  (,*range-name* . ,range))))))))
)


(defun invert-reified-relation-spec (reified-relation id)
  "Produce a reified relation which is the inverse of REIFIED-RELATION."
  (let ((domain (fetch-subc-feature *range-name* reified-relation))
	(range (fetch-subc-feature *domain-name* reified-relation))
	(reltype (intern 
		   (symbol-name 
		     (make-symbol (concatenate 'string 
					       (string-upcase 
						 (symbol-name 
						   (term-graph-type 
						     (symbol-value reified-relation))))
					       "-INVERSE"))))))
    (make-term-graph-id
      :id id 
      :type reltype
      :features `((,*domain-name* . ,domain)
		  (,*range-name* . ,range)))))


(defun functional-role-p (reif-reln)
  "Returns T when there is a DOMAIN but no RANGE.
   Or a RANGE but no DOMAIN (for inverses)."
  (if (or (and (fetch-subc-feature *domain-name* reif-reln)
	       (not (fetch-subc-feature *range-name* reif-reln)))
	  (and (fetch-subc-feature *range-name* reif-reln)
	       (not (fetch-subc-feature *domain-name* reif-reln))))
      T))


;;; ----------------------------------------------------------------------
;;; Function that picks out a non-null coreferential term-graph. This is
;;; for finding the contentful member of a set of distinct SPL term-graphs
;;; that pick out textually distinct but identical SPL variables.
;;;
;;; 4.0 note that this kind of search, which may be performed many times
;;;     during generation, is actually a time-sink. Better to cache the
;;;     result prior to generation of each SPL. Probably a trade-off
;;;     between caching and on-the-fly depending on how complex the SPL
;;;     is. This can be measured directly by looking at the length of
;;;     *plan-graphs*. So we make it a memo function for now: should 
;;;     clear it sometime too... most sensibly at the beginning of 
;;;     each generation run, although greater granularities might be
;;;     be sensible too.
;;; ----------------------------------------------------------------------

(defvar *coreferentials* (make-hash-table))

(defun COREFERENTIAL-TERM (term)
  (let ((result (gethash term *coreferentials*)))
    (if result
	result
      (when (and (symbolp term) 
		 (boundp term)
		 (typep (symbol-value term) 'term-graph))
	(let ((term-graph (symbol-value term)))
	  (if (term-graph-type term-graph)
	      term
	    (loop for term-2 in *plan-graphs*
		  as term-graph-2 = (symbol-value term-2)
		  when (and
			(equal
			 (term-graph-symbol term-graph)
			 (term-graph-symbol term-graph-2))
			(term-graph-type term-graph-2))
		  do (return-from COREFERENTIAL-TERM 
				  (setf (gethash term *coreferentials*) term-2)))))))))


;;; 4.0 following function was not copying all the additional term
;;;     graph slots that are now passed around with the term
;;;     graph that were not in the original Penman. These
;;;     are now added explicitly. It may not always be absolutely
;;;     the correct behaviour to copy them over, but certainly
;;;     most of them should.

(defun COPY-SPL-TERM-GRAPH (graph)
  "Copies graph, recursively copying embedded graphs."
  (let ((new-graph (symbol-value (make-term-graph-id
				  :symbol (if (consp (term-graph-symbol graph)) 
					      (copy-list (term-graph-symbol graph))
					      (term-graph-symbol graph))
				  :id (term-graph-id graph)
				  :type (if (consp (term-graph-type graph)) 
					      (copy-list (term-graph-type graph))
					      (term-graph-type graph)) 
				  ;:features (term-graph-features graph)
				  :parent (term-graph-parent graph)
				  ;;
				  ;; 4.0 -- additions --
				  ;;
				  :annotation (term-graph-annotation graph)
				  :information-status (term-graph-information-status graph)
				  :language (term-graph-language graph)
				  :grammatical-features 
				    (term-graph-grammatical-features graph)
				  ))))
    (setf (term-graph-features new-graph)
	  (mapcar  #'(lambda (feature)
		       (if (typep (rest feature) 'term-graph)
			   (cons (first feature)(copy-spl-term-graph (rest feature)))
			   feature))
		   (term-graph-features graph)))
    (dolist (feature (term-graph-features new-graph))
      (if (typep (rest feature) 'term-graph)
	  (setf (term-graph-parent (rest feature))
		(term-graph-id new-graph))))
    new-graph))





;;; ----------------------------------------------------------------------
;;; Utilities for the graph-to-term: quite a hack (sorry)
(defstruct INTERNAL-INQ-RESPONSE 
  (contents nil))
  
(defun SEPARATE-INQ-RESPONSES (s-exp)
  (cond ((internal-inq-response-p s-exp)
	 (list (butlast (internal-inq-response-contents s-exp) 1)
	       (first (last (internal-inq-response-contents s-exp)))))
	((symbolp s-exp) s-exp)
	((consp s-exp)
	 (loop for s in s-exp
	     when (symbolp s) collect s
	     else
	     when (internal-inq-response-p s)
	     collect (butlast (internal-inq-response-contents s) 1)
	     and collect (first (last (internal-inq-response-contents s)))
	     else
	     when (consp s)
	     collect (separate-inq-responses s)
	     else collect s))
	(t 
	 (warning "Strangely formed term-graph during back-conversion to SPL:"
		  s-exp)
	 nil)))

;;; ----------------------------------------------------------------------
;;; Collection of specialized access functions for particular, generally
;;; non-semantic or experimental components of term-graphs.
;;; ----------------------------------------------------------------------

;;; ----------------------------------------------------------------------
;;; 0.8.19 annotations now allowed in SPL specs...
;;; 2.1    moved out of a global and into a term-graph slot.
;;;     somewhere to keep the annotations:
;;;     (defvar *spl-term-annotations* nil)
;;;     Removed.
;;; and something to find them...
;;; ----------------------------------------------------------------------

(defun FIND-SPL-ANNOTATION (concept)
  (typecase concept
    (symbol
     (if (boundp concept)
         (if (term-graph-p (symbol-value concept))
             (term-graph-annotation (symbol-value concept))
	   nil)
       nil))
    (otherwise
     nil)))

;;; 3.1
;;; sometimes, depending on what people are doing to their hubs and
;;; what gets associated, it might even be possible for an spl-term-id
;;; not to be a symbol...

(defun FIND-SPL-SYMBOL-ANNOTATION (spl-term-id)
  (let ((target (if (and (symbolp spl-term-id)
                         (boundp spl-term-id)
                         (term-graph-p (symbol-value spl-term-id)))
                    (term-graph-symbol (symbol-value spl-term-id))
                  nil)))
    (loop for p in *plan-graphs*
          when (equal (term-graph-symbol (symbol-value p)) target)
          do
          (return-from FIND-SPL-SYMBOL-ANNOTATION
            (find-spl-annotation p)))))

;;; ----------------------------------------------------------------------
;;; 2.1 ready access to contextual-boundness... could well grow to
;;;     include a range of information status properties, so kept
;;;     very simple at this stage (John, Bremen, July99).
;; 3.2.26
;;  contextual-boundness recognition predicate extended to find 
;;  equivalent but SPL-distinct occurences of identifiers and to make
;;  reified relations invisible. For Ivana, Oct2000.
;; ----------------------------------------------------------------------

(defun GET-CB (spl-term-id)
  ;; has to fulfil these conditions or else its not relevant...
  (cond ((and (symbolp spl-term-id)
	      (boundp spl-term-id)
	      (term-graph-p (symbol-value spl-term-id)))
	 (let ((target (term-graph-symbol (symbol-value spl-term-id))))
	   (if target
	       (loop for p in *plan-graphs*
		     when (equal (term-graph-symbol (symbol-value p)) target)
		     do (if (term-graph-information-status (symbol-value p))
			    (return-from 
			     GET-CB
			     (cdr 
			      (assoc :cb (term-graph-information-status (symbol-value p)))))))
	     ;; if target is nil, i.e., symbol is nil, then there is a good chance that
	     ;; it is a reified relation...
	     (when (fetch-feature *range-name* spl-term-id)
	       (get-cb (fetch-feature *range-name* spl-term-id))))))
	(t nil)))

;;; ----------------------------------------------------------------------
;;; 4.1 
;;;     The old SPL functions are not very sophisticated in that they often
;;;     are content to find *one* instance of a particular slot. While this
;;;     makes some sense most of the time, as there should not be more
;;;     than one instance, there are occasional alternatives, e.g., several
;;;     location specifications. We therefore provide the following 
;;;     experimentally... extends fetch-subc-feature in the obvious way.

(defmacro fetch-subc-features (feature term)
  "Produce the symbolic ids of all terms associated with the given feature of the given term,
   or any feature which is a subc of the given feature.  If the term is not bound, look for
   the feature in some term having that symbol."
  (let ((f (intern-feature feature)))
    `(if (numberp ,term)
         nil
       (let ((search-space 
              (if (and (symbolp ,term) 
                       (boundp ,term)
                       (typep (symbol-value ,term) 'term-graph))
                  (symbol-value ,term)
                (symbol-value (get-symbol-term ,term)))))
         (union (loop for a-feature in (term-graph-features search-space)
                      when (or (eq (first a-feature) ,f)
                               (KB-superp (first a-feature) ,f))
                      collect (term-id (rest a-feature)))
                (fetch-reified-relations ,f ,term))))))

(defun fetch-reified-relations (relation term)
  "Look for RELATION as a reified entity in :RELATIONS."
  (let ((relations (symbol-value (fetch-feature 'relations term))))
    (when relations 
      (when (equal (term-graph-type relations) *spl-set-type*)
	;;
	;; if we have a set of variables, here use the list of
	;; variables instead of the um-set that groups them in the term-graph
	;; (*) But this must then be a list and the definition that
        ;;     was in there was just giving the car of the list and,
        ;;     even worse, evaluating it. This is very odd. The
        ;;     reason why such code was placed here needs to be
        ;;     found...
	(setf relations
              (term-graph-symbol relations))
        ;;
        ;; 4.0 make sure that we jump over possibly null textual instances
        ;;     of the term in the SPL to get the content... 
        ;;
        (loop for potential-reif-rel in relations
	      as reif-rel = (coreferential-term potential-reif-rel)
	      when (term-type-p reif-rel relation)
	      collect reif-rel)))))

;;; ----------------------------------------------------------------------
;;; Following functions were added by Niels in 2008 for
;;; some of the inquiry implementation conversion to
;;; Racer. Unclear why at this stage, possibly because
;;; the functions they rely on are defined as macros
;;; and so having them as functions was an easy way
;;; to reload inquiry implementations when the
;;; macros change? Probably not, as the macros
;;; are extremely rarely changed. However, copied over
;;; here so that they can disappear from the individual
;;; inquiry-implementation files for different languages
;;; where they are at present used (only English and
;;; German fortunately). Also a duplication removed
;;; (I see no difference between encaps-fetch-subc-feature
;;; and encaps-fetch-subc-feature-2) and an obvious
;;; error in encaps-term-graph-type (undefined
;;; global).

(defun encaps-fetch-feature (feature term)
  (if (kpml::term-graph-p (symbol-value term))
      (kpml::fetch-feature feature term) 
    nil)
  )

(defun encaps-fetch-subc-feature (feature term)
  (if (kpml::term-graph-p (symbol-value term))
      (kpml::fetch-subc-feature feature term) 
    nil))

  ;; encaps-fetch-subc-feature-2 removed ...

  ;; and following corrected to be halfway sensible, although
  ;; it is clearly never used since it would have thrown an error
  ;; as previously defined....
  ;;
(defun encaps-term-graph-type (term)
  (if (kpml::term-graph-p (symbol-value term))
      (kpml::term-graph-type term) 
    nil))




