diff options
author | Thomas White <taw@physics.org> | 2020-08-12 19:51:05 +0200 |
---|---|---|
committer | Thomas White <taw@physics.org> | 2020-08-12 19:51:05 +0200 |
commit | 1bc3b3224dc6c286ec1c1853193f82ec39a8bdf5 (patch) | |
tree | 1af2382bd3ba0a0c6d252f7e3dc1ea7af86308d0 /guile/starlet | |
parent | 9d38b9ce666138567c27008bdf4531c15bd5ca92 (diff) |
New model for cues and playbacks
Diffstat (limited to 'guile/starlet')
-rw-r--r-- | guile/starlet/base.scm | 149 |
1 files changed, 68 insertions, 81 deletions
diff --git a/guile/starlet/base.scm b/guile/starlet/base.scm index aa939d7..e0cdbaa 100644 --- a/guile/starlet/base.scm +++ b/guile/starlet/base.scm @@ -9,7 +9,7 @@ #:export (<fixture> <fixture-attribute> start-ola-output patch-fixture set-attr! home-attr! home-all! blackout - make-workspace scanout-freq + scanout-freq make-empty-state register-state! make-playback cue cut-to-cue percent->dmxval msb lsb chan)) @@ -76,6 +76,26 @@ #:setter set-state-hash-table!)) +;; A "playback" is a state which knows how to run cues +;; from a cue list +(define-class <starlet-playback> (<starlet-state>) + (active-fade-list + #:init-value '() + #:getter get-active-fade-list + #:setter set-active-fade-list!) + (cue-list + #:init-keyword #:cue-list + #:getter get-playback-cue-list) + (hash-table + #:allocation #:virtual + #:getter get-state-hash-table + #:slot-ref (lambda (instance) + (merge-active-fades + (get-active-fade-list instance))) + #:slot-set! (lambda (instance new-val) + (error "Can't set hash table on playback")))) + + (define-generic set-in-state!) (define-method (set-in-state! (state <starlet-state>) @@ -87,16 +107,6 @@ value)) -;; A "workspace" is just a "state" with extra information -;; about how its contents should be sent out on the wire -(define-class <starlet-workspace> (<starlet-state>) - (priority - #:init-value 0 - #:init-keyword #:priority - #:getter get-workspace-priority - #:setter set-workspace-priority!)) - - (define-record-type <fade> (make-fade state target-frac fade-time fade-delay start-time) fade? @@ -108,16 +118,26 @@ (define-record-type <cue> - (make-cue number state-func up-time down-time up-delay down-delay) + (make-cue number state up-time down-time up-delay down-delay) cue? (number get-cue-number) - (state-func get-cue-state-func) + (state get-cue-state) (up-time up-time) (up-delay up-delay) (down-time down-time) (down-delay down-delay)) +(define (merge-active-fades list-of-fades) + (get-state-hash-table + (merge-states-htp + (map (lambda (fade) + ;; Scale a fade according to the current time + ;; and return a new state + (get-fade-state fade)) + list-of-fades)))) + + (define (qnum a) (/ (inexact->exact (* a 1000)) 1000)) @@ -133,20 +153,9 @@ down-delay)) -(define-class <starlet-playback> (<starlet-workspace>) - (active-state - #:init-value '() - #:getter get-active-state-list - #:setter set-active-state-list!) - (cue-list - #:init-keyword #:cue-list - #:getter get-playback-cue-list)) - - (define (make-playback cue-list) (let ((new-playback (make <starlet-playback> #:cue-list cue-list))) - (add-to-workspace-list new-playback) new-playback)) @@ -158,15 +167,15 @@ (define (cut-to-cue pb cue-number) - (let* ((cue-state-func - (get-cue-state-func - (find-cue (get-playback-cue-list pb) - cue-number)))) + (let* ((state (expand-state + (get-cue-state + (find-cue (get-playback-cue-list pb) + cue-number))))) ;; Flush everything out and just set the state - (set-active-state-list! pb + (set-active-fade-list! pb (list (make-fade - (cue-state-func pb) + state 1.0 0.0 0.0 (hirestime)))))) @@ -175,11 +184,13 @@ ;; Basic workspace which holds everything at "home" unless ;; commanded otherwise -(define base-workspace (make <starlet-workspace> - #:priority -100)) +(define home-state (make <starlet-state>)) + +(define (make-empty-state) + (make <starlet-state>)) ;; List of workspaces -(define workspace-list (make-atomic-box (list base-workspace))) +(define state-list (make-atomic-box (list home-state))) ;; Set a single attribute to home position @@ -210,18 +221,12 @@ attr-name)) (slot-ref fix 'attributes))) -(define (add-to-workspace-list new-workspace) - (atomic-box-set! workspace-list - (cons new-workspace - (atomic-box-ref workspace-list)))) - -(define (make-workspace) - (let ((new-workspace (make <starlet-workspace>))) - (add-to-workspace-list new-workspace) - new-workspace)) - +(define (register-state! new-state) + (atomic-box-set! state-list + (cons new-state + (atomic-box-ref state-list)))) -;; Set an attribute +;; Set an attribute by name (define (set-attr! workspace fix attr-name value) (let ((attr (find-attr fix attr-name))) (when attr (set-in-state! workspace fix attr value)))) @@ -233,35 +238,6 @@ 1.0)) -(define (wrap-fade value fade-time start-time) - (lambda (time) - (inexact->exact (* (value->number value time) - (fade-frac fade-time - start-time - (hirestime)))))) - - -;; "state" is a function with one parameter: a workspace -;; This function sets up "workspace" to fade in the state -(define* (fade-up workspace state - #:key (fade-time 5)) - (let ((fade-up-state (make <starlet-state>)) - (start-time (hirestime))) - - ;; Execute passed-in function to get state - (state fade-up-state) - - (state-for-each (lambda (fix attr value) - (set-in-state! fade-up-state - fix - attr - (wrap-fade value fade-time start-time))) - fade-up-state) - - (set-state-hash-table! workspace - (get-state-hash-table fade-up-state)))) - - ;; Patch a new fixture (define* (patch-fixture class start-addr @@ -270,7 +246,7 @@ #:sa start-addr #:uni universe #:friendly-name friendly-name))) - (home-all! base-workspace new-fixture) + (home-all! home-state new-fixture) (atomic-box-set! patched-fixture-list (cons new-fixture (atomic-box-ref patched-fixture-list))) @@ -337,21 +313,32 @@ (value->number b time)))) +;; If "state" is a procedure, call it to get the real state +;; Otherwise, pass through +(define (expand-state state) + (if (procedure? state) + (state) + state)) + + (define (merge-rule-ltp a b) b) (define (merge-rule-htp a b) (max a b)) +(define (merge-states-htp list-of-states) + (merge-states merge-rule-htp + list-of-states)) ;; Combine states -(define (merge-states merge-rule list-of-workspaces) +(define (merge-states merge-rule list-of-states) (let ((combined-state (make <starlet-state>))) - (for-each (lambda (workspace) + (for-each (lambda (state) (add-state-to-state merge-rule - workspace + (expand-state state) combined-state)) - list-of-workspaces) + list-of-states) combined-state)) @@ -427,9 +414,9 @@ (value->number value (hirestime)) set-dmx))) - (merge-states merge-rule-htp - (atomic-box-ref - workspace-list))) + (merge-states-htp + (reverse + (atomic-box-ref state-list)))) ;; Send everything to OLA (for-each (lambda (a) |