diff options
author | Thomas White <taw@physics.org> | 2021-08-08 17:24:09 +0200 |
---|---|---|
committer | Thomas White <taw@physics.org> | 2021-08-08 17:24:09 +0200 |
commit | d79c75b3db76e242e0299d5d324191e3133de235 (patch) | |
tree | 4f2372906e5daaed42575b2972eafaad606e9d1b /guile/starlet/state.scm | |
parent | bc6dccd1fa53644f81274a5b660749ced7d9d8a5 (diff) |
Add hook for state updates
This includes a "source", intended to be used for avoiding hook users
from responding to their own changes.
Diffstat (limited to 'guile/starlet/state.scm')
-rw-r--r-- | guile/starlet/state.scm | 59 |
1 files changed, 48 insertions, 11 deletions
diff --git a/guile/starlet/state.scm b/guile/starlet/state.scm index 82db18b..010e486 100644 --- a/guile/starlet/state.scm +++ b/guile/starlet/state.scm @@ -52,7 +52,8 @@ get-selection value->number atomically-overlay-state! - update-state!)) + update-state! + add-update-hook!)) ;; A "state" is an atomically-updating container for an immutable @@ -63,13 +64,21 @@ (define-class <starlet-state> (<object>) (hash-table-box #:init-form (make-atomic-box (make-hash-table)) - #:getter get-ht-box)) + #:getter get-ht-box) + (update-hook + #:init-form (make-hook 4) + #:getter get-update-hook)) ;; The state used to build a new scene for recording (define programmer-state (make <starlet-state>)) +(define (add-update-hook! state proc) + (add-hook! (get-update-hook state) + proc)) + + (define (find-colour state fix) (let ((col (state-find fix 'colour state))) (if (eq? 'no-value col) @@ -93,7 +102,8 @@ (define-method (set-in-state! (state <starlet-state>) (fix <fixture>) (attr <colour-component-id>) - new-val) + new-val + source) (let ((current-colour (find-colour state fix)) (colour-component (get-colour-component attr))) @@ -104,48 +114,55 @@ (set-in-state! state fix 'colour (make-colour-cmy new-val (magenta orig-colour) - (yellow orig-colour))))) + (yellow orig-colour)) + source))) ((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))))) + (yellow orig-colour)) + source))) ((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)))) + new-val) + source))) ((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))))) + (blue orig-colour)) + source))) ((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))))) + (blue orig-colour)) + source))) ((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))))))) + new-val) + source)))))) (define-method (set-in-state! (state <starlet-state>) (fix <fixture>) (attr <symbol>) - value) + value + source) (let* ((old-ht (atomic-box-ref (get-ht-box state))) (new-ht (copy-hash-table old-ht))) (hash-set! new-ht @@ -156,7 +173,27 @@ old-ht new-ht) old-ht) - (set-in-state! state fix attr)))) ;; Try again + (set-in-state! state fix attr)) ;; Try again + + (run-hook (get-update-hook state) + fix + attr + value + source))) + + +(define-method (set-in-state! (state <starlet-state>) + (fix <fixture>) + (attr <symbol>) + value) + (set-in-state! state fix attr value #f)) + + +(define-method (set-in-state! (state <starlet-state>) + (fix <fixture>) + (attr <colour-component-id>) + new-val) + (set-in-state! state fix attr new-val #f)) ;; Set any intensity attributes in the current state to zero |