sqrtminusone/dotfiles
1
0
Fork 0
mirror of https://github.com/SqrtMinusOne/dotfiles.git synced 2025-12-11 19:45:25 +03:00
Code Issues Projects Releases Packages Wiki Activity Actions

feat(emacs): simplify my/color-value

Browse source
This commit is contained in:
Pavel Korytov 2023-08-03 00:16:33 +05:00
parent f625ca0504
commit 77b0edc82a
2 changed files with 74 additions and 72 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

70
.emacs.d/init.el
View file

@ -895,23 +895,24 @@ then it takes a second \\[keyboard-quit] to abort the minibuffer."
(defun my/dark-p () (defun my/dark-p ()
(not (my/light-p))) (not (my/light-p)))
(defconst my/theme-string-override (defconst my/theme-override
'((doom-palenight '((doom-palenight
("red" . "#f07178")))) (red . "#f07178"))))
(defun my/doom-color (color) (defun my/doom-color (color)
(if (stringp color) (let ((override (alist-get (my/doom-p) my/theme-override))
(let ((override (alist-get (my/doom-p) my/theme-string-override))) (color-name (symbol-name color))
(or (is-light (ct-light-p (doom-color 'bg))))
(alist-get color override nil nil #'equal) (or
(pcase color (alist-get color override)
((or "red" "green" "yellow" "blue" "magenta" "cyan") (cond
(doom-color (intern color))) ((eq 'black color)
("black" (doom-color 'base0)) (if is-light (doom-color 'fg) (doom-color 'bg)))
("white" (doom-color 'base8)) ((eq 'white color)
((rx bos "light-") (if is-light (doom-color 'bg) (doom-color 'fg)))
(ct-edit-lab-l-inc (my/doom-color (substring color 6)) 10))))) ((string-match-p (rx bos "light-") color-name)
(doom-color color))) (ct-edit-lab-l-inc (my/doom-color (intern (substring color-name 6))) 10))
(t (doom-color color))))))
(defun my/modus-get-base (color) (defun my/modus-get-base (color)
(let ((base-value (string-to-number (substring (symbol-name color) 4 5))) (let ((base-value (string-to-number (substring (symbol-name color) 4 5)))
@ -920,45 +921,43 @@ then it takes a second \\[keyboard-quit] to abort the minibuffer."
(nth base-value (ct-gradient 9 base-start base-end t)))) (nth base-value (ct-gradient 9 base-start base-end t))))
(defun my/modus-color (color) (defun my/modus-color (color)
(let ((palette (modus-themes--current-theme-palette))) (let* ((palette (modus-themes--current-theme-palette))
(is-light (ct-light-p (cadr (assoc 'bg-main palette)))))
(cond (cond
((member color '("black" "white" "light-black" "light-white")) ((member color '(black white light-black light-white))
(let ((bg-main (cadr (assoc 'bg-main palette))) (let ((bg-main (cadr (assoc 'bg-main palette)))
(fg-main (cadr (assoc 'fg-main palette)))) (fg-main (cadr (assoc 'fg-main palette))))
(pcase color (pcase color
("black" (if (ct-light-p bg-main) fg-main bg-main)) ('black (if is-light fg-main bg-main))
("white" (if (ct-light-p bg-main) bg-main fg-main)) ('white (if is-light bg-main fg-main))
("light-black" (ct-edit-lab-l-inc ('light-black (ct-edit-lab-l-inc
(if (ct-light-p bg-main) fg-main bg-main) (if is-light fg-main bg-main)
15)) 15))
("light-white" (ct-edit-lab-l-inc ('light-white (ct-edit-lab-l-inc
(if (ct-light-p bg-main) bg-main fg-main) (if is-light bg-main fg-main)
15))))) 15)))))
((or (eq color 'bg)) ((or (eq color 'bg))
(cadr (assoc 'bg-main palette))) (cadr (assoc 'bg-main palette)))
((or (eq color 'fg)) ((or (eq color 'fg))
(cadr (assoc 'fg-main palette))) (cadr (assoc 'fg-main palette)))
((eq color 'violet) ((eq color 'violet)
(cadr (assoc 'magenta-cooler palette))) (cadr (assoc 'magenta-cooler palette)))
((and (symbolp color) (string-match-p (rx bos "base" digit) (symbol-name color))) ((string-match-p (rx bos "base" digit) (symbol-name color))
(my/modus-get-base color)) (my/modus-get-base color))
((and (symbolp color) (string-match-p (rx bos "dark-") (symbol-name color))) ((string-match-p (rx bos "dark-") (symbol-name color))
(cadr (assoc (intern (format "%s-cooler" (substring (symbol-name color) 5))) (cadr (assoc (intern (format "%s-cooler" (substring (symbol-name color) 5)))
palette))) palette)))
((eq color 'grey) ((eq color 'grey)
(my/modus-get-base 'base5)) (my/modus-get-base 'base5))
((member color '("red" "green" "yellow" "blue" "magenta" "cyan")) ((string-match-p (rx bos "light-") (symbol-name color))
(cadr (assoc (intern color) palette))) (cadr (assoc (intern (format "%s-intense" (substring (symbol-name color) 6))) palette)))
((and (stringp color) (string-match-p (rx bos "light-") color))
(cadr (assoc (intern (format "%s-intense" (substring color 6))) palette)))
(t (cadr (assoc color palette)))))) (t (cadr (assoc color palette))))))
(defconst my/test-colors-list (defconst my/test-colors-list
'("black" "red" "green" "yellow" "blue" "magenta" "cyan" "white" '(black red green yellow blue magenta cyan white light-black
"light-black" "light-red" "light-green" "light-yellow" light-red light-green light-yellow light-blue light-magenta
"light-blue" "light-magenta" "light-cyan" "light-white" bg fg red light-cyan light-white bg fg violet grey base0 base1 base2
green yellow blue magenta cyan dark-blue dark-cyan violet grey base3 base4 base5 base6 base7 base8))
base0 base1 base2 base3 base4 base5 base6 base7 base8))
(defun my/test-colors () (defun my/test-colors ()
(interactive) (interactive)
@ -977,6 +976,7 @@ then it takes a second \\[keyboard-quit] to abort the minibuffer."
(defun my/color-value (color) (defun my/color-value (color)
(cond (cond
((stringp color) (my/color-value (intern color)))
((eq color 'bg-other) ((eq color 'bg-other)
(let ((color (my/color-value 'bg))) (let ((color (my/color-value 'bg)))
(if (ct-light-p color) (if (ct-light-p color)

76
Emacs.org
View file

@ -1502,28 +1502,31 @@ I also want to know if the current theme is light or not:
(not (my/light-p))) (not (my/light-p)))
#+end_src #+end_src
Now, let's get the current color from =doom=. =doom-themes= provide =doom-color=, but it's not enough to populate =Xresources= and the format doesn't quite match. Now, let's get the current color from =doom=. =doom-themes= provide =doom-color=, but I also want to:
- override some colors
- add =black=, =white= and =light-*=
#+begin_src emacs-lisp #+begin_src emacs-lisp
(defconst my/theme-string-override (defconst my/theme-override
'((doom-palenight '((doom-palenight
("red" . "#f07178")))) (red . "#f07178"))))
(defun my/doom-color (color) (defun my/doom-color (color)
(if (stringp color) (let ((override (alist-get (my/doom-p) my/theme-override))
(let ((override (alist-get (my/doom-p) my/theme-string-override))) (color-name (symbol-name color))
(or (is-light (ct-light-p (doom-color 'bg))))
(alist-get color override nil nil #'equal) (or
(pcase color (alist-get color override)
((or "red" "green" "yellow" "blue" "magenta" "cyan") (cond
(doom-color (intern color))) ((eq 'black color)
("black" (doom-color 'base0)) (if is-light (doom-color 'fg) (doom-color 'bg)))
("white" (doom-color 'base8)) ((eq 'white color)
((rx bos "light-") (if is-light (doom-color 'bg) (doom-color 'fg)))
(ct-edit-lab-l-inc (my/doom-color (substring color 6)) 10))))) ((string-match-p (rx bos "light-") color-name)
(doom-color color))) (ct-edit-lab-l-inc (my/doom-color (intern (substring color-name 6))) 10))
(t (doom-color color))))))
#+end_src #+end_src
And the same for =modus-themes=. =my/modus-color= has to accept the same arguments as =my/doom-color= for backward compatibility. And the same for =modus-themes=. =my/modus-color= has to accept the same arguments as I use for =my/doom-color= for backward compatibility, which requires a bit more tuning.
#+begin_src emacs-lisp #+begin_src emacs-lisp
(defun my/modus-get-base (color) (defun my/modus-get-base (color)
(let ((base-value (string-to-number (substring (symbol-name color) 4 5))) (let ((base-value (string-to-number (substring (symbol-name color) 4 5)))
@ -1532,48 +1535,46 @@ And the same for =modus-themes=. =my/modus-color= has to accept the same argumen
(nth base-value (ct-gradient 9 base-start base-end t)))) (nth base-value (ct-gradient 9 base-start base-end t))))
(defun my/modus-color (color) (defun my/modus-color (color)
(let ((palette (modus-themes--current-theme-palette))) (let* ((palette (modus-themes--current-theme-palette))
(is-light (ct-light-p (cadr (assoc 'bg-main palette)))))
(cond (cond
((member color '("black" "white" "light-black" "light-white")) ((member color '(black white light-black light-white))
(let ((bg-main (cadr (assoc 'bg-main palette))) (let ((bg-main (cadr (assoc 'bg-main palette)))
(fg-main (cadr (assoc 'fg-main palette)))) (fg-main (cadr (assoc 'fg-main palette))))
(pcase color (pcase color
("black" (if (ct-light-p bg-main) fg-main bg-main)) ('black (if is-light fg-main bg-main))
("white" (if (ct-light-p bg-main) bg-main fg-main)) ('white (if is-light bg-main fg-main))
("light-black" (ct-edit-lab-l-inc ('light-black (ct-edit-lab-l-inc
(if (ct-light-p bg-main) fg-main bg-main) (if is-light fg-main bg-main)
15)) 15))
("light-white" (ct-edit-lab-l-inc ('light-white (ct-edit-lab-l-inc
(if (ct-light-p bg-main) bg-main fg-main) (if is-light bg-main fg-main)
15))))) 15)))))
((or (eq color 'bg)) ((or (eq color 'bg))
(cadr (assoc 'bg-main palette))) (cadr (assoc 'bg-main palette)))
((or (eq color 'fg)) ((or (eq color 'fg))
(cadr (assoc 'fg-main palette))) (cadr (assoc 'fg-main palette)))
((eq color 'violet) ((eq color 'violet)
(cadr (assoc 'magenta-cooler palette))) (cadr (assoc 'magenta-cooler palette)))
((and (symbolp color) (string-match-p (rx bos "base" digit) (symbol-name color))) ((string-match-p (rx bos "base" digit) (symbol-name color))
(my/modus-get-base color)) (my/modus-get-base color))
((and (symbolp color) (string-match-p (rx bos "dark-") (symbol-name color))) ((string-match-p (rx bos "dark-") (symbol-name color))
(cadr (assoc (intern (format "%s-cooler" (substring (symbol-name color) 5))) (cadr (assoc (intern (format "%s-cooler" (substring (symbol-name color) 5)))
palette))) palette)))
((eq color 'grey) ((eq color 'grey)
(my/modus-get-base 'base5)) (my/modus-get-base 'base5))
((member color '("red" "green" "yellow" "blue" "magenta" "cyan")) ((string-match-p (rx bos "light-") (symbol-name color))
(cadr (assoc (intern color) palette))) (cadr (assoc (intern (format "%s-intense" (substring (symbol-name color) 6))) palette)))
((and (stringp color) (string-match-p (rx bos "light-") color))
(cadr (assoc (intern (format "%s-intense" (substring color 6))) palette)))
(t (cadr (assoc color palette)))))) (t (cadr (assoc color palette))))))
#+end_src #+end_src
Test the two functions. Test the two functions.
#+begin_src emacs-lisp #+begin_src emacs-lisp
(defconst my/test-colors-list (defconst my/test-colors-list
'("black" "red" "green" "yellow" "blue" "magenta" "cyan" "white" '(black red green yellow blue magenta cyan white light-black
"light-black" "light-red" "light-green" "light-yellow" light-red light-green light-yellow light-blue light-magenta
"light-blue" "light-magenta" "light-cyan" "light-white" bg fg red light-cyan light-white bg fg violet grey base0 base1 base2
green yellow blue magenta cyan dark-blue dark-cyan violet grey base3 base4 base5 base6 base7 base8))
base0 base1 base2 base3 base4 base5 base6 base7 base8))
(defun my/test-colors () (defun my/test-colors ()
(interactive) (interactive)
@ -1595,6 +1596,7 @@ Finally, one function to get the value of a color in the current theme.
#+begin_src emacs-lisp #+begin_src emacs-lisp
(defun my/color-value (color) (defun my/color-value (color)
(cond (cond
((stringp color) (my/color-value (intern color)))
((eq color 'bg-other) ((eq color 'bg-other)
(let ((color (my/color-value 'bg))) (let ((color (my/color-value 'bg)))
(if (ct-light-p color) (if (ct-light-p color)