;;;; -*- Mode: Lisp; Syntax: Common-Lisp -*-
;;;; Code from Paradigms of AI Programming
;;;; Copyright (c) 1991 Peter Norvig
;;;; syntax3.lisp: The PSG natural language parser,
;;;; with handling of preferences as described in Section 19.6.
(defvar *grammar* "The grammar used by GENERATE.")
(defstruct (rule (:type list)
(:constructor rule (lhs -> rhs &optional sem score)))
lhs -> rhs sem score)
(defstruct (tree (:type list) (:include rule) (:copier nil)
(:constructor new-tree (lhs sem score rhs))))
(defun use (grammar)
"Switch to a new grammar."
(clear-memoize 'rules-starting-with)
(clear-memoize 'lexical-rules)
(length (setf *grammar*
(mapcar #'(lambda (r) (apply #'rule r))
grammar))))
(defstruct (parse) "A parse tree and a remainder." tree rem)
(defun parse-lhs (parse) (tree-lhs (parse-tree parse)))
(defun lexical-rules (word)
"Return a list of rules with word on the right hand side."
(find-all word *grammar* :key #'rule-rhs :test #'equal))
(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 first-or-nil (x)
"The first element of x if it is a list; else nil."
(if (consp x) (first x) nil))
(defun complete-parses (parses)
"Those parses that are complete (have no remainder)."
(find-all-if #'null parses :key #'parse-rem))
(defun append1 (items item)
"Add item to end of list of items."
(append items (list item)))
(defun parser (words)
"Return all complete parses of a list of words."
(clear-memoize 'parse) ;***
(mapcar #'parse-tree (complete-parses (parse words))))
(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 apply-semantics (tree)
"For terminal nodes, just fetch the semantics.
Otherwise, apply the sem function to its constituents."
(if (terminal-tree-p tree)
(tree-sem tree)
(setf (tree-sem tree)
(apply (tree-sem tree)
(mapcar #'tree-sem (tree-rhs tree))))))
(defun terminal-tree-p (tree)
"Does this tree have a single word on the rhs?"
(and (length=1 (tree-rhs tree))
(atom (first (tree-rhs tree)))))
(defun parse (words)
"Bottom-up parse, returning all parses of any prefix of words.
This version has semantics and preference scores."
(unless (null words)
(mapcan #'(lambda (rule)
(extend-parse (rule-lhs rule) (rule-sem rule)
(rule-score rule) (list (first words)) ;***
(rest words) nil))
(lexical-rules (first words)))))
(defun extend-parse (lhs sem score rhs rem needed) ;***
"Look for the categories needed to complete the parse.
This version has semantics and preference scores."
(if (null needed)
;; If nothing is needed, return this parse and upward extensions,
;; unless the semantics fails
(let ((parse (make-parse :tree (new-tree lhs sem score rhs) ;***
:rem rem)))
(unless (null (apply-semantics (parse-tree parse)))
(apply-scorer (parse-tree parse)) ;***
(cons parse
(mapcan
#'(lambda (rule)
(extend-parse
(rule-lhs rule) (rule-sem rule)
(rule-score rule) (list (parse-tree parse)) ;***
rem (rest (rule-rhs rule))))
(rules-starting-with lhs)))))
;; otherwise try to extend rightward
(mapcan
#'(lambda (p)
(if (eq (parse-lhs p) (first needed))
(extend-parse lhs sem score
(append1 rhs (parse-tree p)) ;***
(parse-rem p) (rest needed))))
(parse rem))))
(defun apply-scorer (tree)
"Compute the score for this tree."
(let ((score (or (tree-score tree) 0)))
(setf (tree-score tree)
(if (terminal-tree-p tree)
score
;; Add up the constituent's scores,
;; along with the tree's score
(+ (sum (tree-rhs tree) #'tree-score-or-0)
(if (numberp score)
score
(or (apply score (tree-rhs tree)) 0)))))))
(defun tree-score-or-0 (tree)
(if (numberp (tree-score tree)) (tree-score tree) 0))
(defun all-parses (words)
(format t "~%Score Semantics~25T~a" words)
(format t "~%===== =========~25T============================~%")
(loop for tree in (sort (parser words) #'> :key #'tree-score)
do (format t "~5,1f ~9a~25T~a~%" (tree-score tree) (tree-sem tree)
(bracketing tree)))
(values))
(defun bracketing (tree)
"Extract the terminals, bracketed with parens."
(cond ((atom tree) tree)
((length=1 (tree-rhs tree))
(bracketing (first (tree-rhs tree))))
(t (mapcar #'bracketing (tree-rhs tree)))))
(defun meaning (words &optional (tie-breaker #'query-user))
"Choose the single top-ranking meaning for the words."
(let* ((trees (sort (parser words) #'> :key #'tree-score))
(best-score (if trees (tree-score (first trees)) 0))
(best-trees (delete best-score trees
:key #'tree-score :test-not #'eql))
(best-sems (delete-duplicates (mapcar #'tree-sem best-trees)
:test #'equal)))
(case (length best-sems)
(0 (format t "~&Sorry, I didn't understand that.") nil)
(1 (first best-sems))
(t (funcall tie-breaker best-sems)))))
(defun query-user (choices &optional
(header-str "~&Please pick one:")
(footer-str "~&Your choice? "))
"Ask user to make a choice."
(format *query-io* header-str)
(loop for choice in choices for i from 1 do
(format *query-io* "~&~3d: ~a" i choice))
(format *query-io* footer-str)
(nth (- (read) 1) choices))
(memoize 'lexical-rules)
(memoize 'rules-starting-with)
(memoize 'parse :test #'eq)
;;;; Grammar
(defparameter *grammar7*
'((NP -> (NP CONJ NP) infix-funcall infix-scorer)
(NP -> (N P N) infix-funcall infix-scorer)
(NP -> (N) list)
(NP -> ([ NP ]) arg2)
(NP -> (NP ADJ) rev-funcall rev-scorer)
(NP -> (NP OP N) infix-funcall)
(N -> (D) identity)
(N -> (N D) 10*N+D)
(P -> to integers prefer<)
([ -> [ [)
(] -> ] ])
(OP -> repeat repeat)
(CONJ -> and append prefer-disjoint)
(CONJ -> without ordered-set-difference prefer-subset)
(ADJ -> reversed reverse inv-span)
(ADJ -> shuffled permute prefer-not-singleton)
(D -> 1 1) (D -> 2 2) (D -> 3 3) (D -> 4 4) (D -> 5 5)
(D -> 6 6) (D -> 7 7) (D -> 8 8) (D -> 9 9) (D -> 0 0)))
(defun infix-funcall (arg1 function arg2)
"Apply the function to the two arguments"
(funcall function arg1 arg2))
(defun 10*N+D (n d) (+ (* 10 N) D))
(defun prefer< (x y) (if (>= (sem x) (sem y)) -1))
(defun prefer-disjoint (x y) (if (intersection (sem x) (sem y)) -1))
(defun prefer-subset (x y)
(+ (inv-span x) (if (subsetp (sem y) (sem x)) 0 -3)))
(defun prefer-not-singleton (x)
(+ (inv-span x) (if (< (length (sem x)) 2) -4 0)))
(defun infix-scorer (arg1 scorer arg2)
(funcall (tree-score scorer) arg1 arg2))
(defun arg2 (a1 a2 &rest a-n) (declare (ignore a1 a-n)) a2)
(defun rev-scorer (arg scorer) (funcall (tree-score scorer) arg))
(defun rev-funcall (arg function) (funcall function arg))
(defun repeat (list n)
"Append list n times."
(if (= n 0)
nil
(append list (repeat list (- n 1)))))
(defun span-length (tree)
"How many words are in tree?"
(if (terminal-tree-p tree) 1
(sum (tree-rhs tree) #'span-length)))
(defun inv-span (tree) (/ 1 (span-length tree)))
(defun sem (tree) (tree-sem tree))
(defun integers (start end)
"A list of all the integers in the range [start...end] inclusive.
This version allows start > end."
(cond ((< start end) (cons start (integers (+ start 1) end)))
((> start end) (cons start (integers (- start 1) end)))
(t (list start))))
(defun sum (numbers &optional fn)
"Sum the numbers, or sum (mapcar fn numbers)."
(if fn
(loop for x in numbers sum (funcall fn x))
(loop for x in numbers sum x)))
(defun permute (bag)
"Return a random permutation of the given input list."
(if (null bag)
nil
(let ((e (random-elt bag)))
(cons e (permute (remove e bag :count 1 :test #'eq))))))