/[cl-colors]/colors.lisp
ViewVC logotype

Contents of /colors.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3 - (show annotations)
Sun Jun 29 08:59:58 2008 UTC (5 years, 9 months ago) by tpapp
File size: 5760 byte(s)
Added convex combination for RGBA colors by Johann Korndoerfer.

Cosmetic changes to ASD definition.

1 (in-package :cl-colors)
2
3 ;;;;
4 ;;;; rgb
5 ;;;;
6
7 (defclass rgb ()
8 ((red :initform 0 :type (real 0 1) :initarg :red :accessor red)
9 (green :initform 0 :type (real 0 1) :initarg :green :accessor green)
10 (blue :initform 0 :type (real 0 1) :initarg :blue :accessor blue)))
11
12 (defmethod print-object ((obj rgb) stream)
13 (print-unreadable-object (obj stream :type t)
14 (with-slots (red green blue) obj
15 (format stream "red: ~a green: ~a blue: ~a" red green blue))))
16
17 (defmethod make-load-form ((obj rgb) &optional environment)
18 (make-load-form-saving-slots obj :environment environment))
19
20 ;;;;
21 ;;;; rgba
22 ;;;;
23
24 (defclass rgba (rgb)
25 ((alpha :initform 1 :type (real 0 1) :initarg :alpha :accessor alpha)))
26
27 (defmethod print-object ((obj rgba) stream)
28 (print-unreadable-object (obj stream :type t)
29 (with-slots (red green blue alpha) obj
30 (format stream "red: ~a green: ~a blue: ~a alpha: ~a"
31 red green blue alpha))))
32
33 (defgeneric add-alpha (color alpha)
34 (:documentation "Add an alpha channel to a given color."))
35
36 (defmethod add-alpha ((color rgb) alpha)
37 (make-instance 'rgba
38 :red (red color)
39 :green (green color)
40 :blue (blue color)
41 :alpha alpha))
42
43 ;;;;
44 ;;;; hsv
45 ;;;;
46
47 (defclass hsv ()
48 ((hue :initform 0 :type (real 0 360) :initarg :hue :accessor hue)
49 (saturation :initform 0 :type (real 0 1) :initarg :saturation
50 :accessor saturation)
51 (value :initform 0 :type (real 0 1) :initarg :value :accessor value)))
52
53 (defmethod print-object ((obj hsv) stream)
54 (print-unreadable-object (obj stream :type t)
55 (with-slots (hue saturation value) obj
56 (format stream "hue: ~a saturation: ~a value: ~a"
57 hue saturation value))))
58
59 (defun normalize-hue (hue)
60 "Normalize hue into the interval [0,360)."
61 (mod hue 360))
62
63 ;;;;
64 ;;;; conversions
65 ;;;;
66
67 (defun rgb->hsv (rgb &optional (undefined-hue 0))
68 "Convert RGB to HSV representation. When hue is undefined
69 \(saturation is zero), undefined-hue will be assigned."
70 (with-slots (red green blue) rgb
71 (let* ((value (max red green blue))
72 (delta (- value (min red green blue)))
73 (saturation (if (plusp value)
74 (/ delta value)
75 0)))
76 (flet ((normalize (constant right left)
77 (let ((hue (+ constant (/ (* 60 (- right left)) delta))))
78 (if (minusp hue)
79 (+ hue 360)
80 hue))))
81 (make-instance 'hsv
82 :hue (cond
83 ((zerop saturation) undefined-hue) ; undefined
84 ((= red value) (normalize 0 green blue)) ; dominant red
85 ((= green value) (normalize 120 blue red)) ; dominant green
86 (t (normalize 240 red green)))
87 :saturation saturation
88 :value value)))))
89
90 (defun hsv->rgb (hsv)
91 "Convert HSV to RGB representation. When saturation is zero, hue is
92 ignored."
93 (with-slots (hue saturation value) hsv
94 ;; if saturation=0, color is on the gray line
95 (when (zerop saturation)
96 (return-from hsv->rgb (make-instance 'rgb
97 :red value :green value :blue value)))
98 ;; nonzero saturation: normalize hue to [0,6)
99 (let ((h (/ (normalize-hue hue) 60)))
100 (multiple-value-bind (quotient remainder) (floor h)
101 (let ((p (* value (- 1 saturation)))
102 (q (* value (- 1 (* saturation remainder))))
103 (r (* value (- 1 (* saturation (- 1 remainder))))))
104 (multiple-value-bind (red green blue)
105 (case quotient
106 (0 (values value r p))
107 (1 (values q value p))
108 (2 (values p value r))
109 (3 (values p q value))
110 (4 (values r p value))
111 (t (values value p q)))
112 (make-instance 'rgb
113 :red red
114 :green green
115 :blue blue)))))))
116
117 ;;;;
118 ;;;; conversion with generic functions
119 ;;;;
120
121 (defgeneric ->hsv (color &optional undefined-hue))
122
123 (defmethod ->hsv ((color rgb) &optional (undefined-hue 0))
124 (rgb->hsv color undefined-hue))
125
126 (defmethod ->hsv ((color hsv) &optional undefined-hue)
127 (declare (ignore undefined-hue))
128 color)
129
130 (defgeneric ->rgb (color))
131
132 (defmethod ->rgb ((color rgb))
133 color)
134
135 (defmethod ->rgb ((color hsv))
136 (hsv->rgb color))
137
138 ;;;;
139 ;;;; convex combinations
140 ;;;;
141
142 (defun convex-combination (a b alpha)
143 "Convex combination (1-alpha*a+alpha*b."
144 (declare ((real 0 1) alpha))
145 (+ (* (- 1 alpha) a) (* alpha b)))
146
147 (defun hue-combination (hue1 hue2 alpha &optional (positivep t))
148 "Return a convex combination of hue1 (with weight 1-alpha) and
149 hue2 \(with weight alpha), in the positive or negative direction
150 on the color wheel."
151 (cond
152 ((and positivep (> hue1 hue2))
153 (normalize-hue (convex-combination hue1 (+ hue2 360) alpha)))
154 ((and (not positivep) (< hue1 hue2))
155 (normalize-hue (convex-combination (+ hue1 360) hue2 alpha)))
156 (t (convex-combination hue1 hue2 alpha))))
157
158 (defmacro with-convex-combination ((cc instance1 instance2 alpha)
159 &body body)
160 "Wrap body in a macrolet so that (cc #'accessor) returns the
161 convex combination of the slots of instance1 and instance2
162 accessed by accessor."
163 `(macrolet ((,cc (accessor)
164 (once-only (accessor)
165 `(convex-combination (funcall ,accessor ,',instance1)
166 (funcall ,accessor ,',instance2)
167 ,',alpha))))
168 ,@body))
169
170 (defun rgb-combination (rgb1 rgb2 alpha)
171 "Convex combination in RGB space."
172 (with-convex-combination (cc rgb1 rgb2 alpha)
173 (make-instance 'rgb :red (cc #'red) :green (cc #'green) :blue (cc #'blue))))
174
175 (defun rgba-combination (rgba1 rgba2 alpha)
176 "Convex combination in RGBA space."
177 (with-convex-combination (cc rgba1 rgba2 alpha)
178 (make-instance 'rgba :red (cc #'red)
179 :green (cc #'green) :blue (cc #'blue)
180 :alpha (cc #'alpha))))
181
182 (defun hsv-combination (hsv1 hsv2 alpha &optional (positivep t))
183 (with-convex-combination (cc hsv1 hsv2 alpha)
184 (make-instance 'hsv
185 :hue (hue-combination (hue hsv1) (hue hsv2) alpha positivep)
186 :saturation (cc #'saturation) :value (cc #'value))))

  ViewVC Help
Powered by ViewVC 1.1.5