src/colors.lisp

   1 (uiop:define-package #:lw2.colors
   2   (:use #:cl #:iterate #:lw2.utils)
   3   (:import-from #:alexandria #:when-let #:emptyp)
   4   (:export #:decode-css-color #:encode-css-color #:safe-color-name #:perceptual-invert-rgba #:perceptual-invert-color-string))
   5
   6 (in-package #:lw2.colors)
   7
   8 ;;;; Refer to https://drafts.csswg.org/css-color/#numeric-srgb
   9
  10 (defparameter *web-colors-list*
  11   (with-open-file (stream (asdf:system-relative-pathname :lw2-viewer "data/webcolors.json") :direction :input)
  12     (map 'list
  13          (lambda (color-data)
  14            (cons (cdr (assoc :name color-data))
  15                  (map 'list (lambda (x) (/ (the (integer 0 255) (cdr x)) 255.0d0)) (cdr (assoc :rgb color-data)))))
  16          (json:decode-json stream))))
  17
  18 (defun parse-multi-hex (string count length &key (start 0) (key #'identity))
  19   (values-list
  20    (iter (for i from start below (+ start (* count length)) by length)
  21          (collect (funcall key (parse-integer string :start i :end (+ i length) :radix 16))))))
  22
  23 (defun parse-css-rgb-value (string)
  24   (let ((number (parse-integer string :junk-allowed t)))
  25     (if (ppcre:scan "%$" string)
  26         (/ number 100.0d0)
  27         (/ number 255.0d0))))
  28
  29 (defun parse-css-hue-value (string)
  30   (let ((number (arnesi:parse-float string :junk-allowed t)))
  31     (regex-case string
  32                 ("grad$" (* number (/ 360.0d0 400.0d0)))
  33                 ("rad$" (* number (/ 360.0d0 (* 2 pi))))
  34                 ("turn$" (* number 360.0d0))
  35                 ("%$" (* number (/ 360.0d0 100.0d0)))
  36                 (t number))))
  37
  38 (defun parse-css-alpha-value (string)
  39   (let ((number (and (not (emptyp string)) (arnesi:parse-float string :junk-allowed t))))
  40     (if number
  41         (regex-case string
  42                     ("%$" (/ number 100d0))
  43                     (t number))
  44         1.0d0)))
  45
  46 (defun decode-css-color (color-string)
  47   (regex-case color-string
  48               ("#[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))
  49               ("#[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))))
  50               ("#[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))
  51               ("#[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))))
  52               ("rgba?\\((.*?)\\)"
  53                (multiple-value-bind (rgb-list a-list) (firstn (ppcre:split "[ ,]+" (reg 0)) 3)
  54                  (values* (values-list (map 'list #'parse-css-rgb-value rgb-list))
  55                           (parse-css-alpha-value (first a-list)))))
  56               ("hsla?\\((.*?)\\)"
  57                (destructuring-bind (h s l &optional a) (ppcre:split "[ ,/]+" (reg 0))
  58                  (values* (dufy/core:hsl-to-rgb (parse-css-hue-value h)
  59                                                 (parse-css-rgb-value s)
  60                                                 (parse-css-rgb-value l))
  61                           (parse-css-alpha-value a))))
  62               (t
  63                (when-let ((color-list (cdr (assoc color-string *web-colors-list* :test #'string-equal))))
  64                  (values* (values-list color-list) 1.0d0)))))
  65
  66 (defun encode-css-color (r g b a)
  67   (format nil "#~6,'0X~2,'0X" (dufy/core:rgb-to-rgbpack r g b) (round (* a 255))))
  68
  69 (defun safe-color-name (r g b a)
  70   (format nil "~6,'0X~2,'0X" (dufy/core:rgb-to-rgbpack r g b) (round (* a 255))))
  71
  72 (defun gamma-invert-lightness (l)
  73   (if (>= l 100d0)
  74       0d0
  75       (* 100d0 (expt (- 1d0 (/ l 100d0)) (/ 1.25d0)))))
  76
  77 (defun perceptual-invert-rgba (r g b alpha)
  78   (multiple-value-bind (l a b)
  79       (multiple-value-call #'dufy/core:xyz-to-lab (dufy/core:rgb-to-xyz r g b))
  80     (multiple-value-bind (nr ng nb)
  81         (multiple-value-call #'dufy/core:xyz-to-rgb
  82           (dufy/core:lab-to-xyz (gamma-invert-lightness l) a b))
  83       (values nr ng nb alpha))))
  84
  85 (defun perceptual-invert-color-string (color-string)
  86   (multiple-value-call #'encode-css-color (multiple-value-call #'perceptual-invert-rgba (decode-css-color color-string))))