Extend attribute-handling functions to handle colour component IDs

The following routines become generic functions with special cases for
when a specific colour channel is being referred to:
- set-in-state!
- find-attr
- get-attr-home-val
- state-find
- current-value

1 files changed, 23 insertions, 1 deletions

diff --git a/guile/starlet/colours.scm b/guile/starlet/colours.scm
index b5ff71b..2553089 100644
--- a/guile/starlet/colours.scm
+++ b/guile/starlet/colours.scm
@@ -21,7 +21,8 @@
              <colour-component-id>
              colour-component-id?
              colour-component-id
-             get-colour-component))
+             get-colour-component
+             extract-colour-component))
 
 
 (define-class <colour> (<object>)
@@ -150,3 +151,24 @@
 (define (colour-component-id a)
   (make <colour-component-id>
         #:component a))
+
+
+(define (extract-colour-component col component-id)
+  (cond
+    ((eq? (get-colour-component component-id) 'cyan)
+     (cyan (colour-as-cmy col)))
+    ((eq? (get-colour-component component-id) 'magenta)
+     (magenta (colour-as-cmy col)))
+    ((eq? (get-colour-component component-id) 'yellow)
+     (yellow (colour-as-cmy col)))
+    ((eq? (get-colour-component component-id) 'red)
+     (red (colour-as-rgb col)))
+    ((eq? (get-colour-component component-id) 'green)
+     (green (colour-as-rgb col)))
+    ((eq? (get-colour-component component-id) 'blue)
+     (blue (colour-as-rgb col)))
+    (else (raise-exception (make-exception
+                             (make-exception-with-message
+                               "Invalid colour component ID")
+                             (make-exception-with-irritants
+                               (get-colour-component component-id)))))))