[beirc-cvs] CVS beirc
afuchs
afuchs at common-lisp.net
Mon Mar 27 21:42:41 UTC 2006
Update of /project/beirc/cvsroot/beirc
In directory clnet:/tmp/cvs-serv9934
Modified Files:
beirc.asd message-display.lisp variables.lisp
Log Message:
Add Thomas Persson's color code interpretation patch. Also, add *filter-colors*
--- /project/beirc/cvsroot/beirc/beirc.asd 2006/03/24 21:19:43 1.8
+++ /project/beirc/cvsroot/beirc/beirc.asd 2006/03/27 21:42:41 1.9
@@ -6,7 +6,7 @@
(cl:in-package :beirc.system)
(defsystem :beirc
- :depends-on (:mcclim :cl-irc :split-sequence :tab-layout)
+ :depends-on (:mcclim :cl-irc :split-sequence :tab-layout :cl-ppcre)
:components ((:file "package")
(:file "variables" :depends-on ("package"))
(:file "events" :depends-on ("package"))
--- /project/beirc/cvsroot/beirc/message-display.lisp 2006/03/27 13:46:47 1.41
+++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/03/27 21:42:41 1.42
@@ -7,6 +7,29 @@
(defvar *current-message*)
+(defparameter *colors* `((0 . (:ink ,+white+))
+ (1 . (:ink ,+black+))
+ (2 . (:ink ,+blue+))
+ (3 . (:ink ,+green+))
+ (4 . (:ink ,+red+))
+ (5 . (:ink ,+brown+))
+ (6 . (:ink ,+purple+))
+ (7 . (:ink ,+orange+))
+ (8 . (:ink ,+yellow+))
+ (9 . (:ink ,+light-green+))
+ (10 . (:ink ,+dark-cyan+))
+ (11 . (:ink ,+cyan+))
+ (12 . (:ink ,+royal-blue+))
+ (13 . (:ink ,+pink+))
+ (14 . (:ink ,+grey+))
+ (15 . (:ink ,+light-grey+))
+ ("" . (normal))
+ (" " . (underline))
+ ("" . (inverse))
+ ("" . (bold))))
+
+(defparameter *color-scanner* (cl-ppcre:create-scanner "[0-9]{1,2}(,[0-9]{1,2}){0,1}||| |"))
+
(define-presentation-type url ()
:inherit-from 'string)
@@ -124,32 +147,138 @@
(string first-char)))
(otherwise (values word ""))))))
+(defun extract-color (string)
+ (multiple-value-bind (start end)
+ (cl-ppcre:scan *color-scanner*
+ string)
+ (if start
+ (let* ((message (subseq string end))
+ (color-code (subseq string start end))
+ (color-code (or (cl-ppcre:all-matches-as-strings "[0-9]{1,2}"
+ color-code)
+ (list (cl-ppcre:scan-to-strings "|| |"
+ color-code))))
+ (foreground (or (parse-integer (car color-code)
+ :junk-allowed t)
+ (car color-code)))
+ (background (when (cadr color-code)
+ (parse-integer (cadr color-code)
+ :junk-allowed t)))
+ (foreground (cdr (assoc foreground
+ *colors*
+ :test #'equal)))
+ (background (cdr (assoc background
+ *colors*
+ :test #'equal))))
+ (values message
+ foreground
+ background
+ ))
+ string)))
+
+(defun split-before (delimiter string)
+ (let ((matches (cl-ppcre:all-matches delimiter string)))
+ (if matches
+ (loop for (a b c) on matches by #'cddr
+ collecting (subseq string a c) into strings
+ finally (return (if (zerop (car matches))
+ strings
+ (cons (subseq string
+ 0
+ (car matches))
+ strings))))
+ (list string))))
+
+(defmacro do-colored-string ((string-var str) &body body)
+ `(dolist (part (split-before *color-scanner* ,str))
+ (multiple-value-bind (message foreground background)
+ (extract-color part)
+ (cond (*filter-colors* nil)
+ ((equal (car foreground)
+ 'normal)
+ (setf foreground-color +black+
+ background-color +white+))
+ ((equal (car foreground)
+ :ink)
+ (setf foreground-color
+ (cadr foreground))
+ (when background
+ (setf background-color (cadr background))))
+ ((equal (car foreground)
+ 'bold)
+ (setf bold (if bold nil :bold)))
+ ((equal (car foreground)
+ 'underline)
+ (setf underline (not underline)))
+ ((equal (car foreground)
+ 'inverse)
+ (setf inverse (not inverse))))
+ (with-drawing-options (t :text-face bold)
+ (let ((,string-var message))
+ (if inverse
+ (with-irc-colors (background-color foreground-color underline)
+ , at body)
+ (with-irc-colors (foreground-color background-color underline)
+ , at body)))))))
+
+(defmacro with-irc-colors ((foreground background underlinep) &body body)
+ `(with-sheet-medium (medium *standard-output*)
+ (let ((record (with-new-output-record (t)
+ (with-drawing-options (t :ink ,foreground)
+ , at body))))
+ (with-bounding-rectangle* (left top right bottom)
+ record
+ (unless (equal left right)
+ (unless (equal ,background +white+)
+ (with-identity-transformation (medium)
+ (draw-rectangle* *standard-output*
+ left
+ top
+ right
+ bottom
+ :filled t
+ :ink ,background)
+ (replay-output-record record *standard-output*)
+ (setf (stream-cursor-position *standard-output*)
+ (values right top))))
+ (when ,underlinep
+ (draw-line* *standard-output* left (- bottom 1)
+ (- right 1) (- bottom 1)
+ :ink ,foreground)))
+ record))))
+
(defun format-message* (mumble &key (limit *default-fill-column*) (start-length 0))
- (loop for (word . rest) on (split-sequence:split-sequence #\Space mumble)
- with column = start-length
- do (incf column (length word))
- when (> column limit)
- do (setf column (length word))
- (terpri)
- do (multiple-value-bind (%word stripped-preceding-punctuation) (strip-preceding-punctuation word)
- (multiple-value-bind (word% stripped-punctuation) (strip-punctuation %word)
- (write-string stripped-preceding-punctuation)
- (cond
- ((or (search "http://" word%) (search "https://" word%))
- (present-url word%))
- ((or
- (nick-equals-my-nick-p word% (irc:connection *current-message*))
- (and (current-connection *application-frame*)
- (irc:find-user (current-connection *application-frame*) word%)))
- (present word% 'nickname))
- ((channelp word%) (present word% 'channel))
- (t (write-string word%)))
- (write-string stripped-punctuation)))
- ;; TODO: more highlighting
- unless (or (null rest) (>= column limit))
- do (write-char #\Space)
- (incf column))
- (terpri))
+ (let ((foreground-color (medium-foreground *standard-output*))
+ (background-color (medium-background *standard-output*))
+ (bold nil)
+ (underline nil)
+ (inverse nil))
+ (let ((column start-length))
+ (loop for (word . rest) on (split-sequence:split-sequence #\Space mumble)
+ do (do-colored-string (word word)
+ (incf column (length word))
+ (when (> column limit)
+ (setf column (length word))
+ (terpri))
+ (multiple-value-bind (%word stripped-preceding-punctuation) (strip-preceding-punctuation word)
+ (multiple-value-bind (word% stripped-punctuation) (strip-punctuation %word)
+ (write-string stripped-preceding-punctuation)
+ (cond
+ ((or (search "http://" word%) (search "https://" word%))
+ (present-url word%))
+ ((or
+ (nick-equals-my-nick-p word% (irc:connection *current-message*))
+ (and (current-connection *application-frame*)
+ (irc:find-user (current-connection *application-frame*) word%)))
+ (present word% 'nickname))
+ ((channelp word%) (present word% 'channel))
+ (t (write-string word%)))
+ (write-string stripped-punctuation))))
+ do (unless (or (null rest) (>= column limit))
+ (do-colored-string (s " ")
+ (write-string s)
+ (incf column))))
+ (terpri))))
;;; privmsg-like messages
--- /project/beirc/cvsroot/beirc/variables.lisp 2006/03/27 13:46:47 1.13
+++ /project/beirc/cvsroot/beirc/variables.lisp 2006/03/27 21:42:41 1.14
@@ -49,4 +49,8 @@
*auto-close-inactive-query-windows-p*).")
(defvar *meme-log-bot-nick* "cmeme"
- "The name of the meme channel log bot")
\ No newline at end of file
+ "The name of the meme channel log bot")
+
+(defvar *filter-colors* nil
+ "If set to non-NIL, filter color, bold, inverse and underline
+codes from IRC messages.")
\ No newline at end of file
More information about the Beirc-cvs
mailing list