From ff6ad474320d2a51d440043d4cc2904bafbedce5 Mon Sep 17 00:00:00 2001 From: Thomas White Date: Sat, 19 Nov 2022 12:18:11 +0100 Subject: New scanout part 3: Split 'engine' from 'scanout' --- guile/starlet/engine.scm | 243 ++++++++++++++++++++++++ guile/starlet/midi-control/faders.scm | 2 +- guile/starlet/playback.scm | 2 +- guile/starlet/scanout.scm | 336 +++++++++++++--------------------- 4 files changed, 369 insertions(+), 214 deletions(-) create mode 100644 guile/starlet/engine.scm 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 +;; +;; 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 . +;; +(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 ) (attr-name )) + (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 ) (attr-name )) + (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 ) (attr-name )) - (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 ) (attr-name )) - (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) -- cgit v1.2.3