diff options
Diffstat (limited to 'guile/starlet/scanout.scm')
| -rw-r--r-- | guile/starlet/scanout.scm | 201 |
1 files changed, 5 insertions, 196 deletions
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) |