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

Contents of /colors.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (hide annotations)
Mon Aug 13 11:52:20 2007 UTC (6 years, 8 months ago) by tpapp
File size: 5252 byte(s)
initial import
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     ;;;;
33     ;;;; hsv
34     ;;;;
35    
36     (defclass hsv ()
37     ((hue :initform 0 :type (real 0 360) :initarg :hue :accessor hue)
38     (saturation :initform 0 :type (real 0 1) :initarg :saturation
39     :accessor saturation)
40     (value :initform 0 :type (real 0 1) :initarg :value :accessor value)))
41    
42     (defmethod print-object ((obj hsv) stream)
43     (print-unreadable-object (obj stream :type t)
44     (with-slots (hue saturation value) obj
45     (format stream "hue: ~a saturation: ~a value: ~a"
46     hue saturation value))))
47    
48     (defun normalize-hue (hue)
49     "Normalize hue into the interval [0,360)."
50     (mod hue 360))
51    
52     ;;;;
53     ;;;; conversions
54     ;;;;
55    
56     (defun rgb->hsv (rgb &optional (undefined-hue 0))
57     "Convert RGB to HSV representation. When hue is undefined
58     \(saturation is zero), undefined-hue will be assigned."
59     (with-slots (red green blue) rgb
60     (let* ((value (max red green blue))
61     (delta (- value (min red green blue)))
62     (saturation (if (plusp value)
63     (/ delta value)
64     0)))
65     (flet ((normalize (constant right left)
66     (let ((hue (+ constant (/ (* 60 (- right left)) delta))))
67     (if (minusp hue)
68     (+ hue 360)
69     hue))))
70     (make-instance 'hsv
71     :hue (cond
72     ((zerop saturation) undefined-hue) ; undefined
73     ((= red value) (normalize 0 green blue)) ; dominant red
74     ((= green value) (normalize 120 blue red)) ; dominant green
75     (t (normalize 240 red green)))
76     :saturation saturation
77     :value value)))))
78    
79     (defun hsv->rgb (hsv)
80     "Convert HSV to RGB representation. When saturation is zero, hue is
81     ignored."
82     (with-slots (hue saturation value) hsv
83     ;; if saturation=0, color is on the gray line
84     (when (zerop saturation)
85     (return-from hsv->rgb (make-instance 'rgb
86     :red value :green value :blue value)))
87     ;; nonzero saturation: normalize hue to [0,6)
88     (let ((h (/ (normalize-hue hue) 60)))
89     (multiple-value-bind (quotient remainder) (floor h)
90     (let ((p (* value (- 1 saturation)))
91     (q (* value (- 1 (* saturation remainder))))
92     (r (* value (- 1 (* saturation (- 1 remainder))))))
93     (multiple-value-bind (red green blue)
94     (case quotient
95     (0 (values value r p))
96     (1 (values q value p))
97     (2 (values p value r))
98     (3 (values p q value))
99     (4 (values r p value))
100     (t (values value p q)))
101     (make-instance 'rgb
102     :red red
103     :green green
104     :blue blue)))))))
105    
106     ;;;;
107     ;;;; conversion with generic functions
108     ;;;;
109    
110     (defgeneric ->hsv (color &optional undefined-hue))
111    
112     (defmethod ->hsv ((color rgb) &optional (undefined-hue 0))
113     (rgb->hsv color undefined-hue))
114    
115     (defmethod ->hsv ((color hsv) &optional undefined-hue)
116     (declare (ignore undefined-hue))
117     color)
118    
119     (defgeneric ->rgb (color))
120    
121     (defmethod ->rgb ((color rgb))
122     color)
123    
124     (defmethod ->rgb ((color hsv))
125     (hsv->rgb color))
126    
127     ;;;;
128     ;;;; convex combinations
129     ;;;;
130    
131     (defun convex-combination (a b alpha)
132     "Convex combination (1-alpha*a+alpha*b."
133     (declare ((real 0 1) alpha))
134     (+ (* (- 1 alpha) a) (* alpha b)))
135    
136     (defun hue-combination (hue1 hue2 alpha &optional (positivep t))
137     "Return a convex combination of hue1 (with weight 1-alpha) and
138     hue2 \(with weight alpha), in the positive or negative direction
139     on the color wheel."
140     (cond
141     ((and positivep (> hue1 hue2))
142     (normalize-hue (convex-combination hue1 (+ hue2 360) alpha)))
143     ((and (not positivep) (< hue1 hue2))
144     (normalize-hue (convex-combination (+ hue1 360) hue2 alpha)))
145     (t (convex-combination hue1 hue2 alpha))))
146    
147     (defmacro with-convex-combination ((cc instance1 instance2 alpha)
148     &body body)
149     "Wrap body in a macrolet so that (cc #'accessor) returns the
150     convex combination of the slots of instance1 and instance2
151     accessed by accessor."
152     `(macrolet ((,cc (accessor)
153     (once-only (accessor)
154     `(convex-combination (funcall ,accessor ,',instance1)
155     (funcall ,accessor ,',instance2)
156     ,',alpha))))
157     ,@body))
158    
159     (defun rgb-combination (rgb1 rgb2 alpha)
160     "Convex combination in RGB space."
161     (with-convex-combination (cc rgb1 rgb2 alpha)
162     (make-instance 'rgb :red (cc #'red) :green (cc #'green) :blue (cc #'blue))))
163    
164     (defun hsv-combination (hsv1 hsv2 alpha positivep)
165     (with-convex-combination (cc hsv1 hsv2 alpha)
166     (make-instance 'hsv
167     :hue (hue-combination (hue hsv1) (hue hsv2) alpha positivep)
168     :saturation (cc #'saturation) :value (cc #'value))))

  ViewVC Help
Powered by ViewVC 1.1.5