;;; erc-nicks.el -- Nick colors for ERC  -*- lexical-binding: t; -*-

;; Copyright (C) 2023 Free Software Foundation, Inc.

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published
;; by the Free Software Foundation, either version 3 of the License,
;; or (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; This module is heavily influenced by the lovely and more featureful
;;
;;   `erc-hl-nicks' by David Leatherman
;;    <http://www.github.com/leathekd/erc-nicks>
;;
;; which itself is based on
;;
;;   `erc-highlight-nicknames' by André Riemann, Andy Stewart, and
;;    others <https://www.emacswiki.org/emacs/ErcHighlightNicknames>
;;

;;; Code:

(require 'erc-button)
(require 'color)

(defgroup erc-nicks nil
  "Colorize nicknames in ERC buffers."
  :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 string string) (const nil)))

(defcustom erc-nicks-skip-nicks nil
  "Nicks to not highlight."
  :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)
  "Faces to avoid highlighting atop."
  :type  '(repeat symbol))

(defcustom erc-nicks-nickname-face erc-button-nickname-face
  "Face to mix with generated one for emphasizing non-speakers."
  :type '(choice face (const nil)))

(defcustom 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."
  :type 'string)

(defcustom erc-nicks-color-contrast-strategy
  '(erc-nicks-invert erc-nicks-add-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'
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 "Contrast" erc-nicks-add-contrast)
                 (repeat function)
                 (const nil)
                 function))

(defcustom erc-nicks-contrast-ratio 3.5
  "Desired amount of contrast.
For this to matter, `erc-nicks-add-contrast' must be present in
the value of `erc-nicks-color-contrast-strategy'.  When that's
so, this specifies the amount of contrast between a buffer's
background color and the foreground colors chosen.  The closer
the number is to the maximum, 21(:1), the greater the contrast.
Depending on the background, nicks are either tinted in pastel or
muted with dark gray.  Somewhere between 3.0 and 4.5 seems ideal."
  :type '(number :match (lambda (_ n) (and (floatp n) (< 0 n 21)))
                 :type-error "This should be a float between 0 and 21"))

(defcustom erc-nicks-colors 'all
  "Pool of colors.
This can be a list of hexes or color names, such as those
provided by `defined-colors', which can itself be used when the
value is the symbol `defined'.  With `all', use any 24-bit color."
  :type '(choice (const all) (const defined) (list string)))

(defvar-local erc-nicks--face-table nil
  "Hash table containing unique nick faces.")

;; 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."
  (let ((out 0)
        (coefficients '(0.2126 0.7152 0.0722))
        (chnls (if (stringp color) (color-name-to-rgb color) color)))
    (dolist (ch chnls out)
      (cl-incf out (* (pop coefficients)
                      (if (<= ch 0.04045)
                          (/ ch 12.92)
                        (expt (/ (+ ch 0.055) 1.055) 2.4)))))))

(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
             ,(cond ((fboundp 'frame--current-background-mode)
                     '(frame--current-background-mode (selected-frame)))
                    ((fboundp 'frame--current-backround-mode)
                     '(frame--current-backround-mode (selected-frame)))
                    (t
                     '(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-add-contrast (color)
  "Adjust COLOR by blending it with white or black.
Unless sufficient contrast exists between COLOR and the
background, bring the contrast up to `erc-nicks-contrast-ratio'."
  (let* ((lum-bg (or erc-nicks--bg-luminance
                     (setq erc-nicks--bg-luminance
                           (erc-nicks--get-luminance erc-nicks-bg-color))))
         (stop (if (eq '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))
         (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)
    (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))
                  (cur (/ (+ 0.05 lighter) (+ 0.05 darker)))
                  (scale (expt 2 maxtries)))
             (cond ((< cur erc-nicks-contrast-ratio)
                    (setq r (+ r (* r-step scale))
                          g (+ g (* g-step scale))
                          b (+ b (* b-step scale))))
                   (started
                    (setq r (- r (* r-step scale))
                          g (- g (* g-step scale))
                          b (- b (* b-step scale))))
                   (t (setq maxtries 1)))
             (unless started
               (setq started t))
             (setq r (min 1.0 (max 0 r))
                   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)))

;; Inversion thresholds for dark and light, respectively.
(defvar erc-nicks--min-lum (/ 1 3.0))
(defvar erc-nicks--max-lum (/ 2 3.0))

(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)))
    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.
;;
;; Short strings of the same length and those differing only in their
;; low order bits tend to land in neighboring buckets, which are often
;; similar in color.  Padding on the right with at least nine added
;; chars seems to scramble things sufficiently enough for our needs.

(defun erc-nicks--hash (s &optional nchoices)
  (let ((h 5381) ; seed and multiplier (33) hardcoded for now
        (p (or nchoices 281474976710656)) ; 48-bits (expt 2 48)
        (i 0)
        (n (length s)))
    (while (< (setq h (% (+ (* h 33) (aref s i)) p)
                    i (1+ i))
              n))
    h))

(defvar-local erc-nicks--colors-len nil)
(defvar-local erc-nicks--custom-keywords '(:group erc-nicks :group erc-faces))

(defun erc-nicks--revive (new-face old-face nick net)
  (put new-face 'erc-nicks--custom-nick (cons nick net))
  (apply #'custom-declare-face new-face (face-user-default-spec old-face)
         (format "Persistent `erc-nicks' color for %s on %s." nick net)
         erc-nicks--custom-keywords))

(defun erc-nicks--create-defface-template (face)
  (pop-to-buffer (get-buffer-create (format "*New face %s*" face)))
  (erase-buffer)
  (lisp-interaction-mode)
  (insert ";; If you *don't* use Customize, put something like this in your\n"
          (substitute-command-keys
           ";; init.el and use \\[eval-last-sexp] to apply any edits.\n\n")
          (format "(defface %s\n  '%S\n  %S"
                  face (face-user-default-spec face) (face-documentation face))
          (cl-loop for (k v) on erc-nicks--custom-keywords by #'cddr
                   concat (format "\n  %s %S" k (list 'quote v)))
          ")\n"))

(defun erc-nicks--redirect-face-widget-link (args)
  (pcase args
    (`(,widget face-link . ,plist)
     (when-let* ((face (widget-value widget))
                 ((get face 'erc-nicks--custom-nick)))
       (unless (symbol-file face)
         (setf (plist-get plist :action)
               (lambda (&rest _) (erc-nicks--create-defface-template face))))
       (setf (plist-get plist :help-echo) "Create or edit `defface'."
             (cddr args) plist))))
  args)

(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."
  (setq nick (erc-downcase nick))
  (let ((table (buffer-local-value 'erc-nicks--face-table
                                   (erc-server-buffer))))
    (or (gethash nick table)
        (and-let* ((face (intern-soft (concat "erc-nicks-" nick "@"
                                              (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)
                      (pcase erc-nicks-colors
                        ('all (format "#%012x" (erc-nicks--hash key)))
                        ((or 'defined v)
                         (unless v (setq v (defined-colors (selected-frame))))
                         (unless erc-nicks--colors-len
                           (setq erc-nicks--colors-len (length v)))
                         (nth (erc-nicks--hash key erc-nicks--colors-len)
                              v)))))
              (new-face (make-symbol (concat "erc-nicks-" nick "-face"))))
          (face-spec-set new-face `((t :foreground ,color)) 'face-defface-spec)
          (set-face-documentation
           new-face (format "Internal face for %s on %s." nick (erc-network)))
          (puthash nick new-face table)))))

(defvar erc-nicks--phony-face nil
  "Face to pretend is propertizing the nick at point.
Modules needing to colorize nicks outside of a buttonizing
context can use this instead of setting fictitious bounds on the
`erc-button--nick' object passed to `erc-nicks--highlight'.")

(defun erc-nicks--highlight (nick-object)
  "Possibly highlight a single nick."
  (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))
                  (erc-server-user-nickname server-user)))
       ((not (member trimmed erc-nicks-skip-nicks)))
       (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
       ;; 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)
                    (and-let* ((net (erc-network))) (format "%9s" net))))
       (out (erc-nicks--get-face trimmed key)))
    ;; `font-lock-prepend-text-property' could also work if preserving
    ;; history isn't needed (in which case this var should be nil).
    (setf (erc-button--nick-erc-button-nickname-face nick-object)
          (if (or (not erc-nicks-nickname-face)
                  (eq face erc-nicks-nickname-face))
              out
            (cons out (erc-list erc-nicks-nickname-face)))))
  nick-object)

(define-erc-module nicks nil
  "Uniquely colorize nicknames in target buffers."
  ((if erc--target
       (progn
         (add-function :filter-return (local 'erc-button--modify-nick-function)
                       #'erc-nicks--highlight '((depth . 80)))
         (erc-button--phantom-users-mode +1))
     (unless erc-button-mode
       (unless (memq 'button erc-modules)
         (erc--warn-once-before-connect 'erc-nicks-mode
           "Enabling default global module `button' needed by local"
           " module `nicks'. This will impact \C-]all\C-] ERC"
           " sessions. Add `nicks' to `erc-modules' to avoid this"
           " warning. See Info:\"(erc) Modules\" for more."))
       (erc-button-mode +1))
     (when (equal erc-nicks-bg-color "unspecified-bg")
       (let ((temp (if (eq (erc-nicks--bg-mode) 'light) "white" "black")))
         (erc-button--display-error-notice-with-keys
          "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--face-table (make-hash-table :test #'equal)))
   (setf (alist-get "Edit face" erc--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))
  ((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--colors-len)
   (when (fboundp 'erc-button--phantom-users-mode)
     (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)
         nil))
  'local)

(defun erc-nicks-customize-face (nick)
  "Customize or create persistent face for NICK."
  (interactive (list (or (car (get-text-property (point) 'erc-data))
                         (completing-read "nick: " (or erc-channel-users
                                                       erc-server-users)))))
  (setq nick (erc-downcase (substring-no-properties nick)))
  (let* ((net (erc-network))
         (key (concat nick (and net (format "%9s" net))))
         (old-face (erc-nicks--get-face nick key))
         (new-face (intern (format "erc-nicks-%s@%s-face" nick net))))
    (unless (eq new-face old-face)
      (erc-nicks--revive new-face old-face nick net)
      (set-face-attribute old-face nil :foreground 'unspecified)
      (set-face-attribute old-face nil :inherit new-face))
    (customize-face new-face)))

(provide 'erc-nicks)

;;; erc-nicks.el ends here