Common Lisp code for the Eliza chatbot

#| This is the Peter Norvig (slightly adapted) code for the vanilla Eliza chatbot. For the rules see here. For an example of the program in action, see here.

This code should run if copied and pasted into a Common Lisp system, provided the rules file is also available and the 'Load' command below suitably amended - or just copy and paste the rules at the end of this file.

---
|#

;;; Eliza:  February 7th 2017 - February 10th 2017
;;;
;;; From Peter Norvig's book: Chapter 5
;;; "Paradigms of Artificial Intelligence Programming"
;;;
;;; Pattern matching, patterns and dialogue manager
;;;
;;; Posted:
; http://interweave-consulting.blogspot.co.uk/2017/02/common-lisp-code-for-eliza-chatbot.html
;;;
;;;  Reminder: (how to load and access files)
;;;
; (load  "C:\\Users\\HP Owner\\Google Drive\\Lisp\\Prog-Eliza\\Eliza.lisp")

(load  "C:\\Users\\HP Owner\\Google Drive\\Lisp\\Prog-Eliza\\Eliza-Rules.lisp")


;;; ---Patterns and input ---
;;;
;;; A pattern is a list of:-  segment-variable-lists, symbols or variables.
;;; An input is a list of symbols (without variables).
;;;
;;; Test pattern match in simple cases
;;;
; (setf *inp1* '(I need a vacation))
; (setf *pat1* '(I need a ?x))
; (pat-match *pat1* *inp1)
;
; ... when matched, should return a binding '((?X . vacation))
;
; (setf *inp2* '(Shadow and I need a holiday))
; (setf *pat2* '((?* ?U) need (?* ?V)) )
;
;;; --- Binding constants ---

(defconstant +fail+ nil "Indicates pat-match failure.")

(defconstant +no-bindings+ '((t . t))
"Indicates pat-match success but with no variables.")

(defconstant +example-bindings+
   '((?X . (the cat)) (?Y . (sat on)) (?Z the mat))  )

;;; --- BINDINGS a list of (var . value) dotted pairs ---
;;;
; a list of the form (?* ?variable-name) denotes a segment variable.
; Eg:  (pat-match '((?* ?p) need (?* ?X)) '(Mr Hulot and I need a vacation))
; gives ((?P MR HULOT AND I) (?X A VACATION)) .. as the (dotted pair) binding.

(defun get-binding (var bindings)
  "Find a (variable . value) pair in a binding list."
  (assoc var bindings))

(defun binding-val (binding)
  "Get the value part of a single binding."
  (cdr binding))

(defun lookup (var bindings)
  "Get the value part (for var) from a binding list."
  (binding-val (get-binding var bindings) ))

(defun extend-bindings (var val bindings)
  "Add a (var . value) pair to a binding list."
  (acons var val bindings))

(defun variable-p (x)    ; SYMBOL -> Bool
  "Is x a variable, a symbol beginning with '?' "
  (and (symbolp x) (equal (char (symbol-name x) 0) #\? )))
 
(defun starts-with (list x)  ; SYMBOL-list x SYMBOL -> Bool
  "Is this a non-empty list whose first element is x?"
  (and (consp list) (eql (car list) x)) )
 
;;; --- Pattern Matcher ---

; pat-match: PATTERN x INPUT x BINDINGS -> BINDINGS

(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+) ))
;
; segment-pattern-p: PATTERN -> bool   (if first element of PATTERN is seg-var

(defun segment-pattern-p (pattern)
  "pattern a non-empty-list, 1st element a segment-matching-pattern: ((?* var) . pat)"
  (and (consp pattern)
       (starts-with (first pattern) '?* )))

(defun match-variable (var input bindings) ; VAR x SYMBOL(-list) x BINDINGS -> BINDINGS
  "Does VAR match input? Uses (or updates) and returns bindings."
  (let ((var+val (get-binding var bindings)))
    (cond ((not var+val) (extend-bindings var input bindings))  ; add new binding
          ((equal (cdr var+val) input) bindings)                             ; do nothing
          (t +fail+ )                                                                          ; clash with existing
   )) )

; (setf b +EXAMPLE-BINDINGS+)
; (match-variable '?X '(the cat) b)
; (match-variable '?U 'dog  b)
; (match-variable '?X 'dog  b)     ; returns NIL

; segment-match: PATTERN x INPUT x BINDINGS x NAT -> BINDINGS

(defun segment-match (pattern input bindings &optional (start1 0))
"Match the pattern = ((?* var) . pat) against input - returns BINDINGS"
  (let ((var (second (first pattern)) )     ; we know ?* is the first
        (pat (rest pattern )) )
     (cond ((null pat) (match-variable var input bindings))   ; return this binding

           ;; We assume that pat, the rest of pattern, starts with a constant
           ;; In other words, a pattern can't have 2 consecutive vars
           ;; pos is index into input, the symbol matching next item in pattern
           (t (let ((pos (position (car pat) input :start start1 :test #'equalp)))
                   (if (null pos)
                         +fail+                          ; pattern-input mismatch
                         (let* ((input-rest (subseq input pos))
                                (input-prefix (subseq input 0 pos)) ; bind to var!
                                (b1 (match-variable var input-prefix bindings)) ;OK
                                (b2 (pat-match pat input-rest b1)))
                           ;; If b2 failed , try another longer one
                             (if (eq b2 +fail+)
                                  (segment-match pattern input bindings (+ pos 1) )
                                  b2) ) ) ) ) ) ) )

; (setf pattern '((?* ?W) sat on the ?V))
; (setf input '(The cat sat on sat on the mat))
; (segment-match pattern input +no-bindings+)

#| Note on segment-match (from Norvig, chapter 5.3)

In writing segment-match, the important question is how much of the input the
segment variable should match. One answer is to look at the next element of the
pattern (the one after the segment variable) and see at what position it occurs in the
input. If it doesn't occur, the total pattern can never match, and we should fail.

If it does occur, call its position pos. We will want to match the variable against the
initial part of the input, up to pos. But first we have to see if the rest of the pattern
matches the rest of the input. This is done by a recursive call to pat-match. Let the
result of this recursive call be named b2. If b2 succeeds, then we go ahead and match
the segment variable against the initial subsequence.

The tricky part is when b2 fails. We don't want to give up completely, because
it may be that if the segment variable matched a longer subsequence of the input,
then the rest of the pattern would match the rest of the input. So what we want is to
try segment-match again, but forcing it to consider a longer match for the variable.

This is done by introducing an optional parameter, start1, which is initially 0 and is
increased with each failure. Notice that this policy rules out the possibility of any
kind of variable following a segment variable.
|#

;;; --- test data for pattern matching ---

; (pat-match '(i need a ?X) '(i really need a vacation)) ; NIL
; (pat-match '(this is easy) '(this is easy))            ; ((T . T))
; (pat-match '(?X is ?X) '((2 + 2) is 4))                ; NIL
; (pat-match '(?X is ?X) '((2 + 2) is (2 + 2 )))       ; ((?X 2 + 2)) = ((?X . (2 + 2)))
; (pat-match '(?P need . ?X) '(i need a long vacation)) ;((?X A LONG VACATION) (?P . I))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; --- RULES ---
;;;
;;; Here's an example of a rule: input-matching-pattern + one or more response-patterns
;;;
;;; (  ((?* ?X) I want (?* ?Y ))                  ; Pattern part
;;;       (What would it mean if you got ?Y)      ; Three possible responses
;;;       (Why do you want ?Y)
;;;       (Suppose you got ?Y soon?)   )
;;;
;;; -----------------------------------------------------------------------------------
;;; --- ELIZA top level ---
;;;
;;; Note on output - recall (terpri) prints a newline.
;;; print is just like prin1 (or princ - human readable)
;;; except that the printed representation of object
;;; is preceded by a newline and followed by a space.
;;;
;;; pprint is just like print except that the trailing space is omitted
;;; and object is printed with the *print-pretty* flag non-nil - pretty output.

(defun eliza (rules)
  "Respond to user input using pattern matching rules. 'bye' to terminate"
  (princ "Hello, I am your doctor. Please type bye to finish.")
  (terpri)
  (terpri)
  (princ "Please type your first name then return> ")
  (setf *user-name* (car (read-line-no-punct)))              ; substitutes $name$ in response
  (loop
   (print 'speak>)
   (let ((input (read-line-no-punct)))
      (if (equalp input (list 'bye)) (progn (print 'Goodbye) (return))
          (let* ((raw-response (use-eliza-rules input rules))
                 (response (flatten1 raw-response))
                 (out  (substitute *user-name* '$name$ response :test #'equalp)) )
            (pprint out) ) ) ) )  )

; Test:  (eliza +eliza-rules+)
; Test:  (eliza +eliza-rules-extended+)

(defun read-line-no-punct ()
  "Read an input line terminated by 'return', ignore punctuation, -> symbol-list"
  (read-from-string
   (concatenate 'string "(" (substitute-if #\space #'punctuation-p (read-line))
                ")")  ))

(defun punctuation-p (char) (find char ".,;:'!?#-()\\\""))

(defun use-eliza-rules (input rules)
  "Find some rule with which to transform the input ... ."
  (some #'(lambda (rule)
            (let ((bindings (pat-match (rule-pattern rule) input)))
              (if (not (eql bindings +fail+) )
                  (sublis (switch-viewpoint bindings)
                          (random-elt (rule-responses rule )) ))))
        rules))

(defun rule-pattern (rule) (car rule))     ; The pattern to match the input

(defun rule-responses (rule) (cdr rule))   ; the list of (remaining) response-patterns

(defun switch-viewpoint (bindings)
  "Change I to you and vice versa, and so on in bindings."
  (sublis '((I . you)  (you . I)    (me . you)
            (am . are) (was . were) (are . am)) bindings ))

(defun flatten1 (l)
  "Append together elements (or lists) in the list l (not lists of lists)."
  (mappend #'mklist  l) )

(defun mklist (x)
  "Return x if it is a list, otherwise (x)."
  (if (listp x) x (list x)))

(defun mappend (fn l)   ; (* -> **) x *-list -> <flat list>
  "Apply fn to each element of list l and append the results."
  (apply #'append (mapcar fn l) ))

(defun random-elt (choices)
  "Choose an element from a list at random."
  (elt choices (random (length choices )) ))


;;; --- End ---