(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.
;;;======================================================================
;;
;;  THE BASIC BU PARSER
;;    This uses the left corner algorithm to build a chart "bottom-up"
;;    To run the parser, you must have made a lexicon and grammar "active" using the
;;    functions make-grammar and make-lexicon. (see file "GrammarandLexicon" for code)
;;
;;  e.g.,  Here is a sample session, assuming *lexicon1* and *grammar1* are
;;              appropriately defined
;;          (make-lexicon *lexicon1*)
;;          (make-grammar *grammar1*)
;;          (BU-parse '(the dog barks))
;;

;;==================================================================================
;;
;;   SEARCH OPTIONS - whether to stop when first interpretation found or not
(let ((best-first nil)
      (FOUND-ANSWER nil))

  (defun set-best-first ()
    (Format t "~%Best first mode: parser will stop at first complete interpretation")
    (setq BEST-FIRST t))
  (defun set-find-all ()
    (Format t "~%Parser will find all interpretations")
    (setq BEST-FIRST nil))
  (defun stop-on-first ()
    BEST-FIRST)

  (defun set-no-answer-found ()
    (setq FOUND-ANSWER nil))
  (defun set-answer-found ()
    (setq FOUND-ANSWER t))
  (defun answer-found ()
    FOUND-ANSWER)

)  ;; end scope of variables BEST-FIRST and FOUND-ANSWER
;;==================================================================================
;;    Options for probabilistic parsing
;;

;;  This handles three modes:
;;        Non-probabilistic parsing: every constituent is assigned probability 1
;;        context-free probabilistic parsing: uses static rule probabilities
;;        context-dependent prob. parsing: uses rule probs conditioned on category of first word

(let ((probabilistic nil))
  (defun use-CF-probabilities ()
    (setq probabilistic 'CF))
  (defun use-CS-probabilities ()
    (setq probabilistic 'CS))
  (defun no-probabilities ()
    (setq probabilistic nil))
  (defun is-prob-parse ()
    probabilistic)
) ;; end scope of variable PROBABILISTIC

;;==================================================================================
;;THE AGENDA
;;   The agenda is a simple stack for the basic parser, but a prioritized list
;;   for the probabilistic parser. These functions all
;;    use the variable AGENDA

(let ((*agenda* nil)
      (*sentence* nil))

  (defun add-to-agenda (k)
     (if k
       (if (is-prob-parse)
         (setq *agenda* (insert-in-agenda k (entry-prob k) *agenda*))
         (setq *agenda* (cons k *agenda*)))))

  (defun get-next-entry nil
    (let ((k (car *agenda*)))
      (setq *agenda* (cdr *agenda*))
      k))
  
  ;;  INIT-AGENDA - takes a sentence and creates a list of constituents by looking
  ;; up each word in the lexicon.
  
  (defun init-agenda (sentence)
    (setq *sentence* sentence)
    (setq *agenda* nil)
    (if (is-prob-parse)
      (mapcar #'add-to-agenda (getCSlexicalentries sentence))
      (setq *agenda* (gen-entries sentence 0))))
  
  ;; GEN-ENTRIES looks up each word in the sentence and makes an entry with its constit
  ;;   with its sentence position

  (defun gen-entries (sentence n)
    (if sentence
      (append (lookupword (car sentence) n) (gen-entries (cdr sentence) (+ n 1)))))

  (defun empty-agenda nil
    (null *agenda*))

  (defun get-word-by-position (pos)
    (nth pos *sentence*))

)  ;; end of scope for variable *agenda*


;;  Inserts entry into agenda based on its probability

(defun insert-in-agenda (arc prob agenda)
  (cond ((null agenda) (list arc))
        ((>= prob (entry-prob (car agenda)))
         (cons arc agenda))
        (t (cons (car agenda) 
                 (insert-in-agenda arc prob (cdr agenda))))))



;;===========================================================================
;;   The B U PARSER

(defun BU-parse (sentence)
  (if (unknown-word sentence) 
    (Format t "~%~%*****Warning****** Unknown word ~s~%" (unknown-word sentence)))
  (set-no-answer-found)
  (init-agenda sentence)
  (make-chart sentence)
  
; ---------- Fred Feb 10, 1995 -------  
  
  (loop (if (parse-done) 
          (return (when (> (tracelevel) 0) 
                        (show-chart) 
                        (show-sem  sentence) 
                        T
                  )))
        (add-entry-to-chart (get-next-entry))))

(defun parse-done ()
  (or (empty-agenda)
      (and (stop-on-first) (answer-found))))
           
;; ADD-ENTRY-TO-CHART inserts a new entry into the chart, adding any new
;;    active arcs introduced by grammar rules that can start with the
;;    constituent, and extending any existing arcs that can be extended by
;;    the consituent. Note that PUT-IN-CHART checks if an identical entry
;;    already exists and returns t only if the entry truly is new.

(defun add-entry-to-chart (entry)
  (when (put-in-chart entry)
    (trace-entry entry)
    (check-for-answer entry)
    (Make-New-BU-Active-Arcs entry (entry-name entry) (getGrammar))
    (Chart-Extend entry (entry-name entry))
    ))

;; checks if an S interpretation that covers the input has been found

(defun check-for-answer (entry)
      (if (and (eq (get-value (entry-constit entry) 'cat) 's)
               (eq (entry-start entry) 0) 
               (eq (entry-end entry) (get-sentence-length))
               (let ((g (get-value (entry-constit entry) 'gap)))
                 (or (eq g '-) (null g))))
        (set-answer-found)))

;;  MAKE-NEW-BU-ACTIVE-ARCS
;;  creates new active arcs by checking the grammar for rules that start
;;      with the constitituent in the new entry with the specified name.

(defun Make-New-BU-Active-Arcs (entry name grammar)
  (let ((c (entry-constit entry)))
    (mapcar #'(lambda (x)
                (let ((bndgs (Constit-Match (car (rule-rhs x)) C)))
                  (if bndgs
                      (extend-arc-with-constit entry name
                                               (make-arc-from-rule x
                                                      (entry-start entry) bndgs)
                                           nil))))
            grammar)))

;; CHART-EXTEND tries to extend arcs in the chart with the new constituent

(defun chart-extend (entry name)
     (mapcar #'(lambda (x) (extend-arc entry name x)) 
             (get-arcs (entry-start entry))))


