From 0f24bdf11f806d7b4ad19e256cf1d5f0cda1b5e4 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson@member.fsf.org>
Date: Sun, 30 Mar 2014 20:23:35 -0400
Subject: Expand color API.

* 2d/color.scm (color*, color+, color-, color-inverse): New procedures.
  (use-color): Delete it.
  (make-color): Clamp channels to the range [0, 1].
  (rgba, rgb): Use low-level color constructor.
---
 2d/color.scm | 77 +++++++++++++++++++++++++++++++++++++++++++++++-------------
 1 file changed, 61 insertions(+), 16 deletions(-)

(limited to '2d')

diff --git a/2d/color.scm b/2d/color.scm
index f66c659..e52cf48 100644
--- a/2d/color.scm
+++ b/2d/color.scm
@@ -32,9 +32,12 @@
             color-g
             color-b
             color-a
-            use-color
             rgba
             rgb
+            color*
+            color+
+            color-
+            color-inverse
             white
             black
             red
@@ -43,19 +46,20 @@
             magenta))
 
 (define-record-type <color>
-  (make-color r g b a)
+  (%make-color r g b a)
   color?
   (r color-r)
   (g color-g)
   (b color-b)
   (a color-a))
 
-(define (use-color color)
-  "Set the current OpenGL color state to the contents of COLOR."
-  (gl-color (color-r color)
-            (color-g color)
-            (color-b color)
-            (color-a color)))
+(define (make-color r g b a)
+  "Return a newly allocated color with the given RGBA channel values.
+Each channel is clamped to the range [0, 1]."
+  (%make-color (clamp 0 1 r)
+               (clamp 0 1 g)
+               (clamp 0 1 b)
+               (clamp 0 1 a)))
 
 (define (color-component color-code offset)
   "Return the value of an 8-bit color channel in the range [0,1] for
@@ -69,19 +73,60 @@ the integer COLOR-CODE, given an OFFSET in bits."
   "Translate an RGBA format string COLOR-CODE into a color object.
 For example: #xffffffff will return a color with RGBA values 1, 1, 1,
 1."
-  (make-color (color-component color-code 24)
-              (color-component color-code 16)
-              (color-component color-code 8)
-              (color-component color-code 0)))
+  (%make-color (color-component color-code 24)
+               (color-component color-code 16)
+               (color-component color-code 8)
+               (color-component color-code 0)))
 
 (define (rgb color-code)
   "Translate an RGB format string COLOR-CODE into a color object.
 For example: #xffffff will return a color with RGBA values 1, 1, 1,
 1."
-  (make-color (color-component color-code 16)
-              (color-component color-code 8)
-              (color-component color-code 0)
-              1))
+  (%make-color (color-component color-code 16)
+               (color-component color-code 8)
+               (color-component color-code 0)
+               1))
+
+(define (color* a b)
+  "Multiply the RGBA channels of colors A and 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))))
+
+(define (color+ a b)
+  "Add the RGBA channels of colors A and 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))))
+
+(define (color- a b)
+  "Subtract the RGBA channels of colors A and 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))))
+
+(define (color-inverse color)
+  "Create a new color that is the inverse of COLOR.  The alpha channel
+is left unchanged."
+  (make-color (- 1 (color-r color))
+              (- 1 (color-g color))
+              (- 1 (color-b color))
+              (color-a color)))
 
 ;; Pre-defined colors.
 (define white (rgb #xffffff))
-- 
cgit v1.2.3