render: color: Add string->color procedure.

1 files changed, 38 insertions, 1 deletions

diff --git a/chickadee/render/color.scm b/chickadee/render/color.scm
index 387e6d2..0536848 100644
--- a/chickadee/render/color.scm
+++ b/chickadee/render/color.scm
@@ -29,7 +29,7 @@
   #:export (color make-color
             color?
             color-r color-g color-b color-a
-            rgba rgb transparency
+            rgba rgb transparency string->color
             color* color+ color- color-inverse color-lerp
 
             white black red green blue yellow magenta cyan transparent
@@ -102,6 +102,43 @@ For example: #xffffff will return a color with RGBA values 1, 1, 1,
 ALPHA.  ALPHA is clamped to the range [0, 1]."
   (make-color 1 1 1 alpha))
 
+(define (string->color s)
+  "Convert the color code string S, in a format like \"#RRGGBBAA\", to
+a color object."
+  (define (parse-digit i)
+    (match (string-ref s i)
+      (#\0 0)
+      (#\1 1)
+      (#\2 2)
+      (#\3 3)
+      (#\4 4)
+      (#\5 5)
+      (#\6 6)
+      (#\7 7)
+      (#\8 8)
+      (#\9 9)
+      ((or #\a #\A) 10)
+      ((or #\b #\B) 11)
+      ((or #\c #\C) 12)
+      ((or #\d #\D) 13)
+      ((or #\e #\E) 14)
+      ((or #\f #\F) 15)))
+  (define (parse-channel i)
+    (/ (+ (* (parse-digit i) 16)
+          (parse-digit (+ i 1)))
+       255.0))
+  ;; Support color codes with or without a "#" prefix and with or
+  ;; without an alpha channel.
+  (let* ((start (if (string-prefix? "#" s) 1 0))
+         (alpha? (> (string-length s) (+ start 6)))
+         (red (parse-channel start))
+         (green (parse-channel (+ start 2)))
+         (blue (parse-channel (+ start 4)))
+         (alpha (if alpha?
+                    (parse-channel (+ start 6))
+                    1.0)))
+    (make-color red green blue alpha)))
+
 ;; TODO: Optimize and inline
 (define color*
   (match-lambda*