From 9aff22914d85d92ca2665c6fc5b3359217b5d766 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Tue, 7 Nov 2023 02:03:27 -0800 Subject: [PATCH 0/1] *** NOT A PATCH *** *** BLURB HERE *** F. Jason Park (1): [5.6] Offer alternate pool-creation strategies in erc-nicks lisp/erc/erc-nicks.el | 87 +++++++++++++++++++++++++++----- test/lisp/erc/erc-nicks-tests.el | 79 ++++++++++++++++++++--------- 2 files changed, 129 insertions(+), 37 deletions(-) Interdiff: diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el index 3e5bf2b8d3f..d512455090b 100644 --- a/lisp/erc/erc-nicks.el +++ b/lisp/erc/erc-nicks.el @@ -102,7 +102,10 @@ 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." +which may be the case in terminal Emacs. Even when automatically +initialized, this value may need adjustment mid-session, such as +after loading a new theme. Remember to run \\[erc-nicks-refresh] +after doing so." :type 'string) (defcustom erc-nicks-color-adjustments @@ -153,9 +156,13 @@ erc-nicks-colors 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) (repeat string))) +color. To change the value mid-session, try +\\[erc-nicks-refresh]." + :type `(choice (const :tag "All 24-bit colors" all) + (const :tag "Defined terminal colors" defined) + (const :tag "Font Lock faces" font-lock) + (const :tag "ANSI color faces" ansi-color) + (repeat :tag "User-provided list" string))) (defcustom erc-nicks-key-suffix-format "@%n" "Template for latter portion of keys to generate colors from. @@ -227,6 +234,7 @@ erc-nicks--bg-mode ;; https://www.w3.org/TR/UNDERSTANDING-WCAG20/visual-audio-contrast-contrast.html (defun erc-nicks--adjust-contrast (color target &optional decrease) + (cl-assert erc-nicks--fg-rgb) (let* ((lum-bg (or erc-nicks--bg-luminance (setq erc-nicks--bg-luminance (erc-nicks--get-luminance erc-nicks-bg-color)))) @@ -356,51 +364,26 @@ erc-nicks--reduce erc-nicks-color-adjustments (if (stringp color) (color-name-to-rgb color) color)))) -(defvar erc-nicks--create-pool-function #'erc-nicks--create-adjusted-pool) - -(defun erc-nicks--create-adjusted-pool (adjustments colors) - "Return COLORS that fall within parameters indicated by ADJUSTMENTS. -Apply adjustments before replacing COLORS with the nearest -defined, and then cull those that still don't meet the grade. -Expect to operate on user-provided lists of `erc-nicks-colors' -rather than all those `defined' by the system." - (let* ((seen (make-hash-table :test #'equal)) - (valmax (float (car (color-values "#ffffffffffff")))) - (erc-nicks-color-adjustments adjustments) - 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) - (pcase-let ((`(,quantized ,_ . ,vals) - (tty-color-approximate (color-values - (erc-nicks--reduce color))))) - (if (gethash quantized seen) - (when erc-nicks--colors-rejects - (push color erc-nicks--colors-rejects)) - (let* ((rgb (mapcar (lambda (x) (/ x valmax)) vals)) - (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 quantized pool) - (puthash quantized color seen)))))) - (nreverse pool))) +(defvar erc-nicks--create-pool-function #'erc-nicks--create-coerced-pool + "Filter function for initializing the pool of colors. +Takes a list of adjustment functions, such as those named in +`erc-nicks-color-adjustments', and a list of colors. Returns +another list whose members need not be among the original +candidates. Users should note that this variable, along with its +predefined function values, `erc-nicks--create-coerced-pool' and +`erc-nicks--create-culled-pool', can be made public in a future +version of this module, perhaps as a single user option, given +sufficient demand.") (defun erc-nicks--create-coerced-pool (adjustments colors) - "Return COLORS that fall within parameters indicated by ADJUSTMENTS. -Rather than culling, apply adjustments and then dedupe after -first replacing adjusted values with the nearest defined. Unlike -`erc-nicks--create-adjusted-pool', don't recheck after adjusting. -Rather, tolerate values that may fall slightly outside desired -parameters, thus yielding a larger pool." + "Return COLORS that fall within parameters heeded by ADJUSTMENTS. +Apply ADJUSTMENTS and dedupe after replacing adjusted values with +those nearest defined for the terminal. Only perform one pass. +That is, accept the nearest initially found as \"close enough,\" +knowing that values may fall outside desired parameters and thus +yield a larger pool than simple culling might produce. When +debugging, add candidates to `erc-nicks--colors-rejects' that map +to the same output color as some prior candidate." (let* ((seen (make-hash-table :test #'equal)) (erc-nicks-color-adjustments adjustments) pool) @@ -414,7 +397,7 @@ erc-nicks--create-coerced-pool (puthash quantized color seen)))) (nreverse pool))) -(defun erc-nicks--create-pool (adjustments colors) +(defun erc-nicks--create-culled-pool (adjustments colors) "Return COLORS that fall within parameters indicated by ADJUSTMENTS." (let (addp capp satp pool) (dolist (adjustment adjustments) @@ -440,6 +423,9 @@ 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) + (and (memq erc-nicks-colors '(font-lock ansi-color)) + (erc-nicks--colors-from-faces + (format "%s-" erc-nicks-colors))) (defined-colors))) (pool (funcall erc-nicks--create-pool-function erc-nicks-color-adjustments colors))) @@ -546,7 +532,8 @@ nicks " Toggling it in individual target buffers is unsupported.") (erc-nicks-mode +1))) ; but do it anyway (setq erc-nicks--downcased-skip-nicks - (mapcar #'erc-downcase erc-nicks-skip-nicks)) + (mapcar #'erc-downcase erc-nicks-skip-nicks) + erc-nicks--fg-rgb (erc-with-server-buffer erc-nicks--fg-rgb)) (add-function :filter-return (local 'erc-button--modify-nick-function) #'erc-nicks--highlight-button '((depth . 80))) (erc-button--phantom-users-mode +1)) @@ -564,14 +551,14 @@ nicks "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)))) + (setq erc-nicks--fg-rgb + (or (color-name-to-rgb + (face-foreground 'erc-default-face nil 'default)) + (color-name-to-rgb + (readable-foreground-color erc-nicks-bg-color)))) (erc-nicks--init-pool) (erc--restore-initialize-priors erc-nicks-mode erc-nicks--face-table (make-hash-table :test #'equal))) - (setq erc-nicks--fg-rgb - (or (color-name-to-rgb - (face-foreground 'erc-default-face nil 'default)) - (color-name-to-rgb - (readable-foreground-color erc-nicks-bg-color)))) (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 @@ -658,8 +645,10 @@ erc-nicks-list-faces (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'." +With DEBUG, review affected faces or colors. Exactly which of +the two depends on the value of `erc-nicks-colors'. Note that +the list of rejected faces may include duplicates of accepted +ones." (interactive "P") (unless (derived-mode-p 'erc-mode) (user-error "Not an ERC buffer")) @@ -695,6 +684,15 @@ erc-nicks-refresh (cadr (apply #'color-rgb-to-hsl (color-name-to-rgb c)))))))))))))) +(defun erc-nicks--colors-from-faces (prefix) + "Extract foregrounds from faces with PREFIX +Expect PREFIX to be something like \"ansi-color-\" or \"font-lock-\"." + (let (out) + (dolist (face (face-list) (nreverse out)) + (when-let (((string-prefix-p prefix (symbol-name face))) + (color (face-foreground face))) + (push color out))))) + (provide 'erc-nicks) ;;; erc-nicks.el ends here diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el index 3e5804734ec..35264a23caa 100644 --- a/test/lisp/erc/erc-nicks-tests.el +++ b/test/lisp/erc/erc-nicks-tests.el @@ -493,7 +493,7 @@ erc-nicks--gen-key-from-format-spec (should (equal (erc-nicks--gen-key-from-format-spec "bob") "bob@Libera.Chat/tester")))) -(ert-deftest erc-nicks--create-pool () +(ert-deftest erc-nicks--create-culled-pool () (let ((erc-nicks--bg-luminance 1.0) (erc-nicks--bg-mode-value 'light) (erc-nicks--fg-rgb '(0.0 0.0 0.0)) @@ -502,37 +502,70 @@ erc-nicks--create-pool (erc-nicks--colors-rejects '(t))) ;; Reject - (should-not (erc-nicks--create-pool '(erc-nicks-invert) '("white"))) + (should-not (erc-nicks--create-culled-pool '(erc-nicks-invert) '("white"))) (should (equal (pop erc-nicks--colors-rejects) "white")) ; too close - (should-not (erc-nicks--create-pool '(erc-nicks-cap-contrast) '("black"))) + (should-not + (erc-nicks--create-culled-pool '(erc-nicks-cap-contrast) '("black"))) (should (equal (pop erc-nicks--colors-rejects) "black")) ; too far - (should-not (erc-nicks--create-pool '(erc-nicks-ensaturate) '("white"))) + (should-not + (erc-nicks--create-culled-pool '(erc-nicks-ensaturate) '("white"))) (should (equal (pop erc-nicks--colors-rejects) "white")) ; lacks color - (should-not (erc-nicks--create-pool '(erc-nicks-ensaturate) '("red"))) + (should-not + (erc-nicks--create-culled-pool '(erc-nicks-ensaturate) '("red"))) (should (equal (pop erc-nicks--colors-rejects) "red")) ; too much color ;; Safe - (should - (equal (erc-nicks--create-pool '(erc-nicks-invert) '("black")) - '("black"))) - (should - (equal (erc-nicks--create-pool '(erc-nicks-add-contrast) '("black")) - '("black"))) - (should - (equal (erc-nicks--create-pool '(erc-nicks-cap-contrast) '("white")) - '("white"))) + (should (equal (erc-nicks--create-culled-pool '(erc-nicks-invert) + '("black")) + '("black"))) + (should (equal (erc-nicks--create-culled-pool '(erc-nicks-add-contrast) + '("black")) + '("black"))) + (should (equal (erc-nicks--create-culled-pool '(erc-nicks-cap-contrast) + '("white")) + '("white"))) (let ((erc-nicks-saturation-range '(0.5 . 1.0))) - (should - (equal (erc-nicks--create-pool '(erc-nicks-ensaturate) '("green")) - '("green")))) + (should (equal (erc-nicks--create-culled-pool '(erc-nicks-ensaturate) + '("green")) + '("green")))) (let ((erc-nicks-saturation-range '(0.0 . 0.5))) - (should - (equal (erc-nicks--create-pool '(erc-nicks-ensaturate) '("gray")) - '("gray")))) + (should (equal (erc-nicks--create-culled-pool '(erc-nicks-ensaturate) + '("gray")) + '("gray")))) (unless noninteractive - (should - (equal (erc-nicks--create-pool '(erc-nicks-ensaturate) '("firebrick")) - '("firebrick")))) + (should (equal (erc-nicks--create-culled-pool '(erc-nicks-ensaturate) + '("firebrick")) + '("firebrick")))) + (should (equal erc-nicks--colors-rejects '(t))))) + +(ert-deftest erc-nicks--create-coerced-pool () + (let ((erc-nicks--bg-luminance 1.0) + (erc-nicks--bg-mode-value 'light) + (erc-nicks--fg-rgb '(0.0 0.0 0.0)) + (erc-nicks-bg-color "white") + (num-colors (length (defined-colors))) + ;; + (erc-nicks--colors-rejects '(t))) + + ;; Deduplication. + (when (= 8 num-colors) + (should (equal (erc-nicks--create-coerced-pool '(erc-nicks-ensaturate) + '("#ee0000" "#f80000")) + '("red"))) + (should (equal (pop erc-nicks--colors-rejects) "#f80000"))) + + ;; "Coercion" in Xterm. + (unless noninteractive + (when (= 665 num-colors) + (pcase-dolist (`(,adjustments ,candidates ,result) + '(((erc-nicks-invert) ("white") ("gray10")) + ((erc-nicks-cap-contrast) ("black") ("gray20")) + ((erc-nicks-ensaturate) ("white") ("lavenderblush2")) + ((erc-nicks-ensaturate) ("red") ("firebrick")))) + (should (equal (erc-nicks--create-coerced-pool adjustments + candidates) + result))))) + (should (equal erc-nicks--colors-rejects '(t))))) ;;; erc-nicks-tests.el ends here -- 2.41.0