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/crossfade.scm | 335 ++++++++++++++++++++++++++++ guile/starlet/cue-list.scm | 241 +++++++++++++++++++++ guile/starlet/playback.scm | 420 ++---------------------------------- guile/starlet/snap-transition.scm | 30 +++ guile/starlet/state.scm | 5 + guile/starlet/transition-effect.scm | 36 ++++ guile/starlet/utils.scm | 18 +- 7 files changed, 678 insertions(+), 407 deletions(-) create mode 100644 guile/starlet/crossfade.scm create mode 100644 guile/starlet/cue-list.scm create mode 100644 guile/starlet/snap-transition.scm create mode 100644 guile/starlet/transition-effect.scm diff --git a/guile/starlet/crossfade.scm b/guile/starlet/crossfade.scm new file mode 100644 index 0000000..4fe35d0 --- /dev/null +++ b/guile/starlet/crossfade.scm @@ -0,0 +1,335 @@ +;; +;; starlet/crossfade.scm +;; +;; Copyright © 2020-2021 Thomas White +;; +;; This file is part of Starlet. +;; +;; Starlet is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . +;; +(define-module (starlet crossfade) + #:use-module (oop goops) + #:use-module (starlet playback) + #:export (crossfade)) + + +(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)) + + +(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 + + ((fixture? attr-el) + (eq? attr-el fix)) + + ((and (pair? attr-el) + (fixture? (car attr-el)) + (symbol? (cdr attr-el))) + (and (eq? (car attr-el) fix) + (eq? (cdr attr-el) attr))) + + ((list? attr-el) + (and (memq fix attr-el) + (memq attr attr-el))) + + (else #f))) + + +(define (in-cue-part? cue-part fix attr) + (find (lambda (p) (match-fix-attr p fix attr)) + (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)))) + + +(define (fix-attrs-in-state state) + (state-map (lambda (fix attr val) (cons fix attr)) + state)) + + +(define (add-fix-attrs-to-list state old-list) + (lset-union fix-attr-eq + old-list + (fix-attrs-in-state state))) + + +(define (fix-attrs-involved . states) + (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)) + + (atomically-overlay-state! pb overlay-state) + (set-pb-cue-clock! pb cue-clock) + (set-running-cue! pb the-cue) + (reset-clock! cue-clock) + (start-clock! cue-clock) + (set-playback-state! pb 'running))) + diff --git a/guile/starlet/cue-list.scm b/guile/starlet/cue-list.scm new file mode 100644 index 0000000..74e7537 --- /dev/null +++ b/guile/starlet/cue-list.scm @@ -0,0 +1,241 @@ +;; +;; starlet/cue-list.scm +;; +;; Copyright © 2020-2021 Thomas White +;; +;; This file is part of Starlet. +;; +;; Starlet is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . +;; +(define-module (starlet cue-list) + #:use-module (oop goops) + #:use-module (ice-9 optargs) + #:use-module (ice-9 receive) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 atomic) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-43) + #:use-module (starlet fixture) + #:use-module (starlet state) + #:use-module (starlet clock) + #:use-module (starlet utils) + #:use-module (starlet transition-effect) + #:use-module (starlet snap-transition) + #:export (cue + cue-part + cue-list + cue-number-to-index + cue-index-to-number + current-cue-clock + read-cue-list-file) + #:re-export (snap)) + + +(define-record-type + (make-cue-part attr-list transition) + cue-part? + (attr-list get-cue-part-attr-list) + (transition get-cue-part-transition)) + + +(define-record-type + (make-cue number + state + tracked-state + preset-state + transition-effect + track-intensities + cue-parts + cue-clock) + cue? + (number get-cue-number) + (state get-cue-state) + (tracked-state get-tracked-state + set-tracked-state!) + (preset-state get-preset-state + set-preset-state!) + (transition-effect get-transition-effect) + (track-intensities track-intensities) + (cue-parts get-cue-parts) + (cue-clock get-cue-clock)) + + +(define (qnum a) + (/ (inexact->exact (* a 1000)) 1000)) + + +(define (cue-index-to-number cue-list cue-index) + (get-cue-number (vector-ref cue-list cue-index))) + + +(define (cue-number-to-index cue-list cue-number) + (vector-index (lambda (a) + (eqv? (get-cue-number a) + cue-number)) + cue-list)) + + +(define (match-fix-attr attr-el fix attr) + (cond + + ((fixture? attr-el) + (eq? attr-el fix)) + + ((and (pair? attr-el) + (fixture? (car attr-el)) + (symbol? (cdr attr-el))) + (and (eq? (car attr-el) fix) + (eq? (cdr attr-el) attr))) + + ((list? attr-el) + (and (memq fix attr-el) + (memq attr attr-el))) + + (else #f))) + + +(define (in-cue-part? cue-part fix attr) + (find (lambda (p) (match-fix-attr p fix attr)) + (get-cue-part-attr-list cue-part))) + + +(define (fix-attr-eq fa1 fa2) + (and (eq? (car fa1) (car fa2)) + (eq? (cdr fa1) (cdr fa2)))) + + +(define (fix-attrs-in-state state) + (state-map (lambda (fix attr val) (cons fix attr)) + state)) + + +(define (add-fix-attrs-to-list state old-list) + (lset-union fix-attr-eq + old-list + (fix-attrs-in-state state))) + + +(define-syntax cue-part + (syntax-rules () + ((_ (fixtures ...) params ...) + (make-cue-part-obj (list fixtures ...) + params ...)))) + + +;; FIXME! +(define (cue-total-time the-cue) + 100) + +(define (cue-proc number . args) + (receive + (states transition-effects cue-parts rest) + (categorize args lighting-state? transition-effect? cue-part?) + (let-keywords + rest + #f ;; allow-other-keys? + ((track-intensities #f)) + + (when (> (length states) 1) + (error "A cue can only contain one state")) + + (when (> (length transition-effects) 1) + (error "A cue can only contain one transition effect")) + + (let ((the-cue (make-cue (qnum number) + (car states) + #f ;; tracked state, to be filled later + #f ;; preset state, to be filled later + (car transition-effects) + 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 (dark? a) + (or (eq? a 'no-value) + (and (number? a) + (< a 1)))) + + +(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-syntax cue-list + (syntax-rules () + ((_ body ...) + (let ((the-cue-list (vector (cue 0 + (make-empty-state) + (snap)) + body ...))) + (track-all-cues! the-cue-list) + (preset-all-cues! the-cue-list) + the-cue-list)))) + + +(define (read-cue-list-file filename) + (call-with-input-file + filename + (lambda (port) + (eval (read port) (interaction-environment))))) 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))) diff --git a/guile/starlet/snap-transition.scm b/guile/starlet/snap-transition.scm new file mode 100644 index 0000000..c44a2ea --- /dev/null +++ b/guile/starlet/snap-transition.scm @@ -0,0 +1,30 @@ +;; +;; starlet/snap-transition.scm +;; +;; Copyright © 2021 Thomas White +;; +;; This file is part of Starlet. +;; +;; Starlet is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . +;; +(define-module (starlet snap-transition) + #:use-module (oop goops) + #:use-module (starlet playback) + #:use-module (starlet transition-effect) + #:export (snap)) + +(define (snap) + (make + #:func (lambda (incoming-state clock) + incoming-state))) diff --git a/guile/starlet/state.scm b/guile/starlet/state.scm index 6abd3c1..86e871e 100644 --- a/guile/starlet/state.scm +++ b/guile/starlet/state.scm @@ -30,6 +30,7 @@ #:use-module (srfi srfi-1) #:export ( make-empty-state + lighting-state? get-state-name state-for-each state-map @@ -70,6 +71,10 @@ #:getter get-update-hook)) +(define (lighting-state? a) + (is-a? a )) + + ;; The state used to build a new scene for recording (define programmer-state (make )) diff --git a/guile/starlet/transition-effect.scm b/guile/starlet/transition-effect.scm new file mode 100644 index 0000000..ad8290d --- /dev/null +++ b/guile/starlet/transition-effect.scm @@ -0,0 +1,36 @@ +;; +;; starlet/transition-effect.scm +;; +;; Copyright © 2021-2022 Thomas White +;; +;; This file is part of Starlet. +;; +;; Starlet is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . +;; +(define-module (starlet transition-effect) + #:use-module (oop goops) + #:export ( + transition-effect?)) + + +(define-class () + (func + #:init-value #f + #:init-keyword #:func + #:getter transition-func)) + + +(define (transition-effect? a) + (is-a? a )) + diff --git a/guile/starlet/utils.scm b/guile/starlet/utils.scm index 16e3364..2046a0a 100644 --- a/guile/starlet/utils.scm +++ b/guile/starlet/utils.scm @@ -20,13 +20,15 @@ ;; (define-module (starlet utils) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-8) #:export (print-hash-table copy-hash-table in-range mean flatten-sublists more-than-one - hirestime)) + hirestime + categorize)) (define (print-hash-table ht) @@ -83,3 +85,17 @@ (/ (cdr a) 1000000)))) + +(define (categorize-rec predicates items so-far) + (if (nil? predicates) + (reverse (cons items so-far)) + (receive + (selected-items remaining-items) + (partition (car predicates) items) + (categorize-rec (cdr predicates) + remaining-items + (cons selected-items so-far))))) + + +(define (categorize items . predicates) + (apply values (categorize-rec predicates items '()))) -- cgit v1.2.3