(in-package :user)
;;;======================================================================
;;; 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) nil)
        ((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))

  (defun gapsDisabled nil
    (not gapsEnabledFlag))

  (defun gapsEnabled nil
    gapsEnabledFlag)

  (defun disableGaps nil
    (setq gapsEnabledFlag nil))

  (defun enableGaps nil
    (setq gapsEnabledFlag t))

)  ;; 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 '(NP PP)))
      (insert-gap gapvalue nextcat arc))))
    
;; This checks to see if the GAP value of the next consituent could be satisfied
;;    the the next consituent. If so, it extends the arc appropriately

(defun insert-gap (gapvalue nextcat arc)
  ;;  There are two cases where we insert a gap:
  ;;   Case 1: the GAP feature is a constituent,
  ;;   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 consituent of form X/X
  (when (or (constit-p gapvalue)
            (and (var-p gapvalue)
                 (not (eq (constit-cat (arc-mother arc)) nextcat))))
    (let ((e (make-entry :constit (make-constit :cat nextcat
                                                :feats (build-gap-feats nextcat))
                         :start (arc-end arc) 
                         :end (arc-end arc) 
                         :rhs nil
                         :name (gen-symbol 'GAP)
                         :rule-id (if (eq nextcat 'NP) 'NP-GAP-INTRO 'GAP-INTRO)
                         :prob 1)))
      (Add-to-agenda e)
      (verbose-msg2 "Inserting ~S at position ~S to fill a gap~%" e (arc-end arc)))))

;; This constructs the appropriate gap features for NPs and PPs.

(defun build-gap-feats (cat)
  (let ((feats
         (if (semenabled) 
           (cons (list 'sem (make-var :name 's))
                 (genfeats cat))
           (genfeats cat))))
    (cons '(EMPTY +)
          (cons
           (list 'gap
                 (make-constit :cat cat
                               :feats feats))
           feats))))

(defun genfeats (cat)
  (let ((feats (cond ((eq cat 'np) '(agr))
                     ((eq cat 'pp) '(pform ptype))
                     (t nil))))
    (mapcar #'(lambda (f)
                (list f (make-var :name (gen-symbol f))))
            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)))))

; --------- Fred, Mar 9, 95 ----       
; ! this is called when rule is completed!

;; Simplify lambda expressions
(defun simplify-lambda (expr)

;(write expr)              

  (cond ((atom expr) expr)
  
        ((and (listp (car expr))
              (eq (caar expr) 'lambda)
              (cadr expr))
         (simplify-lambda (subst (cadr expr) (cadar expr) (caddar expr))))

        ; --------- Fred, Mar 9, 95 ----       
        
        ( (and (listp expr) (eq (car expr) '^))    ; ------------ lisp execute
          (eval (cadr 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))
