| 1 | ;;;; $Id: cliki.lisp 210 2008-06-30 20:52:34Z ehuelsmann $ |
|---|
| 2 | ;;;; $Source$ |
|---|
| 3 | |
|---|
| 4 | ;;;; cliki.lisp - CLiki as an infobot; only works on SBCL. |
|---|
| 5 | |
|---|
| 6 | ;;; To use it, load the net-nittin-irc and cl-ppcre systems, load |
|---|
| 7 | ;;; cliki.lisp, and invoke (cliki::start-cliki-bot "desirednickname" |
|---|
| 8 | ;;; "desiredserver" "#channel1" "#channel2" "#channel3" ...) |
|---|
| 9 | |
|---|
| 10 | (defpackage :cliki (:use :common-lisp :irc :cl-ppcre :split-sequence) |
|---|
| 11 | (:export :start-cliki-bot :*cliki-nickserv-password* |
|---|
| 12 | :*respond-to-general-hellos* :shut-up :un-shut-up)) |
|---|
| 13 | (in-package :cliki) |
|---|
| 14 | |
|---|
| 15 | (defvar *small-definitions* nil) |
|---|
| 16 | |
|---|
| 17 | (defvar *aliases* nil) |
|---|
| 18 | |
|---|
| 19 | (defparameter *sd-file* |
|---|
| 20 | (merge-pathnames "sd.lisp-expr" |
|---|
| 21 | (make-pathname |
|---|
| 22 | :directory |
|---|
| 23 | (pathname-directory |
|---|
| 24 | (or *load-truename* |
|---|
| 25 | *default-pathname-defaults*))))) |
|---|
| 26 | |
|---|
| 27 | (defun forget (term-or-alias) |
|---|
| 28 | (setf *small-definitions* (remove term-or-alias *small-definitions* :test #'string-equal :key #'car)) |
|---|
| 29 | (setf *aliases* (remove term-or-alias *aliases* :test #'string-equal :key #'car)) |
|---|
| 30 | (write-small-definitions)) |
|---|
| 31 | |
|---|
| 32 | (defun fix-aliases () |
|---|
| 33 | (setf *small-definitions* |
|---|
| 34 | (loop for defn in *small-definitions* |
|---|
| 35 | if (stringp (cdr defn)) |
|---|
| 36 | collect defn |
|---|
| 37 | else do (push (cons (first defn) (second defn)) |
|---|
| 38 | *aliases*)))) |
|---|
| 39 | |
|---|
| 40 | (defun read-small-definitions () |
|---|
| 41 | (setf *small-definitions* nil) |
|---|
| 42 | (setf *aliases* nil) |
|---|
| 43 | (with-open-file (sd-file *sd-file* :direction :input :if-does-not-exist nil) |
|---|
| 44 | (when sd-file |
|---|
| 45 | (loop for defn = (read sd-file nil) |
|---|
| 46 | if defn do (ecase (car defn) |
|---|
| 47 | (:sd (push (cdr defn) *small-definitions*)) |
|---|
| 48 | (:alias (push (cdr defn) *aliases*))) |
|---|
| 49 | else return *small-definitions*)))) |
|---|
| 50 | |
|---|
| 51 | (defun write-small-definitions () |
|---|
| 52 | (with-open-file (sd-file *sd-file* :direction :output :if-exists :supersede) |
|---|
| 53 | (mapc #'(lambda (db) |
|---|
| 54 | (mapc #'(lambda (defn) |
|---|
| 55 | (prin1 (cons (car db) defn) sd-file) |
|---|
| 56 | (format sd-file "~%")) (reverse (cdr db)))) |
|---|
| 57 | (list (cons :sd *small-definitions*) |
|---|
| 58 | (cons :alias *aliases*))))) |
|---|
| 59 | |
|---|
| 60 | (defun write-top-definition (&key (of *small-definitions*) (type :sd)) |
|---|
| 61 | (with-open-file (sd-file *sd-file* :direction :output :if-exists :append) |
|---|
| 62 | (prin1 (cons type (car of)) sd-file) |
|---|
| 63 | (format sd-file "~%"))) |
|---|
| 64 | |
|---|
| 65 | (defun add-small-definition (term defn) |
|---|
| 66 | (push (cons term defn) *small-definitions*) |
|---|
| 67 | (write-top-definition)) |
|---|
| 68 | |
|---|
| 69 | (defun add-alias (term defn) |
|---|
| 70 | (push (cons term defn) *aliases*) |
|---|
| 71 | (write-top-definition :of *aliases* :type :alias)) |
|---|
| 72 | |
|---|
| 73 | (defun cliki-apropos (search-string) |
|---|
| 74 | (let ((found (remove-duplicates |
|---|
| 75 | (loop for (term . defn) in *small-definitions* |
|---|
| 76 | if (search search-string defn :test #'string-equal) |
|---|
| 77 | collect term) :test #'string-equal))) |
|---|
| 78 | (if found (format nil "Matches: ~{~S~^ ~}" found) |
|---|
| 79 | "No Matches"))) |
|---|
| 80 | |
|---|
| 81 | (defvar *lookup-depth* 0) |
|---|
| 82 | |
|---|
| 83 | (defvar *followed-aliases* nil) |
|---|
| 84 | |
|---|
| 85 | (defvar *last-lookup* "") |
|---|
| 86 | (defvar *last-lookup-source* "") |
|---|
| 87 | (defvar *last-lookup-time* (get-universal-time)) |
|---|
| 88 | |
|---|
| 89 | (defun alias-string-equal (orig candidate) |
|---|
| 90 | (unless (member candidate *followed-aliases* :test #'string-equal) |
|---|
| 91 | (string-equal orig candidate))) |
|---|
| 92 | |
|---|
| 93 | (defun should-do-lookup (text source) |
|---|
| 94 | (not (and (string-equal text *last-lookup*) |
|---|
| 95 | (string-equal source *last-lookup-source*) |
|---|
| 96 | (< (- (get-universal-time) |
|---|
| 97 | *last-lookup-time*) 5)))) |
|---|
| 98 | |
|---|
| 99 | (defun did-lookup (text source) |
|---|
| 100 | (setf *last-lookup* text) |
|---|
| 101 | (setf *last-lookup-source* source) |
|---|
| 102 | (setf *last-lookup-time* (get-universal-time))) |
|---|
| 103 | |
|---|
| 104 | (defmacro aif (test conseq &optional (else nil)) |
|---|
| 105 | `(let ((it ,test)) |
|---|
| 106 | (if it ,conseq |
|---|
| 107 | (symbol-macrolet ((it ,test)) |
|---|
| 108 | ,else)))) |
|---|
| 109 | |
|---|
| 110 | (defun small-definition-lookup (text) |
|---|
| 111 | (cdr (assoc text *small-definitions* :test #'string-equal))) |
|---|
| 112 | |
|---|
| 113 | (defun alias-lookup (text) |
|---|
| 114 | (let ((alias (or (cdr (assoc text *aliases* :test #'alias-string-equal)) |
|---|
| 115 | (car (rassoc text *aliases* :test #'alias-string-equal))))) |
|---|
| 116 | (if alias |
|---|
| 117 | (let ((*lookup-depth* (1+ *lookup-depth*)) |
|---|
| 118 | (*followed-aliases* (cons alias *followed-aliases*))) |
|---|
| 119 | (if (> *lookup-depth* 5) |
|---|
| 120 | "Too many recursive lookups." |
|---|
| 121 | (cliki-lookup alias)))))) |
|---|
| 122 | |
|---|
| 123 | (defclass memo () |
|---|
| 124 | ((from :accessor memo-from :initarg :from) |
|---|
| 125 | (to :accessor memo-to :initarg :to) |
|---|
| 126 | (contents :accessor memo-contents :initarg :contents))) |
|---|
| 127 | |
|---|
| 128 | (defun without-non-alphanumeric (string) |
|---|
| 129 | (with-output-to-string (s) |
|---|
| 130 | (loop for char across string |
|---|
| 131 | if (alphanumericp char) |
|---|
| 132 | do (princ char s)))) |
|---|
| 133 | |
|---|
| 134 | (defvar *pending-memos* nil) |
|---|
| 135 | |
|---|
| 136 | (defun memo-alias-test (orig candidate) |
|---|
| 137 | (or (string-equal orig (car candidate)) |
|---|
| 138 | (string-equal orig (cdr candidate)) |
|---|
| 139 | (string-equal orig (without-non-alphanumeric (car candidate))) |
|---|
| 140 | (string-equal orig (without-non-alphanumeric (cdr candidate))))) |
|---|
| 141 | |
|---|
| 142 | (defun take-care-of-memos (channel user &key (original-user user) (no-alias nil)) |
|---|
| 143 | (let ((found (find (without-non-alphanumeric user) *pending-memos* :test #'string-equal :key #'memo-to :from-end t))) |
|---|
| 144 | (if found |
|---|
| 145 | (progn |
|---|
| 146 | (setf *pending-memos* (remove found *pending-memos*)) |
|---|
| 147 | (privmsg *cliki-connection* channel (format nil "~A, memo from ~A: ~A" original-user (memo-from found) (memo-contents found))) |
|---|
| 148 | (take-care-of-memos channel user :original-user original-user)) |
|---|
| 149 | (if (not no-alias) |
|---|
| 150 | (let ((alias (find (without-non-alphanumeric user) |
|---|
| 151 | *aliases* |
|---|
| 152 | :test #'memo-alias-test))) |
|---|
| 153 | (if alias |
|---|
| 154 | (take-care-of-memos channel (cdr alias) :original-user original-user :no-alias t))))))) |
|---|
| 155 | |
|---|
| 156 | (defun add-memo (from to contents) |
|---|
| 157 | (push (make-instance 'memo :from from |
|---|
| 158 | :to (without-non-alphanumeric to) |
|---|
| 159 | :contents contents) |
|---|
| 160 | *pending-memos*)) |
|---|
| 161 | |
|---|
| 162 | (defun remove-memos (to &key from) |
|---|
| 163 | (let ((count 0)) |
|---|
| 164 | (setf *pending-memos* |
|---|
| 165 | (remove-if #'(lambda (m) |
|---|
| 166 | (and (string-equal (without-non-alphanumeric to) |
|---|
| 167 | (memo-to m)) |
|---|
| 168 | (or (not from) |
|---|
| 169 | (string-equal (without-non-alphanumeric from) |
|---|
| 170 | (memo-from m))) |
|---|
| 171 | (incf count))) |
|---|
| 172 | *pending-memos*)) |
|---|
| 173 | count)) |
|---|
| 174 | |
|---|
| 175 | (defparameter *advice-file* |
|---|
| 176 | (merge-pathnames "advice" |
|---|
| 177 | (make-pathname |
|---|
| 178 | :directory |
|---|
| 179 | (pathname-directory |
|---|
| 180 | (or *load-truename* |
|---|
| 181 | *default-pathname-defaults*))))) |
|---|
| 182 | |
|---|
| 183 | (defvar *advice-db* nil) |
|---|
| 184 | |
|---|
| 185 | (defun advice-db () |
|---|
| 186 | (when (not *advice-db*) |
|---|
| 187 | (with-open-file (ad *advice-file* :direction :input) |
|---|
| 188 | (setf *advice-db* (read ad)))) |
|---|
| 189 | *advice-db*) |
|---|
| 190 | |
|---|
| 191 | (defun lookup-advice (num-str) |
|---|
| 192 | (let ((num (parse-integer num-str :junk-allowed t))) |
|---|
| 193 | (or (cdr (assoc num (advice-db))) |
|---|
| 194 | "You can't just make up advice numbers and expect a response."))) |
|---|
| 195 | |
|---|
| 196 | (defun random-advice () |
|---|
| 197 | (let ((item (random-element (advice-db)))) |
|---|
| 198 | (format nil "#~A: ~A" (car item) (cdr item)))) |
|---|
| 199 | |
|---|
| 200 | (defun search-advice (str) |
|---|
| 201 | (setf str (regex-replace-all "\\s+" str " ")) |
|---|
| 202 | (setf str (regex-replace-all "[^a-zA-Z0-9 ]" str "")) |
|---|
| 203 | (let* ((terms (split-sequence #\space str)) |
|---|
| 204 | (terms (mapcar #'(lambda (e) |
|---|
| 205 | (loop for r = (regex-replace-all "^(.+)(ness|ing|ation|ion|ly)$" e "\\1") |
|---|
| 206 | if (equal e r) return r |
|---|
| 207 | do (setf e r) |
|---|
| 208 | )) terms)) |
|---|
| 209 | (terms (mapcar #'(lambda (e) |
|---|
| 210 | (regex-replace-all "^(.+)([a-zA-Z])\\2+$" e "\\1\\2")) terms)) |
|---|
| 211 | (terms (mapcar #'(lambda (e) |
|---|
| 212 | (regex-replace-all "^(.+)s$" e "\\1")) terms)) |
|---|
| 213 | (max-score 0) |
|---|
| 214 | (max-score-items nil)) |
|---|
| 215 | ;;(format t "terms is ~S~%" terms) |
|---|
| 216 | (mapc #'(lambda (e) |
|---|
| 217 | (let ((score |
|---|
| 218 | (loop for i in terms |
|---|
| 219 | if (search i (cdr e) :test #'char-equal) |
|---|
| 220 | count it))) |
|---|
| 221 | (if (> score max-score) |
|---|
| 222 | (progn |
|---|
| 223 | (setf max-score score) |
|---|
| 224 | (setf max-score-items (list e))) |
|---|
| 225 | (if (and (not (zerop score)) |
|---|
| 226 | (eql score max-score)) |
|---|
| 227 | (push e max-score-items))))) |
|---|
| 228 | (advice-db)) |
|---|
| 229 | (if (zerop max-score) |
|---|
| 230 | (progn |
|---|
| 231 | (signal 'lookup-failure) |
|---|
| 232 | "You can't expect automated advice for everything.") |
|---|
| 233 | (let ((item (random-element max-score-items))) |
|---|
| 234 | (format nil "#~A: ~A" (car item) (cdr item)))))) |
|---|
| 235 | |
|---|
| 236 | (defun lookup-paste (number) |
|---|
| 237 | (and (find-package :lisppaste) |
|---|
| 238 | (let ((paste (funcall (intern "FIND-PASTE" :lisppaste) number))) |
|---|
| 239 | (and paste |
|---|
| 240 | (format nil "Paste number ~A: \"~A\" by ~A in ~A. ~A" |
|---|
| 241 | number |
|---|
| 242 | (funcall (intern "PASTE-TITLE" :lisppaste) paste) |
|---|
| 243 | (funcall (intern "PASTE-USER" :lisppaste) paste) |
|---|
| 244 | (funcall (intern "PASTE-CHANNEL" :lisppaste) paste) |
|---|
| 245 | (funcall (intern "PASTE-DISPLAY-URL" :lisppaste) paste)))))) |
|---|
| 246 | |
|---|
| 247 | (defun encode-for-url (str) |
|---|
| 248 | (setf str (regex-replace-all " " str "%20")) |
|---|
| 249 | (setf str (regex-replace-all "," str "%2C")) |
|---|
| 250 | (setf str (regex-replace-all "`" str "%60")) |
|---|
| 251 | ;(format t "hi ~A~%" str) |
|---|
| 252 | str) |
|---|
| 253 | |
|---|
| 254 | #-(or sbcl ccl) |
|---|
| 255 | (defmacro host-with-timeout (timeout &body body) |
|---|
| 256 | (declare (ignore timeout)) |
|---|
| 257 | `(progn ,@body)) |
|---|
| 258 | |
|---|
| 259 | #+sbcl |
|---|
| 260 | (defmacro host-with-timeout (timeout &body body) |
|---|
| 261 | `(sb-ext:with-timeout ,timeout ,@body)) |
|---|
| 262 | |
|---|
| 263 | #+ccl |
|---|
| 264 | (defmacro host-with-timeout (timeout &body body) |
|---|
| 265 | `(let ((interrupt-thread nil)) |
|---|
| 266 | (setf interrupt-thread |
|---|
| 267 | (ccl:process-run-function 'timeout |
|---|
| 268 | (let ((process ccl:*current-process*)) |
|---|
| 269 | (lambda () |
|---|
| 270 | (sleep ,timeout) |
|---|
| 271 | (ccl:process-interrupt process |
|---|
| 272 | (lambda () |
|---|
| 273 | (signal 'openmcl-timeout))))))) |
|---|
| 274 | (unwind-protect |
|---|
| 275 | (progn ,@body) |
|---|
| 276 | (if interrupt-thread |
|---|
| 277 | (ccl:process-kill interrupt-thread))))) |
|---|
| 278 | |
|---|
| 279 | (defun http-get-recursively (url) |
|---|
| 280 | (destructuring-bind (status headers stream) |
|---|
| 281 | (trivial-http:http-get url) |
|---|
| 282 | (if (and (eql status 302) |
|---|
| 283 | (assoc :location headers)) |
|---|
| 284 | (progn |
|---|
| 285 | (close stream) |
|---|
| 286 | (http-get-recursively (cdr (assoc :location headers)))) |
|---|
| 287 | (list status headers stream)))) |
|---|
| 288 | |
|---|
| 289 | (define-condition lookup-failure (condition) ()) |
|---|
| 290 | |
|---|
| 291 | (defun cliki-first-sentence (term) |
|---|
| 292 | (let* ((cliki-url (format nil "http://www.cliki.net/~A" |
|---|
| 293 | (encode-for-url term))) |
|---|
| 294 | (url (concatenate 'string cliki-url "?source"))) |
|---|
| 295 | (block cliki-return |
|---|
| 296 | (handler-case |
|---|
| 297 | (host-with-timeout |
|---|
| 298 | 5 |
|---|
| 299 | (destructuring-bind (status headers stream) |
|---|
| 300 | (http-get-recursively url) |
|---|
| 301 | (declare (ignore headers)) |
|---|
| 302 | ;; Please don't hack on this when tired; it's easy to make it leak fds. |
|---|
| 303 | (unwind-protect |
|---|
| 304 | (if (or (not (eql status 200)) (not stream)) |
|---|
| 305 | nil |
|---|
| 306 | ;;(format nil "The term ~A was not found in CLiki." term) |
|---|
| 307 | (let ((first-line "")) |
|---|
| 308 | (loop for i from 1 to 5 do ;; scan the first 5 lines |
|---|
| 309 | (progn |
|---|
| 310 | (multiple-value-bind (next-line missing-newline-p) |
|---|
| 311 | (read-line stream nil) |
|---|
| 312 | (if next-line |
|---|
| 313 | (setf first-line (concatenate 'string first-line (string #\newline) next-line)) |
|---|
| 314 | (return-from cliki-return (format nil "The end of the page was reached before a definition was found in ~A" cliki-url)))) |
|---|
| 315 | (setf first-line (regex-replace-all "\\r" first-line " ")) |
|---|
| 316 | (setf first-line (regex-replace-all "\\n" first-line " ")) |
|---|
| 317 | (setf first-line (regex-replace-all "_\\(([^)]*)\\)" first-line "\\1")) |
|---|
| 318 | (setf first-line (regex-replace-all "#H\\(([^)]*)\\)" first-line "\\1")) |
|---|
| 319 | (setf first-line (regex-replace-all "\\*\\(([^)]*)\\)" first-line "\\1")) |
|---|
| 320 | (setf first-line (regex-replace-all "<[^>]+>" first-line "")) |
|---|
| 321 | (setf first-line (regex-replace-all "^(([^.]|\\.\\S)+)\\.\\s+.*$" first-line "\\1.")) |
|---|
| 322 | (setf first-line (regex-replace-all "(\\s)\\s+" first-line "\\1")) |
|---|
| 323 | (setf first-line (regex-replace-all "^\\s*(.+\\S)\\s*$" first-line "\\1")) |
|---|
| 324 | (when (scan "^([^.]|\\.\\S)+[.?!]$" first-line) |
|---|
| 325 | (setf first-line (concatenate 'string first-line " " cliki-url)) |
|---|
| 326 | (return-from cliki-return first-line)))) |
|---|
| 327 | (progn |
|---|
| 328 | (signal 'lookup-failure) |
|---|
| 329 | (format nil "No definition was found in the first 5 lines of ~A" cliki-url)))) |
|---|
| 330 | (if stream (close stream))))) |
|---|
| 331 | #+sbcl |
|---|
| 332 | (sb-ext:timeout (c) |
|---|
| 333 | (return-from cliki-return (progn (signal 'lookup-failure) |
|---|
| 334 | "I can't be expected to work when CLiki doesn't respond to me, can I?"))) |
|---|
| 335 | (trivial-sockets:socket-error (c) |
|---|
| 336 | (return-from cliki-return (progn (signal 'lookup-failure) |
|---|
| 337 | "I can't be expected to work when CLiki doesn't respond to me, can I?"))) |
|---|
| 338 | (serious-condition (c &rest whatever) (return-from cliki-return (progn (signal 'lookup-failure) (regex-replace-all "\\n" (format nil "An error was encountered in lookup: ~A." c) " ")))))) |
|---|
| 339 | )) |
|---|
| 340 | |
|---|
| 341 | (defun shorten (url) |
|---|
| 342 | (handler-case |
|---|
| 343 | (let ((stream (trivial-http:http-get (format nil "http://shorl.com/create.php?url=~A" url)))) |
|---|
| 344 | (finish-output t) |
|---|
| 345 | (unwind-protect |
|---|
| 346 | (when stream |
|---|
| 347 | (prog1 |
|---|
| 348 | (loop for line = (read-line stream nil nil) |
|---|
| 349 | while line |
|---|
| 350 | if (scan "http://shorl\\.com/[a-z]+" line) |
|---|
| 351 | return (regex-replace-all "^.*(http://shorl\\.com/[a-z]+).*$" line "\\1")) |
|---|
| 352 | (close stream) |
|---|
| 353 | (setf stream nil))) |
|---|
| 354 | (if stream (close stream)))) |
|---|
| 355 | (condition (c) |
|---|
| 356 | (return-from shorten (regex-replace-all "\\n" (format nil "An error was encountered in shorten: ~A." c) " "))))) |
|---|
| 357 | |
|---|
| 358 | (defvar *cliki-connection*) |
|---|
| 359 | (defvar *cliki-nickname*) |
|---|
| 360 | |
|---|
| 361 | (defun shut-up () |
|---|
| 362 | (setf (irc:client-stream *cliki-connection*) (make-broadcast-stream))) |
|---|
| 363 | |
|---|
| 364 | (defun un-shut-up () |
|---|
| 365 | (setf (irc:client-stream *cliki-connection*) *trace-output*)) |
|---|
| 366 | |
|---|
| 367 | |
|---|
| 368 | |
|---|
| 369 | (defun make-cliki-attention-prefix (nick) |
|---|
| 370 | (format nil "^(?i)~A[,:]\\s+" nick)) |
|---|
| 371 | |
|---|
| 372 | (defvar *cliki-attention-prefix* "") |
|---|
| 373 | |
|---|
| 374 | (defparameter *help-text* |
|---|
| 375 | `(("lookups" . ,(lambda (nick) |
|---|
| 376 | (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))) |
|---|
| 377 | ("helping others" . |
|---|
| 378 | ,(lambda (nick) |
|---|
| 379 | (format nil "I can tell another user about something if you address me like ``~A: show some-user something else''. I respond to a lot of different ways of asking for this, and you can have me show pretty much anything to another user." nick))) |
|---|
| 380 | ("adding terms" . |
|---|
| 381 | ,(lambda (nick) |
|---|
| 382 | (format nil "To add a term, say something like ``~A: add \"term\" as: the definition''. I will remember the definition." nick))) |
|---|
| 383 | ("aliasing terms" . |
|---|
| 384 | ,(lambda (nick) |
|---|
| 385 | (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))) |
|---|
| 386 | ("forgetting" . |
|---|
| 387 | ,(lambda (nick) |
|---|
| 388 | (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))) |
|---|
| 389 | ("memos" . |
|---|
| 390 | ,(lambda (nick) |
|---|
| 391 | (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))) |
|---|
| 392 | ("avoiding memos" . |
|---|
| 393 | ,(lambda (nick) |
|---|
| 394 | (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))) |
|---|
| 395 | ("nicknames" . |
|---|
| 396 | ,(lambda (nick) |
|---|
| 397 | (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))) |
|---|
| 398 | ("goodies" . |
|---|
| 399 | ,(lambda (nick) |
|---|
| 400 | (format nil "If I'm connected to a lisppaste bot, try ``~A: paste 42'' or some other number." nick))) |
|---|
| 401 | ("eliza" . |
|---|
| 402 | ,(lambda (nick) |
|---|
| 403 | (declare (ignore nick)) |
|---|
| 404 | (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."))) |
|---|
| 405 | ("advice" . |
|---|
| 406 | ,(lambda (nick) |
|---|
| 407 | (format nil "Try saying something like ``~A: advice #11904'' to get some advice." nick))) |
|---|
| 408 | ("apropos" . |
|---|
| 409 | ,(lambda (nick) |
|---|
| 410 | (format nil "Try ``~A: apropos foo'' to search for all small definitions containing ''foo''." nick))) |
|---|
| 411 | ("acronyms" . |
|---|
| 412 | ,(lambda (nick) |
|---|
| 413 | (format nil "See an acronym you don't recognize? Try ``~A: what does sbcl stand for?'' to find out what it means!" nick))))) |
|---|
| 414 | |
|---|
| 415 | (defun cliki-bot-help (nick) |
|---|
| 416 | (format nil "There are multiple help modules. Try ``/msg ~A help kind'', where kind is one of: ~{\"~A\"~^, ~}." |
|---|
| 417 | nick |
|---|
| 418 | (mapcar #'car *help-text*))) |
|---|
| 419 | |
|---|
| 420 | (defun cliki-find-help (string) |
|---|
| 421 | (and (> (length string) 0) |
|---|
| 422 | (let ((resp-generator (cdr (assoc string *help-text* :test #'string-equal)))) |
|---|
| 423 | (if resp-generator |
|---|
| 424 | (funcall resp-generator *cliki-nickname*) |
|---|
| 425 | (if (not (char-equal (elt string (1- (length string))) #\s)) |
|---|
| 426 | (cliki-find-help (concatenate 'string string |
|---|
| 427 | (string #\s)))))))) |
|---|
| 428 | |
|---|
| 429 | (defun random-element (list) |
|---|
| 430 | (elt list (random (length list)))) |
|---|
| 431 | |
|---|
| 432 | (defparameter *last-eliza-times* (make-list 6 :initial-element 0)) |
|---|
| 433 | |
|---|
| 434 | (defparameter *last-warning-time* 0) |
|---|
| 435 | |
|---|
| 436 | (defmacro without-abuse (&body body) |
|---|
| 437 | `(flet ((doit () ,@body)) |
|---|
| 438 | (if (> (- (get-universal-time) 60) |
|---|
| 439 | *last-warning-time*) |
|---|
| 440 | (let ((time-6 (first *last-eliza-times*)) |
|---|
| 441 | (time-4 (third *last-eliza-times*)) |
|---|
| 442 | (time-2 (fifth *last-eliza-times*)) |
|---|
| 443 | (current-time (get-universal-time)) |
|---|
| 444 | (count 0) |
|---|
| 445 | (overload 0)) |
|---|
| 446 | (if (or |
|---|
| 447 | (and |
|---|
| 448 | (< (- current-time 60) |
|---|
| 449 | time-2) |
|---|
| 450 | (setf count 3) |
|---|
| 451 | (setf overload (- current-time time-2))) |
|---|
| 452 | (and |
|---|
| 453 | (< (- current-time 75) |
|---|
| 454 | time-4) |
|---|
| 455 | (setf count 5) |
|---|
| 456 | (setf overload (- current-time time-4))) |
|---|
| 457 | (and |
|---|
| 458 | (< (- current-time 90) |
|---|
| 459 | time-6) |
|---|
| 460 | (setf count 7) |
|---|
| 461 | (setf overload (- current-time time-6)))) |
|---|
| 462 | (progn |
|---|
| 463 | (setf *last-warning-time* (get-universal-time)) |
|---|
| 464 | (format nil "Would you /please/ stop playing with me? ~A messages in ~A seconds is too many." count overload)) |
|---|
| 465 | (progn |
|---|
| 466 | (setf *last-eliza-times* (nconc (cdr *last-eliza-times*) |
|---|
| 467 | (list (get-universal-time)))) |
|---|
| 468 | (doit)) |
|---|
| 469 | |
|---|
| 470 | ))))) |
|---|
| 471 | |
|---|
| 472 | (defun do-eliza (first-pass) |
|---|
| 473 | (without-abuse (ignore-errors (eliza::eliza first-pass)))) |
|---|
| 474 | |
|---|
| 475 | (defvar *more* "CODE") |
|---|
| 476 | |
|---|
| 477 | (defvar *prepositions* |
|---|
| 478 | '("aboard" "about" "above" "across" "after" "against" "along" "among" "around" "as" "at" "before" "behind" "below" "beneath" "beside" "between" "beyond" "but" "except" "by" "concerning" "despite" "down" "during" "except" "for" "from" "in" "into" "like" "near" "of" "off" "on" "onto" "out" "outside" "over" "past" "per" "regarding" "since" "through" "throughout" "till" "to" "toward" "under" "underneath" "until" "up" "upon" "with" "within" "without")) |
|---|
| 479 | |
|---|
| 480 | (defvar *conjunctions* |
|---|
| 481 | '("for" "and" "nor" "but" "or" "yet" "so")) |
|---|
| 482 | |
|---|
| 483 | (defvar *articles* |
|---|
| 484 | '("an" "a" "the")) |
|---|
| 485 | |
|---|
| 486 | (defun scan-for-more (s) |
|---|
| 487 | (let ((str (nth-value 1 (scan-to-strings "MORE\\W+((\\W|[A-Z0-9])+)([A-Z0-9])($|[^A-Z0-9])" s)))) |
|---|
| 488 | (or |
|---|
| 489 | (and str |
|---|
| 490 | (setf *more* (concatenate 'string (elt str 0) (elt str 2)))) |
|---|
| 491 | (let ((str (nth-value 1 (scan-to-strings "(?i)more\\W+(\\w+)\\W+(\\w+)\\W+(\\w+)" s)))) |
|---|
| 492 | (or |
|---|
| 493 | (and str |
|---|
| 494 | (or (member (elt str 0) *prepositions* :test #'string-equal) |
|---|
| 495 | (member (elt str 0) *conjunctions* :test #'string-equal) |
|---|
| 496 | (member (elt str 0) *articles* :test #'string-equal)) |
|---|
| 497 | (or (member (elt str 1) *prepositions* :test #'string-equal) |
|---|
| 498 | (member (elt str 1) *conjunctions* :test #'string-equal) |
|---|
| 499 | (member (elt str 1) *articles* :test #'string-equal)) |
|---|
| 500 | (setf *more* (string-upcase |
|---|
| 501 | (concatenate 'string (elt str 0) " " (elt str 1) |
|---|
| 502 | " " (elt str 2))))) |
|---|
| 503 | (let ((str (nth-value 1 (scan-to-strings "(?i)more\\W+(\\w+)\\W+(\\w+)" s)))) |
|---|
| 504 | (or |
|---|
| 505 | (and str |
|---|
| 506 | (or (member (elt str 0) *prepositions* :test #'string-equal) |
|---|
| 507 | (member (elt str 0) *conjunctions* :test #'string-equal) |
|---|
| 508 | (member (elt str 0) *articles* :test #'string-equal)) |
|---|
| 509 | (setf *more* (string-upcase |
|---|
| 510 | (concatenate 'string (elt str 0) " " (elt str 1))))) |
|---|
| 511 | (let ((str (nth-value 1 (scan-to-strings "(?i)more\\W+(\\w+)" s)))) |
|---|
| 512 | (or |
|---|
| 513 | (and str (setf *more* (string-upcase (elt str 0)))) |
|---|
| 514 | ))))))))) |
|---|
| 515 | |
|---|
| 516 | (defun cliki-lookup (term-with-question &key sender channel) |
|---|
| 517 | (let ((first-pass (regex-replace-all "^(\\s*)(.*[^?.!,;])([?.!,;]*)$" term-with-question "\\2")) |
|---|
| 518 | (should-send-cant-find t)) |
|---|
| 519 | (setf first-pass (regex-replace-all "\\s\\s+" first-pass " ")) |
|---|
| 520 | (setf first-pass (regex-replace-all "\\s*$" first-pass "")) |
|---|
| 521 | (let ((scanned (or (nth-value 1 (scan-to-strings "^add\\s+\"(.+)\"\\s+as:*\\s+(.+)$" first-pass)) |
|---|
| 522 | (nth-value 1 (scan-to-strings "^add\\s+(.+)\\s+as:*\\s+(.+)$" first-pass))))) |
|---|
| 523 | (if scanned |
|---|
| 524 | (let ((term (elt scanned 0)) |
|---|
| 525 | (defn (elt scanned 1))) |
|---|
| 526 | (add-small-definition term defn) |
|---|
| 527 | "OK, done.") |
|---|
| 528 | (let ((scanned (or |
|---|
| 529 | (nth-value 1 (scan-to-strings "^alias\\s+\"([^\"]+)\"\\s+as:*\\s+(.+)$" first-pass)) |
|---|
| 530 | (nth-value 1 (scan-to-strings "^alias\\s+(.+)\\s+as:*\\s+(.+)$" first-pass)) |
|---|
| 531 | (nth-value 1 (scan-to-strings "^(.+)\\s+is\\s+another\\s+(name|word)\\s+for:*\\s+([^.]+)\\.*$" first-pass))))) |
|---|
| 532 | (if scanned |
|---|
| 533 | (let ((term (elt scanned 0)) |
|---|
| 534 | (defn (elt scanned (1- (length scanned))))) |
|---|
| 535 | (add-alias term defn) |
|---|
| 536 | "OK, done.") |
|---|
| 537 | (progn |
|---|
| 538 | (setf first-pass (regex-replace-all "(:|/|\\\\|\\#)" first-pass "")) |
|---|
| 539 | (setf first-pass (regex-replace-all "^(?i)(.*[^, ])(,|)\\s*please$" first-pass "\\1")) |
|---|
| 540 | (setf first-pass (regex-replace-all "^(?i)please(,|)\\s*(.*[^, ])$" first-pass "\\2")) |
|---|
| 541 | (when (and (scan "^(?i)lisppaste(\\s|!|\\?|\\.|$)*" first-pass) |
|---|
| 542 | (find-package :lisppaste) |
|---|
| 543 | channel |
|---|
| 544 | (> (length channel) 0) |
|---|
| 545 | (char= (elt channel 0) #\#) |
|---|
| 546 | (funcall (intern "IRC-SAY-HELP" :lisppaste) |
|---|
| 547 | channel)) |
|---|
| 548 | (return-from cliki-lookup nil)) |
|---|
| 549 | (or |
|---|
| 550 | |
|---|
| 551 | (if (string-equal first-pass "help") |
|---|
| 552 | (if (should-do-lookup first-pass (or channel sender "")) |
|---|
| 553 | (progn |
|---|
| 554 | (did-lookup first-pass (or channel sender "")) |
|---|
| 555 | (cliki-bot-help *cliki-nickname*)) |
|---|
| 556 | (setf should-send-cant-find nil))) |
|---|
| 557 | (let ((strings (nth-value 1 (scan-to-strings "^(?i)help\\s+(on|about|to|describing|)\\s*\"*([^\"]+)\"*$" first-pass)))) |
|---|
| 558 | (if strings |
|---|
| 559 | (if |
|---|
| 560 | (should-do-lookup first-pass (or channel sender "")) |
|---|
| 561 | (progn |
|---|
| 562 | (did-lookup first-pass (or channel sender "")) |
|---|
| 563 | (cliki-find-help (elt strings 1))) |
|---|
| 564 | (setf should-send-cant-find nil)))) |
|---|
| 565 | (let ((strings (nth-value 1 (scan-to-strings "^(?i)(memo|note)\\s+(for|to)\\s+(\\S+)\\s*[:,]+\\s+(.+)$" term-with-question)))) |
|---|
| 566 | (when (and sender strings) |
|---|
| 567 | (if (string-equal (without-non-alphanumeric |
|---|
| 568 | (elt strings 2)) |
|---|
| 569 | (without-non-alphanumeric |
|---|
| 570 | *cliki-nickname*)) |
|---|
| 571 | "Buzz off." |
|---|
| 572 | (progn |
|---|
| 573 | (add-memo |
|---|
| 574 | sender |
|---|
| 575 | (if (member (elt strings 2) '("self" "myself" "me") :test #'string-equal) |
|---|
| 576 | sender |
|---|
| 577 | (elt strings 2)) |
|---|
| 578 | (elt strings 3)) |
|---|
| 579 | (format nil "Remembered. I'll tell ~A when he/she/it next speaks." (elt strings 2)))))) |
|---|
| 580 | (when (and sender |
|---|
| 581 | (scan "^(?i)(discard|forget)\\s+(my\\s+|)memo(s|)$" first-pass)) |
|---|
| 582 | (let ((count (remove-memos sender))) |
|---|
| 583 | (case count |
|---|
| 584 | (0 "You didn't have any memos!") |
|---|
| 585 | (1 "OK, I threw it out.") |
|---|
| 586 | (t "OK, I threw them out.")))) |
|---|
| 587 | (let ((strings (nth-value 1 (scan-to-strings "^(?i)(discard|forget)\\s+(my\\s+|)memo(s|)\\s+from\\s+([^ .]+)\\.*$" first-pass)))) |
|---|
| 588 | (when (and sender |
|---|
| 589 | strings) |
|---|
| 590 | (let ((count (remove-memos sender :from (elt strings 3)))) |
|---|
| 591 | (case count |
|---|
| 592 | (0 "You didn't have any memos!") |
|---|
| 593 | (1 "OK, I threw it out.") |
|---|
| 594 | (t "OK, I threw them out."))) |
|---|
| 595 | )) |
|---|
| 596 | (let ((to-forget (nth-value 1 (scan-to-strings "^forget\\s+([^.]+)\\.*$" first-pass)))) |
|---|
| 597 | (when to-forget |
|---|
| 598 | (forget (elt to-forget 0)) |
|---|
| 599 | (format nil "What's ~A? Never heard of it." (elt to-forget 0)))) |
|---|
| 600 | (let ((strs (nth-value 1 (scan-to-strings "^(?i)paste\\s+(\\d+)$" first-pass)))) |
|---|
| 601 | (and strs |
|---|
| 602 | (lookup-paste (parse-integer (elt strs 0))))) |
|---|
| 603 | (let ((strings |
|---|
| 604 | (or |
|---|
| 605 | (aif |
|---|
| 606 | (nth-value 1 (scan-to-strings "^(?i)(direct|tell|show|inform|teach|give)\\s+(\\S+)\\s+(about|on|in|to|through|for|some|)\\s*(.+)$" first-pass)) |
|---|
| 607 | (cons :forward it)) |
|---|
| 608 | (aif |
|---|
| 609 | (nth-value 1 (scan-to-strings "^(?i)(look\\s+up\\s+|say|)\\s*(.+)\\s+(for|to|at)\\s+(\\S+)$" first-pass)) |
|---|
| 610 | (cons :backward it)) |
|---|
| 611 | ))) |
|---|
| 612 | (if strings |
|---|
| 613 | (let* ((term (case (car strings) |
|---|
| 614 | (:forward (elt (cdr strings) 3)) |
|---|
| 615 | (:backward (elt (cdr strings) 1)))) |
|---|
| 616 | (person (case (car strings) |
|---|
| 617 | (:forward (elt (cdr strings) 1)) |
|---|
| 618 | (:backward (elt (cdr strings) 3)))) |
|---|
| 619 | (person (if (string-equal person "me") |
|---|
| 620 | (or sender channel "you") |
|---|
| 621 | person)) |
|---|
| 622 | (do-concatenate t) |
|---|
| 623 | (about |
|---|
| 624 | (handler-bind |
|---|
| 625 | ((lookup-failure |
|---|
| 626 | #'(lambda (c) |
|---|
| 627 | (setf do-concatenate nil)))) |
|---|
| 628 | (cliki-lookup term :sender sender |
|---|
| 629 | :channel channel)))) |
|---|
| 630 | (if about |
|---|
| 631 | (if do-concatenate |
|---|
| 632 | (format nil "~A: ~A~A" |
|---|
| 633 | person |
|---|
| 634 | (if (scan "http:" about) |
|---|
| 635 | (concatenate 'string |
|---|
| 636 | (random-element |
|---|
| 637 | '("have a look at" |
|---|
| 638 | "please look at" |
|---|
| 639 | "please see" |
|---|
| 640 | "direct your attention towards" |
|---|
| 641 | "look at")) |
|---|
| 642 | " ") |
|---|
| 643 | "") |
|---|
| 644 | about) |
|---|
| 645 | about) |
|---|
| 646 | (setf should-send-cant-find nil))))) |
|---|
| 647 | (if (scan "^(?i)hello(\\s|$)*" first-pass) "what's up?") |
|---|
| 648 | (if (scan "^(?i)hi(\\s|$)*" first-pass) "what's up?") |
|---|
| 649 | (if (scan "^(?i)yo(\\s|$)*" first-pass) "what's up?") |
|---|
| 650 | (if (scan "^(?i)thank(s| you)(\\s|!|\\?|\\.|$)*" first-pass) |
|---|
| 651 | (random-element |
|---|
| 652 | '("you're welcome" |
|---|
| 653 | "no problem" |
|---|
| 654 | "np"))) |
|---|
| 655 | (if (scan "^(?i)version(\\s|!|\\?|\\.|$)*" first-pass) |
|---|
| 656 | (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))) |
|---|
| 657 | (if (scan "^(?i)(?i)do my bidding!*$" first-pass) "Yes, my master.") |
|---|
| 658 | (if (scan "^(?i)chant(\\s|!|\\?|\\.|$)*" first-pass) |
|---|
| 659 | (format nil "MORE ~A" *more*)) |
|---|
| 660 | (let ((str (nth-value 1 (scan-to-strings "^(?i)apropos\\s+(.+\\S)\\s*$" first-pass)))) |
|---|
| 661 | (and str |
|---|
| 662 | (cliki-apropos (elt str 0)))) |
|---|
| 663 | (if (scan "^(?i)advice$" first-pass) |
|---|
| 664 | (random-advice)) |
|---|
| 665 | (let ((str (nth-value 1 (scan-to-strings "^(?i)advise\\s+(for\\s+|)(\\S+)$" first-pass)))) |
|---|
| 666 | (and str |
|---|
| 667 | (format nil "~A: ~A" |
|---|
| 668 | (if (string-equal (elt str 1) "me") |
|---|
| 669 | (or sender channel "you") |
|---|
| 670 | (elt str 1)) |
|---|
| 671 | (random-advice)))) |
|---|
| 672 | (let ((str (nth-value 1 (scan-to-strings "^(?i)(any\\s+|some\\s+|)advi[cs]e\\s+(for\\s+|)(\\S+)\\s+(on|about)\\s+(.+)$" first-pass)))) |
|---|
| 673 | (and str |
|---|
| 674 | (format nil "~A: ~A" |
|---|
| 675 | (if (string-equal (elt str 2) "me") |
|---|
| 676 | (or sender channel "you") |
|---|
| 677 | (elt str 2)) |
|---|
| 678 | (search-advice (elt str 4))))) |
|---|
| 679 | (let ((str (nth-value 1 (scan-to-strings "^(?i)(any\\s+|some\\s+|)advi[cs]e\\s+(on|about)\\s+(.+)$" first-pass)))) |
|---|
| 680 | (and str |
|---|
| 681 | (search-advice (elt str 2)))) |
|---|
| 682 | (let ((str (nth-value 1 (scan-to-strings "^(?i)advice\\W+(\\d+)$" first-pass)))) |
|---|
| 683 | (and str |
|---|
| 684 | (lookup-advice (elt str 0)))) |
|---|
| 685 | (let ((str |
|---|
| 686 | (or |
|---|
| 687 | (nth-value 1 (scan-to-strings "^(?i)what\\s+does\\s+([a-zA-Z\"]+)\\s+(mean|stand\\s+for)$" first-pass)) |
|---|
| 688 | (nth-value 1 (scan-to-strings "^(?i)what\\s+([a-zA-Z\"]+)\\s+(means|stands\\s+for)$" first-pass))))) |
|---|
| 689 | (and str |
|---|
| 690 | (let ((letters (remove #\" (elt str 0)))) |
|---|
| 691 | (when (< (length letters) 9) |
|---|
| 692 | (without-abuse |
|---|
| 693 | (if (and (> (length letters) 2) |
|---|
| 694 | (string-equal (subseq letters (- (length letters) 2)) "cl")) |
|---|
| 695 | (steel-bazooka:steel-whatever :letters (string-downcase (subseq letters 0 (- (length letters) 2)))) |
|---|
| 696 | (steel-bazooka:steel-whatever :letters (string-downcase letters) :suffix nil))))))) |
|---|
| 697 | (let ((str (nth-value 1 (scan-to-strings "^(?i)shorten\\s+(\\w+://.+\\S)\\s*$" term-with-question)))) |
|---|
| 698 | (and str |
|---|
| 699 | (shorten (elt str 0)))) |
|---|
| 700 | (if (should-do-lookup first-pass (or channel sender "")) |
|---|
| 701 | (aif (or (small-definition-lookup first-pass) |
|---|
| 702 | (cliki-first-sentence first-pass) |
|---|
| 703 | (alias-lookup first-pass)) |
|---|
| 704 | (prog1 |
|---|
| 705 | (concatenate 'string first-pass ": " it) |
|---|
| 706 | (did-lookup first-pass (or channel sender "")))) |
|---|
| 707 | (setf should-send-cant-find nil)) |
|---|
| 708 | (if (and |
|---|
| 709 | should-send-cant-find |
|---|
| 710 | (or |
|---|
| 711 | (scan "(!|\\.|\\s.+\\?|\\)|\\()\\s*$" term-with-question) |
|---|
| 712 | (scan "^\\s*\\S+\\s+\\S+.*$" term-with-question))) |
|---|
| 713 | ;;(generate-text (+ 20 (random 6))) |
|---|
| 714 | (progn |
|---|
| 715 | (setf should-send-cant-find nil) |
|---|
| 716 | (do-eliza first-pass)) |
|---|
| 717 | ) |
|---|
| 718 | (when should-send-cant-find |
|---|
| 719 | (signal 'lookup-failure) |
|---|
| 720 | (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?" ""))) |
|---|
| 721 | )))))))) |
|---|
| 722 | |
|---|
| 723 | |
|---|
| 724 | |
|---|
| 725 | (defun valid-cliki-message (message) |
|---|
| 726 | (scan *cliki-attention-prefix* (car (last (arguments message))))) |
|---|
| 727 | |
|---|
| 728 | (defvar *respond-to-general-hellos* nil) |
|---|
| 729 | |
|---|
| 730 | (defun anybody-here (string) |
|---|
| 731 | (if *respond-to-general-hellos* |
|---|
| 732 | (or (scan "(?i)(anybody|aynbody|any body|anyone|aynone|any one|ne1|any1|n e 1|ne 1) (here|awake|there|home|know).*\\?*" string) |
|---|
| 733 | (scan "^(?i)\\s*(hello|hi|yo)\\s*(channel|room|people|ppl|all|peeps|)\\s*$" string)))) |
|---|
| 734 | |
|---|
| 735 | (defun msg-hook (message) |
|---|
| 736 | (handler-bind |
|---|
| 737 | ((serious-condition (lambda (c) |
|---|
| 738 | (format *trace-output* "Caught error: ~A~%" c) |
|---|
| 739 | #+nil (sb-debug:backtrace 10 *trace-output*) |
|---|
| 740 | (format *trace-output* "~A~%" |
|---|
| 741 | (nthcdr 10 (sb-debug:backtrace-as-list))) |
|---|
| 742 | (return-from msg-hook)))) |
|---|
| 743 | (progn |
|---|
| 744 | (scan-for-more (car (last (arguments message)))) |
|---|
| 745 | (let ((respond-to (if (string-equal (first (arguments message)) *cliki-nickname*) (source message) (first (arguments message))))) |
|---|
| 746 | (if (valid-cliki-message message) |
|---|
| 747 | (let ((response (cliki-lookup (regex-replace *cliki-attention-prefix* (car (last (arguments message))) "") :sender (source message) :channel (first (irc:arguments message))))) |
|---|
| 748 | (and response (privmsg *cliki-connection* respond-to response))) |
|---|
| 749 | (if (string-equal (first (arguments message)) *cliki-nickname*) |
|---|
| 750 | (aif (cliki-lookup (car (last (arguments message))) :sender (source message)) |
|---|
| 751 | (privmsg *cliki-connection* respond-to it)) |
|---|
| 752 | (if (anybody-here (car (last (arguments message)))) |
|---|
| 753 | (privmsg *cliki-connection* (first (arguments message)) (format nil "~A: hello." (source message)))))) |
|---|
| 754 | (take-care-of-memos respond-to (source message)))))) |
|---|
| 755 | |
|---|
| 756 | (defvar *cliki-nickserv-password* "") |
|---|
| 757 | |
|---|
| 758 | (defun notice-hook (message) |
|---|
| 759 | (if (and (string-equal (source message) "NickServ") |
|---|
| 760 | (scan "owned by someone else" (car (last (arguments message))))) |
|---|
| 761 | (privmsg *cliki-connection* (source message) (format nil "IDENTIFY ~A" *cliki-nickserv-password*)))) |
|---|
| 762 | |
|---|
| 763 | (defun rename-cliki (new-nick) |
|---|
| 764 | (setf *cliki-nickname* new-nick) |
|---|
| 765 | (nick *cliki-connection* new-nick) |
|---|
| 766 | (setf *cliki-attention-prefix* (make-cliki-attention-prefix new-nick))) |
|---|
| 767 | |
|---|
| 768 | (defun start-cliki-bot (nick server &rest channels) |
|---|
| 769 | (read-small-definitions) |
|---|
| 770 | (setf *cliki-nickname* nick) |
|---|
| 771 | (setf *cliki-connection* (connect :nickname *cliki-nickname* :server server)) |
|---|
| 772 | (setf *cliki-attention-prefix* (make-cliki-attention-prefix nick)) |
|---|
| 773 | (mapcar #'(lambda (channel) (join *cliki-connection* channel)) channels) |
|---|
| 774 | (add-hook *cliki-connection* 'irc::irc-privmsg-message 'msg-hook) |
|---|
| 775 | (add-hook *cliki-connection* 'irc::irc-notice-message 'notice-hook) |
|---|
| 776 | (start-background-message-handler *cliki-connection*)) |
|---|
| 777 | |
|---|
| 778 | (defun shuffle-hooks () |
|---|
| 779 | (irc::remove-hooks *cliki-connection* 'irc::irc-privmsg-message) |
|---|
| 780 | (add-hook *cliki-connection* 'irc::irc-privmsg-message 'msg-hook)) |
|---|
