From 1527bdbbc70c27adce3fa57e7226dffc62da7853 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Mon, 26 Jun 2023 06:18:50 -0700 Subject: [PATCH 0/1] *** NOT A PATCH *** *** BLURB HERE *** David Leatherman (1): [5.6] Add module for colorizing nicknames to ERC doc/misc/erc.texi | 4 + etc/ERC-NEWS | 8 + lisp/erc/erc-nicks.el | 632 +++++++++++++++++++++++++++++++ lisp/erc/erc.el | 1 + test/lisp/erc/erc-nicks-tests.el | 435 +++++++++++++++++++++ test/lisp/erc/erc-tests.el | 2 +- 6 files changed, 1081 insertions(+), 1 deletion(-) create mode 100644 lisp/erc/erc-nicks.el create mode 100644 test/lisp/erc/erc-nicks-tests.el Interdiff: diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el index 2977235b3a8..dd936af3835 100644 --- a/lisp/erc/erc-nicks.el +++ b/lisp/erc/erc-nicks.el @@ -155,6 +155,15 @@ erc-nicks-colors `erc-nicks-color-adjustments' to nil to prevent unwanted culling." :type '(choice (const all) (const defined) (list string))) +(defcustom erc-nicks-key-suffix-format "@%n" + "Template for latter portion of keys to generate colors from. +ERC passes this to `format-spec' with the following specifiers: +%n for the current network and %m for your nickname (not the one +being colorized). If you don't like the generated palette, try +adding extra characters or padding, for example, with something +like \"@%-012n\"." + :type 'string) + (defvar-local erc-nicks--face-table nil "Hash table mapping nicks to unique, named faces. Keys need not be valid nicks.") @@ -278,13 +287,13 @@ erc-nicks-ensaturate ((< s min) (setq color (color-hsl-to-rgb h min l))))) color) -;; From https://elpa.gnu.org/packages/ement. The resolution has been +;; From https://elpa.gnu.org/packages/ement. The bit depth has been ;; scaled up to try and avoid components being exactly 0.0, which our -;; contrast function doesn't seem to like. Hopefully, that's OK. -(defun erc-nicks--gen-color-ement (string) +;; contrast function doesn't seem to like. +(defun erc-nicks--gen-color (string) "Generate normalized RGB color from STRING." - (let* ((ratio (/ (float (abs (sxhash string))) (float most-positive-fixnum))) - (color-num (round (* (* #xffff #xffff #xffff) ratio)))) + (let* ((ratio (/ (float (abs (random string))) (float most-positive-fixnum))) + (color-num (round (* #xffffffffffff ratio)))) (list (/ (float (logand color-num #xffff)) #xffff) (/ (float (ash (logand color-num #xffff0000) -16)) #xffff) (/ (float (ash (logand color-num #xffff00000000) -32)) #xffff)))) @@ -340,10 +349,11 @@ erc-nicks--reduce (defvar-local erc-nicks--colors-len nil) (defvar-local erc-nicks--colors-pool nil) +(defvar erc-nicks--colors-rejects nil) -(defun erc-nicks--create-pool (adjustments colors &optional debug) +(defun erc-nicks--create-pool (adjustments colors) "Return COLORS that fall within parameters indicated by ADJUSTMENTS." - (let (addp capp satp pool rejects) + (let (addp capp satp pool) (dolist (adjustment adjustments) (pcase adjustment ((or 'erc-nicks-invert 'erc-nicks-add-contrast) (setq addp t)) @@ -358,39 +368,26 @@ erc-nicks--create-pool (s (cadr (apply #'color-rgb-to-hsl rgb)))) (or (< s (car erc-nicks-saturation-range)) (> s (cdr erc-nicks-saturation-range))))) - (when debug - (push color rejects)) + (when erc-nicks--colors-rejects + (push color erc-nicks--colors-rejects)) (push color pool)))) - (when-let - ((debug) - (cb (lambda (c) (message "contrast: %.3f :saturation: %.3f" - (erc-nicks--get-contrast c) - (cadr (apply #'color-rgb-to-hsl - (color-name-to-rgb c))))))) - (save-excursion - (when pool (list-colors-display pool "*erc-nicks-pool*" cb)) - (when rejects (list-colors-display rejects "*erc-nicks-rejects*" cb)))) (nreverse pool))) -(defun erc-nicks--init-pool (&optional debug) - (if (or (eq erc-nicks-colors 'all) (null erc-nicks-color-adjustments)) - (progn (setq erc-nicks--colors-pool nil - erc-nicks--colors-len nil) - (when debug - (erc-nicks-list-faces))) +(defun erc-nicks--init-pool () + "Initialize colors and optionally display faces or color palette." + (unless (eq erc-nicks-colors 'all) (let* ((colors (or (and (listp erc-nicks-colors) erc-nicks-colors) (defined-colors))) - (pool (erc-nicks--create-pool erc-nicks-color-adjustments colors - debug))) + (pool (erc-nicks--create-pool erc-nicks-color-adjustments colors))) (setq erc-nicks--colors-pool pool erc-nicks--colors-len (length pool))))) (defun erc-nicks--determine-color (key) (if (eq erc-nicks-colors 'all) - (erc-nicks--reduce (erc-nicks--gen-color-ement key)) + (erc-nicks--reduce (erc-nicks--gen-color key)) (let ((pool (erc-with-server-buffer erc-nicks--colors-pool)) (len (erc-with-server-buffer erc-nicks--colors-len))) - (nth (% (abs (sxhash key)) len) pool)))) + (nth (% (abs (random key)) len) pool)))) (defun erc-nicks--get-face (nick key) "Retrieve a face for trimmed and downcased NICK. @@ -449,13 +446,15 @@ erc-nicks--trim `(: (+ (any ,erc-nicks-ignore-chars)) eot))) nickname))) -(defvar erc-nicks--key-function #'erc-nicks--gen-key-with-network +(defvar erc-nicks--key-function #'erc-nicks--gen-key-from-format-spec "Function for generating a key to determine nick color. Called with a trimmed and case-mapped nickname.") -(defun erc-nicks--gen-key-with-network (nickname) - "Generate key for NICKNAME with @network suffix." - (concat nickname (and erc-network "@") (and erc-network (erc-network-name)))) +(defun erc-nicks--gen-key-from-format-spec (nickname) + "Generate key for NICKNAME according to `erc-nicks-key-suffix-format'." + (concat nickname (format-spec erc-nicks-key-suffix-format + `((?n . ,(erc-network)) + (?m . ,(erc-current-nick)))))) (defun erc-nicks--highlight (nickname &optional base-face) "Return face for NICKNAME unless it or BASE-FACE is blacklisted." @@ -479,7 +478,7 @@ erc-nicks--highlight-button 'font-lock-face)) (nick (erc-server-user-nickname (erc-button--nick-user nick-object))) (out (erc-nicks--highlight nick face))) - (setf (erc-button--nick-erc-button-nickname-face nick-object) out)) + (setf (erc-button--nick-nickname-face nick-object) out)) nick-object) (define-erc-module nicks nil @@ -600,12 +599,33 @@ erc-nicks-refresh (user-error "Not an ERC buffer")) (erc-with-server-buffer (unless erc-nicks-mode (user-error "Module `nicks' disabled")) - (erc-nicks--init-pool debug) - (dolist (nick (hash-table-keys erc-nicks--face-table)) - ;; User-tuned faces do not have an `erc-nicks--key' property. - (when-let* ((face (gethash nick erc-nicks--face-table)) - (key (get face 'erc-nicks--key))) - (set-face-foreground face (erc-nicks--determine-color key)))))) + (let ((erc-nicks--colors-rejects (and debug (list t)))) + (erc-nicks--init-pool) + (dolist (nick (hash-table-keys erc-nicks--face-table)) + ;; User-tuned faces do not have an `erc-nicks--key' property. + (when-let* ((face (gethash nick erc-nicks--face-table)) + (key (get face 'erc-nicks--key))) + (setq key (funcall erc-nicks--key-function nick)) + (put face 'erc-nicks--key key) + (set-face-foreground face (erc-nicks--determine-color key)))) + (when debug + (if (eq erc-nicks-colors 'all) + (erc-nicks-list-faces) + (pcase-dolist (`(,name ,pool) + `(("*erc-nicks-pool*" ,erc-nicks--colors-pool) + ("*erc-nicks-rejects*" + ,(cdr (nreverse erc-nicks--colors-rejects))))) + (when (buffer-live-p (get-buffer name)) + (kill-buffer name)) + (when pool + (save-excursion + (list-colors-display + pool name + (lambda (c) + (message "contrast: %.3f :saturation: %.3f" + (erc-nicks--get-contrast c) + (cadr (apply #'color-rgb-to-hsl + (color-name-to-rgb c)))))))))))))) (provide 'erc-nicks) diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el index 052a4c6df70..ec6b351a2e7 100644 --- a/test/lisp/erc/erc-nicks-tests.el +++ b/test/lisp/erc/erc-nicks-tests.el @@ -413,4 +413,23 @@ erc-nicks-list-faces (when noninteractive (kill-buffer)))))))) +(ert-deftest erc-nicks--gen-key-from-format-spec () + (let ((erc-network 'OFTC) + (erc-nicks-key-suffix-format "@%-012n") + (erc-server-current-nick "tester")) + (should (equal (erc-nicks--gen-key-from-format-spec "bob") + "bob@OFTC00000000"))) + + (let ((erc-network 'Libera.Chat) + (erc-nicks-key-suffix-format "@%-012n") + (erc-server-current-nick "tester")) + (should (equal (erc-nicks--gen-key-from-format-spec "bob") + "bob@Libera.Chat0"))) + + (let* ((erc-network 'Libera.Chat) + (erc-nicks-key-suffix-format "@%n/%m") + (erc-server-current-nick "tester")) + (should (equal (erc-nicks--gen-key-from-format-spec "bob") + "bob@Libera.Chat/tester")))) + ;;; erc-nicks-tests.el ends here -- 2.40.1