[paip] Upload Twenty Questions and ELIZA

2 files changed, 389 insertions, 0 deletions

diff --git a/paip/eliza.lisp b/paip/eliza.lisp
new file mode 100644
index 0000000..05c6cfc
--- /dev/null
+++ b/paip/eliza.lisp
@@ -0,0 +1,346 @@
+(defconstant fail nil "Indicates pat-match failure.")
+(defconstant no-bindings '((t . t))
+  "Indicates pat-match success with no variables.")
+
+(defun variable? (x)
+  "Is x a variable (a symbol beginning with '?')?"
+  (and (symbolp x) (equal (char (symbol-name x) 0) #\?)))
+
+(defun get-binding (var bindings)
+  "Find a (var . val) 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 . val) pair to a binding list."
+  (cons (cons var val) (unless (eq bindings no-bindings) bindings)))
+
+(defun match-variable (var input bindings)
+  "Does VAR match input? Update and return bindings."
+  (let ((binding (get-binding var bindings)))
+    (cond ((not binding) (extend-bindings var input bindings))
+          ((equal (binding-val binding) input) bindings)
+          (t fail))))
+
+(defun first-match-pos (pat input start)
+  "Find the first position that pat could possibly match input,
+  starting at position start. If pat is non-constant, simply return start."
+  (cond ((and (atom pat) (not (variable? pat)))
+         (position pat input :start start :test #'equal))
+        ((< start (length input)) start)
+        (t nil)))
+
+(defun segment-match (pattern input bindings &optional (start 0))
+  "Match the segment pattern ((:* var) . pat) against input."
+  (let ((var (cadar pattern))
+        (pat (rest pattern)))
+    (if (null pat)
+        (match-variable var input bindings)
+        ; Assume that a pattern cannot have 2 consecutive vars
+        (let ((binding (get-binding var bindings))
+              (pos (first-match-pos (first pat) input start)))
+          (cond ((null pos) fail)
+                ((null binding)
+                 (let ((b2 (pat-match pat (subseq input pos)
+                                      (extend-bindings var (subseq input 0 pos)
+                                                       bindings))))
+                   (if (eq b2 fail)
+                       (segment-match pattern input bindings (1+ pos))
+                       b2)))
+                ((eq (binding-val binding) (subseq input 0 pos))
+                 (pat-match pat (subseq input pos) bindings))
+                (t fail))))))
+(setf (get :* 'segment-match) 'segment-match)
+
+(defun segment-match-+ (pattern input bindings)
+  "Match one or more elements of input."
+  (segment-match pattern input bindings 1))
+(setf (get :+ 'segment-match) 'segment-match-+)
+
+(defun segment-match-? (pattern input bindings)
+  "Match zero or one element of input."
+  (let ((var (cadar pattern))
+        (pat (rest pattern)))
+    (or (pat-match (cons var pat) input bindings)
+        (pat-match pat input bindings))))
+(setf (get :? 'segment-match) 'segment-match-?)
+
+(defun match-if (pattern input bindings)
+  "Test an arbitrary expression involving variables.
+  The pattern looks like ((:if code) . rest)."
+  (and (eval (sublis bindings (cadar pattern)))
+       (pat-match (rest pattern) input bindings)))
+(setf (get :if 'segment-match) 'match-if)
+
+(defun segment-match-fn (x)
+  "Get the segment-match function for x."
+  (when (keywordp x) (get x 'segment-match)))
+
+(defun segment-pattern? (pattern)
+  "Is this a segment matching pattern: ((:* var) . pat) ?"
+  (and (consp pattern) (consp (first pattern)) (symbolp (caar pattern))
+       (segment-match-fn (caar pattern))))
+
+(defun segment-matcher (pattern input bindings)
+  "Calls the right function for this king of segment pattern."
+  (funcall (segment-match-fn (caar pattern)) pattern input bindings))
+
+(defun match-is (var-and-pred input bindings)
+  "Succeed and bind var if the input satisfies pred,
+  where var-and-pred is the list (var pred)."
+  (let* ((var (first var-and-pred))
+         (pred (second var-and-pred))
+         (new-bindings (pat-match var input bindings)))
+    (if (or (eq new-bindings fail)
+            (not (funcall pred input)))
+        fail
+        new-bindings)))
+(setf (get :is 'single-match) 'match-is)
+
+(defun match-and (patterns input bindings)
+  "Succeed if all the patterns match the input."
+  (cond ((eq bindings fail) fail)
+        ((null patterns) bindings)
+        (t (match-and (rest patterns) input
+                      (pat-match (first patterns) input bindings)))))
+(setf (get :and 'single-match) 'match-and)
+
+(defun match-or (patterns input bindings)
+  "Succeed if any one of the patterns match the input."
+  (if (null patterns)
+      fail
+      (let ((new-bindings (pat-match (first patterns) input bindings)))
+        (if (eq new-bindings fail)
+            (match-or (rest patterns) input bindings)
+            new-bindings))))
+(setf (get :or 'single-match) 'match-or)
+
+(defun match-not (patterns input bindings)
+  "Succeed of none of the patterns match the input.
+  This will never bind any variable."
+  (if (match-or patterns input bindings)
+      fail
+      bindings))
+(setf (get :not 'single-match) 'match-not)
+
+(defun single-match-fn (x)
+  "Get the single-match function for x."
+  (when (keywordp x) (get x 'single-match)))
+
+(defun single-pattern? (pattern)
+  "Is this a single-matching pattern?"
+  (and (consp pattern) (single-match-fn (first pattern))))
+
+(defun single-matcher (pattern input bindings)
+  "Call the right function for this kind of single pattern."
+  (funcall (single-match-fn (first pattern)) (rest pattern) input 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? pattern) (match-variable pattern input bindings))
+        ((eql pattern input) bindings)
+        ((segment-pattern? pattern) (segment-matcher pattern input bindings))
+        ((single-pattern? pattern) (single-matcher pattern input bindings))
+        ((and (consp pattern) (consp input))
+         (pat-match (rest pattern) (rest input)
+                    (pat-match (first pattern) (first input) bindings)))
+        (t fail)))
+
+(defparameter *eliza-rules*
+ '(((?x* hello ?y*)
+    (How do you do? Please state your problem.))
+   ((?x* computer ?y*)
+    (Do computers worry you?) (What do you think about machines?)
+    (Why do you mention computers?)
+    (What do you think machines have to do with your problem?))
+   ((?x* name ?y*)
+    (I am not interested in names.))
+   ((?x* sorry ?y*)
+    (Please don't apnologize.) (Apologies are not necessary.)
+    (What feelings do you have when you apologize?))
+   ((?x* I remember ?y*)
+    (Do you often think of ?y ?)
+    (Does thinking of ?y bring anything else to mind?)
+    (What else do you remember?) (Why do you recall ?y right now?)
+    (What in the present situation reminds you of ?y ?)
+    (What is the connection between you and ?y ?))
+   ((?x* do you remember ?y*)
+    (Did you think I would forget ?y ?)
+    (Why do you think I should recall ?y now ?)
+    (What about ?y ?) (You mentioned ?y))
+   ((?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* I dreamt ?y*)
+    (Really-- ?y) (Have you ever fantasized ?y while you were awake?)
+    (Have you dreamt ?y before?))
+   ((?x* dream about ?y*)
+    (How do you feel about ?y in reality?))
+   ((?x* dream ?y*)
+    (What does this dream suggest to you?) (Do you dream often?)
+    (What persons appear in your dreams?)
+    (Don't you believe that dream has to do with your problem?))
+   ((?x* my mother ?y*)
+    (Who else in your family ?y ?) (Tell me more about your family.))
+   ((?x* my father ?y*)
+    (Your father) (Does he influence you strongly?)
+    (What else comes to mind when you think of your father?))
+
+   ((?x* I want ?y*)
+    (What would it mean if you got ?y)
+    (Why do you want ?y) (Suppose you got ?y soon))
+   ((?x* I am glad ?y*)
+    (How have I helped you to be ?y) (What makes you happy just now)
+    (Can you explain why you are suddenly ?y))
+   ((?x* I am sad ?y*)
+    (I am sorry to hear you are depressed)
+    (I'm sure its not pleasant to be sad))
+   ((?x* are like ?y*)
+    (What resemblance do you see between ?x and ?y))
+   ((?x* is like ?y*)
+    (In what way is it that ?x is like ?y)
+    (What resemblance do you see?)
+    (Could there really be some connection?) (How?))
+   ((?x* alike ?y*)
+    (In what way?) (What similarities are there?))
+   ((?x* same ?y*)
+    (What other connections do you see?))
+
+   ((?x* I was ?y*)
+    (Were you really?) (Perhaps I already knew you were ?y)
+    (Why do you tell me you were ?y now?))
+   ((?x* was I ?y*)
+    (What if you were ?y ?) (Do you think you were ?y ?)
+    (What would it mean if you were ?y))
+   ((?x* I am ?y*)
+    (In what way are you ?y ?) (Do you want to be ?y ?))
+   ((?x* am I ?y*)
+    (Do you believe you are ?y) (Would you want to be ?y)
+    (You wish I would tell you you are ?y)
+    (What would it mean if you were ?y))
+   ((?x* am ?y*)
+    (Why do you say "AM?") (I don't understand that))
+   ((?x* are you ?y*)
+    (Why are you interested in whether I am ?y or not?)
+    (Would you prefer if I weren't ?y)
+    (Perhaps I am ?y in your fantasies))
+   ((?x* you are ?y*)
+    (What makes you think I am ?y ?))
+
+   ((?x* because ?y*)
+    (Is that the real reason?) (What other reasons might there be?)
+    (Does that reason seem to explain anything else?))
+   ((?x* were you ?y*)
+    (Perhaps I was ?y) (What do you think?) (What if I had been ?y))
+   ((?x* I can't ?y*)
+    (Maybe you could ?y now) (What if you could ?y ?))
+   ((?x* I feel ?y*)
+    (Do you often feel ?y ?))
+   ((?x* I felt ?y*)
+    (What other feelings do you have?))
+   ((?x* I ?y* you (:* ?z))
+    (Perhaps in your fantasy we ?y each other))
+   ((?x* why don't you ?y*)
+    (Should you ?y yourself?)
+    (Do you believe I don't ?y) (Perhaps I will ?y in good time))
+   ((?x* yes ?y*)
+    (You seem quite positive) (You are sure) (I understand))
+   ((?x* no ?y*)
+    (Why not?) (You are being a bit negative)
+    (Are you saying "NO" just to be negative?))
+
+   ((?x* someone ?y*)
+    (Can you be more specific?))
+   ((?x* everyone ?y*)
+    (surely not everyone) (Can you think of anyone in particular?)
+    (Who for example?) (You are thinking of a special person))
+   ((?x* always ?y*)
+    (Can you think of a specific example) (When?)
+    (What incident are you thinking of?) (Really-- always))
+   ((?x* what ?y*)
+    (Why do you ask?) (Does that question interest you?)
+    (What is it you really want to know?) (What do you think?)
+    (What comes to your mind when you ask that?))
+   ((?x* perhaps ?y*)
+    (You do not seem quite certain))
+   ((?x* are ?y*)
+    (Did you think they might not be ?y)
+    (Possibly they are ?y))
+   ((?x*)
+    (Tell me more about you) ; to be replaced with info from dialog
+    (Very interesting) (I am not sure if I understand you fully.)
+    (What does that suggest to you?) (Please continue) (Go on)
+    (Do you feel strongly about discussing such things?))))
+
+(defun expand-pat-match-abbrev (pattern)
+  "Expand out all pattern matching abbreviations in pattern."
+  (cond ((and (symbolp pattern) (get pattern 'expand-pat-match-abbrev)))
+        ((atom pattern) pattern)
+        (t (mapcar #'expand-pat-match-abbrev pattern))))
+
+(defun pat-match-abbrev (symbol expansion)
+  "Define symbol as a macro standing for a pat-match pattern."
+  (setf (get symbol 'expand-pat-match-abbrev)
+        (expand-pat-match-abbrev expansion)))
+
+(pat-match-abbrev '?x* '(:* ?x))
+(pat-match-abbrev '?y* '(:* ?y))
+
+(defun rule-pattern (rule) (expand-pat-match-abbrev (first rule)))
+(defun rule-responses (rule) (rest rule))
+
+(defun random-elt (seq)
+  "Pick a random element out of a sequence."
+  (elt seq (random (length seq))))
+
+(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)
+              (let* ((response (random-elt (rule-responses rule)))
+                     (var (find-if #'variable? response))
+                     (pats (sublis '((I . you) (you . I) (me . you) (am . are))
+                                   result)))
+                (unless (null var)
+                  (let ((memory (lookup var pats)))
+                    (unless (null memory)
+                      (setf (cadar (last *eliza-rules*))
+                            `(Tell me more about ,memory)))))
+                (sublis pats response)))))
+        *eliza-rules*))
+
+(defun flatten (the-list)
+  "Append together elements (or lists) in the list."
+  (unless (null the-list)
+    (let ((a (first the-list)))
+      (if (and (listp a) (not (eq (first a) 'quote)))
+          (append a (flatten (rest the-list)))
+          (cons a (flatten (rest the-list)))))))
+
+(defun split (string)
+  "Split string into symbols that can be inserted anywhere in a sentence."
+  (read-from-string
+   (format nil "(~a)"
+           (substitute-if #\space (lambda (c) (find c ".!?")) string))))
+
+(defun eliza ()
+  "Respond to user input using pattern matching rules."
+  (loop
+     (print 'eliza>)
+     (let ((input (split (read-line))))
+       (if (equal input '(bye))
+           (return)
+           (mapc (lambda (x) (if (and (listp x) (eq (first x) 'quote))
+                                 (write x :pretty t)
+                                 (format t " ~a" x)))
+                 (flatten (use-eliza-rules input)))))))
diff --git a/paip/twenty-questions.lisp b/paip/twenty-questions.lisp
new file mode 100644
index 0000000..fed4997
--- /dev/null
+++ b/paip/twenty-questions.lisp
@@ -0,0 +1,43 @@
+; Because case doesn't like quotes
+(defconstant yes 'yes)
+(defconstant no 'no)
+(defconstant it 'it)
+
+(defun random-elt (list)
+  "Choose a random element from the given list."
+  (if (null list)
+      nil
+      (elt list (random (length list)))))
+
+(defun query-if (question &optional (pred (lambda (answer) t)))
+  "Ask until receive a proper answer."
+  (princ question)
+  (let ((answer (read)))
+    (if (funcall pred answer)
+        answer
+        (query-if question pred))))
+
+(defun twenty-questions (db n)
+  "Guess what's in the user's mind and return the updated database."
+  (if (or (null db) (= n 0))
+      (let ((answer (query-if "What is it? ")))
+        (if (assoc answer db)
+            db
+            (cons (list answer) db)))
+      (let* ((guess (random-elt db))
+             (word (first guess))
+             (remain (remove guess db)))
+        (case (query-if (format nil "Is it a kind of ~a? " word)
+                        (lambda (answer) (member answer (list yes no it))))
+          (yes (cons (cons word (twenty-questions (rest guess) (1- n))) remain))
+          (no (cons guess (twenty-questions remain (1- n))))
+          (it db)))))
+
+(defun play (&optional (db nil))
+  "Play again and again."
+  (let ((n (query-if "How many questions can be asked? " #'integerp)))
+    (if (>= n 0)
+        (play (twenty-questions db n))
+        (print db))))
+
+(play)