(in-package "KPML")

;;; File: multilinguality.lisp
;;;
;;; Provides the basic multilingual functionality of KPML as originally
;;; implemented by Licheng Zeng for ML-Penman and subsequently 
;;; extended/debugged for use throughout KPML.
;;;
;;; KPML 2.0: Feb98 made clisp independent.

;/*-----------------------------------------------------------------------*/
;            Implementation of Language-specific Expression Class
;/*-----------------------------------------------------------------------*/
;
;struct LX-parser :: root {
;
;	struct 	namelst	{
;			symbol		name;
;			list		List-of-LSs;
;			}
;
;	struct  LS-lst  {
;			symbol		ls;
;			list		List-of-Atoms;
;			}
;
;       /*-- interfacing routines --*/
;       typedef struct LS-lst lst-LS-lst [maxnum];
;	
;	struct namelst  get-atom-ls(LX); 
;                           /* extract atom:ls pair, and sort them according to different atom */
;	lst-LS-lst	get-ls-atom(LX); 
;                           /* extract ls:atom pair, and sort them according to language specifier */
;	list		parse-clause(LX, ls); 
;                           /* isolate a normal Lisp expression from LX clause */
;       list            get-all-ls(LX);   
;                           /* extract all LSs from a LX clause);
;
;       /*-- house keeping routines --*/
;       get_nxt_sym(LX)
;       mk-ls-atom-pair(LS, symbol-table)
;	}
;
;  notice in get-ls-atom, LX will be considered as in ALL_LANGUAGES environment. The ':not :L' will 
;  return all LSs that are not :L.
;/*----------------------------------------------------------------------*/

;;;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(declaim (special all_languages))
;;;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

;---------------------------------------------------------------------
; syntax: get-atom-ls (LX-expression, &optional sort-it)
; return: list of atom-LS pairs sorted on atom. It takes the format: 
;         ((atom1, L1 ... Ln)(atom2, L1' ... Ln')...) 
; assume: 
; target: parse any LX expression to get a symbol table of that expression;
; global: ALL_LANGUAGES;
; symbol: symtab = symbol table for LX; 
;         atom-ls = table of atom-ls pairs;
; pseudo: call get-sym-tab to obtain symtab for the LX-expression;
;         copy all entries in symtab that are symbols to atom-ls;
;         if sort-it available, sort the atom-ls;
;-----------------------------------------------------------------------

(defun get-atom-ls (lx &optional sort-it)
  (let (atom-ls symtab)
    (setq symtab (mk-sym-tab lx ALL_LANGUAGES))
    (loop for every-item in symtab 
	do (if (symbolp (car every-item)) (push every-item atom-ls)))
    (if sort-it (sort atom-ls #'string-lessp :key #'car))
    atom-ls))


;---------------------------------------------------------------------------
; syntax: mk-sym-tab (LX LS)
; return: symbol table. numbers and Realization statements will also be treated as symbol in 
;         addition to ordinary symbols;
; assume: LX is syntactically correct, so this parser does not do any syntactic check;
; target: parse a LX expression to get a symbol table.
; global:
; symbol: id = type of the sym;
;         sym = symbol just obtained from the expression;
;         RestLX = rest of LX;
;         ROP = realization operator;
; pseudo: mk-Sym-Tab uses a Left-Right LR method for parsing LX. The method is greatly simplified 
;         from the original one because the use of LS Syntax. The idea is that: get one symbol from 
;         LX and from this terminal symbol we determine
;         which of the next possible non-terminal symbols to parse. Notice ROP stmt is treated 
;         simply as symbols and numbers
;         so that we may access ROP and lexico-grammatical functions as a whole. To extract 
;         lexico-grammatical functions,
;         we may simply go to the created symbol-table to find out the symbols that are of type
;         LIST, and get the functions. 
;---------------------------------------------------------------------------

(defun mk-sym-tab (LX LS)
  (unless LX (return-from mk-sym-tab nil))
  (let* ((result (get-nxt-sym LX))
    (id (first result))
    (sym (second result))
    (RestLX (third result)))

    (case id
      ((LX-symbol LX-number rop) 
                (cons (cons sym LS) (mk-sym-tab RestLX LS)))
			       ; for symbol-names, numbers and 
			       ; realization stmts, we register 
                               ; them as symbols in sym-tab.
      (lop      (mk-sym-tab RestLX LS))
                               ; for expression like (and/or ...), 
			       ; we simply ignore Logical
                               ; Operators and proceed to analyse
                               ; the rest of expression.
      (LX-list  (append (mk-sym-tab sym LS) (mk-sym-tab RestLX LS)))
			       ; for the pattern like: ((LX) LX...), 
			       ; we go one-level deep
      (ls       (append 
		 (mk-sym-tab (first RestLX) (intersection LS sym))  
		 (mk-sym-tab (cdr RestLX) LS)))
                               ; for language specifiers, :L LX1 LX2, 
			       ; LX1 is bound to :L, so LX1 is evaluated
			       ; under the situation :L, while LX2
			       ; shall not be evaluated under :L.
      (t nil))
))


;-------------------------------------------------------------------------
; syntax: get-nxt-sym (lx)
; return: a list of three elements. The first is symbol-type, the second symbol, 
;         the third is the left-over part of lx;
; assume:
; target: get first symbol (often referred to as 'handle' in compiler) from LX, identify its property. Also the (:not L)
;         expression will replaced by (ALL_LANGUAGES - (L)); 
; global: ALL_LANGUAGES
; symbol: handle = first symbol in LX, since the LX is already in parsed form. 
;         tail = rest of symbols in LX;
; pseudo: depending on handle, return different message for type, symbol and restlx. 
;         If LS is encountered, read in all LSs
;         on the same level, so we do not have to call :L1 :L2... recursively.
;         (ROP...) is tested twice so that in any
;         case, it will be treated as a single atom.
;---------------------------------------------------------------------------------------------------

;;; 0.8: language designator checking moved to a predicate, but
;;;      then have to explicitly check for :not occuring.
;;;      John:May95.
;;; 4.0: missed the clisp dependence in the while expression.

(defun get-nxt-sym (LX)
  (if (atom LX) (return-from get-nxt-sym (list 'LX-symbol LX nil)))
  (let ((handle (first LX)) (tail (rest LX)) id)
    (unless handle (return-from get-nxt-sym nil))
    (cond ( (listp handle) 
	    (if (member (car handle) operators) 
		(setq id 'rop) (setq id 'LX-list) ) )
	  ( (numberp handle) (setq id 'LX-number) )
	  ( (or (eq handle 'and) (eq handle 'or)) (setq id 'lop) )
	  ( (member handle operators) 
	    (setq id 'rop ) (setq handle lx) (setq tail nil))        
	  ( (or
	     (lg-designator-p handle) 
	     (eq handle :not))
	    (setq handle (list handle))
	    (loop while (lg-designator-p (car tail)) do 
		  (push (car tail) handle) (setq tail (cdr tail)))
	    (if (member ':not handle) 
		(setq handle (set-difference ALL_LANGUAGES handle)))
	    (setq id 'ls) )
	  ( (symbolp handle) (setq id 'LX-symbol) )
	  (t nil)
	  )
    (return-from get-nxt-sym (list id handle tail))
    ))


;----------------------------------------------------------------------------
; syntax: get-ls-atom (lx-exp)
; return: a list of atoms in the lx-exp sorted according to ls prefix; the data structure is LS-lst;
; assume: LX in correct syntax;
; target: parse lx, but organize symbol table in different order from get-atom-ls;
; global: ALL_LANGUAGES
; symbol: symtab = symbol table of lx-exp;
;         LS-set = all language specifiers occur in the LX-exp;
;         LS-atom-tab = ls-atom table we want; buffer = an entry in LS-atom-tab;
; pseudo: call get-atom-ls & we obtain symtab;
;         search symtab and find out LS-set;
;         for eachLS in LS-set do 
;             for eachATOM in symtab do if eachATOM.LS includes eachLS then put eachATOM.ATOM into
;                 buffer;
;             collect buffer into LS-atom-tab;
;         note: the algorithm below is not very efficient, but uses LISP facilities to make 
;               program easy. 
;--------------------------------------------------------------------------------------------------

(defun get-ls-atom (LX)
  (let (symtab LS-set)
    (setq symtab (get-atom-ls LX))
    (loop for each-symbol in symtab 
	do (setq LS-set (union LS-set (cdr each-symbol))))
    (return-from get-ls-atom 
      (loop for eachLS in LS-set collect (mk-ls-atom-pair eachLS symtab)))
    ))


;----------------------------------------------------------------------------
; mk-ls-atom-pair: scan through symbol table, and list all atoms that fall within the scope of ls
;----------------------------------------------------------------------------

(defun mk-ls-atom-pair (ls symtab)
  (let (ls-atom-pair)
    (loop for each-sym-entry in symtab 
	do (if (member ls (cdr each-sym-entry)) 
	       (push (car each-sym-entry) ls-atom-pair)))
    (return-from mk-ls-atom-pair (push ls ls-atom-pair))
    ))

;;; Here: Licheng's patch of Dec 10, 1991 with knots...

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

(defvar *KNOT* '&)

;----------------------------------------------------------------------------
; syntax: parse-clause (lx, ls, &optional float-ls)
; return: a clause of the type LIST;
; assume: lx is of correct LX syntax; LS must be a symbol or nil. In the latter case, 
;         parse-input-clause returns part of lx that is UNconditionalized.
; target: parse an LX expression and extract that part of lx that is conditionalized to ls.
; global: *KNOT*
; symbol: lx = an LX expression; ls = language specifier;
;         LS-set = handle = a set of language specifiers preceding a Lambda list;
;         restLX = tail = unprocessed LX expression;
;         float-ls = the LS-set that "&" in an LX expression should be interpreted as.
; pseudo: /* general method is to evaluate a Lambda list only if it is conditionalized by ls. */
;
;         break clause into car and cdr;
;         if car is knot, then replace car with float-ls, and parse-clause again;
;         if car is atom, then (cons car parse-input-clause cdr ls);
;         if car is ls, then {call get-nxt-sym, and obtain (id, handle, tail),
;                       float-ls := handle;
;                       if handle includes ls, then 
;                             (cons parse-clause(first(cdr),ls), 
;                                   parse-clause(rest(cdr),ls float-ls)) 
;                       else 
;                             just return parse-clause(rest(cdr),ls, float-ls); 
;         if car is list, then (cons parse-clause(first(cdr),ls), parse-clause(second(cdr), ls));
;         if car is nil, return nil
;         Note: For beautiful use of Lambda car,cdr resursion, parse-clause might return a list for 
;               single element. We will use strip-LX to convert such a list to a single element.
;------------------------------------------------------------------------

;;; 0.8: language designator checking moved to a predicate, but
;;;      then have to explicitly check for :not occuring.
;;;      John:May95.
;;; 0.9  possibility of strictly monolingual specs added for speedups
;;;      where required...

;;; This is the function where, of course, the multilingual generation
;;; algorithm spends most of its time: checking for each linguistic
;;; specification, which perspective is valid for the current language.
;;; Now, an additional flag is provided:
(defvar *rigidly-monolingual* nil "Do not interpret multilingual exprs")
;;; which ignores multilinguality. This can therefore be set when the
;;; linguistic resources loaded contain *no* multilingual conditionalizations.

(defun PARSE-CLAUSE (lx ls &optional float-ls)
  (if *rigidly-monolingual* 
      lx
    (always-parse-clause lx ls float-ls)))

(defun ALWAYS-PARSE-CLAUSE (lx ls &optional float-ls)
  (unless lx (return-from always-parse-clause nil))
  (if (atom lx) (return-from always-parse-clause lx))
  (cond ((or (lg-designator-p (car lx))
	     (eq (car lx) :not))
	 (let* ((result (get-nxt-sym lx)) 
		(LS-set (second result)) 
		(restLX (third result)))
	   (if (member ls LS-set)
	       (return-from always-parse-clause 
			    (cons (parse-clause (car restLX) ls) 
				  (parse-clause (cdr restLX) ls LS-set)))
	     (return-from always-parse-clause 
			  (parse-clause (cdr restLX) ls LS-set)))
	   ))
	
        ((and (atom (car lx)) (eq (car lx) *KNOT*))
	 (parse-clause (append float-ls (cdr lx)) ls))
					; knot treatment
	
        ((atom (car lx))     (return-from always-parse-clause 
			       (cons (car lx) 
				     (parse-clause (cdr lx) ls))))
	
	((and (listp (car lx)) (member (caar lx) operators))
	 (return-from always-parse-clause 
		      (cons (car lx) (parse-clause (cdr lx) ls))))
	
	((listp (car lx))    (return-from always-parse-clause 
                                          (cons (parse-clause (car lx) ls) 
                                                (parse-clause (cdr lx) ls))))
	)
  )


(defun parse-clause-for-lex (lx ls)
  (unless lx (return-from parse-clause-for-lex nil))
  (if (atom lx) (return-from parse-clause-for-lex lx))
  (cond ((keywordp (car lx))  
	 ;;; N.B. each keyword may introduce an additional level of
	 ;;; bracketing that is only there for grouping info together.
	 ;;; this should *not* be passed back up to the next level...
	 ;;; Strip-LX can not be guaranteed to get this right since
	 ;;; it only removes single elements... Suggested solution is
	 ;;; a change to LX-syntax that makes its semantics consistent:
	 ;;; :lx x now inserts x into the embedding structure, ASSUMING
	 ;;; THAT LISTS ARE ONLY THERE AS A BRACKETTING FOR THE LX;
	 ;;; thus :lg x inserts x into the structure, :lg (x y) inserts
	 ;;; the elements x and y into the structure, :lg ((x y)) inserts
	 ;;; the element (x y) into the structure, etc.... However,
	 ;;; rather than introduce this generally now, which could lead
	 ;;; to incompatible versions of multilingual grammars, use
	 ;;; this version for the moment only for the lexicon, where
	 ;;; it is *necessary* to be able to introduce elements into the
	 ;;; the top level list and where spurious brackets stop lexical
	 ;;; features being recognized. Hence the name change.
	 ;;;
	 ;;; Also, although this function is very compact when written
	 ;;; recursively, implementationally this causes huges run time
	 ;;; control stacks which usually overflow, it may also be a
	 ;;; major contribution to the slower generation times that
	 ;;; are experienced with the multilingual system. As soon as
	 ;;; someone thinks of an alternative implementation, it should
	 ;;; be tried out.

	 (let* ((result (get-nxt-sym lx)) 
		(LS-set (second result)) 
		(restLX (third result)))
	   (if (member ls LS-set)
	       (return-from parse-clause-for-lex
		 (if (atom (car restLX)) 
		     (cons (car restLX)
			   (parse-clause-for-lex (cdr restLX) ls))
		     (append (loop for ele in (car restLX)
				   collect
				     (parse-clause-for-lex ele ls))
			     (parse-clause-for-lex (cdr restLX) ls))))
	       (return-from parse-clause-for-lex 
		 (parse-clause-for-lex (cdr restLX) ls)))
	   )
	 )
        ((atom (car lx))     
	 (return-from parse-clause-for-lex  
	   (cons (car lx) (parse-clause-for-lex (cdr lx) ls))))
	((and (listp (car lx)) (member (caar lx) operators))
	 (return-from parse-clause-for-lex 
	   (cons (car lx) (parse-clause-for-lex (cdr lx) ls))))
	((listp (car lx))    (return-from parse-clause-for-lex 
			       (cons (parse-clause-for-lex (car lx) ls) 
				     (parse-clause-for-lex (cdr lx) ls))))
	)
  )


;---------------------------------------------------------------------------
; strip-LX (lambda-list): get rid of the list of single node. (x) -> x; () -> neglect
;--------------------------------------------------------------------------
;;; KPML 0.8: this is actually much stronger than I was assuming (John)
;;;           usually only want the top level to be treated, not all
;;;           sublists... Fortunately lists of single elements have not
;;;           occured very often: e.g., in SPL expressions. So it
;;;           may be possible to replace this one with a weaker version
;;;           given below (and used in ml-example-class experimentally).
;;;           It is possible that problems have been caused by the
;;;           overuse of the stronger definition.
        
(defun strip-LX (lx-list)
  (cond ((not lx-list)           nil)
        ((atom lx-list)          lx-list)
        ((eq (length lx-list) 1) (car lx-list))
        (t                       (loop for node in lx-list 
				     when node
				     collect (strip-LX node)))
	))
   

(defun WK-ST-LX (lx-list)
  (cond ((not lx-list)           nil)
	((atom lx-list)          lx-list)
	((eq (length lx-list) 1) (car lx-list))
	(t                       lx-list)))

;---------------------------------------------------------------------------
; SYNTAX: get-all-ls(LX)
; RETURN: a list of language specifiers;
; TARGET: extracting all explicit LSs from a LX expression;
; ASSUME: 
; GLOBAL: ALL_LANGUAGES;
; SYMBOL:
; PSEUDO: for X in LX collect following returns {
;             if X is atom, then neglect;
;             if X is keyword and x in ALL_LANGUAGES, return X;
;             if X is list, call get-all-ls(X) recursively;
;---------------------------------------------------------------------------

(defun get-all-ls(LX)
  (let ((all-ls nil))
    (loop for X in LX do 
	  (cond ((and (lg-designator-p X)  (not (member X all-ls))) 
		 (push X all-ls))
		((listp X) (setq all-ls (union all-ls (get-all-ls X))))
		)
	  )
    (return-from get-all-ls all-ls)))
     


;-------------------------------------------------------------------------
; SYNTAX: (Unify-LS-Lst ls-lst1 ls-lst2)
; RETURN: ls-lst3 containing result of unification;
; TARGET: unifying two ls-lst lists, so that the result is a superset of ls-lst1 and ls-lst2
; ASSUME: ls-lst1 and ls-lst2, ls-lst3 are list with LS-Lst data structure as element;
; GLOBAL: ALL_LANGUAGES
; SYMBOL: x = ls-lst in ls-lst2, y = ls-lst in ls-lst1 with the same ls as in x;
; PSEUDO: the result ls-lst3 consists of ls-lst built from the following rules:
;         1) if ls-lst.ls exists both in ls-lst1 and ls-lst2, then 
;               ls-lst = (ls (union ls-lst1.atoms ls-lst2.atoms);
;         2) if ls-lst.ls exists in either ls-lst1 or ls-lst2, but not both then
;               ls-lst = either ls-lst1 or ls-lst2.
;--------------------------------------------------------------------------
(defun Unify-LS-Lst (old-ls-lst  new-ls-lst)
  (let ((lptr nil) (result nil))
;
;-- scanning first ordered-pair
    (loop for x in old-ls-lst 
	do
	  (setf lptr (assoc (car x) new-ls-lst))
	  (if lptr 
	      (push (cons (car x) (union (cdr x) (cdr lptr))) result)
	    (push x result))
	  )
;
;-- scanning second ordered-pair
    (loop for x in new-ls-lst do
	  (unless (assoc (car x) old-ls-lst)
	    (push x result))
         )
    result)
  )



;;; Merge code pasted in...
;==========================================================================
; code for merging lx. Please paste it to the ML-penman-LX-class file.
; Evaluate the whole file. The code uses parse-clause function.
;========================================================================== 

;--------------------------------------------------------------------------
; SYNTAX: (merge-LX ML-lx)
; INPUTS: ML-lx = {lx}. each lx is a lx expression, all lx directives are supported.
; OUTPUT: NewLx = a merged lx expression, which is "lx-semantically" equivalent to
;           the combination of ML-lx;
; TARGET: merge lx expressions LX1 ... LXn into a new lx expression NewLx, which can be
;         recovered to be LX1 ... LXn by the format: (parse-clause NewLX Ls)
;
;         important: merge-lx does not merge LXs to a great extend because of the 
;         requirement to preserve structures of LX1 ... LXn. That means it cannot
;         create as many layers of embedding as it needs in order to capture 
;         maximum commonality. merge-lx merges LXs according to the semantics of
;         the lx expression; it only guarantees NewLx to be correct lx expression. 
;         The user should decide what LXn to be merged.
;
; ASSUME: LX syntax. All ML-LXs bear a somewhat similar structure (in order to present
;         a meaning).
; GLOBAL: operators
; SYMBOL: 
; PSEUDO: The general idea is to recover the 'pure' LISP form (cons-tree) of the 
;         expression in each language, put each form into superset. 
;         And then the algorithm scans through each cons-tree in the superset and tries
;         to merge each sub-cons-tree.
;
;--------------------------------------------------------------------------

;;;=======================================================================
;;; There were a couple of holes in the merging algorithm. These are
;;; patched up in the following.
;;; (function in ml-penman-lx-class).                    John:Sep94
;;; Further patch: nil seemed to squash all results
;;; rather than just the one conditionalized.            John:Dec94
;;; 0.8: but the fix was wrong, since we still have
;;;      to make sure that knots properly conditionalize
;;;      the elements of the non-nil expression...       John:Apr95

(defun merge-lx (&rest ML-lx)
  (declare (type list ML-lx))
  (let (superset tmp)

    (setq superset 

          (loop for eachLan in ALL_LANGUAGES  
	      when (setq tmp 
		     (strip-lx (parse-clause  ML-lx EachLan)))
	      collect 
		(if (atom tmp)
		    (cons EachLan (list tmp))
		  (cons EachLan tmp))
		))
              ; extract the original form of resource of each language
              ; double use of strip-lx here to get rid of excessive brackets.

    (Merge-ML-Tree superset)
))

;;; ----------------------------------------------------------------------
;;; 3.2.45 extra utility added here...

(defun MERGE-SIMPLE-LX-LISTS (lx1 lx2)
  "Function for merging in the multilingual expression lx2 into
     the expression lx1. Values are added, there is no replacement
     of existing values. If replacement is required, use something 
     else."
  (if lx1
   (multiple-value-bind (lx1-decomposed lx2-decomposed)
    (loop for i in all_languages
	as lx1-i = (parse-clause lx1 i)
	as lx2-i = (parse-clause lx2 i)
	when lx1-i
	collect (cons i lx1-i) into a
	when lx2-i
	collect (cons i lx2-i) into b
	;; 4.0+ was the following two lines, which is not ANSI compatible
	;; finally
	;; return (values a b)
	finally (return (values a b))
	)
    (let* ((relevant-lgs (mapcar #'first lx2-decomposed))
	   (merged
	    (loop for (lg . values) in lx1-decomposed
		  if (member lg relevant-lgs)
		  collect (progn
			    (setf relevant-lgs (remove lg relevant-lgs))
			    (cons lg (remove-duplicates 
				      (append values 
					      (cdr 
					       (assoc lg lx2-decomposed))))))
		  else
		  collect (cons lg values))))
      ;; and mop up those which are in lx2 but which were not already
      ;; in lx1...
      (when relevant-lgs 
	(setf merged (append merged (loop for lx in lx2-decomposed
					  when (member (first lx) relevant-lgs)
					  collect lx))))
      (mapcan #'(lambda (lx) 
		  (cons (first lx) 
			(butlast 
			 (loop for l in (cdr lx) collect l collect '&) 1)))
	      merged)))
   lx2))


;-------------------------------------------------------------------------
; SYNTAX: (Merge-ML-Tree TreeLst)
; INPUTS: TreeLst has the structure: ((:L1 # #...) (:L2 # # ...) ...)
;         Each element of TreeLst is a tree for a language specifier, standing for a piece
;         of resouce. The # is any lambda list form.
; OUTPUT: NewLx = a merged lx expression;
; TARGET: merge multiple lambda lists, based on structural resemblance.
; SYMBOL: left-tree = (car TreeLst), right-tree = (cdr TreeLst)
; PSEUDO: Merge-ML-Tree merges cons-tree structure based on following principles:
;         if TreeLst is empty, then no need to merge, just return nil;
;         if cons-trees in TreeLst are equal, then treat them as a unit, stick a set of
;            language specifiers in front of the unit; (capture maximun commonality)
;         if trees are terminal leaves, then they are mergable, so merge them;
;         otherwise, (merge-ML-Tree left-tree) and (merge-ML-tree right-tree).
;                    if the left-tree is an embeded tree, then we create an embedding
;                       structure in NewLX by CONSing left-tree & right-tree.
;                    if the left-tree is a flat symbol, then we simply append right-tree
;                       to the left-tree;
;---------------------------------------------------------------------------

(defun Merge-ML-Tree (TreeLst)
  (declare (type list TreeLst))

  (cond
   ((eq (length treelst) 1) 
    (ml-conditionalize 
     (first treelst))) ;; if only one item then merging done already
                       ;; *BUT* have to enforce conditionalization.
   ((Tree-Empty-p  TreeLst) nil)  ;; not sure this ever succeeds...
   ((Trees-null-p  TreeLst) nil)  ;; this takes care of empty trees for sure...
   ((Tree-Equal-p  TreeLst) (merge-sub-tree TreeLst))
   ((Tree-mergable TreeLst) (merge-treeleaf TreeLst))
   ((Left-Tree-p   TreeLst) (cons (Merge-ML-Tree (CAR-ML-tree TreeLst))
                                  (Merge-ML-Tree (CDR-ML-tree TreeLst))))
   ((Trees-similar-p TreeLst)
;;; only makes sense trying to merge if the structures to be merged
;;; are similar... i.e., don't try merging an atom with a list...
    (append (Merge-ML-Tree (CAR-ML-tree TreeLst))
	    (Merge-ML-Tree (CDR-ML-tree TreeLst))))

;;; otherwise     give  up    merging  and  just    put  the  language
;;; conditionalizations in place...
    (t (merge-treeleaf TreeLst))))

;;; ----------------------------------------------------------------------
;;; *** Also: there is a problem with the merging of choosers, in
;;; that they also use * as a comment character. This effects the
;;; following in that so-marked chooser components are then handled
;;; incorrectly since they trigger treeleaf-p whereas no other
;;; chooser operations do. It is also unfortunately the case,
;;; that some versions of Nigel use, e.g., classify statements
;;; in the choosers. Classifies must also therefore be intercepted.
;;; For this reason, I have introduced a
;;; somewhat hacky flag that must be set whenever one is trying
;;; to merge choosers.
;;;                                              John:IPSI:Dec94
(defvar *chooser-merging-mode* nil)

(defmacro TreeLeaf-P (x)
  `(or (atom ,x)
       (and (listp ,x) (member (car ,x) 
			       (if *chooser-merging-mode*
				   (remove 'classify 
					   (remove '* operators))
				 operators)))
       )
  )

;;; *** end of changes.



(defun CAR-ML-Tree (TreeLst)
  (declare (type list TreeLst))
 
  (loop for EachTree in TreeLst
      collect
	(if (TreeLeaf-p (second EachTree))
	    (list (car EachTree) (second EachTree))
	  (cons (car EachTree) (Second EachTree)))
       )
  )

(defun CDR-ML-Tree (TreeLst)
  (declare (type list TreeLst))

  (loop for EachTree in TreeLst
      collect
	(cons (car EachTree) (cddr EachTree))
       )
  )
         

(defun Left-Tree-P (TreeLst)
  (declare (type list TreeLst))

  (loop for tree in TreeLst
      always
	(not (TreeLeaf-P (second Tree)))
	)
  )

(defun Tree-Mergable (TreeLst)
  (declare (type list TreeLst))

    (if (or
         (loop for tree in TreeLst
	     thereis (= (length tree) 1))
         (and
          (loop for tree in TreeLst
               always (= (length tree) 2))
          (loop for tree in TreeLst
	      thereis (treeLeaf-p (second tree)))
          ))
      t 
      nil)
)

(defun Tree-Equal-p (TreeLst)
  (declare (type list TreeLst))

  (loop for tree in (cdr TreeLst)
       always
       (tree-equal (cdr (first TreeLst)) (cdr tree))
       )
  )
     

    
(defun Tree-Empty-p (TreeLst)
  (declare (type list TreeLst))

  (loop for tree in (cdr TreeLst)
       always
       (not tree))
  )

(defun Trees-null-p (TreeLst)
  (declare (type list TreeLst))

  (loop for tree in TreeLst
       always
       (not (cdr tree)))
  )

(defun Trees-similar-p (TreeLst)
  (declare (type list TreeLst))

  (let* ((keys (mapcar #'second TreeLst))
	 (type (type-of (first keys))))

    (loop for key in keys
	always (eq (type-of key) type))))

(defun merge-sub-tree (TreeLst)
  (declare (type list TreeLst))
  (let (ls-set newtree)

    (setq ls-set (loop for tree in TreeLst collect (car tree)))
    (loop for eachone in (cdr (first TreeLst))
	do
	  (setq newtree (append newtree (list  eachone *KNOT*)))
	  )

    (append ls-set (butlast newtree))
    ))



(defun merge-treeleaf (treelst)
  (declare (type list TreeLst))
  (let (symtab residue SharedLeaves)

  (loop for leaf in TreeLst
      do
	(if (second leaf)
         (setq symtab (insert-leaf symtab (car leaf) (second leaf)))
         )       
                 ; find out the shared tree leaves
                 ; if (:l1 x ...), then we insert the pair (:l1 x ) into symtab.

       (if (cddr leaf)
         (block insert-residue
           (setq residue 
                 (append residue (list (car leaf))))
           (loop for eachone in (cddr leaf)
	       do
		 (setq residue (append residue (list eachone *knot*)))
		 )
           (setq residue (butlast residue))
           ))       
              ; now we have the residue: (:l1 x & y :l2 a & b ...)
       )         
       
  
  (loop for eachone in symtab 
      do
       (setq sharedLeaves 
             (append SharedLeaves
                     (append (car eachone) (cdr eachone))))
       )
       
  (append SharedLeaves Residue)
  ))


(defun insert-leaf (symtab ls data)
  (declare (type list symtab)
           (symbol ls))
  (let (ptr)

  (if (setf ptr (find data symtab :key #'second :test #'equal))
    (setf (car ptr) (pushnew ls (car ptr)))

         ; the point here is : e.g.
         ; symtab = ( ((l1 l2) x) ((l2 l3) y) ...)
         ; ptr = ((l1 l2) x) if data = x. Hence result will be:
         ; symtab = ( ((l1 l2 l6) x) ((l2 l3) y) ...) if ls = l6.

    (return-from insert-leaf 
                 (push (list (list ls) data) symtab))
    )
  symtab
))


;;; ----------------------------------------------------------------------
;;; Utilities...

(defun EXTRACT-LG-SPECIFIERS (list)
  (loop for x in list when (keywordp x) collect x))

;;; By now need the combination (strip-lx (parse-clause ...)) so often,
;;; may as well define a function for it.

(defun STRIP-ML (x ls) (strip-lx (parse-clause x ls)))

;;;----------------------------------------------------------------------
;;; KPML 0.8 addition; recognition of language conditionalizations
;;;   is parameterized by the following predicate...
;;;

(defun LG-DESIGNATOR-P (symbol)
;; 0.9: presumably the following conjunct was meant to speed things up!
;;     (keywordp symbol)
;;   this it certainly does not do. (John:IPSI:Oct95). It is redundent
;;   since all_languages is only allowed to contain proper language
;;   variety names (which are all keywords).
  (member symbol all_languages))

;;; Following takes an input expression where the first element marks a
;;; language conditionalization that is to apply to the all the
;;; elements of the expression represented by the rest of the
;;; input expression.
;;;
(defun ML-CONDITIONALIZE (prefixed-expression)
  (let ((lgvar (first prefixed-expression))
	(expression (rest prefixed-expression))
	(result nil))
    (push lgvar result)
    (push (first expression) result)
    (loop for element in (rest expression) do
	  (push '& result)
	  (push element result))
    (reverse result)))
    
;;; ----------------------------------------------------------------------
(defun CHECK-LANGUAGE-AVAILABILITY (lg-list)
  (dolist (lg lg-list)
    (unless (member lg all_languages)
      (warning "System not configured to expect language variety: " lg))))

;;; ----------------------------------------------------------------------
;;; KPML 0.8: following function merges in a new value to a multilingual
;;;           expression... Always returns an lx-expression.

(defun UPDATE-SLOT-FOR-ONE-LANGUAGE-ONLY
  (old-slot-value new-value lg &optional (lgs all_languages))
  (unless lg (setf lg curlan))
  (cond ((not old-slot-value)
	 (if (and new-value lg)
	     (list lg new-value)
	   nil))
	((not (parse-clause old-slot-value lg))
	 (append 
	  (list lg new-value)
	  old-slot-value))
	(t
	 (let ((old-lg-value-pairs nil))
	   (loop for l in lgs
		 unless (eq l lg)
		 do
		 (setf old-lg-value-pairs
		       (append (list l
				     (parse-clause old-slot-value l))
			       old-lg-value-pairs)))
	   (apply #'merge-lx (append
			      (list lg new-value)
			      old-lg-value-pairs))))))

;;;====================================================================
;;; Function  for  switching  languages,  in  case this  becomes  more
;;; complicated  than changing  a variable  value ---  code using this
;;; function then need not be changed.

(defun SWITCH-LANGUAGE (&key (language curlan) 
			     (load-patches nil))
  (let ((old-curlan curlan))
    (setf curlan language)
    (when load-patches
	  (unless (eq curlan old-curlan)
		  (load-language-specific-patches curlan)))))

