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