From 9f5d9fe528040a9ef4a776c3cac4f7b8350bad4e Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Wed, 13 Sep 2023 19:04:40 -0400
Subject: graphics: color: Add color/, color-tone-map, and color->string.

---
 chickadee/graphics/color.scm | 33 +++++++++++++++++++++++++++++++++
 1 file changed, 33 insertions(+)

diff --git a/chickadee/graphics/color.scm b/chickadee/graphics/color.scm
index c962b74..78e4c75 100644
--- a/chickadee/graphics/color.scm
+++ b/chickadee/graphics/color.scm
@@ -39,10 +39,13 @@
             rgb
             transparency
             string->color
+            color->string
             color*
             color+
             color-
+            color/
             color-inverse
+            color-tone-map
             color-lerp
 
             white
@@ -221,6 +224,21 @@ a color object."
                     1.0)))
     (make-color red green blue alpha)))
 
+(define (color->string color)
+  (define (8bit-channel channel)
+    (inexact->exact (round (* (clamp 0.0 1.0 channel) 255.0))))
+  (let ((r (8bit-channel (color-r color)))
+        (g (8bit-channel (color-g color)))
+        (b (8bit-channel (color-b color)))
+        (a (8bit-channel (color-a color))))
+    (with-output-to-string
+      (lambda ()
+        (display "#")
+        (display (number->string r 16))
+        (display (number->string g 16))
+        (display (number->string b 16))
+        (display (number->string a 16))))))
+
 (define-inlinable (color* a b)
   (if (color? b)
       (make-color (* (color-r a) (color-r b))
@@ -233,6 +251,18 @@ a color object."
                   (* (color-b a) b)
                   (* (color-a a) b))))
 
+(define-inlinable (color/ a b)
+  (if (color? b)
+      (make-color (/ (color-r a) (color-r b))
+                  (/ (color-g a) (color-g b))
+                  (/ (color-b a) (color-b b))
+                  (/ (color-a a) (color-a b)))
+      ;; Scalar multiplication.
+      (make-color (/ (color-r a) b)
+                  (/ (color-g a) b)
+                  (/ (color-b a) b)
+                  (/ (color-a a) b))))
+
 (define-inlinable (color+ a b)
   (make-color (+ (color-r a) (color-r b))
               (+ (color-g a) (color-g b))
@@ -252,6 +282,9 @@ a color object."
               ;; Do not alter alpha channel.
               (color-a color)))
 
+(define-inlinable (color-tone-map color)
+  (color/ color (color+ color (make-color 1.0 1.0 1.0 0.0))))
+
 (define-inlinable (color-lerp start end alpha)
   (color+ (color* start (- 1.0 alpha))
           (color* end alpha)))
-- 
cgit v1.2.3