;;
;;      Name: Unrestricted Unification Routines
;;
;;      Functions:  contains routines that are specific to 
;;                  Unrestricted Unification
;;
;;      Author: Alan W Black September 1984
;;              Dept of A.I.
;;              University of Edinburgh
;;
;;      Copyright Graeme Ritchie, Alan Black,
;;                Steve Pulman and Graham Russell  1987
;;
;;         ---------------------------------------------
;;         |    Not to be used for military purposes   |
;;         ---------------------------------------------
;;
;;

(declare
   (special
      D-CurrentSym
      D-WHEAD
      D-WDAUGHTER
      D-MORPHOLOGYONLY
      D-DISTINGUISHEDCATEGORY
      D-CATVALFEAT
      D-LCATEGORIES
      D-LOADEDPARTS
      D-fileid
   )
   (localf
      D-ParseCatDef
      D-ParseFeatureClass 
      D-ParseTopCategory
      D-MakeCanMakeTree 
      D-CheckConventions
      D-ParseLCategory
      D-CheckDistCat
      D-CheckTopCat
   )
)

(defun D-ParseCatDef ()
;;
;;   parses a category definition
;;   This is not allowed in the bay area unification form so an
;;   error is given forcing the user to modify the grammar/lexicon
;;   file
;;
   (D-FindCurrentLine)
   (error "CatDefs are only allowed in the Term Unification System")
)

(defun D-ParseFeatureClass ()
;;
;;  This takes a feature classes declaration and adds
;;  to the appropriate global list
;;  Currently three classes are valid,
;;    WHead, WDaughter and MorphologyOnly.
;;  consistancy checks are done later
;;
   (cond
      ((eq D-CurrentSym (DK-WHead))
         (D-GetNextSym)    ;; skip to class list 
	 (D-MustHave '=)
	 (setq D-WHEAD (D-ParseSimpleSet))  ;; list of head features
      )
      ((eq D-CurrentSym (DK-WDaughter))
         (D-GetNextSym)    ;; skip to class list 
	 (D-MustHave '=)
	 (setq D-WDAUGHTER (D-ParseSimpleSet)) ;; list of daughter features
      )
      ((eq D-CurrentSym (DK-MorphologyOnly))
	 (D-GetNextSym)    ;; skip to class list
	 (D-MustHave '=)
	 (setq D-MORPHOLOGYONLY (D-ParseSimpleSet)) ;; list of morpho-features
      )
      (t
	 (D-FindCurrentLine)
	 (error (concat "Unknown Feature Class name " D-CurrentSym))
      )
   )
)

(defun D-ParseTopCategory ()
;;
;;   Parses the definition of a top category that is 
;;   used in parsing to define what a word is
;;   This category can include variables - it is defaulted to
;;   nil if the user does not specify it and a warning is given
;;
;;   All parses that span the chart and has labels that are extensions of 
;;   D-DISTINGUISHEDCATEGORY are valid parses
;;
   (D-MustHave '=)
   (setq D-DISTINGUISHEDCATEGORY
         (D-ParseCategory))
)

(defun D-MakeCanMakeTree (grammar)
;;
;;  Used in term unification version
;;
   nil
)

(defun D-CheckConventions (edge)
;;
;;    this checks the three feature passing conventions for the given
;;    edge.  If the edge is incomplete no checking is done
;;    The conventions only work on BINARY branching rules.
;;    The three passing conventions are
;;    Wsister
;;       This is a check rather than passing features.  Of the two
;;       daughters.  The value (a category value) of the feature STEM
;;       which one and only one will have must be a subset of the label
;;       of the other daughter
;;    Whead
;;       The mother label should be the unification of the current
;;       mother label and the whead features of the right daughter
;;    Wdaughter
;;       For each feature in this class if it is in the right daughter
;;       it is copied up to the mother, if not the left daughter is
;;       checked and if their it is copied up to the mother.
;;
;;    This also instantiates all variables to their lowest form
;;    which may be a literal or a variable.  This is so in later
;;    matches time is saved when finding the value of variables
;;
;;
   (cond
      ((or (D-getedgeREMAINDER edge)     ;; is it incomplete
	   (D-LexicalEdgeP edge))    ;; or a lexical edge
	 edge                    ;; no checking of conventions required
      )
      ((eq 2 (length (D-getedgeRECOG edge)))  ;; binary branching rule
	 (let ((bind (D-WSisterConvention
	                (D-LeftDaughter edge)
			(D-RightDaughter edge)
			(D-getedgeBIND edge))))
            (cond
	       ((null bind) nil)         ;; failed sister convention
	       (t
		  (D-putedgeBIND edge bind)
	          (D-WHeadConvention edge)
	          (D-WDaughterConvention edge)
	          (D-ApplyDefaults edge)   ;; check if unification was valid
		  (cond
		     ((eq 'FAILED (D-getedgeLABEL edge)) nil)
		     (t
			(D-putedgeLABEL;; simplify label removing var chains
			   edge
			   (D-DereferenceVariables
			      (D-getedgeLABEL edge)
			      (D-getedgeBIND edge)
			   )
			)
			edge))))))
      (t                        ;; other lengthed rule
	 (D-ApplyDefaults edge)
	 (D-putedgeLABEL;; simplify label removing var chains
	    edge
	    (D-DereferenceVariables
	       (D-getedgeLABEL edge)
	       (D-getedgeBIND edge)
	    )
	 )
	 edge)
   )
)

(defun D-ParseLCategory ()
;;
;;   parses a lexical category definition
;;
   (let ( cat values feat )
      (cond
	 ((D-CatValFeatP D-CurrentSym)   ;; a category extension
	    (setq feat D-CurrentSym)
	    (D-GetNextSym)
	    (setq cat (D-ParseCategory))
            (D-MustHave '=)
            (D-MustHave '>)
            (setq values (D-ParseSimpleSet))
            (setq D-LCATEGORIES 
	       (cons (list feat cat values)
	          D-LCATEGORIES))
         )
	 (t                             ;; simple extension one
            (setq cat (D-ParseCategory))
            (D-MustHave '=)
            (D-MustHave '>)
            (setq values (D-ParseSimpleSet))
            (setq D-LCATEGORIES 
	       (cons (list cat values)
	          D-LCATEGORIES))
         )
      )
   )
)

(defun D-CheckDistCat (distcat)
;;
;;  expands aliases
;;
   (D-SubsAliasCategory distcat)
)

(defun D-SetTop ()
;;
;;  This is part of the command interpreter but has to be included here
;;  as it differs between term and bay area unification
;;
;;  Changes the distinguished symbol used for recognising complete
;;  parses in the grammar.  
;;  Note the new category cannot be read in on the command line because
;;  a special parser is required for reading the category
;;
   (let ( newcategory )
      (cond
	 ((null (assq 'gr D-LOADEDPARTS))
	    (error "Must have word grammar loaded to change top category")))
      (princ "Enter new category: ") (drain)
      (setq D-fileid t)   ;; so parse category will get the right file
      (D-MakeEOLNSymbol)
      (D-GetNextSym)      ;; read first symbol
      (setq newcategory (D-ParseCategory))
      (D-MakeEOLNNotSymbol)
      (cond
	 ((D-CheckCategory newcategory)   ;; check to see if it is valid
	    (setq D-DISTINGUISHEDCATEGORY newcategory)
	    (princ "New top category set") (terpri))
         (t    ;; illegal new category
	    (princ "New top category NOT set because")
	    (princ " given category is not valid") (terpri)))
   )
)

(defun D-CheckTopCat ()
;;
;;   This checks to see if a distinguished category has been
;;   defined.  If one has not a warning message is given and 
;;   the distinguished category is set to nil (i.e. all parses
;;   that span the chart)
;;
   (cond
      ((eq D-DISTINGUISHEDCATEGORY 'UNSET)
	 (princ "WARNING: no top category - so top set to ()")
	 (terpri)
	 (setq D-DISTINGUISHEDCATEGORY nil)
      )
      (t
	 t    ;; no problem
      )
   )
)

