~pkal/face-shift: face-shift.el - sourcehut git


                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
;;; face-shift.el --- Shift the colour of certain faces -*- lexical-binding: t -*-

;; Author: Philip Kaludercic <philipk@posteo.net>
;; Version: 0.2.0
;; Keywords: faces
;; Package-Requires: ((emacs "24.1"))
;; URL: https://git.sr.ht/~pkal/face-shift

;; This file is NOT part of Emacs.
;;
;; This file is in the public domain, to the extent possible under law,
;; published under the CC0 1.0 Universal license.
;;
;; For a full copy of the CC0 license see
;; https://creativecommons.org/publicdomain/zero/1.0/legalcode

;;; Commentary:

;; This library provides a (global) minor mode to shift the fore- and
;; background colours of all buffers towards a certain hue.  Which hue
;; which major mode should take on is described in
;; `face-shift-shifts'.

;;; Code:

(require 'color)
(require 'face-remap)

(defgroup face-shift nil
  "Distort colour of certain faces."
  :group 'faces
  :prefix "face-shift-")

(defcustom face-shift-faces
  '(default
    cursor
    highlight
    region
    shadow
    secondary-selection
    isearch
    isearch-fail
    lazy-highlight
    match
    query-replace)
  "Faces that command `face-shift-mode' should distort."
  :type '(list face))

(defcustom face-shift-shifts
  '((text-mode . "linen")
    (help-mode . "lavender blush")
    (prog-mode . "honeydew")
    (dired-mode . "azure")
    (comint-mode . "light yellow")
    (eshell-mode . "light yellow"))
  "In what direction to shift what major mode and derivatives.

The first element of each element is a symbol representing the
major mode and all it's derivatives.  If a buffer's major mode is
derived from this mode, it will use the string value to shift all
colours in `face-shift-faces' towards the colour in string.  If
the colour name is invalid or doesn't exist, it will not apply
any shift.

See info node `(emacs) Colors' or `color-name-to-rgb' for more
information."
  :type '(alist :key-type face :value-type string))

(defcustom face-shift-shift-foreground nil
  "Non-nil means shift the forground color too."
  :type 'boolean)

(defvar face-shift--cookies nil
  "List of remapped faces in a single buffer.")
(make-variable-buffer-local 'face-shift--cookies)

(defcustom face-shift-intensity (/ (1+ (sqrt 5)) 2)
  "Relaxation factor when applying a colour-shift.

See `face-shift--interpolate'."
  :type 'number)

(defun face-shift--interpolate (col-ref col-base)
  "Attempt to find median colour between COL-REF and COL-BASE."
  (let (results)
    (while (and col-ref col-base)
      (let ((ref (pop col-ref))
            (base (pop col-base)))
        (push (if (> face-shift-intensity 0)
                  (- 1 (* (- 1 (* ref base)) face-shift-intensity))
                (* (* ref base) (abs face-shift-intensity)))
              results)))
    (nreverse results)))

(defun face-shift-setup (&optional buffer)
  "Shift colours in BUFFER according to `face-shift-shifts'.

If BUFFER is nil, use current buffer."
  (with-current-buffer (or buffer (current-buffer))
    (let ((colour (cdr (assoc (apply #'derived-mode-p
                                     (mapcar #'car face-shift-shifts))
                              face-shift-shifts))))
      (when colour
        (dolist (face face-shift-faces)
          (dolist (prop (if face-shift-shift-foreground
                            '(:background :foreground)
                          '(:background)))
            (let* ((attr (face-attribute face prop))
                   (rgb (and attr (color-name-to-rgb attr)))
                   (shift (and rgb (face-shift--interpolate
                                    (color-name-to-rgb colour)
                                    rgb)))
                   (new (and shift (apply #'color-rgb-to-hex shift))))
              (when new
                (push (face-remap-add-relative face `(,prop ,new))
                      face-shift--cookies)))))))))

(defun face-shift-clear (buffer)
  "Undo colour shifts in BUFFER by `face-shift-setup'."
  (with-current-buffer buffer
    (dolist (cookie face-shift--cookies)
      (face-remap-remove-relative cookie))
    (setq face-shift--cookies nil)))

;;;###autoload
(define-minor-mode face-shift-mode
  "Shift fore- and background colour towards a certain hue.

See `face-shift-shifts' and `face-shift-intensity' for more
information"
  :group 'face-shift
  :global t
  (if face-shift-mode
      (progn
        (mapc #'face-shift-setup (buffer-list))
        (add-hook 'after-change-major-mode-hook #'face-shift-setup))
    (mapc #'face-shift-clear (buffer-list))
    (remove-hook 'after-change-major-mode-hook #'face-shift-setup)))

(provide 'face-shift)

;;; face-shift.el ends here