(in-package "KPML")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;COPYRIGHT (C) UNIVERSITY OF SOUTHERN CALIFORNIA, 1987                         ;
;UNIVERSITY OF SOUTHERN CALIFORNIA, INFORMATION SCIENCES INSTITUTE             ;
;4676 ADMIRALTY WAY                                                            ;
;MARINA DEL REY, CALIFORNIA 90292                                              ;
;                                                                              ;
;THIS SOFTWARE WAS PARTIALLY DEVELOPED UNDER NATIONAL SCIENCE FOUNDATION       ;
;GRANT IST-8408726, FEDERAL CONTRACT NUMBERS MDA903-81-C-0335,                 ;
;MDA903-87-C-0641, F49620-84-C-0100, AND F49620-87-C-0005, AND THE             ;
;GOVERNMENT HOLDS LICENSE RIGHTS UNDER DAR 7-104.9 (A)(C)(1).  IT IS           ;
;TRANSMITTED OUTSIDE OF THE UNIVERSITY OF SOUTHERN CALIFORNIA ONLY UNDER       ;
;WRITTEN LICENSE AGREEMENTS OR SOFTWARE EXCHANGE AGREEMENTS, AND ITS USE       ;
;IS LIMITED BY THESE AGREEMENTS.  AT NO TIME SHALL ANY RECIPIENT USE THIS      ;
;SOFTWARE IN ANY MANNER WHICH CONFLICTS OR INTERFERES WITH THE                 ;
;GOVERNMENTAL LICENSE RIGHTS OR OTHER PROVISIONS OF THE GOVERNING              ;
;AGREEMENT UNDER WHICH IT IS OBTAINED.  IT IS SUPPLIED "AS IS," WITHOUT        ;
;ANY WARRANTIES OF ANY KIND.  IT IS FURNISHED ONLY ON THE BASIS THAT ANY       ;
;PARTY WHO RECEIVES IT INDEMNIFIES AND HOLDS HARMLESS THE PARTIES WHO          ;
;FURNISH AND ORIGINATE IT AGAINST ANY CLAIMS, DEMANDS OR LIABILITIES           ;
;CONNECTED WITH USING IT, FURNISHING IT TO OTHERS OR PROVIDING IT TO A         ;
;THIRD PARTY.  THIS NOTICE MUST NOT BE REMOVED FROM THE SOFTWARE, AND IN       ;
;THE EVENT THAT THE SOFTWARE IS DIVIDED, IT SHOULD BE ATTACHED TO EVERY        ;
;PART.                                                                         ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; NB: John: Feb94: note that the use of function calls with macro
;;; applications can get those functions called when the wrong
;;; package is active; particularly warning. Package explicitly
;;; added below.

;;; SPL DEFAULTS:  
;;; Currently active default values are stored in the :activedefault
;;; slot of inquiries.  These default values may be appealed to by
;;; OPERATOR-RUN when answering an inquiry.

;;; ================================================================
;;;		       APPLICATION-LEVEL INTERFACE
;;; ================================================================
(defvar *APPLIC-PRI*)


;;; DEFSPL-DEFAULT
;;; ==============
;;;
;;; used to define default environments

(defmacro DEFSPL-DEFAULT (env-name &rest features)
  `(if (eq (first ',features) 'constant)
       (define-default-env ',env-name (process-features (rest ',features) nil)
	 :constant t)
       (define-default-env ',env-name (process-features ',features nil))))


;;; BEGIN-DEFAULT
;;; =============
;;;
;;; used to invoke default environments

(defmacro BEGIN-DEFAULT (env-name)
  `(begin-default-env ',env-name))


;;; END-DEFAULT
;;; ===========
;;;
;;; If env-name is provided, then close most recent active instance
;;; of that environment and all more recently opened environments.
;;; When env-name is not provided, just close most recent environment.

(defmacro END-DEFAULT (&optional env-name)
  `(end-default-env ',env-name))


;;; *SPL-DEFAULT-TABLE*
;;; ===================
;;; In order to accomodate multiple levels of defaults,
;;; a separate data structure is used to store default definitions.
;;; Hash table, indexed by keyword.
;;; The value for an entry is a list of spl-default structures,
;;; which is sorted by:
;;;   1. priority-level,
;;;   2. recency.

(defvar *spl-default-table* (make-hash-table :size 50))


;;; Each default definition is recorded in a spl-default structure:

(defstruct spl-default
  (keyword nil :type atom)
  (value nil :type atom)  ; TERM-GRAPH ID
  (priority *applic-pri* :type integer)
  (envir nil :type atom)
  (constant nil :type atom))

;;; PRIORITY:
;;; Higher numbers for priority-level indicate greater priority.
;;; Any number of priority levels is possible in the implementation.

;;; John: Stirling: May97 (must these really be constants??)
(defconstant *penman-pri* 0)
;; (defconstant *applic-pri* 10)
(defvar  *applic-pri* 10)

;;; ENVIR:
;;; used for selective addition and removal of default-definitions
;;; in order to provide envirs of defaults with a temporal scope.

;;; CONSTANT: boolean, t = interpret this default as constant,
;;; taking precedence over the inquiry operator code.


;;; DEFAULT DEFINITION FUNCTIONS

;;; ADD-SPL-DEFAULT
;;; ===============

(defun add-spl-default (feature value &key
			(priority *applic-pri*)
			envir constant)
  (let* ((new-def (make-spl-default :keyword feature
				    :value value
				    :priority priority
				    :constant constant
				    :envir envir))
	 (prev-defs (gethash feature *spl-default-table*))
	 (active-def (first prev-defs))
	 (active-value (when active-def
			 (if (listp (spl-default-value active-def))
			     (first (last (spl-default-value active-def)))
			     (spl-default-value active-def)))))
    (if (and active-def
	     (> (spl-default-priority active-def) priority))

	;; new-def has lower priority than active-def
	;; find correct position for new-def in prev-defs.
	(setf (gethash feature *spl-default-table*)
	      (merge 'list (list new-def) prev-defs
		     #'> :key #'spl-default-priority))

	(if (and active-def
		 (eql envir (spl-default-envir active-def))
		 (eql priority (spl-default-priority active-def))
		 (or (inq-response-term value)
		     (listp (spl-default-value active-def))))

	    ;; add to list of parameterized defaults for feature
	    (let* ((prev-value (spl-default-value active-def))
		   (new-value (if (listp prev-value)
				  (if (inq-response-term value)
				      (cons value prev-value)
				      (mapcar #'(lambda (elt)
						  (if (inq-response-term elt)
						      elt
						      value))
					      prev-value))
				  (list value prev-value))))
	      (setf (spl-default-value active-def) new-value)
	      (set-current-default-value feature new-value))

	    ;; new-def should become the current default
	    (progn
	      (if (inq-response-term value)
		  (setq value (list value active-value))
		  (when (identifying-inquiry-p feature)
		    (setq value (merge-terms-with-copy value active-value))))
	      (setf (spl-default-value new-def) value)
	      (setf (gethash feature *spl-default-table*)
		    (push new-def prev-defs))
	      (set-current-default-value feature value))))))

(defun inq-response-term (val)
  (let ((term (if (and (symbolp val)
		       (boundp val))
		  (symbol-value val)
		  val)))
    (when (typep term 'term-graph)
      (eq (term-graph-type term) 'inquiry-response))))


;;; MERGE-TERMS-WITH-COPY  returns a copy of TERM with info of NEW-TERM merged in,
;;; =====================  if the following conditions hold:
;;; both values are term-graphs (not atoms), AND
;;; the term-type of one of the values specializes
;;; (or is the same as) the term-type of the other value, AND
;;; the values of all features of the two term-graphs are compatible.
;;; Otherwise, just return TERM.

(defun merge-terms-with-copy (term new-term)
  (setq *merged-terms* nil)
  (setq *merge-failure* nil)
  (if (and
	(typep term 'term-graph)
	(typep new-term 'term-graph)
	(comensurate-p term new-term))
      (let ((result-term (copy-spl-term-graph term)))
	(merge-terms result-term new-term)
	(if (not *merge-failure*)
	    (progn
	      (replace-all-graph-symbols result-term)
	      result-term)
	    term))
      term))


;;; COMENSURATE-P
;;; =============
;;; Return non-NIL if the term-type of one of the terms specializes
;;; (or is the same as) the term-type of the other term.

(defun comensurate-p (term1 term2)
  (let ((type1 (term-graph-type term1))
	(type2 (term-graph-type term2)))
    (or (null type1)
	(null type2)
	(if (atom type1)
	    (term-type-p (term-graph-id term2) type1)
	    (every #'(lambda (type)
		       (term-type-p (term-graph-id term2) type))
		   type1))
	(if (atom type2)
	    (term-type-p (term-graph-id term1) type2)
	    (every #'(lambda (type)
		       (term-type-p (term-graph-id term1) type))
		   type2)))))

  
;;; REMOVE-SPL-DEFAULT
;;; ==================
;;;
;;; If ENVIR is specified, then remove the most recent default
;;; for FEATURE that is in specified ENVIR.
;;; If ENVIR is not specified, then just remove the most recent default.

(defun remove-spl-default (feature &key
			   (priority *applic-pri*)
			   (envir nil))
  priority  ; for the compiler
  (let ((prev-defs (gethash feature *spl-default-table*))
	new-def)
    (if (or (not envir)
	    (and prev-defs
		 (eq envir (spl-default-envir (first prev-defs)))))
	;; remove current default
	(if (rest prev-defs)
	    (progn
	      (setq new-def (first (rest prev-defs)))
	      (setf (gethash feature *spl-default-table*)
		    (rest prev-defs))
	      (set-current-default-value
		feature
		(spl-default-value new-def)))
	    (progn
	      (caution "Removing only default value for: " feature)
	      (setf (gethash feature *spl-default-table*) nil)
	      (set-current-default-value feature nil)))
	;; remove some inactive default
	(setf (gethash feature *spl-default-table*)
	      (remove-if #'(lambda (def-envir)
			     (eq def-envir envir))
			 prev-defs
			 :key #'spl-default-envir
			 :count 1)))))





;;; GET-CURRENT-DEFAULT-VALUE
;;; =========================
;;;
;;; Returns the currently active default value for FEATURE
;;; in *spl-default-table*

(defun get-current-default-value (feature)
  (let ((def (first (gethash feature *spl-default-table*))))
    (when def
      (spl-default-value def))))


;;; CONSTANT-DEFAULT-VALUE
;;; ======================
;;;
;;; Returns the constant default value for INQUIRY, if one has been defined.

(defun constant-default-value (inquiry-name)
  (let ((def (first (gethash inquiry-name *spl-default-table*)))
	answer)
    (when (and def
	       (spl-default-constant def))
      (setq answer (spl-default-value def)))
    (if (typep answer 'term-graph)
	(term-graph-id answer)
	answer)))


;;; DEFAULT ENVIRONMENTS
;;; definitions currently stored in a global association list,
;;; with item format: (env-name priority feature-list &optional constantp)
;;; NOTE: priority of environments is currently ignored.

(defvar *defined-default-environments* nil)

;;; stack of active environments is an association list,
;;; with item format: (env-name . instance-id)

(defvar *active-default-environments* nil)
(defvar *current-priority* *penman-pri*)


;;; DEFINE-DEFAULT-ENV
;;; ==================
;;;
;;; feature-list -> (feature value)*

(defun define-default-env (env-name feature-list &key
			   (constant nil)
			   (priority *applic-pri*))
  (when (assoc env-name *defined-default-environments*)
    (penman::warning "Default environment " env-name " is being redefined."))
  ;; Warn about any unsupported keywords
  (dolist (feature feature-list)
    (let ((feature-type (spl-keyword-type (first feature))))
      (case feature-type
	((askoperator identifyoperator))
	((relation system special)
	 (penman::warning "Default values for " feature-type " keywords ("
		  (first feature) " in default environment "
		  env-name ") not supported."))
	(macro
	 (penman::warning "Default value for macro, " feature
		  ", was not expanded."))
	(otherwise
	 (penman::warning "Attempt to define default value for unknown keyword: "
		  feature)))))
  (push (list env-name priority feature-list constant)
	*defined-default-environments*)
  env-name)


;;; ACCESS FUNCTIONS for default environment definitions

(defmacro default-env-features (env)
  `(third ,env))

(defmacro default-env-constantp (env)
  `(fourth ,env))


;;; BEGIN-DEFAULT-ENV
;;; =================
;;;
;;; Returns a unique identifier for this invocation of the envir.

(defun BEGIN-DEFAULT-ENV (env-name)
  (let ((env-def (assoc env-name *defined-default-environments*)))
    (if env-def
	(let ((id (gentemp (symbol-name env-name)))
	      (features (default-env-features env-def)))
	  (incf *current-priority*)
	  (dolist 
	   (feature features)
	   (let ((inq (find-symbol 
		       (string (first feature))
		       (find-package "PENMAN"))))
	     (add-spl-default inq
			      (cdr feature)
			      :priority *current-priority*
			      :constant (default-env-constantp env-def)
			      :envir id)))
	  (push (cons env-name id) *active-default-environments*))
	(penman::warning "Default environment " env-name " is not defined."))))



;;; END-DEFAULT-ENV
;;; ===============
;;;
;;; If env-name is provided, then close most recent active instance
;;; of that environment and all more recently opened environments.
;;; When env-name is not provided, just close most recent environment.

(defun end-default-env (&optional env-name)
  (if env-name
      (if (assoc env-name *active-default-environments*)
	  (loop
	    (let ((env (pop *active-default-environments*)))
	      (close-default-env env)
	      (decf *current-priority*)
	      (when (eq env-name (first env))
		(return env-name))))
	  (penman::warning "END-DEFAULT-ENV (" env-name
		   ") attempted with no such active environment."))
      ;; close most recent environment
      (if *active-default-environments*
	  (close-default-env (pop *active-default-environments*))
	  (penman::warning "END-DEFAULT-ENV attempted with no active environment."))))

;;; CLOSE-DEFAULT-ENV
;;; =================

(defun close-default-env (env-pair)
  (let* ((id (cdr env-pair))
	 (env-def (assoc (car env-pair) *defined-default-environments*))
	 (feature-list (default-env-features env-def)))
    (dolist (feature feature-list)
      (remove-spl-default (intern (symbol-name (first feature)) (find-package 'penman)) :envir id))
    env-pair))


;;; INITIALIZE-SPL-DEFAULTS
;;; =======================
;;; The SPL-DEFAULT-TABLE is initialized with the :trivialdefault values
;;; defined for each Penman inquiry at priority-level *penman-pri*.
;;; Redefinition of an inquiry should add a new default-definition
;;; to the SPL-DEFAULT-TABLE with priority *penman-pri*.
;;; 0.9: why did initialization clear out the defined default
;;;      environments? This seems a bit strong. 

(defun initialize-spl-defaults ()
  ;; First, close any active defaults.
  (when *active-default-environments*
    (loop
      (let ((env (pop *active-default-environments*)))
	(close-default-env env)
	(decf *current-priority*)
	(when (null  *active-default-environments*)
	  (return)))))
;;  (setq *defined-default-environments* nil)
  (setq *active-default-environments* nil)
  (setq *current-priority* *penman-pri*)
  (clrhash *spl-default-table*)
  (set-trivial-defaults))


;;; ----------------------------------------------------------------------
;;; The following collection of functions for setting up the SPL defaults,
;;; the inquiry response default environments, etc. are on their
;;; way out as they are gradually integrated and automated in the
;;; KPML resource loading mechanisms.

;;; Need the following stuff so often, collect it together in 
;;; a function.

;;; KPML 0.8: add a merging option, which means that existing 
;;;   default environments are not cleared.

(declaim (special *merging-active*))

;;; Old Penman function: ready-defaults, even as changed in KPML betas
;;; for multilinguality, should no longer be used.

;;; In the ML-environment with individual language resources
;;; perhaps having different macros and defaults, the following
;;; function relativizes spl macro definition to the directory
;;; maintaining the linguistic resources...

;;; NOTE: In KPML 0.8 this function is largely taken over by the
;;;  standard and automatic resource loading functions in 
;;;  kpml-resource-maintenance. That is, when resources are loaded,
;;;  it will normally be the case that the defaults are loaded
;;;  and activated for the language being loaded. 

(defun ML-READY-DEFAULTS (language)
  (let* ((lg-name (string language))
	 (lg-root-directory 
	  (pathname
	   (concatenate 'string 
	    (coerce-directory common-lisp-user::*root-of-resources*) lg-name "/")))
	 (spl-macros
	  (merge-pathnames (pathname lg-root-directory)  "basic-spl-macros.lisp"))
	 (spl-macros? (open spl-macros :direction :probe))
	 (spl-defaults
	  (merge-pathnames (pathname lg-root-directory)  "basic-spl-defaults.lisp"))
	 (spl-defaults? (open spl-defaults :direction :probe))
	 (spl-defaults-activate
	  (merge-pathnames (pathname lg-root-directory)  "activate-defaults.lisp"))
	 (spl-defaults-activate? (open spl-defaults-activate :direction :probe))
	 (kpml-0.7-load-basic-defaults
	  (merge-pathnames (pathname lg-root-directory)  
			   "load-basic-defaults.lisp"))
	 (kpml-0.7-load-basic-defaults? 
	  (open kpml-0.7-load-basic-defaults :direction :probe)))
    (when spl-macros? 
	  (format *trace-output* "~%;;; Loading SPL macros for language: ~A" 
		  language)
	  (load spl-macros))
    (when spl-defaults?
	  (format *trace-output* "~%;;; Loading SPL defaults for language: ~A" 
		  language)
	  (load spl-defaults))
    (cond (spl-defaults-activate?
	   (format *trace-output* 
		   "~%;;; Activating SPL defaults for language: ~A" curlan)
	   (load spl-defaults-activate)
	   (when kpml-0.7-load-basic-defaults?
		 (warning "Old-style load-basic-defaults file is also present:
this is being ignored and should be removed.")))
	  (kpml-0.7-load-basic-defaults?
	   (warning "Only old-style load-basic-defaults file found. This is being loaded, but it should be renamed to \"activate-defaults\"")
	   (load kpml-0.7-load-basic-defaults)))
    ))

;;; ----------------------------------------------------------------------
;;; KPML 0.8: during the default setting of loading a new language,
;;;           the new SPL default environments are to be merged into existing
;;;           defaults rather than replacing them. This is triggered
;;;           by the global:

          (defvar *merging-during-language-switching* NIL)

;;;           which is only set T during this phase.
;;; ----------------------------------------------------------------------

;;; SET-CURRENT-DEFAULT-VALUE
;;; =========================

;;; ----------------------------------------------------------------------
;;; KPML 0.8: actually, we should merge in the active default, so
;;;           as not to disturb values that are already present.
;;;           If nothing is there, then in any case a LX-expression
;;;           should be created...
;;; ----------------------------------------------------------------------

(defun SET-CURRENT-DEFAULT-VALUE (feature value)
  (let ((feature-type (spl-keyword-type feature)))
    (case feature-type
      ((askoperator identifyoperator)
;; when Penman and KPML code merged properly can use the
;; following setf-method, until then...
;;       (setf (fetch-inquiry-info feature 'activedefault) ...)
       (if (inquiry-defined-for-lg-p feature curlan)
	   (replace-inquiry-info FEATURE 'ACTIVEDEFAULT
				 (update-slot-for-one-language-only 
				  (inquiry-operator-activedefault
				   (gethash feature quiry-operators))
				  value
				  curlan
				  (fetch-inquiry-info feature 'ls-set)))
	 (warning "Default setting: no inquiry " feature " for " curlan ".")))
      ((relation system special)
       (warning "Default values for " feature-type " keywords ("
		feature	") not supported."))
      (macro
       (warning "Default value for macro, " feature
		", was not expanded."))
      (otherwise
       (warning "Attempt to set default value for unknown keyword: "
		feature)))))

;;; ----------------------------------------------------------------------
;;; KPML 0.8: while the following is fine monolingually, in that it
;;;  stacks away old default values on the spl-default-table so that
;;;  they can be restored when the default environment pops, for
;;;  multilingual operation it is problematic in that we want to
;;;  *merge* new values for different languages with existing
;;;  values. To deal with this, stacking defaults is made
;;;  conditional upon *merging-during-language-switching*. 
;;; ----------------------------------------------------------------------

(defun SET-TRIVIAL-DEFAULTS ()
  (loop for op-name in inquiry-operators
	do
	(let* ((default (fetch-inquiry-info op-name 'trivialdefault)))
	  (when default
		(when (consp default)
		      (setq default (symbol-value (term-to-graph default))))
		(if *merging-during-language-switching*
		    (set-current-default-value op-name default)
		  (add-spl-default op-name default :priority *penman-pri*))))))

;;; ----------------------------------------------------------------------
;;; KPML 2.1 and multilinguality...
;;; ----------------------------------------------------------------------

(defun SETUP-SPL-KEYWORDS-OVER-LANGUAGE-RANGE ()
  (if *current-language-range*
      (progn
	(format *trace-output* "~%;;; Resetting SPL keyword types over: ~A"
		*current-language-range*)
	(loop for curlan in *current-language-range*
	    do (setup-spl)))
    (setup-spl)))
