;;;; Chart Parser with Unification Augmentation
(defstructure grammar
"A grammar for a chart parser has rules indexed by word and LHS."
(lexicon nil)
(rules nil)
(start-symbol 'S)
(categories-for (make-hash-table :test #'eq))
(rewrites-for (make-hash-table :test #'eq))
(unknown-word-cats '(noun verb adjective adverb)))
(defvar *grammar* nil
"The currently used grammar. Defining a new grammar changes this, or you
can set it yourself.")
(defun rule-lhs (rule) "The left hand side." (first rule))
(defun rule-rhs (rule) "The right-hand side." (nthcdr 2 rule))
(defstructure chart
"A chart has a vector that holds the edges that end at vertex i."
;; A more efficient implementation would store other things
(ends-at #()))
(defstructure (edge)
"An edge represents a dotted rule instance. In the edge [i, j, L -> F . R],
i is the start, j is the end, L is the lhs, (F) is found, and (R) remains."
;; The FOUND slot is stored in reverse order, so you can just push on it.
start end lhs found remains bindings)
;;;; Chart Parsing Algorithm
(defun chart-parse (words &optional (*grammar* *grammar*))
"See if the string of words can be parsed by the grammar. (See page 702.)"
(let ((chart (make-chart :ends-at (make-array (+ 1 (length words))
:initial-element nil))))
(add-edge (edge 0 0 'S* nil (list (grammar-start-symbol *grammar*)))
chart 'initializer)
(for v = 0 to (- (length words) 1) do
(scanner v (elt words v) chart))
chart))
(defun scanner (j word chart)
"Add edges everywhere WORD is expected."
(for each cat in (categories-for word *grammar*) do
(dprint "scanner:" cat (elt (chart-ends-at chart) j))
(when (member cat (elt (chart-ends-at chart) j)
:test #'unify :key #'edge-expects)
(add-edge (edge j (+ j 1) cat (list word) nil) chart 'scanner))))
(defun predictor (edge chart)
"Add edges saying what we expect to see here."
(for each rule in (rewrites-for (op (edge-expects edge)) *grammar*) do
(add-edge (edge (edge-end edge) (edge-end edge)
(rule-lhs rule)
nil (rule-rhs rule))
chart 'predictor)))
(defun completer (edge chart)
"Use this edge to extend any edges in the chart."
(for each old-edge in (elt (chart-ends-at chart) (edge-start edge)) do
(let ((b (unify (edge-lhs edge) (edge-expects old-edge)
(edge-bindings old-edge))))
(when b
(add-edge (edge (edge-start old-edge) (edge-end edge)
(edge-lhs old-edge)
(cons edge (edge-found old-edge))
(rest (edge-remains old-edge))
b)
chart 'completer)))))
(defun add-edge (edge chart &optional reason)
"Put edge into chart, and complete or predict as appropriate."
(unless (member edge (elt (chart-ends-at chart) (edge-end edge))
:test #'edge-equal)
(when (handle-augmentation *grammar* edge)
(push edge (elt (chart-ends-at chart) (edge-end edge)))
(dprint reason edge);; debugging output (as in Figure 23.4, [p 700])
(if (complete? edge)
(completer edge chart)
(predictor edge chart)))))
;;;; Other Top-Level Functions
(defun chart-parses (words &optional (*grammar* *grammar*))
"See if the string of words can be parsed by the grammar. If it can, look
into the chart and pull out complete spanning strings."
(mapcar #'edge->tree (spanning-edges (chart-parse words *grammar*))))
(defun meanings (words &optional (*grammar* *grammar*))
"Parse words, then pick out the semantics of each parse.
Assumes the semantics will be the last element of the LHS."
(delete-duplicates
(mapcar #'(lambda (edge) (last1 (mklist (edge-lhs edge))))
(spanning-edges (chart-parse words *grammar*)))
:test #'equal))
;;;; Auxiliary Functions
(defun spanning-edges (chart)
"Find the edges that span the chart and form the start symbol."
(remove-if-not
#'(lambda (e)
(and (complete? e)
(eql (edge-start e) 0)
(eq (op (edge-lhs e)) (grammar-start-symbol *grammar*))))
(elt (chart-ends-at chart) (- (length (chart-ends-at chart)) 1))))
(defun edge->tree (edge)
"Convert an edge into a parse tree by including its FOUND parts."
(cond ((edge-p edge)
(cons (edge-lhs edge)
(mapcar #'edge->tree (reverse (edge-found edge)))))
(t edge)))
(defun edge (start end lhs found remains &optional (bindings +no-bindings+))
"Construct a new edge."
(make-edge :start start :end end :lhs lhs :found found :remains remains
:bindings bindings))
(defun grammar (&rest args)
"Take a list of rules, index them to form a grammar for chart-parse."
(setf *grammar* (apply #'make-grammar args))
(for each rule in (grammar-lexicon *grammar*) do
(for each word in (rule-rhs rule) do
;; Rule [A -> word] means index A under categories-for word
;; Replace (A $w) with (A word)
(let ((lhs (subst-bindings `(($w . ,word)) (rule-lhs rule))))
(push lhs (gethash word (grammar-categories-for *grammar*))))))
(for each rule in (grammar-rules *grammar*) do
;; Rule [A -> B C] indexed under rewrites for A
(push rule (gethash (op (rule-lhs rule))
(grammar-rewrites-for *grammar*))))
*grammar*)
(defun rewrites-for (lhs grammar)
"Find the rules in grammar with LHS as the left hand side."
(gethash (op lhs) (grammar-rewrites-for grammar)))
(defun categories-for (word grammar)
"Find what categories this word can be.
For unknown words, use the grammar's unknown-word-cats field"
(or (gethash word (grammar-categories-for grammar))
(subst word '$w (grammar-unknown-word-cats grammar))))
(defun edge-expects (edge)
"What does the edge expect next in order to be extended?"
(first (edge-remains edge)))
(defun lhs-op (edge)
"Left hand side of an edge's category"
(if (edge-p edge) (op (edge-lhs edge)) edge))
(defun complete? (edge)
"An edge is complete if it has no remaining constituents."
(null (edge-remains edge)))
(defun edge-equal (edge1 edge2)
"Are two edges the same, up to renaming of the parts with variables?"
(and (eql (edge-start edge1) (edge-start edge2))
(eql (edge-end edge1) (edge-end edge2))
(eql (op (edge-lhs edge1)) (op (edge-lhs edge2)))
(renaming? (edge-found edge1) (edge-found edge2))
(renaming? (edge-remains edge1) (edge-remains edge2))))
(defmethod handle-augmentation ((grammar grammar) edge)
"There are two things to do: (1) When we start a new edge, rename vars.
(2) When an edge is complete, substitute the bindings into the lhs."
(when (null (edge-found edge)) ;; (1) rename vars
(let ((new (rename-variables (cons (edge-lhs edge) (edge-remains edge)))))
(setf (edge-lhs edge) (first new)
(edge-remains edge) (rest new))))
(when (complete? edge) ;; (2) substitute bindings into lhs
(setf (edge-lhs edge)
(subst-bindings (edge-bindings edge) (edge-lhs edge))))
(edge-bindings edge))
(defmethod print-structure ((e edge) stream)
(format stream "[~D, ~D, ~A ->~{ ~A~} .~{ ~A~}]"
(edge-start e) (edge-end e) (lhs-op e)
(nreverse (mapcar #'lhs-op (edge-found e)))
(mapcar #'lhs-op (edge-remains e))))