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

2 files changed, 121 insertions, 5 deletions

diff --git a/guile/starlet/base.scm b/guile/starlet/base.scm
index 0d73acd..d9c7dd7 100644
--- a/guile/starlet/base.scm
+++ b/guile/starlet/base.scm
@@ -137,6 +137,73 @@
     #:setter set-state-name!))
 
 
+(define (find-colour state fix)
+  (let ((col (state-find fix 'colour state)))
+    (if (eq? 'no-value col)
+
+        (let ((home-col (get-attr-home-val fix 'colour)))
+          (if (eq? 'fixture-does-not-have-attribute home-col)
+              (raise-exception (make-exception
+                                 (make-exception-with-message
+                                   "Fixture doesn't have colour attribute")
+                                 (make-exception-with-irritants fix)))
+              home-col))
+
+        col)))
+
+
+(define-method (set-in-state! (state <starlet-state>)
+                              (fix <fixture>)
+                              (attr <colour-component-id>)
+                              new-val)
+  (let ((current-colour (find-colour state fix))
+        (colour-component (get-colour-component attr)))
+
+    (cond
+
+      ((eq? colour-component 'cyan)
+       (let ((orig-colour (colour-as-cmy current-colour)))
+         (set-in-state! state fix 'colour
+                        (make-colour-cmy new-val
+                                         (magenta orig-colour)
+                                         (yellow orig-colour)))))
+
+      ((eq? colour-component 'magenta)
+       (let ((orig-colour (colour-as-cmy current-colour)))
+         (set-in-state! state fix 'colour
+                        (make-colour-cmy (cyan orig-colour)
+                                         new-val
+                                         (yellow orig-colour)))))
+
+      ((eq? colour-component 'yellow)
+       (let ((orig-colour (colour-as-cmy current-colour)))
+         (set-in-state! state fix 'colour
+                        (make-colour-cmy (cyan orig-colour)
+                                         (magenta orig-colour)
+                                         new-val))))
+
+      ((eq? colour-component 'red)
+       (let ((orig-colour (colour-as-rgb current-colour)))
+         (set-in-state! state fix 'colour
+                        (make-colour-rgb new-val
+                                         (green orig-colour)
+                                         (blue orig-colour)))))
+
+      ((eq? colour-component 'green)
+       (let ((orig-colour (colour-as-rgb current-colour)))
+         (set-in-state! state fix 'colour
+                        (make-colour-rgb (red orig-colour)
+                                         new-val
+                                         (blue orig-colour)))))
+
+      ((eq? colour-component 'blue)
+       (let ((orig-colour (colour-as-rgb current-colour)))
+         (set-in-state! state fix 'colour
+                        (make-colour-rgb (red orig-colour)
+                                         (green orig-colour)
+                                         new-val)))))))
+
+
 (define-method (set-in-state! (state <starlet-state>)
                               (fix <fixture>)
                               (attr <symbol>)
@@ -160,20 +227,30 @@
   (make <starlet-state>))
 
 
-(define (find-attr fix attr-name)
+(define-method (find-attr (fix <fixture>) (attr-name <symbol>))
   (find (lambda (a)
           (eq? (get-attr-name a)
                attr-name))
         (slot-ref fix 'attributes)))
 
 
-(define (get-attr-home-val fix attr)
+(define-method (find-attr (fix <fixture>) (attr-name <colour-component-id>))
+  (find-attr fix 'colour))
+
+
+(define-method (get-attr-home-val (fix <fixture>) (attr <symbol>))
   (let ((attr-obj (find-attr fix attr)))
     (if attr-obj
         (attr-home-value attr-obj)
         'fixture-does-not-have-attribute)))
 
 
+(define-method (get-attr-home-val (fix <fixture>) (attr <colour-component-id>))
+  (extract-colour-component
+    (get-attr-home-val fix 'colour)
+    attr))
+
+
 (define (blackout state)
   (state-for-each
     (lambda (fix attr val)
@@ -303,11 +380,23 @@
                  (get-state-hash-table state)))
 
 
-(define (state-find fix attr state)
+(define-method (state-find (fix <fixture>)
+                           (attr <symbol>)
+                           (state <starlet-state>))
   (hash-ref (get-state-hash-table state)
             (cons fix attr)
             'no-value))
 
+
+(define-method (state-find (fix <fixture>)
+                           (attr <colour-component-id>)
+                           (state <starlet-state>))
+  (let ((col (state-find fix 'colour state)))
+    (if (eq? 'no-value col)
+        'no-value
+        (extract-colour-component col attr))))
+
+
 (define (state-map func state)
   (hash-map->list (lambda (key value)
                     (func (car key)
@@ -479,7 +568,7 @@ pre-existing contents."
         (state-find fix attr first-state)
         'no-value)))
 
-(define (current-value fix attr-name tnow)
+(define-method (current-value (fix <fixture>) (attr-name <symbol>) tnow)
   (let  ((programmer-val (state-find fix attr-name programmer-state)))
     (if (eq? 'no-value programmer-val)
 
@@ -508,6 +597,11 @@ pre-existing contents."
         (value->number programmer-val tnow))))
 
 
+(define-method (current-value (fix <fixture>) (attr-name <colour-component-id>) tnow)
+  (let ((colour (current-value fix 'colour tnow)))
+    (extract-colour-component colour attr-name)))
+
+
 (define-syntax attr-continuous
   (syntax-rules ()
     ((_ attr-name attr-range attr-home-value)
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)))))))