;;;======================================================================
;;; 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 GRAMMAR AND LEXICON
;;  This file contains functions that manage the grammar and the lexicon
;;  These are mostly I/O routines to provide for a more user-friendly system.



;;*******************************************************************************
;;  THE LEXICON DATA STRUCTURE
;; 
;; The lexicon is a simple assoc list of the form
;;   ((word constit) ... (word constit))
;; These functions just convert the user specified format into the more cumbersome
;;   to type internal format


(let ((lexicon nil))
  
  ;;  MAKE-LEXICON deletes the old active lexicon and creates a new one
  
  (defun make-lexicon (ls)
    (setq lexicon (mapcar #'make-lex ls)))
  
  ;;  AUGMENT-LEXICON extends the current active lexicon
  (defun augment-lexicon (ls)
    (setq lexicon (append lexicon (mapcar #'make-lex ls))))
  
  (defun get-lexicon nil
    lexicon)

  (defun defined-words nil
    (mapcar #'car lexicon))
  
  ;; UNKNOWN-WORD checks a sentence of unknown words to provide a warning message
  
  (defun unknown-word (sentence)
    (if sentence
      (let ((entry (assoc (car sentence) lexicon)))
        (if entry 
          (unknown-word (cdr sentence))
          (car sentence)
          ))))
  
  )  ;; end of scope for LEXICON

   
;; MAKE-LEX creates a lexical entry from the user-input format

(defun make-lex (entry)
  (init-var-table)
  (if (not (eq (length entry) 2)) 
    (Format t "~%WARNING: Bad lexical entry: ~S~%" entry))
  (let* ((name (car entry))
         (def (cadr entry))
         (cat (car def))
         (feats (cdr def)))
    (mapcar #'check-feat  feats)
    (if (noSemEnabled)
      (list name 
            (build-constit cat (mapcar #'(lambda (x)
                                           (read-fv-pair x nil))
                                       feats) nil))
      (list name 
            (build-constit cat (cons (list 'VAR (make-var :name 'V))
                                     (mapcar #'(lambda (x)
                                           (read-fv-pair x nil))
                                       feats))
                           nil)))))
      

;; LOOKUPWORD finds all the entries in the lexicon for a specific word and creates
;;    a chart entry for them. To do this, is also must know the starting position of
;;    the word.

(defun lookupword (word n)
  (let ((entries nil))
    (mapcar #'(lambda (lex-entry) 
                (if (eq word (car lex-entry))
                  (setq entries (cons (build-entry 
                                       (instantiateVAR (cadr lex-entry)) n (+ n 1) nil) entries))))
            (get-lexicon))
    entries))

;;    CHECK-FEAT verifies that a feature-value pair is in the right format

(defun check-feat (fv)
  (if (not (and (listp fv) (eq (length fv) 2)))
    (Format t "~%Warning: bad feature specification: more than one value in ~S~%" fv)
))

;;*******************
;;  LEXICAL CATEGORIES

(let ((lexicalCats '(n v adj art p aux pro qdet pp-wrd name to)))
  
  (defun defineLexicalCats (cs)
    (if (listp cs) 
      (setq lexicalCats cs)
      (Format t "Bad Format in ~S~%  you must pass in a list of lexical categories" cs)))

  (defun addLexicalCat (c)
    (if (symbolp c)
      (setq lexicalCats (cons c lexicalCats))
      (Format t "Lexical categories must be atoms. ~S is ignored" c)))
  
  (defun getLexicalCats nil
    lexicalCats)
  
  (defun lexicalConstit (c)
    (and (constit-p c) (member (constit-cat c) lexicalCats)))
  
  (defun nonLexicalConstit (c)
    (and (constit-p c) (not (member (constit-cat c) lexicalCats))))

)  ;; end scope of LEXICALCATS


;;**************************************************************************
;;  THE GRAMMAR DATA STRUCTURE

;;     Grammar rules are of the form
;;        (<constit-pattern>  ->  <constit-pattern> ... <constit-pattern>)
;; e.g.,  (((CAT S) (INV -) (AGR (? a))) -> ((CAT NP) (AGR (? a))) ((CAT VP) (AGR (? a))))

(defstruct (rule
            (:print-function (lambda (p s k)
                               (Format s "~%<~S~%   ~S ~S>" (rule-lhs p) (rule-id p) (rule-rhs p)))))
  lhs id rhs)

(let ((grammar nil))
  
  ;; MAKE-GRAMMAR removes the old active grammar and creates a new one
  
  (defun make-grammar (g)
    (setq grammar  (convert-grammar g)))
  
  ;;AUGMENT-GRAMMAR adds a new grammar onto the existing active grammar 
  
  (defun augment-grammar (g)
    (setq grammar (append grammar (convert-grammar g))))
  
  (defun getGrammar nil
    grammar)
  
  ) ;; end scope of variable GRAMMAR

;;  CONSTRUCTION OF GRAMMAR FROM INPUT FORMAT

;;   These functions convert a grammar specified in CAT or headfeature
;;   format into internal grammar format

;; CONVERT-GRAMMAR does the actual conversion from the input formats

(defun convert-grammar (g)
  (let ((format (car g))
        (rules (cdr g)))
    (Cond ((eq format 'CAT)
           (merge-rules (mapcar #'build-rule rules)))
          ((eq (car format) 'Headfeatures)
             (mapcar #'(lambda (x)
                         (insertHeadFeatures x (cdr format)))
                      (merge-rules (mapcar #'build-rule rules))))
          (t (Warn "***WARNING*** Bad grammar format") g))))

;;  MERGE-RULES collapses a list of lists into one list (using append)
   
(defun merge-rules (g)
  (cond ((null g) nil)
        (t (append (car g) (merge-rules (cdr g))))))
                                                                     
;;  BUILD-RULE
;;   inserts the CAT feature for each constituent and builds all the variables.
;;   It also checks the format of the rule.
;;   It returns a list of transformed rules. If gaps are disabled, 
;;   there will only be one element in the list. Otherwise, multiple rules
;;   may be generated using the algorithm in Chapter 5.  


(defun build-rule (r)
  (init-var-table)
  (let ((newrule
         (make-rule :lhs (Verify-and-build-constit (car r) r nil)
                          :id (cadr r) 
                          :rhs (mapcar #'(lambda (x)
                                           (cond ((eq (car x) 'head)
                                                  (if (caddr x) (Format t "~%***WARNING*** Bad head specification format in rule ~%~S~%"
                                                                        r))
                                                  (verify-and-build-constit (cadr x) r t))
                                                 (t (verify-and-build-constit x r nil))))
                                       (cddr r)))))
    (if (GapsDisabled) (list newrule)
        (generate-gap-features-in-rule newrule))))


;;  This checks the form of a constituent in a rule, and converts it to
;;   the internal format. The rule arg is just passe in for the error message

(defun verify-and-build-constit (constit rule head)
  (if (not (atom (car constit)))
    (Format t "~%***WARNING*** Constituent category must be an atom. Bad constituent ~s~%     in rule ~s~%"
            constit rule))
  (let ((feats (mapcar #'(lambda (x) (read-fv-pair x rule))
                       (cdr constit))))
    (build-constit (car constit) feats head)))

;;  READ-FV-PAIR reads a single feature-value pair and returns its internal format

(defun read-fv-pair (fv-pair rule)
    (if (not (and (listp fv-pair) 
                  (eql (list-length fv-pair) 2)))
      (Format t "~%***WARNING*** Bad feature-value specification ~s in rule ~s~%"
              fv-pair rule)
      (list (car fv-pair) (read-value (cadr fv-pair) rule))))

;;  READ-VALUE checks the value to see if it is a variable, or an embedded
;;   constituent.

(defun read-value (val rule)
  (cond ((isvar val)
         (let ((var (get-var val)))
           (if var var
               (if (atom val)
                 (add-var val (build-var val nil))
                 (add-var val (build-var (cadr val) (cddr val)))))))
        ((isembeddedconstit val)
         (if (and (atom (second val))
                  (listp (third val)))
           (make-constit :cat (cadr val) :feats (mapcar #'(lambda (x) (read-fv-pair x rule))
                                                      (cddr val)))
           (Format t "~%Warning: bad embedded constituent specification found: ~S~%" val)))
        ((atom val) val)
        ((listp val) (mapcar #'(lambda (x) (read-value x rule)) val))))

;;  This allows variables to be specified in three different forms 
;;           ?X,  (? X), or (? X Val1 ... Valn)

(defun isvar (expr)
  (or (and (symbolp expr)
           (equal (char (symbol-name expr) 0) #\?))
      (and (listp expr)
           (equal (car expr) '?))))

;;  Embedded constituents are of form (& cat feat-val-list)
(defun isembeddedconstit (expr)
  (and (listp expr)
       (equal (car expr) '%)))


;;   VAR-TABLE MAINTENANCE
;;  These functions maintain an a-list of variables so that identical
;;   variables in the input gets the same variable structure.

(let ((var-table nil))

  (defun init-var-table nil
    (setq var-table nil))

  (defun get-var (x)
    (cdr (assoc x var-table :test #'equal)))
  
  (defun add-var (expr var)
    (setq var-table (cons (cons expr var)
                          var-table))
    var)

) ;; end scope of VAR-TABLE


;;  INSERTHEADFEATURES

;; inserts head features into a rule

(defun insertHeadFeatures (rule headfeatList)
  (let* ((mother (rule-lhs rule))
         (headfeats (cdr (assoc (constit-cat mother) headfeatList)))
         (rhs (rule-rhs rule))
         (head (findfirsthead rhs)))
    (cond 
     ;;  If there are no head features, just return the old rule
     ((null headfeats) rule)
     ;;  Otherwise, construct the feature-value pairs for the headfeats and insert them
     (t
      (if (null head) (Format t "~%****WARNING: No head specified in rule ~s" rule))
      (Insertfeatures rule 
                      (mapcar #'(lambda (hf)
                                  (BuildHeadFeat hf mother head rule))
                              headfeats))))))

             
;;  BUILDHEADFEAT builds a feature/value pair to insert in the mother and head
;;  We must check both the mother and head to see if these features already are
;;  defined
(defun BuildHeadFeat (headfeat mother head rule)
  (let ((mval (get-value mother headfeat))
        (hval (get-value head headfeat))
        (varname (gen-symbol headfeat)))
    (cond ((and (null mval) (null hval))
           (list headfeat (make-var :name varname)))
          ((null mval)
           (list headfeat hval))
          ((null hval)
           (list headfeat mval))
          ((equal mval hval)
           (list headfeat mval))
          (t (Format t "~%***WARNING*** Head feature ~s incompatible ~%   in rule ~s"
                     headfeat rule)))))

(defun findFirstHead (rhs)
  (cond ((null rhs) nil)
        ((constit-head (car rhs)) (car rhs))
        (t (findFirstHead (cdr rhs)))))

;;INSERTFEATURES builds the rule, inserts the feature-value pairs (values)
;;   into the mother and any consituent on the rhs marked as a head.

(defun insertfeatures (rule values)
  (let ((mother (rule-lhs rule)))
    (make-rule :lhs (build-constit (constit-cat mother)
                                   (mergefeatures (constit-feats mother) values) nil)
               :id (rule-id rule)
               :rhs (mapcar #'(lambda (c)
                                (if (constit-head c)
                                  (build-constit (constit-cat c)
                                                 (mergefeatures (constit-feats c) values)
                                                 t)
                                  c))
                            (rule-rhs rule)))))

;; MERGEFEATURES adds the feature-value pairs in feats to the constit, 
;;   It assumes that the feature value in oldfeats is the one desired if both present

(defun mergefeatures (oldfeats feats)
  (cond ((null feats) oldfeats)
        (t (if (assoc (caar feats) oldfeats)
             (mergefeatures oldfeats (cdr feats))
             (mergefeatures (append oldfeats (list (car feats)))
                         (cdr feats))))))



;; REMOVEFEATURE returns a copy of a feature list with the feature named fname removed

(defun removefeature (fname flist)
 (remove-if #'(lambda (y) (eq fname (car y))) flist))

;;  GEN-SYMBOL generates a unique identifier to identify a constituent

(defun gen-symbol (name)
  (gentemp (string name)))

;;********************************************************************************
;;
;;   PRINTING OUT THE GRAMMAR

(defun show-grammar ()
  (mapcar #'%print (getGrammar))
  t)

(defun %print (obj)
  (Format t "~%~S" obj)
)
         
;; ********************************************************************************
;;
;;   PRINTING OUT THE CHART
;;
;;  Printing the entire chart

(defun show-chart nil
  (Format t "~%~%  T H E   C H A R T ~%")
  (mapcar #'Show-named-entry (get-constits-by-name))
  (Format t "~%"))

(defun show-named-entry (e)
  (let* ((entry (cadr e))
         (name (car e)))
    (Format t "~s:~S from ~S to ~S~%" name (entry-constit entry)
            (entry-start entry) (entry-end entry))))

;;  Printing out every S structure that spans the sentence

(defun show-answers nil
  (Format t "~%~% THE COMPLETE PARSES FOUND~%")
  (mapcar #'(lambda (x)
              (Print-solution x (get-sentence-length)))
                                 (get-constits-by-name))
  t)

(defun print-solution (ce length)
  (let* ((entry (cadr ce))
        (c (entry-constit entry))
        (g (get-value c 'gap)))
    (if (and (eq (get-value c 'cat) 's)
             (eq (entry-start entry) 0) 
             (eq (entry-end entry) length)
             (or (eq g '-) (null g))) 
      (print-tree 0 ce))))

;; Prints out a constituent, instantiates the variables in its subconstituents 
;;  and prints them with appropriate indentation

(defun print-tree (prefix ce)
  (print-blanks prefix)
  (show-named-entry ce)
  (instantiate-and-print 1 (+ prefix 1) (entry-constit (cadr ce)) (entry-rhs (cadr ce))))

(defun instantiate-and-print (n prefix constit rhs)
  (cond ((null rhs) nil)
        (t (print-tree prefix (instantiate-entry (get-entry-by-name (get-value constit n)) 
                                                 (car rhs)))
           (instantiate-and-print (+ n 1) prefix constit (cdr rhs)))))

(defun instantiate-entry (entry pattern)
  (list (entry-name entry) (subst-in entry
                          (constit-match pattern (entry-constit entry)))))
         

(defun print-blanks (n)
 (dotimes (i n)
   (format t "  ")))
                          
              




