From d79c75b3db76e242e0299d5d324191e3133de235 Mon Sep 17 00:00:00 2001 From: Thomas White Date: Sun, 8 Aug 2021 17:24:09 +0200 Subject: Add hook for state updates This includes a "source", intended to be used for avoiding hook users from responding to their own changes. --- guile/starlet/midi-control/faders.scm | 15 ++++++--- guile/starlet/state.scm | 59 ++++++++++++++++++++++++++++------- 2 files changed, 58 insertions(+), 16 deletions(-) diff --git a/guile/starlet/midi-control/faders.scm b/guile/starlet/midi-control/faders.scm index 8745688..dbd2a0f 100644 --- a/guile/starlet/midi-control/faders.scm +++ b/guile/starlet/midi-control/faders.scm @@ -128,7 +128,8 @@ attr (clamp-to-attr-range attr-obj - (+ old-val offset)))))) + (+ old-val offset)) + controller)))) fixtures old-vals))))))) @@ -177,13 +178,15 @@ attr-name gradients initial-vals - fixtures) + fixtures + controller) (for-each (lambda (fix initial-val gradient) (set-in-state! programmer-state fix attr-name (+ initial-val - (* gradient cc-offset)))) + (* gradient cc-offset)) + controller)) fixtures initial-vals gradients)) @@ -225,13 +228,15 @@ attr-name up-gradients initial-vals - fixtures)) + fixtures + controller)) ((<= new-cc-value congruent-val) (apply-fader (- new-cc-value congruent-val) attr-name dn-gradients initial-vals - fixtures))) + fixtures + controller))) (when (or (and (not prev-cc-val) (= new-cc-value congruent-val)) 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 () (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 )) +(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 ) (fix ) (attr ) - 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 ) (fix ) (attr ) - 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 ) + (fix ) + (attr ) + value) + (set-in-state! state fix attr value #f)) + + +(define-method (set-in-state! (state ) + (fix ) + (attr ) + new-val) + (set-in-state! state fix attr new-val #f)) ;; Set any intensity attributes in the current state to zero -- cgit v1.2.3