From 823b4ff220ba55fbbd95e3442a1fdfe8de5661b1 Mon Sep 17 00:00:00 2001
From: "Kevin M. Rosenberg" <kevin@rosenberg.net>
Date: Sat, 25 Oct 2003 23:02:53 +0000
Subject: [PATCH] r8057: add tests for color conversion, hsv-equal

---
 color.lisp   | 107 ++++++++++++++++++++++++++++++++++++---------------
 package.lisp |   1 +
 tests.lisp   |  21 ++++++++++
 3 files changed, 97 insertions(+), 32 deletions(-)

diff --git a/color.lisp b/color.lisp
index a3033bd..64f0fb2 100644
--- a/color.lisp
+++ b/color.lisp
@@ -33,55 +33,98 @@
 ;; values.
 
 (defun hsv->rgb (h s v) 
+  (declare (optimize (speed 3) (safety 0)))
+  (when (zerop s)
+    (return-from hsv->rgb (values v v v)))
+
   (while (minusp h)
          (incf h 360))
-  (while (> h 360)
+  (while (>= h 360)
          (decf h 360))
 
-  (let (r g b)
-    (cond
-     ((< h 120)
-      (setf r (/ (- 120 h) 60)
-            g (/ h 60)
-            b 0))
-     ((< h 240)
-      (setf r 0
-            g (/ (- 240 h) 60)
-            b (/ (- h 120) 60)))
-     (t
-      (setf r (/ (- h 240) 60)
-            g 0
-            b (/ (- 360 h) 60))))
-    (setf r (min r 1)
-          g (min g 1)
-          b (min b 1))
+  (let ((h-pos (/ h 60))
+        r g b)
+    (multiple-value-bind (h-int h-frac) (truncate h-pos)
+      (declare (fixnum h-int))
+      (let ((p (* v (- 1 s)))
+            (q (* v (- 1 (* s h-frac))))
+            (t_ (* v (- 1 (* s (- 1 h-frac))))))
 
-    (values (* (+ 1 (* s r) (- s)) v)
-            (* (+ 1 (* s g) (- s)) v)
-            (* (+ 1 (* s b) (- s)) v))))
+        (cond
+         ((zerop h-int)
+          (setf r v
+                g t_  
+                b p))
+         ((= 1 h-int)
+          (setf r q
+                g v
+                b p))
+         ((= 2 h-int)
+          (setf r p
+                g v
+                b t_))
+         ((= 3 h-int)
+          (setf r p
+                g q
+                b v))
+         ((= 4 h-int)
+          (setf r t_
+                g p
+                b v))
+         ((= 5 h-int)
+          (setf r v
+                g p
+                b q)))))
+    (values r g b)))
 
 
 (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))
          (v max)
          (s 0)
-         (h 0))
-
+         h)
+    
     (when (plusp max)
       (setq s (/ delta max)))
 
-    (when (plusp delta)
-      (when (and (= max r) (/= max g))
-        (incf h (/ (- g b) delta)))
-      (when (and (= max g) (/= max b))
-        (incf h (+ 2 (/ (- b r) delta))))
-      (when (and (= max b) (/= max r))
-        (incf h (+ 4 (/ (- r g) delta))))
-      (setq h (* 60 h)))
+    (cond
+     ((zerop delta)
+      (setq h nil))
+     (t
+      (setq h (cond
+               ((= max r)
+                (/ (- g b) delta))
+               ((= max g)
+                (+ 2 (/ (- b r) delta)))
+               (t
+                (+ 4 (/ (- r g) delta)))))
+      (setq h (* 60 h))
+      (when (minusp h)
+        (incf h 360))))
 
     (values h s v)))
 
- 
+
+(defun hsv-equal (h1 s1 v1 h2 s2 v2)
+  (flet ((~= (a b)
+           (cond 
+            ((and (null a) (null b))
+             t)
+            ((or (null a) (null b))
+             nil)
+            (t
+             (< (abs (- a b)) 0.000001)))))
+    (cond
+     ((and (~= 0 v1) (~= 0 v2))
+      t)
+     ((or (null h1) (null h2))
+      (when (and (~= 0 s1) (~= 0 s2) (~= v1 v2))
+        t))
+     (t
+      (when (~= h1 h2) (~= s1 s2) (~= v1 v2)
+        t)))))
+
diff --git a/package.lisp b/package.lisp
index 14582b2..d6f17a9 100644
--- a/package.lisp
+++ b/package.lisp
@@ -248,6 +248,7 @@
    ;; color.lisp
    #:rgb->hsv
    #:hsv->rgb
+   #:hsv-equal
    ))
 
 
diff --git a/tests.lisp b/tests.lisp
index fc950e4..bf088b4 100644
--- a/tests.lisp
+++ b/tests.lisp
@@ -186,6 +186,27 @@
 (deftest sse.4 (string-strip-ending "abc" '("ab")) "abc")
 (deftest sse.5 (string-strip-ending "abcd" '("a" "cd")) "ab")
 
+
+(defun test-color-conversion ()
+  (dotimes (ih 11)
+    (dotimes (is 11)
+      (dotimes (iv 11)
+        (let ((h (/ ih 10))
+              (s (/ is 10))
+              (v (/ iv 10)))
+          (multiple-value-bind (r g b) (hsv->rgb h s v)
+            (multiple-value-bind (h2 s2 v2) (rgb->hsv r g b)
+              (unless (hsv-equal h s v h2 s2 v2)
+                (warn "Colors not equal: ~4D ~4D ~4D | ~6D:~6D ~6D:~6D ~6D:~6D~%" 
+                        (float r) (float g) (float b)
+                        (when (typep h 'number) (float h))
+                        (when (typep h2 'number) (float h2))
+                        (float s) (float s2) (float v) (float v2))
+                (return-from test-color-conversion nil))))))))
+  t)
+
+(deftest color (test-color-conversion) t)
+
   
 ;;; MOP Testing
 
-- 
2.34.1