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

Contents of /colors.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3 - (hide 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 tpapp 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 tpapp 3
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 tpapp 1 ;;;;
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 tpapp 3 (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 tpapp 1 (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