;;;======================================================================
;;; 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.
;;;======================================================================

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

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

;;   A constituent consists of
;;        its main syntactic category 
;;        a set of features, of form ((<feature> <value>) ... (<feature> <value>))
;;             where a <value> may be an atom, a variable, or a constrained variable, restricted to one of a list of values
;;        a binary flag that indicates if the constituent is the head of a rule 

(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)))

(defun replace-feature-value (constit feat val)
  (if (null (get-fvalue (constit-feats constit) feat))
    (add-feature-value constit feat val)
    (build-constit (constit-cat constit)
                   (replace-feat (constit-feats constit) feat val)
                   (constit-head constit))))

(defun replace-feat (feats feat val)
  (cond ((null feats) (list (list feat val)))
        ((eq (caar feats) feat) (cons (list feat val) (cdr feats)))
        (t (cons (car feats) (replace-feat (cdr feats) feat val)))))

;;  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" (cons '? (cons (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 of 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 a 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.
     ;;   Succeed unless var occurs in val
     ((null value-list) (if (occurs-in var val) nil 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))))

;; This return t if the var is in the val. Matching in such cases should fail
(defun occurs-in (var val)
  (if (listp val)
    (cond ((null val) nil)
          ((member var val) (Verbose-msg2 "~%OCCURS CHECK ELIMINATES ~S and ~S match~%" var val) t)
          (t (some #'(lambda (x) (occurs-in var x)) val)))
    nil))
  
;; 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)
                       :rule-id (entry-rule-id x)
                       :prob (entry-prob x)))
          (t x))))

(defun get-most-specific-binding (var bndgs)
  (let ((val (cadr (assoc var bndgs))))
    (if val
      (if (var-p val)
        ;; if its a var, then see if that var is bound
        (let ((val2 (get-most-specific-binding val bndgs)))
          (if val2 val2 val))
        ;; otherwise, it might contain vars that need binding
        (subst-in val bndgs)))))

;;*************************************************************************************                 
;;*************************************************************************************                 
    
;;  MANAGING THE GAP FEATURE

(let ((gapsEnabledFlag nil)
      (gap-cats '(NP PP))
      (gap-feat-lists '((NP AGR SEM)
                        (PP AGR SEM PTYPE PFORM))))
                
  (defun gapsDisabled nil
    (not gapsEnabledFlag))

  (defun gapsEnabled nil
    gapsEnabledFlag)

  (defun disableGaps nil
    (setq gapsEnabledFlag nil))

  (defun enableGaps nil
    (setq gapsEnabledFlag t))

  (defun declare-gap-cat (cat feats)
    (if (not (member cat gap-cats))
      (setq gap-cats (cons cat gap-cats)))
    (setq gap-feat-lists
          (cons (cons cat feats)
                (remove-if #'(lambda (x) (eq (car x) cat)) gap-feat-lists)))
    )

  (defun reset-gap-cats nil
    (setq gap-cats nil)
    (setq gap-feat-lists nil))

  (defun get-gap-cats nil
    gap-cats)

  
(defun get-gap-feat-list (cat)
    (cdr (assoc cat gap-feat-lists)))

)  ;; end scope of gapsEnabledFlag


;;********************************************************************************
;;   CODE TO INSERT GAP FEATURES INTO GRAMMAR
;;

;;  This is the main function. It generates the GAP features into the rules as described
;;   in Chapter 5. It returns a list of modified rules, since there may be more than
;;   one gap rule generated from a single original rule.

(defun generate-gap-features-in-rule (rule)
  (if 
    ;; If the rule explicitly sets the GAP feature, then it is left alone
    ;; Rules with lexical lhs also do not have gap features
    (or (gap-defined-already rule)
        (lexicalConstit (rule-lhs rule)))
    (list rule)
    ;; Otherwise, break up the rule and analyse it
    (let* ((rhs (rule-rhs rule))
           (head (findfirsthead rhs))
           (numbNonLex (count-if #'nonLexicalConstit  rhs)))
      (cond
       ;; If no nonlexical subconsitutents, then no GAP possible
       ((<= numbNonLex 0) (list (make-rule :lhs (add-feature-value (rule-lhs rule) 'GAP '-)
                             :id (rule-id rule)
                             :rhs (rule-rhs rule))))

       ;;  If head is a lexical category, propagate GAP to each non-lexical subconstituent
       ((lexicalConstit head)
        (gen-rule-each-NonLex rule numbNonLex))

       ;;  If non-lexical head, set up GAP as a head feature
       (t (let ((var (make-var :name (gen-symbol 'g))))
            (list (make-rule :lhs (add-feature-value (rule-lhs rule) 'GAP var)
                             :id (rule-id rule)
                             :rhs (add-gap-to-heads rhs var)))))))))

;; This returns true if the rule already specifies the GAP feature

(defun gap-defined-already (rule)
  (cond ((get-value (rule-lhs rule) 'gap) t)
        (t (find-gap-in-rhs (rule-rhs rule)))))

(defun find-gap-in-rhs (rhs)
  (cond ((null rhs) nil)
        ((get-value (car rhs) 'gap) t)
        (t (find-gap-in-rhs (cdr rhs)))))

;;  This adds the gap to every head subconstituent marked as a head

(defun add-gap-to-heads (rhs val)
  (if (null rhs) nil
      (let ((firstc (car rhs)))
        (if (constit-head firstc)
          (cons (add-feature-value firstc 'GAP val)
                (add-gap-to-heads (cdr rhs) val))
          (cons (add-feature-value firstc 'GAP '-) 
                (add-gap-to-heads (cdr rhs) val))))))


;; This generates a new rule for each non-lexical subconstituent
;;   n is the number of non-lexical subconstituents
        
(defun gen-rule-each-NonLex (rule n)
   (let ((var (make-var :name (gen-symbol 'g))))
     (if (<= n 0) nil
         (cons 
           (make-rule :lhs (add-feature-value (rule-lhs rule) 'GAP var)
                      :id (rule-id rule) 
                      :rhs (insert-gap-features var n (rule-rhs rule)))
           (gen-rule-each-NonLex rule (- n 1))))))
          
;;  inserts the GAP var in the n'th non-lexical consituent, and - in the others

(defun insert-gap-features (val n rhs)
  (if (null rhs) nil
    (mapcar #'(lambda (c)
                  (cond ((not (lexicalConstit c))
                         (setq n (1- n))
                         (if (= n 0)
                          (add-feature-value c 'GAP val)
                          (add-feature-value c 'GAP '-)))
                        (t c)))
              rhs)))
  
;;*****************************************************************************************
;;  FUNCTIONS USED BY THE PARSER

(defun generate-gaps (arc)
  ;;  Check here if rule might accept an empty consituent 
  ;;     (i.e., non-null GAP or PASSGAP feature of right type)
  ;;    if so, generate the gap
  (let* ((next (car (arc-post arc)))
         (nextcat (constit-cat next))
         (gapvalue (get-value next 'gap)))
    (if (and (not (eq gapvalue '-))
             (not (null gapvalue))
             (member nextcat (get-gap-cats)))
      (insert-gap gapvalue next nextcat arc))))
    
;; This checks to see if the GAP value of the next consituent could be satisfied
;;    the the next constituent. If so, it extends the arc appropriately

(defun insert-gap (gapvalue next nextcat arc)
  ;;  There are two cases where we insert a gap:
  ;;   Case 1: the GAP feature is a constituent that matches the next constit,
  ;;   Case 2: the GAP feature is a variable and the cat of next is NOT the same as the 
  ;;           cat of the mother, since that would create a constituent of form X/X
  (let ((gap
         (if (constit-p gapvalue)
           (if (constit-match gapvalue next) 
             (make-gap-entry gapvalue arc))
           (if (and (var-p gapvalue)
                    (not (eq (constit-cat (arc-mother arc)) nextcat)))
               (make-gap-entry next arc)))))
    (when gap
      (Add-to-agenda gap)
      (verbose-msg2 "Inserting ~S at position ~S to fill a gap~%" gap (arc-end arc))))
  )

;; Takes a constituent as a template an generates a GAP constituent that
;;  would satisfy it. The value of the GAP feature is a copy of the constituent
    
(defun make-gap-entry (constit arc)
  (let* ((cat (constit-cat constit))
        (feats (gen-feats-for-gap cat (constit-feats constit))))
    (make-entry :constit (make-constit 
                          :cat cat
                          ;;  set GAP feature, add +EMPTY
                          :feats (cons '(empty +)
                                     (cons (list 'gap (make-constit :cat cat :feats feats))
                                         feats)))
                :start (arc-end arc) 
                :end (arc-end arc) 
                :rhs nil
                :name (gen-symbol 'GAP)
                :rule-id (if (eq (constit-cat constit) 'NP) 'NP-GAP-INTRO 'GAP-INTRO)
                :prob 1)))
              
;;  Remove GAP feature, and add all features in GAP-FEAT-LIST
;;  that are not currently defined

(defun gen-feats-for-gap (cat feats)
  (let ((feats (remove-if #'(lambda (x) (eq (car x) 'gap)) feats)))
    (mapcar #'(lambda (f)
                (if (not (get-fvalue feats f))
                  (setq feats (cons (list f (make-var :name (gen-symbol f)))
                                    feats))))
            (get-gap-feat-list cat))
    feats))


;; *****************************************************************************************
;; ****************************************************************************************
;;    HANDLING THE SEM FEATURE

(let ((semEnableFlag nil))
  (defun semEnabled nil
    semEnableFlag)
  (defun noSemEnabled nil
    (not semEnableFlag))
  (defun enableSem nil
    (setq semEnableFlag t))
  (defun disableSem nil
    (setq semEnableFlag nil)))

;;  MAKE-ENTRY-WITH-SEM makes one pass at simplifying lambda expressions
;;   each time a consituent is constructed. Note this would not guarantee 
;;   that each constit has the most simplified form. But works well for simple
;;    examples and is correct in any case since simplification is not logically necessary!

(defun make-entry-with-sem (constit start end rhs name rule-id prob)
    (make-entry :constit (sem-simplify constit) 
                :start start :end end :rhs rhs :name name :rule-id rule-id :prob prob))

(defun sem-simplify (constit)
  (let* ((sem (get-value constit 'sem))
        (newsem (simplify-lambda sem)))
    (if (equal sem newsem)
      constit
      (make-constit :cat (constit-cat constit)
                    :feats (subst newsem sem (constit-feats constit))
                    :head (constit-head constit)))))

;; Simplify lambda expressions
(defun simplify-lambda (expr)
  (cond ((atom expr) expr)
        ((and (listp (car expr))
              (eq (caar expr) 'lambda)
              (cadr expr))
         (simplify-lambda (subst (cadr expr) (cadar expr) (caddar expr))))
        (t (mapcar #'simplify-lambda expr))))

;; If semantic interpretation is enabled, a discourse variable must be
;;     created for the VAR feature
(defun instantiateVAR (constit)
  (if (semEnabled)
    (subst-in constit (list (list (get-value constit 'VAR) (gen-symbol 'V))))
    constit))
