r8057: add tests for color conversion, hsv-equal

[kmrcl.git] / color.lisp

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