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 (regex-case color-string
51 ("#[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
))
52 ("#[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
))))
53 ("#[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
))
54 ("#[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
))))
56 (multiple-value-bind (rgb-list a-list
) (firstn (ppcre:split
"[ ,]+" (reg 0)) 3)
57 (values* (values-list (map 'list
#'parse-css-rgb-value rgb-list
))
58 (parse-css-alpha-value (first a-list
)))))
60 (destructuring-bind (h s l
&optional a
) (ppcre:split
"[ ,/]+" (reg 0))
61 (values* (dufy/core
:hsl-to-rgb
(parse-css-hue-value h
)
62 (parse-css-rgb-value s
)
63 (parse-css-rgb-value l
))
64 (parse-css-alpha-value a
))))
66 (when-let ((color-list (cdr (assoc color-string
*web-colors-list
* :test
#'string-equal
))))
67 (values* (values-list color-list
) 1.0d0
)))))
69 (defun encode-css-color (r g b a
)
70 (format nil
"#~6,'0X~2,'0X" (dufy/core
:rgb-to-rgbpack r g b
) (round (* a
255))))
72 (defun safe-color-name (r g b a
)
73 (format nil
"~6,'0X~2,'0X" (dufy/core
:rgb-to-rgbpack r g b
) (round (* a
255))))
75 (defun gamma-invert-lightness (l &optional gamma
)
76 (declare (double-float l
)
77 (type (or null
(double-float 0d0
)) gamma
))
78 (let ((gamma (or gamma
1.7d0
)))
79 (cond ((>= l
1d0
) 0d0
)
81 (t (expt (the (double-float 0d0
) (- 1d0 l
)) (/ gamma
))))))
83 (defun linear-to-srgb (r g b
)
84 (declare (optimize (debug 0))
87 (declare (double-float x
))
88 (if (>= x
0.0031308d0
)
89 (- (* 1.055d0
(expt x
(/ 2.4d0
))) 0.055d0
)
92 (values (f r
) (f g
) (f b
))))
94 (defun linear-to-simple-srgb (r g b
)
95 (declare (double-float r g b
))
96 (flet ((f (x) (if (plusp x
) (expt x
(/ 2.2d0
)) 0d0
)))
97 (values (f r
) (f g
) (f b
))))
99 (defun srgb-to-linear (r g b
)
100 (declare (optimize (debug 0))
101 (double-float r g b
))
103 (declare (double-float x
))
105 (expt (/ (+ x
0.055d0
) 1.055d0
) 2.4d0
)
108 (values (f r
) (f g
) (f b
))))
110 (defun simple-srgb-to-linear (r g b
)
111 (declare (double-float r g b
))
113 (if (plusp x
) (expt x
2.2d0
) 0d0
)))
114 (values (f r
) (f g
) (f b
))))
116 (declaim (ftype (function (double-float double-float double-float
) (values double-float double-float double-float
))
118 oklab-to-linear-srgb
))
120 (defun linear-srgb-to-oklab (r g b
)
121 (declare (optimize (debug 0))
122 (type (double-float 0d0
) r g b
))
123 (flet ((soft-cbrt (x)
124 (declare (type (double-float 0d0
) x
))
125 (let* ((image-cutoff 0.1d0
)
126 (arg-cutoff (expt image-cutoff
3)))
128 (* (expt arg-cutoff
1/3) (expt (- (* (/ arg-cutoff
) x
) 1) (/ 3.0d0
)))
129 (* (/ arg-cutoff image-cutoff
) x
)))))
130 (declare (inline soft-cbrt
))
131 (let ((l (soft-cbrt (+ (* 0.4122214708 r
) (* 0.5363325363 g
) (* 0.0514459929 b
))))
132 (m (soft-cbrt (+ (* 0.2119034982 r
) (* 0.6806995451 g
) (* 0.1073969566 b
))))
133 (s (soft-cbrt (+ (* 0.0883024619 r
) (* 0.2817188376 g
) (* 0.6299787005 b
)))))
134 (values (+ (* 0.2104542553 l
) (* +0.7936177850 m
) (* -
0.0040720468 s
))
135 (+ (* 1.9779984951 l
) (* -
2.4285922050 m
) (* +0.4505937099 s
))
136 (+ (* 0.0259040371 l
) (* +0.7827717662 m
) (* -
0.8086757660 s
))))))
138 (declaim (ftype (function (double-float double-float
) (values double-float double-float
))
141 (defun ab-to-ch (a b
)
142 (declare (type (double-float #.
(- pi
) #.pi
) a b
))
143 (values (sqrt (+ (expt a
2) (expt b
2)))
146 (defun ch-to-ab (c h
)
147 (declare (type (double-float #.
(- pi
) #.pi
) c h
))
148 (values (* c
(cos h
))
151 (defun oklab-to-linear-srgb (l a b
)
152 (declare (optimize (debug 0))
153 (type double-float l
)
154 (type (double-float #.
(- pi
) #.pi
) a b
))
155 (flet ((soft-cube (x)
156 (declare (type double-float x
))
157 (let* ((arg-cutoff 0.1d0
)
158 (image-cutoff (expt arg-cutoff
3)))
160 (+ image-cutoff
(* (- 1 image-cutoff
) (expt x
3)))
161 (* (/ image-cutoff arg-cutoff
) x
)))))
162 (declare (inline soft-cube
))
163 (let ((l (soft-cube (+ l
(* 0.3963377774 a
) (* 0.2158037573 b
))))
164 (m (soft-cube (- l
(* 0.1055613458 a
) (* 0.0638541728 b
))))
165 (s (soft-cube (- l
(* 0.0894841775 a
) (* 1.2914855480 b
)))))
166 (values (+ (* +4.0767416621 l
) (* -
3.3077115913 m
) (* +0.2309699292 s
))
167 (+ (* -
1.2684380046 l
) (* +2.6097574011 m
) (* -
0.3413193965 s
))
168 (+ (* -
0.0041960863 l
) (* -
0.7034186147 m
) (* +1.7076147010 s
))))))
170 (defun oklab-to-srgb (l a b
)
171 (declare (optimize (debug 0))
172 (double-float l a b
))
173 (flet ((in-gamut (l a b
)
174 (multiple-value-bind (r g b
) (multiple-value-call #'linear-to-srgb
(oklab-to-linear-srgb l a b
))
175 (and (not (> (max r g b
) 1.0d0
))
176 (not (< (min r g b
) 0.0d0
))))))
178 (multiple-value-call #'linear-to-srgb
(oklab-to-linear-srgb l a b
))
179 (let ((array (cl-grnm:grnm-optimize
181 (let ((c-l (aref array
0))
183 (c-b (aref array
2)))
184 (declare (double-float c-l c-a c-b
))
185 (if (in-gamut c-l c-a c-b
)
186 (+ (* 10.0d0
(the double-float
(expt (- l c-l
) 2)))
189 most-positive-double-float
)))
190 (vector (* (+ 0.05d0
(max 0.0d0
(min 1.0d0 l
))) 0.9d0
) 0.0d0
0.0d0
)
191 :max-function-calls
10000)))
192 (let ((l (aref array
0))
195 (multiple-value-call #'linear-to-srgb
(oklab-to-linear-srgb l a b
)))))))
197 (defun perceptual-invert-rgba (r g b alpha
&optional gamma
)
198 (multiple-value-bind (l a b
)
199 (multiple-value-call #'linear-srgb-to-oklab
(srgb-to-linear r g b
))
200 (multiple-value-bind (c h
)
202 (multiple-value-bind (a b
)
203 (ch-to-ab c
(if (< -
1.5591128900152316d0 h
2.372773855360125d0
)
205 (+ (* (mod (- h
2.372773855360125d0
) (* 2 pi
))
206 0.11248729401633725d0
)
207 2.372773855360125d0
)))
208 (multiple-value-call #'values
209 (oklab-to-srgb (gamma-invert-lightness l gamma
) a b
)
212 (defun perceptual-invert-color-string (color-string &optional gamma
)
213 (multiple-value-call #'encode-css-color
(multiple-value-call #'perceptual-invert-rgba
(decode-css-color color-string
) gamma
)))
215 (defun rewrite-css-colors (in-stream out-stream fn
)
216 (flet ((replacer (target-string start end match-start match-end reg-starts reg-ends
)
217 (declare (ignore start end reg-starts reg-ends
))
218 (funcall fn
(substring target-string match-start match-end
))))
219 (declare (dynamic-extent #'replacer
))
220 (loop for in-line
= (read-line in-stream nil
)
222 do
(let ((out-line (ppcre:regex-replace-all -css-color-scanner- in-line
#'replacer
)))
223 (write-line out-line out-stream
)))))