New scanout part 3: Split 'engine' from 'scanout'

4 files changed, 369 insertions, 214 deletions

diff --git a/guile/starlet/engine.scm b/guile/starlet/engine.scm
new file mode 100644
index 0000000..61a6014
--- /dev/null
+++ b/guile/starlet/engine.scm
@@ -0,0 +1,243 @@
+;;
+;; starlet/engine.scm
+;;
+;; Copyright © 2020-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 engine)
+  #:use-module (starlet fixture)
+  #:use-module (starlet state)
+  #:use-module (starlet utils)
+  #:use-module (starlet colours)
+  #:use-module (starlet attributes)
+  #:use-module (oop goops)
+  #:use-module (ice-9 threads)
+  #:use-module (ice-9 atomic)
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (srfi srfi-1)
+  #:export (patch-fixture!
+            patch-many!
+            engine-freq
+            total-num-attrs
+            register-state!
+            current-value
+            fixtures
+            patched-fixture-names))
+
+
+;; The list of patched fixtures
+(define fixtures (make-atomic-box '()))
+
+;; List of states being scanned out
+(define state-list (make-atomic-box '()))
+
+;; Association list of names to states
+(define state-names (make-atomic-box '()))
+
+;; Current values (literal, not functions) of active attributes
+(define current-values (make-atomic-box (make-empty-state)))
+
+
+(define (patched-fixture-names)
+  (map get-fixture-name (atomic-box-ref fixtures)))
+
+
+(define (total-num-attrs)
+  (fold (lambda (fix prev)
+          (+ prev (length (get-fixture-attrs fix))))
+        0
+        (atomic-box-ref fixtures)))
+
+
+(define (get-state-name st)
+  (assq-ref (atomic-box-ref state-names)
+            st))
+
+
+(define (set-state-name! st name)
+  (atomic-box-set! state-names
+                   (assq-set! (atomic-box-ref state-names)
+                              st
+                              name)))
+
+
+;; Patch a new fixture
+(define* (patch-real name
+                     class
+                     start-addr
+                     #:key (universe 0) (friendly-name "Fixture"))
+  (let ((new-fixture (make class
+                           #:name name
+                           #:sa start-addr
+                           #:uni universe
+                           #:friendly-name friendly-name)))
+    (atomic-box-set! fixtures (cons new-fixture
+                                    (atomic-box-ref fixtures)))
+    new-fixture))
+
+
+(define-syntax patch-fixture!
+  (syntax-rules ()
+    ((_ name stuff ...)
+     (define name (patch-real (quote name) stuff ...)))))
+
+
+;; Patch several new fixtures
+(define* (patch-many-real name
+                          class
+                          start-addrs
+                          #:key (universe 0) (friendly-name "Fixture"))
+  (map (lambda (start-addr n)
+         (patch-real `(list-ref ,name ,n)
+                     class
+                     start-addr
+                     #:universe universe
+                     #:friendly-name friendly-name))
+       start-addrs
+       (iota (length start-addrs))))
+
+
+(define-syntax patch-many!
+  (syntax-rules ()
+    ((_ name stuff ...)
+     (define name (patch-many-real (quote name) stuff ...)))))
+
+
+(define-method (current-value (fix <fixture>) (attr-name <starlet-attribute>))
+  (let ((v (state-find fix attr-name (atomic-box-ref current-values))))
+    (if (eq? v 'no-value)
+      (get-attr-home-val fix attr-name)
+      v)))
+
+
+(define-method (current-value (fix <fixture>) (attr-name <colour-component-id>))
+  (let ((colour (current-value fix 'colour)))
+    (extract-colour-component colour attr-name)))
+
+
+(define (append-or-replace-named-state orig-list name new-state)
+  (let ((new-list (map (lambda (st)
+                         (if (eq? (get-state-name st) name)
+                             (begin
+                               new-state)
+                             st))
+                       orig-list)))
+
+    ;; If there is no state with this name in the list,
+    ;; the replacement above will have no effect.
+    ;; Check again and add in the normal way if so.
+    (if (find (lambda (st) (eq? (get-state-name st)
+                                name))
+              new-list)
+        new-list
+        (append orig-list (list new-state)))))
+
+
+(define* (register-state! new-state
+                          #:key (unique-name #f))
+  (if unique-name
+      (begin (set-state-name! new-state unique-name)
+             (atomic-box-set! state-list
+                              (append-or-replace-named-state (atomic-box-ref state-list)
+                                                             unique-name
+                                                             new-state)))
+      (atomic-box-set! state-list
+                       (append (atomic-box-ref state-list)
+                               (list new-state)))))
+
+
+(define engine-freq 0)
+(define output-thread #f)
+
+
+(define (htp-attr? attr)
+  (eq? attr intensity))
+
+
+(define broadcast-socket
+  (socket PF_INET SOCK_DGRAM 0))
+
+
+(define (serialize-state st)
+  (call-with-output-bytevector
+    (lambda (port)
+      (write st port))))
+
+(define (broadcast-state st)
+  (atomic-box-swap! current-values st)
+  (sendto broadcast-socket
+          (serialize-state st)
+          (make-socket-address AF_INET INADDR_BROADCAST 5749)))
+
+
+(define (output-loop start-time count)
+
+  ;; Combine all the active attributes and send it out
+  (broadcast-state
+    (let ((states (atomic-box-ref state-list)))
+      (for-each update-state! states)
+      (fold
+        (lambda (incoming-state combined-state)
+          (state-for-each
+            (lambda (fix attr val)
+              (let ((incoming-val (value->number val))
+                    (current-val (state-find fix attr combined-state)))
+                (unless (eq? incoming-val 'no-value)
+                  (if (eq? current-val 'no-value)
+                    (set-in-state! combined-state fix attr incoming-val)
+                    (set-in-state! combined-state fix attr
+                                   (if (htp-attr? attr)
+                                     (max incoming-val current-val)
+                                     incoming-val))))))
+            incoming-state)
+          combined-state)
+        (make-empty-state)
+        (append states (list programmer-state)))))
+
+  (usleep 10000)
+
+  ;; Update output rate every 1000 cycles
+  (if (eq? count 100)
+    (begin
+      (set! engine-freq
+        (exact->inexact (/ 100
+                           (- (hirestime) start-time))))
+      (output-loop (hirestime) 0))
+    (output-loop start-time (+ count 1))))
+
+
+(define (start-output)
+  (setsockopt broadcast-socket SOL_SOCKET SO_BROADCAST 1)
+  (bind broadcast-socket AF_INET INADDR_LOOPBACK 0)
+  (if output-thread
+    (format #t "Output thread is already running\n")
+    (let ((start-time (hirestime)))
+      (set! output-thread
+        (begin-thread
+          (with-exception-handler
+            (lambda (exn)
+              (display "Error in output thread:\n")
+              (set! output-thread #f)
+              (backtrace)
+              (raise-exception exn))
+            (lambda ()
+              (output-loop start-time 0))
+            #:unwind? #f))))))
+
+
+(start-output)
diff --git a/guile/starlet/midi-control/faders.scm b/guile/starlet/midi-control/faders.scm
index 70cff66..aa8aacf 100644
--- a/guile/starlet/midi-control/faders.scm
+++ b/guile/starlet/midi-control/faders.scm
@@ -23,7 +23,7 @@
   #:use-module (starlet state)
   #:use-module (starlet fixture)
   #:use-module (starlet colours)
-  #:use-module (starlet scanout)
+  #:use-module (starlet engine)
   #:use-module (starlet utils)
   #:use-module (starlet attributes)
   #:use-module (srfi srfi-1)
diff --git a/guile/starlet/playback.scm b/guile/starlet/playback.scm
index 551c023..2d20137 100644
--- a/guile/starlet/playback.scm
+++ b/guile/starlet/playback.scm
@@ -30,7 +30,7 @@
   #:use-module (srfi srfi-43)
   #:use-module (starlet fixture)
   #:use-module (starlet state)
-  #:use-module (starlet scanout)
+  #:use-module (starlet engine)
   #:use-module (starlet utils)
   #:use-module (starlet clock)
   #:use-module (starlet cue-list)
diff --git a/guile/starlet/scanout.scm b/guile/starlet/scanout.scm
index 3d049ed..a18949d 100644
--- a/guile/starlet/scanout.scm
+++ b/guile/starlet/scanout.scm
@@ -22,225 +22,137 @@
   #:use-module (starlet fixture)
   #:use-module (starlet state)
   #:use-module (starlet utils)
-  #:use-module (starlet colours)
-  #:use-module (starlet attributes)
+  #:use-module (starlet engine)
   #:use-module (starlet guile-ola)
-  #:use-module (oop goops)
   #:use-module (ice-9 threads)
   #:use-module (ice-9 atomic)
   #:use-module (ice-9 exceptions)
-  #:use-module (ice-9 binary-ports)
   #:use-module (srfi srfi-1)
-  #:export (patch-fixture!
-            patch-many!
-            scanout-freq
-            total-num-attrs
-            register-state!
-            current-value
-            patched-fixture-names
-            get-attr
-            set-chan8
-            set-chan16))
+  #:export (start-ola-output
+             scanout-freq
+             get-attr
+             set-chan8
+             set-chan16))
 
 
-;; The list of patched fixtures
-(define fixtures (make-atomic-box '()))
-
-;; List of states being scanned out
-(define state-list (make-atomic-box '()))
-
-;; Association list of names to states
-(define state-names (make-atomic-box '()))
-
-;; Current values (literal, not functions) of active attributes
-(define current-values (make-atomic-box (make-empty-state)))
-
-
-(define (patched-fixture-names)
-  (map get-fixture-name (atomic-box-ref fixtures)))
-
-
-(define (total-num-attrs)
-  (fold (lambda (fix prev)
-          (+ prev (length (get-fixture-attrs fix))))
-        0
-        (atomic-box-ref fixtures)))
-
-
-(define (get-state-name st)
-  (assq-ref (atomic-box-ref state-names)
-            st))
-
-
-(define (set-state-name! st name)
-  (atomic-box-set! state-names
-                   (assq-set! (atomic-box-ref state-names)
-                              st
-                              name)))
-
-
-;; Patch a new fixture
-(define* (patch-real name
-                     class
-                     start-addr
-                     #:key (universe 0) (friendly-name "Fixture"))
-  (let ((new-fixture (make class
-                           #:name name
-                           #:sa start-addr
-                           #:uni universe
-                           #:friendly-name friendly-name)))
-    (atomic-box-set! fixtures (cons new-fixture
-                                    (atomic-box-ref fixtures)))
-    new-fixture))
-
-
-(define-syntax patch-fixture!
-  (syntax-rules ()
-    ((_ name stuff ...)
-     (define name (patch-real (quote name) stuff ...)))))
-
-
-;; Patch several new fixtures
-(define* (patch-many-real name
-                          class
-                          start-addrs
-                          #:key (universe 0) (friendly-name "Fixture"))
-  (map (lambda (start-addr n)
-         (patch-real `(list-ref ,name ,n)
-                     class
-                     start-addr
-                     #:universe universe
-                     #:friendly-name friendly-name))
-       start-addrs
-       (iota (length start-addrs))))
-
-
-(define-syntax patch-many!
-  (syntax-rules ()
-    ((_ name stuff ...)
-     (define name (patch-many-real (quote name) stuff ...)))))
-
-
-(define-method (current-value (fix <fixture>) (attr-name <starlet-attribute>))
-  (let ((v (state-find fix attr-name (atomic-box-ref current-values))))
-    (if (eq? v 'no-value)
-      (get-attr-home-val fix attr-name)
-      v)))
-
-
-(define-method (current-value (fix <fixture>) (attr-name <colour-component-id>))
-  (let ((colour (current-value fix 'colour)))
-    (extract-colour-component colour attr-name)))
-
-
-(define (append-or-replace-named-state orig-list name new-state)
-  (let ((new-list (map (lambda (st)
-                         (if (eq? (get-state-name st) name)
-                             (begin
-                               new-state)
-                             st))
-                       orig-list)))
-
-    ;; If there is no state with this name in the list,
-    ;; the replacement above will have no effect.
-    ;; Check again and add in the normal way if so.
-    (if (find (lambda (st) (eq? (get-state-name st)
-                                name))
-              new-list)
-        new-list
-        (append orig-list (list new-state)))))
-
-
-(define* (register-state! new-state
-                          #:key (unique-name #f))
-  (if unique-name
-      (begin (set-state-name! new-state unique-name)
-             (atomic-box-set! state-list
-                              (append-or-replace-named-state (atomic-box-ref state-list)
-                                                             unique-name
-                                                             new-state)))
-      (atomic-box-set! state-list
-                       (append (atomic-box-ref state-list)
-                               (list new-state)))))
+(define (send-to-ola ola-client universe-buffer-pair)
+  (let ((uni (car universe-buffer-pair))
+        (buf (cdr universe-buffer-pair)))
+  (send-streaming-dmx-data! ola-client uni buf)))
 
 
 (define scanout-freq 0)
-(define output-thread #f)
-
-
-(define (htp-attr? attr)
-  (eq? attr intensity))
-
-
-(define broadcast-socket
-  (socket PF_INET SOCK_DGRAM 0))
-
-
-(define (serialize-state st)
-  (call-with-output-bytevector
-    (lambda (port)
-      (write st port))))
-
-(define (broadcast-state st)
-  (atomic-box-swap! current-values st)
-  (sendto broadcast-socket
-          (serialize-state st)
-          (make-socket-address AF_INET INADDR_BROADCAST 5749)))
-
-
-(define (output-loop start-time count)
-
-  ;; Combine all the active attributes and send it out
-  (broadcast-state
-    (let ((states (atomic-box-ref state-list)))
-      (for-each update-state! states)
-      (fold
-        (lambda (incoming-state combined-state)
-          (state-for-each
-            (lambda (fix attr val)
-              (let ((incoming-val (value->number val))
-                    (current-val (state-find fix attr combined-state)))
-                (unless (eq? incoming-val 'no-value)
-                  (if (eq? current-val 'no-value)
-                    (set-in-state! combined-state fix attr incoming-val)
-                    (set-in-state! combined-state fix attr
-                                   (if (htp-attr? attr)
-                                     (max incoming-val current-val)
-                                     incoming-val))))))
-            incoming-state)
-          combined-state)
-        (make-empty-state)
-        (append states (list programmer-state)))))
-
-  (usleep 10000)
-
-  ;; Update output rate every 1000 cycles
-  (if (eq? count 100)
-    (begin
-      (set! scanout-freq
-        (exact->inexact (/ 100
-                           (- (hirestime) start-time))))
-      (output-loop (hirestime) 0))
-    (output-loop start-time (+ count 1))))
-
-
-(define (start-output)
-  (setsockopt broadcast-socket SOL_SOCKET SO_BROADCAST 1)
-  (bind broadcast-socket AF_INET INADDR_LOOPBACK 0)
-  (if output-thread
-    (format #t "Output thread is already running\n")
-    (let ((start-time (hirestime)))
-      (set! output-thread
-        (begin-thread
-          (with-exception-handler
-            (lambda (exn)
-              (display "Error in output thread:\n")
-              (set! output-thread #f)
-              (backtrace)
-              (raise-exception exn))
-            (lambda ()
-              (output-loop start-time 0))
-            #:unwind? #f))))))
-
-
-(start-output)
+(define ola-thread #f)
+(define current-scanout-fixture (make-parameter #f))
+(define current-scanout-universe (make-parameter #f))
+(define current-scanout-addr (make-parameter #f))
+
+
+(define (get-attr attr-name)
+  (current-value
+    (current-scanout-fixture)
+    attr-name))
+
+
+(define (set-dmx universe addr value)
+  (ensure-number value (list universe addr value))
+
+  ;; Create DMX array for universe if it doesn't exist already
+  (set-ola-dmx-buffer! universe
+                       (- addr 1)              ; OLA indexing starts from zero
+                       (round-dmx value)))
+
+
+(define (set-chan8 relative-channel-number value)
+  (ensure-number
+    value
+    (list (current-scanout-fixture)
+          relative-channel-number
+          value))
+  (set-dmx
+    (current-scanout-universe)
+    (+ (current-scanout-addr)
+       relative-channel-number
+       -1)
+    value))
+
+
+(define (set-chan16 relative-channel-number value)
+  (ensure-number
+    value
+    (list (current-scanout-fixture)
+          relative-channel-number
+          value))
+  (set-chan8 relative-channel-number (msb value))
+  (set-chan8 (+ relative-channel-number 1) (lsb value)))
+
+
+(define (scanout-loop ola-client start-time count previous-universes)
+
+  (let ((universes '()))
+
+    (for-each
+      (lambda (fix)
+
+        ;; Ensure the DMX array exists for this fixture's universe
+        (unless (assq (get-fixture-universe fix) universes)
+          (set! universes (acons (get-fixture-universe fix)
+                                 (make-ola-dmx-buffer)
+                                 universes)))
+
+        (parameterize
+          ((current-scanout-fixture fix)
+           (current-scanout-universe (assq-ref
+                                       universes
+                                       (get-fixture-universe fix)))
+           (current-scanout-addr (get-fixture-addr fix)))
+          (scanout-fixture fix)))
+      (atomic-box-ref fixtures))
+
+    ;; Send everything to OLA
+    (for-each (lambda (uni-buf-pair)
+                (let ((uni (car uni-buf-pair))
+                      (buf (cdr uni-buf-pair)))
+                  (let ((prev-buf (assv-ref previous-universes uni)))
+
+                    ;; Do not send exactly the same data every time,
+                    ;; but do send an update once every 100 loops, just to
+                    ;; make sure OLA does not forget about us.
+                    (unless (and prev-buf
+                                 (ola-dmx-buffers-equal? buf prev-buf)
+                                 (not (= count 0)))
+                      (send-streaming-dmx-data! ola-client uni buf)))))
+              universes)
+
+    (usleep 10000)
+
+    ;; Update scanout rate every 1000 cycles
+    (if (eq? count 100)
+      (begin
+        (set! scanout-freq
+          (exact->inexact (/ 100
+                             (- (hirestime) start-time))))
+        (scanout-loop ola-client (hirestime) 0 universes))
+      (scanout-loop ola-client start-time (+ count 1) universes))))
+
+
+(define (start-ola-output)
+  (if ola-thread
+      (format #t "OLA output already running\n")
+      (let* ((ola-client (make-ola-streaming-client))
+             (start-time (hirestime)))
+
+        (set! ola-thread
+          (begin-thread
+            (with-exception-handler
+              (lambda (exn)
+                (display "Error in OLA output thread:\n")
+                (set! ola-thread #f)
+                (backtrace)
+                (raise-exception exn))
+              (lambda ()
+                (scanout-loop ola-client start-time 0 '()))
+              #:unwind? #f))))))
+
+
+(start-ola-output)