;;
;;      Name: catrouts
;;
;;      Functions:  basic functions for dealing with categories
;;
;;      Author: Alan W Black  May 1987
;;              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   |
;;         ---------------------------------------------
;;
;;             >>>  UNRESTRICTED UNIFICATION VERSION <<<
;;
;;      The major functions are
;;       D-MakeCategory  - takes a printable category and
;;           returns a category structure
;;       D-MakePrintCategory - takes a category structure
;;           and returns a printable one.
;;
;;      These two functions are used to interface to the
;;      different types of category implementation 
;;      mainly Unrestricted (or "bay area") and Term Unification.
;;

(declare 
   (localf
      D-MakeCategory
      D-MakeCategoryStruct
      D-MakeFeature 
      D-MakeCategoryList 
      D-MakeCategoryStructList 
      D-HeadFeatures 
      D-WDaughterFeatures 
      D-CheckCategory 
      D-CheckForNoDuplicates 
      D-CheckFeatures 
      D-CheckFeaturePair 
      D-ProcessGRules
      D-SetUpDistCat
   )
)

(defmacro DK-VERSION-STAMP ()
   `(append (DK-LISP-VERSION) (ncons 'UU)))

(defmacro D-MakePCategory (cat)
   `,cat)

(defun D-MakeCategory (cat)
;;
;;   takes a category and returns it with variables changed into
;;   the required normal form
;;
   (D-MakeCategoryStruct cat (ncons (list nil nil)))
)

(defun D-MakeCategoryStruct (cat bindings)
   (mapcar
      #'(lambda (fpair)
         (D-MakeFeature fpair bindings)
      )
      cat
   )
)

(defun D-MakeFeature (fpair bindings)
;;
;;  substitute all variables for unique ones
;;
   (cond
      ((D-DeclaredVariableP (cadr fpair))
	 (let ( (value (assq (cadr fpair) bindings)) )
	    (cond       ;; variable unchanged   
	       ((null value) ;; variable is unbound
		  (let ( (newvar (D-MakeNewVariable 
				       (D-GetDeclVarRange (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-MakeCategoryStruct (cadr fpair) bindings))
      )
      (t    ;; simple literal
	 fpair
      )
   )
)

(defun D-MakeCategoryList (cats)
;;
;;  normalises all the variables in the given list of categories.
;;
   (D-MakeCategoryStructList cats (ncons (list nil nil)))
)

(defun D-MakeCategoryStructList (cats bindings)
   (cond
      ((null cats)
	 nil)
      (t
	 (cons
	    (D-MakeCategoryStruct (car cats) bindings)  ;; modifies bindings
	    (D-MakeCategoryStructList
	       (cdr cats) bindings)))
   )
)


(defun D-HeadFeatures (category)
;;
;;    Returns the list of whead features as declared in the dcls file
;;
   (mapcan
      #'(lambda (fpair)
	    (cond
	       ((D-HeadFeatureP (car fpair)) (ncons fpair))
	       (t nil)))
      category
   )
)

(defun D-WDaughterFeatures (category)
;;
;;    Returns the list of wdaughter features as declared in the dcls file
;;
   (mapcan
      #'(lambda (fpair)
	    (cond
	       ((D-DaughterFeatureP (car fpair)) (ncons fpair))
	       (t nil)))
      category
   )
)

(defun D-CheckCategory (category)
;;
;;   This checks the consistancy of a category.  All values of
;;   features must be consistant with there declarations.  If they
;;   are not a warning is given, but processing continues.  No
;;   guarantee is given for running grammars that give inconsistancy
;;   warnings, but they will probably work.
;;
   (cond
      ((listp category)    ;; catgegory must be a list
	 (cond
	    ((D-CheckForNoDuplicates category nil (length category))
	       (D-CheckFeatures category t)
            )
	    (t nil)    ;; must have been duplicates
         )
      )
      (t
	 (D-errmsg " invalid category " category)
      )
   )
)

(defun D-CheckForNoDuplicates (category catsfound numcats)
;;
;;  checks the category to find any feature names that are used more
;;  than once
;;  duplications are reported to the terminal, nil is always returned
;;
   (cond
      ((null category)
	 (cond
	    ((eq numcats (length catsfound)) t) ;; check ok
	    (t nil)         ;; must have been some duplicates
         )
      )
      ((memq (caar category) catsfound)
	 (D-errmsg "duplicate feature name " (caar category))
	 (D-CheckForNoDuplicates (cdr category) catsfound numcats)
      )
      (t
	 (D-CheckForNoDuplicates 
	    (cdr category)
	    (cons (caar category) catsfound)
	    numcats
         )
      )
   )
)

(defun D-CheckFeatures (category resultflag)
;;
;;   checks the features in a category and returns nil if at
;;   least one error, t otherwise
;;
   (cond
      ((null category) resultflag)
      ((atom (car category))
	 (D-errmsg "not feature pair " (car category))
      )
      ((D-CheckFeaturePair (car category))
         (D-CheckFeatures (cdr category) resultflag)
      )
      (t     ;; there was an error here
	 (D-CheckFeatures (cdr category) nil)   ;; pass on error flag
      )
   )
)

(defun D-CheckFeaturePair (featurepair)
;;
;;  This checks the validity of a feature pair, The feature must be
;;  declared and have an apropriate value
;;
   (cond
      ((D-CatValFeatP (car featurepair))  ;; category valued feature
	 (cond
	    ((listp (cadr featurepair))   ;; must be a list
	       (D-CheckCategory
	          (cadr featurepair)
               )
            )
	    ((and (D-DeclaredVariableP (cadr featurepair))
		  (eq (D-GetDeclVarRange (cadr featurepair)) (DK-category)))
               t
            )
	    (t
	       (D-errmsg "Not a valid category-value for feature "
			  (car featurepair))
            )
         )
      )
      ((D-FeatureP (car featurepair))    ;; atomic valued feature
	 (cond
	    ((or (D-FeatureValueP (car featurepair)
				  (cadr featurepair))
                 (and (D-DeclaredVariableP (cadr featurepair))
		      (D-Subset (D-GetDeclVarRange (cadr featurepair))
				(D-GetFeatRange (car featurepair)))))
               t                ;; feature pair ok
            )
	    (t
	       (D-errmsg "Invalid feature value" featurepair)
            )
         )
      )
      (t
	 (D-errmsg "Invalid feature name" featurepair)
      )
   )
)

(defun D-ProcessGRules (rules)
;;
;;  Normalises all the variables in the rules to standard cons cells
;;
   (mapcar
      #'(lambda (rule)
	 (cond 
	    ((car rule)  ;; does it have any variables
	       (cons t
		  (cons
		     (cadr rule)   ;;the rule name
		     (D-MakeCategoryList (cddr rule)))))
            (t rule)   ;; no variables
         )
      )
      rules)
)

(defun D-SetUpDistCat (cat)
;;
;;   This sets up the distinguished category.  Here (bay area) it
;;   changes the printable category form into the internal form
;;
   (D-MakeCategory cat)
)

