colors.lisp 7.4 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220
  1. (in-package :cl-colors2)
  2. (defparameter *x11-colors-list* '())
  3. ;;; color representations
  4. (deftype unit-real ()
  5. "Real number in [0,1]."
  6. '(real 0 1))
  7. (defstruct (rgb (:constructor rgb (red green blue)))
  8. "RGB color."
  9. (red nil :type unit-real :read-only t)
  10. (green nil :type unit-real :read-only t)
  11. (blue nil :type unit-real :read-only t))
  12. (defmethod make-load-form ((p rgb) &optional env)
  13. (declare (ignore env))
  14. (make-load-form-saving-slots p))
  15. (defun gray (value)
  16. "Create an RGB representation of a gray color (value in [0,1)."
  17. (rgb value value value))
  18. (defstruct (hsv (:constructor hsv (hue saturation value)))
  19. "HSV color."
  20. (hue nil :type (real 0 360) :read-only t)
  21. (saturation nil :type unit-real :read-only t)
  22. (value nil :type unit-real :read-only t))
  23. (defmethod make-load-form ((p hsv) &optional env)
  24. (declare (ignore env))
  25. (make-load-form-saving-slots p))
  26. (defun normalize-hue (hue)
  27. "Normalize hue to the interval [0,360)."
  28. (mod hue 360))
  29. ;;; conversions
  30. (defun rgb-to-hsv (rgb &optional (undefined-hue 0))
  31. "Convert RGB to HSV representation. When hue is undefined (saturation is
  32. zero), UNDEFINED-HUE will be assigned."
  33. (flet ((normalize (constant right left delta)
  34. (let ((hue (+ constant (/ (* 60 (- right left)) delta))))
  35. (if (minusp hue)
  36. (+ hue 360)
  37. hue))))
  38. (let* ((red (rgb-red rgb))
  39. (green (rgb-green rgb))
  40. (blue (rgb-blue rgb))
  41. (value (max red green blue))
  42. (delta (- value (min red green blue)))
  43. (saturation (if (plusp value)
  44. (/ delta value)
  45. 0))
  46. (hue (cond
  47. ((zerop saturation) undefined-hue) ; undefined
  48. ((= red value) (normalize 0 green blue delta)) ; dominant red
  49. ((= green value) (normalize 120 blue red delta)) ; dominant green
  50. (t (normalize 240 red green delta)))))
  51. (hsv hue saturation value))))
  52. (defun hsv-to-rgb (hsv)
  53. "Convert HSV to RGB representation. When SATURATION is zero, HUE is
  54. ignored."
  55. (let* ((hue (hsv-hue hsv))
  56. (saturation (hsv-saturation hsv))
  57. (value (hsv-value hsv)))
  58. ;; if saturation=0, color is on the gray line
  59. (when (zerop saturation)
  60. (return-from hsv-to-rgb (gray value)))
  61. ;; nonzero saturation: normalize hue to [0,6)
  62. (let* ((h (/ (normalize-hue hue) 60)))
  63. (multiple-value-bind (quotient remainder)
  64. (floor h)
  65. (let* ((p (* value (- 1 saturation)))
  66. (q (* value (- 1 (* saturation remainder))))
  67. (r (* value (- 1 (* saturation (- 1 remainder))))))
  68. (multiple-value-bind (red green blue)
  69. (case quotient
  70. (0 (values value r p))
  71. (1 (values q value p))
  72. (2 (values p value r))
  73. (3 (values p q value))
  74. (4 (values r p value))
  75. (t (values value p q)))
  76. (rgb red green blue)))))))
  77. (defun hex-to-rgb (string)
  78. "Parse hexadecimal notation (eg ff0000 or f00 for red) into an RGB color."
  79. (multiple-value-bind (width max)
  80. (case (length string)
  81. (3 (values 1 15))
  82. (6 (values 2 255))
  83. (t (error "string ~A doesn't have length 3 or 6, can't parse as ~
  84. RGB specification" string)))
  85. (flet ((parse (index)
  86. (/ (parse-integer string
  87. :start (* index width)
  88. :end (* (1+ index) width)
  89. :radix 16)
  90. max)))
  91. (rgb (parse 0) (parse 1) (parse 2)))))
  92. ;;; conversion with generic functions
  93. (defgeneric as-hsv (color &optional undefined-hue)
  94. (:method ((color rgb) &optional (undefined-hue 0))
  95. (rgb-to-hsv color undefined-hue))
  96. (:method ((color hsv) &optional undefined-hue)
  97. (declare (ignore undefined-hue))
  98. color))
  99. (define-compiler-macro as-rgb (&whole form color)
  100. (let ((low-funname #'as-rgb))
  101. (if (constantp color)
  102. (funcall low-funname color)
  103. (progn form))))
  104. (declaim (notinline as-rgb))
  105. (defgeneric as-rgb (color)
  106. (:method ((rgb rgb))
  107. rgb)
  108. (:method ((hsv hsv))
  109. (hsv-to-rgb hsv))
  110. (:method ((string string))
  111. (handler-case
  112. (hex-to-rgb string)
  113. (error ()
  114. (or (cdr (assoc string *x11-colors-list* :test #'equalp))
  115. (error "Color can not be parsed"))))))
  116. ;;; combinations
  117. (declaim (inline cc))
  118. (defun cc (a b alpha)
  119. "Convex combination (1-ALPHA)*A+ALPHA*B, ie ALPHA is the weight of A."
  120. (declare (type (real 0 1) alpha))
  121. (+ (* (- 1 alpha) a) (* alpha b)))
  122. (defun rgb-combination (color1 color2 alpha)
  123. "Color combination in RGB space."
  124. (flet ((c (c1 c2) (cc c1 c2 alpha)))
  125. (let ((rgb-1 (as-rgb color1))
  126. (rgb-2 (as-rgb color2)))
  127. (rgb (c (rgb-red rgb-1) (rgb-red rgb-2))
  128. (c (rgb-green rgb-1) (rgb-green rgb-2))
  129. (c (rgb-blue rgb-1) (rgb-blue rgb-2))))))
  130. (defun hsv-combination (hsv1 hsv2 alpha &optional (positive? t))
  131. "Color combination in HSV space. POSITIVE? determines whether the hue
  132. combination is in the positive or negative direction on the color wheel."
  133. (flet ((c (c1 c2) (cc c1 c2 alpha)))
  134. (let* ((hsv-1 (as-hsv hsv1))
  135. (hsv-2 (as-hsv hsv2))
  136. (hue-1 (hsv-hue hsv-1))
  137. (saturation-1 (hsv-saturation hsv-1))
  138. (value-1 (hsv-value hsv-1))
  139. (hue-2 (hsv-hue hsv-2))
  140. (saturation-2 (hsv-saturation hsv-2))
  141. (value-2 (hsv-value hsv-2)))
  142. (hsv (cond
  143. ((and positive? (> hue-1 hue-2))
  144. (normalize-hue (c hue-1 (+ hue-2 360))))
  145. ((and (not positive?) (< hue-1 hue-2))
  146. (normalize-hue (c (+ hue-1 360) hue-2)))
  147. (t (c hue-1 hue-2)))
  148. (c saturation-1 saturation-2)
  149. (c value-1 value-2)))))
  150. ;; equality
  151. (defun eps= (a b &optional (epsilon 1e-10))
  152. (<= (abs (- a b)) epsilon))
  153. (defgeneric color-equals (a b &key tolerance))
  154. (defmethod color-equals ((a rgb) (b rgb) &key (tolerance 1e-10))
  155. (and (eps= (rgb-red a)
  156. (rgb-red b)
  157. tolerance)
  158. (eps= (rgb-green a)
  159. (rgb-green b)
  160. tolerance)
  161. (eps= (rgb-blue a)
  162. (rgb-blue b)
  163. tolerance)))
  164. (defmethod color-equals ((a hsv) (b hsv) &key (tolerance 1e-10))
  165. (and (eps= (hsv-hue a)
  166. (hsv-hue b)
  167. tolerance)
  168. (eps= (hsv-saturation a)
  169. (hsv-saturation b)
  170. tolerance)
  171. (eps= (hsv-value a)
  172. (hsv-value b)
  173. tolerance)))
  174. (defmethod color-equals ((a hsv) (b rgb) &key (tolerance 1e-10))
  175. (color-equals a (as-hsv b) :tolerance tolerance))
  176. (defmethod color-equals ((a rgb) (b hsv) &key (tolerance 1e-10))
  177. (color-equals (as-hsv a) b :tolerance tolerance))
  178. ;;; macros used by the autogenerated files
  179. (defun colorname->constant-name (name)
  180. (symbolicate #\+
  181. (cl-ppcre:regex-replace-all "\\s+" (string-upcase name) "-")
  182. #\+))
  183. (defmacro define-rgb-color (name red green blue)
  184. "Macro for defining color constants. Used by the automatically generated color file."
  185. (let ((constant-name (colorname->constant-name name)))
  186. `(progn
  187. (define-constant ,constant-name (rgb ,red ,green ,blue)
  188. :test #'equalp :documentation ,(format nil "X11 color ~A." name)))))