|
|
@@ -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))))))
|
|
|
|
|
|
|
