Some eliza rules

chatikbot.asd

@@ -5,8 +5,9 @@
   :license "MIT"
   :depends-on (#:alexandria
                #:bordeaux-threads
-               #:cl-oauth
+;;               #:cl-oauth
                #:clon
+               #:dexador
                #:flexi-streams
                #:local-time
                #:log4cl
@@ -15,10 +16,11 @@
   :serial t
   :components ((:file "package")
                (:file "utils")
-               (:file "twitter")
+;;               (:file "twitter")
                (:file "telegram")
                (:file "forecast")
                (:file "vk")
                (:file "finance")
+               (:file "patmatch")
                (:file "eliza")
                (:file "chatikbot")))

chatikbot.lisp

@@ -20,24 +20,6 @@
                    (aget "update_id" update)))
      do (handle-message (aget "message" update))))
 
-(defvar *responses*
-  '((:text . "И чё?")
-    (:text . "Сам-то понял?")
-    (:text . "Ну хуй знает")
-    (:text . "Бля...")
-    (:text . "В душе не ебу")
-    (:text . "Мне похуй")
-    (:text . "Eбаный ты нахуй")
-    (:text . "Отъебись")
-    (:sticker . "BQADAgADFAADOoERAAGoLKS_Vgs6GgI") ;; ЭЭ епта Чо
-    (:sticker . "BQADAgADGQADOoERAAFDXJisD4fClgI") ;; Ну чё ты несёшь
-    (:sticker . "BQADAgADFwADOoERAAHCw-fBiFjACgI") ;; А у меня собака, я не могу
-    (:sticker . "BQADAgADEgADOoERAAFtU3uF9HvtQgI") ;; Бухнём?
-    (:sticker . "BQADBAADQAEAAnscSQABqWydSKTnASoC")) ;; Trollface
-  "Unknown command respond strings")
-
-(defun random-choice (messages)
-  (nth (random (length messages)) messages))
 
 (defun send-response (chat-id response &optional reply-id)
   (if (consp response)
@@ -47,21 +29,20 @@
       (telegram-send-message chat-id response :reply-to reply-id)))
 
 (defun send-dont-understand (chat-id &optional text reply-id)
-  (if (and text (zerop (random 5)))
-      ;; Reply to "пидор" with "сам пидор" in 20%
-      (telegram-send-message chat-id
-                             (format nil "Сам ~A"
-                                     (replace-all
-                                      (if (equal (char text 0) #\/)
-                                          (subseq text 1)
-                                          text)
-                                      "@chatikbot" ""))
-                             :reply-to reply-id)
-      ;; Reply with predefined responses
-      (send-response chat-id (random-choice *responses*))))
+  (let ((resp (eliza text)))
+    (log:info text resp)
+    (when resp
+      (send-response chat-id resp reply-id))))
 
 (defvar *chat-locations* nil "ALIST of chat->location")
 
+(defun preprocess-input (text)
+  (when text
+    (let ((first-word (subseq text 0 (position #\Space text))))
+      (if (equal first-word "@chatikbot")
+          (preprocess-input (subseq text 11))
+          (replace-all text "@chatikbot" "ты")))))
+
 (defun handle-message (message)
   (let ((id (aget "message_id" message))
         (chat-id (aget "id" (aget "chat" message)))
@@ -83,30 +64,14 @@
               (:weather (handle-cmd-weather chat-id id args))
               (:hourly (handle-cmd-weather chat-id id '("hourly")))
               (:daily (handle-cmd-weather chat-id id '("daily")))
-	      (:rates (handle-cmd-rates chat-id id args))
-              (:help (handle-cmd-help chat-id id args))
+              (:rates (handle-cmd-rates chat-id id args))
               (otherwise (handle-admin-cmd chat-id text cmd args))))
-          (send-dont-understand chat-id text)))
+          (send-dont-understand chat-id (preprocess-input text))))
     (when location
       (push (cons chat-id location) *chat-locations*)
       (telegram-send-message chat-id "Взял на карандаш"))
     (when sticker
-      ;; Save incoming stickers in 20% of the cases if it's not already there
-      (if (and (or (find chat-id *admins*)
-                   (zerop (random 5)))
-               (not (find sticker *responses* :key #'cdr :test #'equal)))
-          (progn
-            (push (cons :sticker sticker) *responses*)
-            (telegram-send-message chat-id "Припомним"))
-          (send-dont-understand chat-id)))))
-
-(defun %admin-send-responses (chat-id)
-  (telegram-send-message
-   chat-id
-   (format nil "~{~A~^~%~}"
-           (loop for (type . text) in *responses*
-              for i = 1 then (1+ i)
-              collect (format nil "~D. ~A [~A]" i text type)))))
+      (send-dont-understand chat-id))))
 
 (defmacro handling-errors (&body body)
   `(handler-case (progn ,@body)
@@ -132,15 +97,6 @@
 (defun handle-admin-cmd (chat-id text cmd args)
   (if (find chat-id *admins*)
       (case cmd
-        (:addresponse
-         (push (cons :text (format nil "~{~A~^ ~}" args)) *responses*)
-         (%admin-send-responses chat-id))
-        (:showresponses
-         (%admin-send-responses chat-id))
-        (:delresponse
-         (setf *responses* (delete (nth (1- (parse-integer (car args))) *responses*) *responses*))
-         (%admin-send-responses chat-id))
-        (:sendresponse (send-response chat-id (nth (1- (parse-integer (car args))) *responses*)))
         (:eval (telegram-send-message chat-id (rep (format nil "~{~A~^ ~}" args))))
         (otherwise (send-dont-understand chat-id text)))
       (send-dont-understand chat-id text)))
@@ -168,7 +124,6 @@
     (format nil "~A~%~A" (aget "text" post) url)))
 
 (defun process-latest-akb ()
-  (log:info "Getting latest AKBs")
   (handler-case
       (dolist (post (reverse (aget "items" (vk-wall-get :domain +akb-vk-domain+
                                                         :count *akb-max-count*))))
@@ -200,14 +155,6 @@
         (error (e) (log:error e))))))
 
 
-(defvar *help-responses*
-  (list "Сам себе помоги, нахуй!" "Вот заняться мне больше нечем" "Нахуй пошел!"
-        "Хэлп, ай нид самбади, хелп нот джаст энибади" "Отъебись"))
-
-(defun handle-cmd-help (chat-id message-id args)
-  (log:info "handle-cmd-help" chat-id message-id args)
-  (telegram-send-message chat-id (random-choice *help-responses*)))
-
 (defun handle-cmd-rates (chat-id message-id args)
   (log:info "handle-cmd-rates" chat-id message-id args)
   (let ((rates (get-rates)))
@@ -244,5 +191,6 @@
    :thread t)
   (bordeaux-threads:make-thread
    (lambda ()
+     (in-package #:chatikbot)
      (loop-with-error-backoff #'process-updates))
    :name "process-updates"))

eliza.lisp

@@ -1,108 +1,44 @@
 (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)))
+(defparameter *fuck-off*
+  '((отъебись) (мне похуй) (ебаный ты нахуй!))
+  "Fuck-off responses")
 
-(defun extend-bindings (var val bindings)
-  "Add a (var . value) pair to a binding list."
-  (cons (cons var val) bindings))
+(defun goto-p (input) (member input '(иди пошел вали)))
+(defun prep-p (i) (member i '(в на)))
+(defun dirty-p (i) (member i '(лох хуй мудак ебалай)))
 
-(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)))
+(defparameter *eliza-rules*
+  `(
+    (((?is ?g goto-p) (?is ?prep prep-p) (?* ?х))
+     (а самому не пойти ?prep ?х ?) (мамку свою посылай ?prep ?х) (покомандуй тут еще) ,@*fuck-off*)
+    (((?is ?g goto-p) (?* ?x))
+     (сам иди ?x) (покомандуй тут еще) ,@*fuck-off*)
+    (((?* ?a) (?or норм хорошо молодец) (?* ?b))
+     (спасибо) (я старался) (как себе) ,@*fuck-off*)
+    (((?or спасибо) (?* ?x))
+     (всё для вас) (пожалуйста) (на здоровье) ,@*fuck-off*)
+    (((?* ?x) (?or уровень) (?* ?y))
+     (в жопу себе его засунь) (хуюровень) ,@*fuck-off*)
+    (((?* ?a) (?is ?x ,(lambda (i) (search "ХАХА" (symbol-name i)))) (?* ?b))
+     (очень смешно) (клоунов тут нашел?) (посмейся мне еще) ,@*fuck-off*)
+    (((?* ?a) (?or ты бот) (?* ?x))
+     (сам ?x) (сам ты ?x) (а по ебалу?) (сейчас мы разберемся кто еще тут ?x) ,@*fuck-off*)
+    (((?* x))
+     (:text . "И чё?")
+     (:text . "Сам-то понял?")
+     (:text . "Ну хуй знает")
+     (:text . "Бля...")
+     (:text . "В душе не ебу")
+     (:text . "Мне похуй")
+     (:text . "Eбаный ты нахуй")
+     (:text . "Отъебись")
+     (:sticker . "BQADAgADFAADOoERAAGoLKS_Vgs6GgI") ;; ЭЭ епта Чо
+     (:sticker . "BQADAgADGQADOoERAAFDXJisD4fClgI") ;; Ну чё ты несёшь
+     (:sticker . "BQADAgADFwADOoERAAHCw-fBiFjACgI") ;; А у меня собака, я не могу
+     (:sticker . "BQADAgADEgADOoERAAFtU3uF9HvtQgI") ;; Бухнём?
+     (:sticker . "BQADBAADQAEAAnscSQABqWydSKTnASoC"))))
 
-(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 ".,;:'!?#-()\\\""))
@@ -116,7 +52,7 @@
                 ")")))
 
 (defun print-with-spaces (list)
-  (string-downcase (format nil "~{~a~^ ~}" list)))
+  (format nil "~@(~{~a~^ ~}~)" list))
 
 (defun mappend (fn &rest lists)
   "Apply fn to each element of lists and append the results."
@@ -132,27 +68,23 @@
 
 (defun switch-viewpoint (words)
   "Change I to you and vice versa, and so on."
-  (sublis '((I . you) (you . I) (me . you) (am . are))
+  (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*))
+  (rule-based-translator input *eliza-rules*
+                         :action #'(lambda (bindings responses)
+                                     (sublis (switch-viewpoint bindings)
+                                             (random-elt responses)))))
 
 (defun eliza (input)
   (let ((response (use-eliza-rules
                    (read-from-string-no-punct input))))
     (when response
-      (print-with-spaces (flatten response)))))
+      (if (keywordp (first response))
+          response
+          (print-with-spaces (flatten response))))))
 
 

patmatch.lisp

@@ -10,6 +10,31 @@
 
 (in-package #:chatikbot)
 
+(defconstant fail nil "Indicates pat-match failure")
+
+(defparameter 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 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 (elt (symbol-name x) 0) #\?)))
@@ -168,14 +193,14 @@
         (t (cons (expand-pat-match-abbrev (first pat))
                  (expand-pat-match-abbrev (rest pat))))))
 
-(defun rule-based-translator 
-       (input rules &key (matcher 'pat-match) 
-        (rule-if #'first) (rule-then #'rest) (action #'sublis))
+(defun rule-based-translator
+    (input rules &key (matcher 'pat-match)
+                   (rule-if #'first) (rule-then #'rest) (action #'sublis))
   "Find the first rule in rules that matches input,
   and apply the action to that rule."
-  (some 
+  (some
     #'(lambda (rule)
-        (let ((result (funcall matcher (funcall rule-if rule) 
+        (let ((result (funcall matcher (funcall rule-if rule)
                                input)))
           (if (not (eq result fail))
               (funcall action result (funcall rule-then rule)))))