(in-package "USER")

;;; Der Aufruf des Parsers erfolgt mit:
;;;
;;; (is-sentece '("Das" "Boot" "sinkt") meine-grammatik mein-lexikon)
;;;
;;; Dabei m"ussen meine-grammatik und mein-lexikon an eine Grammatik, bzw. ein
;;; Lexikon gebunden sein, dass den ADTs aus "Ubung 11 und 12 entspricht:
;;;
;;; Die folgenden Funktionen werden als Interface zum Lexikon und zur Grammatik
;;; erwartet:
;;;
;;; (defun lhs (rule) ..)  liefert ein Symobl: die linke Seite der Regel
;;; (defun rhs (rule) ..)  liefert eine Liste von Symbolen: die rechte Seite der Regel
;;; (defun find-all-rules-with-first-rhs (grammatik kategorie) ..)
;;;                        liefert eine Liste von Regeln, die Kategorie als erstes auf
;;;                        der rechten Seite tragen
;;; (defun find-in-lexicon (lexikon wort-string) ..)
;;;                        liefert den Lexikoneintrag, der laut lexicon dem
;;;                        wort-string zugeordnet ist.
;;; (defun lex-entry-cat (lex-entry) ..) liefert zu einem Lexikoneintrag die Kategorie
;;;
;;; Beispiel:
;;;
;;; USER(354): (is-sentence '("Die" "alte" "Frau" "liest" "ein" "Buch" "in" "dem" "Bus") *grammatik* *lexikon*)
;;; ((S (NP (DET) (ADJ) (N))
;;;   (VP (V) (NP (DET) (N (N) (PP (PREP) (NP (DET) (N)))))))
;;;  (S (NP (DET) (ADJ) (N))
;;;   (VP (V) (NP (DET) (N)) (PP (PREP) (NP (DET) (N))))))
;;;
;;; eine Liste mit zwei Ableitungsb"aumen.



(defun snoc (item list)
  (append list (list item)))

(defun complement! (fn)
  #'(lambda (&rest args) (not (apply fn args))))

(defun find! (item sequence 
              &key (test #'eql) key)
  (funcall #'remove item sequence :test (complement! test) :key key))

(defun rule-lhs (rule)
  (lhs rule))

(defun rule-rhs (rule)
  (rhs rule))

(defun rules-starting-in (category grammar)
  (find-all-rules-with-first-rhs grammar category))

(defstruct edge
  lhs
  analyzed
  unanalyzed
  start
  span)

(defun passive-p (edge)
  (null (edge-unanalyzed edge)))

(defun edge= (x y)
  (and (eq (edge-lhs x) (edge-lhs y))
       (equal (edge-analyzed x) (edge-analyzed y))
       (equal (edge-unanalyzed x) (edge-unanalyzed y))
       (= (edge-start x) (edge-start y))
       (= (edge-span x) (edge-span y))))

(defun active-edges-at (chart position)
  (remove nil (aref chart position) :key #'edge-unanalyzed))

(defun passive-edges-at (chart position)
  (find! nil (aref chart position) :key #'edge-unanalyzed))

(defun parse (input grammar)
  (let ((chart (make-array (length input))))
    (do* ((input input (rest input))
          (word (first input) (first input))
          (i 0 (+ i 1)))
        ((null input) (parse-loop chart i grammar))
      (push (make-edge :lhs word :analyzed nil :unanalyzed nil :start i :span 1)
	    (aref chart i))
      (dolist (rule (rules-starting-in word grammar))
        (let* ((edge (make-edge :lhs (rule-lhs rule)
                                :analyzed (list word) 
                                :unanalyzed (rest (rule-rhs rule))
                                :start i :span 1)))
          (push edge (aref chart i)))))))

(defun parse-loop (chart length grammar)
  (let ((n 0))
    (dotimes (i length)
      (dolist (edge (aref chart i))
        (if (passive-p edge)
          (incf n (postulate edge chart grammar))
          (when (< (+ i (edge-span edge)) length)
            (incf n (fundamental-rule edge chart))))))
    (if (zerop n)
      chart
      (parse-loop chart length grammar))))

(defun fundamental-rule (active chart)
  (let* ((lhs (edge-lhs active))
         (analyzed (edge-analyzed active))
         (unanalyzed (edge-unanalyzed active))
         (start (edge-start active))
         (span (edge-span active))
         (n 0))
    (dolist (passive (passive-edges-at chart (+ start span)) n)
      (when (eq (edge-lhs passive) (first unanalyzed))
        (let ((edge (make-edge :lhs lhs
                               :analyzed (snoc (first unanalyzed) analyzed)
                               :unanalyzed (rest unanalyzed)
                               :start start 
                               :span (+ span (edge-span passive)))))
          (unless (member edge (aref chart start) :test #'edge=)
	    (push edge (aref chart start))
            (incf n)))))))

(defun postulate (passive chart grammar)
  (let ((category (edge-lhs passive))
        (start (edge-start passive))
        (span (edge-span passive))
        (n 0))
    (dolist (rule (rules-starting-in category grammar) n)
      (let* ((lhs (rule-lhs rule))
             (rhs (rule-rhs rule))
             (edge (make-edge :lhs lhs
                              :analyzed (list category) :unanalyzed (rest rhs)
                              :start start :span span)))
        (unless (member edge (aref chart start) :test #'edge=)
	  (push edge (aref chart start))
          (incf n))))))

(defun words-to-categories (lexicon list-of-word-strings)
  (mapcar #'(lambda (word-string) (lex-entry-cat (find-in-lexicon lexicon word-string)))
	  list-of-word-strings))

(defun is-sentence (list-of-word-strings grammar lexicon)
  (let* ((categories (words-to-categories lexicon list-of-word-strings))
	 (chart (parse categories grammar))
	 (complete-edges (find-edges chart :start 0 :span (length list-of-word-strings))))
    (cond (complete-edges
	   (loop for edge in complete-edges
		 append (edge2trees chart edge)))
	  (T NIL))))

(defun edge2trees (chart edge)
  ;;
  ;; return all trees subsumed by .edge.; compute all consistent instantiations
  ;; for the right-hand side (complete()), convert embedded edges into trees,
  ;; cross multiply the sequence of resulting trees, and then fold out into a
  ;; full forest.
  ;;
  (let* ((root (edge-lhs edge))
         (analyzed (edge-analyzed edge))
         (daughters 
          (complete chart analyzed (edge-start edge) (edge-span edge))))
    (if daughters
      (mapcan #'(lambda (analysis)
                  ;;
                  ;; for each decomposition of the right-hand side determine
                  ;; the corresponding tree(s) and then add the tree root;
                  ;; accumulate all results in a flat list
                  ;;
                  (let ((trees (cross-product 
                                (mapcar #'(lambda (edge) 
                                            (edge2trees chart edge))
                                        analysis))))
                    (mapcar #'(lambda (tree)
                                (cons root tree))
                            trees)))
              daughters)
      (list (cons root analyzed)))))

(defun cross-product (lists)
  ;;
  ;; ((a b) (1 2)) --> ((a 1) (a 2) (b 1) (b 2))
  ;;
  (if (null (rest lists))
    (mapcar #'list (first lists))
    (mapcan #'(lambda (prefix)
                (mapcar #'(lambda (suffix)
                            (cons prefix suffix))
                        (cross-product (rest lists))))
            (first lists))))

(defun alternative-cross-product (lists)
  ;;
  ;; `loop' instead of `map':
  ;; Allegro compiler produces much more efficient code!
  ;; try: (time (cross-product (make-list 6 :initial-element (make-list 10))))
  ;;
  (if (null (rest lists))
      (loop for element in (first lists)
            collect (list element))
    (loop with cross-product-of-rest = (alternative-cross-product (rest lists))
          for element in (first lists)
          append (loop for list in cross-product-of-rest
                       collect (cons element list)))))


(defun find-edges (chart &key (lhs nil lhs-p) 
                              (analyzed nil analyzed-p) 
                              (unanalyzed nil unanalyzed-p)
                              (start 0 start-p)
                              (span 0 span-p))
  ;;
  ;; successively select edges from .chart. that meet the criteria specified through
  ;; the optional .lhs. to .span. arguments; unspecified arguments do not constrain
  ;; the selection (i.e. match any actual value).
  ;;
  (let* ((start (if start-p (aref chart start) (reduce #'append chart)))
         (span (if span-p (find! span start :key #'edge-span) start))
         (unanalyzed (if unanalyzed-p 
                       (find! unanalyzed span :key #'edge-unanalyzed) 
                       span))
         (analyzed (if analyzed-p 
                     (find! analyzed unanalyzed :key #'edge-analyzed) 
                     unanalyzed))
         (lhs (if lhs-p (find! lhs analyzed :key #'edge-lhs) analyzed)))
    lhs))

(defun complete (chart rhs start span)
  ;;
  ;; find all complete instantiations for .rhs. in .chart.; since there may
  ;; well be multiple decompositions with different edge boundaries, walk
  ;; through .rhs. category by category, find corresponding edges, and then
  ;; cross multiply with all instantiations for the remainder of .rhs.
  ;;
  (cond ((<= span 0) nil)
        ((null (rest rhs))
         (mapcar #'list (find-edges chart 
				    :lhs (first rhs) :unanalyzed nil
				    :start start :span span)))
        (t
         (mapcan #'(lambda (edge)
                     (mapcar #'(lambda (completion)
                                 (cons edge completion))
                             (complete chart (rest rhs) 
                                       (+ start (edge-span edge))
                                       (- span (edge-span edge)))))
                 (find-edges chart
                             :lhs (first rhs) :unanalyzed nil
                             :start start)))))