cl-colors2/colors.lisp

(in-package :cl-colors2)

(defparameter *x11-colors-list* '())
(defparameter *svg-colors-list* '())
(defparameter *svg-extended-colors-list* '())

;;; color representations

(deftype unit-real ()
  "Real number in [0,1]."
  '(real 0 1))

(defstruct (rgb (:constructor rgb (red green blue)))
  "RGB color."
  (red   nil :type unit-real :read-only t)
  (green nil :type unit-real :read-only t)
  (blue  nil :type unit-real :read-only t))

(defmethod make-load-form ((p rgb) &optional env)
  (declare (ignore env))
  (make-load-form-saving-slots p))

(defun gray (value)
  "Create an RGB representation of a gray color (value in [0,1)."
  (rgb value value value))

(defstruct (hsv (:constructor hsv (hue saturation value)))
  "HSV color."
  (hue        nil :type (real 0 360) :read-only t)
  (saturation nil :type unit-real    :read-only t)
  (value      nil :type unit-real    :read-only t))

(defmethod make-load-form ((p hsv) &optional env)
  (declare (ignore env))
  (make-load-form-saving-slots p))

(defun normalize-hue (hue)
  "Normalize hue to the interval [0,360)."
  (mod hue 360))

;;; conversions

(defun rgb-to-hsv (rgb &optional (undefined-hue 0))
  "Convert RGB to HSV representation.  When hue is undefined (saturation is
zero), UNDEFINED-HUE will be assigned."
  (flet ((normalize (constant right left delta)
           (let ((hue (+ constant (/ (* 60 (- right left)) delta))))
             (if (minusp hue)
                 (+ hue 360)
                 hue))))
  (let* ((red   (rgb-red   rgb))
         (green (rgb-green rgb))
         (blue  (rgb-blue  rgb))
         (value (max red green blue))
         (delta (- value (min red green blue)))
         (saturation (if (plusp value)
                         (/ delta value)
                         0))
         (hue (cond
                ((zerop saturation) undefined-hue) ; undefined
                ((= red value) (normalize 0 green blue delta)) ; dominant red
                ((= green value) (normalize 120 blue red delta)) ; dominant green
                (t (normalize 240 red green delta)))))
    (hsv hue saturation value))))

(defun hsv-to-rgb (hsv)
  "Convert HSV to RGB representation.  When SATURATION is zero, HUE is
ignored."
  (let* ((hue        (hsv-hue        hsv))
         (saturation (hsv-saturation hsv))
         (value      (hsv-value      hsv)))
    ;; if saturation=0, color is on the gray line
    (when (zerop saturation)
      (return-from hsv-to-rgb (gray value)))
    ;; nonzero saturation: normalize hue to [0,6)
    (let* ((h (/ (normalize-hue hue) 60)))
      (multiple-value-bind (quotient remainder)
          (floor h)
        (let* ((p (* value (- 1 saturation)))
               (q (* value (- 1 (* saturation remainder))))
               (r (* value (- 1 (* saturation (- 1 remainder))))))
          (multiple-value-bind (red green blue)
              (case quotient
                (0 (values value r p))
                (1 (values q value p))
                (2 (values p value r))
                (3 (values p q value))
                (4 (values r p value))
                (t (values value p q)))
            (rgb red green blue)))))))

(defun hex-to-rgb (string)
  "Parse hexadecimal notation (eg ff0000 or f00 for red) into an RGB color."
  (multiple-value-bind (width max)
      (case (length string)
        (3 (values 1 15))
        (6 (values 2 255))
        (t (error "string ~A doesn't have length 3 or 6, can't parse as ~
                       RGB specification" string)))
    (flet ((parse (index)
             (/ (parse-integer string
                               :start (* index width)
                               :end   (* (1+ index) width)
                               :radix 16)
               max)))
      (rgb (parse 0) (parse 1) (parse 2)))))

;;; conversion with generic functions

(define-compiler-macro as-hsv (&whole form color)
  (if (constantp color)
      (funcall #'as-hsv color)
      (progn form)))

(defgeneric as-hsv (color &optional undefined-hue)
  (:documentation "Coerce an RGB, an HSV, or a HEX string into a HSV structure. HEX string is parsed as an RGB specification.")
  (:method ((color rgb) &optional (undefined-hue 0))
    (rgb-to-hsv color undefined-hue))
  (:method ((color hsv) &optional undefined-hue)
    (declare (ignore undefined-hue))
    color)
  (:method ((string string) &optional (undefined-hue 0))
    (rgb-to-hsv
     (handler-case
         (hex-to-rgb string)
       (error ()
         (or (cdr (assoc string *x11-colors-list* :test #'equalp))
             (error "Color can not be parsed"))))
     undefined-hue)))

(define-compiler-macro as-rgb (&whole form color)
  (if (constantp color)
      (funcall #'as-rgb color)
      (progn form)))

(defgeneric as-rgb (color)
  (:documentation "Coerce an RGB, an HSV, or a HEX string into a RGB structure")
  (:method ((rgb rgb))
    rgb)
  (:method ((hsv hsv))
    (hsv-to-rgb hsv))
  (:method ((string string))
    (handler-case
        (hex-to-rgb string)
      (error ()
        (or (cdr (assoc string *x11-colors-list* :test #'equalp))
            (error "Color can not be parsed"))))))

;;; combinations

(declaim (inline cc))
(defun cc (a b alpha)
  "Convex combination (1-ALPHA)*A+ALPHA*B, ie  ALPHA is the weight of A."
  (declare (type (real 0 1) alpha))
  (+ (* (- 1 alpha) a) (* alpha b)))

(defun rgb-combination (color1 color2 alpha)
  "Color combination in RGB space."
  (flet ((c (c1 c2) (cc c1 c2 alpha)))
    (let ((rgb-1 (as-rgb color1))
          (rgb-2 (as-rgb color2)))
      (rgb (c (rgb-red   rgb-1) (rgb-red   rgb-2))
           (c (rgb-green rgb-1) (rgb-green rgb-2))
           (c (rgb-blue  rgb-1) (rgb-blue  rgb-2))))))

(defun hsv-combination (hsv1 hsv2 alpha &optional (positive? t))
  "Color combination in HSV space.  POSITIVE? determines whether the hue
combination is in the positive or negative direction on the color wheel."
  (flet ((c (c1 c2) (cc c1 c2 alpha)))
    (let* ((hsv-1        (as-hsv hsv1))
           (hsv-2        (as-hsv hsv2))
           (hue-1        (hsv-hue hsv-1))
           (saturation-1 (hsv-saturation hsv-1))
           (value-1      (hsv-value      hsv-1))
           (hue-2        (hsv-hue hsv-2))
           (saturation-2 (hsv-saturation hsv-2))
           (value-2      (hsv-value      hsv-2)))
      (hsv (cond
             ((and positive? (> hue-1 hue-2))
              (normalize-hue (c hue-1 (+ hue-2 360))))
             ((and (not positive?) (< hue-1 hue-2))
              (normalize-hue (c (+ hue-1 360) hue-2)))
             (t (c hue-1 hue-2)))
           (c saturation-1 saturation-2)
           (c value-1 value-2)))))

;; equality

(defun eps= (a b &optional (epsilon 1e-10))
  (<= (abs (- a b)) epsilon))

(defgeneric color-equals  (a b &key tolerance)
  (:documentation "Compare two colors under a given floating point tolerance."))

(defmethod color-equals ((a rgb) (b rgb) &key (tolerance 1e-10))
  (and (eps= (rgb-red a)
             (rgb-red b)
             tolerance)
       (eps= (rgb-green a)
             (rgb-green b)
             tolerance)
       (eps= (rgb-blue a)
             (rgb-blue b)
             tolerance)))

(defmethod color-equals ((a hsv) (b hsv) &key (tolerance 1e-10))
  (and (eps= (hsv-hue        a)
             (hsv-hue        b)
             tolerance)
       (eps= (hsv-saturation a)
             (hsv-saturation b)
             tolerance)
       (eps= (hsv-value      a)
             (hsv-value      b)
             tolerance)))

(defmethod color-equals ((a hsv) (b rgb) &key (tolerance 1e-10))
  (color-equals a (as-hsv b) :tolerance tolerance))

(defmethod color-equals ((a rgb) (b hsv) &key (tolerance 1e-10))
  (color-equals (as-hsv a) b :tolerance tolerance))

;;; macros used by the autogenerated files

(defun colorname->constant-name (name)
  (symbolicate #\+
               (cl-ppcre:regex-replace-all "\\s+" (string-upcase name) "-")
               #\+))

(defmacro define-rgb-color (name red green blue)
  "Macro for defining color constants.  Used by the automatically generated color file."
  (let ((constant-name (colorname->constant-name name)))
    `(progn
       (define-constant ,constant-name (rgb ,red ,green ,blue)
         :test #'equalp :documentation ,(format nil "X11 color ~A." name)))))