;;;======================================================================
;;; 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 5-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
;;
;; defining abstract data type for entries

(defstruct entry
  constit start end rhs name ruleid)

;;  BUILD-ENTRY - this constructs an entry given a constit, start, end and rhs
;;  This version is for Chapters 4 and 5  only. A new version is defined later

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


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

;;  An Active arc is a 5-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 (not used til chapter 7)

(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)
  (make-arc :mother mother :pre pre :post post :start start :end end :rule-id rule-id))

;; MAKE-ARC-FROM-RULE creates an arc from an instantiated rule 
;;        and a specified starting position

(defun make-arc-from-rule (rule start bndgs)
    (make-active-arc (subst-in (rule-lhs rule) bndgs) 
                     nil (subst-in (rule-rhs rule) bndgs)
                     start start (rule-id rule)))

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

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

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

  (defun verboseoff nil
    (setq trace 1))
  
  (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 (s expr p1 p2)
  (cond ((> (tracelevel) 0)
         (format t s expr p1 p2)
         (cond ((and (> (tracelevel) 1) (atom expr))
                (Format t "~S~%" (rule-lhs (get-entry-by-name expr)))
                (format t "~%"))))))

;; Special trace function for tracing arcs

(defun trace-arc (arc)
  (if (and (> (tracelevel) 1)
           (nonLexicalConstit (arc-mother arc)))
    (Format t "Adding active arc ~s <- ~%      ~s * ~s from ~s to ~s~%"
            (arc-mother arc) (arc-pre arc) (arc-post arc) (arc-start arc) (arc-end arc))))
