diff options
author | Thomas White <taw@physics.org> | 2021-04-18 11:38:17 +0200 |
---|---|---|
committer | Thomas White <taw@physics.org> | 2021-04-18 12:57:30 +0200 |
commit | f02b353e84d4fea27630216dca8a8c7aa144b77d (patch) | |
tree | edb6690e37ff3d6464b44a3ce31c8f8e6d6bfd45 | |
parent | b8ed119b2289f0a81e2ada3f2fc8c85ff37de21c (diff) |
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
-rw-r--r-- | guile/starlet/base.scm | 102 | ||||
-rw-r--r-- | guile/starlet/colours.scm | 24 |
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))))))) |