(in-package "KPML")

;;; File: ml-merging.lisp
;;; 
;;;====================================================================
;;; ... and now the work of merging instances of linguistic objects
;;;      that are defined for different sets of (possibly overlapping)
;;;      languages...
;;;
;;; If *merging-active* is   set,  then the following  function   will
;;; attempt  to  merge   incoming   new  definitions   with   existing
;;; definitions of the same name rather than overwriting them. This is
;;; to be used particularly when  the languages of the two definitions
;;; are different.  It does not make  sense to  overwrite the system X
;;; for German just because a system X for Spanish is loaded. This has
;;; to be strictly  limited, since the  general problem of unification
;;; of systems cannot be solved automatically.

;;; The following restrictions are therefore observed:
;;;
;;;  - merging is by name only (that is no systems of distinct names will
;;;    be merged)
;;;    
;;;  - merging is only undertaken when we are in the context of a properly
;;;    defined region with a single language specified as default: this
;;     is because at the stage that this function is called, the 
;;;    language of the new-instance has not been properly established.
;;;
;;; Works as follows: the old instance and the new instance are
;;; taken apart with respect to the languages for which they 
;;; are defined, creating a set of system instances: one new,
;;; the other old. For instances where the languages overlap,
;;; the new replaces the old; where they do not overlap,
;;; they are unified/merged.
;;;
;;;---------------------------------------------------------------------
;;; The  following  function  is  a generalized  function  for merging
;;; linguistic units according to the merge-lx method of Licheng.
;;;

;;; For debugging purposes, the following globals are sometimes set:
(defvar *MERGED-INSTANCE* nil "For debugging")
(defvar *MERGED-SLOT-VALUE* nil "For debugging")

(defun GENERALIZED-MERGE-INSTANCE 
  (list-of-lg-instance-pairs list-of-slots creator-function)
  (let ((merged-instance (apply creator-function nil)))
    (setf *merged-instance* merged-instance)
    (dolist (f list-of-slots)
	      (setf *merged-slot-value*
		    (apply #'merge-lx 
			   (let ((arg-list nil))
			     (dolist 
			      (pair list-of-lg-instance-pairs)
			      (let ((res-f 
				     (apply f (list (second pair)))))
				(setf arg-list 
				      (append
				       (list 
					(first pair) 
					(if (or 
;;; 0.8.31: cases where stripping not appropriate extended to
;;;         include system outputs and lexeme properties... Any others?
					     *chooser-merging-mode*
					     (eq f 'system-outputs)
					     (eq f 'lexical-item-properties)
;;; 0.9
					     (eq f 'example-logicalform))
					    res-f
					  (strip-lx res-f)))
				       arg-list))
				(when *step-by-step-merging-behavior*
				  (format t
					  "~%KPML>MERGING:ARG-LIST: ~A"
					  arg-list))
				))
			     arg-list)))
	      (when *step-by-step-merging-behavior*
		    (format t
			    "~%KPML>MERGING:RESULT (slot: ~A): ~A" 
			    f *merged-slot-value*))
	      ;; beware!! this is not runtime compatible of course (but
	      ;; I don't have a working non-ACL runtime generator, so
	      ;; I'll let it stand for now (John:Oct97).
	      #-acl3.0
	      (eval
	       `(setf (,f *merged-instance*) (quote ,*merged-slot-value*)))
	      #+acl3.0  ;; following is however robust for runtime...
	      (kpml-apply-acl-setf-of 
	       f *merged-instance* *merged-slot-value*)
	      )
    (setf merged-instance *merged-instance*)
    (setf *merged-instance* nil)
    merged-instance))

;;; ... this is used for creating functions such as merge-system-instances
;;; etc

#||

(defun MERGE-SYSTEM-INSTANCES (list-of-lg-instance-pairs)
  (let ((instance   (generalized-merge-instance
		     list-of-lg-instance-pairs
		     '(system-name system-inputs system-outputs 
		       system-chooser system-selector
		       system-region system-metafunction
		       system-patch-status)
		     #'create-system)))
    (setf (system-language-set instance)
	  (mapcar #'first list-of-lg-instance-pairs))

;;; following ugliness is necessary because of gates and ml-expressions
;;; competing for the use of embeddings!
    (unless (wellformedness-check (system-outputs instance))
	    (setf (system-outputs instance) (list (system-outputs instance))))
    instance))

;;; ... the following is just an example of what the generalized
;;; functions would expand into...

(defun expanded-merge-system-instances (list-of-lg-instance-pairs)
  (let ((merged-instance (create-system)))
    (setf (system-name Merged-Instance) (merge-lx lg1 (system-name i1)
						  lg2 (system-name i2)))

    (setf (system-inputs Merged-Instance) (merge-lx lg1 (system-inputs i1)
						    lg2 (system-inputs i2)))

    (setf (system-outputs Merged-Instance) (merge-lx lg1 (system-outputs i1)
						     lg2 (system-outputs i2)))

    (setf (system-chooser Merged-Instance) (merge-lx lg1 (system-chooser i1)
						     lg2 (system-chooser i2)))

    (setf (system-selector Merged-Instance) (merge-lx lg1 (system-selector i1)
						      lg2 (system-selector i2)))
    
    (setf (system-region Merged-Instance) (merge-lx lg1 (system-region i1)
						    lg2 (system-region i2)))
    
    (setf (system-metafunction Merged-Instance) (merge-lx lg1 (system-metafunction i1)
							  lg2 (system-metafunction i2)))
    Merged-Instance))
||#

;;;--------------------------------------------------------------------
;;; Following functions  create sets of   monolingual instances from a
;;; multilingual instance.

  ;; ----------------------------------------------------------------------
  ;; 3.2.31
  ;; Bit nasty this one... was not merging multilingual instances correctly
  ;; because it was not always conditionalising the language appropriately
  ;; to make the access functions work.
  ;; Consequence:
  ;;   Obscure merging bug fix for 
  ;;   (L1:nil->L2:object->L3:nil = L1,L2,L3:object).
  ;; ----------------------------------------------------------------------

(defun CREATE-SET-OF-MONO-LINGUAL-INSTANCES (object type)
  (let ((hash-table (case type
			  (:system system-table)
			  (:chooser choosers)
			  (:inquiry quiry-operators)
			  (:lexeme lexicon)
			  (:example penexamples))))
    (flet ((lg-set-function (x)
	    (case type
		  (:system (system-language-set x))
		  (:chooser (chooser-ls-set x))
		  (:inquiry (inquiry-operator-ls-set x))
		  (:lexeme (lexical-item-ls-set x))
		  (:example (example-ls-set x))))
	   (object-to-list-fn (x lg)
	    (case type
		  (:system  (system-to-list-multi-to-mono x lg))
		  (:chooser (chooser-to-list-multi-to-mono x lg))
		  (:inquiry (inquiry-to-list-multi-to-mono x lg))
		  (:lexeme (lexeme-to-list-multi-to-mono x lg))
		  (:example (example-to-list-multi-to-mono x lg))))
	   (instance-to-list-fn (x lg)
	    (case type
		  (:system (system-instance-to-list-multi-to-mono x lg))
		  (:chooser (chooser-instance-to-list-multi-to-mono x lg))
		  (:inquiry (inquiry-instance-to-list-multi-to-mono x lg))
		  (:lexeme (lexeme-instance-to-list-multi-to-mono x lg))
		  (:example (example-instance-to-list-multi-to-mono x lg))))
	   (creator-function (x)
	    (case type
		  (:system (apply #'create-system x))
		  (:chooser (apply #'make-chooser x))
		  (:inquiry (apply #'make-inquiry-operator x))
		  (:lexeme (apply #'make-lexical-item x))
		  (:example (apply #'make-example x)))))

  (cond ((symbolp object)
	 (for language in (lg-set-function (gethash object hash-table))
	      collect
	      (let ((curlan language))      ;; 3.2.31 important!
		(declare (special curlan))  ;;        (of course)
		(list language
		      (creator-function
		       (cdr (object-to-list-fn object language)))))))
	(t
	 (for language in (lg-set-function object)
	      collect
	      (let ((curlan language))      ;; 3.2.31 important!
		(declare (special curlan))  ;;        (of course)
		(list language
		      (creator-function
		       (cdr (instance-to-list-fn object language)))))))))))
	
;;;--------------------------------------------------------------------
;;; To try and stop messup output feature specifications slipping
;;; through due to too many or too few strip-lx's....
;;; Returns T if ok.
;;; OK is when:
;;;  (i) the first element of the output spec is in any case a 
;;;      list;
;;;  (ii) the first non-language variety specification element
;;;      of the output spec is a list
;;; The first case is included in the second, but is hopefully
;;; quicker to check.

(defvar *ml-tuning-flag* nil)

(defun wellformedness-check (output-spec)
  (cond ((or (consp (first output-spec))
	     (block look-for-first-non-conditioner
		    (dolist (o output-spec)
			    (when (not (member o all_languages))
				  (return-from 
				   look-for-first-non-conditioner
				   (consp o))))))
	 T)
	(t
	 (when *ml-tuning-flag*
	       (format *trace-output*
		       "~%;;; ML-tuning. Wellformedness failure. 
;;; Repairing following expression: ~A" output-spec))
	 nil)))
	    
