Tony Hasemer & John Domingue - 1989
International Computer Science Series
Addison & Wesley
ISBN 0-201-17579-7
This book was written during the period of standardization of Common Lisp, before the specification of CLOS was included in the standard.
It was addressed to programmers learning Common Lisp, but today beginners will prefer newer books, giving a more complete and modern coverage of Common Lisp and CLOS, post standardization.
Otherwise it is quite pedagogical a book, leading easily the beginner to a basic working knowledge of Common Lisp, and still interesting today for its presentation of:
- a simple rule interpreter,
- a simple object system implemented with closures,
- a simplified version of the Schank and Riesbeck's SAM algorithm (matching events (conceptual dependencies) to story scripts as the engine of story understanding).
The programming style is simplified (making use of a small number of lisp functions). The examples are often uninteresting (meaningless foo bar stuff, instead of taking more real examples). Most examples of macros and in exercises should actually be implemented as functions, and some functions should have been implemented as macros. Notably in the last chapter about the SAM algorithm, a big opportunity to write a couple of nice DSL-like macros was missed.
Here is the modernized code from chapter 14:
;;;; -*- mode:lisp; coding:utf-8 -*-
;;; This file contains the code for chapter 14, modified and
;;; modernized to use CLOS and higher order lisp functions. I
;;; further added some macros notably with-variables and following.
;;; - PJB
(defpackage "SAM"
(:use "CL")
(:shadow "VARIABLE" "DEFCLASS")
(:documentation "A program to implement a simplified version of Schank and Riesbeck's Conceptual Dependencies."))
(in-package "SAM")
(defvar *cd-trace* nil
"A Flag used for tracing. If *cd-trace* is T then cd-trace prints a trace.")
(defun cd-trace-on () (setf *cd-trace* t))
(defun cd-trace-off () (setf *cd-trace* nil))
(defun cd-trace (&rest args)
(when *cd-trace*
(apply (function format) *trace-output* args)))
(defun slots (class)
(mapcar (function clos:slot-definition-name)
(CLOS:CLASS-SLOTS (if (symbolp class)
(find-class class)
class))))
(defgeneric slots-and-values (self)
(:method-combination append)
(:documentation "Return a plist containing the slots name (as keyword)
and values of each slot."))
(defmacro defclass (classname superclasses slots &rest options)
`(progn
(cl:defclass ,classname ,superclasses
,(mapcar (lambda (slot)
(if (atom slot)
(list slot
:initarg (intern (string slot) "KEYWORD")
:initform nil
:accessor slot)
(destructuring-bind (name initform) slot
(list name
:initarg (intern (string name) "KEYWORD")
:initform initform
:accessor name))))
slots)
,@options)
(defmethod slots-and-values append ((self ,classname))
(list ,@(mapcan (lambda (slot)
(if (atom slot)
(list (intern (string slot) "KEYWORD") (list slot 'self))
(destructuring-bind (name initform) slot
(list (intern (string name) "KEYWORD") (list name 'self)))))
slots)))
',classname))
(defgeneric show (self &optional pre-string post-string))
(defmethod show :before ((self t) &optional pre-string post-string)
(declare (ignorable self post-string))
(when pre-string (format t pre-string)))
(defmethod show :after ((self t) &optional pre-string post-string)
(declare (ignorable self pre-string))
(when post-string (format t post-string)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass cd ()
(action actor object from to)
(:documentation "A Conceptual Dependency."))
(defun make-cd (&key action actor object from to)
(make-instance 'cd :action action :actor actor :object object :from from :to to))
(defmethod print-object ((self cd) stream)
(print-unreadable-object (self stream :identity t :type t)
(format stream "~{~S ~S~^ ~}" (slots-and-values self)))
self)
(defmethod show ((self cd) &optional pre-string post-string)
(declare (ignorable pre-string post-string))
(dolist (slot (cd-slots self))
(let ((value (funcall slot self)))
(when value
(show value (format nil "~%~8A " slot))))))
(defmethod cd-slots ((self cd))
(mapcar (function clos:slot-definition-name)
(CLOS:CLASS-DIRECT-SLOTS (find-class 'cd))))
(defmethod script-triggers ((self cd))
'(actor object from to))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass cd-entity ()
(cd-name)
(:documentation "A cd-entity is the most general type of object that can
fill a slot in a conceptual dependency."))
(defmethod print-object ((self cd-entity) stream)
(print-unreadable-object (self stream :identity t :type t)
(format stream "~{~S ~S~^ ~}" (slots-and-values self)))
self)
(defmethod show ((self cd-entity) &optional pre-string post-string)
(declare (ignorable pre-string post-string))
(princ (cd-name self)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass action (cd-entity) ())
(defmacro define-action (name)
`(progn
(defclass ,name (action) ((cd-name ',name)))
(defmethod print-object ((self ,name) stream)
(print-unreadable-object (self stream :type t)
(format stream ":CD-NAME ~A" (cd-name self)))
self)
(defmacro ,name (&key actor object from to)
`(make-instance 'cd :action (make-instance ',',name)
:actor ,actor :object ,object :from ,from :to ,to))))
(define-action atrans)
(define-action ptrans)
(define-action mtrans)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass cd-entity-with-scripts (cd-entity)
(associated-scripts))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass role (cd-entity-with-scripts)
()
(:documentation "Used to fill the actor slot of a Conceptual Dependency"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass setting (cd-entity-with-scripts)
()
(:documentation "Used to fill the from or to slot of a Conceptual Dependency"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass store (setting)
((cd-name 'store)
(associated-scripts 'shopping))
(:documentation "A specialization of setting. Represents any store.
Notice that we have a script associated with this class of object."))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass prop (cd-entity-with-scripts)
()
(:documentation "Used to fill the object slot of a Conceptual Dependency"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass story ()
(cds ; A list of cds
current-script ; The script we are currently trying to match against.
possible-next-events ; The possible next events we are trying to match against.
))
(defmethod show ((self story) &optional pre-string post-string)
(declare (ignorable pre-string post-string))
(dolist (cd (cds self)) (show cd "~%")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass script ()
(events ; The possible events in a story: a list of cds.
variables ; A list of the variables used in the script.
; This is used to clear the script before it is used.
))
(defmethod show ((self script) &optional pre-string post-string)
(declare (ignorable pre-string post-string))
(dolist (event (events self)) (show event "~%")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass variable ()
(cd-name ; The name of the variable.
value ; The value of the variable.
))
(defmethod show ((self variable) &optional pre-string post-string)
(declare (ignorable pre-string post-string))
(format t "~A " (cd-name self))
(if (value self)
(show (value self))
(format t "Unmatched ")))
(defmethod bound? ((self variable))
(value self))
(defmethod clear-value ((self variable))
(setf (value self) nil))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar *scripts* (make-hash-table))
(defun get-script (name) (gethash name *scripts*))
(defun events-script (name) (events (get-script name)))
(defun store-script (name script) (setf (gethash name *scripts*) script))
(defmethod match ((self cd) event)
"Tries to match a cd against an event in a script
by matching the slots in the cd against those in the event."
(every (lambda (slot) (match-cd-slot self slot event)) (cd-slots self)))
(defmethod match-cd-slot ((self cd) slot event)
"Try AND match one of the slots in a cd against the same slot
in an event from a script.
SLOT holds the name of the slot (action from to etc) we want
to compare to."
(let ((e-val (funcall slot event))
(c-val (funcall slot self)))
(cond
((null e-val) t)
((null c-val) t)
((and (typep c-val 'role)
(member (cd-name c-val) '(he she it they))) t)
(t (check-equal e-val c-val)))))
(defmethod check-equal ((self t) story-object)
"Checks that two objects are equal."
(if (cd-name story-object)
(equal (cd-name self) (cd-name story-object))
t))
(defmethod check-equal ((self variable) story-object)
"Checks that a variable can match against a story object."
(if (bound? self)
(check-equal (value self) story-object)
(setf (value self) story-object)))
(defmethod process ((self story))
(clear self)
(dolist (cd (cds self))
(show cd "~2%Input is ")
(process-cd cd self))
(show (get-script (current-script self)) "~%Story done -- script is "))
(defmethod process-cd ((self cd) story)
"Process one of the CD in a story."
(or (find-cd-in-script self story)
(suggest-new-script self story)
(show self "~2%not adding to any script")))
(defmethod clear ((self script))
(dolist (variable (variables self))
(clear-value variable)))
(defmethod clear ((self story))
(setf (current-script self) nil
(possible-next-events self) nil))
(defmethod find-cd-in-script ((self cd) story)
(let ((event (find-if (lambda (event) (match self event))
(possible-next-events story))))
(when event
(show event "~2%matches")
(reset-script-info story event)
event)))
(defmethod reset-script-info ((self story) position)
(setf (possible-next-events self) (cdr (member position (possible-next-events self)))))
(defmethod suggest-new-script ((self cd) story)
(let ((new-script (find-script self)))
(when new-script
(format t "~2%newscript ~A" new-script)
(setf (current-script story) new-script
(possible-next-events story) (events-script new-script))
(find-cd-in-script self story))))
(defmethod find-script ((self cd))
(some (lambda (trigger) (try self trigger)) (script-triggers self)))
(defmethod try ((self cd) slot)
(when (funcall slot self)
(associated-scripts (funcall slot self))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; WITH-VARIABLES Macro
;;; (with-variables (vardecl...) body...)
;;;
;;; vardecl are either a symbol naming the variable,
;;; or a list (name class [cd-name])
;;; When the cd-name is absent, it is either the name itself if it
;;; doesn't start with a question mark, or the name with the prefix
;;; question mark removed.
(defun variable-name (vardecl)
(if (atom vardecl) vardecl (first vardecl)))
(defun variable-cd-name (vardecl)
(if (or (atom vardecl) (null (third vardecl)))
(if (char= (aref (string (variable-name vardecl)) 0) #\?)
(intern (subseq (string (variable-name vardecl)) 1))
(variable-name vardecl))
(third vardecl)))
(defun variable-class (vardecl)
(if (atom vardecl)
'variable
(or (second vardecl) 'variable)))
(defmacro with-variables ((&rest variables) &body body)
`(let ,(mapcar (lambda (vardecl)
`(,(variable-name vardecl)
(make-instance ',(variable-class vardecl)
,@(when (find 'cd-name (slots (find-class (variable-class vardecl))))
`(:cd-name ',(variable-cd-name vardecl))))))
variables)
,@body))
(defmacro goes-to (who where-to &key from)
(let ((vwho (gensym)))
`(let ((,vwho ,who))
(ptrans :actor ,vwho :object ,vwho :from ,from :to ,where-to))))
(defmacro takes (who what &key from)
(let ((vwho (gensym)))
`(let ((,vwho ,who))
(ptrans :actor ,vwho :object ,what :from ,from :to ,vwho))))
(defmacro gives (who what to-whom)
(let ((vwho (gensym)))
`(let ((,vwho ,who))
(atrans :actor ,vwho :object ,what :from ,vwho :to ,to-whom))))
(define-symbol-macro he (make-instance 'role :cd-name 'he))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun initialize-cd-system ()
(with-variables ((money prop)
(script script)
?shopper ?store ?item ?elsewhere)
(store-script 'shopping script)
(setf (variables script) (list ?shopper ?store ?item ?elsewhere)
(events script) (list (goes-to ?shopper ?store)
(takes ?shopper ?item)
(gives ?store ?item ?shopper)
(gives ?shopper money ?store)
(goes-to ?shopper ?elsewhere :from ?store)))))
(defparameter *kite-story*
(with-variables
((jack role)
(woolworths store)
(kite prop)
(home setting)
(story story))
(setf (cds story) (list (goes-to jack woolworths)
(takes he kite)
(goes-to he home)))
story))
(defun demo ()
(clear (get-script 'shopping))
(process *kite-story*))
(initialize-cd-system)
(setf *print-pretty* nil)
(demo)
Sample run:
C/USER[251]> (load "sam.lisp") ;; Loading file sam.lisp ... Input is ACTION PTRANS ACTOR JACK OBJECT JACK TO WOOLWORTHS newscript SHOPPING matches ACTION PTRANS ACTOR SHOPPER JACK OBJECT SHOPPER JACK TO STORE WOOLWORTHS Input is ACTION PTRANS ACTOR HE OBJECT KITE TO HE matches ACTION PTRANS ACTOR SHOPPER JACK OBJECT ITEM KITE TO SHOPPER JACK Input is ACTION PTRANS ACTOR HE OBJECT HE TO HOME matches ACTION PTRANS ACTOR SHOPPER JACK OBJECT SHOPPER JACK FROM STORE WOOLWORTHS TO ELSEWHERE HOME Story done -- script is ACTION PTRANS ACTOR SHOPPER JACK OBJECT SHOPPER JACK TO STORE WOOLWORTHS ACTION PTRANS ACTOR SHOPPER JACK OBJECT ITEM KITE TO SHOPPER JACK ACTION ATRANS ACTOR STORE WOOLWORTHS OBJECT ITEM KITE FROM STORE WOOLWORTHS TO SHOPPER JACK ACTION ATRANS ACTOR SHOPPER JACK OBJECT MONEY FROM SHOPPER JACK TO STORE WOOLWORTHS ACTION PTRANS ACTOR SHOPPER JACK OBJECT SHOPPER JACK FROM STORE WOOLWORTHS TO ELSEWHERE HOME ;; Loaded file sam.lisp T C/USER[252]>
macro example