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
143
144
145
146
147
148
149
|
;;; face-shift.el --- Shift the colour of certain faces -*- lexical-binding: t -*-
;; Copyright (C) 2019, 2021, 2023 Free Software Foundation, Inc.
;; Author: Philip Kaludercic <philipk@posteo.net>
;; Version: 0.2.1
;; Keywords: faces
;; Package-Requires: ((emacs "24.1"))
;; URL: https://git.sr.ht/~pkal/face-shift
;; 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, see <https://www.gnu.org/licenses/>.
;;; 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
|
