;;
;;
;;      Title : D-Unify and D-IsExtensionOf
;;
;;      Function :  finds the unification of two syntactic
;;            categories.  Also finds out if two categories are extensions
;;
;;      Author :   Alan W Black  17th March 1986
;;     
;;      Copyright : Graeme Ritchie, Alan Black,
;;                  Steve Pulman and Graham Russell  1987
;;
;;         ---------------------------------------------
;;         |    Not to be used for military purposes   |
;;         ---------------------------------------------
;;
;;               >>>>>  UNRESTRICTED UNIFICATION <<<<<
;;
;;      Description :
;;          These functions find the unifcation and extension of two
;;          categories that can contain variables
;;
;;          category A is an extension of category B iff
;;           1. all atomic valued features B are in A with the same
;;              values.
;;           2. for any category-valued feature f in A, the value of f in A
;;              is an extension of the value of f in B.
;;
;;          The unification of two categories is the smallest category 
;;          that is an extension of both.  It can be thought of as
;;          the union of categories (and values of category valued features).
;;
;;          These routines are pretty fundemental to the ideas of feature
;;          grammars in general (and GPSG in particular).  I have tried
;;          to make them as efficient as possible but this is not easy
;;          as they are pretty difficult tasks.
;;
;;          If there was not any variables it would be a lot easier,
;;          but not nearly as useful.
;;
;;      Parameters :
;;      Returns :
;;      Side Effect :
;;
;;      External references :
;;
;;      System functions used :
;;        Name     type      Args #  type                 Comment
;;
;;      Restrictions :
;;
;;
(declare
   (special
      D-VARIABLENUMBERS
      )
   (localf
      D-Unify                         
      D-UnifyDD
      D-UnifyFPair                    
      D-IsExtensionOf                 
      D-MatchFeature                  
      D-FindType                      
      D-UniquifyVariables
      D-UniquifyCategory
      D-UniquifyFeature
      D-BuildGrammarDiscrimminationNet
      D-BuildDList
      D-FindUnMatchingRules
      D-PossibleFeatures
      D-AddFeatToList
      D-GetValueType
      D-MatchWithDList
      D-DereferenceVariables
   )
)

(defmacro D-MakeBinding (var value bindings)
;;
;;   Adds a new binding to the bindings list
;;
   `(cons
      (list ,var ,value)
      ,bindings
   )
)

(defun D-Unify (cat1 bind cat2)
;;
;;   Unification a la Gazdar and Pullum GPSG.  A union of two categories
;;   With the condition that if a feature exists in both categories 
;;   then  they must have equal feature values
;;   The unification is returned or the atom FAILED if no unification exists
;;
;;   Returns the pair  (newcat bindings)
;;   This effectively extends cat1 until it holds all of cat2
;;
   ;(setq TOT (+ 1 TOT))
   (catch 'morph
      (D-UnifyDD cat1 bind cat2)
   )
)

(defun D-UnifyDD (cat1 bind cat2)
   (let ( (cat cat1) (localbind bind) )
      (mapc   
	 #'(lambda (fpair)
	    (let ( (newcatbind (D-UnifyFPair cat localbind 
			   (D-GetFeature (car fpair) cat)
			   fpair)) )
              (cond 
		 ((eq newcatbind 'FAILED)
                    (throw 'morph 'FAILED))
		 (t
	            (setq cat (car newcatbind))
	            (setq localbind (cadr newcatbind))))))
	 cat2
      )
      (list cat localbind)
   )
)

(defun D-UnifyFPair (cat1 bind1 fpair1 fpair2)
;;
;;   Adds fpair2 to cat1 making necessary changes to bindings as required
;;   returns new category and new bindings
;;   
   (cond
      ((null fpair1)   ;; fpair2 does not exist in cat1
	 (list
	    (cons 
	       fpair2  ;; new feature pair
	       cat1)
            bind1)
      )
      ((eq (cadr fpair1) (cadr fpair2))  ;; an efficiency hack
	 (list cat1 bind1)
      )
      (t
	 (let ( (fv1 (D-FindType (cadr fpair1) bind1))
                (fv2 (D-FindType (cadr fpair2) bind1)) )
	    (cond
	       ((and (eq (car fv1) 'LITERAL) (eq (car fv2) 'LITERAL))
		  (cond
		     ((D-CatValFeatP (car fpair2))
		        (let ( (lower (D-UnifyDD (cadr fv1) bind1
		  			       (cadr fv2))) )
                        (cond
		  	   ((eq lower 'FAILED) 'FAILED)
			   ((D-VariableP (cadr fpair1))   ;; funny case
			      (list
				 cat1
			         (D-MakeBinding   ;; may get used later
				    (cadr fpair1) ;; note this is being
				    (car lower)   ;; re-bound
				    (cadr lower))))
			   (t
			      (list (cons
			          (list (car fpair1) (car lower))
				  (D-RemoveFeature (car fpair1) cat1))
			          (cadr lower))))))
                     ((eq (cadr fv1) (cadr fv2))
			(list cat1 bind1))     ;; eq literals
                     (t 'FAILED)))  ;; different literals
               ((eq (car fv1) 'LITERAL)  ;; fv2 a variable
                  (cond
		     ((or (eq (caddr fv2) (DK-category))  ;; category valued var
		       (memq (cadr fv1) (caddr fv2))) ;; is it in range of var
			  (list cat1
			      (D-MakeBinding   ;; may get used later
				 (cadr fv2)
				 (cadr fv1)
				 bind1)))
                     (t 'FAILED)  ;; lit not in range of variable
                 )
               )
	       ((eq (car fv2) 'LITERAL)  ;; fv1 a variable
                  (cond
		     ((or (eq (caddr fv1) (DK-category))  ;; category valued var
		       (memq (cadr fv2) (caddr fv1))) ;; is it in range of var
			  (list cat1
			     (D-MakeBinding
				(cadr fv1)  ;; Variable name
				(cadr fv2)  ;; variable value
				bind1)))
                     (t 'FAILED)  ;; lit not in range of variable
                 )
               )
	       (t        ;; both are variables
		  (let ( (newrange (D-IntersectVar (caddr fv1) (caddr fv2))) )
		     (cond
			((null newrange) 'FAILED)  ;; vars incompatible
			(t
			   (let ( (newvar (D-MakeNewVariable newrange)) )
			   (list
			      cat1
			      (D-MakeBinding
			         (cadr fv1)  ;; variable name
 			         newvar      ;; new variable is value
			         (D-MakeBinding
				    (cadr fv2)
				    newvar
				    bind1)))))))
               )
            )
         )
      )
   )
)

(defun D-IsExtensionOf (cat1 bind1 cat2)
;;
;;  tests to see if cat2 is an extension of cat1.
;;  returns a a list of bindings if true, nil if not true.
;;  The bindings returned are bind1 plus the sufficient additions
;;  to make cat2 an extension of cat1
;;
;;  cat2 is an extension of cat1 if cat2 contains at least all features
;;  that cat1 has.
;;
;;  Note bind1 is always non-nil (default is (t t))
;;  cat1 comes from an active edge, cat2 from an inactive one
;;  all variables in cat2 have been replace with there values
;;  (which means all variables that can be literals have been
;;  changed to literals)
;;
   ;(printc "Enter IsExtensionOf") (terpri)
   ;(print cat1) (terpri)
   ;(print bind1) (terpri)
   ;(print cat2) (terpri)
   (cond
      ((null cat1)   ;; all categories are an extension of the empty category
	 bind1       ;; return new set of bindings (which could be nil)
      )
      ((null bind1)  ;; previous operation failed so return failure
	 nil
      )
      ((or (D-VariableP cat1) (D-VariableP cat2))
         ;; this hack means the proper result is given (honest)
	 ;; the pairs passed in are guaranteed to be cat vald features
	 (D-MatchFeature
	    (list (DK-STEM) cat1)  ;; a guaranteed cat val feat
	    bind1
	    (list (DK-STEM) cat2)))
      (t
	 (D-IsExtensionOf   ;; it is more efficient to search the category
	    (cdr cat1)      ;; in the given order
	    (D-MatchFeature  
	       (car cat1)
	       bind1 
	       (D-GetFeature (caar cat1) cat2))
	    cat2
         )
      )
   )
)

(defun D-MatchFeature (fpair1 bind1 fpair2)
;;
;;  checks to see if feature fpair1 matches fpair2.
;;  returns (possibly augmented) bind1 if a match
;;  nil otherwise
;;
   (cond
      ((null fpair2)  ;; cat2 does not have fpair1 in it
	 nil          ;; fail match
      )
      ((null bind1)
	 nil          ;; previous match failed so return failure
      )
      ((eq (cadr fpair1) (cadr fpair2))  ;; this is an efficiency hack
	 bind1
      )
      (t
         (let ( (fv1 (D-FindType (cadr fpair1) bind1))
	        (fv2 (D-FindType (cadr fpair2) bind1)) )
            (cond
	       ((and (eq (car fv1) 'LITERAL)
		     (eq (car fv2) 'LITERAL))
                  (cond
		     ((eq (cadr fv1) (cadr fv2)) bind1)
		     ((D-CatValFeatP (car fpair1))
			(D-IsExtensionOf 
			   (cadr fv1) bind1 (cadr fv2))
                     )
		     (t   nil)))
               ((eq (car fv2) 'LITERAL)
                  (cond
		     ((or (eq (caddr fv1) (DK-category))  ;; category valued var
		      (memq (cadr fv2) (caddr fv1))) ;; is it in range of var
			(D-MakeBinding
			   (cadr fv1)  ;; variable name
			   (cadr fv2)  ;; value
			   bind1)      ;; old bindings
                     )
		     (t   nil)));; literal not in var range so fail
               ((eq (car fv1) 'LITERAL)
                  (cond
		     ((or (eq (caddr fv2) (DK-category))
		      (memq (cadr fv1) (caddr fv2))) ;; is it in range of var
			(D-MakeBinding
			   (cadr fv2)  ;; variable name
			   (cadr fv1)  ;; value
			   bind1)      ;; old bindings
                     )
		     (t   nil)));; literal not in var range so fail
               (t                      ;; so both are variables
		  (let ( (newrange (D-IntersectVar (caddr fv1) (caddr fv2))) )
		     (cond
			((null newrange) nil)  ;; vars incompatible
			(t
			   (let ( (newvar (D-MakeNewVariable newrange)) )
			   (D-MakeBinding
			      (cadr fv1)  ;; variable name
 			      newvar      ;; new variable is value
			      (D-MakeBinding
				 (cadr fv2)
				 newvar
				 bind1)))))))
            )
         )
      )
   )
)
 
(defun D-FindType (term bindings)
;;
;;   Finds out what a term is, either a variable or a literal.
;;   If Term is directly a variable it looks for any binding of
;;   it (and recursively)
;;   returns (LITERAL <value>)
;;        or (VARIABLE <name> <range>)
;;
;;   note that the original term passed maybe a variable but the
;;   bindings are searched until the end of the isbound to relationship
;;   is reached
;;
   (cond
      ((D-VariableP term)
         (let ( (binding (D-PattBinding term bindings)) )
	    (cond
	       ((eq binding 'D-UNBOUND)
		  (list 'VARIABLE term (D-GetVarRange term)))
	       (t (D-FindType binding bindings))
            )
         )
      )
      (t
	 (list 'LITERAL term)
      )
   )
)

(defun D-UniquifyVariables (rule)
;;
;;  Substitutes all variables in the rule for new unique variable
;;  names.  This is to avoid name clashes
;;
   (cond
     ((D-GetGRuleVarFlag rule)
	 (let  ( (bindings (ncons (list nil nil))) )
	    (cons
	       (D-GetGRuleName rule)       ;; name of rule
	       (mapcar
		  #'(lambda (category)
		     (D-UniquifyCategory category bindings))
		  (D-GetGRuleCategories rule)
	       )
	    )
         )
      )
      (t (cdr rule))   ;; return simple rules without flags
   )
)

(defun D-UniquifyCategory (cat bindings)
;;
;;   substitute all variable in a category for normalise ones
;;
   (mapcar
      #'(lambda (fpair)
         (D-UniquifyFeature fpair bindings)
      )
      cat
   )
)

(defun D-UniquifyFeature (fpair bindings)
;;
;;  substitute all variables for unique ones
;;
   (cond
      ((D-VariableP (cadr fpair))
	 (let ( (value (assq (cadr fpair) bindings)) )
	    (cond       ;; variable unchanged   
	       ((null value) ;; variable is unbound
		  (let ( (newvar (D-MakeNewVariable 
				       (D-GetVarRange (cadr fpair)))) )
		     (attach (list (cadr fpair) newvar) bindings)
                     (list (car fpair) newvar)))
               (t
		  (list (car fpair) (cadr value)))))
      )
      ((D-CatValFeatP (car fpair))
	 (list
	    (car fpair)
	    (D-UniquifyCategory (cadr fpair) bindings))
      )
      (t    ;; simple literal
	 fpair
      )
   )
)

(defun D-BuildGrammarDiscrimminationNet (grammar)
;;
;;   Builds a tree (discrimmination net) where in each level
;;   the first node is labelled with the names of all rules that 
;;      do not have the current feature
;;         and a subtree for the next feature
;;   the second node is all those that have a variable value
;;         and a subtree for the next feature
;;   and then nodes for each value of the current feature that
;;      are found in the grammar
;;
;;   This is built up from the features in the first daughters of
;;   the grammar rules because I am running bottom up
;;
   (cons
      (mapcar #'(lambda (rule)
	 (D-GetGRuleName rule)) grammar)
      (D-BuildDList 
	  (D-PossibleFeatures
	      (mapcar #'(lambda (rule)
		 (D-GetGRuleFirstDaughter rule)) grammar))
	   (mapcar            
	     #'(lambda (rule)
		 (cons (D-GetGRuleName rule)
		       (D-GetGRuleFirstDaughter rule))) grammar)
      )
   )
)

(defun D-BuildDList (featlist catrules)
;;
;;  builds a tree of the form
;;     (
;;        <current feature>
;;        <fvalue list of rules which cannot be with this value>
;;        <fvalue1 list of rules which cannot be with this value>
;;        <fvalue2 list of rules which cannot be with this value>
;;        ...
;;     )
;;
;;
   (cond
      ((null featlist)
	 nil
      )
      ((eq (cdar featlist) (DK-category))   ;; ignore category values features
	 (D-BuildDList (cdr featlist) catrules))
      (t
	 (let ( (dpart 
		  (mapcan
		     #'(lambda (value)
			(let ( (unmatching
			      (D-FindUnMatchingRules 
				 (caar featlist) value catrules)) )
			   (cond
			      ((null unmatching) nil)  
			      (t
				 (ncons
				    (cons value
				       (mapcar #'car unmatching)))))))
		     (cdar featlist))) )
            (cond
	       ((null dpart)   ;; it doesn't discriminate anything
	          (D-BuildDList (cdr featlist) catrules))
               (t
		  (cons
		     (cons (caar featlist) dpart)
	             (D-BuildDList (cdr featlist) catrules))))
         )
      )
   )
)

(defun D-FindUnMatchingRules (feat value catrules)
;;
;;   returns a list of rulenames which cannot match the given feat
;;   and value
;;
   (cond
      ((null catrules)
	 nil)        ;; none
      (t
	 (let ( (fpair (D-GetFeature feat (cdar catrules))) )
	    (cond
	       ((null fpair)
		  (D-FindUnMatchingRules feat value (cdr catrules)))
               ((eq (D-GetValueType (cadr fpair)) 'D-VARIABLE)
		  (cond
		     ((or (eq (D-GetDeclVarRange (cadr fpair)) (DK-category))
			  (memq value (D-GetDeclVarRange (cadr fpair))))
		        (D-FindUnMatchingRules feat value (cdr catrules)))
                     (t   ;; doesn't match the variable so add to list
		        (cons (car catrules)
		           (D-FindUnMatchingRules feat value (cdr catrules))))))
	       ((eq (D-GetValueType (cadr fpair)) value)
		  (D-FindUnMatchingRules feat value (cdr catrules)))
               (t   ;; doesn't  match
		  (cons (car catrules)
		     (D-FindUnMatchingRules feat value (cdr catrules))))
            )
         )
      )
   )
)

(defun D-PossibleFeatures (cats)
;;
;;   given a list of features returns a list of things
;;   each with a feature name and a list of the possible values
;;
   (let ( newlist )
      (mapcar
	 #'(lambda (cat)
	    (mapcar
	       #'(lambda (fpair)
		  (setq newlist (D-AddFeatToList fpair newlist)))
               cat))
         cats)
      (mapcar 
	 #'(lambda (fname)
	       (cons fname
	          (D-GetFeatRange fname)))
         newlist)
   )
)

(defun D-AddFeatToList (fpair cumlist)
;;
;;   adds this fpair into the cummulated list
;;
   (cond
      ((memq (car fpair) cumlist)
	 cumlist)
      (t
	 (cons (car fpair) cumlist)))
)

(defun D-GetValueType (thing)
;;
;;  returns the value or 'D-VARIABLE if a variable
;;
;;  what do I do with category valued features ?
;;
   (cond
      ((D-VariableP thing) 'D-VARIABLE)
      ((D-DeclaredVariableP thing) 'D-VARIABLE)
      (t thing)
   )
)

(defun D-MatchWithDList (category acceptable dlist)
;;
;;  matches the given category with the dicrimmination tree to 
;;  give a list of grammar rules that it matches
;;
   (cond
      ((null dlist)        ;; end of search
	 acceptable        ;; list of matching names
      )
      (t
	 (let ( (fpair (D-GetFeature (caar dlist) category))  )
	    (cond
	       ((null fpair)   ;; category doesn't contain 
		  (D-MatchWithDList
		     category acceptable (cdr dlist)))
               (t
		  (let ( (unmatched (assq (D-GetValueType (cadr fpair))
						(cdar dlist))) )
		     (cond 
			((null unmatched)
			   (D-MatchWithDList
			      category acceptable (cdr dlist))
                        )
			(t
			   (D-MatchWithDList
			      category 
			      (D-RemoveUnacceptable 
				 acceptable (cdr unmatched))
			      (cdr dlist))))))))
      )
   )
)

(defun D-RemoveUnacceptable (l1 l2)
;;
;;  destructively changes l1 to remove each element that also
;;  in l2
;;
   (cond
      ((null l2) l1)
      (t
	 (D-RemoveUnacceptable
	    (delq (car l2) l1 1) (cdr l2))))
)

(defun D-DereferenceVariables (category bindings)
;;
;;   This checks for any occurrences of the given variables and instantiates
;;   them in category.  The new category is returned
;;
   (cond
      ((equal bindings '((t t)))  ;; if no bindings nothing to do
	 category  ;; this is not required but is for efficiency
      )
      (t
         (mapcar
            #'(lambda (feat)           ;; for each feature in category
	       (let ( (fv (D-FindType (cadr feat) bindings)) )
	          (cond
	             ((eq (car fv) 'LITERAL)
			(cond
			   ((D-CatValFeatP (car feat))
			      (list (car feat)
				    (D-DereferenceVariables
				       (cadr fv) bindings)))
                           (t
		              (cons (car feat) (cdr fv))))
                     )
	             (t      ;; a variable
		        (list (car feat) (cadr fv))
                     )
                  )
               ))
            category
         )
      )
   )
)
 
