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

;; THE CHART DATA STRUCTURE

;;  Throughout, the term "arc" will be used for non-completed active arcs, and
;       "entry" will be used for completed arcs containing a constituent.

;; The chart is stored in four different variables:
;;     chart-arcs - an array that stores arcs indexed by their ending position
;;     constits-by-name chart-entries - an assoc list all the completed constituents, allows the
;;          code to access consituent by their unique name.
;;     sentence-length - the length of the last sentence (used to record
;;         the size of the arrays storing the chart
;;     constits-by-position chart-completed-arcs an array of the completed constituents indexed by
;;         their beginninng position. This is not by the parser, but is used in later chapters

(let  ((chart-arcs nil)
       (constits-by-name nil)
       (sentence-length 0)
       (constits-by-position nil))
       
  ;;  This initializes structures of the appropriate size for a given sentence.
       
       (defun make-chart (sentence)
         (setq sentence-length (length sentence))
         (setq chart-arcs (make-array (list (1+ sentence-length))))
         (setq constits-by-position (make-array (list (1+ sentence-length))))
         (setq constits-by-name nil))

     (defun get-sentence-length nil sentence-length)
     (defun get-chart-arcs nil chart-arcs)
     (defun get-constits-by-position nil constits-by-position)
     (defun get-constits-by-name nil constits-by-name)

       
       ;;  MAINTAINING THE ACTIVE ARCS ON THE CHART
       
       ;;  Adding an arc to the chart 
     (defun add-arc-to-chart (arc)
       (let ((e (arc-end arc)))
         (setf (aref chart-arcs e) (cons arc (aref chart-arcs e)))))
       
       ;; Retrieving all arcs ending at a specified position p
       
     (defun get-arcs (p)
       (aref chart-arcs p))
       
     ;;   PUT-IN-CHART  - adds an entry e identified by symbol name into the
     ;;     chart data structures, unless an identical one is already there
     ;;     or if the constituent is non-empty and has a gap feature of same category (e.g., NP/NP)
     ;;   Returns t is constituent is new 
     
     (defun put-in-chart (newentry)
       (let* ((start (entry-start newentry))
              (name (entry-name newentry)))
         (when (filter-constit start (entry-end newentry) (entry-constit newentry) newentry)
           (Setq constits-by-name (cons (list name newentry) constits-by-name))
           (setf (aref constits-by-position start)
                 (cons newentry (aref constits-by-position start)))
           t)))
     
     ;;   get-entry-by-name retrieves a constituent given its unique identifier
     
     (defun get-entry-by-name (name)
       (cadr (assoc name constits-by-name)))
     
     ;;    get-entries-by-position returns all entries with indicate CAT
     ;;      that start at pos
     
     (defun get-entries-by-position (cat pos)
       (remove-if-not #'(lambda (e)
                          (eq (constit-cat (entry-constit e)) cat))
                      (aref constits-by-position pos)))
     
     
)  ;; end scope of chart variables 

;; FILTER-CONSTIT - the constituent filter. Returns t if the constituent should
;;   be added to the chart. Currently this checks two things:
;;      - whether an identical constituent is already on the chart
;;      - whether the constituent has an illegal GAP feature, i.e., 
;;           a non-empty constit of cat C with a gap of cat C


(defun filter-constit (start end constit newentry)
  (let* ((cat (constit-cat constit))
         (feats (constit-feats constit))
         (existing-entries (get-entries-by-position cat start))
         (gapval (get-value constit 'gap)))
     (cond 
      ;;   check for duplicate entry
      ((some #'(lambda (e)
                  (eql (entry-end e) end)
                  (identical-feats (constit-feats (entry-constit e))
                                   feats))
             existing-entries)
       (verbose-msg "~% Not adding duplicate entry ~S" newentry)
       nil)
      ;;  check for non-empty constit of form X/X
      ((and (constit-p gapval) (eq (constit-cat gapval) cat)
              (not (equal (get-value constit 'EMPTY) '+)))
       (trace-msg "~% Not adding X/X entry ~S" newentry)
       nil)
      (t t))))


;;  This returns true if the features are identical up to variable renaming

(defun identical-feats (fl1 fl2)
  (if (eql (list-length fl1) (list-length fl2)) 
       (let ((bndgs (fconstit-match fl1 fl2)))
         ;;  check each binding. Value must be an unconstrained variable
         (if bndgs
           (every #'(lambda (pair)
                    (or (equal pair '(nil nil))
                        (and (var-p (cadr pair))
                             (null (var-values (cadr pair))))))
                bndgs)))))



;;=========================================================================
;;  MAINTAINING THE ENTRIES (i.e., completed constituents)
;;  Entries are a 7-element list of the form
;;      constit - the constituent
;;      start - the starting position of the constituent
;;      end - the ending position of the constituent
;;      rhs - the instantited rhs of the rule that built the constituent
;;      name - a unique id name
;;      rule-id - the id of the grammar rule that was used to build the entry
;;      prob - the probability score (if used)
;;
;; defining abstract data type for entries

(defstruct entry
  constit start end rhs name rule-id prob)

;;  BUILD-ENTRY - this constructs an entry given a constit, start, end and rhs

(defun build-entry (constit start end rhs rule-id prob)
  (let ((name (gen-symbol (constit-cat constit))))
    (if (noSemEnabled)
      (make-entry :constit constit :start start :end end :rhs rhs 
                :name name :rule-id rule-id :prob prob)
      (make-entry-with-sem constit start end rhs name rule-id prob))))
       

;;=========================================================================
;; Maintaining the ACTIVE ARCS

;;  An Active arc is a 7-element list consisting of
;;    mother - the constituent being built
;;    pre - the subconstituents found so far
;;    post - the subconstituents still needed
;;    start - the starting position of the arc
;;    end - the current ending position of the arc
;;    rule-id - the rule used in the grammar to introduce the arc
;;    prob -  the probability score

(defstruct arc
  mother pre post start end rule-id prob)

;;    MAKE-ACTIVE-ARC builds an active arc

(defun make-active-arc (mother pre post start end rule-id prob)
  (make-arc :mother mother :pre pre :post post :start start :end end 
            :rule-id rule-id :prob prob))

;; MAKE-ARC-FROM-RULE creates an arc from an instantiated rule 
;;        and a specified starting position. It makes copies of all unbound vars
;;        in the rule to make sure they are unique

(defun make-arc-from-rule (rule start bndgs)
  (let* ((copyrule (copy-vars-in-rule rule bndgs))
        (id (rule-id copyrule)))
    (make-active-arc (rule-lhs copyrule)
                     nil (rule-rhs copyrule)
                     start start id (get-rule-prob id start))))

;;   This computes the rule probability using one of three methods
;;    for context independent probs (CF), context dependent pobs (CS),
;;    or non-probabilistic parsing (every constituent prob defaults to 1)

(defun get-rule-prob (ruleid position)
  (case (is-prob-parse)
    (CF
     (getCFruleProb ruleid))
    (CS
     (getCSruleProb ruleid (get-word-by-position position)))
    (otherwise 1)))

;; EXTEND-ARC matches a constituent with the specified name
;;     against the next constituent needed for the active arc,
;;     so that a new extended arc can be created if they match. 

(defun extend-arc (entry name arc)
  (let ((bndgs (constit-match 
                (car (arc-post arc)) 
                (entry-constit entry))))
    (if bndgs
      (extend-arc-with-constit entry name arc bndgs))))

;;  EXTEND-ARC-WITH-CONSTIT builds a new active arc by extending an existing arc
;;   with a constituent. The constituent is added to the mother as a subconstituent
;;   feature: 1 for the first, 2 for the second, and so on. It also instantiates
;;   any variables indicated in the binding list bndgs.

(defun extend-arc-with-constit (entry name arc bndgs)
  (let* ((mother (subst-in (arc-mother arc) bndgs))
         (pre (subst-in (arc-pre arc) bndgs))
         (post (subst-in (arc-post arc) bndgs))
         (start (arc-start arc))
         (end (entry-end  entry))
         (id (arc-rule-id arc))
         (prob (* (arc-prob arc) (entry-prob (get-entry-by-name name)))))
    (cond 
     ;; arc is completed, build a new constituent
     ((endp (cdr post))
      (Add-to-agenda (build-entry 
                       (Add-feature-value mother (+ (list-length pre) 1) name)
                        start end (append pre post) id prob)))
     ;; add a new active arc by extending the current one
     (t (Add-arc (make-active-arc (Add-feature-value mother (+ (list-length pre) 1) name)
                                  (append pre (list (car post)))
                                  (cdr post)
                                   start end
                                   (arc-rule-id arc)
                                   prob))))))
    
;;   ADD-ARC  Adds a non-completed arc to the chart, and looks to extend it with gaps
;;     or entries already on the chart

(defun add-arc (arc)
  (trace-arc arc)
  (add-arc-to-chart arc)
  (when (GapsEnabled) 
    ;;  generate any gaps that could extend the arc
    (generate-gaps arc))
  ;;  check existing entries on the chart to see if they extend the arc
  (mapcar #'(lambda (entry)
              (extend-arc entry (entry-name entry) arc))
          (get-entries-by-position (constit-cat (car (arc-post arc)))
                                   (arc-end arc))))

;;=============================================================================
;;  TRACING

;; There are two levels of tracing:
;;     Basic tracing: each entry is traced as it is entered,
;;          and the complete chart is printed at the end (the default on)
;;     Verbose tracing: each non-lexical active arc is traced as well
;;           as it is constructed 
;;   TRACEON enables simple tracing, TRACEOFF turns it off
;;   VERBOSEON enables verbose tracing, if simple tracing is on.

;;   trace: 0 - no tracing, 1 - for basic tracing, 2 - verbose tracing

(let ((trace 1)
      (rules-traced))

  (defun traceon nil
    (setq trace 1))
  
  (defun traceoff nil
    (setq trace 0))
  
  (defun verboseon nil
    (setq trace 2))

  (defun trace-rule (rule-id)
    (setq trace 1)
    (setq rules-traced (cons rule-id rules-traced)))

  (defun verboseoff nil
    (setq trace 1)
    (setq rules-traced nil))
  
  (defun rules-to-trace ()
    rules-traced)
  
  (defun tracelevel nil
    trace)

  ;; General trace function for use elsewhere
  
  (defun trace-msg (string arg)
    (if (> trace 0)
      (Format t string arg)))

   (defun trace-msg2 (string arg1 arg2)
    (if (> trace 0)
      (Format t string arg1 arg2)))

  (defun verbose-msg (string arg)
    (if (> trace 1)
      (Format t string arg)))

  (defun verbose-msg2 (string arg1 arg2)
    (if (> trace 1)
      (Format t string arg1 arg2)))

)   ;;   end of scope for variable TRACE

;;  Special trace function for tracing entries

(defun trace-entry (entry)
  (cond ((> (tracelevel) 0)
         (format t "Entering constituent ~s from ~s to ~s" 
                 (entry-name entry)
                 (entry-start entry) 
                 (entry-end  entry))
         (if (is-prob-parse) (Format t ", prob = ~s~%" (entry-prob entry))
             (Format t "~%"))
         (when (> (tracelevel) 1)
                (Format t "     ~S~%" (entry-constit entry))
                (format t "~%")))))

;; Special trace function for tracing arcs


(defun trace-arc (arc)
  (if (or (and (> (tracelevel) 1)
	       (nonLexicalConstit (arc-mother arc)))
	  (and (eql (tracelevel) 1) 
		(member (arc-rule-id arc) (rules-to-trace))))
       (Format t "Adding active arc: ~%~s ~%    ~s ~%        ~s ~%        *~%         ~s from ~s to ~s~%"
	       (arc-mother arc) (arc-rule-id arc) 
	       (arc-pre arc) (arc-post arc)
	       (arc-start arc) (arc-end arc))))
	
