diff options
author | Thomas White <taw@physics.org> | 2022-05-06 16:27:41 +0200 |
---|---|---|
committer | Thomas White <taw@physics.org> | 2022-05-06 16:36:09 +0200 |
commit | 4552ce9ecb3e49f1c54a52fd41375b2f9c40c9e8 (patch) | |
tree | 58037d7402f5c168d404c0a0620dcfa93fcaee4a /guile/starlet/scanout.scm | |
parent | 43d00c233d4bda38bc5882e7fe1ca2f37837fef2 (diff) |
define-fixture: Eliminate need to provide names for get-attr etc
This needed some rearranging, but I think the resulting code is a little
bit more efficient.
Diffstat (limited to 'guile/starlet/scanout.scm')
-rw-r--r-- | guile/starlet/scanout.scm | 94 |
1 files changed, 61 insertions, 33 deletions
diff --git a/guile/starlet/scanout.scm b/guile/starlet/scanout.scm index 43c2cf0..8cea49a 100644 --- a/guile/starlet/scanout.scm +++ b/guile/starlet/scanout.scm @@ -35,7 +35,11 @@ total-num-attrs register-state! current-value - patched-fixture-names)) + patched-fixture-names + get-attr + set-chan8 + set-chan16 + scanout-fixture)) ;; The list of patched fixtures @@ -47,6 +51,9 @@ ;; Association list of names to states (define state-names (make-atomic-box '())) +;; Method for scanning out fixtures +(define-generic scanout-fixture) + (define (patched-fixture-names) (map get-fixture-name (atomic-box-ref fixtures))) @@ -202,51 +209,72 @@ (define scanout-freq 0) (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 (scanout-loop ola-client start-time count previous-universes) - (let ((universes '())) +(define (get-attr attr-name) + (current-value + (current-scanout-fixture) + attr-name)) - ;; 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))) +(define (set-dmx universe addr value) + (ensure-number value (list universe addr value)) - (set-ola-dmx-buffer! (assq-ref universes universe) - (- addr 1) ; OLA indexing starts from zero - (round-dmx 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))) - (for-each update-state! (atomic-box-ref state-list)) - (for-each - (lambda (fix) +(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)) - (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)) +(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))) - ;; 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))) +(define (scanout-loop ola-client start-time count previous-universes) - (scanout-fixture fix get-attr set-chan set-chan-16bit))) + (let ((universes '())) + + (for-each update-state! (atomic-box-ref state-list)) + + (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 |