;; Musterloesung Uebung 8
;;
;; Aufgabe 1. Ein Chart Parser mit Agenda

(in-package "USER")

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

(defvar *chart* nil)

(defvar *agenda* nil)

(defvar *trace* nil)

(defparameter *grammar*
    '((s np vp)
      (np det n)
      (np np pp)
      (vp v)
      (vp v np)
      (vp v pp)
      (pp p np)
      (n adj n)
      (n woman)(n man)(n ball)(n scope)
      (det the)(det a)
      (p with)
      (adj fat)
      (adj cute)
      (v saw)(v snored)))

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

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

(defun rules-starting-in (category)
  (loop for rule in *grammar*
      when (eq category (first (rule-rhs rule)))
      collect rule))

(defstruct (edge (:print-function edge-print))
  lhs analyzed unanalyzed start end)

(defun edge-print (edge stream level)
  (declare (ignore level))
  (format stream "~_<(~A, ~A) ~A -> ~{~A~^ ~} . ~{~A~^ ~}>"
          (edge-start edge)
          (edge-end edge)
          (edge-lhs edge)
          (edge-analyzed edge) 
          (edge-unanalyzed edge) ))
          
(defun passive-p (edge)
  (null (edge-unanalyzed edge)))

(defstruct chart by-start by-end)



(defun active-edges-ending-at (chart position)
  (loop for edge in (aref (chart-by-end chart) position)
      unless (passive-p edge)
      collect edge))

(defun passive-edges-starting-at (chart position)
  (loop for edge in (aref (chart-by-start chart) position)
      when (passive-p edge)
      collect edge))

(defun find-edges (&key (lhs nil lhs-p)
                        (analyzed nil analyzed-p)
                        (unanalyzed nil unanalyzed-p)
                        (start 0 start-p)
                        (end 0 end-p))
  (loop for edges across (chart-by-start *chart*)
      nconc (loop for edge in edges
                when (and (or (null start-p)
                              (= start (edge-start edge)))
                          (or (null end-p)
                              (= end (edge-end edge)))
                          (or (null lhs-p)
                              (eq lhs (edge-lhs edge)))
                          (or (null analyzed-p)
                              (equal analyzed (edge-analyzed edge)))
                          (or (null unanalyzed-p)
                              (equal unanalyzed (edge-unanalyzed edge))))
                     collect edge)))
  
(defun parse (input)
  (let ((number-of-vertices (1+ (length input))))
    (setf *chart*
      (make-chart :by-start (make-array number-of-vertices)
                  :by-end (make-array number-of-vertices)))
    (setf *agenda* nil)
    (loop for word in input
        for position from 0
        do (loop for rule in (rules-starting-in word)
               do (new-edge :lhs (rule-lhs rule)
                            :analyzed (list word)
                            :unanalyzed (rest (rule-rhs rule))
                            :start position
                            :end (1+ position))))
    (parse-loop)))

(defun parse-loop ()
  (loop for edge = (pop *agenda*)
      when *trace*
      do (print edge)
      when (not edge)
      return *chart*
      when (store-edge edge)
      do (cond ((passive-p edge)
                (fundamental4passive edge)
                (postulate edge))
               (T 
                (fundamental4active edge)))))

(defun fundamental4active (active)
  (loop with lhs = (edge-lhs active)
      with analyzed = (edge-analyzed active)
      with unanalyzed = (edge-unanalyzed active)
      with start = (edge-start active)
      with end = (edge-end active)
      for passive in (passive-edges-starting-at *chart* end)
      when (eq (edge-lhs passive)
               (first unanalyzed))
      do (new-edge :lhs lhs
                   :analyzed (snoc (first unanalyzed) analyzed)
                   :unanalyzed (rest unanalyzed)
                   :start start :end (edge-end passive))))

(defun fundamental4passive (passive)
  (loop with lhs = (edge-lhs passive)
      with start = (edge-start passive)
      with end = (edge-end passive)
      for active in (active-edges-ending-at *chart* start)
      when (eq lhs (first (edge-unanalyzed active)))
      do (new-edge :lhs (edge-lhs active)
                   :analyzed (snoc lhs (edge-analyzed active))
                   :unanalyzed (rest (edge-unanalyzed active))
                   :start (edge-start active)
                   :end end)))

(defun postulate (passive)
  (loop with category = (edge-lhs passive)
      with start = (edge-start passive)
      with end = (edge-end passive)
      for rule in (rules-starting-in category)
      do (new-edge :lhs (rule-lhs rule)
                   :analyzed (list category)
                   :unanalyzed (rest (rule-rhs rule))
                   :start start :end end)))

(defun new-edge (&key lhs analyzed unanalyzed start end)
  (push (make-edge :lhs lhs :analyzed analyzed :unanalyzed unanalyzed
                   :start start :end end)
        *agenda*))

(defun store-edge (edge)
  (unless (find-edges :lhs (edge-lhs edge)
                      :analyzed (edge-analyzed edge)
                      :unanalyzed (edge-unanalyzed edge)
                      :start (edge-start edge)
                      :end (edge-end edge))
    (push edge (aref (chart-by-start *chart*)
                     (edge-start edge)))
    (push edge (aref (chart-by-end *chart*)
                     (edge-end edge)))))
  
  
  
                  
;; Aufgabe 2. Ein nichtexhaustiver Parser

;; 2 a)

(defun complete-parse-p (edge &key (goal 's))
  (and (passive-p edge)
       (zerop (edge-start edge))
       (= (edge-end edge) 
          (1- (length (chart-by-start *chart*))))
       (eq (edge-lhs edge) goal)))

;; 2 b) + c)
;; (Musterloesung von Tanja, danke!)

(defun parse (input &optional (start-symbol 's))
  (let ((number-of-vertices (1+ (length input))))
    (setf *chart*
      (make-chart :by-start (make-array number-of-vertices)
                  :by-end (make-array number-of-vertices)))
    (setf *agenda* nil)
    (loop for word in input
        for position from 0
        do (loop for rule in (rules-starting-in word)
               do (new-edge :lhs (rule-lhs rule)
                            :analyzed (list word)
                            :unanalyzed (rest (rule-rhs rule))
                            :start position
                            :end (1+ position))))
    (parse-loop start-symbol)))

(defun parse-loop (start-symbol)
  (loop for edge = (pop *agenda*)
      when (or (not edge)
	;;; Oder die Kante ist gerade schon der vollstaendige Parse. <--
	       (complete-parse-p edge start-symbol))
      return *chart*
             
      ;;; Dies ist die einzige Stelle, an der Kanten tatsaechlich
      ;;; in die Chart eingetragen werden!
      when (store-edge edge)
           
      ;;; Die anderen Funktionen kommunizieren mit
      ;;; der Chart lediglich ueber die Agenda.
      do (cond ((passive-p edge)
                (fundamental4passive edge)
                (postulate edge))
               (T 
                (fundamental4active edge)))))


;; Schmoekaufgabe: Vorzeitiger Abbruch der Verarbeitung bei gueltiger  
;;                 Kante durch einen nichtlokalen Ausgang (throw und catch)

(defun parse (input)
  (let ((number-of-vertices (1+ (length input))))
    (setf *chart*
      (make-chart :by-start (make-array number-of-vertices)
                  :by-end (make-array number-of-vertices)))
    (setf *agenda* nil)
    (loop for word in input
        for position from 0
        do (loop for rule in (rules-starting-in word)
               do (new-edge :lhs (rule-lhs rule)
                            :analyzed (list word)
                            :unanalyzed (rest (rule-rhs rule))
                            :start position
                            :end (1+ position))))
    (parse-loop)))

(defun parse-loop ()
  (catch :handle
    (loop for edge = (pop *agenda*)
        when (not edge)
        return *chart*
        when (store-edge edge)
        do (cond ((passive-p edge)
                  (fundamental4passive edge)
                  (postulate edge))
                 (T (fundamental4active edge))))))

(defun new-edge (&key lhs analyzed unanalyzed start end)
  (let ((edge (make-edge :lhs lhs :analyzed analyzed :unanalyzed unanalyzed
                         :start start :end end)))
    (when (complete-parse-p edge)
      (store-edge edge)
      (throw :handle *chart*))
    (push edge *agenda*)))