From 7318662ad47e9f7b0da1a72f158690bbd4504724 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Fri, 30 Jun 2023 19:38:15 -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 | 635 +++++++++++++++++++++++++++++++ lisp/erc/erc.el | 1 + test/lisp/erc/erc-nicks-tests.el | 439 +++++++++++++++++++++ test/lisp/erc/erc-tests.el | 2 +- 6 files changed, 1088 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 dd936af3835..42bbdc1c59d 100644 --- a/lisp/erc/erc-nicks.el +++ b/lisp/erc/erc-nicks.el @@ -40,9 +40,11 @@ ;; This module has enjoyed a number of contributors across several ;; variants over the years, including: ;; -;; Thibault Polge , -;; Jay Kamat , +;; Thibault Polge +;; Jay Kamat ;; Alex Kost +;; Antoine Levitt +;; Adam Porter ;; ;; To those not mentioned, your efforts are no less appreciated. @@ -164,9 +166,32 @@ erc-nicks-key-suffix-format like \"@%-012n\"." :type 'string) +(defvar erc-nicks--max-skip-search 3 ; make this an option? + "Max number of faces to visit when testing `erc-nicks-skip-faces'.") + +(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.") + +(defvar erc-nicks--colors-rejects nil) +(defvar erc-nicks--custom-keywords '(:group erc-nicks :group erc-faces)) +(defvar erc-nicks--grad-steps 9) + (defvar-local erc-nicks--face-table nil "Hash table mapping nicks to unique, named faces. -Keys need not be valid nicks.") +Keys are nonempty strings but need not be valid nicks.") + +(defvar-local erc-nicks--downcased-skip-nicks nil + "Case-mapped copy of `erc-nicks-skip-nicks'.") + +(defvar-local erc-nicks--bg-luminance nil) +(defvar-local erc-nicks--bg-mode-value nil) +(defvar-local erc-nicks--colors-len nil) +(defvar-local erc-nicks--colors-pool nil) +(defvar-local erc-nicks--fg-rgb nil) + +(defvar help-xref-stack) +(defvar help-xref-stack-item) ;; https://stackoverflow.com/questions/596216#answer-56678483 (defun erc-nicks--get-luminance (color) @@ -182,8 +207,6 @@ erc-nicks--get-luminance (/ 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." @@ -196,8 +219,6 @@ erc-nicks--get-contrast (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 @@ -208,20 +229,14 @@ erc-nicks--bg-mode (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))) + (stop (if decrease + (color-name-to-rgb erc-nicks-bg-color) + erc-nicks--fg-rgb)) ;; From `color-gradient' in color.el (r (nth 0 color)) (g (nth 1 color)) @@ -298,8 +313,6 @@ erc-nicks--gen-color (/ (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) @@ -347,10 +360,6 @@ erc-nicks--reduce 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) @@ -415,9 +424,6 @@ erc-nicks--anon-face-p ('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." @@ -434,9 +440,6 @@ erc-nicks--skip-p (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 @@ -446,10 +449,6 @@ erc-nicks--trim `(: (+ (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 @@ -505,7 +504,13 @@ nicks 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))) + (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 @@ -513,6 +518,7 @@ nicks ((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--fg-rgb) (kill-local-variable 'erc-nicks--colors-len) (kill-local-variable 'erc-nicks--colors-pool) (kill-local-variable 'erc-nicks--downcased-skip-nicks) @@ -552,9 +558,6 @@ erc-nicks--list-faces-help-button-action (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) diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el index ec6b351a2e7..08e423bf6b3 100644 --- a/test/lisp/erc/erc-nicks-tests.el +++ b/test/lisp/erc/erc-nicks-tests.el @@ -208,6 +208,8 @@ erc-nicks-invert--dark (ert-deftest erc-nicks-add-contrast () (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") (erc-nicks-contrast-range '(3.5)) (show (lambda (c) (erc-nicks-tests--print-contrast #'erc-nicks-add-contrast c)))) @@ -240,6 +242,8 @@ 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) + (erc-nicks--fg-rgb '(0.0 0.0 0.0)) + (erc-nicks-bg-color "white") (show (lambda (c) (erc-nicks-tests--print-contrast #'erc-nicks-cap-contrast c)))) -- 2.41.0