July 2004 - cl-irc-cvs@common-lisp.net - mailman3.common-lisp.net

[Cl-irc-cvs] CVS update: cl-irc/example/cliki.lisp cl-irc/example/specbot.lisp
by Brian Mastenbrook 20 Jul '04

20 Jul '04

Update of /project/cl-irc/cvsroot/cl-irc/example In directory common-lisp.net:/home/bmastenbrook/cl-irc/example Modified Files: cliki.lisp specbot.lisp Log Message: big changes to cliki-bot: tell users about things, gets mad over abuse Date: Tue Jul 20 12:08:46 2004 Author: bmastenbrook Index: cl-irc/example/cliki.lisp diff -u cl-irc/example/cliki.lisp:1.12 cl-irc/example/cliki.lisp:1.13 --- cl-irc/example/cliki.lisp:1.12 Tue Jul 6 14:30:44 2004 +++ cl-irc/example/cliki.lisp Tue Jul 20 12:08:46 2004 @@ -1,4 +1,4 @@ -;;;; $Id: cliki.lisp,v 1.12 2004/07/06 21:30:44 bmastenbrook Exp $ +;;;; $Id: cliki.lisp,v 1.13 2004/07/20 19:08:46 bmastenbrook Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/cliki.lisp,v $ ;;;; cliki.lisp - CLiki as an infobot; only works on SBCL. @@ -151,6 +151,19 @@ :contents contents) *pending-memos*)) +(defun remove-memos (to &key from) + (let ((count 0)) + (setf *pending-memos* + (remove-if #'(lambda (m) + (and (string-equal (without-non-alphanumeric to) + (memo-to m)) + (or (not from) + (string-equal (without-non-alphanumeric from) + (memo-from m))) + (incf count))) + *pending-memos*)) + count)) + (defun lookup-paste (number) (and (find-package :lisppaste) (let ((paste (funcall (intern "FIND-PASTE" :lisppaste) number))) @@ -257,6 +270,7 @@ (setf first-line (regex-replace-all "\\r" first-line " ")) (setf first-line (regex-replace-all "\\n" first-line " ")) (setf first-line (regex-replace-all "_\$([^)]*)\$" first-line "\\1")) + (setf first-line (regex-replace-all "#H\$([^)]*)\$" first-line "\\1")) (setf first-line (regex-replace-all "\\*\$([^)]*)\$" first-line "\\1")) (setf first-line (regex-replace-all "<[^>]+>" first-line "")) (setf first-line (regex-replace-all "^(([^.]|\\.\\S)+)\\.\\s+.*$" first-line "\\1.")) @@ -301,6 +315,9 @@ ("memos" . ,(lambda (nick) (format nil "To send a memo, say something like ``~A: memo for nick: the memo''. I'll remember the memo for any nick which is the same as the given nick, +/- differences in punctuation, and any nick which is an alias for it, and give it to them when they next speak." nick))) + ("avoiding memos" . + ,(lambda (nick) + (format nil "To flush all your memos without delivery, say something like ``~A: discard my memos''. To flush only memos from a specific person, say ``~A: discard my memos from person''." nick nick))) ("nicknames" . ,(lambda (nick) (format nil "If you have multiple nicknames and want to get your memos at any of them, say something like ``~A: nick1 is another nick for nick2''. If you decide to give up a nick, say ``~:*~A: forget nick2'' and I'll forget it." nick))) @@ -326,94 +343,185 @@ (cliki-find-help (concatenate 'string string (string #\s)))))))) +(defun random-element (list) + (elt list (random (length list)))) + +(defparameter *last-eliza-times* (make-list 6 :initial-element 0)) + +(defparameter *last-warning-time* 0) + +(defun do-eliza (first-pass) + (if (> (- (get-universal-time) 30) + *last-warning-time*) + (let ((time-6 (first *last-eliza-times*)) + (time-4 (third *last-eliza-times*)) + (time-2 (fifth *last-eliza-times*)) + (current-time (get-universal-time)) + (count 0) + (overload 0)) + (if (or + (and + (< (- current-time 15) + time-2) + (setf count 3) + (setf overload (- current-time time-2))) + (and + (< (- current-time 45) + time-4) + (setf count 5) + (setf overload (- current-time time-4))) + (and + (< (- current-time 75) + time-6) + (setf count 7) + (setf overload (- current-time time-6)))) + (progn + (setf *last-warning-time* (get-universal-time)) + (format nil "Would you /please/ stop playing with me? ~A messages in ~A seconds is too many." count overload)) + (progn + (setf *last-eliza-times* (nconc (cdr *last-eliza-times*) + (list (get-universal-time)))) + (ignore-errors (eliza::eliza first-pass))) + + )))) + (defun cliki-lookup (term-with-question &key sender channel) (let ((first-pass (regex-replace-all "^(\\s*)([^?]+)(\\?*)$" term-with-question "\\2")) (should-send-cant-find t)) (setf first-pass (regex-replace-all "\\s\\s+" first-pass "")) (setf first-pass (regex-replace-all "\\s*$" first-pass "")) (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))))) + (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 *cliki-nickname*)) - (let ((strings (nth-value 1 (scan-to-strings "^(?i)help\\s\"*([^\"]+)\"*$" first-pass)))) - (when strings - (cliki-find-help (elt strings 0)))) - (let ((strings (nth-value 1 (scan-to-strings "^(?i)(memo|note)\\s+(for|to)\\s+(\\S+)\\s*[:,]+\\s+(.+)$" term-with-question)))) - (when (and sender strings) - (if (string-equal (without-non-alphanumeric - (elt strings 2)) - (without-non-alphanumeric - *cliki-nickname*)) - "Buzz off." - (progn - (add-memo - sender - (if (member (elt strings 2) '("self" "myself" "me") :test #'string-equal) - sender - (elt strings 2)) - (elt strings 3)) - (format nil "Remembered. I'll tell ~A when he/she/it next speaks." (elt strings 2)))))) - (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)))) - (let ((strs (nth-value 1 (scan-to-strings "^(?i)paste\\s+(\\d+)$" first-pass)))) - (and strs - (lookup-paste (parse-integer (elt strs 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.") - (if (should-do-lookup first-pass (or channel sender "")) - (aif (or (small-definition-lookup first-pass) - (cliki-first-sentence first-pass) - (alias-lookup first-pass)) - (prog1 - (concatenate 'string first-pass ": " it) - (did-lookup first-pass (or channel sender "")))) - (setf should-send-cant-find nil)) - (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)) - ) - (when should-send-cant-find - (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 "^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 + (let ((strings + (nth-value 1 (scan-to-strings "^(?i)(direct|tell|show|inform|teach)\\s+(\\S+)\\s+(about|on|in|to|through|)\\s*(.+)$" first-pass)))) + (if strings + (let ((about (cliki-lookup (elt strings 3) :sender sender + :channel channel))) + (if about + (format nil "~A: ~A~A" + (elt strings 1) + (if (scan "http:" about) + (concatenate 'string + (random-element + '("have a look at" + "please look at" + "please see" + "direct your attention towards" + "look at")) + " ") + "") + about) + (setf should-send-cant-find nil))))) + (if (string-equal first-pass "help") + (if (should-do-lookup first-pass (or channel sender "")) + (progn + (did-lookup first-pass (or channel sender "")) + (cliki-bot-help *cliki-nickname*)) + (setf should-send-cant-find nil))) + (let ((strings (nth-value 1 (scan-to-strings "^(?i)help\\s+(on|about|to|describing|)\\s*\"*([^\"]+)\"*$" first-pass)))) + (if strings + (if + (should-do-lookup first-pass (or channel sender "")) + (progn + (did-lookup first-pass (or channel sender "")) + (cliki-find-help (elt strings 1))) + (setf should-send-cant-find nil)))) + (let ((strings (nth-value 1 (scan-to-strings "^(?i)(memo|note)\\s+(for|to)\\s+(\\S+)\\s*[:,]+\\s+(.+)$" term-with-question)))) + (when (and sender strings) + (if (string-equal (without-non-alphanumeric + (elt strings 2)) + (without-non-alphanumeric + *cliki-nickname*)) + "Buzz off." + (progn + (add-memo + sender + (if (member (elt strings 2) '("self" "myself" "me") :test #'string-equal) + sender + (elt strings 2)) + (elt strings 3)) + (format nil "Remembered. I'll tell ~A when he/she/it next speaks." (elt strings 2)))))) + (when (and sender + (scan "^(?i)(discard|forget)\\s+(my\\s+|)memo(s|)$" first-pass)) + (let ((count (remove-memos sender))) + (case count + (0 "You didn't have any memos!") + (1 "OK, I threw it out.") + (t "OK, I threw them out.")))) + (let ((strings (nth-value 1 (scan-to-strings "^(?i)(discard|forget)\\s+(my\\s+|)memo(s|)\\s+from\\s+([^ .]+)\\.*$" first-pass)))) + (when (and sender + strings) + (let ((count (remove-memos sender :from (elt strings 3)))) + (case count + (0 "You didn't have any memos!") + (1 "OK, I threw it out.") + (t "OK, I threw them out."))) + )) + (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)))) + (let ((strs (nth-value 1 (scan-to-strings "^(?i)paste\\s+(\\d+)$" first-pass)))) + (and strs + (lookup-paste (parse-integer (elt strs 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.") + (if (should-do-lookup first-pass (or channel sender "")) + (aif (or (small-definition-lookup first-pass) + (cliki-first-sentence first-pass) + (alias-lookup first-pass)) + (prog1 + (concatenate 'string first-pass ": " it) + (did-lookup first-pass (or channel sender "")))) + (setf should-send-cant-find nil)) + (if (and + should-send-cant-find + (or + (scan "(!|\\.|\\s.+\\?|\\)|\\()\\s*$" term-with-question) + (scan "^\\s*\\S+\\s+\\S+.*$" term-with-question))) + ;;(generate-text (+ 20 (random 6))) + (progn + (setf should-send-cant-find nil) + (do-eliza first-pass)) + ) + (when should-send-cant-find + (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))) @@ -426,7 +534,6 @@ (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))) @@ -434,7 +541,8 @@ (aif (cliki-lookup (trailing-argument message) :sender (source message)) (privmsg *cliki-connection* respond-to it)) (if (anybody-here (trailing-argument message)) - (privmsg *cliki-connection* (first (arguments message)) (format nil "~A: hello." (source message)))))))) + (privmsg *cliki-connection* (first (arguments message)) (format nil "~A: hello." (source message)))))) + (take-care-of-memos respond-to (source message)))) (defvar *cliki-nickserv-password* "") Index: cl-irc/example/specbot.lisp diff -u cl-irc/example/specbot.lisp:1.4 cl-irc/example/specbot.lisp:1.5 --- cl-irc/example/specbot.lisp:1.4 Fri Jul 9 09:03:35 2004 +++ cl-irc/example/specbot.lisp Tue Jul 20 12:08:46 2004 @@ -1,4 +1,4 @@ -;;;; $Id: specbot.lisp,v 1.4 2004/07/09 16:03:35 bmastenbrook Exp $ +;;;; $Id: specbot.lisp,v 1.5 2004/07/20 19:08:46 bmastenbrook Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/specbot.lisp,v $ ;;;; specbot.lisp - an example IRC bot for cl-irc @@ -66,7 +66,7 @@ (defun add-simple-alist-lookup (file designator prefix description) (let ((alist (with-open-file (s file :direction :input) (read s)))) - (push (cons designator alist) *alists*) + (pushnew (cons designator alist) *alists* :test #'equal) (setf *spec-providers* (nconc *spec-providers* (list `((simple-alist-lookup ,designator) ,prefix ,description)))))) @@ -114,7 +114,7 @@ do (aif (strip-address to-lookup :address (second type) :final t) (let ((looked-up (funcall actual-fun it))) - (if (and (< 0 (count #\space it) 3) + (if (and (<= 0 (count #\space it) 1) (not looked-up)) (setf looked-up (format nil "Sorry, I couldn't find anything for ~A." it))) (and looked-up

1 0

[Cl-irc-cvs] CVS update: cl-irc/example/clim-lookup.lisp cl-irc/example/mrindex
by Brian Mastenbrook 09 Jul '04

09 Jul '04

Update of /project/cl-irc/cvsroot/cl-irc/example In directory common-lisp.net:/home/bmastenbrook/cl-irc/example Added Files: clim-lookup.lisp mrindex Log Message: CLIM spec lookup Date: Fri Jul 9 09:03:47 2004 Author: bmastenbrook

1 0

[Cl-irc-cvs] CVS update: cl-irc/example/specbot.lisp
by Brian Mastenbrook 09 Jul '04

09 Jul '04

Update of /project/cl-irc/cvsroot/cl-irc/example In directory common-lisp.net:/home/bmastenbrook/cl-irc/example Modified Files: specbot.lisp Log Message: CLIM spec lookup Date: Fri Jul 9 09:03:35 2004 Author: bmastenbrook Index: cl-irc/example/specbot.lisp diff -u cl-irc/example/specbot.lisp:1.3 cl-irc/example/specbot.lisp:1.4 --- cl-irc/example/specbot.lisp:1.3 Thu Jun 17 10:40:35 2004 +++ cl-irc/example/specbot.lisp Fri Jul 9 09:03:35 2004 @@ -1,4 +1,4 @@ -;;;; $Id: specbot.lisp,v 1.3 2004/06/17 17:40:35 bmastenbrook Exp $ +;;;; $Id: specbot.lisp,v 1.4 2004/07/09 16:03:35 bmastenbrook Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/specbot.lisp,v $ ;;;; specbot.lisp - an example IRC bot for cl-irc @@ -37,30 +37,30 @@ ,else)))) (defun clhs-lookup (str) - (aif (and (find-package :clhs-lookup) - (funcall (intern "SPEC-LOOKUP" :clhs-lookup) - str)) - it - (format nil "Nothing was found for: ~A" str))) + (and (find-package :clhs-lookup) + (funcall (intern "SPEC-LOOKUP" :clhs-lookup) + str))) (defun r5rs-lookup (str) - (aif (and (find-package :r5rs-lookup) - (funcall (intern "SYMBOL-LOOKUP" :r5rs-lookup) - str)) - it - (format nil "Nothing was found for: ~A" str))) + (and (find-package :r5rs-lookup) + (funcall (intern "SYMBOL-LOOKUP" :r5rs-lookup) + str))) (defun elisp-lookup (str) - (aif (and (find-package :elisp-lookup) - (funcall (intern "SYMBOL-LOOKUP" :elisp-lookup) - str)) - it - (format nil "Nothing was found for: ~A" str))) + (and (find-package :elisp-lookup) + (funcall (intern "SYMBOL-LOOKUP" :elisp-lookup) + str))) + +(defun clim-lookup (str) + (and (find-package :clim-lookup) + (funcall (intern "TERM-LOOKUP" :clim-lookup) + str))) (defvar *spec-providers* '((clhs-lookup "clhs" "The Common Lisp HyperSpec") (r5rs-lookup "r5rs" "The Revised 5th Ed. Report on the Algorithmic Language Scheme") - (elisp-lookup "elisp" "GNU Emacs Lisp Reference Manual"))) + (elisp-lookup "elisp" "GNU Emacs Lisp Reference Manual") + (clim-lookup "clim" "Common Lisp Interface Manager II Specification"))) (defvar *alists* nil) @@ -73,9 +73,7 @@ (defun simple-alist-lookup (designator string) (let ((alist (cdr (assoc designator *alists*)))) - (aif (assoc string alist :test #'equalp) - (cdr it) - (format nil "Nothing was found for: ~A" string)))) + (cdr (assoc string alist :test #'equalp)))) (defun valid-message (string prefix &key space-allowed) (if (eql (search prefix string :test #'char-equal) 0) @@ -89,7 +87,7 @@ (format nil "~A: " address) (format nil "~A:" address) (format nil "~A, " address)) - do (aif (valid-message string i :space-allowed (not final)) + do (aif (valid-message string i :space-allowed t) (return-from strip-address (subseq string it)))) (and (not final) string)) @@ -115,7 +113,12 @@ (funcall fun first-arg lookup)))) do (aif (strip-address to-lookup :address (second type) :final t) - (privmsg *connection* destination (funcall actual-fun it))))))) + (let ((looked-up (funcall actual-fun it))) + (if (and (< 0 (count #\space it) 3) + (not looked-up)) + (setf looked-up (format nil "Sorry, I couldn't find anything for ~A." it))) + (and looked-up + (privmsg *connection* destination looked-up)))))))) (defun start-specbot (nick server &rest channels) (add-simple-alist-lookup "754.lisp-expr" 'ieee754 "ieee754" "Section numbers of IEEE 754")

1 0

[Cl-irc-cvs] CVS update: cl-irc/example/cliki.lisp cl-irc/example/eliza-rules.lisp
by Brian Mastenbrook 06 Jul '04

06 Jul '04

Update of /project/cl-irc/cvsroot/cl-irc/example In directory common-lisp.net:/home/bmastenbrook/cl-irc/example Modified Files: cliki.lisp eliza-rules.lisp Log Message: w00t! minion! Date: Tue Jul 6 14:30:44 2004 Author: bmastenbrook Index: cl-irc/example/cliki.lisp diff -u cl-irc/example/cliki.lisp:1.11 cl-irc/example/cliki.lisp:1.12 --- cl-irc/example/cliki.lisp:1.11 Tue Jun 22 11:21:05 2004 +++ cl-irc/example/cliki.lisp Tue Jul 6 14:30:44 2004 @@ -1,4 +1,4 @@ -;;;; $Id: cliki.lisp,v 1.11 2004/06/22 18:21:05 bmastenbrook Exp $ +;;;; $Id: cliki.lisp,v 1.12 2004/07/06 21:30:44 bmastenbrook Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/cliki.lisp,v $ ;;;; cliki.lisp - CLiki as an infobot; only works on SBCL. @@ -16,6 +16,14 @@ (defvar *aliases* nil) +(defparameter *sd-file* + (merge-pathnames "sd.lisp-expr" + (make-pathname + :directory + (pathname-directory + (or *load-truename* + *default-pathname-defaults*))))) + (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)) @@ -32,7 +40,7 @@ (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) + (with-open-file (sd-file *sd-file* :direction :input :if-does-not-exist nil) (when sd-file (loop for defn = (read sd-file nil) if defn do (ecase (car defn) @@ -41,7 +49,7 @@ else return *small-definitions*)))) (defun write-small-definitions () - (with-open-file (sd-file "sd.lisp-expr" :direction :output :if-exists :supersede) + (with-open-file (sd-file *sd-file* :direction :output :if-exists :supersede) (mapc #'(lambda (db) (mapc #'(lambda (defn) (prin1 (cons (car db) defn) sd-file) @@ -50,7 +58,7 @@ (cons :alias *aliases*))))) (defun write-top-definition (&key (of *small-definitions*) (type :sd)) - (with-open-file (sd-file "sd.lisp-expr" :direction :output :if-exists :append) + (with-open-file (sd-file *sd-file* :direction :output :if-exists :append) (prin1 (cons type (car of)) sd-file) (format sd-file "~%"))) @@ -66,10 +74,31 @@ (defvar *followed-aliases* nil) +(defvar *last-lookup* "") +(defvar *last-lookup-source* "") +(defvar *last-lookup-time* (get-universal-time)) + (defun alias-string-equal (orig candidate) (unless (member candidate *followed-aliases* :test #'string-equal) (string-equal orig candidate))) +(defun should-do-lookup (text source) + (not (and (string-equal text *last-lookup*) + (string-equal source *last-lookup-source*) + (< (- (get-universal-time) + *last-lookup-time*) 5)))) + +(defun did-lookup (text source) + (setf *last-lookup* text) + (setf *last-lookup-source* source) + (setf *last-lookup-time* (get-universal-time))) + +(defmacro aif (test conseq &optional (else nil)) + `(let ((it ,test)) + (if it ,conseq + (symbol-macrolet ((it ,test)) + ,else)))) + (defun small-definition-lookup (text) (cdr (assoc text *small-definitions* :test #'string-equal))) @@ -122,6 +151,17 @@ :contents contents) *pending-memos*)) +(defun lookup-paste (number) + (and (find-package :lisppaste) + (let ((paste (funcall (intern "FIND-PASTE" :lisppaste) number))) + (and paste + (format nil "Paste number ~A: \"~A\" by ~A in ~A. ~A" + number + (funcall (intern "PASTE-TITLE" :lisppaste) paste) + (funcall (intern "PASTE-USER" :lisppaste) paste) + (funcall (intern "PASTE-CHANNEL" :lisppaste) paste) + (funcall (intern "PASTE-DISPLAY-URL" :lisppaste) paste)))))) + (defun url-port (url) (assert (string-equal url "http://" :end1 7)) (let ((port-start (position #\: url :start 7))) @@ -189,45 +229,46 @@ (defun cliki-first-sentence (term) (let* ((cliki-url (format nil "http://www.cliki.net/~A" - (encode-for-url term))) - (url (concatenate 'string cliki-url "?source"))) + (encode-for-url term))) + (url (concatenate 'string cliki-url "?source"))) (block cliki-return (handler-case - (host-with-timeout 5 - (destructuring-bind (response headers stream) - (block got - (loop - (destructuring-bind (response headers stream) (url-connection url) - (unless (member response '(301 302)) - (return-from got (list response headers stream))) - (close stream) - (setf url (cdr (assoc :location headers)))))) - (unwind-protect - (if (not (eql response 200)) + (host-with-timeout 5 + (destructuring-bind (response headers stream) + (block got + (loop + (destructuring-bind (response headers stream) (url-connection url) + (unless (member response '(301 302)) + (return-from got (list response headers stream))) + (close stream) + (setf url (cdr (assoc :location headers)))))) + (unwind-protect + (if (not (eql response 200)) nil - ;;(format nil "The term ~A was not found in CLiki." term) - (let ((first-line "")) - (loop for i from 1 to 5 do ;; scan the first 5 lines - (progn - (multiple-value-bind (next-line missing-newline-p) - (read-line stream nil) - (if next-line - (setf first-line (concatenate 'string first-line next-line (string #\newline))) - (return-from cliki-return (format nil "The end of the page was reached before a definition was found in ~A" cliki-url)))) - (setf first-line (regex-replace-all "\\r" first-line " ")) - (setf first-line (regex-replace-all "\\n" first-line " ")) - (setf first-line (regex-replace-all "_\$([^)]*)\$" first-line "\\1")) - (setf first-line (regex-replace-all "\\*\$([^)]*)\$" first-line "\\1")) - (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*(.+\\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))) - (if stream (close stream))))) - (condition (c &rest whatever) (return-from cliki-return (regex-replace-all "\\n" (format nil "An error was encountered in lookup: ~A." c) " "))))))) + ;;(format nil "The term ~A was not found in CLiki." term) + (let ((first-line "")) + (loop for i from 1 to 5 do ;; scan the first 5 lines + (progn + (multiple-value-bind (next-line missing-newline-p) + (read-line stream nil) + (if next-line + (setf first-line (concatenate 'string first-line next-line (string #\newline))) + (return-from cliki-return (format nil "The end of the page was reached before a definition was found in ~A" cliki-url)))) + (setf first-line (regex-replace-all "\\r" first-line " ")) + (setf first-line (regex-replace-all "\\n" first-line " ")) + (setf first-line (regex-replace-all "_\$([^)]*)\$" first-line "\\1")) + (setf first-line (regex-replace-all "\\*\$([^)]*)\$" first-line "\\1")) + (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*(.+\\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))) + (if stream (close stream))))) + (condition (c &rest whatever) (return-from cliki-return (regex-replace-all "\\n" (format nil "An error was encountered in lookup: ~A." c) " "))))) + )) (defvar *cliki-connection*) (defvar *cliki-nickname*) @@ -238,25 +279,60 @@ (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 - (symbol-macrolet ((it ,test)) - ,else)))) + (defun make-cliki-attention-prefix (nick) (format nil "^~A[,:]\\s+" nick)) (defvar *cliki-attention-prefix* "") -(defparameter *cliki-bot-help* "The minion bot supplies small definitions and performs lookups on CLiki. To use it, try ``minion: term?''. To add a term for IRC, try saying ``minion: add \"term\" as: definition'' or ``minion: alias \"term\" as: term''; otherwise, edit the corresponding CLiki page.") +(defparameter *help-text* + `(("lookups" . ,(lambda (nick) + (format nil "To look up a term, say something like ``~A: term?''. I will either return a definition for the term or say that it could not be found. Lookups check the internal database first and then try to retrieve the first sentence of the page named like that on CLiki." nick))) + ("adding terms" . + ,(lambda (nick) + (format nil "To add a term, say something like ``~A: add \"term\" as: the definition''. I will remember the definition." nick))) + ("aliasing terms" . + ,(lambda (nick) + (format nil "To make a term an alias for another term, say something like ``~A: alias \"term\" as: some other term''. I will remember the alias." nick))) + ("forgetting" . + ,(lambda (nick) + (format nil "To make me forget something, say something like ``~A: forget term''. I'll forget what I know about that term or nickname." nick))) + ("memos" . + ,(lambda (nick) + (format nil "To send a memo, say something like ``~A: memo for nick: the memo''. I'll remember the memo for any nick which is the same as the given nick, +/- differences in punctuation, and any nick which is an alias for it, and give it to them when they next speak." nick))) + ("nicknames" . + ,(lambda (nick) + (format nil "If you have multiple nicknames and want to get your memos at any of them, say something like ``~A: nick1 is another nick for nick2''. If you decide to give up a nick, say ``~:*~A: forget nick2'' and I'll forget it." nick))) + ("goodies" . + ,(lambda (nick) + (format nil "If I'm connected to a lisppaste bot, try ``~A: paste 42'' or some other number." nick))) + ("eliza" . + ,(lambda (nick) + (declare (ignore nick)) + (format nil "If you say multiple words to me which I don't recognize and it's not found as a lookup, you might get a sarcastic reply. Don't abuse this too much."))))) + +(defun cliki-bot-help (nick) + (format nil "There are multiple help modules. Try ``/msg ~A help kind'', where kind is one of: ~{\"~A\"~^, ~}." + nick + (mapcar #'car *help-text*))) + +(defun cliki-find-help (string) + (and (> (length string) 0) + (let ((resp-generator (cdr (assoc string *help-text* :test #'string-equal)))) + (if resp-generator + (funcall resp-generator *cliki-nickname*) + (if (not (char-equal (elt string (1- (length string))) #\s)) + (cliki-find-help (concatenate 'string string + (string #\s)))))))) (defun cliki-lookup (term-with-question &key sender channel) - (let ((first-pass (regex-replace-all "^(\\s*)([^?]+)(\\?*)$" term-with-question "\\2"))) + (let ((first-pass (regex-replace-all "^(\\s*)([^?]+)(\\?*)$" term-with-question "\\2")) + (should-send-cant-find t)) (setf first-pass (regex-replace-all "\\s\\s+" first-pass "")) (setf first-pass (regex-replace-all "\\s*$" first-pass "")) (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))))) + (nth-value 1 (scan-to-strings "^add\\s+(.+)\\s+as:*\\s+(.+)$" first-pass))))) (if scanned (let ((term (elt scanned 0)) (defn (elt scanned 1))) @@ -281,21 +357,35 @@ (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)))) + (if (string-equal first-pass "help") + (cliki-bot-help *cliki-nickname*)) + (let ((strings (nth-value 1 (scan-to-strings "^(?i)help\\s\"*([^\"]+)\"*$" first-pass)))) + (when strings + (cliki-find-help (elt strings 0)))) + (let ((strings (nth-value 1 (scan-to-strings "^(?i)(memo|note)\\s+(for|to)\\s+(\\S+)\\s*[:,]+\\s+(.+)$" term-with-question)))) (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)))) + (if (string-equal (without-non-alphanumeric + (elt strings 2)) + (without-non-alphanumeric + *cliki-nickname*)) + "Buzz off." + (progn + (add-memo + sender + (if (member (elt strings 2) '("self" "myself" "me") :test #'string-equal) + sender + (elt strings 2)) + (elt strings 3)) + (format nil "Remembered. I'll tell ~A when he/she/it next speaks." (elt strings 2)))))) (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)))) + (let ((strs (nth-value 1 (scan-to-strings "^(?i)paste\\s+(\\d+)$" first-pass)))) + (and strs + (lookup-paste (parse-integer (elt strs 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?") @@ -306,16 +396,22 @@ (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 (should-do-lookup first-pass (or channel sender "")) + (aif (or (small-definition-lookup first-pass) + (cliki-first-sentence first-pass) + (alias-lookup first-pass)) + (prog1 + (concatenate 'string first-pass ": " it) + (did-lookup first-pass (or channel sender "")))) + (setf should-send-cant-find nil)) (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?" "")) + (when should-send-cant-find + (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) @@ -335,9 +431,10 @@ (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) :sender (source message))) - (if (anybody-here (trailing-argument message)) - (privmsg *cliki-connection* (first (arguments message)) (format nil "~A: hello." (source message)))))))) + (aif (cliki-lookup (trailing-argument message) :sender (source message)) + (privmsg *cliki-connection* respond-to it)) + (if (anybody-here (trailing-argument message)) + (privmsg *cliki-connection* (first (arguments message)) (format nil "~A: hello." (source message)))))))) (defvar *cliki-nickserv-password* "") @@ -345,6 +442,11 @@ (if (and (string-equal (source message) "NickServ") (scan "owned by someone else" (trailing-argument message))) (privmsg *cliki-connection* (source message) (format nil "IDENTIFY ~A" *cliki-nickserv-password*)))) + +(defun rename-cliki (new-nick) + (setf *cliki-nickname* new-nick) + (nick *cliki-connection* new-nick) + (setf *cliki-attention-prefix* (make-cliki-attention-prefix new-nick))) (defun start-cliki-bot (nick server &rest channels) (read-small-definitions) Index: cl-irc/example/eliza-rules.lisp diff -u cl-irc/example/eliza-rules.lisp:1.4 cl-irc/example/eliza-rules.lisp:1.5 --- cl-irc/example/eliza-rules.lisp:1.4 Wed Jun 9 11:54:25 2004 +++ cl-irc/example/eliza-rules.lisp Tue Jul 6 14:30:44 2004 @@ -14,6 +14,12 @@ (((?* ?x) ass (?* ?y)) (|Can't| you be a bit more polite?)) + + (((?* ?x) me harder) + ("MORE" ?x)) + + ((more (?* ?x)) + (?x me harder)) (((?* ?x) you (?* ?y) written (?* ?z)) (|I'm| written in Common Lisp)) @@ -234,6 +240,11 @@ (yes) (maybe)) + ((does (?* ?x)) + (no) + (yes) + (maybe)) + ((attack the (?* ?y)) (|Die,| ?y)) ((attack (?* ?y)) @@ -410,4 +421,4 @@ (you speak nonsense) (does torturing a poor bot with things beyond its comprehension please you?) (please stop playing with |me...| I am not a toy) - (watch |out,| |you'll| make Krystof angry)))) \ No newline at end of file + (watch |out,| |you'll| make Krystof angry))))

1 0