From 5100a10672355255a80549acde1ca939f61e465d Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Mon, 12 Jun 2023 21:00:28 -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 | 485 +++++++++++++++++++++++++++++++ lisp/erc/erc.el | 1 + test/lisp/erc/erc-nicks-tests.el | 340 ++++++++++++++++++++++ test/lisp/erc/erc-tests.el | 2 +- 6 files changed, 839 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 0e0a481d453..ad4fca523d2 100644 --- a/lisp/erc/erc-nicks.el +++ b/lisp/erc/erc-nicks.el @@ -34,7 +34,7 @@ ;; init.el. Customize users need only click "Apply and Save", as ;; usual. -;; History: +;;; History: ;; This module has enjoyed a number of contributors across several ;; variants over the years. To those not mentioned, your efforts are @@ -69,8 +69,9 @@ erc-nicks (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 a la `erc-nick-uniquifier' to secure a nickname -after a rejection. A value of nil means don't trim anything." +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))) @@ -95,7 +96,7 @@ erc-nicks-bg-color :type 'string) (defcustom erc-nicks-color-adjustments - '(erc-nicks-add-contrast erc-nicks-cap-contrast erc-nicks-ensaturate) + '(erc-nicks-invert 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' @@ -110,7 +111,7 @@ erc-nicks-color-adjustments (function-item :tag "Bound saturation" erc-nicks-ensaturate) function))) -(defcustom erc-nicks-contrast-range '(4.0 . 12.5) +(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 @@ -118,9 +119,10 @@ erc-nicks-contrast-range 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. Values can range from 1.0 to -21.0(:1) but may produce unsatisfactory results toward either -extreme." +`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) @@ -183,11 +185,14 @@ erc-nicks--bg-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))) @@ -275,6 +280,17 @@ erc-nicks--hash n)) h)) +;; From https://elpa.gnu.org/packages/ement. The resolution 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) + "Generate normalized RGB color from STRING." + (let* ((ratio (/ (float (abs (sxhash string))) (float most-positive-fixnum))) + (color-num (round (* (* #xffff #xffff #xffff) 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--colors-len nil) (defvar-local erc-nicks--custom-keywords '(:group erc-nicks :group erc-faces)) @@ -312,12 +328,13 @@ erc-nicks--redirect-face-widget-link (cddr args) plist)))) args) -(defun erc-nicks--reduce (color-string) - "Fold contrast strategies over COLOR-STRING." +(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 - (color-name-to-rgb color-string)))) + (if (stringp color) (color-name-to-rgb color) color)))) (defun erc-nicks--get-face (nick key) "Retrieve or create a face for NICK, stored locally under KEY. @@ -332,7 +349,7 @@ erc-nicks--get-face (erc-nicks--revive face face nick (erc-network)))))) (let ((color (erc-nicks--reduce (pcase erc-nicks-colors - ('all (format "#%012x" (erc-nicks--hash key))) + ('all (erc-nicks--gen-color-ement key)) ((or 'defined v) (unless v (setq v (defined-colors (selected-frame)))) (unless erc-nicks--colors-len @@ -345,6 +362,32 @@ erc-nicks--get-face 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. +But 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 erc-nicks--phony-face nil "Face to pretend is propertizing the nick at point. Modules needing to colorize nicks outside of a buttonizing @@ -366,8 +409,8 @@ erc-nicks--highlight (face (or erc-nicks--phony-face (get-text-property (car (erc-button--nick-bounds nick-object)) 'font-lock-face))) - ((not (seq-some (lambda (f) (memq f erc-nicks-skip-faces)) - (erc-list face)))) ; cl-notany + ((not (erc-nicks--skip-p face erc-nicks-skip-faces + erc-nicks--max-skip-search))) ;; Ensure nicks are colored uniquely (per network) by padding ;; from the right, as mentioned above in `erc-nicks--hash'. (key (concat (erc-button--nick-downcased nick-object) diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el index e84a2fea6ce..0d640ad59c3 100644 --- a/test/lisp/erc/erc-nicks-tests.el +++ b/test/lisp/erc/erc-nicks-tests.el @@ -300,4 +300,41 @@ erc-nicks--hash (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))) + ;;; erc-nicks-tests.el ends here -- 2.40.1