Separate 'engine' and 'scanout'

The new module "engine" contains everything to do with working out the
final attribute values.  This module should be referenced for anything
that needs to register states, get values etc.

Now, "scanout" is only about converting attribute values to DMX values
and sending them to OLA.  This module only needs to be referenced by
fixture definitions, and once by the top level program.

4 files changed, 235 insertions, 198 deletions

diff --git a/guile/starlet/engine.scm b/guile/starlet/engine.scm
new file mode 100644
index 0000000..2bf99f2
--- /dev/null
+++ b/guile/starlet/engine.scm
@@ -0,0 +1,228 @@
+;;
+;; starlet/engine.scm
+;;
+;; Copyright © 2020-2023 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 (srfi srfi-1)
+  #:export (patch-fixture!
+            patch-many!
+            engine-freq
+            total-num-attrs
+            register-state!
+            current-value
+            patched-fixture-names
+            patched-fixtures))
+
+
+;; 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 (patched-fixtures)
+  (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-thread #f)
+(define engine-freq 0)
+
+
+(define (htp-attr? attr)
+  (eq? attr intensity))
+
+
+(define (engine-loop start-time count)
+
+  ;; Combine all the active attributes and send it out
+  (atomic-box-swap! current-values
+    (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))))
+      (engine-loop (hirestime) 0))
+    (engine-loop start-time (+ count 1))))
+
+
+(define (start-engine)
+  (if engine-thread
+    (format #t "Engine thread is already running\n")
+    (let ((start-time (hirestime)))
+      (set! engine-thread
+        (begin-thread
+          (with-exception-handler
+            (lambda (exn)
+              (display "Error in engine thread:\n")
+              (set! engine-thread #f)
+              (backtrace)
+              (raise-exception exn))
+            (lambda ()
+              (engine-loop start-time 0))
+            #:unwind? #f))))))
+
+
+(start-engine)
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 2a8952a..e0d1133 100644
--- a/guile/starlet/scanout.scm
+++ b/guile/starlet/scanout.scm
@@ -1,7 +1,7 @@
 ;;
 ;; starlet/scanout.scm
 ;;
-;; Copyright © 2020-2022 Thomas White <taw@bitwiz.org.uk>
+;; Copyright © 2020-2023 Thomas White <taw@bitwiz.org.uk>
 ;;
 ;; This file is part of Starlet.
 ;;
@@ -19,154 +19,22 @@
 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 ;;
 (define-module (starlet scanout)
+  #:use-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 (starlet guile-ola)
-  #:use-module (oop goops)
   #:use-module (ice-9 threads)
   #:use-module (ice-9 atomic)
   #:use-module (ice-9 exceptions)
-  #:use-module (srfi srfi-1)
-  #:export (patch-fixture!
-            patch-many!
-            engine-freq
-            scanout-freq
-            total-num-attrs
-            register-state!
-            current-value
-            patched-fixture-names
+  #:export (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 engine-thread #f)
-(define engine-freq 0)
-
 (define scanout-thread #f)
 (define scanout-freq 0)
 
@@ -174,6 +42,7 @@
 (define current-scanout-universe (make-parameter #f))
 (define current-scanout-addr (make-parameter #f))
 
+
 (define (get-attr attr-name)
   (current-value
     (current-scanout-fixture)
@@ -213,46 +82,6 @@
   (set-chan8 (+ relative-channel-number 1) (lsb value)))
 
 
-(define (htp-attr? attr)
-  (eq? attr intensity))
-
-
-(define (engine-loop start-time count)
-
-  ;; Combine all the active attributes and send it out
-  (atomic-box-swap! current-values
-    (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))))
-      (engine-loop (hirestime) 0))
-    (engine-loop start-time (+ count 1))))
-
-
 (define (scanout-loop ola-client start-time previous-universes count)
 
   (let ((universes '()))
@@ -274,7 +103,7 @@
            (current-scanout-addr (get-fixture-addr fix)))
           (scanout-fixture fix)))
 
-      (atomic-box-ref fixtures))
+      (patched-fixtures))
 
     (for-each
       (lambda (uni-buf-pair)
@@ -303,25 +132,6 @@
       (scanout-loop ola-client start-time universes (+ count 1)))))
 
 
-
-
-(define (start-engine)
-  (if engine-thread
-    (format #t "Engine thread is already running\n")
-    (let ((start-time (hirestime)))
-      (set! engine-thread
-        (begin-thread
-          (with-exception-handler
-            (lambda (exn)
-              (display "Error in engine thread:\n")
-              (set! engine-thread #f)
-              (backtrace)
-              (raise-exception exn))
-            (lambda ()
-              (engine-loop start-time 0))
-            #:unwind? #f))))))
-
-
 (define (start-scanout)
   (if scanout-thread
     (format #t "Scanout thread is already running\n")
@@ -340,5 +150,4 @@
             #:unwind? #f))))))
 
 
-(start-engine)
 (start-scanout)