(in-package "USER")

(defvar *trace* nil)
(setq *trace* T)

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

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

(defmacro flag (variable bool)
  `(setq ,variable
	 (or ,variable ,bool)))

(defparameter *grammar*
  '((S NP VP) 
    (NP Det N) (NP NP PP)
    (VP V) (VP V NP) (VP VP PP)
    (PP P NP)
    (Det the) (Det a)
    (P with)
    (Adj fat) (Adj cute)
    (N Adj N) (N woman) (N man) (N ball) (N scope)
    (V snored) (V saw)))

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

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

(defun rules-starting-in (category)
  (find! category *grammar* :key #'(lambda (rule)
                                     (first (rule-rhs rule)))))

;Conditional newline. Without any modifiers, the directive ~_ is equivalent to
;(pprint-newline :linear). The directive ~@_ is equivalent to (pprint-newline
;:miser). The directive ~:_ is equivalent to (pprint-newline :fill). The
;directive ~:@_ is equivalent to (pprint-newline     :mandatory). 


(defun my-print-edge  (edge stream level &rest args)
  (format stream "~_[(~S,~S):   ~S -> ~{~S~^ ~} . ~{~S~^ ~}]"
	  (edge-start edge)
	  (edge-span edge)
	  (edge-lhs edge)
	  (edge-analyzed edge)
	  (edge-unanalyzed edge)))

(defstruct (edge (:print-function my-print-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)
  (let* ((input-length (length input))
	 (chart (init-chart input input-length)))
    (parse-loop chart input-length)))

(defun init-chart (input length)
  (loop with chart = (make-array length)
	for word in input
	for i from 0
	do (loop for rule in (rules-starting-in word)
		 do (push (make-edge :lhs (rule-lhs rule)
                                :analyzed (list word) 
                                :unanalyzed (rest (rule-rhs rule))
                                :start i :span 1)
			  (aref chart i)))
	finally (return chart)))

(defun parse-loop (chart length)
  (loop with chart-changed
	do (loop initially (setq chart-changed NIL)
		 for i from 0 below length
		 do (loop for edge in (aref chart i)
			  do (flag chart-changed
				   (cond ((passive-p edge)
					  (postulate edge chart))
					 (;; useful active edge:
					  (< (+ i (edge-span edge)) length)
					  (fundamental-rule edge chart))))))
	while chart-changed
	finally (return chart)))

(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))
         (chart-changed NIL))
    (loop for passive in (passive-edges-at chart (+ start span))
	  when (eq (edge-lhs passive) (first unanalyzed))
	  do (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))
		 (setq chart-changed T)))
	  finally (return chart-changed))))

(defun postulate (passive chart)
  (let ((category (edge-lhs passive))
        (start (edge-start passive))
        (span (edge-span passive))
        (chart-changed NIL))
    (loop for rule in (rules-starting-in category)
	  for lhs = (rule-lhs rule)
	  for rhs = (rule-rhs rule)
	  for edge = (make-edge :lhs lhs
				:analyzed (list category)
				:unanalyzed (rest rhs)
				:start start :span span)
	  unless (member edge (aref chart start) :test #'edge=)
          do (push edge (aref chart start))
	     (setq chart-changed T)
	  finally (return chart-changed))))