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

;; A simple sentence generator: given a constituent with the SEM filled
;;   in, randomly generates a setence to realize the expression.
  
;; Given a consituent, find all rules whose lhs matches it
(defun find-expansions (C)
    (let ((rulesWithBindings nil))
      (mapcar #'(lambda (x)
                  (let ((bndgs (Constit-Match C (rule-lhs x))))
                    (if bndgs 
                      (setq rulesWithBindings (cons (list bndgs x) rulesWithBindings)))))
              (getgrammar))
     rulesWithBindings))

;; Given a list of constituents, return back a triple
;;   (pre head post) breaking the list at the first head found

(defun split-up-list (clist pred)
  (cond ((null clist) nil)
        ((apply pred (list (car clist))) (list nil (car clist) (cdr clist)))
        (t (let ((ans (split-up-list (cdr clist) pred)))
             (if ans (list (cons (car clist) (first ans)) (second ans) (third ans))
                 nil)))))

;; Given a clist, find all expansions of the next constituent (doing
;;     heads first, fully-bound non-lexical constituents second,
;;     then other nonlexical heads, then lexical constits
;;  returns a list of new symbol-lists if the constituent can be expanded
;;  returns t if there are no expansions to perform (i.e., we are done)
;;  returns nil if there is a constituent that cannot be expanded

(defun expand-clist (clist)
  (let* ((ans (select-next clist)))
    (if ans
      (let* 
        ((pre (car ans))
         (constit (second ans))
         (post (third ans))
         (explist (find-expansions constit))
         (results (if explist
                    (mapcar #'(lambda (rulewithBinding)
                                (let ((bndgs (car ruleWithBinding))
                                      (rule (cadr ruleWithBinding)))
                                  (subst-in (append pre (append (rule-rhs rule) post)) bndgs)))
                            explist)
                    (insert-lexical pre Constit post))))
        (trace-msg2 "~%Expanding ~S~%   to ~S" constit (car results))
        (verbose-msg "~%   Backup stack is ~S" (cdr results))
        (if results results
            (trace-msg "~%  BACKTRACKING:  Cannot realize ~S" constit)))
      t)))

(defun select-next (clist)
  (let* ((ans (split-up-list clist #'(lambda (x)
                                        (and (constit-p x)
                                             (constit-head x)))))
        (ans1 (if ans ans 
                  (split-up-list clist #'(lambda (x) 
                                 (and (nonlexicalconstit x)
                                      (fully-bound x))))))
        (ans2 (if ans1 ans1 
                  (split-up-list clist #'(lambda (x)
                                           (and (nonlexicalconstit x)
                                                (eq (constit-cat x) 'VP))))))
        (ans3 (if ans2 ans2 
                  (split-up-list clist #'nonlexicalconstit)))
        (ans4 (if ans3 ans3 
                  (split-up-list clist #'constit-p))))
    ans4))

(defun fully-bound (constit)
  (every #'(lambda (fv)
             (not (var-p (cadr fv))))
         (constit-feats constit)))

(defun insert-lexical (pre C post)
  (let ((lexs (find-possible-lexs C)))
    (if lexs
        (mapcar #'(lambda (lex)
                    (subst-in (append pre (cons (cons 'word (cadr lex))
                                          post)) (car lex)))
                lexs)
    )))

;;  returns a list of possible lexical realizations of C, together
;;   with the bindings required

(defun find-possible-lexs (C)
    (let ((rulesWithBindings nil))
      (mapcar #'(lambda (x)
                  (let ((bndgs (Constit-Match C (cadr x))))
                    (if bndgs 
                      (setq rulesWithBindings (cons (list bndgs x) rulesWithBindings)))))
              (get-Lexicon))
     rulesWithBindings))


(defun complete-lexical-realization (clist)
  (if (null clist) nil
    (let ((c (car clist)))
      (if (constit-p c)
        (let ((lexs (find-possible-lexs C)))
          (if lexs
            (let ((firstlex (cadar lexs))
                  (firstbndgs (caar lexs)))
              (cons (cons 'word firstlex)
                    (complete-lexical-realization (subst-in (cdr clist) firstbndgs))))
            (cons (list 'word 'unknown-word c)
                  (complete-lexical-realization (cdr clist)))))
       (cons c (complete-lexical-realization (cdr clist))))))
    )


(defun realize (C)
  (let ((symbol-lists (list (list C))))
    (loop
      (let*  
        ((current-symbol-list (car symbol-lists))
         (expansion (expand-clist current-symbol-list)))
        (cond ((listp expansion)
               (setq symbol-lists (append expansion (cdr symbol-lists))))
              (expansion 
               (let ((ans (complete-lexical-realization current-symbol-list)))
                 (if (or ans (null symbol-lists))
                   (return ans)
                     
        ))))))))

(defun words (C)
  (mapcar #'(lambda (x)
              (cadr x))
          (realize C)))

(defun build-gen-constit (cat feats)
  (make-constit :cat cat
                :feats (merge-features feats (gen-feats cat))))  

