unofficial mirror of bug-gnu-emacs@gnu.org 
 help / color / mirror / code / Atom feed
From: "J.P." <jp@neverwas.me>
To: 63569@debbugs.gnu.org
Cc: emacs-erc@gnu.org
Subject: bug#63569: 30.0.50; ERC 5.6: Add automatic nickname highlighting to ERC
Date: Mon, 26 Jun 2023 06:44:40 -0700	[thread overview]
Message-ID: <87jzvq1gon.fsf@neverwas.me> (raw)
In-Reply-To: <87wmzu8fjg.fsf@neverwas.me> (J. P.'s message of "Fri, 23 Jun 2023 06:38:27 -0700")

[-- Attachment #1: Type: text/plain, Size: 222 bytes --]

v7. Adapt to change in `buttons' interface. Rework refresh command's
"debug" feature for user-provided color pools. Use `random' instead of
`sxhash' for generating colors. Add option for controlling suffix of
color keys.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0000-v6-v7.diff --]
[-- Type: text/x-patch, Size: 9977 bytes --]

From 1527bdbbc70c27adce3fa57e7226dffc62da7853 Mon Sep 17 00:00:00 2001
From: "F. Jason Park" <jp@neverwas.me>
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


[-- Attachment #3: 0001-5.6-Add-module-for-colorizing-nicknames-to-ERC.patch --]
[-- Type: text/x-patch, Size: 53758 bytes --]

From 1527bdbbc70c27adce3fa57e7226dffc62da7853 Mon Sep 17 00:00:00 2001
From: David Leatherman <leathekd@gmail.com>
Date: Sun, 18 Dec 2022 19:01:40 -0800
Subject: [PATCH 1/1] [5.6] Add module for colorizing nicknames to ERC

* doc/misc/erc.texi: Add `nicks' to module lineup.
* etc/ERC-NEWS: Mention new module `nicks'.
* lisp/erc/erc-nicks.el: New file.
* lisp/erc/erc.el: (erc-modules): Add `nicks'.
* test/lisp/erc/erc-nicks-tests.el: New file.
* test/lisp/erc/erc-tests (erc-tests--modules): Add
`nicks'.  (Bug#63569)

Co-authored-by: Andy Stewart <lazycat.manatee@gmail.com>
---
 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

diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi
index ddfdb2e2b64..a67dcb3da7c 100644
--- a/doc/misc/erc.texi
+++ b/doc/misc/erc.texi
@@ -459,6 +459,10 @@ Modules
 @item netsplit
 Detect netsplits
 
+@cindex modules, nicks
+@item nicks
+Automatically colorize nicks
+
 @cindex modules, noncommands
 @item noncommands
 Don't display non-IRC commands after evaluation
diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS
index 68cf0e2d6ca..658665f9d86 100644
--- a/etc/ERC-NEWS
+++ b/etc/ERC-NEWS
@@ -30,6 +30,14 @@ helper called 'erc-fill-wrap-nudge' allows for dynamic "refilling" of
 buffers on the fly.  Set 'erc-fill-function' to 'erc-fill-wrap' to get
 started.
 
+** A new module for nickname highlighting has joined ERC.
+Automatic nickname coloring has come to ERC core.  Users familiar with
+'erc-hl-nicks', from which this module directly descends, will already
+be familiar with its suite of handy options.  By default, each
+nickname in an ERC session receives a unique face with a unique (or
+evenly dealt) foreground color.  Add 'nicks' to 'erc-modules' to get
+started.
+
 ** A unified interactive entry point.
 New users are often dismayed to discover that M-x ERC doesn't connect
 to its default network, Libera.Chat, over TLS.  Though perhaps a
diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el
new file mode 100644
index 00000000000..dd936af3835
--- /dev/null
+++ b/lisp/erc/erc-nicks.el
@@ -0,0 +1,632 @@
+;;; erc-nicks.el -- Nick colors for ERC  -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2023 Free Software Foundation, Inc.
+
+;; Author: David Leatherman <leathekd@gmail.com>
+;;         Andy Stewart <lazycat.manatee@gmail.com>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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.
+
+;; GNU Emacs 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 GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file provides the `nicks' module for automatic nickname
+;; highlighting.  Add `nicks' to `erc-modules' to get started.
+;;
+;; Use the command `erc-nicks-refresh' to review changes after
+;; adjusting an option, like `erc-nicks-contrast-range'.  To change
+;; the color of a nickname in a target buffer, click on it and choose
+;; "Edit face" from the completion interface, and then perform your
+;; adjustments in the resulting Customize menu.  Non-Customize users
+;; can persist changes permanently by clicking on the face's
+;; "location" hyperlink and copying the generated code snippet
+;; (`defface' or `use-package') to their init.el.  Customize users
+;; need only click "Apply and Save", as usual.
+
+;;; History:
+
+;; This module has enjoyed a number of contributors across several
+;; variants over the years, including:
+;;
+;;   Thibault Polge <thibault@thb.lt>,
+;;   Jay Kamat <jaygkamat@gmail.com>,
+;;   Alex Kost <alezost@gmail.com>
+;;
+;; To those not mentioned, your efforts are no less appreciated.
+
+;; 2023/05 - erc-nicks
+;;           Rewrite using internal API, and rebrand for ERC 5.6
+;; 2020/03 - erc-hl-nicks 1.3.4
+;;           Final release, see [1] for intervening history
+;; 2014/05 - erc-highlight-nicknames.el
+;;           Final release, see [2] for intervening history
+;; 2011/08 - erc-hl-nicks 1.0
+;;           Initial release forked from erc-highlight-nicknames.el
+;; 2008/12 - erc-highlight-nicknames.el
+;;           First release from Andy Stewart
+;; 2007/09 - erc-highlight-nicknames.el
+;;           Initial release by by André Riemann
+
+;; [1] <http://www.github.com/leathekd/erc-hl-nicks>
+;; [2] <https://www.emacswiki.org/emacs/ErcHighlightNicknames>
+
+;;; Code:
+
+(require 'erc-button)
+(require 'color)
+
+(defgroup erc-nicks nil
+  "Colorize nicknames in ERC buffers."
+  :package-version '(ERC . "5.6") ; FIXME sync on release
+  :group 'erc)
+
+(defcustom erc-nicks-ignore-chars ",`'_-"
+  "Trailing characters in a nick to ignore while highlighting.
+Value should be a string containing characters typically appended
+by IRC clients to secure a nickname after a rejection (see option
+`erc-nick-uniquifier').  A value of nil means don't trim
+anything."
+  :type '(choice (string :tag "Chars to trim")
+                 (const :tag "Don't trim" nil)))
+
+(defcustom erc-nicks-skip-nicks nil
+  "Nicks to avoid highlighting.
+ERC only considers this option during module activation, so users
+should adjust it before connecting."
+  :type '(repeat string))
+
+(defcustom erc-nicks-skip-faces '( erc-notice-face erc-current-nick-face
+                                   erc-my-nick-face erc-pal-face erc-fool-face)
+  "Faces to avoid highlighting atop."
+  :type  '(repeat symbol))
+
+(defcustom erc-nicks-backing-face erc-button-nickname-face
+  "Face to mix with generated one for emphasizing non-speakers."
+  :type '(choice face (const nil)))
+
+(defcustom erc-nicks-bg-color
+  (frame-parameter (selected-frame) 'background-color)
+  "Background color for calculating contrast.
+Set this explicitly when the background color isn't discoverable,
+which may be the case in terminal Emacs."
+  :type 'string)
+
+(defcustom erc-nicks-color-adjustments
+  '(erc-nicks-add-contrast erc-nicks-cap-contrast erc-nicks-ensaturate)
+  "Treatments applied to improve aesthetics or visibility.
+For example, the function `erc-nicks-invert' inverts a nick when
+it's too close to the background, and `erc-nicks-add-contrast'
+attempts to find a decent contrast ratio by brightening or
+darkening.  When `erc-nicks-colors' is set to the symbol
+`defined' or a user-provided list of colors, ERC uses this option
+as a guide for culling any colors that don't fall within
+`erc-nicks-contrast-range' or `erc-nicks-saturation-range', as
+appropriate.  For example, if `erc-nicks-cap-contrast' is present
+in this option's value, and a color's contrast exceeds the CDR of
+`erc-nicks-contrast-range', ERC will purge that color from its
+rolls when initializing this module.  Specify a value of nil to
+inhibit this process."
+  :type '(repeat
+          (choice (function-item :tag "Invert" erc-nicks-invert)
+                  (function-item :tag "Add contrast" erc-nicks-add-contrast)
+                  (function-item :tag "Cap contrast" erc-nicks-cap-contrast)
+                  (function-item :tag "Bound saturation" erc-nicks-ensaturate)
+                  function)))
+
+(defcustom erc-nicks-contrast-range '(4.3 . 12.5)
+  "Desired range of contrast as a cons of (MIN . MAX).
+When `erc-nicks-add-contrast' and/or `erc-nicks-invert' appear in
+`erc-nicks-color-adjustments', MIN specifies the minimum amount
+of contrast allowed between a buffer's background and its
+foreground colors.  Depending on the background, nicks may appear
+tinted in pastels or shaded with muted grays.  MAX works
+similarly for reducing contrast, but only when
+`erc-nicks-cap-contrast' is active.  Users with lighter
+backgrounds may want to lower MAX significantly.  Either value
+can range from 1.0 to 21.0(:1) but may produce unsatisfactory
+results toward either extreme."
+  :type '(cons float float))
+
+(defcustom erc-nicks-saturation-range '(0.2 . 0.8)
+  "Desired range for constraining saturation.
+Expressed as a cons of decimal proportions.  Only matters when
+`erc-nicks-ensaturate' appears in `erc-nicks-color-adjustments'."
+  :type '(cons float float))
+
+(defcustom erc-nicks-colors 'all
+  "Pool of colors.
+List colors as strings (hex or named) or, alternatively, a single
+symbol representing a set of colors, like that produced by the
+function `defined-colors', which ERC associates with the symbol
+`defined'.  Similarly, `all' tells ERC to use any 24-bit color.
+When specifying a list, users may want to set the option
+`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.")
+
+;; https://stackoverflow.com/questions/596216#answer-56678483
+(defun erc-nicks--get-luminance (color)
+  "Return relative luminance of COLOR.
+COLOR can be a list of normalized values or a name.  This is the
+same as the Y component returned by `color-srgb-to-xyz'."
+  (let ((out 0)
+        (coefficients '(0.2126 0.7152 0.0722))
+        (chnls (if (stringp color) (color-name-to-rgb color) color)))
+    (dolist (ch chnls out)
+      (cl-incf out (* (pop coefficients)
+                      (if (<= ch 0.04045)
+                          (/ ch 12.92)
+                        (expt (/ (+ ch 0.055) 1.055) 2.4)))))))
+
+(defvar-local erc-nicks--bg-luminance nil)
+
+(defun erc-nicks--get-contrast (fg &optional bg)
+  "Return a float between 1 and 21 for colors FG and BG.
+If FG or BG are floats, interpret them as luminance values."
+  (let* ((lum-fg (if (numberp fg) fg (erc-nicks--get-luminance fg)))
+         (lum-bg (if bg
+                     (if (numberp bg) bg (erc-nicks--get-luminance bg))
+                   (or erc-nicks--bg-luminance
+                       (setq erc-nicks--bg-luminance
+                             (erc-nicks--get-luminance erc-nicks-bg-color))))))
+    (when (< lum-fg lum-bg) (cl-rotatef lum-fg lum-bg))
+    (/ (+ 0.05 lum-fg) (+ 0.05 lum-bg))))
+
+(defvar-local erc-nicks--bg-mode-value nil)
+
+(defmacro erc-nicks--bg-mode ()
+  `(or erc-nicks--bg-mode-value
+       (setq erc-nicks--bg-mode-value
+             ,(cond ((fboundp 'frame--current-background-mode)
+                     '(frame--current-background-mode (selected-frame)))
+                    ((fboundp 'frame--current-backround-mode)
+                     '(frame--current-backround-mode (selected-frame)))
+                    (t
+                     '(frame-parameter (selected-frame) 'background-mode))))))
+
+(defvar erc-nicks--grad-steps 9)
+
+;; https://www.w3.org/TR/UNDERSTANDING-WCAG20/visual-audio-contrast-contrast.html
+;;
+;; TODO see implementation in https://elpa.gnu.org/packages/ement and
+;; maybe copy that instead.
+(defun erc-nicks--adjust-contrast (color target &optional decrease)
+  (let* ((lum-bg (or erc-nicks--bg-luminance
+                     (setq erc-nicks--bg-luminance
+                           (erc-nicks--get-luminance erc-nicks-bg-color))))
+         ;; Shouldn't this use the actual bg color instead of b+w?
+         (stop (if (eq (if decrease 'light 'dark) (erc-nicks--bg-mode))
+                   '(1.0 1.0 1.0)
+                 '(0.0 0.0 0.0)))
+         ;; From `color-gradient' in color.el
+         (r (nth 0 color))
+         (g (nth 1 color))
+         (b (nth 2 color))
+         (interval (float (1+ (expt 2 erc-nicks--grad-steps))))
+         (r-step (/ (- (nth 0 stop) r) interval))
+         (g-step (/ (- (nth 1 stop) g) interval))
+         (b-step (/ (- (nth 2 stop) b) interval))
+         (maxtries erc-nicks--grad-steps)
+         started)
+    ;; FIXME stop when sufficiently close instead of exhausting.
+    (while (let* ((lum-fg (erc-nicks--get-luminance (list r g b)))
+                  (darker (if (< lum-bg lum-fg) lum-bg lum-fg))
+                  (lighter (if (= darker lum-bg) lum-fg lum-bg))
+                  (cur (/ (+ 0.05 lighter) (+ 0.05 darker)))
+                  (scale (expt 2 maxtries)))
+             (cond ((if decrease (> cur target) (< cur target))
+                    (setq r (+ r (* r-step scale))
+                          g (+ g (* g-step scale))
+                          b (+ b (* b-step scale))))
+                   (started
+                    (setq r (- r (* r-step scale))
+                          g (- g (* g-step scale))
+                          b (- b (* b-step scale))))
+                   (t (setq maxtries 1)))
+             (unless started
+               (setq started t))
+             (setq r (min 1.0 (max 0 r))
+                   g (min 1.0 (max 0 g))
+                   b (min 1.0 (max 0 b)))
+             (not (zerop (cl-decf maxtries)))))
+    (list r g b)))
+
+(defun erc-nicks-add-contrast (color)
+  "Increase COLOR's contrast by blending it with white or black.
+Unless sufficient contrast exists between COLOR and the
+background, raise it to somewhere around the lower bound of
+`erc-nicks-contrast-range'."
+  (erc-nicks--adjust-contrast color (car erc-nicks-contrast-range)))
+
+(defun erc-nicks-cap-contrast (color)
+  "Reduce COLOR's contrast by blending it with white or black.
+If excessive contrast exists between COLOR and the background,
+lower it to the upper bound of `erc-nicks-contrast-range'."
+  (erc-nicks--adjust-contrast color (cdr erc-nicks-contrast-range) 'remove))
+
+(defun erc-nicks-invert (color)
+  "Invert COLOR based on the CAR of `erc-nicks-contrast-range'.
+Don't bother if the inverted color has less contrast than the
+input."
+  (if-let ((con-input (erc-nicks--get-contrast color))
+           ((< con-input (car erc-nicks-contrast-range)))
+           (flipped (mapcar (lambda (c) (- 1.0 c)) color))
+           ((> (erc-nicks--get-contrast flipped) con-input)))
+      flipped
+    color))
+
+(defun erc-nicks-ensaturate (color)
+  "Ensure COLOR falls within `erc-nicks-saturation-range'."
+  (pcase-let ((`(,min . ,max) erc-nicks-saturation-range)
+              (`(,h ,s ,l) (apply #'color-rgb-to-hsl color)))
+    (cond ((> s max) (setq color (color-hsl-to-rgb h max l)))
+          ((< s min) (setq color (color-hsl-to-rgb h min l)))))
+  color)
+
+;; 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.
+(defun erc-nicks--gen-color (string)
+  "Generate normalized RGB color from STRING."
+  (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))))
+
+(defvar-local erc-nicks--custom-keywords '(:group erc-nicks :group erc-faces))
+
+;; This doesn't add an entry to the face table because "@" faces are
+;; interned in the global `obarray' and thus easily accessible.
+(defun erc-nicks--revive (new-face old-face nick net)
+  (put new-face 'erc-nicks--custom-face t)
+  (put new-face 'erc-nicks--nick nick)
+  (put new-face 'erc-nicks--netid erc-networks--id)
+  (put old-face 'erc-nicks--key nil)
+  (apply #'custom-declare-face new-face (face-user-default-spec old-face)
+         (format "Persistent `erc-nicks' color for %s on %s." nick net)
+         erc-nicks--custom-keywords))
+
+(defun erc-nicks--create-defface-template (face)
+  (pop-to-buffer (get-buffer-create (format "*New face %s*" face)))
+  (erase-buffer)
+  (lisp-interaction-mode)
+  (insert ";; If you *don't* use Customize, put something like this in your\n"
+          (substitute-command-keys
+           ";; init.el and use \\[eval-last-sexp] to apply any edits.\n\n")
+          (format "(defface %s\n  '%S\n  %S"
+                  face (face-user-default-spec face) (face-documentation face))
+          (cl-loop for (k v) on erc-nicks--custom-keywords by #'cddr
+                   concat (format "\n  %s %S" k (list 'quote v)))
+          ")\n\n;; Or, if you use use-package\n(use-package erc-nicks\n"
+          "  :custom-face\n"
+          (format "  (%s %S)" face (face-user-default-spec face))
+          ")\n"))
+
+(defun erc-nicks--redirect-face-widget-link (args)
+  (pcase args
+    (`(,widget face-link . ,plist)
+     (when-let* ((face (widget-value widget))
+                 ((get face 'erc-nicks--custom-face)))
+       (unless (symbol-file face)
+         (setf (plist-get plist :action)
+               (lambda (&rest _) (erc-nicks--create-defface-template face))))
+       (setf (plist-get plist :help-echo) "Create or edit `defface'."
+             (cddr args) plist))))
+  args)
+
+(defun erc-nicks--reduce (color)
+  "Fold contrast strategies over COLOR, a string or normalized triple.
+Return a hex string."
+  (apply #'color-rgb-to-hex
+         (seq-reduce (lambda (color strategy) (funcall strategy color))
+                     erc-nicks-color-adjustments
+                     (if (stringp color) (color-name-to-rgb color) color))))
+
+(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)
+  "Return COLORS that fall within parameters indicated by ADJUSTMENTS."
+  (let (addp capp satp pool)
+    (dolist (adjustment adjustments)
+      (pcase adjustment
+        ((or 'erc-nicks-invert 'erc-nicks-add-contrast) (setq addp t))
+        ('erc-nicks-cap-contrast (setq capp t))
+        ('erc-nicks-ensaturate (setq satp t))))
+    (dolist (color colors)
+      (let* ((rgb (color-name-to-rgb color))
+             (contrast (and (or addp capp) (erc-nicks--get-contrast rgb))))
+        (if (or (and addp (< contrast (car erc-nicks-contrast-range)))
+                (and capp (> contrast (cdr erc-nicks-contrast-range)))
+                (and-let* ((satp)
+                           (s (cadr (apply #'color-rgb-to-hsl rgb))))
+                  (or (< s (car erc-nicks-saturation-range))
+                      (> s (cdr erc-nicks-saturation-range)))))
+            (when erc-nicks--colors-rejects
+              (push color erc-nicks--colors-rejects))
+          (push color pool))))
+    (nreverse pool)))
+
+(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)))
+      (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 key))
+    (let ((pool (erc-with-server-buffer erc-nicks--colors-pool))
+          (len (erc-with-server-buffer erc-nicks--colors-len)))
+      (nth (% (abs (random key)) len) pool))))
+
+(defun erc-nicks--get-face (nick key)
+  "Retrieve a face for trimmed and downcased NICK.
+If NICK is new, use KEY to derive color, and store under NICK.
+Favor a custom erc-nicks-NICK@NETWORK-face when defined."
+  (let ((table (erc-with-server-buffer erc-nicks--face-table)))
+    (or (gethash nick table)
+        (and-let* ((face (intern-soft (concat "erc-nicks-" nick "@"
+                                              (erc-network-name) "-face")))
+                   ((or (and (facep face) face)
+                        (erc-nicks--revive face face nick (erc-network))))))
+        (let ((color (erc-nicks--determine-color key))
+              (new-face (make-symbol (concat "erc-nicks-" nick "-face"))))
+          (put new-face 'erc-nicks--nick nick)
+          (put new-face 'erc-nicks--netid erc-networks--id)
+          (put new-face 'erc-nicks--key key)
+          (face-spec-set new-face `((t :foreground ,color)) 'face-defface-spec)
+          (set-face-documentation
+           new-face (format "Internal face for %s on %s." nick (erc-network)))
+          (puthash nick new-face table)))))
+
+(define-inline erc-nicks--anon-face-p (face)
+  (inline-quote (and (consp ,face) (pcase (car ,face)
+                                     ((pred keywordp) t)
+                                     ('foreground-color t)
+                                     ('background-color t)))))
+
+(defvar erc-nicks--max-skip-search 3 ; make this an option?
+  "Max number of faces to visit when testing `erc-nicks-skip-faces'.")
+
+(defun erc-nicks--skip-p (prop option limit)
+  "Return non-nil if a face in PROP appears in OPTION.
+Abandon search after examining LIMIT faces."
+  (setq prop (if (erc-nicks--anon-face-p prop) (list prop) (ensure-list prop)))
+  (catch 'found
+    (while-let (((> limit 0))
+                (elem (pop prop)))
+      (while (and (consp elem) (not (erc-nicks--anon-face-p elem)))
+        (when (cdr elem)
+          (push (cdr elem) prop))
+        (setq elem (car elem)))
+      (when elem
+        (cl-decf limit)
+        (when (if (symbolp elem) (memq elem option) (member elem option))
+          (throw 'found elem))))))
+
+(defvar-local erc-nicks--downcased-skip-nicks nil
+  "Case-mapped copy of `erc-nicks-skip-nicks'.")
+
+(defun erc-nicks--trim (nickname)
+  "Return downcased NICKNAME sans trailing `erc-nicks-ignore-chars'."
+  (erc-downcase
+   (if erc-nicks-ignore-chars
+       (string-trim-right nickname
+                          (rx-to-string
+                           `(: (+ (any ,erc-nicks-ignore-chars)) eot)))
+     nickname)))
+
+(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-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."
+  (when-let* ((trimmed (erc-nicks--trim nickname))
+              ((not (member trimmed erc-nicks--downcased-skip-nicks)))
+              ((not (and base-face
+                         (erc-nicks--skip-p base-face erc-nicks-skip-faces
+                                            erc-nicks--max-skip-search))))
+              (key (funcall erc-nicks--key-function trimmed))
+              (out (erc-nicks--get-face trimmed key)))
+    (if (or (null erc-nicks-backing-face)
+            (eq base-face erc-nicks-backing-face))
+        out
+      (cons out (erc-list erc-nicks-backing-face)))))
+
+(defun erc-nicks--highlight-button (nick-object)
+  "Possibly add face to `erc-button--nick-user' NICK-OBJECT."
+  (when-let*
+      ((nick-object)
+       (face (get-text-property (car (erc-button--nick-bounds nick-object))
+                                'font-lock-face))
+       (nick (erc-server-user-nickname (erc-button--nick-user nick-object)))
+       (out (erc-nicks--highlight nick face)))
+    (setf (erc-button--nick-nickname-face nick-object) out))
+  nick-object)
+
+(define-erc-module nicks nil
+  "Uniquely colorize nicknames in target buffers."
+  ((if erc--target
+       (progn
+         (setq erc-nicks--downcased-skip-nicks
+               (mapcar #'erc-downcase erc-nicks-skip-nicks))
+         (add-function :filter-return (local 'erc-button--modify-nick-function)
+                       #'erc-nicks--highlight-button '((depth . 80)))
+         (erc-button--phantom-users-mode +1))
+     (unless erc-button-mode
+       (unless (memq 'button erc-modules)
+         (erc--warn-once-before-connect 'erc-nicks-mode
+           "Enabling default global module `button' needed by local"
+           " module `nicks'. This will impact \C-]all\C-] ERC"
+           " sessions. Add `nicks' to `erc-modules' to avoid this"
+           " warning. See Info:\"(erc) Modules\" for more."))
+       (erc-button-mode +1))
+     (when (equal erc-nicks-bg-color "unspecified-bg")
+       (let ((temp (if (eq (erc-nicks--bg-mode) 'light) "white" "black")))
+         (erc-button--display-error-notice-with-keys
+          "Module `nicks' unable to determine background color.  Setting to \""
+          temp "\" globally.  Please see `erc-nicks-bg-color'.")
+         (custom-set-variables (list 'erc-nicks-bg-color temp))))
+     (erc-nicks--init-pool)
+     (setq erc-nicks--face-table (make-hash-table :test #'equal)))
+   (setf (alist-get "Edit face" erc-button--nick-popup-alist nil nil #'equal)
+         #'erc-nicks-customize-face)
+   (advice-add 'widget-create-child-and-convert :filter-args
+               #'erc-nicks--redirect-face-widget-link))
+  ((kill-local-variable 'erc-nicks--face-table)
+   (kill-local-variable 'erc-nicks--bg-mode-value)
+   (kill-local-variable 'erc-nicks--bg-luminance)
+   (kill-local-variable 'erc-nicks--colors-len)
+   (kill-local-variable 'erc-nicks--colors-pool)
+   (kill-local-variable 'erc-nicks--downcased-skip-nicks)
+   (when (fboundp 'erc-button--phantom-users-mode)
+     (erc-button--phantom-users-mode -1))
+   (remove-function (local 'erc-button--modify-nick-function)
+                    #'erc-nicks--highlight-button)
+   (setf (alist-get "Edit face"
+                    erc-button--nick-popup-alist nil 'remove #'equal)
+         nil))
+  'local)
+
+(defun erc-nicks-customize-face (nick)
+  "Customize or create persistent face for NICK."
+  (interactive (list (or (car (get-text-property (point) 'erc-data))
+                         (completing-read "nick: " (or erc-channel-users
+                                                       erc-server-users)))))
+  (setq nick (erc-nicks--trim (substring-no-properties nick)))
+  (let* ((net (erc-network))
+         (key (funcall erc-nicks--key-function nick))
+         (old-face (erc-nicks--get-face nick key))
+         (new-face (intern (format "erc-nicks-%s@%s-face" nick net))))
+    (unless (eq new-face old-face)
+      (erc-nicks--revive new-face old-face nick net)
+      (set-face-attribute old-face nil :foreground 'unspecified)
+      (set-face-attribute old-face nil :inherit new-face))
+    (customize-face new-face)))
+
+(defun erc-nicks--list-faces-help-button-action (face)
+  (when-let (((or (get face 'erc-nicks--custom-face)
+                  (y-or-n-p (format "Create new persistent face for %s?"
+                                    (get face 'erc-nicks--key)))))
+             (nid (get face 'erc-nicks--netid))
+             (foundp (lambda ()
+                       (erc-networks--id-equal-p nid erc-networks--id)))
+             (server-buffer (car (erc-buffer-filter foundp))))
+    (with-current-buffer server-buffer
+      (erc-nicks-customize-face (get face 'erc-nicks--nick)))))
+
+(defvar help-xref-stack)
+(defvar help-xref-stack-item)
+
+(defun erc-nicks-list-faces ()
+  "Show faces owned by ERC-nicks in a help buffer."
+  (interactive)
+  (save-excursion
+    (list-faces-display (rx bot "erc-nicks-"))
+    (with-current-buffer "*Faces*"
+      (setq help-xref-stack nil
+            help-xref-stack-item '(erc-nicks-list-faces))
+      (with-silent-modifications
+        (goto-char (point-min))
+        (while (zerop (forward-line))
+          (when (and (get-text-property (point) 'button)
+                     (facep (car (button-get (point) 'help-args))))
+            (button-put (point) 'help-function
+                        #'erc-nicks--list-faces-help-button-action)
+            (if-let* ((face (car (button-get (point) 'help-args)))
+                      ((not (get face 'erc-nicks--custom-face)))
+                      ((not (get face 'erc-nicks--key))))
+                (progn (delete-region (pos-bol) (1+ (pos-eol)))
+                       (forward-line -1))
+              (when-let* ((nid (get face 'erc-nicks--netid))
+                          (net (symbol-name (erc-networks--id-symbol nid))))
+                (goto-char (button-end (point)))
+                (skip-syntax-forward "-")
+                (put-text-property (point) (1+ (point)) 'rear-nonsticky nil)
+                (forward-char)
+                (when (stringp (face-foreground face))
+                  (setq net (format "%-13.13s %s" (substring-no-properties
+                                                   (face-foreground face))
+                                    net)))
+                (insert-and-inherit net)
+                (delete-region (button-start (point))
+                               (1+ (button-start (point))))
+                (delete-region (point) (pos-eol))))))))))
+
+(defun erc-nicks-refresh (debug)
+  "Recompute faces for all nicks on current network.
+With DEBUG, review affected faces or colors.  Which one depends
+on the value of `erc-nicks-colors'."
+  (interactive "P")
+  (unless (derived-mode-p 'erc-mode)
+    (user-error "Not an ERC buffer"))
+  (erc-with-server-buffer
+    (unless erc-nicks-mode (user-error "Module `nicks' disabled"))
+    (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)
+
+;;; erc-nicks.el ends here
diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el
index 70adbb15b5f..a269d10dc51 100644
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -2008,6 +2008,7 @@ erc-modules
            move-to-prompt)
     (const :tag "netsplit: Detect netsplits" netsplit)
     (const :tag "networks: Provide data about IRC networks" networks)
+    (const :tag "nicks: Uniquely colorize nicknames in target buffers" nicks)
     (const :tag "noncommands: Don't display non-IRC commands after evaluation"
            noncommands)
     (const :tag "notifications: Desktop alerts on PRIVMSG or mentions"
diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el
new file mode 100644
index 00000000000..ec6b351a2e7
--- /dev/null
+++ b/test/lisp/erc/erc-nicks-tests.el
@@ -0,0 +1,435 @@
+;;; erc-nicks-tests.el --- Tests for erc-nicks  -*- lexical-binding:t -*-
+
+;; Copyright (C) 2023 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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.
+
+;; GNU Emacs 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 GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Unlike most of ERC's tests, the ones in this file can be run
+;; interactively in the same session.
+
+;; TODO:
+;;
+;; * Add mock session (or scenario) with buffer snapshots, like those
+;;   in erc-fill-tests.el.  (Should probably move helpers to a common
+;;   library under ./resources.)
+
+;;; Code:
+
+(require 'ert)
+(require 'erc-nicks)
+
+;; This function replicates the behavior of older "invert" strategy
+;; implementations from EmacsWiki, etc.  The values for the lower and
+;; upper bounds (0.33 and 0.66) are likewise inherited.  See
+;; `erc-nicks--invert-classic--dark' below for one reason its results
+;; may not be plainly obvious.
+(defun erc-nicks-tests--invert-classic (color)
+  (if (pcase (erc-nicks--bg-mode)
+        ('dark (< (erc-nicks--get-luminance color) (/ 1 3.0)))
+        ('light (> (erc-nicks--get-luminance color) (/ 2 3.0))))
+      (list (- 1.0 (nth 0 color)) (- 1.0 (nth 1 color)) (- 1.0 (nth 2 color)))
+    color))
+
+
+(ert-deftest erc-nicks--get-luminance ()
+  (should (eql 0.0 (erc-nicks--get-luminance "black")))
+  (should (eql 1.0 (erc-nicks--get-luminance "white")))
+  (should (eql 21.0 (/ (+ 0.05 1.0) (+ 0.05 0.0))))
+
+  ;; RGB floats from a `display-graphic-p' session.
+  (let ((a (erc-nicks--get-luminance ; #9439ad
+            '(0.5803921568627451 0.2235294117647059 0.6784313725490196)))
+        (b (erc-nicks--get-luminance ; #ae54c7
+            '(0.6823529411764706 0.32941176470588235 0.7803921568627451)))
+        (c (erc-nicks--get-luminance ; #d19ddf
+            '(0.8196078431372549 0.615686274509804 0.8745098039215686)))
+        (d (erc-nicks--get-luminance ; #f5e8f8
+            '(0.9607843137254902 0.9098039215686274 0.9725490196078431))))
+    ;; Low, med, high contrast comparisons against known values from
+    ;; an external source.
+    (should (eql 1.42 (/ (round (* 100 (/ (+ 0.05 b) (+ 0.05 a)))) 100.0)))
+    (should (eql 2.78 (/ (round (* 100 (/ (+ 0.05 c) (+ 0.05 a)))) 100.0)))
+    (should (eql 5.16 (/ (round (* 100 (/ (+ 0.05 d) (+ 0.05 a)))) 100.0)))))
+
+(ert-deftest erc-nicks-invert--classic ()
+  (let ((convert (lambda (n) (apply #'color-rgb-to-hex
+                                    (erc-nicks-tests--invert-classic
+                                     (color-name-to-rgb n))))))
+    (let ((erc-nicks--bg-mode-value 'dark))
+      (should (equal (funcall convert "white") "#ffffffffffff"))
+      (should (equal (funcall convert "black") "#ffffffffffff"))
+      (should (equal (funcall convert "green") "#0000ffff0000")))
+    (let ((erc-nicks--bg-mode-value 'light))
+      (should (equal (funcall convert "white") "#000000000000"))
+      (should (equal (funcall convert "black") "#000000000000"))
+      (should (equal (funcall convert "green") "#ffff0000ffff")))))
+
+(ert-deftest erc-nicks--get-contrast ()
+  (should (= 21.0 (erc-nicks--get-contrast "white" "black")))
+  (should (= 21.0 (erc-nicks--get-contrast "black" "white")))
+  (should (= 1.0 (erc-nicks--get-contrast "black" "black")))
+  (should (= 1.0 (erc-nicks--get-contrast "white" "white"))))
+
+(defun erc-nicks-tests--print-contrast (fn color)
+  (let* ((erc-nicks-color-adjustments (list fn))
+         (result (erc-nicks--reduce color))
+         (start (point)))
+    (insert (format "%16s%-16s%16s%-16s\n"
+                    (concat color "-")
+                    (concat ">" result)
+                    (concat color " ")
+                    (concat " " result)))
+    (put-text-property (+ start 32) (+ start 48) 'face
+                       (list :background color :foreground result))
+    (put-text-property (+ start 48) (+ start 64) 'face
+                       (list :background result :foreground color))
+    result))
+
+(ert-deftest erc-nicks--invert-classic--light ()
+  (let ((erc-nicks--bg-luminance 1.0)
+        (erc-nicks--bg-mode-value 'light)
+        (show (lambda (c) (erc-nicks-tests--print-contrast
+                           #'erc-nicks-tests--invert-classic c))))
+
+    (with-current-buffer (get-buffer-create
+                          "*erc-nicks--invert-classic--light*")
+      (should (equal "#000000000000" (funcall show "white")))
+      (should (equal "#000000000000" (funcall show "black")))
+      (should (equal "#ffff00000000" (funcall show "red")))
+      (should (equal "#ffff0000ffff" (funcall show "green"))) ; magenta
+      (should (equal "#00000000ffff" (funcall show "blue")))
+
+      (unless noninteractive
+        (should (equal "#bbbbbbbbbbbb" (funcall show "#bbbbbbbbbbbb")))
+        (should (equal "#cccccccccccc" (funcall show "#cccccccccccc")))
+        (should (equal "#222122212221" (funcall show "#dddddddddddd")))
+        (should (equal "#111011101110" (funcall show "#eeeeeeeeeeee"))))
+
+      (when noninteractive
+        (kill-buffer)))))
+
+;; This shows that the output can be darker (have less contrast) than
+;; the input.
+(ert-deftest erc-nicks--invert-classic--dark ()
+  (let ((erc-nicks--bg-luminance 0.0)
+        (erc-nicks--bg-mode-value 'dark)
+        (show (lambda (c) (erc-nicks-tests--print-contrast
+                           #'erc-nicks-tests--invert-classic c))))
+
+    (with-current-buffer (get-buffer-create
+                          "*erc-nicks--invert-classic--dark*")
+      (should (equal "#ffffffffffff" (funcall show "white")))
+      (should (equal "#ffffffffffff" (funcall show "black")))
+      (should (equal "#0000ffffffff" (funcall show "red"))) ; cyan
+      (should (equal "#0000ffff0000" (funcall show "green")))
+      (should (equal "#ffffffff0000" (funcall show "blue"))) ; yellow
+
+      (unless noninteractive
+        (should (equal "#aaaaaaaaaaaa" (funcall show "#555555555555")))
+        (should (equal "#999999999999" (funcall show "#666666666666")))
+        (should (equal "#888888888888" (funcall show "#777777777777")))
+        (should (equal "#777777777777" (funcall show "#888888888888")))
+        (should (equal "#666666666666" (funcall show "#999999999999")))
+        (should (equal "#aaaaaaaaaaaa" (funcall show "#aaaaaaaaaaaa"))))
+
+      (when noninteractive
+        (kill-buffer)))))
+
+;; These are the same as the legacy version but work in terms of
+;; contrast ratios.  Converting the original bounds to contrast ratios
+;; (assuming pure white and black backgrounds) gives:
+;;
+;;   min-lum of 0.33 ~~> 1.465
+;;   max-lum of 0.66 ~~> 7.666
+;;
+(ert-deftest erc-nicks-invert--light ()
+  (let ((erc-nicks--bg-luminance 1.0)
+        (erc-nicks--bg-mode-value 'light)
+        (erc-nicks-contrast-range '(1.465))
+        (show (lambda (c) (erc-nicks-tests--print-contrast
+                           #'erc-nicks-invert c))))
+
+    (with-current-buffer (get-buffer-create
+                          "*erc-nicks--invert-classic--light*")
+      (should (equal "#000000000000" (funcall show "white")))
+      (should (equal "#000000000000" (funcall show "black")))
+      (should (equal "#ffff00000000" (funcall show "red")))
+      (should (equal "#ffff0000ffff" (funcall show "green"))) ; magenta
+      (should (equal "#00000000ffff" (funcall show "blue")))
+
+      (unless noninteractive
+        (should (equal "#bbbbbbbbbbbb" (funcall show "#bbbbbbbbbbbb")))
+        (should (equal "#cccccccccccc" (funcall show "#cccccccccccc")))
+        (should (equal "#222122212221" (funcall show "#dddddddddddd")))
+        (should (equal "#111011101110" (funcall show "#eeeeeeeeeeee"))))
+
+      (when noninteractive
+        (kill-buffer)))))
+
+(ert-deftest erc-nicks-invert--dark ()
+  (let ((erc-nicks--bg-luminance 0.0)
+        (erc-nicks--bg-mode-value 'dark)
+        (erc-nicks-contrast-range '(7.666))
+        (show (lambda (c) (erc-nicks-tests--print-contrast
+                           #'erc-nicks-invert c))))
+
+    (with-current-buffer (get-buffer-create "*erc-nicks-invert--dark*")
+      (should (equal "#ffffffffffff" (funcall show "white")))
+      (should (equal "#ffffffffffff" (funcall show "black")))
+      (should (equal "#0000ffffffff" (funcall show "red"))) ; cyan
+      (should (equal "#0000ffff0000" (funcall show "green")))
+      (should (equal "#ffffffff0000" (funcall show "blue"))) ; yellow
+
+      (unless noninteractive
+        (should (equal "#aaaaaaaaaaaa" (funcall show "#555555555555")))
+        (should (equal "#999999999999" (funcall show "#666666666666")))
+        (should (equal "#888888888888" (funcall show "#777777777777")))
+        (should (equal "#888888888888" (funcall show "#888888888888")))
+        (should (equal "#999999999999" (funcall show "#999999999999"))))
+
+      (when noninteractive
+        (kill-buffer)))))
+
+(ert-deftest erc-nicks-add-contrast ()
+  (let ((erc-nicks--bg-luminance 1.0)
+        (erc-nicks--bg-mode-value 'light)
+        (erc-nicks-contrast-range '(3.5))
+        (show (lambda (c) (erc-nicks-tests--print-contrast
+                           #'erc-nicks-add-contrast c))))
+
+    (with-current-buffer (get-buffer-create "*erc-nicks-add-contrast*")
+      (should (equal "#893a893a893a" (funcall show "white")))
+      (should (equal "#893a893a893a" (funcall show "#893a893a893a")))
+      (should (equal "#000000000000" (funcall show "black")))
+      (should (equal "#ffff00000000" (funcall show "red")))
+      (should (equal "#0000a12e0000" (funcall show "green")))
+      (should (equal "#00000000ffff" (funcall show "blue")))
+
+      ;; When the input is already near the desired ratio, the result
+      ;; may not be in bounds, only close.  But the difference is
+      ;; usually imperceptible.
+      (unless noninteractive
+        ;; Well inside (light slate gray)
+        (should (equal "#777788889999" (funcall show "#777788889999")))
+        ;; Slightly outside -> just outside
+        (should (equal "#7c498bd39b5c" (funcall show "#88889999aaaa")))
+        ;; Just outside -> just inside
+        (should (equal "#7bcc8b479ac0" (funcall show "#7c498bd39b5c")))
+        ;; Just inside
+        (should (equal "#7bcc8b479ac0" (funcall show "#7bcc8b479ac0"))))
+
+      (when noninteractive
+        (kill-buffer)))))
+
+(ert-deftest erc-nicks-cap-contrast ()
+  (should (= 12.5 (cdr erc-nicks-contrast-range)))
+  (let ((erc-nicks--bg-luminance 1.0)
+        (erc-nicks--bg-mode-value 'light)
+        (show (lambda (c) (erc-nicks-tests--print-contrast
+                           #'erc-nicks-cap-contrast c))))
+
+    (with-current-buffer (get-buffer-create "*erc-nicks-remove-contrast*")
+      (should (equal (funcall show "black") "#34e534e534e5" )) ; 21.0 -> 12.14
+      (should ; 12.32 -> 12.32 (same)
+       (equal (funcall show "#34e534e534e5") "#34e534e534e5"))
+      (should (equal (funcall show "white") "#ffffffffffff"))
+
+      (unless noninteractive
+        (should (equal (funcall show "DarkRed") "#8b8b00000000"))
+        (should (equal (funcall show "DarkGreen") "#000064640000"))
+        ;; 15.29 -> 12.38
+        (should (equal (funcall show "DarkBlue") "#1cf11cf198b5"))
+
+        ;; 12.50 -> 12.22
+        (should (equal (funcall show "#33e033e033e0") "#34ab34ab34ab"))
+        ;; 12.57 -> 12.28
+        (should (equal (funcall show "#338033803380") "#344c344c344c"))
+        ;; 12.67 -> 12.37
+        (should (equal (funcall show "#330033003300") "#33cc33cc33cc")))
+
+      (when noninteractive
+        (kill-buffer)))))
+
+(ert-deftest erc-nicks--skip-p ()
+  ;; Baseline
+  (should-not (erc-nicks--skip-p 'bold nil 10000000))
+  (should-not (erc-nicks--skip-p '(bold) nil 10000000))
+  (should-not (erc-nicks--skip-p nil '(bold) 10000000))
+  (should-not (erc-nicks--skip-p 'bold '(bold) 0))
+  (should-not (erc-nicks--skip-p '(bold) '(bold) 0))
+  (should-not (erc-nicks--skip-p 'bold '(foo bold) 0))
+  (should-not (erc-nicks--skip-p '((:inherit bold)) '(bold) 1))
+  (should (erc-nicks--skip-p 'bold '(bold) 1))
+  (should (erc-nicks--skip-p 'bold '(fake bold) 1))
+  (should (erc-nicks--skip-p 'bold '(foo bar bold) 1))
+  (should (erc-nicks--skip-p '(bold) '(bold) 1))
+  (should (erc-nicks--skip-p '((bold)) '(bold) 1))
+  (should (erc-nicks--skip-p '((((bold)))) '(bold) 1))
+  (should (erc-nicks--skip-p '(bold) '(foo bold) 1))
+  (should (erc-nicks--skip-p '(:inherit bold) '((:inherit bold)) 1))
+  (should (erc-nicks--skip-p '((:inherit bold)) '((:inherit bold)) 1))
+  (should (erc-nicks--skip-p '(((:inherit bold))) '((:inherit bold)) 1))
+
+  ;; Composed
+  (should-not (erc-nicks--skip-p '(italic bold) '(bold) 1))
+  (should-not (erc-nicks--skip-p '((italic) bold) '(bold) 1))
+  (should-not (erc-nicks--skip-p '(italic (bold)) '(bold) 1))
+  (should (erc-nicks--skip-p '(italic bold) '(bold) 2))
+  (should (erc-nicks--skip-p '((italic) bold) '(bold) 2))
+  (should (erc-nicks--skip-p '(italic (bold)) '(bold) 2))
+
+  (should-not (erc-nicks--skip-p '(italic default bold) '(bold) 2))
+  (should-not (erc-nicks--skip-p '((default italic) bold) '(bold) 2))
+  (should-not (erc-nicks--skip-p '(italic (default bold)) '(bold) 2))
+  (should-not (erc-nicks--skip-p '((default italic) (bold shadow)) '(bold) 2))
+  (should (erc-nicks--skip-p '((default italic) bold) '(bold) 3))
+  (should (erc-nicks--skip-p '(italic (default bold)) '(bold) 3))
+  (should (erc-nicks--skip-p '((default italic) (bold shadow)) '(bold) 3))
+  (should (erc-nicks--skip-p '(italic (default (bold shadow))) '(bold) 3)))
+
+(ert-deftest erc-nicks--trim ()
+  (should (equal (erc-nicks--trim "Bob`") "bob"))
+  (should (equal (erc-nicks--trim "Bob``") "bob"))
+
+  ;; `erc--casemapping-rfc1459'
+  (let ((erc-nicks-ignore-chars "^"))
+    (should (equal (erc-nicks--trim "Bob~") "bob^"))
+    (should (equal (erc-nicks--trim "Bob^") "bob"))))
+
+(defun erc-nicks-tests--create-session (test)
+  (should-not (memq 'nicks erc-modules))
+  (let ((erc-modules (cons 'nicks erc-modules))
+        (inhibit-message noninteractive)
+        erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook)
+
+    (with-current-buffer
+        (cl-letf
+            (((symbol-function 'erc-server-connect)
+              (lambda (&rest _)
+                (setq erc-server-process
+                      (start-process "sleep" (current-buffer) "sleep" "1"))
+                (set-process-query-on-exit-flag erc-server-process nil))))
+
+          (erc-open "localhost" 6667 "tester" "Tester" 'connect
+                    nil nil nil nil nil "tester"))
+
+      (let ((inhibit-message noninteractive))
+        (dolist (line (split-string "\
+:irc.foonet.org 004 tester irc.foonet.org irc.d abc 123 456
+:irc.foonet.org 005 tester NETWORK=foonet :are supported
+:irc.foonet.org 376 tester :End of /MOTD command."
+                                    "\n"))
+          (erc-parse-server-response erc-server-process line)))
+
+      (with-current-buffer (erc--open-target "#chan")
+        (erc-update-channel-member
+         "#chan" "Alice" "Alice" t nil nil nil nil nil "fake" "~u" nil nil t)
+
+        (erc-update-channel-member
+         "#chan" "Bob" "Bob" t nil nil nil nil nil "fake" "~u" nil nil t)
+
+        (erc-display-message
+         nil 'notice (current-buffer)
+         (concat "This server is in debug mode and is logging all user I/O. "
+                 "Blah Alice (1) Bob (2) blah."))
+
+        (erc-display-message nil nil (current-buffer)
+                             (erc-format-privmessage "Bob" "Hi Alice" nil t))
+
+        (erc-display-message nil nil (current-buffer)
+                             (erc-format-privmessage "Alice" "Hi Bob" nil t)))
+
+      (funcall test)
+
+      (when noninteractive
+        (kill-buffer "#chan")
+        (kill-buffer)))))
+
+(ert-deftest erc-nicks-list-faces ()
+  (erc-nicks-tests--create-session
+   (lambda ()
+     (erc-nicks-list-faces)
+     (let ((table (buffer-local-value 'erc-nicks--face-table
+                                      (get-buffer "foonet")))
+           calls)
+       (cl-letf (((symbol-function 'erc-nicks--list-faces-help-button-action)
+                  (lambda (&rest r) (push r calls))))
+         (with-current-buffer "*Faces*"
+           (set-window-buffer (selected-window) (current-buffer))
+           (goto-char (point-min))
+
+           (ert-info ("Clicking on face link runs action function")
+             (forward-button 1)
+             (should (looking-at "erc-nicks-alice-face"))
+             (push-button)
+             (should (eq (car (car calls)) (gethash "alice" table))))
+
+           (ert-info ("Clicking on sample text describes face")
+             (forward-button 1)
+             (should (looking-at (rx "#" (+ xdigit))))
+             (push-button)
+             (should (search-forward-regexp
+                      (rx "Foreground: #" (group (+ xdigit)) eol)))
+             (forward-button 1)
+             (push-button))
+
+           (ert-info ("First entry's sample is rendered correctly")
+             (let ((hex (match-string 1)))
+               (should (looking-at (concat "#" hex)))
+               (goto-char (button-end (point)))
+               (should (looking-back " foonet"))
+               (should (eq (button-get (1- (point)) 'face) (car (pop calls))))
+               (should-not calls)))
+
+           (ert-info ("Clicking on another entry's face link runs action")
+             (forward-button 1)
+             (should (looking-at "erc-nicks-bob-face"))
+             (push-button)
+             (should (eq (car (car calls)) (gethash "bob" table))))
+
+           (ert-info ("Second entry's sample is rendered correctly")
+             (forward-button 1)
+             (should (looking-at (rx "#" (+ xdigit))))
+             (goto-char (button-end (point)))
+             (should (looking-back " foonet"))
+             (should (eq (button-get (1- (point)) 'face) (car (pop calls))))
+             (should-not calls))
+
+           (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
diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el
index b751ef50520..a154b81db30 100644
--- a/test/lisp/erc/erc-tests.el
+++ b/test/lisp/erc/erc-tests.el
@@ -1754,7 +1754,7 @@ erc-handle-irc-url
 (defconst erc-tests--modules
   '( autoaway autojoin button capab-identify completion dcc fill identd
      imenu irccontrols keep-place list log match menu move-to-prompt netsplit
-     networks noncommands notifications notify page readonly
+     networks nicks noncommands notifications notify page readonly
      replace ring sasl scrolltobottom services smiley sound
      spelling stamp track truncate unmorse xdcc))
 
-- 
2.40.1


  parent reply	other threads:[~2023-06-26 13:44 UTC|newest]

Thread overview: 15+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
     [not found] <87ilcp1za1.fsf@neverwas.me>
2023-05-23 13:37 ` bug#63569: 30.0.50; ERC 5.6: Add automatic nickname highlighting to ERC J.P.
2023-05-30 14:24 ` J.P.
2023-06-13  4:07 ` J.P.
     [not found] ` <87r0qgknt1.fsf@neverwas.me>
2023-06-16  3:07   ` Richard Stallman
     [not found]   ` <E1q9zoC-0003PO-Jf@fencepost.gnu.org>
2023-06-16  5:12     ` J.P.
     [not found]     ` <87h6r8j8ie.fsf@neverwas.me>
2023-06-18  2:13       ` Richard Stallman
2023-06-22 13:47 ` J.P.
     [not found] ` <871qi3boca.fsf@neverwas.me>
2023-06-23 13:38   ` J.P.
     [not found]   ` <87wmzu8fjg.fsf@neverwas.me>
2023-06-26 13:44     ` J.P. [this message]
2023-07-01  3:31 ` J.P.
2023-07-14  2:37 ` J.P.
2023-09-07 13:31 ` J.P.
     [not found] ` <87zg1yjeib.fsf@neverwas.me>
2023-11-07 16:28   ` J.P.
     [not found]   ` <87r0l1frzc.fsf@neverwas.me>
2023-11-13 20:06     ` J.P.
2023-05-18 14:37 J.P.

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

  List information: https://www.gnu.org/software/emacs/

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=87jzvq1gon.fsf@neverwas.me \
    --to=jp@neverwas.me \
    --cc=63569@debbugs.gnu.org \
    --cc=emacs-erc@gnu.org \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body.
Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/emacs.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).