(defun variable-p (x)
“Is x a variable (a symbol beginning with `?’)?”
(and (symbolp x) (equal (elt (symbol-name x) 0) #\?)))
(defun pat-match (pattern input &optional; (bindings no-bindings))
“Match pattern against input in the context of the bindings”
(cond ((eq bindings fail) fail)
((variable-p pattern)
(match-variable pattern input bindings))
((eql pattern input) bindings)
((segment-pattern-p pattern) ; ***
(segment-match pattern input bindings)) ; ***
((and (consp pattern) (consp input))
(pat-match (rest pattern) (rest input)
(pat-match (first pattern) (first input)
bindings)))
(t fail)))
(defun segment-pattern-p (pattern)
“Is this a segment matching pattern: ((?* var) . pat)”
(and (consp pattern)
(starts-with (first pattern) ‘?*)))
;;; ==============================
(defun segment-match (pattern input bindings &optional; (start 0))
“Match the segment pattern ((?* var) . pat) against input.”
(let ((var (second (first pattern)))
(pat (rest pattern)))
(if (null pat)
(match-variable var input bindings)
;; We assume that pat starts with a constant
;; In other words, a pattern can’t have 2 consecutive vars
(let ((pos (position (first pat) input
:start start :test #‘equal)))
(if (null pos)
fail
(let ((b2 (pat-match pat (subseq input pos) bindings)))
;; If this match failed, try another longer one
;; If it worked, check that the variables match
(if (eq b2 fail)
(segment-match pattern input bindings (+ pos 1))
(match-variable var (subseq input 0 pos) b2))))))))
;;; ==============================
(defun segment-match (pattern input bindings &optional; (start 0))
“Match the segment pattern ((?* var) . pat) against input.”
(let ((var (second (first pattern)))
(pat (rest pattern)))
(if (null pat)
(match-variable var input bindings)
;; We assume that pat starts with a constant
;; In other words, a pattern can’t have 2 consecutive vars
(let ((pos (position (first pat) input
:start start :test #‘equal)))
(if (null pos)
fail
(let ((b2 (pat-match
pat (subseq input pos)
(match-variable var (subseq input 0 pos)
bindings))))
;; If this match failed, try another longer one
(if (eq b2 fail)
(segment-match pattern input bindings (+ pos 1))
b2)))))))
;;; ==============================
(defun rule-pattern (rule) (first rule))
(defun rule-responses (rule) (rest rule))
;;; ==============================
(defparameter *eliza-rules*
‘((((?* ?x) hello (?* ?y))
(How do you do. Please state your problem.))
(((?* ?x) I want (?* ?y))
(What would it mean if you got ?y)
(Why do you want ?y) (Suppose you got ?y soon))
(((?* ?x) if (?* ?y))
(Do you really think its likely that ?y) (Do you wish that ?y)
(What do you think about ?y) (Really—if ?y))
(((?* ?x) no (?* ?y))
(Why not?) (You are being a bit negative)
(Are you saying “NO” just to be negative?))
(((?* ?x) I was (?* ?y))
(Were you really?) (Perhaps I already knew you were ?y)
(Why do you tell me you were ?y now?))
(((?* ?x) I feel (?* ?y))
(Do you often feel ?y ?))
(((?* ?x) I felt (?* ?y))
(What other feelings do you have?))))
;;; ==============================
(defun eliza ()
“Respond to user input using pattern matching rules.”
(loop
(print ‘eliza>)
(write (flatten (use-eliza-rules (read))) :pretty t)))
(defun use-eliza-rules (input)
“Find some rule with which to transform the input.”
(some #’(lambda (rule)
(let ((result (pat-match (rule-pattern rule) input)))
(if (not (eq result fail))
(sublis (switch-viewpoint result)
(random-elt (rule-responses rule))))))
*eliza-rules*))
(defun switch-viewpoint (words)
“Change I to you and vice versa, and so on.”
(sublis ‘((I . you) (you . I) (me . you) (am . are))
words))
;;; ==============================
(defun flatten (the-list)
“Append together elements (or lists) in the list.”
(mappend #‘mklist the-list))
(defun mklist (x)
“Return x if it is a list, otherwise (x).”
(if (listp x)
x
(list x)))
(defun mappend (fn the-list)
“Apply fn to each element of list and append the results.”
(apply #‘append (mapcar fn the-list)))
(defun random-elt (choices)
“Choose an element from a list at random.”
(elt choices (random (length choices))))
;;; ==============================
RSS AI Zone
