;; ;; starlet/crossfade.scm ;; ;; Copyright © 2020-2023 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 (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) #:use-module (ice-9 exceptions) #:use-module (starlet clock) #:use-module (starlet cue-part) #:use-module (starlet colours) #:use-module (starlet fixture) #:use-module (starlet state) #:use-module (starlet attributes) #: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 (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 (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* (crossfade-real incoming-state up-time #:optional (down-time up-time) #:key (attr-time (min up-time down-time)) (up-delay 0) (down-delay 0) (attr-delay 0)) (cue-part incoming-state (lambda (incoming-state current-state clock) (let ((up-clock (make-delayed-clock clock up-delay up-time)) (down-clock (make-delayed-clock clock down-delay down-time)) (attribute-clock (make-delayed-clock clock attr-delay attr-time))) (let ((overlay-state (make-empty-state))) (state-for-each (lambda (fixture attr target-val) (let ((start-val (fade-start-val current-state fixture attr))) (if (intensity? attr) ;; Intensity attribute (set-in-state! overlay-state fixture attr (make-intensity-fade start-val target-val up-clock down-clock)) ;; Non-intensity attribute (let ((attribute-obj (find-attr fixture attr))) (unless attribute-obj (raise-exception (make-exception (make-exception-with-message "Attribute not found") (make-exception-with-irritants (list fixture attr))))) (let* ((atype (get-attr-type attribute-obj)) (make-fade-func (make-fade-for-attribute-type atype))) (set-in-state! overlay-state fixture attr (make-fade-func start-val target-val attribute-clock))))))) incoming-state) (values overlay-state (max (+ up-time up-delay) (+ down-time down-delay) (+ attr-time attr-delay)))))))) ;; Rearrange the arguments to put the lighting state (last argument) ;; at the beginning. This makes optional arguments in crossfade-real possible. (define (crossfade . args) (apply crossfade-real (last args) (drop-right args 1)))