From 5f1f79c6d3fa853786bd10fe075780143ed76559 Mon Sep 17 00:00:00 2001
From: Thomas White <taw@physics.org>
Date: Mon, 24 May 2021 16:12:50 +0200
Subject: Add hook for state changes on a playback

---
 guile/starlet/playback.scm | 24 ++++++++++++++++++++++--
 guile/starlet/scanout.scm  |  2 ++
 guile/starlet/state.scm    |  8 +++++++-
 3 files changed, 31 insertions(+), 3 deletions(-)

diff --git a/guile/starlet/playback.scm b/guile/starlet/playback.scm
index 96e52c3..7a83cfd 100644
--- a/guile/starlet/playback.scm
+++ b/guile/starlet/playback.scm
@@ -23,6 +23,7 @@
   #: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-43)
@@ -65,6 +66,10 @@
     #:getter get-cue-clock
     #:setter set-cue-clock!)
 
+  (current-state
+    #:init-form (make-atomic-box 'ready)
+    #:getter state-box)
+
   (state-change-hook
     #:init-form (make-hook 1)
     #:getter state-change-hook))
@@ -146,6 +151,7 @@
     (clear-state! pb)
     (set-next-cue-index! pb (+ cue-index 1))
     (set-cue-clock! pb #f)
+    (atomic-box-set! (state-box  pb) 'ready)
     (run-hook (state-change-hook pb) 'ready)
     (let ((cue-state (calculate-tracking cue-list cue-index)))
       (state-for-each
@@ -195,7 +201,8 @@
 
         ;; Restart paused cue
         (begin (start-clock! clock)
-               (run-hook (state-change-hook pb) 'ready))
+               (atomic-box-set! (state-box pb) 'running)
+               (run-hook (state-change-hook pb) 'running))
 
         ;; Run next cue
         (let ((next-cue-index (get-next-cue-index pb)))
@@ -212,6 +219,7 @@
     (when (and clock
                (not (clock-expired? clock)))
       (stop-clock! (get-cue-clock pb))
+      (atomic-box-set! (state-box pb) 'pause)
       (run-hook (state-change-hook pb) 'pause))))
 
 
@@ -219,6 +227,7 @@
   (let ((prev-cue-index (- (get-next-cue-index pb) 2)))
     (if (>= prev-cue-index 0)
         (begin (cut-to-cue-index! pb prev-cue-index)
+               (atomic-box-set! (state-box pb) 'ready)
                (run-hook (state-change-hook pb) 'ready))
         'already-at-cue-zero)))
 
@@ -566,7 +575,8 @@
 
     (atomically-overlay-state! pb overlay-state)
     (set-cue-clock! pb cue-clock)
-    (run-hook (state-change-hook pb) 'ready)))
+    (atomic-box-set! (state-box pb) 'running)
+    (run-hook (state-change-hook pb) 'running)))
 
 
 (define (print-playback pb)
@@ -672,6 +682,16 @@
                 (current-state)))))))
 
 
+(define-method (update-state! (pb <starlet-playback>))
+  (when (and (get-cue-clock pb)
+             (clock-expired? (get-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))))
+
+
 (define-syntax cue-list
   (syntax-rules ()
     ((_ body ...)
diff --git a/guile/starlet/scanout.scm b/guile/starlet/scanout.scm
index 70698d4..4d38f0f 100644
--- a/guile/starlet/scanout.scm
+++ b/guile/starlet/scanout.scm
@@ -208,6 +208,8 @@
                            (- addr 1)                   ; OLA indexing starts from zero
                            (round-dmx value)))
 
+    (for-each update-state! (atomic-box-ref state-list))
+
     (for-each
       (lambda (fix)
 
diff --git a/guile/starlet/state.scm b/guile/starlet/state.scm
index 35db6bd..a9aa6b4 100644
--- a/guile/starlet/state.scm
+++ b/guile/starlet/state.scm
@@ -50,7 +50,8 @@
             sel
             selection-hook
             value->number
-            atomically-overlay-state!))
+            atomically-overlay-state!
+            update-state!))
 
 
 ;; A "state" is an atomically-updating container for an immutable
@@ -83,6 +84,11 @@
         col)))
 
 
+(define-method (update-state! (state <starlet-state>))
+  ;; Basic state object needs no updates
+  #f)
+
+
 (define-method (set-in-state! (state <starlet-state>)
                               (fix <fixture>)
                               (attr <colour-component-id>)
-- 
cgit v1.2.3