;;
;;
;;      Title : D-LRuleConv
;;
;;      Function :  expands the feature specification on lexical
;;                  entries using user specified Completion
;;                  Rules and Muliplication Rules and then
;;                  checks them with the given Consistency Checks
;;
;;      Author :  Alan W Black, January 1986
;;                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   |
;;         ---------------------------------------------
;;
;;      1.15 February 24th 1986
;;         Added the phonological field to the entries, in between
;;         citation form and syntax field
;;      2.4 January 25th 1987
;;         Adding tracing capabilities for the rules.
;;
;;      Description :
;;         These are the new updated form of rules added at version
;;         1.13 January 1986
;;
;;         The three forms of rule are -
;;         Completion Rules: these allow you to modify ane entries
;;            specification, typically they are used to add in default
;;            features.
;;         Multiplication Rules: These create new entries from given
;;            ones, these can be used to add in predicable multiple 
;;            senses of entries
;;         Consistency Checks: checks that entries are internally
;;            consistent
;;
;;         See the user document for details of these formalisms
;;
;;       They order they apply on depends on the global D-RULESORER
;;
;;      Parameters :
;;         crs        list of crs
;;         mrs        list of mrs
;;         ccs        list of consistency checks
;;         entry      lexical entry to be expanded
;;
;;      Returns :
;;         a list of expanded entries
;;
;;      Side Effect :
;;         none
;;
;;      External references :
;;
;;      System functions used :
;;        Name     type      Args #  type                 Comment
;;
;;      Restrictions :
;;         can't have variables matching D-UNBOUND
;;
;;

(declare
   (special
      D-TRACEFLAG
   )
   (localf
      D-ApplyRules                    
      D-ApplyCCS                    
      D-CheckEntryWithCCs           
      D-CheckConsistancy
      D-CheckEntryWithCC            
      D-ApplyCRS                     
      D-ApplyCRSs
      D-ApplyCR                      
      D-ApplyListofFeatures           
      D-ApplyMRS                     
      D-ApplyMR                      
      D-ConstructNewEntry             
      D-ConstructCitationForm         
      D-ConstructPhonoForm         
      D-ConstructSemanticField        
      D-ConstructUserField            
      D-ConstructSyntaxField          
      D-ConstructNewCategory          
      D-MatchRulePattern              
      D-MatchRulePatterns             
      D-MatchSimplePatt               
      D-VerySimpleMatch               
      D-MatchCitationForm             
      D-MatchPhonoForm             
      D-MatchUserFieldPattern         
      D-MatchSemanticPattern          
      D-AddPatternBinding             
      D-MatchSyntacticPattern         
      D-MatchFeaturePairPattern       
   )
)

(defun D-ApplyRules (mrs crs ccs entry)
;;
;;   Applies the three types of rule to an entry.  Returns
;;   a list of valid entries.  If the ccs find a problem
;;   with an entry a warning is generated of the terminal and
;;   that one is not added to the returned list
;;
   (let ((newentries nil))
      (cond
	 ((eq D-TRACEFLAG (DK-ON))
	    (princ (D-CitationForm entry))
	 )
      )
      (cond
	 ((eq D-RULESORDER 'COMP)
	   (setq newentries
	      (D-ApplyCCS      ;; returns list of entries
		 ccs
		 (D-ApplyMRS  ;; return expanded entries
		    mrs
		    (D-ApplyCRS    ;; returns expanded entry  
		       crs
		       entry))))
	 )
	 (t    ;; multiplication rules first
	   (setq newentries
	      (D-ApplyCCS      ;; returns list of entries
	         ccs
	         (D-ApplyCRSs  ;; return expanded entries
		    crs
		    (D-ApplyMRS   ;; returns list of entries
		       mrs
		       entry)))))
      )
      (cond
	 ((eq D-TRACEFLAG (DK-ON)) (terpri))
      )
      newentries
   )
)

(defun D-ApplyCCS (ccs entries)
;;
;;   apply the consistancy checks on the entries
;;   entries that fail the checks are not contained in the returned
;;   list of entries
;;
   (cond
      ((null entries) nil)    ;; no more entries to apply
      ((D-CheckConsistancy (car entries) ccs)
	 (cons
	    (car entries)
	    (D-ApplyCCS ccs (cdr entries)))
      )
      (t      ;; (car entries) is erroneous so drop it
	 (D-ApplyCCS ccs (cdr entries))
      )
   )
)

(defun D-CheckConsistancy (entry ccs)
;;
;; This checks the consistancy of an entry.  First the
;; syntax field is checked to be valid then the ccs
;; are applied
;;
   (cond
      ((and (D-CheckCategory (D-Syntax-Field entry))
	 (D-CheckEntryWithCCs entry ccs))
         t
      )
      (t       ;; error in entry so print it out
	 (princ "   ") (princ entry) (terpri)
      )
   )
)

(defun D-CheckEntryWithCCs (entry ccs)
;;
;;  checks an entry with the CCs returns entry if ok, nil
;;  if not ok
;;
   (cond
      ((null ccs)
	 entry
      )
      ((D-CheckEntryWithCC entry (car ccs))
	 (D-CheckEntryWithCCs entry (cdr ccs))
      )
      (t   ;; last cc did not match to fail
	 nil
      )
   )
)

(defun D-CheckEntryWithCC (entry cc)
;;
;;  checks an entry with a consistancy check
;;  returns the entry if a match or rule not applicable
;;  nil if rule applicable but fail to match.  Also
;;  in this case a warning message is given on standard output
;;
   (let ( (name (car cc))
	  (bindings (D-MatchRulePattern entry (cadr cc))) )
      (cond
	 ((null bindings) entry) ;; rule not applicable
	 ((catch         ;; rule is applicable to must match the rest of rule
	    (D-MatchRulePatterns entry (caddr cc) bindings))
            entry     ;; return entry as all is ok
         )
	 (t      ;; mandatory matching part of rule has failed to return fail
	    (princ "ERROR >> entry failed Consistency Check: ")
	    (princ name) (terpri)
	    nil
         )
      )
   )
)


(defun D-ApplyCRSs (crs entries)
;;
;;   applies the list of crs to the entries in order they are 
;;   given.   This returns a list of expaned entries after all relevant 
;;   rules have applied
;;
   (mapcar
      #'(lambda (entry)
	    (D-ApplyCRS crs entry))
      entries)
)

(defun D-ApplyCRS (crs entry)
;;
;;  applies the list of crs to the given entry
;;
   (cond
      ((null crs)
	 entry
      )
      (t
	 (D-ApplyCRS
	    (cdr crs)
	    (D-ApplyCR (car crs) entry))
      )
   )
)

(defun D-ApplyCR (cr entry)
;;
;;   tests to see if cr is applicable, if so applies it and
;;   returns the expanded entry (or same one if rule not applicable)
;;
   (let ( (name (car cr))
	  (bindings (D-MatchRulePattern entry (cadr cr))) )
      (cond
	 (bindings        ;; will be nil if failed match
	    (cond 
	       ((eq D-TRACEFLAG (DK-ON))
		  (princ " ") (princ name)))
	    (D-ConstructNewEntry 
	       (caddr cr)   ;; skeleton 
	       entry
	       bindings
            )
         )
	 (t entry)   ;; rule does not apply
      )
   )
)

(defun D-ApplyListofFeatures (entry featlist)
;;
;; adds each feature in featlist to entry if it is not already there
;;
   (cond
      ((null featlist)
	 entry
      )
      ((D-HasFeature (caar featlist) (D-Syntax-Field entry))
	 (D-ApplyListofFeatures
	    entry   ;; has the feature already so no change
	    (cdr featlist))
      )
      (t      ;; does not have this feature so add it
	 (D-ApplyListofFeatures
	    (list       ;; build new entry
	       (D-CitationForm entry)
	       (cons (car featlist) (D-Syntax-Field entry))
	       (D-Semantic-Field entry)
	       (D-User-Field entry))
            (cdr featlist)
         )
      )
   )
)

(defun D-ApplyMRS (mrs entry)
;;
;;  applies the mrs to the entry producing a list of the given entry
;;  and any new entries that can be created by the mrs
;;
   (cons
      entry      ;; the entry itself unchanged plus
      (mapcan    ;; any others the mrs can construct
	 #'(lambda (mr) (D-ApplyMR mr entry))
	 mrs
      )
   )
)

(defun D-ApplyMR (mr entry)
;;
;;  applies the mr if appropriate constructing new entries
;;  if mr does not apply then returns nil
;;
   (let ( (name (car mr))
	  (bindings (D-MatchRulePattern entry (cadr mr))) )
      (cond
	 (bindings      ;; will be list if rule applies
	    (cond 
	       ((eq D-TRACEFLAG (DK-ON))
		  (princ " ") (princ name)))
	    (mapcar
	       #'(lambda (construct)
		    (D-ConstructNewEntry construct entry bindings))
               (caddr mr)  ;; the constructs
            )
         )
	 (t             ;; mr does not apply
	    nil
         )
      )
   )
)

(defun D-ConstructNewEntry (construct entry bindings)
;;
;;  Builds a new entry from the construct skeleton based
;;  on the bindings, literals in construct and entry itself
;;  (if & used)
;;
   (list
      (D-ConstructCitationForm 
	 (D-CitationForm construct)
	 (D-CitationForm entry)
	 bindings)
      (D-ConstructPhonoForm
	 (D-PhonologicalForm construct)
	 (D-PhonologicalForm entry)
	 bindings)
      (D-ConstructSyntaxField
	 (D-Syntax-Field construct)
	 (D-Syntax-Field entry)
	 bindings)
      (D-ConstructSemanticField
	 (D-Semantic-Field construct)
	 (D-Semantic-Field entry)
	 bindings)
      (D-ConstructUserField
	 (D-User-Field construct)
	 (D-User-Field entry)
	 bindings))
)

(defun D-ConstructCitationForm (skel citform bindings)
;;
;;  returns new citation form depending on skel
;;
   (cond
      ((eq skel '&)
	 citform       ;; no change from basic entry
      )
      ((D-IsPattVariable skel)    ;; variable
	 (let ( (value (D-PattBinding skel bindings)) )
	    (cond
	       ((eq value 'D-UNBOUND)    ;; no binding for this ERROR
		  ;; I am not sure what to do here yet
		  (error "variable in citation form unset by pattern")
               )
	       (t value))
         )
      )
      (t
	 skel     ;;  It must be a literal so return it
      )
   )
)

(defun D-ConstructPhonoForm (skel phonoform bindings)
;;
;;  returns new phonological form depending on skel
;;
   (cond
      ((eq skel '&)
	 phonoform       ;; no change from basic entry
      )
      ((D-IsPattVariable skel)    ;; variable
	 (let ( (value (D-PattBinding skel bindings)) )
	    (cond
	       ((eq value 'D-UNBOUND)    ;; no binding for this ERROR
		  ;; I am not sure what to do here yet
		  (error "variable in phonological form unset by pattern")
               )
	       (t value))
         )
      )
      (t
	 skel     ;;  It must be a literal so return it
      )
   )
)

(defun D-ConstructSemanticField (skel semanticfield bindings)
;;
;;  returns new semantic field depending on skel
;;
;;  yes this is the code as the citation form but it may not stay
;;  the same.  I could add variables into the s-expression of the 
;;  semantic field
;;
   (cond
      ((eq skel '&)
	 semanticfield       ;; no change from basic entry
      )
      ((D-IsPattVariable skel)    ;; variable
	 (let ( (value (D-PattBinding skel bindings)) )
	    (cond
	       ((eq value 'D-UNBOUND)    ;; no binding for this ERROR
		  ;; I am not sure what to here yet
		  (error "variable in semantic-field unset by pattern")
               )
	       (t value))
         )
      )
      (t
	 skel     ;;  It must be a literal so return it
      )
   )
)

(defun D-ConstructUserField (skel userfield bindings)
;;
;;  returns new user-field form depending on skel
;;
;;  yes this is the code as the citation form but it may not stay
;;  the same.  I could add variables into the s-expression of the 
;;  user field
;;
   (cond
      ((eq skel '&)
	 userfield       ;; no change from basic entry
      )
      ((D-IsPattVariable skel)    ;; variable
	 (let ( (value (D-PattBinding skel bindings)) )
	    (cond
	       ((eq value 'D-UNBOUND)    ;; no binding for this ERROR
		  ;; I am not sure what to here yet
		  (error "variable in user-field unset by pattern")
               )
	       (t value))
         )
      )
      (t
	 skel     ;;  It must be a literal so return it
      )
   )
)

(defun D-ConstructSyntaxField (skel syntaxfield bindings)
;;
;;   constructs a new syntaxfield based on the given skeleton
;;
   (cond
      ((eq skel '&)     ;; just carry forward syntax field
	 syntaxfield
      )
      ((D-IsPattVariable skel)   ;; simple variable
	 (let ( (value (D-PattBinding (car skel) bindings)) )
	    (cond
	       ((eq value 'D-UNBOUND) ;; no binding - ERROR !!!
		  ;; I am not sure what to here yet
		  (error "variable in syntax-field unset by pattern")
               )
	       (t value)))
      )
      (t
	 (D-ConstructNewCategory
	    skel
	    bindings)
      )
   )
)

(defun D-ConstructNewCategory (skel bindings)
;;
;;  returns new category built up from bindings and skeleton
;;
   (cond
      ((null skel)     ;; finished
	 nil
      )
      ((D-IsPattVariable (car skel))   ;; rest type variable
	 (let ( (value (D-PattBinding (car skel) bindings)) )
	    (cond
	       ((eq value 'D-UNBOUND) ;; no binding - ERROR !!!
		  ;; I am not sure what to here yet
		  (error (concat 
		      "variable " (car skel) 
		      " in syntax-field unset by pattern"))
               )
	       (t 
		  (append
		     value
		     (D-ConstructNewCategory
			(cdr skel) bindings))
               )
            )
         )
      )
      ((D-IsPattVariable (cadar skel))  ;; variable in feature pair
	 (let ( (value (D-PattBinding (cadar skel) bindings)) )
	    (cond
	       ((eq value 'D-UNBOUND) ;; no binding - ERROR !!!
		  ;; I am not sure what to here yet
		  (error
		     (concat "variable "
		     (cadar skel) " in syntax-field unset by pattern"))
               )
	       (t 
		  (cons   
		     (list (caar skel) value)
		     (D-ConstructNewCategory
			(cdr skel) bindings))
               )
            )
         )
      )
      ((D-CatValFeatP (caar skel))  ;;category valued feature
	 (cons
	    (list           ;; construct feature pair
	       (caar skel) 
	       (D-ConstructNewCategory
		  (cadar skel)     ;; category value skeleton
		  bindings))
	    (D-ConstructNewCategory
	       (cdr skel) bindings))
      )
      (t          ;; car of skel must just be literal then
	 (cons
	    (car skel)
	    (D-ConstructNewCategory
	       (cdr skel) bindings))
      )
   )
)

(defun D-MatchRulePattern (entry pattern)
;;
;;  matchs a lhs of rule with the given entry returns
;;  nil if no match
;;  if a match returns bindings in an a list terminated
;;  by the pair (t t)
;;
   (catch
      (D-MatchRulePatterns
         entry
         pattern
         '((t t))   ;; basic bindings
      )
   )
)

(defun D-MatchRulePatterns (entry pattern bindings)
;;
;;   Matchs the given conjuction of simple patterns 
;;   with entry returns bindings or throws a nil
;;
   (cond
      ((null pattern)
	 bindings       ;; true match
      )
      (t
	 (D-MatchRulePatterns
	    entry
	    (cdr pattern)
	    (D-MatchSimplePatt entry (car pattern) bindings))
      )
   )
)

(defun D-MatchSimplePatt (entry simppatt bindings)
;;
;;  checks a simple pattern (NOT patt) or (patt) with an entry
;;  returns bindings of ok throws nil otherwise
;;
   (cond
      ((eq (car simppatt) '~ )   ;; negative match (no bindings passed on)
	 (cond
	    ((catch (D-VerySimpleMatch entry (cadr simppatt) bindings))
	       (throw nil)    ;; fail match
            )
	    (t bindings)      ;; not match but no new bindings
         )
      )
      (t             ;; not negated match
	 (D-VerySimpleMatch entry simppatt bindings)
      )
   )
)

(defun D-VerySimpleMatch (entry patt bindings)
;;
;;  matches an entry with an entry pattern, returns 
;;  new bindings if succeed, throw's nil other wise
;;
   (D-MatchSyntacticPattern
      (D-Syntax-Field entry)
      (D-Syntax-Field patt)
      (D-MatchSemanticPattern
	 (D-Semantic-Field entry)
	 (D-Semantic-Field patt)
	 (D-MatchUserFieldPattern
	    (D-User-Field entry)
	    (D-User-Field patt)
	    (D-MatchPhonoForm
	       (D-PhonologicalForm entry)
	       (D-PhonologicalForm patt)
	       (D-MatchCitationForm 
	          (D-CitationForm entry)
	          (D-CitationForm patt)
	          bindings)))))
)

(defun D-MatchCitationForm (citform citpatt bindings)
;;
;;   matchs citation form, returns bindings if true,
;;   throws nil other wise
;;
   (cond
      ((eq citpatt '_)     ;; don't care variable
	 bindings
      )
      ((D-IsPattVariable citpatt)
	 (D-AddPatternBinding   ;; fails if cannot bind variable
	    citpatt
	    citform 
	    bindings)
      )
      ((eq citform citpatt)
	 bindings             ;; does match
      )
      (t
	 (throw nil)          ;; does not match
      )
   )
)

(defun D-MatchPhonoForm (phonoform phonopatt bindings)
;;
;;   matches phonological form, returns bindings if true,
;;   throws nil other wise
;;
   (cond
      ((eq phonopatt '_)     ;; don't care variable
	 bindings
      )
      ((D-IsPattVariable phonopatt)
	 (D-AddPatternBinding   ;; fails if cannot bind variable
	    phonopatt
	    phonoform 
	    bindings)
      )
      ((eq phonoform phonopatt)
	 bindings             ;; does match
      )
      (t
	 (throw nil)          ;; does not match
      )
   )
)

(defun D-MatchUserFieldPattern (userfield ufpatt bindings)
;;
;;   matches userfield, returns bindings if true,
;;   throws nil otherwise
;;
   (cond
      ((eq ufpatt '_)     ;; don't care variable
	 bindings
      )
      ((D-IsPattVariable ufpatt)
	 (D-AddPatternBinding   ;; fails if cannot bind variable
	    ufpatt
	    userfield
	    bindings)
      )
      ((equal ufpatt userfield)
	 bindings             ;; does match
      )
      (t
	 (throw nil)          ;; does not match
      )
   )
)

(defun D-MatchSemanticPattern (semanticfield sfpatt bindings)
;;
;;   matches semantic field, returns bindings if true,
;;   throws nil otherwise
;;
   (cond
      ((eq '_ sfpatt)      ;; don't care variable
	 bindings
      )
      ((D-IsPattVariable sfpatt)
	 (D-AddPatternBinding
	    sfpatt
	    semanticfield
	    bindings)
      )
      ((equal sfpatt semanticfield)
	 bindings             ;; does match
      )
      (t
	 (throw nil)          ;; does not match
      )
   )
)

(defun D-AddPatternBinding (variable thing bindings)
;;
;;  returns binding for variable and thing if not already
;;  bound, checks equality if is.  throws nil if different
;;  value
;;
   (let ( (value (D-PattBinding variable bindings)) )
      (cond             ;; is a variable, is it bound
         ((eq value 'D-UNBOUND)
            (cons
               (list variable thing)  ;; new bindings
               bindings))
         ((equal value thing)      ;; check value of var the same
               bindings)   ;; does match
         (t (throw nil))   ;; does not match
      )
   )
)

(defun D-MatchSyntacticPattern (category catpattern bindings)
;;
;;   matchs a category pattern to the category returns
;;   new bindings if all ok throw's nil otherwise
;;
   (cond
      ((eq '_ catpattern)  ;; don't care variable
	 bindings
      )
      ((and (null category) (null catpattern))
	 bindings             ;; match complete
      )
      ((null catpattern)   ;; no pattern left but some category left
	 (throw nil)
      )
      ((eq (car catpattern) '_)        ;; rest type variable but don't care
	 (D-MatchSyntacticPattern
	    nil       ;; nothing left of category
	    (cdr catpattern)  ;; this should be nil
	    bindings
         )
      )
      ((D-IsPattVariable (car catpattern))  ;; rest type variable
	 (D-MatchSyntacticPattern
	    nil       ;; nothing left of category
	    (cdr catpattern)  ;; this should be nil
	    (D-AddPatternBinding    ;; fails if variable bound to unequal thing
	       (car catpattern)  ;; variable name
	       category          ;; value
	       bindings          ;; bindings
            )
         )
      )
      (t
	 (let  ( (newcatandbind
	            (D-MatchFeaturePairPattern
	               category
	               (car catpattern)
	               bindings)) )
	    (D-MatchSyntacticPattern
	       (car newcatandbind)   ;; the new category
	       (cdr catpattern)   ;; rest of pattern
	       (cdr newcatandbind)
            )
         )
      )
   )
)

(defun D-MatchFeaturePairPattern (category featpatt bindings)
;;
;;   matchs a feature pattern (possably with a ~ (not) symbol)
;;   returns cons pair of new category (with matching feat pair
;;   remove) and new bindings
;;   throw's nil if match fails
;;
   (cond
      ((eq (car featpatt) '~)  ;; negate match
	 (cond
	    ((catch (D-MatchFeaturePairPattern
			category (cadr featpatt) bindings))
	       (throw nil)   ;; failed match, throw away bindings too
            )
	    (t  (cons
		   category
		   bindings))  ;; didn't match so ok
         )
      )
      ((not (D-HasFeature (car featpatt) category))
	 (throw nil)        ;; if doesn't have feature then fail
      )
      ((eq (cadr featpatt) '_)      ;; don't care variable
	 (cons
	    (D-RemoveFeature (car featpatt) category)  ;; throw's nil if fail
	    bindings
         )
      )
      ((D-IsPattVariable (cadr featpatt))
	 (cons
	    (D-RemoveFeature (car featpatt) category)  ;; throw's nil if fail
	    (D-AddPatternBinding
	       (cadr featpatt)
	       (D-GetFeatureValue (car featpatt) category)
	       bindings
            )
         )
      )
      ((equal (cadr featpatt) (D-GetFeatureValue (car featpatt) category))
	 (cons
	    (D-RemoveFeature (car featpatt) category)
            bindings)
      )
      ((D-CatValFeatP (car featpatt))  ;; category value feature
	 (cons
	    (D-RemoveFeature (car featpatt) category)
	    (D-MatchSyntacticPattern
	       (D-GetFeatureValue (car featpatt) category)
	       (cadr featpatt)
	       bindings)
         )
      )
      (t
	 (throw nil)
      )
   )
)

