;;;======================================================================
;;; NLP code for use with Natural Language Understanding, 2nd ed.
;;; Copyright (C) 1994 James F. Allen
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2, or (at your option)
;;; any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;;======================================================================

;;   This file contains the functions that manage the features in constituents,
;;   primarily constituent matching and unification

(defconstant *success* '((NIL NIL)))

;;============================================================================
;;   MANAGING CONSTITUENTS

;;   A constituent is represented as a list of form 
;;        ((<feature> <value>) ... (<feature> <value>))
;;   where a <value> may be
;;       an atom
;;       a variable
;;       a constrained variable, restricted to one of a list of values

(defstruct
  (constit
   (:print-function
    (lambda (p s k)
      (Format s "<~S ~S>" (constit-cat p) (constit-feats p)))))
  cat feats head)

;; Make a constituent of the indicated category with the indicated features

(defun Build-constit (cat feats head)
  (make-constit :cat cat :feats feats :head head))

;; Add a new feature-value pair to an existing constituent

(defun add-feature-value (constit feat val)
        (build-constit (constit-cat constit) 
                       (append (constit-feats constit) (list (list feat val)))
                       (constit-head constit)))

;;  Get the value of a specific feature from a constituent

(defun get-value (constit feature)
  (if (eq feature 'cat)
    (constit-cat constit)
    (get-fvalue (constit-feats constit) feature)))

; This gets the value from a feature-value list
(defun get-fvalue (featlist feature)
    (cadr (assoc feature featlist)))

;;===========================================
;;  VARIABLES

;; Check if an expression is a variable

(defstruct (var
            (:print-function 
             (lambda (p s k)
               (if (null (var-values p))
                 (Format s "?~S" (var-name p))
                 (Format s "?~s:~S" (var-name p) (var-values p))))))
  name values)

;; Construct a new variable with the indicated name, and possible values

(defun build-var (name values)
  (make-var :name name :values values))

;;==================================================================================
;; CONSTITUENT MATCHING
;; Rules are specified using constituent patterns, (i.e., constituents with
;;  variable in them. The principle operation is matching a constituent pattern 
;;  from a rule with a constituent. The match returns a list of variable bindings
;;  that will make the pattern have identical features (or a subset of features) 
;;  as the constituent.
;;  Bindings are a list of the form ((<var> <value>) ... (<var> <value>)).
;; A binding list always ends with the entry (NIL NIL). This way you can tell
;;  if the match succeeded. A succesful match requiring no bindings will
;;  return (NIL NIL), where as a failure will return NIL.

;; This takes the first feature-value pair and matches it against the
;;  constituent. If it succeeds, it recurses on the remaining features in the
;;  pattern. Whenever a variable binding is found, the variable is replaced
;;  in the expressions before recursing. This also allows variables in the
;;  constituent as well to allow local ambiguity to be represented. 

(defun constit-match (pattern constit)
  (if (eq (constit-cat pattern) (constit-cat constit))
    (fconstit-match (constit-feats pattern) (constit-feats constit))))

;;  FCONSTIT-MATCH matches the two feature lists

(defun fconstit-match (fpattern fconstit)
 (if (null fpattern) *success*
  (let* ((feat (caar fpattern))
         (val (cadar fpattern))
         (cval (get-fvalue fconstit feat))
         (bndgs (match-vals val cval)))
     (if bndgs
      (let ((result
             (fconstit-match (subst-in (cdr fpattern) bndgs)
                        (subst-in fconstit bndgs))))
        (if result 
          (if (equal bndgs *success*) result
              (append bndgs result))))))))
 
;;  Matches two values and returns the binding list if
;;   they match
(defun match-vals (val cval)
  (if (null cval) (setq cval '-))     ;; Use - as the default
  (cond 
    ;; If val = cval, then they already match
   ((eq val cval) *success*)
   ;; If val is a variable, then check if the value is compatible
   ;;   If cval is also a variable, then we may have to add two new bindings
   ((var-p val)
    (let ((vals (feature-intersect val cval)))
      (if (null vals) nil               ;; no match
          (if (var-p vals) 
            ;;  check is answers is one od the variables or a new one
            (cond ((eq cval vals) (list (list val vals)))
                  ((eq val vals) (list (list cval vals)))
                  (t (list (list val vals) (list cval vals))))
            (list (list val vals))))))
              
   ;; If cval is a variable (and val is not), then check that it matches.
   ((var-p cval)
    (let ((vals (feature-intersect cval val)))
      (if (null vals) nil
          (list (list cval vals)))))

     ;;  matching two lists
     ((and (listp val) (listp cval))
      (match-lists val cval))

     ;;  recursive matching of two values that are constituents
     ((and (constit-p val) (constit-p cval))
      (constit-match val cval))))

;;   recursively matches each element down the list, substituting for
;;    variables as it goes

(defun match-lists (val cval)
  (if (null val)
    (if (null cval) *success* nil)
    (let ((bndgs (match-vals (car val) (car cval))))
      (if bndgs 
        (let ((bndgs2 (match-lists (subst-in (cdr val) bndgs) 
                                   (subst-in (cdr cval) bndgs))))
          (if bndgs2
            (if (equal bndgs2 *success*) 
              bndgs
              (append bndgs bndgs2))))))))
            
          
  
;; FEATURE-INTERSECT - Takes a variable and an arg (val) that is an value,
;;      simple variable or constrained variable
;;  returns the intersection in the cases where
;;     val is an expression and is in the list of values, then the answer is val
;;     val is an unconstrained variable, then the answer is the var
;;     val is a constrained variable, then the answer is a variable constrained
;;     to the intersection between its possible values and the values of the var

(defun feature-intersect (var val)
  (let ((value-list (var-values var)))
    (cond 
     ;; If value-list is nil, the var is unconstrained
     ((null value-list) val)
     ;;  If val is in the value-list, then it is the answer
     ((member val value-list) val)
     ;; otherwise, compute the intersection
     ((var-p val)
      (let* ((other-values (var-values val))
             (int-values (intersection value-list other-values)))
        (cond 
         ;;  If other-values was nil, the val was an unconstrained variable
         ((null other-values) var)
         ;;  If int-values is null, then the match failed
         ((null int-values) nil)
         ;;   If int-values consist of one element, return as an atom
         ((endp (cdr int-values)) (car int-values))
         ;;  else return int-values as the answer
         (t (build-var (var-name var) int-values))))))))

(defun single-value (x)
  (or (atom x) (endp (cdr x))))

  
;; SUBST-IN FUNCTION
;;  Given a list of bindings, instantiates the variables in the expression
;;  This is used to instantiate constituents and rules.

(defun subst-in (x bndgs)
  (if (or (null bndgs) (equal bndgs '((nil nil)))) 
    x
    (cond ((or (symbolp x) (numberp x)) x)
          ((var-p x)
           (let ((val (get-most-specific-binding x bndgs)))
             (if val val x)))
          ((listp x)
           (mapcar #'(lambda (y)
                       (subst-in y bndgs))
                   x))
          ((constit-p x)
           (make-constit :cat (constit-cat x)
                         :feats (subst-in (constit-feats x) bndgs)
                         :head (constit-head x)))
          ((entry-p x)
           (make-entry :constit (subst-in (entry-constit x) bndgs)
                       :start (entry-start x)
                       :end (entry-end x)
                       :rhs (entry-rhs x)
                       :name (entry-name x)))
          (t x))))

(defun get-most-specific-binding (var bndgs)
  (let ((val (cadr (assoc var bndgs :test #'equal))))
    (if val
      (if (var-p val)
        (let ((val2 (get-most-specific-binding val bndgs)))
          (if val2 val2 val))
        val))))


                  
    
        
