1 (uiop:define-package
#:lw2.colors
2 (:use
#:cl
#:iterate
#:lw2.utils
)
3 (:import-from
#:alexandria
#:when-let
#:emptyp
)
4 (:import-from
#:parse-float
#:parse-float
)
5 (:export
#:-css-color-scanner-
#:decode-css-color
#:encode-css-color
#:safe-color-name
#:perceptual-invert-rgba
#:perceptual-invert-color-string
))
7 (in-package #:lw2.colors
)
9 ;;;; Refer to https://drafts.csswg.org/css-color/#numeric-srgb
11 (global-vars:define-global-parameter -css-color-scanner-
(ppcre:create-scanner
"#[0-9a-fA-F]{3,8}|rgba?\\((?:.*?)\\)|hsla?\\((?:.*?)\\)"))
13 (defparameter *web-colors-list
*
14 (with-open-file (stream (asdf:system-relative-pathname
:lw2-viewer
"data/webcolors.json") :direction
:input
)
17 (cons (cdr (assoc :name color-data
))
18 (map 'list
(lambda (x) (/ (the (integer 0 255) (cdr x
)) 255.0d0
)) (cdr (assoc :rgb color-data
)))))
19 (json:decode-json stream
))))
21 (defun parse-multi-hex (string count length
&key
(start 0) (key #'identity
))
23 (iter (for i from start below
(+ start
(* count length
)) by length
)
24 (collect (funcall key
(parse-integer string
:start i
:end
(+ i length
) :radix
16))))))
26 (defun parse-css-rgb-value (string)
27 (let ((number (parse-integer string
:junk-allowed t
)))
28 (if (ppcre:scan
"%$" string
)
32 (defun parse-css-hue-value (string)
33 (let ((number (parse-float string
:junk-allowed t
)))
35 ("grad$" (* number
(/ 360.0d0
400.0d0
)))
36 ("rad$" (* number
(/ 360.0d0
(* 2 pi
))))
37 ("turn$" (* number
360.0d0
))
38 ("%$" (* number
(/ 360.0d0
100.0d0
)))
41 (defun parse-css-alpha-value (string)
42 (let ((number (and (not (emptyp string
)) (parse-float string
:junk-allowed t
))))
45 ("%$" (/ number
100d0
))
49 (defun decode-css-color (color-string)
50 ;; TODO: handle CSS variables
51 (regex-case color-string
52 ("#[0-9a-fA-F]{3}\\s*$" (values* (parse-multi-hex color-string
3 1 :start
1 :key
(lambda (x) (declare (type (integer 0 15) x
)) (/ (+ x
(* x
16)) 255.0d0
))) 1.0d0
))
53 ("#[0-9a-fA-F]{4}\\s*$" (parse-multi-hex color-string
4 1 :start
1 :key
(lambda (x) (declare (type (integer 0 15) x
)) (/ (+ x
(* x
16)) 255.0d0
))))
54 ("#[0-9a-fA-F]{6}\\s*$" (values* (parse-multi-hex color-string
3 2 :start
1 :key
(lambda (x) (declare (type (integer 0 255) x
)) (/ x
255.0d0
))) 1.0d0
))
55 ("#[0-9a-fA-F]{8}\\s*$" (parse-multi-hex color-string
4 2 :start
1 :key
(lambda (x) (declare (type (integer 0 255) x
)) (/ x
255.0d0
))))
57 (multiple-value-bind (rgb-list a-list
) (firstn (ppcre:split
"[ ,]+" (reg 0)) 3)
58 (values* (values-list (map 'list
#'parse-css-rgb-value rgb-list
))
59 (parse-css-alpha-value (first a-list
)))))
61 (destructuring-bind (h s l
&optional a
) (ppcre:split
"[ ,/]+" (reg 0))
62 (values* (dufy/core
:hsl-to-rgb
(parse-css-hue-value h
)
63 (parse-css-rgb-value s
)
64 (parse-css-rgb-value l
))
65 (parse-css-alpha-value a
))))
67 (when-let ((color-list (cdr (assoc color-string
*web-colors-list
* :test
#'string-equal
))))
68 (values* (values-list color-list
) 1.0d0
)))))
70 (defun encode-css-color (r g b a
)
71 (format nil
"#~6,'0X~2,'0X" (dufy/core
:rgb-to-rgbpack r g b
) (round (* a
255))))
73 (defun safe-color-name (r g b a
)
74 (format nil
"~6,'0X~2,'0X" (dufy/core
:rgb-to-rgbpack r g b
) (round (* a
255))))
76 (defun gamma-invert-lightness (l &optional gamma
)
77 (declare (double-float l
)
78 (type (or null
(double-float 0d0
)) gamma
))
79 (let ((gamma (or gamma
1.7d0
)))
80 (cond ((>= l
1d0
) 0d0
)
82 (t (expt (the (double-float 0d0
) (- 1d0 l
)) (/ gamma
))))))
84 (defun linear-to-srgb (r g b
)
85 (declare (optimize (debug 0))
88 (declare (double-float x
))
89 (if (>= x
0.0031308d0
)
90 (- (* 1.055d0
(expt x
(/ 2.4d0
))) 0.055d0
)
93 (values (f r
) (f g
) (f b
))))
95 (defun linear-to-simple-srgb (r g b
)
96 (declare (double-float r g b
))
97 (flet ((f (x) (if (plusp x
) (expt x
(/ 2.2d0
)) 0d0
)))
98 (values (f r
) (f g
) (f b
))))
100 (defun srgb-to-linear (r g b
)
101 (declare (optimize (debug 0))
102 (double-float r g b
))
104 (declare (double-float x
))
106 (expt (/ (+ x
0.055d0
) 1.055d0
) 2.4d0
)
109 (values (f r
) (f g
) (f b
))))
111 (defun simple-srgb-to-linear (r g b
)
112 (declare (double-float r g b
))
114 (if (plusp x
) (expt x
2.2d0
) 0d0
)))
115 (values (f r
) (f g
) (f b
))))
117 (declaim (ftype (function (double-float double-float double-float
) (values double-float double-float double-float
))
119 oklab-to-linear-srgb
))
121 (defun linear-srgb-to-oklab (r g b
)
122 (declare (optimize (debug 0))
123 (type (double-float 0d0
) r g b
))
124 (flet ((soft-cbrt (x)
125 (declare (type (double-float 0d0
) x
))
126 (let* ((image-cutoff 0.1d0
)
127 (arg-cutoff (expt image-cutoff
3)))
129 (* (expt arg-cutoff
1/3) (expt (- (* (/ arg-cutoff
) x
) 1) (/ 3.0d0
)))
130 (* (/ arg-cutoff image-cutoff
) x
)))))
131 (declare (inline soft-cbrt
))
132 (let ((l (soft-cbrt (+ (* 0.4122214708 r
) (* 0.5363325363 g
) (* 0.0514459929 b
))))
133 (m (soft-cbrt (+ (* 0.2119034982 r
) (* 0.6806995451 g
) (* 0.1073969566 b
))))
134 (s (soft-cbrt (+ (* 0.0883024619 r
) (* 0.2817188376 g
) (* 0.6299787005 b
)))))
135 (values (+ (* 0.2104542553 l
) (* +0.7936177850 m
) (* -
0.0040720468 s
))
136 (+ (* 1.9779984951 l
) (* -
2.4285922050 m
) (* +0.4505937099 s
))
137 (+ (* 0.0259040371 l
) (* +0.7827717662 m
) (* -
0.8086757660 s
))))))
139 (declaim (ftype (function (double-float double-float
) (values double-float double-float
))
142 (defun ab-to-ch (a b
)
143 (declare (type (double-float #.
(- pi
) #.pi
) a b
))
144 (values (sqrt (+ (expt a
2) (expt b
2)))
147 (defun ch-to-ab (c h
)
148 (declare (type (double-float #.
(- pi
) #.pi
) c h
))
149 (values (* c
(cos h
))
152 (defun oklab-to-linear-srgb (l a b
)
153 (declare (optimize (debug 0))
154 (type double-float l
)
155 (type (double-float #.
(- pi
) #.pi
) a b
))
156 (flet ((soft-cube (x)
157 (declare (type double-float x
))
158 (let* ((arg-cutoff 0.1d0
)
159 (image-cutoff (expt arg-cutoff
3)))
161 (+ image-cutoff
(* (- 1 image-cutoff
) (expt x
3)))
162 (* (/ image-cutoff arg-cutoff
) x
)))))
163 (declare (inline soft-cube
))
164 (let ((l (soft-cube (+ l
(* 0.3963377774 a
) (* 0.2158037573 b
))))
165 (m (soft-cube (- l
(* 0.1055613458 a
) (* 0.0638541728 b
))))
166 (s (soft-cube (- l
(* 0.0894841775 a
) (* 1.2914855480 b
)))))
167 (values (+ (* +4.0767416621 l
) (* -
3.3077115913 m
) (* +0.2309699292 s
))
168 (+ (* -
1.2684380046 l
) (* +2.6097574011 m
) (* -
0.3413193965 s
))
169 (+ (* -
0.0041960863 l
) (* -
0.7034186147 m
) (* +1.7076147010 s
))))))
171 (defun oklab-to-srgb (l a b
)
172 (declare (optimize (debug 0))
173 (double-float l a b
))
174 (flet ((in-gamut (l a b
)
175 (multiple-value-bind (r g b
) (multiple-value-call #'linear-to-srgb
(oklab-to-linear-srgb l a b
))
176 (and (not (> (max r g b
) 1.0d0
))
177 (not (< (min r g b
) 0.0d0
))))))
179 (multiple-value-call #'linear-to-srgb
(oklab-to-linear-srgb l a b
))
180 (let ((array (cl-grnm:grnm-optimize
182 (let ((c-l (aref array
0))
184 (c-b (aref array
2)))
185 (declare (double-float c-l c-a c-b
))
186 (if (in-gamut c-l c-a c-b
)
187 (+ (* 10.0d0
(the double-float
(expt (- l c-l
) 2)))
190 most-positive-double-float
)))
191 (vector (* (+ 0.05d0
(max 0.0d0
(min 1.0d0 l
))) 0.9d0
) 0.0d0
0.0d0
)
192 :max-function-calls
10000)))
193 (let ((l (aref array
0))
196 (multiple-value-call #'linear-to-srgb
(oklab-to-linear-srgb l a b
)))))))
198 (defun perceptual-invert-rgba (r g b alpha
&optional gamma
)
199 (multiple-value-bind (l a b
)
200 (multiple-value-call #'linear-srgb-to-oklab
(srgb-to-linear r g b
))
201 (multiple-value-bind (c h
)
203 (multiple-value-bind (a b
)
204 (ch-to-ab c
(if (< -
1.5591128900152316d0 h
2.372773855360125d0
)
206 (+ (* (mod (- h
2.372773855360125d0
) (* 2 pi
))
207 0.11248729401633725d0
)
208 2.372773855360125d0
)))
209 (multiple-value-call #'values
210 (oklab-to-srgb (gamma-invert-lightness l gamma
) a b
)
213 (defun perceptual-invert-color-string (color-string &optional gamma
)
214 (multiple-value-call #'encode-css-color
(multiple-value-call #'perceptual-invert-rgba
(decode-css-color color-string
) gamma
)))
216 (defun rewrite-css-colors (in-stream out-stream fn
)
217 (flet ((replacer (target-string start end match-start match-end reg-starts reg-ends
)
218 (declare (ignore start end reg-starts reg-ends
))
219 (funcall fn
(substring target-string match-start match-end
))))
220 (declare (dynamic-extent #'replacer
))
221 (loop for in-line
= (read-line in-stream nil
)
223 do
(let ((out-line (ppcre:regex-replace-all -css-color-scanner- in-line
#'replacer
)))
224 (write-line out-line out-stream
)))))