From 520b7cb0408ec8e4498d53f21f5189d73bafb1bb Mon Sep 17 00:00:00 2001 From: saturn Date: Fri, 14 Oct 2022 03:49:35 -0500 Subject: [PATCH] Add oklab support to colors.lisp --- lw2-viewer.asd | 2 +- src/colors.lisp | 84 ++++++++++++++++++++++++++++++++++++++++++++++++++++----- 2 files changed, 78 insertions(+), 8 deletions(-) diff --git a/lw2-viewer.asd b/lw2-viewer.asd index 5b30077d..fc1ed92e 100644 --- a/lw2-viewer.asd +++ b/lw2-viewer.asd @@ -1,7 +1,7 @@ (in-package :asdf) (asdf:defsystem :lw2-viewer - :depends-on ("uiop" "flexi-streams" "hunchentoot" "dexador" "cl-json" "lmdb" "local-time" "plump" "clss" "cl-ppcre" "xml-emitter" "city-hash" "bit-smasher" "cl-unicode" "parse-js" "cl-markdown" "websocket-driver-client" "ironclad" "cl-base64" "djula" "split-sequence" "cl-typesetting" "named-readtables" "collectors" "closer-mop" "chronicity" "parenscript" "trivial-gray-streams" "trivia" "iterate" "introspect-environment" "trivial-macroexpand-all" "trivial-cltl2" "dufy/core" "parse-float" "global-vars") + :depends-on ("uiop" "flexi-streams" "hunchentoot" "dexador" "cl-json" "lmdb" "local-time" "plump" "clss" "cl-ppcre" "xml-emitter" "city-hash" "bit-smasher" "cl-unicode" "parse-js" "cl-markdown" "websocket-driver-client" "ironclad" "cl-base64" "djula" "split-sequence" "cl-typesetting" "named-readtables" "collectors" "closer-mop" "chronicity" "parenscript" "trivial-gray-streams" "trivia" "iterate" "introspect-environment" "trivial-macroexpand-all" "trivial-cltl2" "dufy/core" "parse-float" "global-vars" "cl-grnm") :components ((:module "src" :components ((:file "utils" :depends-on ("macro-utils")) (:file "macro-utils") diff --git a/src/colors.lisp b/src/colors.lisp index 12683288..83de5aa3 100644 --- a/src/colors.lisp +++ b/src/colors.lisp @@ -73,17 +73,87 @@ (format nil "~6,'0X~2,'0X" (dufy/core:rgb-to-rgbpack r g b) (round (* a 255)))) (defun gamma-invert-lightness (l) - (if (>= l 100d0) + (if (>= l 1d0) 0d0 - (* 100d0 (expt (- 1d0 (/ l 100d0)) (/ 1.25d0))))) + (expt (- 1d0 l) (/ 2.2d0)))) + +(defun linear-to-srgb (r g b) + (declare (optimize (debug 0)) + (double-float r g b)) + (flet ((f (x) + (if (>= x 0.0031308) + (- (* 1.055 (the double-float (expt x (/ 2.4d0)))) 0.055) + (* 12.92 x)))) + (declare (inline f)) + (values (f r) (f g) (f b)))) + +(defun srgb-to-linear (r g b) + (declare (optimize (debug 0)) + (double-float r g b)) + (flet ((f (x) + (if (>= x 0.04045) + (the double-float (expt (/ (+ x 0.055) 1.055) 2.4d0)) + (/ x 12.92)))) + (declare (inline f)) + (values (f r) (f g) (f b)))) + +(defun linear-srgb-to-oklab (r g b) + (declare (optimize (debug 0)) + (double-float r g b)) + (flet ((cbrt (x) (the double-float (expt x (/ 3.0d0))))) + (declare (inline cbrt)) + (let ((l (cbrt (+ (* 0.4122214708 r) (* 0.5363325363 g) (* 0.0514459929 b)))) + (m (cbrt (+ (* 0.2119034982 r) (* 0.6806995451 g) (* 0.1073969566 b)))) + (s (cbrt (+ (* 0.0883024619 r) (* 0.2817188376 g) (* 0.6299787005 b))))) + (values (+ (* 0.2104542553 l) (* +0.7936177850 m) (* -0.0040720468 s)) + (+ (* 1.9779984951 l) (* -2.4285922050 m) (* +0.4505937099 s)) + (+ (* 0.0259040371 l) (* +0.7827717662 m) (* -0.8086757660 s)))))) + +(defun oklab-to-linear-srgb (l a b) + (declare (optimize (debug 0)) + (double-float l a b)) + (flet ((cube (x) (* x x x))) + (declare (inline cube)) + (let ((l (cube (+ l (* 0.3963377774 a) (* 0.2158037573 b)))) + (m (cube (- l (* 0.1055613458 a) (* 0.0638541728 b)))) + (s (cube (- l (* 0.0894841775 a) (* 1.2914855480 b))))) + (values (+ (* +4.0767416621 l) (* -3.3077115913 m) (* +0.2309699292 s)) + (+ (* -1.2684380046 l) (* +2.6097574011 m) (* -0.3413193965 s)) + (+ (* -0.0041960863 l) (* -0.7034186147 m) (* +1.7076147010 s)))))) + +(defun oklab-to-srgb (l a b) + (declare (optimize (debug 0)) + (double-float l a b)) + (flet ((in-gamut (l a b) + (multiple-value-bind (r g b) (multiple-value-call #'linear-to-srgb (oklab-to-linear-srgb l a b)) + (and (not (> (max r g b) 1.0d0)) + (not (< (min r g b) 0.0d0)))))) + (if (in-gamut l a b) + (multiple-value-call #'linear-to-srgb (oklab-to-linear-srgb l a b)) + (let ((array (cl-grnm:grnm-optimize + (lambda (array) + (let ((c-l (aref array 0)) + (c-a (aref array 1)) + (c-b (aref array 2))) + (declare (double-float c-l c-a c-b)) + (if (in-gamut c-l c-a c-b) + (+ (* 10.0d0 (the double-float (expt (- l c-l) 2))) + (expt (- a c-a) 2) + (expt (- b c-b) 2)) + most-positive-double-float))) + (vector (* (+ 0.05d0 (max 0.0d0 (min 1.0d0 l))) 0.9d0) 0.0d0 0.0d0) + :max-function-calls 10000))) + (let ((l (aref array 0)) + (a (aref array 1)) + (b (aref array 2))) + (multiple-value-call #'linear-to-srgb (oklab-to-linear-srgb l a b))))))) (defun perceptual-invert-rgba (r g b alpha) (multiple-value-bind (l a b) - (multiple-value-call #'dufy/core:xyz-to-lab (dufy/core:rgb-to-xyz r g b)) - (multiple-value-bind (nr ng nb) - (multiple-value-call #'dufy/core:xyz-to-rgb - (dufy/core:lab-to-xyz (gamma-invert-lightness l) a b)) - (values nr ng nb alpha)))) + (multiple-value-call #'linear-srgb-to-oklab (srgb-to-linear r g b)) + (multiple-value-call #'values + (oklab-to-srgb (gamma-invert-lightness l) a b) + alpha))) (defun perceptual-invert-color-string (color-string) (multiple-value-call #'encode-css-color (multiple-value-call #'perceptual-invert-rgba (decode-css-color color-string)))) -- 2.11.4.GIT