;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(in-package kmrcl)
+(in-package #:kmrcl)
;; The HSV colour space has three coordinates: hue, saturation, and
;; value (sometimes called brighness) respectively. This colour system is
;; point in the plane. The disks on the right show this for various
;; values.
-(defun hsv->rgb (h s v)
+(defun hsv->rgb (h s v)
(declare (optimize (speed 3) (safety 0)))
(when (zerop s)
(return-from hsv->rgb (values v v v)))
(incf h 360))
(while (>= h 360)
(decf h 360))
-
+
(let ((h-pos (/ h 60)))
(multiple-value-bind (h-int h-frac) (truncate h-pos)
(declare (fixnum h-int))
(q (* v (- 1 (* s h-frac))))
(t_ (* v (- 1 (* s (- 1 h-frac)))))
r g b)
-
+
(cond
((zerop h-int)
(setf r v
- g t_
+ g t_
b p))
((= 1 h-int)
(setf r q
(values r g b)))))
-(defun hsv255->rgb255 (h s v)
+(defun hsv255->rgb255 (h s v)
(declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
(when (zerop s)
(incf h 360))
(while (>= h 360)
(decf h 360))
-
+
(let ((h-pos (/ h 60)))
(multiple-value-bind (h-int h-frac) (truncate h-pos)
(declare (fixnum h-int))
(q (round (* 255 fv (- 1 (* fs h-frac)))))
(t_ (round (* 255 fv (- 1 (* fs (- 1 h-frac))))))
r g b)
-
+
(cond
((zerop h-int)
(setf r v
- g t_
+ g t_
b p))
((= 1 h-int)
(setf r q
(defun rgb->hsv (r g b)
(declare (optimize (speed 3) (safety 0)))
-
+
(let* ((min (min r g b))
(max (max r g b))
(delta (- max min))
(setq h (the fixnum (* 60 h)))
(when (minusp h)
(incf h 360)))
-
+
(values h s v)))
(defun rgb255->hsv255 (r g b)
(h nil))
(declare (fixnum min max delta v s)
(type (or null fixnum) h))
-
+
(when (plusp max)
(setq s (truncate (the fixnum (* 255 delta)) max)))
(+ 240 (truncate (the fixnum (* 60 (the fixnum (- r g)))) delta))))))
(when (minusp h)
(incf h 360)))
-
+
(values h s v)))
(defun hsv-equal (h1 s1 v1 h2 s2 v2 &key (limit .001))
(declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
(flet ((~= (a b)
- (cond
+ (cond
((and (null a) (null b))
t)
((or (null a) (null b))
(optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
(flet ((~= (a b)
(declare (type (or null fixnum) a b))
- (cond
+ (cond
((and (null a) (null b))
t)
((or (null a) (null b))
(when (~= h1 h2) (~= s1 s2) (~= v1 v2)
t)))))
-(defun hsv-similar (h1 s1 v1 h2 s2 v2 &key
+(defun hsv-similar (h1 s1 v1 h2 s2 v2 &key
(hue-range 15) (value-range .2) (saturation-range 0.2)
(gray-limit 0.3) (black-limit 0.3))
"Returns T if two HSV values are similar."
t))))
-(defun hsv255-similar (h1 s1 v1 h2 s2 v2
+(defun hsv255-similar (h1 s1 v1 h2 s2 v2
&key (hue-range 15) (value-range 50) (saturation-range 50)
(gray-limit 75) (black-limit 75))
"Returns T if two HSV values are similar."
t))))
-
+
(defun hue-difference (h1 h2)
"Return difference between two hues around 360 degree circle"
(cond
(- (- 360 diff)))
(t
diff))))))
-
-
+
+
(defun hue-difference-fixnum (h1 h2)
"Return difference between two hues around 360 degree circle"
(cond
(- (- 360 diff)))
(t
diff)))))))
-
+