(in-package "USER")

(defvar *chart*)
(defvar *agenda*)

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

(defun make-rule (lhs rhs)
  (cons lhs rhs))

(defun rule-lhs (rule)
  (first rule))
  
(defun rule-rhs (rule)
  (rest rule))

(defstruct chart by-start by-end)

#||
(defstruct rule
  lhs ;; one fs  
  rhs ;; list of fs
  bindings)
||#

(defun rules-starting-in (category)
  (loop
      for rule in *grammar*
      for unification = (unify4 (fs-structure (first (rule-rhs rule)))
                                (fs-bindings (rule-lhs rule))
                                (fs-structure category)
                                (fs-bindings category))
                                
      unless (bottomp unification) 
      collect (make-rule (make-fs :structure (fs-structure (rule-lhs rule))
                                  :bindings (fs-bindings unification))
                         (cons unification (rest (rule-rhs rule))))))

(defparameter *grammar*
  ;;
  ;; sample grammar one (agreement) from [Shieber 1986], page 25
  ;;
  ;; note that _all_ variables have to be listed in the :bindings slot at the
  ;; mother, including unbound variables (e.g. 2 in the first rule).
  ;;
  (list
   ;;
   ;; S --> NP VP; <S head> = <VP head>; <S head subject> = <NP head>
   ;;
   (list
    (make-fs :structure '((cat . s) (head . 1)) 
             :bindings '(1 ((subj . 2)) 2 nil))
    (make-fs :structure '((cat . np) (head . 2)))
    (make-fs :structure '((cat . vp) (head . 1))))
   ;;
   ;; VP --> V; <VP head> = <V head>
   ;;
   (list
    (make-fs :structure '((cat . vp) (head . 1))
             :bindings '(1 nil))
    (make-fs :structure '((cat . v) (head . 1))))
   ;;
   ;; NP --> Uther
   ;;
   (list
    (make-fs :structure '((cat . np) 
                          (head . ((agr . ((number . sg)
                                           (person . 3rd)))))))
    (make-fs :structure 'uther))
   ;;
   ;; V --> sleeps
   ;;
   (list
    (make-fs :structure '((cat . v)
                          (head . ((subj . ((agr . ((number . sg)
                                                    (person . 3rd)))))))))
    (make-fs :structure 'sleeps))
   ;;
   ;; V --> sleep
   ;;
   (list
    (make-fs :structure '((cat . v)
                          (head . ((subj . ((agr . ((number . pl)))))))))
    (make-fs :structure 'sleep))))

(defstruct edge
  lhs
  analyzed
  unanalyzed
  start
  end)

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

(defun active-edges-ending-at (chart position)
  ;;
  ;; find all active edges ending at .position.
  ;;
  (loop 
      for edge in (aref (chart-by-end chart) position)
      when (edge-unanalyzed edge)
      collect edge))

(defun passive-edges-starting-at (chart position)
  ;;
  ;; find all passive edges starting at .position.
  ;;
  (loop
      for edge in (aref (chart-by-start chart) position)
      unless (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 i from 0 by 1
      for word in input do
        ;;(new-edge :lhs (make-fs :structure word) :start i :end (+ i 1)))
        (new-edge :lhs (make-fs :structure word) :start i :end (+ i 1)))
  (parse-loop))

(defun parse-loop ()
  (loop
      for edge = (pop *agenda*)
      while edge
      when (passive-p edge) do
        (fundamental4passive edge)
        (postulate edge)
      else do
        (fundamental4active edge)
      do (store-edge edge)
;;;        (push edge (aref chart (edge-start edge) 0))
;;;        (push edge (aref chart (edge-end edge) 1))
         finally (return *chart*)))
  
(defun fundamental4active (active)
  (loop with bindings = (fs-bindings (edge-lhs active))
      with next = (first (edge-unanalyzed active))
      for passive in (passive-edges-starting-at *chart* (edge-end active))
      for passive-lhs = (edge-lhs passive)
      for unification = (unify4 (fs-structure next)
                                bindings
                                (fs-structure passive-lhs)
                                (fs-bindings  passive-lhs))
      unless (bottomp unification)
      do ;;(new-edge :active active :daughter unification  :end (edge-end passive))
           (new-edge :bindings (fs-bindings unification)
                  :lhs (edge-lhs active) 
                  :analyzed (snoc unification (edge-analyzed active))
                  :unanalyzed (rest  (edge-unanalyzed active))
                  :start (edge-start active)
                  :end (edge-end passive))))

(defun fundamental4passive (passive)
  ;;
  ;; apply fundamental rule for .passive.: search backwards in chart for a
  ;; suitable active edge that can incorporate .passive. at its position.
  ;;
  (loop with lhs = (edge-lhs passive)
      with lhs-structure = (fs-structure lhs)
      with lhs-bindings = (fs-bindings lhs)
      for active in (active-edges-ending-at *chart* (edge-start passive))
      for unification = (unify4 (fs-structure (first (edge-unanalyzed active)))
                                (fs-bindings (edge-lhs active))
                                lhs-structure
                                lhs-bindings)
      unless (bottomp unification) 
      do ;;(new-edge :active active :daughter unification :end (edge-end passive))
        (new-edge :bindings (fs-bindings unification)
                  :lhs (edge-lhs active)
                  :analyzed (snoc unification (edge-analyzed active))
                  :unanalyzed (rest  (edge-unanalyzed active))
                  :start (edge-start active)
                  :end (edge-end passive))))

(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) ;; rules-starting-in does unification!!
      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 active daughter)
  ;;
  ;; create new edge and add to agenda; accumulate binding sets when appropriate
  ;;
  (let* ((start (or start (edge-start active)))
         (edge (if (and active daughter)
                  ;;
                  ;; new edge resulting from fundametal rule application:
                  ;; .active. incorporates .daughter. as its next daughter
                  ;;
                 (make-edge 
                  :lhs (make-fs :structure (fs-structure (edge-lhs active))
                                :bindings (fs-bindings daughter))
                  :analyzed (snoc daughter (edge-analyzed active))
                  :unanalyzed (rest (edge-unanalyzed active))
                  :start start :end end)
                 (make-edge :lhs lhs 
                            :analyzed analyzed :unanalyzed unanalyzed
                            :start start :end end))))
    (push edge agenda)))

(defun new-edge (&key bindings lhs analyzed unanalyzed start end)
  ;;
  ;; create new edge and add to agenda
  ;;
  (when bindings
    (setf (fs-bindings lhs) bindings))
  (push (make-edge :lhs lhs
                   :analyzed analyzed
                   :unanalyzed unanalyzed
                   :start start
                   :end end)
        *agenda*))
                   
(defun store-edge (edge)
  (push edge (aref (chart-by-start *chart*)
                   (edge-start edge)))
  (push edge (aref (chart-by-end *chart*)
                   (edge-end edge))))