Eliza pattern matcher

chatikbot.asd

@@ -20,4 +20,5 @@
                (:file "forecast")
                (:file "vk")
                (:file "finance")
+               (:file "eliza")
                (:file "chatikbot")))

eliza.lisp

@@ -0,0 +1,164 @@
+(in-package #:chatikbot)
+
+(defparameter *eliza-rules*
+  '((((?* ?x) hello (?* ?y))
+     (How do you do. Please state your problem.))
+    (((?* ?x) want (?* ?y))
+     (What would it mean if ?x got ?y)
+     (Why do ?x want ?y)
+     (Suppose ?x 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?))
+    (((?* x))
+     (Why would you say that?))))
+
+(defconstant fail nil "Indicates pat-match failure")
+
+;; (defconstant no-bindings '((t . t))
+;;   "Indicates pat-match success, with no variables.")
+
+(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."
+  (cons (cons var val) bindings))
+
+(defun match-variable (var input bindings)
+  "Does VAR match input? Uses (or updates) and returns bindings."
+  (let ((binding (get-binding var bindings)))
+    (cond ((not binding) (extend-bindings var input bindings))
+          ((equal input (binding-val binding)) bindings)
+          (t fail))))
+
+(defun variable-p (x)
+  "Is x a variable (a symbol beginning with '?')?"
+  (and (symbolp x) (equal (char (symbol-name x) 0) #\?)))
+
+(defun starts-with (list x)
+  "Is this a list whose first element is x?"
+  (and (consp list)
+       (eql (first list) x)))
+
+(defun segment-pattern-p (pattern)
+  "Is this a segment matching pattern: ((?* var) . pat)"
+  (and (consp pattern)
+       (starts-with (first pattern) '?*)))
+
+(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-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 punctuation-p (char)
+  (find char ".,;:'!?#-()\\\""))
+
+(defun read-from-string-no-punct (input)
+  "Read from an input string, ignoring punctuation."
+  (read-from-string
+   (concatenate 'string
+                "("
+                (substitute-if #\space #'punctuation-p input)
+                ")")))
+
+(defun print-with-spaces (list)
+  (string-downcase (format nil "~{~a~^ ~}" list)))
+
+(defun mappend (fn &rest lists)
+  "Apply fn to each element of lists and append the results."
+  (apply #'append (apply #'mapcar fn lists)))
+
+(defun random-elt (choices)
+  "Choose an element from a list at random."
+  (elt choices (random (length choices))))
+
+(defun mklist (x)
+  "Return x if it is a list otherwise (x)."
+  (if (listp x)
+      (flatten x)
+      (list x)))
+
+(defun flatten (the-list)
+  "Append together elements (or lists) in the list."
+  (mappend #'mklist the-list))
+
+(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 rule-pattern (rule)
+  (first rule))
+(defun rule-responses (rule)
+  (rest rule))
+
+(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)))
+              (unless (eq result fail)
+                (sublis (switch-viewpoint result)
+                        (random-elt (rule-responses rule))))))
+        *eliza-rules*))
+
+(defun eliza (input)
+  (let ((response (use-eliza-rules
+                   (read-from-string-no-punct input))))
+    (when response
+      (print-with-spaces (flatten response)))))
+
+