Separate cue lists from playbacks and crossfades

7 files changed, 678 insertions, 407 deletions

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 <taw@bitwiz.org.uk>
+;;
+;; 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 <http://www.gnu.org/licenses/>.
+;;
+(define-module (starlet crossfade)
+  #:use-module (oop goops)
+  #:use-module (starlet playback)
+  #:export (crossfade))
+
+
+(define-record-type <fade-times>
+  (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 <taw@bitwiz.org.uk>
+;;
+;; 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 <http://www.gnu.org/licenses/>.
+;;
+(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 <cue-part>
+  (make-cue-part attr-list transition)
+  cue-part?
+  (attr-list    get-cue-part-attr-list)
+  (transition   get-cue-part-transition))
+
+
+(define-record-type <cue>
+  (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 <transition-effect> (<object>)
+  (func
+    #:init-value #f))
+
+
+(define (transition-effect? a)
+  (is-a? a <transition-effect>))
+
+
 (define-record-type <cue-part>
-  (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 <fade-times>
-  (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 <cue>
@@ -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 <starlet-playback>))
-  (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 <taw@bitwiz.org.uk>
+;;
+;; 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 <http://www.gnu.org/licenses/>.
+;;
+(define-module (starlet snap-transition)
+  #:use-module (oop goops)
+  #:use-module (starlet playback)
+  #:use-module (starlet transition-effect)
+  #:export (snap))
+
+(define (snap)
+  (make <transition-effect>
+        #: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 (<starlet-state>
             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 <starlet-state>))
+
+
 ;; The state used to build a new scene for recording
 (define programmer-state (make <starlet-state>))
 
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 <taw@bitwiz.org.uk>
+;;
+;; 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 <http://www.gnu.org/licenses/>.
+;;
+(define-module (starlet transition-effect)
+  #:use-module (oop goops)
+  #:export (<transition-effect>
+             transition-effect?))
+
+
+(define-class <transition-effect> (<object>)
+  (func
+    #:init-value #f
+    #:init-keyword #:func
+    #:getter transition-func))
+
+
+(define (transition-effect? a)
+  (is-a? a <transition-effect>))
+
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 '())))