diff options
| -rw-r--r-- | guile/starlet/base.scm | 153 | ||||
| -rw-r--r-- | guile/starlet/midi-control/faders.scm | 18 | ||||
| -rw-r--r-- | guile/starlet/playback.scm | 101 |
3 files changed, 114 insertions, 158 deletions
diff --git a/guile/starlet/base.scm b/guile/starlet/base.scm index b857a7f..278e44c 100644 --- a/guile/starlet/base.scm +++ b/guile/starlet/base.scm @@ -25,9 +25,8 @@ get-attr-type get-attr-range get-attr-name - fixture-attribute? + get-attr-home-val intensity? - home-val <starlet-state> make-empty-state @@ -39,8 +38,9 @@ clear-state! print-state state-source - set-attr! + set-in-state! state-find + have-value merge-states-htp current-state at @@ -83,8 +83,7 @@ (home-value #:init-value 0 #:init-keyword #:home-value - #:getter get-attr-home-value - #:setter set-attr-home-value!)) + #:getter attr-home-value)) (define-class <fixture> (<object>) @@ -125,10 +124,6 @@ (is-a? f <fixture>)) -(define (fixture-attribute? f) - (is-a? f <fixture-attribute>)) - - ;; A "state" is just a thin wrapper around a hash table ;; of (fixture . attribute) --> value (define-class <starlet-state> (<object>) @@ -140,44 +135,46 @@ (define-method (set-in-state! (state <starlet-state>) (fix <fixture>) - (attr <fixture-attribute>) + (attr <symbol>) value) (hash-set! (get-state-hash-table state) (cons fix attr) value)) - -(define make-fixture-home-pair cons) -(define get-fixture-list car) -(define get-home-state cdr) - ;; List of fixtures and home state (must remain consistent) -(define fixtures - (make-atomic-box - (make-fixture-home-pair - - ;; Actual list of fixtures - '() - - ;; Basic state which holds everything at "home" unless commanded otherwise - (make <starlet-state>)))) +(define fixtures (make-atomic-box '())) +;; List of states being scanned out +(define state-list (make-atomic-box '())) ;; The state used to build a new scene for recording (define programmer-state (make <starlet-state>)) -(define (blackout state) - (state-for-each - (lambda (fix attr val) - (when (intensity? attr) - (set-in-state! state fix attr 0.0))) - state)) (define (make-empty-state) (make <starlet-state>)) -;; List of states being scanned out -(define state-list (make-atomic-box '())) + +(define (find-attr fix attr-name) + (find (lambda (a) + (eq? (get-attr-name a) + attr-name)) + (slot-ref fix 'attributes))) + + +(define (get-attr-home-val fix attr) + (let ((attr-obj (find-attr fix attr))) + (if attr-obj + (attr-home-value attr-obj) + 'fixture-does-not-have-attribute))) + + +(define (blackout state) + (state-for-each + (lambda (fix attr val) + (when (intensity? attr) + (set-in-state! state fix attr 0.0))) + state)) ;; Set a single attribute to home position @@ -185,7 +182,7 @@ (set-in-state! state fix attr - (get-attr-home-value attr))) + (get-attr-home-val fix attr))) (define (copy-state state) @@ -199,46 +196,15 @@ new-state)) -;; Return a new state with all attributes of 'fix' set to home values -(define (home-all state fix) - (let ((new-home-state (copy-state state))) - (for-each (lambda (attr) - (home-attr! new-home-state fix attr)) - (slot-ref fix 'attributes)) - new-home-state)) - - -(define (home-val fix attr) - (state-find fix - attr - (get-home-state - (atomic-box-ref fixtures)))) - (define (intensity? a) - (eq? 'intensity (get-attr-name a))) + (eq? 'intensity a)) -(define (find-attr fix attr-name) - (find (lambda (a) - (eq? (get-attr-name a) - attr-name)) - (slot-ref fix 'attributes))) - (define (register-state! new-state) (atomic-box-set! state-list (cons new-state (atomic-box-ref state-list)))) -;; Set an attribute by name -(define (set-attr! state fix attr-name value) - (cond - ((symbol? attr-name) - (let ((attr (find-attr fix attr-name))) - (when attr (set-in-state! state fix attr value)))) - ((fixture-attribute? attr-name) - (set-in-state! state fix attr-name value)))) - - ;; Patch a new fixture (define* (patch-real name class @@ -248,14 +214,9 @@ #:name name #:sa start-addr #:uni universe - #:friendly-name friendly-name)) - (fixture-home-pair (atomic-box-ref fixtures))) - (atomic-box-set! fixtures - (make-fixture-home-pair - (cons new-fixture - (get-fixture-list fixture-home-pair)) - (home-all (get-home-state fixture-home-pair) - new-fixture))) + #:friendly-name friendly-name))) + (atomic-box-set! fixtures (cons new-fixture + (atomic-box-ref fixtures))) new-fixture)) @@ -301,9 +262,14 @@ value)) (get-state-hash-table state))) + +(define (have-value val) + (not (eq? val 'attribute-not-in-state))) + (define (state-find fix attr state) (hash-ref (get-state-hash-table state) - (cons fix attr))) + (cons fix attr) + 'attribute-not-in-state)) (define (state-map func state) (hash-map->list (lambda (key value) @@ -319,7 +285,7 @@ (let ((current-value (state-find fix attr combined-state))) - (if current-value + (if (have-value current-value) (set-in-state! combined-state fix attr @@ -444,7 +410,6 @@ pre-existing contents." (let* ((fixture-home-pair (atomic-box-ref fixtures)) (combined-state (merge-states-ltp (list - (get-home-state fixture-home-pair) (merge-states-htp (atomic-box-ref state-list)) programmer-state)))) @@ -458,10 +423,10 @@ pre-existing contents." ;; Helper function to get a value for this ;; fixture in the current state (define (get-attr attr-name) - (value->number (state-find fix - (find-attr fix attr-name) - combined-state) - (hirestime))) + (let ((val (state-find fix attr-name combined-state))) + (if (have-value val) + (value->number val (hirestime)) + (get-attr-home-val fix attr-name)))) ;; Helper function to set 8-bit DMX value (define (set-chan relative-channel-number value) @@ -478,7 +443,7 @@ pre-existing contents." (scanout-fixture fix get-attr set-chan set-chan-16bit))) - (get-fixture-list fixture-home-pair)) + (atomic-box-ref fixtures)) ;; Send everything to OLA @@ -527,12 +492,13 @@ pre-existing contents." (let* ((fixture-home-pair (atomic-box-ref fixtures)) (combined-state (merge-states-ltp (list - (get-home-state fixture-home-pair) (merge-states-htp (atomic-box-ref state-list)) - programmer-state))) - (attr (find-attr fix attr-name))) - (value->number (state-find fix attr combined-state) 0))) + programmer-state)))) + (let ((val (state-find fix attr-name combined-state))) + (if (have-value val) + (value->number val 0) + (get-attr-home-val fix attr-name))))) (define-syntax attr-continuous @@ -584,17 +550,12 @@ pre-existing contents." (values output1 output2 others)))) -(define (attr-or-symbol? a) - (or (fixture-attribute? a) - (symbol? a))) - - (define (set-fixtures fixtures attr-name value) (for-each (lambda (fix) - (set-attr! (current-state) - fix - (car attr-name) - (car value))) + (set-in-state! (current-state) + fix + (car attr-name) + (car value))) fixtures)) @@ -609,7 +570,7 @@ pre-existing contents." (define (at . args) (receive (fixtures attr-name value) - (partition3 fixture? attr-or-symbol? (flatten-sublists args)) + (partition3 fixture? symbol? (flatten-sublists args)) (cond ((nil? value) (error "at: Value not specified")) @@ -647,6 +608,6 @@ pre-existing contents." (state-map (lambda (fix attr val) (list 'at (get-fixture-name fix) - (list 'quote (get-attr-name attr)) + (list 'quote attr) val)) a))) diff --git a/guile/starlet/midi-control/faders.scm b/guile/starlet/midi-control/faders.scm index 97ed1ff..ae8162a 100644 --- a/guile/starlet/midi-control/faders.scm +++ b/guile/starlet/midi-control/faders.scm @@ -80,10 +80,10 @@ #:func (lambda (prev-cc-val new-cc-value) (set! offset (+ offset (ccval->offset new-cc-value))) (for-each (lambda (fix old-val) - (set-attr! programmer-state - fix - attr - (+ old-val offset))) + (set-in-state! programmer-state + fix + attr + (+ old-val offset))) fixtures old-vals))))))) @@ -129,11 +129,11 @@ initial-vals fixtures) (for-each (lambda (fix initial-val gradient) - (set-attr! programmer-state - fix - attr-name - (+ initial-val - (* gradient cc-offset)))) + (set-in-state! programmer-state + fix + attr-name + (+ initial-val + (* gradient cc-offset)))) fixtures initial-vals gradients)) diff --git a/guile/starlet/playback.scm b/guile/starlet/playback.scm index 9746659..1d28d46 100644 --- a/guile/starlet/playback.scm +++ b/guile/starlet/playback.scm @@ -306,7 +306,7 @@ ;; Attr not seen before in this playback: start fading from home ((eq? old-fade-record #f) - (home-val fix attr)) + (get-attr-home-val fix attr)) ;; Attr seen in a finished fade ((fade-finished? tnow old-fade-record) @@ -330,54 +330,54 @@ ;; Non-intensity attribute ((not (intensity? attr)) - (set-attr! pb fix attr (wrap-fade (fade-previous fade-record) - (fade-target fade-record) - (fade-preset fade-record) - attr-time - attr-delay - preset-time - preset-delay - (fade-start-time fade-record)))) + (set-in-state! pb fix attr (wrap-fade (fade-previous fade-record) + (fade-target fade-record) + (fade-preset fade-record) + attr-time + attr-delay + preset-time + preset-delay + (fade-start-time fade-record)))) ;; Number to number, fading up ((and (number? target) (number? prev-val) (> target prev-val)) - (set-attr! pb fix attr (wrap-fade prev-val - target - #f - up-time - up-delay - 0.0 - 0.0 - (fade-start-time fade-record)))) + (set-in-state! pb fix attr (wrap-fade prev-val + target + #f + up-time + up-delay + 0.0 + 0.0 + (fade-start-time fade-record)))) ;; Number to number, fading down ((and (number? target) (number? prev-val) (< target prev-val)) - (set-attr! pb fix attr (wrap-fade prev-val - target - #f - down-time - down-delay - 0.0 - 0.0 - (fade-start-time fade-record)))) + (set-in-state! pb fix attr (wrap-fade prev-val + target + #f + down-time + down-delay + 0.0 + 0.0 + (fade-start-time fade-record)))) ;; Number to number, staying the same ((and (number? target) (number? prev-val)) - (set-attr! pb fix attr (wrap-fade prev-val - target - #f - 0.0 - 0.0 - 0.0 - 0.0 - (fade-start-time fade-record)))) + (set-in-state! pb fix attr (wrap-fade prev-val + target + #f + 0.0 + 0.0 + 0.0 + 0.0 + (fade-start-time fade-record)))) ;; Everything else, e.g. number to effect (else - (set-attr! pb fix attr (wrap-xf (fade-previous fade-record) - (fade-target fade-record) - (get-fade-record-fade-times fade-record) - (fade-start-time fade-record)))))))) + (set-in-state! pb fix attr (wrap-xf (fade-previous fade-record) + (fade-target fade-record) + (get-fade-record-fade-times fade-record) + (fade-start-time fade-record)))))))) (define (fade-finished? tnow fade-record) @@ -409,20 +409,13 @@ ((and (pair? attr-el) (fixture? (car attr-el)) - (fixture-attribute? (cdr attr-el))) - (and (eq? (car attr-el) fix) - (eq? (cdr attr-el) attr))) - - ((and (pair? attr-el) - (fixture? (car attr-el)) (symbol? (cdr attr-el))) (and (eq? (car attr-el) fix) - (eq? (cdr attr-el) (get-attr-name attr)))) + (eq? (cdr attr-el) attr))) ((list? attr-el) (and (memq fix attr-el) - (or (memq attr attr-el) - (memq (get-attr-name attr) attr-el)))) + (memq attr attr-el))) (else #f))) @@ -445,9 +438,9 @@ (define (fixture-dark? fix the-cue) (let ((val (state-find fix - (find-attr fix 'intensity) + 'intensity (get-realized-state the-cue)))) - (or (not val) + (or (not (have-value val)) (eqv? 0 val)))) @@ -577,11 +570,13 @@ ((get-cue-state-function the-cue)) (state-for-each (lambda (fix attr val) (unless (intensity? attr) - (unless (state-find fix attr old-current-state) - (set-attr! old-current-state - fix - attr - (home-val fix attr))))) + (unless (have-value (state-find fix + attr + old-current-state)) + (set-in-state! old-current-state + fix + attr + (get-attr-home-val fix attr))))) (current-state)))))) |