Skip to content


Subversion checkout URL

You can clone with
Download ZIP
Fetching contributors…
Cannot retrieve contributors at this time
123 lines (102 sloc) 4.06 KB
;;;; -*- Mode: Lisp; Syntax: Common-Lisp -*-
;;;; Code from Paradigms of AI Programming
;;;; Copyright (c) 1991 Peter Norvig
;;;; File syntax1.lisp: The PSG-based natural language parser.
;;;; This is the more efficient version of the non-semantic parser,
;;;; which uses the memoized functions in Section 19.3 and handles
;;;; unknown words as described in Section 19.4.
;;;; Remember to use a grammar, as in (use *grammar4*)
(defvar *grammar* nil "The grammar used by GENERATE.")
(defstruct (rule (:type list)) lhs -> rhs)
(defstruct (parse) "A parse tree and a remainder." tree rem)
;; Trees are of the form: (lhs . rhs)
(defun new-tree (cat rhs) (cons cat rhs))
(defun tree-lhs (tree) (first tree))
(defun tree-rhs (tree) (rest tree))
(defun parse-lhs (parse) (tree-lhs (parse-tree parse)))
(defparameter *open-categories* '(N V A Name)
"Categories to consider for unknown words")
(defun lexical-rules (word)
"Return a list of rules with word on the right hand side."
(or (find-all word *grammar* :key #'rule-rhs :test #'equal)
(mapcar #'(lambda (cat) `(,cat -> ,word)) *open-categories*)))
(defun rules-starting-with (cat)
"Return a list of rules where cat starts the rhs."
(find-all cat *grammar*
:key #'(lambda (rule) (first-or-nil (rule-rhs rule)))))
(defun complete-parses (parses)
"Those parses that are complete (have no remainder)."
(find-all-if #'null parses :key #'parse-rem))
(defun parse (words)
"Bottom-up parse, returning all parses of any prefix of words."
(unless (null words)
(mapcan #'(lambda (rule)
(extend-parse (rule-lhs rule) (list (first words))
(rest words) nil))
(lexical-rules (first words)))))
(defun extend-parse (lhs rhs rem needed)
"Look for the categories needed to complete the parse."
(if (null needed)
;; If nothing needed, return parse and upward extensions
(let ((parse (make-parse :tree (new-tree lhs rhs) :rem rem)))
(cons parse
#'(lambda (rule)
(extend-parse (rule-lhs rule)
(list (parse-tree parse))
rem (rest (rule-rhs rule))))
(rules-starting-with lhs))))
;; otherwise try to extend rightward
#'(lambda (p)
(if (eq (parse-lhs p) (first needed))
(extend-parse lhs (append1 rhs (parse-tree p))
(parse-rem p) (rest needed))))
(parse rem))))
(defun append1 (items item)
"Add item to end of list of items."
(append items (list item)))
(memoize 'lexical-rules)
(memoize 'rules-starting-with)
(memoize 'parse :test #'eq)
(defun parser (words)
"Return all complete parses of a list of words."
(clear-memoize 'parse) ;***
(mapcar #'parse-tree (complete-parses (parse words))))
(defun use (grammar)
"Switch to a new grammar."
(clear-memoize 'rules-starting-with)
(clear-memoize 'lexical-rules)
(length (setf *grammar* grammar)))
;;; Grammars
(defparameter *grammar3*
'((Sentence -> (NP VP))
(NP -> (Art Noun))
(VP -> (Verb NP))
(Art -> the) (Art -> a)
(Noun -> man) (Noun -> ball) (Noun -> woman) (Noun -> table)
(Noun -> noun) (Noun -> verb)
(Verb -> hit) (Verb -> took) (Verb -> saw) (Verb -> liked)))
(defparameter *grammar4*
'((S -> (NP VP))
(NP -> (D N))
(NP -> (D A+ N))
(NP -> (NP PP))
(NP -> (Pro))
(NP -> (Name))
(VP -> (V NP))
(VP -> (V))
(VP -> (VP PP))
(PP -> (P NP))
(A+ -> (A))
(A+ -> (A A+))
(Pro -> I) (Pro -> you) (Pro -> he) (Pro -> she)
(Pro -> it) (Pro -> me) (Pro -> him) (Pro -> her)
(Name -> John) (Name -> Mary)
(A -> big) (A -> little) (A -> old) (A -> young)
(A -> blue) (A -> green) (A -> orange) (A -> perspicuous)
(D -> the) (D -> a) (D -> an)
(N -> man) (N -> ball) (N -> woman) (N -> table) (N -> orange)
(N -> saw) (N -> saws) (N -> noun) (N -> verb)
(P -> with) (P -> for) (P -> at) (P -> on) (P -> by) (P -> of) (P -> in)
(V -> hit) (V -> took) (V -> saw) (V -> liked) (V -> saws)))
Jump to Line
Something went wrong with that request. Please try again.