diff options
| author | David Thompson <dthompson2@worcester.edu> | 2023-09-13 19:04:40 -0400 |
|---|---|---|
| committer | David Thompson <dthompson2@worcester.edu> | 2023-09-13 19:04:40 -0400 |
| commit | 9f5d9fe528040a9ef4a776c3cac4f7b8350bad4e (patch) | |
| tree | 907043b95beed698b290ff6daa8e12aae13de6b3 | |
| parent | 3d536ad31168f5f3b07f70f8a8bef4d17233d51c (diff) | |
graphics: color: Add color/, color-tone-map, and color->string.
| -rw-r--r-- | chickadee/graphics/color.scm | 33 |
1 files changed, 33 insertions, 0 deletions
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))) |