From ef97b82a7d38e4a61a54cfb7be7444bc8293261b Mon Sep 17 00:00:00 2001
From: "F. Jason Park" <jp@neverwas.me>
Date: Sun, 3 Sep 2023 16:05:59 -0700
Subject: [PATCH] [POC] Offer alternate pool-creation strategies in erc-nicks

(erc-nicks--create-pool-function): New function-valued variable to
allow for changing fixed-pool creation strategy.
(erc-nicks--create-adjusted-pool,
erc-nicks--create-coerced-pool): New functions for filtering
user-provided `erc-nicks-color' values.
(erc-nicks--init-pool): Call `erc-nicks--create-pool-function'.
(erc-nicks-refresh): Provide helpful user error instead of letting
`arith-error' propagate due to an empty pool.  (Bug#63569)
---
 lisp/erc/erc-nicks.el | 63 ++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 62 insertions(+), 1 deletion(-)

diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el
index a7d0b0769f2..3e5bf2b8d3f 100644
--- a/lisp/erc/erc-nicks.el
+++ b/lisp/erc/erc-nicks.el
@@ -356,6 +356,64 @@ 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)))
+
+(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."
+  (let* ((seen (make-hash-table :test #'equal))
+         (erc-nicks-color-adjustments adjustments)
+         pool)
+    (dolist (color colors)
+      (let ((quantized (car (tty-color-approximate
+                             (color-values (erc-nicks--reduce color))))))
+        (if (gethash quantized seen)
+            (when erc-nicks--colors-rejects
+              (push color erc-nicks--colors-rejects))
+          (push quantized pool)
+          (puthash quantized color seen))))
+    (nreverse pool)))
+
 (defun erc-nicks--create-pool (adjustments colors)
   "Return COLORS that fall within parameters indicated by ADJUSTMENTS."
   (let (addp capp satp pool)
@@ -383,7 +441,8 @@ erc-nicks--init-pool
   (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)))
+           (pool (funcall erc-nicks--create-pool-function
+                          erc-nicks-color-adjustments colors)))
       (setq erc-nicks--colors-pool pool
             erc-nicks--colors-len (length pool)))))
 
@@ -608,6 +667,8 @@ erc-nicks-refresh
     (unless erc-nicks-mode (user-error "Module `nicks' disabled"))
     (let ((erc-nicks--colors-rejects (and debug (list t))))
       (erc-nicks--init-pool)
+      (unless erc-nicks--colors-pool
+        (user-error "Pool empty: all colors rejected"))
       (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))
-- 
2.41.0