[Cl-irc-cvs] CVS update: cl-irc/example/cliki.lisp
Brian Mastenbrook
bmastenbrook at common-lisp.net
Tue Jun 22 18:21:05 UTC 2004
Update of /project/cl-irc/cvsroot/cl-irc/example
In directory common-lisp.net:/home/bmastenbrook/cl-irc/example
Modified Files:
cliki.lisp
Log Message:
Memos and better aliases oh my!
Date: Tue Jun 22 11:21:05 2004
Author: bmastenbrook
Index: cl-irc/example/cliki.lisp
diff -u cl-irc/example/cliki.lisp:1.10 cl-irc/example/cliki.lisp:1.11
--- cl-irc/example/cliki.lisp:1.10 Thu Jun 17 10:40:35 2004
+++ cl-irc/example/cliki.lisp Tue Jun 22 11:21:05 2004
@@ -1,4 +1,4 @@
-;;;; $Id: cliki.lisp,v 1.10 2004/06/17 17:40:35 bmastenbrook Exp $
+;;;; $Id: cliki.lisp,v 1.11 2004/06/22 18:21:05 bmastenbrook Exp $
;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/cliki.lisp,v $
;;;; cliki.lisp - CLiki as an infobot; only works on SBCL.
@@ -12,32 +12,115 @@
:*respond-to-general-hellos* :shut-up :un-shut-up))
(in-package :cliki)
-
(defvar *small-definitions* nil)
+(defvar *aliases* nil)
+
+(defun forget (term-or-alias)
+ (setf *small-definitions* (remove term-or-alias *small-definitions* :test #'string-equal :key #'car))
+ (setf *aliases* (remove term-or-alias *aliases* :test #'string-equal :key #'car))
+ (write-small-definitions))
+
+(defun fix-aliases ()
+ (setf *small-definitions*
+ (loop for defn in *small-definitions*
+ if (stringp (cdr defn))
+ collect defn
+ else do (push (cons (first defn) (second defn))
+ *aliases*))))
+
(defun read-small-definitions ()
(setf *small-definitions* nil)
+ (setf *aliases* nil)
(with-open-file (sd-file "sd.lisp-expr" :direction :input :if-does-not-exist nil)
(when sd-file
- (block nil
- (loop (let ((defn (read sd-file nil)))
- (if defn (push defn *small-definitions*)
- (return (setf *small-definitions* (nreverse *small-definitions*))))))))))
+ (loop for defn = (read sd-file nil)
+ if defn do (ecase (car defn)
+ (:sd (push (cdr defn) *small-definitions*))
+ (:alias (push (cdr defn) *aliases*)))
+ else return *small-definitions*))))
(defun write-small-definitions ()
(with-open-file (sd-file "sd.lisp-expr" :direction :output :if-exists :supersede)
- (mapc #'(lambda (defn)
- (prin1 defn sd-file)
- (format sd-file "~%")) *small-definitions*)))
+ (mapc #'(lambda (db)
+ (mapc #'(lambda (defn)
+ (prin1 (cons (car db) defn) sd-file)
+ (format sd-file "~%")) (reverse (cdr db))))
+ (list (cons :sd *small-definitions*)
+ (cons :alias *aliases*)))))
-(defun write-top-definition ()
+(defun write-top-definition (&key (of *small-definitions*) (type :sd))
(with-open-file (sd-file "sd.lisp-expr" :direction :output :if-exists :append)
- (prin1 (car *small-definitions*) sd-file)
+ (prin1 (cons type (car of)) sd-file)
(format sd-file "~%")))
(defun add-small-definition (term defn)
(push (cons term defn) *small-definitions*)
- (write-small-definitions))
+ (write-top-definition))
+
+(defun add-alias (term defn)
+ (push (cons term defn) *aliases*)
+ (write-top-definition :of *aliases* :type :alias))
+
+(defvar *lookup-depth* 0)
+
+(defvar *followed-aliases* nil)
+
+(defun alias-string-equal (orig candidate)
+ (unless (member candidate *followed-aliases* :test #'string-equal)
+ (string-equal orig candidate)))
+
+(defun small-definition-lookup (text)
+ (cdr (assoc text *small-definitions* :test #'string-equal)))
+
+(defun alias-lookup (text)
+ (let ((alias (or (cdr (assoc text *aliases* :test #'alias-string-equal))
+ (car (rassoc text *aliases* :test #'alias-string-equal)))))
+ (if alias
+ (let ((*lookup-depth* (1+ *lookup-depth*))
+ (*followed-aliases* (cons alias *followed-aliases*)))
+ (if (> *lookup-depth* 5)
+ "Too many recursive lookups."
+ (cliki-lookup alias))))))
+
+(defclass memo ()
+ ((from :accessor memo-from :initarg :from)
+ (to :accessor memo-to :initarg :to)
+ (contents :accessor memo-contents :initarg :contents)))
+
+(defun without-non-alphanumeric (string)
+ (with-output-to-string (s)
+ (loop for char across string
+ if (alphanumericp char)
+ do (princ char s))))
+
+(defvar *pending-memos* nil)
+
+(defun memo-alias-test (orig candidate)
+ (or (string-equal orig (car candidate))
+ (string-equal orig (cdr candidate))
+ (string-equal orig (without-non-alphanumeric (car candidate)))
+ (string-equal orig (without-non-alphanumeric (cdr candidate)))))
+
+(defun take-care-of-memos (channel user &key (original-user user) (no-alias nil))
+ (let ((found (find (without-non-alphanumeric user) *pending-memos* :test #'string-equal :key #'memo-to :from-end t)))
+ (if found
+ (progn
+ (setf *pending-memos* (remove found *pending-memos*))
+ (privmsg *cliki-connection* channel (format nil "~A, memo from ~A: ~A" original-user (memo-from found) (memo-contents found)))
+ (take-care-of-memos channel user :original-user original-user))
+ (if (not no-alias)
+ (let ((alias (find (without-non-alphanumeric user)
+ *aliases*
+ :test #'memo-alias-test)))
+ (if alias
+ (take-care-of-memos channel (cdr alias) :original-user original-user :no-alias t)))))))
+
+(defun add-memo (from to contents)
+ (push (make-instance 'memo :from from
+ :to (without-non-alphanumeric to)
+ :contents contents)
+ *pending-memos*))
(defun url-port (url)
(assert (string-equal url "http://" :end1 7))
@@ -138,8 +221,8 @@
(setf first-line (regex-replace-all "<[^>]+>" first-line ""))
(setf first-line (regex-replace-all "^(([^.]|\\.\\S)+)\\.\\s+.*$" first-line "\\1."))
(setf first-line (regex-replace-all "(\\s)\\s+" first-line "\\1"))
- (setf first-line (regex-replace-all "^\\s(.+)$" first-line "\\1"))
- (when (scan "^([^.]|\\.\\S)+\\.$" first-line)
+ (setf first-line (regex-replace-all "^\\s*(.+\\S)\\s*$" first-line "\\1"))
+ (when (scan "^([^.]|\\.\\S)+[.?!]$" first-line)
(setf first-line (concatenate 'string first-line " " cliki-url))
(return-from cliki-return first-line))))
(format nil "No definition was found in the first 5 lines of ~A" cliki-url)))
@@ -155,7 +238,6 @@
(defun un-shut-up ()
(setf (irc:client-stream *cliki-connection*) *trace-output*))
-
(defmacro aif (test conseq &optional (else nil))
`(let ((it ,test))
(if it ,conseq
@@ -173,48 +255,69 @@
(let ((first-pass (regex-replace-all "^(\\s*)([^?]+)(\\?*)$" term-with-question "\\2")))
(setf first-pass (regex-replace-all "\\s\\s+" first-pass ""))
(setf first-pass (regex-replace-all "\\s*$" first-pass ""))
- (if (scan "^add \"([^\"]+)\" as: (.+)$" first-pass)
- (let ((term (regex-replace "^add \"([^\"]+)\" .*$" first-pass "\\1"))
- (defn (regex-replace "^add \"[^\"]+\" as: (.+)$" first-pass "\\1")))
- (add-small-definition term defn)
- "OK, done.")
- (if (scan "^alias \"([^\"]+)\" as: (.+)$" first-pass)
- (let ((term (regex-replace "^alias \"([^\"]+)\" .*$" first-pass "\\1"))
- (defn (regex-replace "^alias \"[^\"]+\" as: (.+)$" first-pass "\\1")))
- (add-small-definition term (list defn))
- "OK, done.")
- (progn
- (setf first-pass (regex-replace-all "(:|/|\\\\|\\#)" first-pass ""))
- (when (and (scan "^(?i)lisppaste(\\s|!|\\?|\\.|$)*" first-pass)
- (find-package :lisppaste)
- channel
- (> (length channel) 0)
- (char= (elt channel 0) #\#)
- (funcall (intern "SAY-HELP" :lisppaste)
- channel))
- (return-from cliki-lookup nil))
- (or
- (if (string-equal first-pass "help") *cliki-bot-help*)
- (if (scan "^(?i)hello(\\s|$)*" first-pass) "what's up?")
- (if (scan "^(?i)hi(\\s|$)*" first-pass) "what's up?")
- (if (scan "^(?i)yo(\\s|$)*" first-pass) "what's up?")
- (if (scan "^(?i)thank(s| you)(\\s|!|\\?|\\.|$)*" first-pass)
- (if sender
- (format nil "~A: you failed the inverse turing test!" sender)
- "you failed the inverse turing test!"))
- (if (scan "^(?i)version(\\s|!|\\?|\\.|$)*" first-pass)
- (format nil "This is the minion bot, running on a ~A (~A) and running under ~A ~A." (machine-type) (machine-version) (lisp-implementation-type) (lisp-implementation-version)))
- (if (scan "^(?i)(?i)do my bidding!*$" first-pass) "Yes, my master.")
- (aif (or (let ((term (cdr (assoc first-pass *small-definitions* :test #'string-equal))))
- (if term (if (stringp term) term (cliki-lookup (car term)))))
- (cliki-first-sentence first-pass)) (concatenate 'string first-pass ": " it))
- (if (scan "(!|\\.|\\s.+\\?|\\)|\\()\\s*$" term-with-question)
- ;;(generate-text (+ 20 (random 6)))
- (ignore-errors (eliza::eliza first-pass))
- )
- (format nil "Sorry, I couldn't find anything in the database for ``~A''.~A" first-pass (if (scan " " first-pass) " Maybe you meant to end with punctuation?" ""))
- ))))))
-
+ (let ((scanned (or (nth-value 1 (scan-to-strings "^add\\s+\"([^\"]+)\"\\s+as:*\\s+(.+)$" first-pass))
+ (nth-value 1 (scan-to-strings "^add\\s+(.+)\\s+as:\\s+(.+)$" first-pass)))))
+ (if scanned
+ (let ((term (elt scanned 0))
+ (defn (elt scanned 1)))
+ (add-small-definition term defn)
+ "OK, done.")
+ (let ((scanned (or
+ (nth-value 1 (scan-to-strings "^alias\\s+\"([^\"]+)\"\\s+as:*\\s+(.+)$" first-pass))
+ (nth-value 1 (scan-to-strings "^alias\\s+(.+)\\s+as:*\\s+(.+)$" first-pass))
+ (nth-value 1 (scan-to-strings "^(.+)\\s+is\\s+another\\s+(name|word)\\s+for:*\\s+([^.]+)\\.*$" first-pass)))))
+ (if scanned
+ (let ((term (elt scanned 0))
+ (defn (elt scanned (1- (length scanned)))))
+ (add-alias term defn)
+ "OK, done.")
+ (progn
+ (setf first-pass (regex-replace-all "(:|/|\\\\|\\#)" first-pass ""))
+ (when (and (scan "^(?i)lisppaste(\\s|!|\\?|\\.|$)*" first-pass)
+ (find-package :lisppaste)
+ channel
+ (> (length channel) 0)
+ (char= (elt channel 0) #\#)
+ (funcall (intern "SAY-HELP" :lisppaste)
+ channel))
+ (return-from cliki-lookup nil))
+ (or
+ (if (string-equal first-pass "help") *cliki-bot-help*)
+ (let ((strings (nth-value 1 (scan-to-strings "^(?i)memo\\s+(for|to)\\s+(\\S+)\\s+:*\\s*(.+)$" first-pass))))
+ (when (and sender strings)
+ (add-memo
+ sender
+ (if (member (elt strings 1) '("self" "myself" "me") :test #'string-equal)
+ sender
+ (elt strings 1))
+ (elt strings 2))
+ (format nil "Remembered. I'll tell ~A when he/she/it next speaks." (elt strings 1))))
+ (let ((to-forget (nth-value 1 (scan-to-strings "^forget\\s+([^.]+)\\.*$" first-pass))))
+ (when to-forget
+ (forget (elt to-forget 0))
+ (format nil "What's ~A? Never heard of it." (elt to-forget 0))))
+ (if (scan "^(?i)hello(\\s|$)*" first-pass) "what's up?")
+ (if (scan "^(?i)hi(\\s|$)*" first-pass) "what's up?")
+ (if (scan "^(?i)yo(\\s|$)*" first-pass) "what's up?")
+ (if (scan "^(?i)thank(s| you)(\\s|!|\\?|\\.|$)*" first-pass)
+ (if sender
+ (format nil "~A: you failed the inverse turing test!" sender)
+ "you failed the inverse turing test!"))
+ (if (scan "^(?i)version(\\s|!|\\?|\\.|$)*" first-pass)
+ (format nil "This is the minion bot, running on a ~A (~A) and running under ~A ~A." (machine-type) (machine-version) (lisp-implementation-type) (lisp-implementation-version)))
+ (if (scan "^(?i)(?i)do my bidding!*$" first-pass) "Yes, my master.")
+ (aif (or (small-definition-lookup first-pass)
+ (cliki-first-sentence first-pass)
+ (alias-lookup first-pass)) (concatenate 'string first-pass ": " it))
+ (if (or
+ (scan "(!|\\.|\\s.+\\?|\\)|\\()\\s*$" term-with-question)
+ (scan "^\\s*\\S+\\s+\\S+.*$" term-with-question))
+ ;;(generate-text (+ 20 (random 6)))
+ (ignore-errors (eliza::eliza first-pass))
+ )
+ (format nil "Sorry, I couldn't find anything in the database for ``~A''.~A" first-pass (if (scan " " first-pass) " Maybe you meant to end with punctuation?" ""))
+ ))))))))
+
(defun valid-cliki-message (message)
(scan *cliki-attention-prefix* (trailing-argument message)))
@@ -227,11 +330,12 @@
(defun msg-hook (message)
(let ((respond-to (if (string-equal (first (arguments message)) *cliki-nickname*) (source message) (first (arguments message)))))
+ (take-care-of-memos respond-to (source message))
(if (valid-cliki-message message)
(let ((response (cliki-lookup (regex-replace *cliki-attention-prefix* (trailing-argument message) "") :sender (source message) :channel (first (irc:arguments message)))))
(and response (privmsg *cliki-connection* respond-to response)))
(if (string-equal (first (arguments message)) *cliki-nickname*)
- (privmsg *cliki-connection* respond-to (cliki-lookup (trailing-argument message)))
+ (privmsg *cliki-connection* respond-to (cliki-lookup (trailing-argument message) :sender (source message)))
(if (anybody-here (trailing-argument message))
(privmsg *cliki-connection* (first (arguments message)) (format nil "~A: hello." (source message))))))))
More information about the cl-irc-cvs
mailing list