From a7d23ce4ca9f3b09c03b65d074ad0915d88a6da1 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Tue, 30 May 2023 07:01:48 -0700 Subject: [PATCH 0/2] *** NOT A PATCH *** *** BLURB HERE *** David Leatherman (1): [5.6] Add module for colorizing nicknames to ERC F. Jason Park (1): [5.6] Allow ERC modules to extend erc-nick-popup-alist doc/misc/erc.texi | 4 + etc/ERC-NEWS | 26 +- lisp/erc/erc-button.el | 64 +++-- lisp/erc/erc-nicks.el | 442 +++++++++++++++++++++++++++++++ lisp/erc/erc.el | 1 + test/lisp/erc/erc-nicks-tests.el | 303 +++++++++++++++++++++ test/lisp/erc/erc-tests.el | 2 +- 7 files changed, 818 insertions(+), 24 deletions(-) create mode 100644 lisp/erc/erc-nicks.el create mode 100644 test/lisp/erc/erc-nicks-tests.el Interdiff: diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS index a1279526015..e312ec38ca3 100644 --- a/etc/ERC-NEWS +++ b/etc/ERC-NEWS @@ -32,11 +32,11 @@ started. ** A new module for nickname highlighting has joined ERC. Automatic nickname coloring has come to ERC core. Users familiar with -the excellent 'erc-hl-nicks' by David Leatherman, from which this new -addition draws heavily, 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. +'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 @@ -124,13 +124,19 @@ asking users who've customized this option to switch to that some other solution, like automatic migration, is justified, please make that known on the bug list. -** The 'nicknames' entry in 'erc-button-alist' is officially exceptional. +** 'erc-button-alist' and 'erc-nick-popup-alist' have evolved slightly. It's no secret that the 'buttons' module treats potential nicknames -specially. To simplify ERC's move to next-gen "rich UI" extensions, -this special treatment is being canonized. From now on, all values -other than the symbol 'erc-button-buttonize-nicks' appearing in the -"FORM" field (third element) of this entry are considered deprecated -and will incur a warning. +specially. This is perhaps most evident in its treatment of the +'nicknames' entry in 'erc-button-alist'. Indeed, to simplify ERC's +move to next-gen "rich UI" extensions, this special treatment is being +canonized. From now on, all values other than the symbol +'erc-button-buttonize-nicks' appearing in the "FORM" field (third +element) of this entry are considered deprecated and will incur a +warning. Relatedly, the option 'erc-nick-popup-alist' now favors +functions, which ERC calls non-interactively, over arbitrary +s-expressions, which ERC will continue to honor. Although the default +lineup remains functionally equivalent, its members have all been +updated accordingly. ** Option 'erc-query-on-unjoined-chan-privmsg' restored and renamed. This option was accidentally removed from the default client in ERC diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el index c79b4e11f71..9c84de6720a 100644 --- a/lisp/erc/erc-button.el +++ b/lisp/erc/erc-button.el @@ -660,20 +660,20 @@ erc-browse-emacswiki-lisp ;;; Nickname buttons: (defcustom erc-nick-popup-alist - '(("DeOp" . (erc-cmd-DEOP nick)) - ("Kick" . (erc-cmd-KICK (concat nick " " - (read-from-minibuffer - (concat "Kick " nick ", reason: "))))) - ("Msg" . (erc-cmd-MSG (concat nick " " - (read-from-minibuffer - (concat "Message to " nick ": "))))) - ("Op" . (erc-cmd-OP nick)) - ("Query" . (erc-cmd-QUERY nick)) - ("Whois" . (erc-cmd-WHOIS nick)) - ("Lastlog" . (erc-cmd-LASTLOG nick))) + '(("DeOp" . erc-cmd-DEOP) + ("Kick" . erc-button-cmd-KICK) + ("Msg" . erc-button-cmd-MSG) + ("Op" . erc-cmd-OP) + ("Query" . erc-cmd-QUERY) + ("Whois" . erc-cmd-WHOIS) + ("Lastlog" . erc-cmd-LASTLOG)) "An alist of possible actions to take on a nickname. -An entry looks like (\"Action\" . SEXP) where SEXP is evaluated with -the variable `nick' bound to the nick in question. +For all entries (ACTION . FUNC), ERC offers ACTION as a possible +completion item and calls the selected entry's FUNC with the +buttonized nickname at point as the only argument. For +historical reasons, FUNC can also be an arbitrary sexp, in which +case, ERC binds the nick in question to the variable `nick' and +evaluates the expression. Examples: (\"DebianDB\" . @@ -681,15 +681,39 @@ erc-nick-popup-alist (format \"ldapsearch -x -P 2 -h db.debian.org -b dc=debian,dc=org ircnick=%s\" nick)))" + :package-version '(ERC . "5.6") ; FIXME sync on release :type '(repeat (cons (string :tag "Op") - sexp))) - -(defvar-local erc--nick-popup-alist nil + (choice function sexp)))) + +(defun erc-button-cmd-KICK (nick) + "Prompt for a reason, then kick NICK via `erc-cmd-KICK'. +In server buffers, also prompt for a channel." + (erc-cmd-KICK + (or (and erc--target (erc-default-target)) + (let ((targets (mapcar (lambda (b) + (cons (erc--target-string + (buffer-local-value 'erc--target b)) + b)) + (erc-channel-list erc-server-process)))) + (completing-read (format "Channel (%s): " (caar targets)) + targets (pcase-lambda (`(,_ . ,buf)) + (with-current-buffer buf + (erc-get-channel-user nick))) + t nil t (caar targets)))) + nick + (read-from-minibuffer "Reason: "))) + +(defun erc-button-cmd-MSG (nick) + "Prompt for a message to NICK, and send it via `erc-cmd-MSG'." + (let ((msg (read-from-minibuffer (concat "Message to " nick ": ")))) + (erc-cmd-MSG (concat nick " " msg)))) + +(defvar-local erc-button--nick-popup-alist nil "Internally controlled items for `erc-nick-popup-alist'.") (defun erc-nick-popup (nick) (let* ((completion-ignore-case t) - (alist (append erc-nick-popup-alist erc--nick-popup-alist)) + (alist (append erc-nick-popup-alist erc-button--nick-popup-alist)) (action (completing-read (format-message "What action to take on `%s'? " nick) alist)) diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el index 85d182f9a09..0e0a481d453 100644 --- a/lisp/erc/erc-nicks.el +++ b/lisp/erc/erc-nicks.el @@ -2,6 +2,9 @@ ;; Copyright (C) 2023 Free Software Foundation, Inc. +;; Author: David Leatherman +;; Andy Stewart + ;; This file is part of GNU Emacs. ;; GNU Emacs is free software: you can redistribute it and/or modify @@ -19,16 +22,39 @@ ;;; Commentary: -;; This module is heavily influenced by the lovely and more featureful -;; -;; `erc-hl-nicks' by David Leatherman -;; -;; -;; which itself is based on -;; -;; `erc-highlight-nicknames' by André Riemann, Andy Stewart, and -;; others +;; This file provides the `nicks' module for automatic nickname +;; highlighting. Add `nicks' to `erc-modules' to get started. ;; +;; 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 their 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. 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] +;; [2] ;;; Code: @@ -40,19 +66,20 @@ erc-nicks :package-version '(ERC . "5.6") ; FIXME sync on release :group 'erc) -(defcustom erc-nicks-ignore-chars-regexp - (cons (rx bot (+ (any ",`'_-"))) (rx (+ (any ",`'_-")) eot)) - "Characters surrounding a nick to ignore while highlighting. -Regexps should be suitable for `string-trim'." - :type '(choice (cons regexp regexp) (const nil))) +(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." + :type '(choice (string :tag "Chars to trim") + (const :tag "Don't trim" nil))) (defcustom erc-nicks-skip-nicks nil - "Nicks to not highlight." + "Nicks to avoid highlighting." :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) +(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)) @@ -67,40 +94,42 @@ erc-nicks-bg-color which may be the case in terminal Emacs." :type 'string) -(defcustom erc-nicks-color-contrast-strategy - '(erc-nicks-add-contrast erc-nicks-cap-contrast) - "Treatments applied to colors for increasing visibility. -A value of `erc-nicks-invert' inverts a nick when it's too close -to the background. A value of `erc-nicks-add-contrast' +(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. This option can also be a list, in which case, -members will be applied in the order they appear. For example, - - \\='(erc-nicks-invert erc-nicks-add-contrast) - -will invert as needed and likewise adjust the contrast. Note -that anything specified by this option will still be applied when -`erc-nicks-colors' is a user-defined list of colors." - :type '(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) - (repeat function) - (const nil) - function)) - -(defcustom erc-nicks-contrast-ratio '(3.5 . 12.5) +darkening. Note that ERC still applies adjustments when +`erc-nicks-colors' is a user-defined list of colors. Specify a +value of nil to prevent that." + :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.0 . 12.5) "Desired range of contrast as a cons of (MIN . MAX). -For this to matter, `erc-nicks-color-contrast-strategy' must be -set to `erc-nicks-add-contrast' or `erc-nicks-cap-contrast' or -contain at least one if that option is a list. If adding -contrast, MIN specifies the minimum amount allowed between a -buffer's background color and the foreground colors specified by -`erc-nicks-colors'. The closer the number to the possible -maximum of 21(:1), the greater the contrast. Depending on the -background, nicks are either tinted in pastel or muted with dark -gray. MAX works similarly for reducing contrast." +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. Values 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)) + +;; Should we also accept a list of faces? (defcustom erc-nicks-colors 'all "Pool of colors. This can be a list of hexes or color names, such as those @@ -114,7 +143,8 @@ erc-nicks--face-table ;; 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." +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))) @@ -124,6 +154,20 @@ 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." + (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 () @@ -137,12 +181,8 @@ erc-nicks--bg-mode '(frame-parameter (selected-frame) 'background-mode)))))) (defvar erc-nicks--grad-steps 9) -(defvar-local erc-nicks--bg-luminance nil) ;; https://www.w3.org/TR/UNDERSTANDING-WCAG20/visual-audio-contrast-contrast.html -;; -;; We could cache results, which may help when `erc-nicks-colors' is -;; set to `defined'. (defun erc-nicks--adjust-contrast (color target &optional decrease) (let* ((lum-bg (or erc-nicks--bg-luminance @@ -151,17 +191,17 @@ erc-nicks--adjust-contrast (stop (if (eq (if decrease 'light 'dark) (erc-nicks--bg-mode)) '(1.0 1.0 1.0) '(0.0 0.0 0.0))) - (start (color-name-to-rgb color)) ;; From `color-gradient' in color.el - (r (nth 0 start)) - (g (nth 1 start)) - (b (nth 2 start)) + (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)) @@ -182,34 +222,40 @@ erc-nicks--adjust-contrast g (min 1.0 (max 0 g)) b (min 1.0 (max 0 b))) (not (zerop (cl-decf maxtries))))) - (color-rgb-to-hex r g b))) + (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-ratio'." - (erc-nicks--adjust-contrast color (car erc-nicks-contrast-ratio))) +`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-ratio'." - (erc-nicks--adjust-contrast color (cdr erc-nicks-contrast-ratio) 'remove)) - -;; Inversion thresholds for dark and light, respectively. -(defvar erc-nicks--min-lum (/ 1 3.0)) -(defvar erc-nicks--max-lum (/ 2 3.0)) +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 luminance and background." - (if (pcase (erc-nicks--bg-mode) - ('dark (< (erc-nicks--get-luminance color) erc-nicks--min-lum)) - ('light (> (erc-nicks--get-luminance color) erc-nicks--max-lum))) - (pcase-let ((`(,r ,g ,b) (color-values color))) - (format "#%04x%04x%04x" (- 65535 r) (- 65535 g) (- 65535 b))) + "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) + ;; http://www.cse.yorku.ca/~oz/hash.html ;; See also gui_nick_hash_djb2_64 in weechat/src/gui/gui-nick.c, ;; which is originally from https://savannah.nongnu.org/patch/?8062. @@ -266,6 +312,13 @@ erc-nicks--redirect-face-widget-link (cddr args) plist)))) args) +(defun erc-nicks--reduce (color-string) + "Fold contrast strategies over COLOR-STRING." + (apply #'color-rgb-to-hex + (seq-reduce (lambda (color strategy) (funcall strategy color)) + erc-nicks-color-adjustments + (color-name-to-rgb color-string)))) + (defun erc-nicks--get-face (nick key) "Retrieve or create a face for NICK, stored locally under KEY. But favor a custom erc-nicks-NICK@NETWORK-face, when defined." @@ -277,9 +330,7 @@ erc-nicks--get-face (erc-network-name) "-face"))) ((or (and (facep face) face) (erc-nicks--revive face face nick (erc-network)))))) - (let ((color (seq-reduce - (lambda (color strategy) (funcall strategy color)) - (erc-list erc-nicks-color-contrast-strategy) + (let ((color (erc-nicks--reduce (pcase erc-nicks-colors ('all (format "#%012x" (erc-nicks--hash key))) ((or 'defined v) @@ -305,10 +356,11 @@ erc-nicks--highlight (when-let* ((nick-object) (server-user (erc-button--nick-user nick-object)) - (trimmed (if erc-nicks-ignore-chars-regexp - (string-trim (erc-server-user-nickname server-user) - (car erc-nicks-ignore-chars-regexp) - (cdr erc-nicks-ignore-chars-regexp)) + (trimmed (if erc-nicks-ignore-chars + (string-trim-right (erc-server-user-nickname server-user) + (rx-to-string + `(: (+ (any ,erc-nicks-ignore-chars)) + eot))) (erc-server-user-nickname server-user))) ((not (member trimmed erc-nicks-skip-nicks))) (face (or erc-nicks--phony-face @@ -352,7 +404,7 @@ nicks temp "\" globally. Please see `erc-nicks-bg-color'.") (custom-set-variables (list 'erc-nicks-bg-color temp)))) (setq erc-nicks--face-table (make-hash-table :test #'equal))) - (setf (alist-get "Edit face" erc--nick-popup-alist nil nil #'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)) @@ -364,7 +416,8 @@ nicks (erc-button--phantom-users-mode -1)) (remove-function (local 'erc-button--modify-nick-function) #'erc-nicks--highlight) - (setf (alist-get "Edit face" erc--nick-popup-alist nil 'remove #'equal) + (setf (alist-get "Edit face" + erc-button--nick-popup-alist nil 'remove #'equal) nil)) 'local) diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el index e0a5691b073..e84a2fea6ce 100644 --- a/test/lisp/erc/erc-nicks-tests.el +++ b/test/lisp/erc/erc-nicks-tests.el @@ -19,6 +19,9 @@ ;;; 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 @@ -30,6 +33,19 @@ (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"))) @@ -50,36 +66,149 @@ erc-nicks--get-luminance (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 () - (let ((erc-nicks--bg-mode-value 'dark)) - (should (equal (erc-nicks-invert "white") "white")) - (should (equal (erc-nicks-invert "black") "#ffffffffffff")) - (should (equal (erc-nicks-invert "green") "green"))) - (let ((erc-nicks--bg-mode-value 'light)) - (should (equal (erc-nicks-invert "white") "#000000000000")) - (should (equal (erc-nicks-invert "black") "black")) - (should (equal (erc-nicks-invert "green") "#ffff0000ffff")))) +(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 ((result (funcall fn color)) - (fg (if (eq 'dark erc-nicks--bg-mode-value) "white" "black")) - (start (point))) + (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 (+ start 32) 'face - (list :foreground fg)) (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)))) @@ -108,7 +237,7 @@ erc-nicks-add-contrast (kill-buffer))))) (ert-deftest erc-nicks-cap-contrast () - (should (= 12.5 (cdr erc-nicks-contrast-ratio))) + (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 -- 2.40.1