Eliza Program - Newer Syntax
;;; SHRINK.LSP -- a simple conversational program after ELIZA.
;;; (C) Copyright 1995 by Steven L. Tanimoto.
;;; This program is described in Chapter 3 ("Productions Systems
;;; and Pattern Matching") of
;;; "The Elements of Artificial Intelligence Using Common Lisp," 2nd ed.,
;;; published by W. H. Freeman, 41 Madison Ave., New York, NY 10010.
;;; Permission is granted for noncommercial use and modification of
;;; this program, provided that this copyright notice is retained
;;; and followed by a notice of any modifications made to the program.
;;; Requires the functions MATCH and VAL defined in MATCH.CL.
(defun shrink ()
"SHRINK is the top-level function."
(let ((wword-count 0) ; counter for question words.
(punt-count 0) ; counter for punt responses.
b ; holds bindings after matching.
s ; holds the mapped input sentence.
)
(format t "WELCOME TO MY SOFA!~%")
(format t "PLEASE ENCLOSE YOUR INPUT IN PARENTHESES.~%")
(loop (setq s (you-me-map (read)))
(terpri)
(cond ((match '(bye) s)
(return 'goodbye) )
((setf b (match '(you are (* x)) s))
(incf wword-count)
(print-s (append '(please tell me)
(list (wword wword-count))
'(you are)
(val 'x b) )) )
((setf b (match '(you have (* x)) s))
(print-q (append '(how long have you had) (val 'x b) )) )
((match '(you feel (* x)) s)
(format t "I SOMETIMES FEEL THE SAME WAY.~%") )
((match '(because (* x)) s)
(format t "IS THAT REALLY THE REASON.~%") )
((match nil s)
(format t "PLEASE SAY SOMETHING!~%") )
((setf b (match '(yes (* x)) s))
(print-q (append '(how can you be so sure) (val 'x b) )) )
((setf b (match '(me are (* x)) s))
(print-s (append '(oh yeah i am) (val 'x b) )) )
((setf b (match '((verbp v) (* x)) s))
(print-q (append '(why do you want me to)
(list (val 'v b)) (val 'x b) ) ) )
((setf b (match '((wpred w)(* x)) s))
(print-s (append '(you tell me)(list (val 'w b))) ) )
((match '(do me think (* x)) s)
(format t "I THINK YOU SHOULD ANSWER THAT YOURSELF.~%") )
((setf b (match '((dpred w) me (* x)) s))
(print-s (append '(perhaps i)(list (val 'w b)) (val 'x b) ) ) )
((member 'dream s)
(format t "FOR DREAM ANALYSIS SEE FREUD.~%") )
((member 'love s)
(format t "ALL IS FAIR IN LOVE AND WAR.~%") )
((member 'no s)
(format t "DONT BE SO NEGATIVE.~%") )
((member 'maybe s)
(format t "BE MORE DECISIVE!~%") )
((member 'you s)(print-s s))
(t (incf punt-count)
(print-s (punt punt-count)) ) ) ) ) )
(defun print-s (message)
"Print message list as a sentence."
(printl (butlast message))
; Print the last element followed by a period:
(format t "~a." (first (last message)))
(terpri) )
(defun print-q (message)
"Print message list as a question."
(printl (butlast message))
; Print the last element followed by a question mark:
(format t "~a?" (first (last message)))
(terpri) )
(defun printl (message)
"Prints a list without the surrounding parens."
; Print each element except the last followed by a space:
(mapcar #'(lambda (txt) (format t "~a " txt))
message) )
;;; WWORD returns one of four question words,
;;; WWORD-COUNT must be an integer.
(defun wword (wword-count)
"Returns the ith question word where i = WWORD-COUNT mod 4."
(nth (mod wword-count 4)
'(when why where how) ) )
(defun wpred (w)
"Returns T if W is one of the question words."
(member w '(why where when what which how)) )
(defun dpred (w)
"Returns T is W is an auxiliary verb."
(member w '(do can should would)) )
(defun punt (punt-count)
"Returns one from a list of default responses."
(nth (mod punt-count 6)
'((please go on)
(tell me more)
(i see)
(what does that indicate)
(but why be concerned about it)
(just tell me how you feel) ) ) )
(defun you-me (w)
"Changes a word from 1st to 2nd person or vice-versa."
(cond
((eql w 'i) 'you) ((eql w 'me) 'you) ((eql w 'you) 'me)
((eql w 'my) 'your) ((eql w 'your) 'my)
((eql w 'yours) 'mine) ((eql w 'mine) 'yours)
((eql w 'am) 'are) (t w) ) )
(defun you-me-map (lst)
"Applies YOU-ME to a whole sentence or phrase."
(mapcar (function you-me) lst) )
(defun verbp (w)
"Return T if W is one of these known verbs."
(member w '(go have be try eat take help make get jump
write type fill put turn compute
think drink blink crash crunch add) ) )