346 lines
13 KiB
EmacsLisp
346 lines
13 KiB
EmacsLisp
;;; circe-color-nicks.el --- Color nicks in the channel
|
||
|
||
;; Copyright (C) 2012 Taylan Ulrich Bayırlı/Kammer
|
||
|
||
;; Author: Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
|
||
|
||
;; This file is part of Circe.
|
||
|
||
;; This program is free software; you can redistribute it and/or
|
||
;; modify it under the terms of the GNU General Public License
|
||
;; as published by the Free Software Foundation; either version 3
|
||
;; of the License, or (at your option) any later version.
|
||
|
||
;; This program is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;; GNU General Public License for more details.
|
||
|
||
;; You should have received a copy of the GNU General Public License
|
||
;; along with this program; if not, write to the Free Software
|
||
;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
|
||
;; 02110-1301 USA
|
||
|
||
;;; Commentary:
|
||
|
||
;; This Circe module adds the ability to assign a color to each
|
||
;; nick in a channel.
|
||
|
||
;; Some ideas/code copied from rcirc-colors.el.
|
||
|
||
;; To use it, put the following into your .emacs:
|
||
|
||
;; (require 'circe-color-nicks)
|
||
;; (enable-circe-color-nicks)
|
||
|
||
;;; Code:
|
||
|
||
(require 'circe)
|
||
(require 'color)
|
||
(require 'cl-lib)
|
||
|
||
;;;###autoload
|
||
(defun enable-circe-color-nicks ()
|
||
"Enable the Color Nicks module for Circe.
|
||
This module colors all encountered nicks in a cross-server fashion."
|
||
(interactive)
|
||
(dolist (buf (buffer-list))
|
||
(with-current-buffer buf
|
||
(when (eq major-mode 'circe-channel-mode)
|
||
(add-circe-color-nicks))))
|
||
(add-hook 'circe-channel-mode-hook
|
||
'add-circe-color-nicks))
|
||
|
||
(defun disable-circe-color-nicks ()
|
||
"Disable the Color Nicks module for Circe.
|
||
See `enable-circe-color-nicks'."
|
||
(interactive)
|
||
(dolist (buf (buffer-list))
|
||
(with-current-buffer buf
|
||
(when (eq major-mode 'circe-channel-mode)
|
||
(remove-circe-color-nicks))))
|
||
(remove-hook 'circe-channel-mode-hook
|
||
'add-circe-color-nicks))
|
||
|
||
(defun add-circe-color-nicks ()
|
||
"Add `circe-color-nicks' to `lui-pre-output-hook'."
|
||
(add-hook 'lui-pre-output-hook 'circe-color-nicks))
|
||
|
||
(defun remove-circe-color-nicks ()
|
||
"Remove `circe-color-nicks' from `lui-pre-output-hook'."
|
||
(remove-hook 'lui-pre-output-hook 'circe-color-nicks))
|
||
|
||
|
||
(defgroup circe-color-nicks nil
|
||
"Nicks colorization for Circe"
|
||
:prefix "circe-color-nicks-"
|
||
:group 'circe)
|
||
|
||
(defcustom circe-color-nicks-min-contrast-ratio 7
|
||
"Minimum contrast ratio from background for generated colors;
|
||
recommended is 7:1, or at least 4.5:1 (7 stands for 7:1 here).
|
||
Lower value allows higher color spread, but could lead to less
|
||
readability."
|
||
:group 'circe-color-nicks)
|
||
|
||
(defcustom circe-color-nicks-min-difference 17
|
||
"Minimum difference from each other for generated colors."
|
||
:group 'circe-color-nicks)
|
||
|
||
(defcustom circe-color-nicks-min-fg-difference 17
|
||
"Minimum difference from foreground for generated colors."
|
||
:group 'circe-color-nicks)
|
||
|
||
(defcustom circe-color-nicks-min-my-message-difference 0
|
||
"Minimum difference from own nick color for generated colors."
|
||
:group 'circe-color-nicks)
|
||
|
||
(defcustom circe-color-nicks-everywhere nil
|
||
"Whether nicks should be colored in message bodies too."
|
||
:type 'boolean
|
||
:group 'circe-color-nicks)
|
||
|
||
(defcustom circe-color-nicks-message-blacklist nil
|
||
"Blacklist for nicks that shall never be highlighted inside
|
||
images."
|
||
:type '(repeat string)
|
||
:group 'circe-color-nicks)
|
||
|
||
(defcustom circe-color-nicks-pool-type 'adaptive
|
||
"Type of the color nick pool.
|
||
Must be one of the following:
|
||
|
||
'adaptive: Generate colors based on the current theme.
|
||
|
||
List of strings: Pick colors from the specified list of hex codes
|
||
or color names (see `color-name-rgb-alist')."
|
||
:type '(choice (const :tag "Adaptive" adaptive)
|
||
(repeat string))
|
||
:group 'circe-color-nicks)
|
||
|
||
|
||
;;; See http://www.w3.org/TR/2013/NOTE-WCAG20-TECHS-20130905/G18
|
||
|
||
(defsubst circe-w3-contrast-c-to-l (c)
|
||
(if (<= c 0.03928)
|
||
(/ c 12.92)
|
||
(expt (/ (+ c 0.055) 1.055) 2.4)))
|
||
|
||
(defsubst circe-w3-contrast-relative-luminance (rgb)
|
||
(apply #'+
|
||
(cl-mapcar (lambda (color coefficient)
|
||
(* coefficient
|
||
(circe-w3-contrast-c-to-l color)))
|
||
rgb
|
||
'(0.2126 0.7152 0.0722))))
|
||
|
||
(defsubst circe-w3-contrast-contrast-ratio (color1 color2)
|
||
(let ((l1 (+ 0.05 (circe-w3-contrast-relative-luminance color1)))
|
||
(l2 (+ 0.05 (circe-w3-contrast-relative-luminance color2))))
|
||
(if (> l1 l2)
|
||
(/ l1 l2)
|
||
(/ l2 l1))))
|
||
|
||
|
||
(defun circe-color-alist ()
|
||
"Return list of colors (name rgb lab) where rgb is 0 to 1."
|
||
(let ((alist (if (display-graphic-p)
|
||
color-name-rgb-alist
|
||
(mapcar (lambda (c)
|
||
(cons (car c) (cddr c)))
|
||
(tty-color-alist))))
|
||
(valmax (float (car (color-values "#ffffff")))))
|
||
(mapcar (lambda (c)
|
||
(let* ((name (car c))
|
||
(rgb (mapcar (lambda (v)
|
||
(/ v valmax))
|
||
(cdr c)))
|
||
(lab (apply #'color-srgb-to-lab rgb)))
|
||
(list name rgb lab)))
|
||
alist)))
|
||
|
||
(defun circe-color-canonicalize-format (color)
|
||
"Turns COLOR into (name rgb lab) format. Avoid calling this in
|
||
a loop, it's very slow on a tty!"
|
||
(let* ((name color)
|
||
(rgb (circe-color-name-to-rgb color))
|
||
(lab (apply #'color-srgb-to-lab rgb)))
|
||
(list name rgb lab)))
|
||
|
||
(defun circe-color-contrast-ratio (color1 color2)
|
||
"Gives the contrast ratio between two colors."
|
||
(circe-w3-contrast-contrast-ratio (nth 1 color1) (nth 1 color2)))
|
||
|
||
(defun circe-color-diff (color1 color2)
|
||
"Gives the difference between two colors per CIEDE2000."
|
||
(color-cie-de2000 (nth 2 color1) (nth 2 color2)))
|
||
|
||
(defun circe-color-name-to-rgb (color)
|
||
"Like `color-name-to-rgb' but also handles \"unspecified-bg\"
|
||
and \"unspecified-fg\"."
|
||
(cond ((equal color "unspecified-bg") '(0 0 0))
|
||
((equal color "unspecified-fg") '(1 1 1))
|
||
(t (color-name-to-rgb color))))
|
||
|
||
|
||
(defun circe-nick-color-appropriate-p (color bg fg my-msg)
|
||
"Tells whether COLOR is appropriate for being a nick color.
|
||
BG, FG, and MY-MSG are the background, foreground, and my-message
|
||
colors; these are expected as parameters instead of computed here
|
||
because computing them repeatedly is a heavy operation."
|
||
(and (>= (circe-color-contrast-ratio color bg)
|
||
circe-color-nicks-min-contrast-ratio)
|
||
(>= (circe-color-diff color fg)
|
||
circe-color-nicks-min-fg-difference)
|
||
(>= (circe-color-diff color my-msg)
|
||
circe-color-nicks-min-my-message-difference)))
|
||
|
||
(defun circe-nick-colors-delete-similar (colors)
|
||
"Return list COLORS with pairs of colors filtered out that are
|
||
too similar per `circe-color-nicks-min-difference'. COLORS may
|
||
be mutated."
|
||
(cl-mapl (lambda (rest)
|
||
(let ((color (car rest)))
|
||
(setcdr rest (cl-delete-if
|
||
(lambda (c)
|
||
(< (circe-color-diff color c)
|
||
circe-color-nicks-min-difference))
|
||
(cdr rest)))))
|
||
colors)
|
||
colors)
|
||
|
||
(defun circe-nick-color-generate-pool ()
|
||
"Return a list of appropriate nick colors."
|
||
(if (consp circe-color-nicks-pool-type)
|
||
circe-color-nicks-pool-type
|
||
(let ((bg (circe-color-canonicalize-format (face-background 'default)))
|
||
(fg (circe-color-canonicalize-format (face-foreground 'default)))
|
||
(my-msg (circe-color-canonicalize-format
|
||
(face-attribute
|
||
'circe-my-message-face :foreground nil 'default))))
|
||
(mapcar #'car (circe-nick-colors-delete-similar
|
||
(cl-remove-if-not
|
||
(lambda (c)
|
||
(circe-nick-color-appropriate-p c bg fg my-msg))
|
||
(circe-color-alist)))))))
|
||
|
||
(defun circe-nick-color-pool-test ()
|
||
"Display all appropriate nick colors in a temp buffer."
|
||
(interactive)
|
||
(switch-to-buffer (get-buffer-create "*Circe color test*"))
|
||
(erase-buffer)
|
||
(let ((pool (circe-nick-color-generate-pool)))
|
||
(while pool
|
||
(let ((pt (point)))
|
||
(insert "The quick brown fox jumped over the lazy dog.\n")
|
||
(put-text-property pt (point) 'face `(:foreground ,(pop pool)))))))
|
||
|
||
(defvar circe-nick-color-pool nil
|
||
"Pool of yet unused nick colors.")
|
||
|
||
(defvar circe-nick-color-mapping (make-hash-table :test 'equal)
|
||
"Hash-table from nicks to colors.")
|
||
|
||
(defun circe-nick-color-nick-list ()
|
||
"Return list of all nicks that have a color assigned to them.
|
||
Own and blacklisted nicks are excluded."
|
||
(let ((our-nick (circe-nick))
|
||
(channel-nicks (circe-channel-nicks))
|
||
nicks)
|
||
(maphash
|
||
(lambda (nick color)
|
||
(when (and (member nick channel-nicks)
|
||
(not (string= our-nick nick))
|
||
(not (member nick circe-color-nicks-message-blacklist)))
|
||
(push nick nicks)))
|
||
circe-nick-color-mapping)
|
||
nicks))
|
||
|
||
(defvar circe-nick-color-timestamps (make-hash-table :test 'equal)
|
||
"Hash-table from colors to the timestamp of their last use.")
|
||
|
||
(defun circe-nick-color-for-nick (nick)
|
||
"Return the color for NICK. Assigns a color to NICK if one
|
||
wasn't assigned already."
|
||
(let ((color (gethash nick circe-nick-color-mapping)))
|
||
(when (not color)
|
||
;; NOTE use this as entry point for taking NICK into account for
|
||
;; picking the new color
|
||
(setq color (circe-nick-color-pick))
|
||
(puthash nick color circe-nick-color-mapping))
|
||
(puthash color (float-time) circe-nick-color-timestamps)
|
||
color))
|
||
|
||
(defun circe-nick-color-pick ()
|
||
"Picks either a color from the pool of unused colors, or the
|
||
color that was used least recently (i.e. nicks that have it
|
||
assigned have been least recently active)."
|
||
(if (zerop (hash-table-count circe-nick-color-mapping))
|
||
(setq circe-nick-color-pool (circe-nick-color-generate-pool)))
|
||
(or (pop circe-nick-color-pool)
|
||
(circe-nick-color-pick-least-recent)))
|
||
|
||
(defun circe-nick-color-pick-least-recent ()
|
||
"Pick the color that was used least recently.
|
||
See `circe-nick-color-pick', which is where this is used."
|
||
(let ((least-recent-color nil)
|
||
(oldest-time (float-time)))
|
||
(maphash
|
||
(lambda (color time)
|
||
(if (< time oldest-time)
|
||
(progn
|
||
(setq least-recent-color color)
|
||
(setq oldest-time time))))
|
||
circe-nick-color-timestamps)
|
||
(if least-recent-color
|
||
least-recent-color
|
||
;; Someone must have messed with `circe-nick-color-mapping', recover by
|
||
;; re-filling the pool.
|
||
(setq circe-nick-color-pool (circe-nick-color-generate-pool))
|
||
(pop circe-nick-color-pool))))
|
||
|
||
(defun circe-color-nicks ()
|
||
"Color nicks on this lui output line."
|
||
(when (eq major-mode 'circe-channel-mode)
|
||
(let ((nickstart (text-property-any (point-min) (point-max)
|
||
'lui-format-argument 'nick)))
|
||
(when nickstart
|
||
(goto-char nickstart)
|
||
(let ((nickend (next-single-property-change nickstart
|
||
'lui-format-argument))
|
||
(nick (plist-get (plist-get (text-properties-at nickstart)
|
||
'lui-keywords)
|
||
:nick)))
|
||
(when (not (circe-server-my-nick-p nick))
|
||
(let ((color (circe-nick-color-for-nick nick)))
|
||
(add-face-text-property nickstart nickend
|
||
`(:foreground ,color)))))))
|
||
(when circe-color-nicks-everywhere
|
||
(let ((body (text-property-any (point-min) (point-max)
|
||
'lui-format-argument 'body)))
|
||
(when body
|
||
(with-syntax-table circe-nick-syntax-table
|
||
(goto-char body)
|
||
(let* ((nicks (circe-nick-color-nick-list))
|
||
(regex (regexp-opt nicks 'words)))
|
||
(let (case-fold-search)
|
||
(while (re-search-forward regex nil t)
|
||
(let* ((nick (match-string-no-properties 0))
|
||
(color (circe-nick-color-for-nick nick)))
|
||
(add-face-text-property (match-beginning 0) (match-end 0)
|
||
`(:foreground ,color))))))))))))
|
||
|
||
(defun circe-nick-color-reset ()
|
||
"Reset the nick color mapping (and some internal data).
|
||
|
||
This is useful if you switched between frames supporting
|
||
different color ranges and would like nicks to get new colors
|
||
appropriate to the new color range."
|
||
(interactive)
|
||
(setq circe-nick-color-pool (circe-nick-color-generate-pool))
|
||
(setq circe-nick-color-mapping (make-hash-table :test 'equal))
|
||
(setq circe-nick-color-timestamps (make-hash-table :test 'equal)))
|
||
|
||
(provide 'circe-color-nicks)
|
||
;;; circe-color-nicks.el ends here
|