From 5e97aba9f9616a2b047dc2cb2ba81c9caa69c19d Mon Sep 17 00:00:00 2001 From: Thomas White Date: Sat, 6 Jun 2020 15:42:56 +0200 Subject: Nicer scanout --- guile/nanolight/fixture-library/generic.scm | 2 +- guile/nanolight/fixture.scm | 127 +++++++++++++++------------- guile/nanolight/state.scm | 36 ++++++-- 3 files changed, 98 insertions(+), 67 deletions(-) diff --git a/guile/nanolight/fixture-library/generic.scm b/guile/nanolight/fixture-library/generic.scm index 2117e75..ff497b3 100644 --- a/guile/nanolight/fixture-library/generic.scm +++ b/guile/nanolight/fixture-library/generic.scm @@ -9,5 +9,5 @@ (make #:name 'intensity #:range '(0 100) #:type 'continuous #:home-value 0 #:translator (lambda (universe start-addr value set-dmx) - (set-dmx universe start-addr 1 + (set-dmx universe start-addr (percent->dmxval value)))))) diff --git a/guile/nanolight/fixture.scm b/guile/nanolight/fixture.scm index 4a530f7..fbaecb2 100644 --- a/guile/nanolight/fixture.scm +++ b/guile/nanolight/fixture.scm @@ -1,13 +1,12 @@ (define-module (nanolight fixture) #:use-module (oop goops) - #:use-module (nanolight state) #:use-module (ice-9 threads) #:export ( - make-output - patch-fixture show-state - fixture-string get-address-string - percent->dmxval - get-start-addr get-universe)) + make-output patch-fixture + fixture-string fixture-address-string + percent->dmxval chan + get-start-addr get-universe + assign-attr!)) (use-modules (srfi srfi-1)) @@ -33,6 +32,12 @@ #:init-keyword #:home-value #:getter home-value) + (value-func + #:init-value (lambda () 0) + #:init-keyword #:value-func + #:getter value-func + #:setter set-value-func!) + (translator #:init-value (lambda (universe start-addr value set-dmx) #f) #:init-keyword #:translator @@ -62,30 +67,43 @@ #:init-value "Fixture" #:init-keyword #:friendly-name #:getter get-friendly-name - #:setter set-friendly-name!) + #:setter set-friendly-name!)) - (address-string - #:init-value #f - #:allocation #:virtual - #:getter get-address-string - #:slot-ref (lambda (a) - (string-append - (number->string (slot-ref a 'universe)) - "." - (number->string (slot-ref a 'start-addr)))) - #:slot-set! (lambda (a s) #f))) + +(define (find-attribute-by-name attr-list attr-name) + (find + (lambda (a) + (eq? (name a) attr-name)) + attr-list)) + + +;; Place an attribute of the physical lighting fixture +;; under the control of the given function +(define (assign-attr! fix attr-name value-func) + (set-value-func! + (find-attribute-by-name + (attributes fix) + attr-name) + value-func)) -(define (fixture-string fixture) +(define (fixture-address-string fix) (string-append - (get-friendly-name fixture) + (number->string (get-universe fix)) + "." + (number->string (get-start-addr fix)))) + + +(define (fixture-string fix) + (string-append + (get-friendly-name fix) " at " - (get-address-string fixture))) + (fixture-address-string fix))) (define (patch-fixture output attributes universe start-addr friendly-name) (let ((new-fixture (make - #:attributes attributes + #:attributes (copy-tree attributes) #:uni universe #:sa start-addr #:friendly-name friendly-name))) @@ -93,78 +111,71 @@ new-fixture)) -; FIXME: Clamp to range -(define (percent->dmxval val) - (/ (* 256 val) 100)) +(define (round-dmx a) + (min 255 (max 0 (round a)))) -(define (show-state output state) - (output 'show-state state)) +(define (percent->dmxval val) + (round-dmx (/ (* 256 val) 100))) -(define (find-attribute fix attr) - (find (lambda (a) - (eq? (name a) attr)) - (attributes fix))) +(define (chan channel start-addr) + (- (+ channel start-addr) 1)) -(define (round-dmx a) - (min 255 (max 0 (round a)))) (define (make-output) - - (let ((fixtures '()) - (current-state '())) + (let ((fixtures '())) (define (run-scanout) - (let ((universes '())) - (define (set-dmx universe addr nbytes value) - ; FIXME: 16 bit values + ;; Helper function called by attribute translators + ;; to set individual DMX values + (define (set-dmx universe addr value) + + ;; Create DMX array for universe if it doesn't exist already (unless (assq universe universes) (set! universes (acons universe (make-u8vector 512 0) universes))) + + ;; Set the value in the DMX array (u8vector-set! (assq-ref universes universe) addr (round-dmx value))) - (define (execute-state-assignment state-assignment) - (let ((attr (find-attribute - (fixture state-assignment) - (attribute state-assignment)))) - (when attr - (let ((trans (translator attr))) - (trans - (get-universe (fixture state-assignment)) - (get-start-addr (fixture state-assignment)) - ((value-func state-assignment)) - set-dmx))))) + (define (run-translator fix attr set-dmx) + (let ((trans (translator attr))) + (trans + (get-universe fix) + (get-start-addr fix) + ((value-func attr)) + set-dmx))) + ;; Scan out all fixtures + (for-each (lambda (fix) - (for-each execute-state-assignment current-state) + ;; Scan out one fixture + (for-each (lambda (attr) + (run-translator fix attr set-dmx)) + (attributes fix))) - (display universes) - (display "\r")) + fixtures)) (yield) (run-scanout)) - ; Start sending output + ;; Start sending output (make-thread run-scanout) - ; Method functions - (define (show-state state) - (set! current-state state)) - + ;; Method functions (define (add-fixture fixture) (set! fixtures (cons fixture fixtures))) (lambda args (apply (case (car args) - ((show-state) show-state) ((add-fixture) add-fixture) (else => (error "Invalid method"))) (cdr args))))) diff --git a/guile/nanolight/state.scm b/guile/nanolight/state.scm index 405a19c..8237d6e 100644 --- a/guile/nanolight/state.scm +++ b/guile/nanolight/state.scm @@ -1,6 +1,6 @@ (define-module (nanolight state) #:use-module (oop goops) - #:export (print-state define-state + #:export (print-state define-state exec-state merge-states merge-rule-htp merge-rule-ltp merge-htp merge-ltp int flash pan tilt @@ -97,16 +97,36 @@ '() (apply append list-of-states))) -(define (compare-addr a b) - (or - (< (get-universe (fixture a)) (get-universe (fixture b))) - (and - (eq? (get-universe (fixture a)) (get-universe (fixture b))) - (< (get-start-addr (fixture a)) (get-start-addr (fixture b)))))) +(define (find-attribute fix attr) + (find (lambda (a) + (eq? (name a) attr)) + (attributes fix))) + + +; Execute the state, i.e. apply it to the physical lighting rig +(define (exec-state state) + (for-each + (lambda (a) + (assign-attr! + (fixture a) + (attribute a) + (value-func a))) + state)) (define (sort-by-dmx-addr state) - (stable-sort state compare-addr)) + (stable-sort state (lambda (a b) + (or + (< + (get-universe (fixture a)) + (get-universe (fixture b))) + (and + (eq? + (get-universe (fixture a)) + (get-universe (fixture b))) + (< + (get-start-addr (fixture a)) + (get-start-addr (fixture b)))))))) (define (print-state st) -- cgit v1.2.3