Update utilsHEADmain

1 files changed, 23 insertions, 25 deletions

diff --git a/color.lisp b/color.lisp
index d9ed800..623007c 100644
--- a/color.lisp
+++ b/color.lisp
@@ -1,28 +1,26 @@
 (in-package #:color)
 
 (defun hsl->rgb (h s l)
-  (let* ((c (* (- 1 (abs (- (* 2 l) 1))) s))
-         (x (* c (- 1 (abs (- (mod (/ h 60) 2) 1)))))
-         (m (- l (/ c 2)))
-         (r m)
-         (g m)
-         (b m))
-    (cond ((<= 0 h 59)
-           (incf r c)
-           (incf g x))
-          ((<= 60 h 119)
-           (incf r x)
-           (incf g c))
-          ((<= 120 h 179)
-           (incf g c)
-           (incf b x))
-          ((<= 180 239)
-           (incf g x)
-           (incf b c))
-          ((<= 240 299)
-           (incf r x)
-           (incf b c))
-          ((<= 300 359)
-           (incf r c)
-           (incf b x)))
-    (values r g b)))
+  (declare (optimize (speed 3) (safety 0))
+           ((single-float 0.0 1.0) h s l))
+  (labels ((hue-to-rgb
+             (p q tt)
+             (declare (single-float p q tt))
+             (setf tt (mod tt 1))
+             (cond ((< tt (float (/ 1 6)))
+                    (+ p (* (- q p) 6 tt)))
+                   ((< tt (/ 1 2))
+                    q)
+                   ((< tt (float (/ 2 3)))
+                    (+ p (* (- q p) 6 (- (/ 2 3) tt))))
+                   (t p))))
+    (if (= s 0)
+      (values l l l)
+      (let* ((q (if (< l 0.5)
+                  (* l (1+ s))
+                  (+ l s (- (* l s)))))
+             (p (- (* 2 l) q)))
+        (values
+          (hue-to-rgb p q (+ h (/ 1 3)))
+          (hue-to-rgb p q h)
+          (hue-to-rgb p q (- h (/ 1 3))))))))