-
Notifications
You must be signed in to change notification settings - Fork 51
/
circe-color-nicks.el
339 lines (285 loc) · 12.5 KB
/
circe-color-nicks.el
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
;;; circe-color-nicks.el --- Color nicks in the channel
;; Copyright (C) 2012 Taylan Ulrich Bayırlı/Kammer
;; Author: Taylan Ulrich Bayırlı/Kammer <[email protected]>
;; 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 (derived-mode-p 'circe-chat-mode)
(add-circe-color-nicks))))
(add-hook 'circe-chat-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 (derived-mode-p 'circe-chat-mode)
(remove-circe-color-nicks))))
(remove-hook 'circe-chat-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."
:type 'number
:group 'circe-color-nicks)
(defcustom circe-color-nicks-min-difference 17
"Minimum difference from each other for generated colors."
:type 'integer
:group 'circe-color-nicks)
(defcustom circe-color-nicks-min-fg-difference 17
"Minimum difference from foreground for generated colors."
:type 'integer
:group 'circe-color-nicks)
(defcustom circe-color-nicks-min-my-message-difference 0
"Minimum difference from own nick color for generated colors."
:type 'integer
: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.")
(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 (derived-mode-p 'circe-chat-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* ((conn (circe-server-process))
(channel (irc-connection-channel conn circe-chat-target))
(body (text-property-any (point-min) (point-max)
'lui-format-argument 'body)))
(when (and channel body)
(with-syntax-table circe-nick-syntax-table
(goto-char body)
(while (forward-word 1)
(let ((nick (thing-at-point 'word))
(blacklist circe-color-nicks-message-blacklist))
(when (and nick
(not (equal nick (circe-nick)))
(not (member nick blacklist))
(irc-channel-user channel nick))
(let ((bounds (bounds-of-thing-at-point 'word))
(color (circe-nick-color-for-nick nick)))
(add-face-text-property (car bounds) (cdr bounds)
`(: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