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 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 335 insertions(+) create mode 100644 guile/starlet/crossfade.scm (limited to 'guile/starlet/crossfade.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))) + -- cgit v1.2.3