(in-package "KPML")

;;; File: shared-discourse-semantics.lisp
;;;
;;; Contains a few remnant attempts at controlling some textual decisions.
;;; Most of what was here as been moved to modiciation-specification.lisp
;;; for KPML 1.1+. 

;;; ----------------------------------------------------------------------
;;; Identifiability... originally from Nigel inquiry implementations...
;;;   but modified to provide an identifiability method for anyone
;;;   who wants to use use it. Includes:
;;; i) Identifiability of possessed items follows that of possessor; 

(defvar *identifiability-possessor-transitivity* nil)

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

(defun Identifiability-Q-Code (item &optional (recursive-limit nil))
  (kpml::identifiability-method item recursive-limit))

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

(defun IDENTIFIABILITY-METHOD (item recursive-limit)
  "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."
  (let ((old-identifiable-value
	 (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 *identifiability-possessor-transitivity* (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 *identifiability-possessor-transitivity* (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 *identifiability-possessor-transitivity* (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 *identifiability-possessor-transitivity* (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 *identifiability-possessor-transitivity*
		   (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)))))))

    (textual-identifiability-check item old-identifiable-value)))

(defun TEXTUAL-IDENTIFIABILITY-CHECK (item old-value)
  (let* ((types? (term-graph-type (symbol-value item)))
	 (types (if (consp types?) types?
		  (list types?))))
    (when (intersection types
			*domain-identifiables*)
	  (return-from TEXTUAL-IDENTIFIABILITY-CHECK 'identifiable))
    old-value))



;;;
;;; ============================================================
;;;
;;; Remainder changes some of the default inquiries...

;;; Following changed so that generalized-possession's are not picked up...
;;; To avoid `whose OWNED-BY is'. 

(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)
		       ))
	     (not (pledged-p process)))
      'process)))

;;; Following changed so that generalized-possessions, particular owned-by, are
;;; picked up. But *not* if the obj is identifiable!

;;; BEWARE!!! THIS FUNCTION IS DEFINED 3 OR 4 TIMES IN INQUIRY-IMPLEMENTATIONS.LISP
;;;           AS IT IS; OBVIOUSLY PROBLEMATIC!

(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))
	  (and (fetch-subc-feature 'owned-by obj)
	       (not (identifiability-q-code obj))))
      'portion))


(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))
      (if (fetch-subc-feature 'owned-by obj)
	  (fetch-relation-spec obj 'owned-by 'Portion-Modification-ID))))



