+\r
+(defun hsv-equal (h1 s1 v1 h2 s2 v2 &key (limit .001))\r
+ (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))\r
+ (flet ((~= (a b)\r
+ (cond \r
+ ((and (null a) (null b))\r
+ t)\r
+ ((or (null a) (null b))\r
+ nil)\r
+ (t\r
+ (< (abs (- a b)) limit)))))\r
+ (cond\r
+ ((and (~= 0 v1) (~= 0 v2))\r
+ t)\r
+ ((or (null h1) (null h2))\r
+ (when (and (~= 0 s1) (~= 0 s2) (~= v1 v2))\r
+ t))\r
+ (t\r
+ (when (~= h1 h2) (~= s1 s2) (~= v1 v2)\r
+ t)))))\r
+\r
+(defun hsv255-equal (h1 s1 v1 h2 s2 v2 &key (limit 1))\r
+ (declare (type fixnum s1 v1 s2 v2 limit)\r
+ (type (or null fixnum) h1 h2)\r
+ (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))\r
+ (flet ((~= (a b)\r
+ (declare (type (or null fixnum) a b))\r
+ (cond \r
+ ((and (null a) (null b))\r
+ t)\r
+ ((or (null a) (null b))\r
+ nil)\r
+ (t\r
+ (<= (abs (the fixnum (- a b))) limit)))))\r
+ (cond\r
+ ((and (~= 0 v1) (~= 0 v2))\r
+ t)\r
+ ((or (null h1) (null h2))\r
+ (when (and (~= 0 s1) (~= 0 s2) (~= v1 v2))\r
+ t))\r
+ (t\r
+ (when (~= h1 h2) (~= s1 s2) (~= v1 v2)\r
+ t)))))\r
+\r
+(defun hsv-similar (h1 s1 v1 h2 s2 v2 &key \r
+ (hue-range 15) (value-range .2) (saturation-range 0.2)\r
+ (gray-limit 0.3) (black-limit 0.3))\r
+ "Returns T if two HSV values are similar."\r
+ (cond\r
+ ;; all black colors are similar\r
+ ((and (<= v1 black-limit) (<= v2 black-limit))\r
+ t)\r
+ ;; all desaturated (gray) colors are similar for a value, despite hue\r
+ ((and (<= s1 gray-limit) (<= s2 gray-limit))\r
+ (when (<= (abs (- v1 v2)) value-range)\r
+ t))\r
+ (t\r
+ (when (and (<= (abs (hue-difference h1 h2)) hue-range)\r
+ (<= (abs (- v1 v2)) value-range)\r
+ (<= (abs (- s1 s2)) saturation-range))\r
+ t))))\r
+\r
+\r
+(defun hsv255-similar (h1 s1 v1 h2 s2 v2 \r
+ &key (hue-range 15) (value-range 50) (saturation-range 50)\r
+ (gray-limit 75) (black-limit 75))\r
+ "Returns T if two HSV values are similar."\r
+ (declare (fixnum s1 v1 s2 v2 hue-range value-range saturation-range\r
+ gray-limit black-limit)\r
+ (type (or null fixnum) h1 h2)\r
+ (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))\r
+ (cond\r
+ ;; all black colors are similar\r
+ ((and (<= v1 black-limit) (<= v2 black-limit))\r
+ t)\r
+ ;; all desaturated (gray) colors are similar for a value, despite hue\r
+ ((and (<= s1 gray-limit) (<= s2 gray-limit))\r
+ (when (<= (abs (- v1 v2)) value-range)\r
+ t))\r
+ (t\r
+ (when (and (<= (abs (hue-difference-fixnum h1 h2)) hue-range)\r
+ (<= (abs (- v1 v2)) value-range)\r
+ (<= (abs (- s1 s2)) saturation-range))\r
+ t))))\r
+\r
+\r
+ \r
+(defun hue-difference (h1 h2)\r
+ "Return difference between two hues around 360 degree circle"\r
+ (cond\r
+ ((and (null h1) (null h2))\r
+ t)\r
+ ((or (null h1) (null h2))\r
+ 360)\r
+ (t\r
+ (let ((diff (- h2 h1)))\r
+ (cond\r
+ ((< diff -180)\r
+ (+ 360 diff)\r
+ )\r
+ ((> diff 180)\r
+ (- (- 360 diff)))\r
+ (t\r
+ diff))))))\r
+ \r
+ \r
+(defun hue-difference-fixnum (h1 h2)\r
+ "Return difference between two hues around 360 degree circle"\r
+ (cond\r
+ ((and (null h1) (null h2))\r
+ t)\r
+ ((or (null h1) (null h2))\r
+ 360)\r
+ (t\r
+ (locally (declare (type fixnum h1 h2))\r
+ (let ((diff (- h2 h1)))\r
+ (cond\r
+ ((< diff -180)\r
+ (+ 360 diff)\r
+ )\r
+ ((> diff 180)\r
+ (- (- 360 diff)))\r
+ (t\r
+ diff)))))))\r