emacs/external/rcirc-nick-colors.el

   1 (defvar rcirc-colors
   2   (if (fboundp 'color-distance)
   3       (let ((min-distance (* 0.23 (color-distance "black" "white")))
   4             (bg (face-background 'default))
   5             (fg (face-foreground 'rcirc-my-nick))
   6             candidates)
   7         (dolist (item color-name-rgb-alist)
   8           (let ((color (car item)))
   9             (when (and (not (color-gray-p color))
  10                        (> (color-distance color bg) min-distance)
  11                        (> (color-distance color fg) min-distance))
  12               (setq candidates (cons color candidates)))))
  13         candidates)
  14     (delete (face-background 'default) (defined-colors)))
  15   "Colors to use for nicks in rcirc.
  16 By default, all the non-grey colors that are very different from
  17 the default background are candidates.  The minimum
  18 color-distance is half the distance between black and red as
  19 computed by `color-distance'.
  20
  21 To check out the list, evaluate (list-colors-display rcirc-colors).")
  22
  23 (defvar rcirc-color-mapping (make-hash-table :test 'equal)
  24   "Hash-map mapping nicks to color names.")
  25
  26 (eval-after-load 'rcirc
  27   '(defun rcirc-facify (string face)
  28      "Return a copy of STRING with FACE property added.
  29 Also add colors to other nicks based on `rcirc-colors'."
  30      (when (and (eq face 'rcirc-other-nick)
  31                 (not (string= string "")))
  32        (let ((color (gethash string rcirc-color-mapping)))
  33          (unless color
  34            (setq color (elt rcirc-colors (random (length rcirc-colors))))
  35            (puthash string color rcirc-color-mapping))
  36          (setq face `((foreground-color . ,color)))))
  37      (if face
  38          (propertize (or string "") 'face face 'rear-nonsticky t)
  39        string)))
  40
  41 (defadvice rcirc-mangle-text (after rcirc-mangle-text-color-nick activate)
  42   "Highlight nicks according to `rcirc-color-mapping'."
  43   (with-syntax-table rcirc-nick-syntax-table
  44     (maphash (lambda (nick color)
  45                (let ((face (cons 'foreground-color color)))
  46                  (rcirc-map-regexp (lambda (start end string)
  47                                      (add-text-properties
  48                                       start end `(face ,face rear-nonsticky t)
  49                                       text))
  50                                    (concat "\\b" (regexp-quote nick) "\\b")
  51                                    text)))
  52              rcirc-color-mapping)))
  53
  54 (eval-after-load 'rcirc
  55   '(defun-rcirc-command color (args)
  56      "Change one of the nick colors."
  57      (interactive)
  58      (setq args (split-string args))
  59      (rcirc-do-color (car args) (cadr args) process target)))
  60
  61 (defun rcirc-do-color (nick color process target)
  62   "Implement /COLOR."
  63   (if (not nick)
  64       (let (names)
  65         (maphash (lambda (key value)
  66                    (add-text-properties
  67                     0 (length key)
  68                     `(face ((foreground-color . ,value)) help-echo ,value)
  69                     key)
  70                    (setq names (cons key names)))
  71                  rcirc-color-mapping)
  72         (rcirc-print process (rcirc-nick process) "NOTICE" target
  73                      (mapconcat 'identity names " ")))
  74     (unless color
  75       (error "Use what color?"))
  76     (puthash nick color rcirc-color-mapping)))
  77
  78 (defadvice rcirc-handler-NICK (before rcirc-handler-NICK-colors activate)
  79   "Update colors in `rcirc-color-mapping'."
  80   (let* ((old-nick (rcirc-user-nick sender))
  81          (color (gethash old-nick rcirc-color-mapping))
  82          (new-nick (car args)))
  83     ;; don't delete the old mapping
  84     (puthash new-nick color rcirc-color-mapping)))