From 0171a2975024ea7155b02951943754688488ecee Mon Sep 17 00:00:00 2001 From: Thomas White Date: Tue, 21 Dec 2021 12:58:57 +0100 Subject: Separate cue lists from playbacks and crossfades --- guile/starlet/playback.scm | 420 ++------------------------------------------- 1 file changed, 14 insertions(+), 406 deletions(-) (limited to 'guile/starlet/playback.scm') diff --git a/guile/starlet/playback.scm b/guile/starlet/playback.scm index 10a5848..bd8dd74 100644 --- a/guile/starlet/playback.scm +++ b/guile/starlet/playback.scm @@ -33,7 +33,9 @@ #:use-module (starlet scanout) #:use-module (starlet utils) #:use-module (starlet clock) + #:use-module (starlet cue-list) #:use-module (starlet colours) + #:use-module (starlet transition-effect) #:export (make-playback cue cue-part @@ -89,28 +91,20 @@ #:getter state-change-hook)) +(define-class () + (func + #:init-value #f)) + + +(define (transition-effect? a) + (is-a? a )) + + (define-record-type - (make-cue-part attr-list - fade-times) + (make-cue-part attr-list transition) cue-part? (attr-list get-cue-part-attr-list) - (fade-times get-cue-part-fade-times)) - - -(define-record-type - (make-fade-times up-time - down-time - attr-time - up-delay - down-delay - attr-delay) - fade-times? - (up-time get-fade-up-time) - (down-time get-fade-down-time) - (attr-time get-fade-attr-time) - (up-delay get-fade-up-delay) - (down-delay get-fade-down-delay) - (attr-delay get-fade-attr-delay)) + (transition get-cue-part-transition)) (define-record-type @@ -118,8 +112,6 @@ state tracked-state preset-state - fade-times - preset-time track-intensities cue-parts cue-clock) @@ -130,8 +122,6 @@ set-tracked-state!) (preset-state get-preset-state set-preset-state!) - (fade-times get-cue-fade-times) - (preset-time get-cue-preset-time) (track-intensities track-intensities) (cue-parts get-cue-parts) (cue-clock get-cue-clock)) @@ -148,13 +138,6 @@ (/ (inexact->exact (* a 1000)) 1000)) -(define (read-cue-list-file filename) - (call-with-input-file - filename - (lambda (port) - (eval (read port) (interaction-environment))))) - - (define (reload-cue-list! pb) (let ((filename (get-playback-cue-list-file pb))) (if filename @@ -306,129 +289,6 @@ 'next-cue-unspecified)) -(define (snap-fade start-val - target-val - clock) - (if (> (elapsed-fraction clock) 0) - target-val - start-val)) - - -(define (colour-fade start-val - end-val - clock) - - (unless (and (colour? start-val) - (colour? end-val)) - (raise-exception (make-exception - (make-exception-with-message - "Non-colour arguments given to colour-fade") - (make-exception-with-irritants - (list start-val end-val))))) - - (interpolate-colour start-val - end-val - (elapsed-fraction clock) - #:interpolation-type 'linear-cmy)) - - -(define (simple-fade start-val - end-val - clock) - - (unless (and (number? start-val) - (number? end-val)) - (raise-exception (make-exception - (make-exception-with-message - "Non-number arguments given to simple-fade") - (make-exception-with-irritants - (list start-val end-val))))) - - (+ start-val - (* (- end-val start-val) - (elapsed-fraction clock)))) - - -(define (replace-noval val replacement) - (if (eq? 'no-value val) replacement val)) - - -(define (make-intensity-fade prev-val - target-val-in - up-clock - down-clock) - (let ((target-val (replace-noval target-val-in 0.0))) - - (cond - - ;; Number to number, fading up - ((and (number? target-val) - (number? prev-val) - (> target-val prev-val)) - (lambda () - (simple-fade prev-val - target-val - up-clock))) - - ;; Number to number, fading down - ((and (number? target-val) - (number? prev-val) - (< target-val prev-val)) - (lambda () - (simple-fade prev-val - target-val - down-clock))) - - ;; Number to number, staying the same - ;; NB We still need a static value so that fade-start-val can "unwrap" it - ((and (number? target-val) - (number? prev-val)) - (lambda () prev-val)) - - ;; Everything else, e.g. number to effect - (else - (lambda () - (max - (simple-fade (value->number prev-val) - 0 - down-clock) - (simple-fade 0 - (value->number target-val) - up-clock))))))) - - -(define (make-list-attr-fade start-val - target-val - clock) - (lambda () - (snap-fade start-val - target-val - clock))) - - -(define (make-general-fade fade-func - start-val - target-val - clock) - - (if (and (not (procedure? target-val)) - (not (eq? target-val 'no-value)) - (not (eq? start-val 'no-value))) - - ;; It makes sense to do a fade - (let ((real-start-val (value->number start-val))) - (lambda () - (fade-func real-start-val - target-val - clock))) - - ;; A fade doesn't make sense, so make do with a snap transition - (lambda () - (snap-fade start-val - target-val - clock)))) - - (define (match-fix-attr attr-el fix attr) (cond @@ -453,55 +313,6 @@ (get-cue-part-attr-list cue-part))) -(define (cue-part-fade-times the-cue fix attr) - - (let ((the-cue-part - (find (lambda (p) (in-cue-part? p fix attr)) - (get-cue-parts the-cue)))) - - (if (cue-part? the-cue-part) - (get-cue-part-fade-times the-cue-part) - (get-cue-fade-times the-cue)))) - - -(define (fade-start-val pb fix attr) - (let ((val-in-pb (state-find fix attr pb))) - (if (eq? val-in-pb 'no-value) - - ;; Not currently in playback - fade from home value - (get-attr-home-val fix attr) - - ;; Currently in playback - fade from current value - ;; by running the outer crossfade function - (val-in-pb)))) - - -(define (dark? a) - (or (eq? a 'no-value) - (and (number? a) - (< a 1)))) - - -(define (longest-fade-time fade-times) - (max - (+ (get-fade-down-time fade-times) - (get-fade-down-delay fade-times)) - (+ (get-fade-up-time fade-times) - (get-fade-up-delay fade-times)) - (+ (get-fade-attr-time fade-times) - (get-fade-attr-delay fade-times)))) - - -;; Work out how long it will take before we can forget about this cue -(define (cue-total-time the-cue) - (let ((fade-times (cons (get-cue-fade-times the-cue) - (map get-cue-part-fade-times - (get-cue-parts the-cue))))) - (fold max - 0 - (map longest-fade-time fade-times)))) - - (define (fix-attr-eq fa1 fa2) (and (eq? (car fa1) (car fa2)) (eq? (cdr fa1) (cdr fa2)))) @@ -522,75 +333,13 @@ (fold add-fix-attrs-to-list '() states)) -(define (make-fade-for-attribute-type type) - (cond - ((eq? type 'continuous) (cut make-general-fade simple-fade <...>)) - ((eq? type 'list) make-list-attr-fade) - ((eq? type 'colour) (cut make-general-fade colour-fade <...>)) - (else - (raise-exception (make-exception - (make-exception-with-message - "Unrecognised attribute type") - (make-exception-with-irritants type)))))) - - (define (run-cue-index! pb cue-index) (let* ((the-cue (vector-ref (get-playback-cue-list pb) cue-index)) (this-cue-state (get-tracked-state the-cue)) (overlay-state (make-empty-state)) (cue-clock (get-cue-clock the-cue))) - (for-each - (lambda (fix-attr) - - (let* ((fix (car fix-attr)) - (attr (cdr fix-attr)) - (fade-times (cue-part-fade-times the-cue fix attr)) - - ;; The values for fading - (start-val (fade-start-val pb fix attr)) - (target-val (state-find fix attr this-cue-state)) - ;; The clocks for things in this cue part - (up-clock (make-delayed-clock cue-clock - (get-fade-up-delay fade-times) - (get-fade-up-time fade-times))) - - (down-clock (make-delayed-clock cue-clock - (get-fade-down-delay fade-times) - (get-fade-down-time fade-times))) - - (attribute-clock (make-delayed-clock cue-clock - (get-fade-attr-delay fade-times) - (get-fade-attr-time fade-times)))) - - (if (intensity? attr) - - ;; Intensity attribute - (set-in-state! overlay-state fix attr - (make-intensity-fade start-val - target-val - up-clock - down-clock)) - - ;; Non-intensity attribute - (let ((attribute-obj (find-attr fix attr))) - - (unless attribute-obj - (raise-exception (make-exception - (make-exception-with-message - "Attribute not found") - (make-exception-with-irritants - (list fix attr))))) - - (let* ((atype (get-attr-type attribute-obj)) - (make-fade-func (make-fade-for-attribute-type atype))) - - (set-in-state! overlay-state fix attr - (make-fade-func start-val - target-val - attribute-clock))))))) - - (fix-attrs-involved pb this-cue-state)) + ;; FIXME: Use transition effect (atomically-overlay-state! pb overlay-state) (set-pb-cue-clock! pb cue-clock) @@ -616,146 +365,5 @@ *unspecified*) -;;; ******************** Cue lists ******************** - -(define-syntax cue-part - (syntax-rules () - ((_ (fixtures ...) params ...) - (make-cue-part-obj (list fixtures ...) - params ...)))) - - -(define* (make-cue-part-obj attr-list - #:key - (up-time 5) - (down-time 5) - (attr-time 0) - (up-delay 0) - (down-delay 0) - (attr-delay 0)) - (make-cue-part attr-list - (make-fade-times - up-time - down-time - attr-time - up-delay - down-delay - attr-delay))) - - -(define cue-proc - (lambda (number state . rest) - (receive (cue-parts rest-minus-cue-parts) - (partition cue-part? rest) - (let-keywords rest-minus-cue-parts #f - ((up-time 5) - (down-time 5) - (attr-time 0) - (up-delay 0) - (down-delay 0) - (attr-delay 0) - (preset-time 1) - (track-intensities #f)) - - (let ((the-cue (make-cue (qnum number) - state - #f ;; tracked state - #f ;; preset state - (make-fade-times - up-time - down-time - attr-time - up-delay - down-delay - attr-delay) - preset-time - track-intensities - cue-parts - (current-cue-clock)))) - - (set-clock-expiration-time! (current-cue-clock) - (cue-total-time the-cue)) - the-cue))))) - - -(define current-cue-clock (make-parameter #f)) - -(define-syntax cue - (syntax-rules () - ((_ body ...) - (parameterize ((current-cue-clock (make-clock #:stopped #t))) - (cue-proc body ...))))) - - -(define (track-all-cues! the-cue-list) - (vector-fold - (lambda (idx prev-state the-cue) - (let ((the-tracked-state (lighting-state - (apply-state prev-state) - (unless (track-intensities the-cue) - (blackout!)) - (apply-state (get-cue-state the-cue))))) - (set-tracked-state! the-cue the-tracked-state) - the-tracked-state)) - (make-empty-state) - the-cue-list)) - - -(define (fixture-dark-in-state? fix state) - (dark? (state-find fix 'intensity state))) - - -(define (preset-all-cues! the-cue-list) - (vector-fold-right - (lambda (idx next-state the-cue) - (let ((preset-state (make-empty-state))) - - (state-for-each - (lambda (fix attr val) - (unless (intensity? attr) - (when (fixture-dark-in-state? fix (get-tracked-state the-cue)) - (set-in-state! preset-state fix attr val)))) - next-state) - - (set-preset-state! the-cue preset-state)) - - ;; Pass the raw state from this cue to the previous one - (get-cue-state the-cue)) - - (make-empty-state) - the-cue-list)) - - -(define-method (update-state! (pb )) - (when (and (get-pb-cue-clock pb) - (clock-expired? (get-pb-cue-clock pb)) - (eq? 'running (atomic-box-ref (state-box pb)))) - (when (eq? 'running (atomic-box-compare-and-swap! (state-box pb) - 'running - 'ready)) - (run-hook (state-change-hook pb) 'ready) - (let ((st (get-preset-state (get-running-cue pb)))) - (state-for-each - (lambda (fix attr val) - (set-in-state! pb fix attr (lambda () val))) - st)) - (set-running-cue! pb #f)))) - - -(define-syntax cue-list - (syntax-rules () - ((_ body ...) - (let ((the-cue-list (vector (cue 0 - (make-empty-state) - #:up-time 0 - #:down-time 0 - #:attr-time 0 - #:preset-time 0) - body ...))) - (track-all-cues! the-cue-list) - (preset-all-cues! the-cue-list) - the-cue-list)))) - - (define (reassert-current-cue! pb) (cut-to-cue-number! pb (get-playback-cue-number pb))) -- cgit v1.2.3