Split 'base' module up into 'fixture', 'state' and 'scanout'

1 files changed, 258 insertions, 0 deletions

diff --git a/guile/starlet/scanout.scm b/guile/starlet/scanout.scm
new file mode 100644
index 0000000..3c9562a
--- /dev/null
+++ b/guile/starlet/scanout.scm
@@ -0,0 +1,258 @@
+;;
+;; starlet/scanout.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 scanout)
+  #:use-module (starlet fixture)
+  #:use-module (starlet state)
+  #:use-module (starlet utils)
+  #:use-module (starlet colours)
+  #: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 (start-ola-output
+            patch-fixture!
+            scanout-freq
+            register-state!
+            current-value))
+
+
+;; The list of patched fixtures
+(define fixtures (make-atomic-box '()))
+
+;; List of states being scanned out
+(define state-list (make-atomic-box '()))
+
+
+;; 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 ...)))))
+
+
+(define (state-has-fix-attr fix attr tnow state)
+  (let ((val (state-find fix attr state)))
+    (if (eq? 'no-value val)
+        #f
+        (not (eq? 'no-value (value->number val tnow))))))
+
+
+(define (first-val fix attr tnow state-list)
+  (let ((first-state (find (lambda (state)
+                             (state-has-fix-attr fix attr tnow state))
+                           state-list)))
+    (if first-state
+        (state-find fix attr first-state)
+        'no-value)))
+
+
+(define-method (current-value (fix <fixture>) (attr-name <symbol>) tnow)
+  (let  ((programmer-val (state-find fix attr-name programmer-state)))
+    (if (eq? 'no-value programmer-val)
+
+        ;; Look in the states
+        (if (intensity? attr-name)
+
+            ;; HTP for intensity
+            (fold (lambda (state prev)
+                    (let ((val (state-find fix attr-name state)))
+                      (if (eq? 'no-value val)
+                          prev
+                          (let ((real-val (value->number val tnow)))
+                            (if (eq? 'no-value real-val)
+                                prev
+                                (max real-val prev))))))
+                  0.0
+                  (atomic-box-ref state-list))
+
+            ;; Priority order for everything else
+            (let ((val (first-val fix attr-name tnow (atomic-box-ref state-list))))
+              (if (eq? 'no-value val)
+                  (get-attr-home-val fix attr-name)
+                  (value->number val tnow))))
+
+        ;; Use programmer value, if we have it
+        (value->number programmer-val tnow))))
+
+
+(define-method (current-value (fix <fixture>) (attr-name <colour-component-id>) tnow)
+  (let ((colour (current-value fix 'colour tnow)))
+    (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 (msb val)
+  (round-dmx (euclidean-quotient val 256)))
+
+(define (lsb val)
+  (round-dmx (euclidean-remainder val 256)))
+
+
+(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 (ensure-number value irritating)
+  (unless (number? value)
+    (raise-exception (make-exception
+                       (make-exception-with-message "Value is not a number")
+                       (make-exception-with-irritants irritating)))))
+
+
+(define scanout-freq 0)
+(define ola-thread #f)
+
+(define (scanout-loop ola-client start-time count previous-universes)
+
+  (let ((universes '()))
+
+    ;; Helper function for scanout functions to set individual DMX values
+    (define (set-dmx universe addr value)
+      (ensure-number value (list universe addr value))
+
+      ;; Create DMX array for universe if it doesn't exist already
+      (unless (assq universe universes)
+        (set! universes (acons universe
+                               (make-ola-dmx-buffer)
+                               universes)))
+
+      (set-ola-dmx-buffer! (assq-ref universes universe)
+                           (- addr 1)                   ; OLA indexing starts from zero
+                           (round-dmx value)))
+
+    (for-each
+      (lambda (fix)
+
+        (let ((univ (get-fixture-universe fix))
+              (addr (get-fixture-addr fix)))
+
+          ;; Helper function to get a value for this
+          ;; fixture in the current state
+          (define (get-attr attr-name)
+            (current-value fix attr-name (hirestime)))
+
+          ;; Helper function to set 8-bit DMX value
+          (define (set-chan relative-channel-number value)
+            (ensure-number value (list fix relative-channel-number value))
+            (set-dmx univ (+ addr relative-channel-number -1) value))
+
+          ;; Helper function to set 16-bit DMX value
+          (define (set-chan-16bit relative-channel-number value)
+            (ensure-number value (list fix relative-channel-number value))
+            (set-chan relative-channel-number (msb value))
+            (set-chan (+ relative-channel-number 1) (lsb value)))
+
+          (scanout-fixture fix get-attr set-chan set-chan-16bit)))
+
+      (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)
+  (unless ola-thread
+    (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))))))
+