src/colors.lisp

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