;;;======================================================================
;;; 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 to support the GAP feature
;;   as described in Chapter 5. You can ignore this file if you call (disableGaps)

;;  MANAGING THE GAP OPTION

(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 PASS-GAP feature of right type)
  ;;    if so, generate the gap
  (let* ((next (car (arc-post arc)))
         (nextcat (constit-cat next))
         (passgap (get-value next 'pass-gap))
         (gapvalue (get-value next 'gap)))
    (cond 
     ;;  An NP with a PASSGAP set (or a variable) allows for a gap
     ((and (eq nextcat 'np) 
           (or (eq passgap '+) (var-p passgap)))
      (insert-np-for-passive (arc-end arc)))
     ;;  No GAP feature 
     ((or (eq gapvalue '-) (null gapvalue))
      nil)
     ;; Insert NP and PP Gaps
     (t (if (member nextcat '(NP PP)) (insert-gap gapvalue nextcat arc))))))
    
;; This handles the np gap for passives. We already know that the cat is NP and PASSGAP is +

(defun insert-np-for-passive (position)
  (verbose-msg "Inserting empty np for passive~%" nil)
  (Add-to-agenda (make-entry :constit (make-constit :cat 'NP
                                     :feats '((passgap +)
                                              (root *empty*)))
                               :start position 
                               :end position 
                               :rhs nil)))

;; 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 (and (var-p gapvalue)
                 (not (eq (constit-cat (arc-mother arc)) nextcat)))
            (constit-p gapvalue))
    (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))))
      (Add-to-agenda e)
      (verbose-msg2 "Inserting e at position ~p to fill gaps~%" 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)))
         
