diff options
Diffstat (limited to 'configs/shared/emacs/.emacs.d/elpa/circe-20180525.531/circe-color-nicks.el')
| -rw-r--r-- | configs/shared/emacs/.emacs.d/elpa/circe-20180525.531/circe-color-nicks.el | 340 |
1 files changed, 340 insertions, 0 deletions
diff --git a/configs/shared/emacs/.emacs.d/elpa/circe-20180525.531/circe-color-nicks.el b/configs/shared/emacs/.emacs.d/elpa/circe-20180525.531/circe-color-nicks.el new file mode 100644 index 0000000000..dd5e64e04f --- /dev/null +++ b/configs/shared/emacs/.emacs.d/elpa/circe-20180525.531/circe-color-nicks.el @@ -0,0 +1,340 @@ +;;; circe-color-nicks.el --- Color nicks in the channel + +;; Copyright (C) 2012 Taylan Ulrich Bayırlı/Kammer + +;; Author: Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com> + +;; This file is part of Circe. + +;; This program 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. + +;; This program 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 this program; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA +;; 02110-1301 USA + +;;; Commentary: + +;; This Circe module adds the ability to assign a color to each +;; nick in a channel. + +;; Some ideas/code copied from rcirc-colors.el. + +;; To use it, put the following into your .emacs: + +;; (require 'circe-color-nicks) +;; (enable-circe-color-nicks) + +;;; Code: + +(require 'circe) +(require 'color) +(require 'cl-lib) + +;;;###autoload +(defun enable-circe-color-nicks () + "Enable the Color Nicks module for Circe. +This module colors all encountered nicks in a cross-server fashion." + (interactive) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when (eq major-mode 'circe-channel-mode) + (add-circe-color-nicks)))) + (add-hook 'circe-channel-mode-hook + 'add-circe-color-nicks)) + +(defun disable-circe-color-nicks () + "Disable the Color Nicks module for Circe. +See `enable-circe-color-nicks'." + (interactive) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when (eq major-mode 'circe-channel-mode) + (remove-circe-color-nicks)))) + (remove-hook 'circe-channel-mode-hook + 'add-circe-color-nicks)) + +(defun add-circe-color-nicks () + "Add `circe-color-nicks' to `lui-pre-output-hook'." + (add-hook 'lui-pre-output-hook 'circe-color-nicks)) + +(defun remove-circe-color-nicks () + "Remove `circe-color-nicks' from `lui-pre-output-hook'." + (remove-hook 'lui-pre-output-hook 'circe-color-nicks)) + + +(defgroup circe-color-nicks nil + "Nicks colorization for Circe" + :prefix "circe-color-nicks-" + :group 'circe) + +(defcustom circe-color-nicks-min-contrast-ratio 7 + "Minimum contrast ratio from background for generated colors; +recommended is 7:1, or at least 4.5:1 (7 stands for 7:1 here). +Lower value allows higher color spread, but could lead to less +readability." + :group 'circe-color-nicks) + +(defcustom circe-color-nicks-min-difference 17 + "Minimum difference from each other for generated colors." + :group 'circe-color-nicks) + +(defcustom circe-color-nicks-min-fg-difference 17 + "Minimum difference from foreground for generated colors." + :group 'circe-color-nicks) + +(defcustom circe-color-nicks-min-my-message-difference 0 + "Minimum difference from own nick color for generated colors." + :group 'circe-color-nicks) + +(defcustom circe-color-nicks-everywhere nil + "Whether nicks should be colored in message bodies too." + :type 'boolean + :group 'circe-color-nicks) + +(defcustom circe-color-nicks-message-blacklist nil + "Blacklist for nicks that shall never be highlighted inside + images." + :type '(repeat string) + :group 'circe-color-nicks) + +(defcustom circe-color-nicks-pool-type 'adaptive + "Type of the color nick pool. +Must be one of the following: + +'adaptive: Generate colors based on the current theme. + +List of strings: Pick colors from the specified list of hex codes +or color names (see `color-name-rgb-alist')." + :type '(choice (const :tag "Adaptive" adaptive) + (repeat string)) + :group 'circe-color-nicks) + + +;;; See http://www.w3.org/TR/2013/NOTE-WCAG20-TECHS-20130905/G18 + +(defsubst circe-w3-contrast-c-to-l (c) + (if (<= c 0.03928) + (/ c 12.92) + (expt (/ (+ c 0.055) 1.055) 2.4))) + +(defsubst circe-w3-contrast-relative-luminance (rgb) + (apply #'+ + (cl-mapcar (lambda (color coefficient) + (* coefficient + (circe-w3-contrast-c-to-l color))) + rgb + '(0.2126 0.7152 0.0722)))) + +(defsubst circe-w3-contrast-contrast-ratio (color1 color2) + (let ((l1 (+ 0.05 (circe-w3-contrast-relative-luminance color1))) + (l2 (+ 0.05 (circe-w3-contrast-relative-luminance color2)))) + (if (> l1 l2) + (/ l1 l2) + (/ l2 l1)))) + + +(defun circe-color-alist () + "Return list of colors (name rgb lab) where rgb is 0 to 1." + (let ((alist (if (display-graphic-p) + color-name-rgb-alist + (mapcar (lambda (c) + (cons (car c) (cddr c))) + (tty-color-alist)))) + (valmax (float (car (color-values "#ffffff"))))) + (mapcar (lambda (c) + (let* ((name (car c)) + (rgb (mapcar (lambda (v) + (/ v valmax)) + (cdr c))) + (lab (apply #'color-srgb-to-lab rgb))) + (list name rgb lab))) + alist))) + +(defun circe-color-canonicalize-format (color) + "Turns COLOR into (name rgb lab) format. Avoid calling this in +a loop, it's very slow on a tty!" + (let* ((name color) + (rgb (circe-color-name-to-rgb color)) + (lab (apply #'color-srgb-to-lab rgb))) + (list name rgb lab))) + +(defun circe-color-contrast-ratio (color1 color2) + "Gives the contrast ratio between two colors." + (circe-w3-contrast-contrast-ratio (nth 1 color1) (nth 1 color2))) + +(defun circe-color-diff (color1 color2) + "Gives the difference between two colors per CIEDE2000." + (color-cie-de2000 (nth 2 color1) (nth 2 color2))) + +(defun circe-color-name-to-rgb (color) + "Like `color-name-to-rgb' but also handles \"unspecified-bg\" +and \"unspecified-fg\"." + (cond ((equal color "unspecified-bg") '(0 0 0)) + ((equal color "unspecified-fg") '(1 1 1)) + (t (color-name-to-rgb color)))) + + +(defun circe-nick-color-appropriate-p (color bg fg my-msg) + "Tells whether COLOR is appropriate for being a nick color. +BG, FG, and MY-MSG are the background, foreground, and my-message +colors; these are expected as parameters instead of computed here +because computing them repeatedly is a heavy operation." + (and (>= (circe-color-contrast-ratio color bg) + circe-color-nicks-min-contrast-ratio) + (>= (circe-color-diff color fg) + circe-color-nicks-min-fg-difference) + (>= (circe-color-diff color my-msg) + circe-color-nicks-min-my-message-difference))) + +(defun circe-nick-colors-delete-similar (colors) + "Return list COLORS with pairs of colors filtered out that are +too similar per `circe-color-nicks-min-difference'. COLORS may +be mutated." + (cl-mapl (lambda (rest) + (let ((color (car rest))) + (setcdr rest (cl-delete-if + (lambda (c) + (< (circe-color-diff color c) + circe-color-nicks-min-difference)) + (cdr rest))))) + colors) + colors) + +(defun circe-nick-color-generate-pool () + "Return a list of appropriate nick colors." + (if (consp circe-color-nicks-pool-type) + circe-color-nicks-pool-type + (let ((bg (circe-color-canonicalize-format (face-background 'default))) + (fg (circe-color-canonicalize-format (face-foreground 'default))) + (my-msg (circe-color-canonicalize-format + (face-attribute + 'circe-my-message-face :foreground nil 'default)))) + (mapcar #'car (circe-nick-colors-delete-similar + (cl-remove-if-not + (lambda (c) + (circe-nick-color-appropriate-p c bg fg my-msg)) + (circe-color-alist))))))) + +(defun circe-nick-color-pool-test () + "Display all appropriate nick colors in a temp buffer." + (interactive) + (switch-to-buffer (get-buffer-create "*Circe color test*")) + (erase-buffer) + (let ((pool (circe-nick-color-generate-pool))) + (while pool + (let ((pt (point))) + (insert "The quick brown fox jumped over the lazy dog.\n") + (put-text-property pt (point) 'face `(:foreground ,(pop pool))))))) + +(defvar circe-nick-color-pool nil + "Pool of yet unused nick colors.") + +(defvar circe-nick-color-mapping (make-hash-table :test 'equal) + "Hash-table from nicks to colors.") + +(defun circe-nick-color-nick-list () + "Return list of all nicks that should be colored in this channel. +Own and blacklisted nicks are excluded." + (let ((our-nick (circe-nick)) + (channel-nicks (circe-channel-nicks))) + (cl-remove-if (lambda (nick) + (or (string= our-nick nick) + (member nick circe-color-nicks-message-blacklist))) + channel-nicks))) + +(defvar circe-nick-color-timestamps (make-hash-table :test 'equal) + "Hash-table from colors to the timestamp of their last use.") + +(defun circe-nick-color-for-nick (nick) + "Return the color for NICK. Assigns a color to NICK if one +wasn't assigned already." + (let ((color (gethash nick circe-nick-color-mapping))) + (when (not color) + ;; NOTE use this as entry point for taking NICK into account for + ;; picking the new color + (setq color (circe-nick-color-pick)) + (puthash nick color circe-nick-color-mapping)) + (puthash color (float-time) circe-nick-color-timestamps) + color)) + +(defun circe-nick-color-pick () + "Picks either a color from the pool of unused colors, or the +color that was used least recently (i.e. nicks that have it +assigned have been least recently active)." + (if (zerop (hash-table-count circe-nick-color-mapping)) + (setq circe-nick-color-pool (circe-nick-color-generate-pool))) + (or (pop circe-nick-color-pool) + (circe-nick-color-pick-least-recent))) + +(defun circe-nick-color-pick-least-recent () + "Pick the color that was used least recently. +See `circe-nick-color-pick', which is where this is used." + (let ((least-recent-color nil) + (oldest-time (float-time))) + (maphash + (lambda (color time) + (if (< time oldest-time) + (progn + (setq least-recent-color color) + (setq oldest-time time)))) + circe-nick-color-timestamps) + (if least-recent-color + least-recent-color + ;; Someone must have messed with `circe-nick-color-mapping', recover by + ;; re-filling the pool. + (setq circe-nick-color-pool (circe-nick-color-generate-pool)) + (pop circe-nick-color-pool)))) + +(defun circe-color-nicks () + "Color nicks on this lui output line." + (when (eq major-mode 'circe-channel-mode) + (let ((nickstart (text-property-any (point-min) (point-max) + 'lui-format-argument 'nick))) + (when nickstart + (goto-char nickstart) + (let ((nickend (next-single-property-change nickstart + 'lui-format-argument)) + (nick (plist-get (plist-get (text-properties-at nickstart) + 'lui-keywords) + :nick))) + (when (not (circe-server-my-nick-p nick)) + (let ((color (circe-nick-color-for-nick nick))) + (add-face-text-property nickstart nickend + `(:foreground ,color))))))) + (when circe-color-nicks-everywhere + (let ((body (text-property-any (point-min) (point-max) + 'lui-format-argument 'body))) + (when body + (with-syntax-table circe-nick-syntax-table + (goto-char body) + (let* ((nicks (circe-nick-color-nick-list)) + (regex (regexp-opt nicks 'words))) + (let (case-fold-search) + (while (re-search-forward regex nil t) + (let* ((nick (match-string-no-properties 0)) + (color (circe-nick-color-for-nick nick))) + (add-face-text-property (match-beginning 0) (match-end 0) + `(:foreground ,color)))))))))))) + +(defun circe-nick-color-reset () + "Reset the nick color mapping (and some internal data). + +This is useful if you switched between frames supporting +different color ranges and would like nicks to get new colors +appropriate to the new color range." + (interactive) + (setq circe-nick-color-pool (circe-nick-color-generate-pool)) + (setq circe-nick-color-mapping (make-hash-table :test 'equal)) + (setq circe-nick-color-timestamps (make-hash-table :test 'equal))) + +(provide 'circe-color-nicks) +;;; circe-color-nicks.el ends here |