| ;;;; $Id: specbot.lisp,v 1.14 2005/08/09 01:26:14 lisppaste Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/specbot.lisp,v $ ;;;; specbot.lisp - an example IRC bot for cl-irc ;;; specbot is an example IRC bot for cl-irc. It runs on ;;; irc.freenode.net in the channels #lisp, #scheme and #clhs ;;; (preferred for testing). It responds to queries of its various ;;; databases, which right now include "clhs" and "r5rs". ;;; You will need to load and populate the tables for both the clhs ;;; and r5rs lookup packages; currently these are available in ;;; lisppaste CVS. ;;; To use it, load the cl-irc system, load specbot.lisp, and ;;; invoke (specbot:start-specbot "desirednickname" "desiredserver" ;;; "#channel1" "#channel2" "#channel3" ...) (defpackage :specbot (:use :common-lisp :irc) (:export :start-specbot :shut-up :un-shut-up)) (in-package :specbot) (defvar *base-path* (asdf:component-pathname (asdf:find-system :cliki-bot))) (defvar *connection*) (defvar *nickname* "") (defun shut-up () (setf (irc:client-stream *connection*) (make-broadcast-stream))) (defun un-shut-up () (setf (irc:client-stream *connection*) *trace-output*)) (defmacro aif (test conseq &optional (else nil)) `(let ((it ,test)) (if it ,conseq (symbol-macrolet ((it ,test)) ,else)))) (defun clhs-lookup (str) (and (find-package :clhs-lookup) (funcall (intern "SPEC-LOOKUP" :clhs-lookup) str))) (defun r5rs-lookup (str) (and (find-package :r5rs-lookup) (funcall (intern "SYMBOL-LOOKUP" :r5rs-lookup) str))) (defun cocoa-lookup (str) (and (find-package :cocoa-lookup) (funcall (intern "SYMBOL-LOOKUP" :cocoa-lookup) str))) (defun elisp-lookup (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") (cocoa-lookup "cocoa" "Classes in the Cocoa Foundation and Application kits") (elisp-lookup "elisp" "GNU Emacs Lisp Reference Manual") (clim-lookup "clim" "Common Lisp Interface Manager II Specification"))) (defvar *spaces-allowed* '(clim-lookup)) (defvar *alists* nil) (defun add-simple-alist-lookup (file designator prefix description) (unless (assoc designator *alists*) (let ((alist (with-open-file (s file :direction :input) (read s)))) (push (cons designator alist) *alists*) (setf *spec-providers* (nconc *spec-providers* (list `((simple-alist-lookup ,designator) ,prefix ,description))))))) (defun simple-alist-lookup (designator string) (let ((alist (cdr (assoc designator *alists*)))) (cdr (assoc string alist :test #'equalp)))) (defun valid-message (string prefix &key space-allowed) (if (eql (search prefix string :test #'char-equal) 0) (and (or space-allowed (not (find #\space string :start (length prefix)))) (length prefix)) nil)) (defun strip-address (string &key (address *nickname*) (final nil)) (loop for i in (list (format nil "~A " address) (format nil "~A: " address) (format nil "~A:" address) (format nil "~A, " address)) do (aif (valid-message string i :space-allowed t) (return-from strip-address (subseq string it)))) (and (not final) string)) (defun msg-hook (message) (let ((destination (if (string-equal (first (arguments message)) *nickname*) (source message) (first (arguments message)))) (to-lookup (strip-address (trailing-argument message)))) (if (and (or (string-equal (first (arguments message)) *nickname*) (not (string= to-lookup (trailing-argument message)))) (member to-lookup '("help" "help?") :test #'string-equal)) (progn (privmsg *connection* destination (format nil "To use the ~A bot, say something like \"database term\", where database is one of (~{~S~^, ~}) and term is the desired lookup. The available databases are:" *nickname* (mapcar #'second *spec-providers*))) (loop for i from 1 for j in *spec-providers* with elts = nil do (push j elts) if (zerop (mod i 4)) do (progn (privmsg *connection* destination (format nil "~{~{~*~S, ~A~}~^; ~}" (nreverse elts))) (setf elts nil))) ) (loop for type in *spec-providers* for actual-fun = (if (typep (first type) 'symbol) (first type) (lambda (lookup) (destructuring-bind (fun first-arg) (first type) (funcall fun first-arg lookup)))) do (aif (strip-address to-lookup :address (second type) :final t) (let ((looked-up (funcall actual-fun it))) (if (and (<= 0 (count #\space it) (if (member actual-fun *spaces-allowed*) 1 0)1) (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)))))))) (defparameter *754-file* (merge-pathnames "754.lisp-expr" (make-pathname :directory (pathname-directory *base-path*)))) (defparameter *ppc-file* (merge-pathnames "ppc-assem.lisp-expr" (make-pathname :directory (pathname-directory *base-path*)))) (defparameter *sus-file* (merge-pathnames "sus.lisp-expr" (make-pathname :directory (pathname-directory *base-path*)))) (defparameter *man-file* (merge-pathnames "man.lisp-expr" (make-pathname :directory (pathname-directory *base-path*)))) (defun start-specbot (nick server &rest channels) (add-simple-alist-lookup *754-file* 'ieee754 "ieee754" "Section numbers of IEEE 754") (add-simple-alist-lookup *ppc-file* 'ppc "ppc" "PowerPC assembly mnemonics") (add-simple-alist-lookup *sus-file* 'sus "posix" "Single UNIX Specification") (add-simple-alist-lookup *man-file* 'man "man" "Mac OS X Man Pages") (setf *nickname* nick) (setf *connection* (connect :nickname *nickname* :server server)) (mapcar #'(lambda (channel) (join *connection* channel)) channels) (add-hook *connection* 'irc::irc-privmsg-message 'msg-hook) #+(or sbcl openmcl) (start-background-message-handler *connection*) #-(or sbcl openmcl) (read-message-loop *connection*)) (defun shuffle-hooks () (irc::remove-hooks *connection* 'irc::irc-privmsg-message) (add-hook *connection* 'irc::irc-privmsg-message 'msg-hook)) |