r8057: add tests for color conversion, hsv-equal

diff --git a/color.lisp b/color.lisp
index a3033bd864d1991492dc722f2af495330229e8d8..64f0fb26fd2e31815f5b2dfbea3b68e5c55538be 100644 (file)
--- a/color.lisp
+++ b/color.lisp
@@ -33,55 +33,98 @@
 ;; values.\r
 \r
 (defun hsv->rgb (h s v) \r
+  (declare (optimize (speed 3) (safety 0)))\r
+  (when (zerop s)\r
+    (return-from hsv->rgb (values v v v)))\r
+\r
   (while (minusp h)\r
          (incf h 360))\r
-  (while (> h 360)\r
+  (while (>= h 360)\r
          (decf h 360))\r
 \r
-  (let (r g b)\r
-    (cond\r
-     ((< h 120)\r
-      (setf r (/ (- 120 h) 60)\r
-            g (/ h 60)\r
-            b 0))\r
-     ((< h 240)\r
-      (setf r 0\r
-            g (/ (- 240 h) 60)\r
-            b (/ (- h 120) 60)))\r
-     (t\r
-      (setf r (/ (- h 240) 60)\r
-            g 0\r
-            b (/ (- 360 h) 60))))\r
-    (setf r (min r 1)\r
-          g (min g 1)\r
-          b (min b 1))\r
+  (let ((h-pos (/ h 60))\r
+        r g b)\r
+    (multiple-value-bind (h-int h-frac) (truncate h-pos)\r
+      (declare (fixnum h-int))\r
+      (let ((p (* v (- 1 s)))\r
+            (q (* v (- 1 (* s h-frac))))\r
+            (t_ (* v (- 1 (* s (- 1 h-frac))))))\r
 \r
-    (values (* (+ 1 (* s r) (- s)) v)\r
-            (* (+ 1 (* s g) (- s)) v)\r
-            (* (+ 1 (* s b) (- s)) v))))\r
+        (cond\r
+         ((zerop h-int)\r
+          (setf r v\r
+                g t_  \r
+                b p))\r
+         ((= 1 h-int)\r
+          (setf r q\r
+                g v\r
+                b p))\r
+         ((= 2 h-int)\r
+          (setf r p\r
+                g v\r
+                b t_))\r
+         ((= 3 h-int)\r
+          (setf r p\r
+                g q\r
+                b v))\r
+         ((= 4 h-int)\r
+          (setf r t_\r
+                g p\r
+                b v))\r
+         ((= 5 h-int)\r
+          (setf r v\r
+                g p\r
+                b q)))))\r
+    (values r g b)))\r
 \r
 \r
 (defun rgb->hsv (r g b)\r
+  (declare (optimize (speed 3) (safety 0)))\r
 \r
   (let* ((min (min r g b))\r
          (max (max r g b))\r
          (delta (- max min))\r
          (v max)\r
          (s 0)\r
-         (h 0))\r
-\r
+         h)\r
+    \r
     (when (plusp max)\r
       (setq s (/ delta max)))\r
 \r
-    (when (plusp delta)\r
-      (when (and (= max r) (/= max g))\r
-        (incf h (/ (- g b) delta)))\r
-      (when (and (= max g) (/= max b))\r
-        (incf h (+ 2 (/ (- b r) delta))))\r
-      (when (and (= max b) (/= max r))\r
-        (incf h (+ 4 (/ (- r g) delta))))\r
-      (setq h (* 60 h)))\r
+    (cond\r
+     ((zerop delta)\r
+      (setq h nil))\r
+     (t\r
+      (setq h (cond\r
+               ((= max r)\r
+                (/ (- g b) delta))\r
+               ((= max g)\r
+                (+ 2 (/ (- b r) delta)))\r
+               (t\r
+                (+ 4 (/ (- r g) delta)))))\r
+      (setq h (* 60 h))\r
+      (when (minusp h)\r
+        (incf h 360))))\r
 \r
     (values h s v)))\r
 \r
- \r
+\r
+(defun hsv-equal (h1 s1 v1 h2 s2 v2)\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)) 0.000001)))))\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

diff --git a/package.lisp b/package.lisp
index 14582b25f4bbfaafebb65064933cb41901b6cb26..d6f17a9ddc2df5955a3de28e5158b33bfa39a6a8 100644 (file)
--- 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 fc950e47ddf2a17d3b1ef979d29061332de9ad8f..bf088b44a2115b29114d57d726c590574918e389 100644 (file)
--- 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