summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorThomas White <taw@physics.org>2020-06-16 22:45:04 +0200
committerThomas White <taw@physics.org>2020-06-16 22:45:04 +0200
commit746b0c880ce786ba6ceb900228abbab0eed1dd54 (patch)
treef1bfb31adac4a6b6630d812406a1c8fccf0a3535
parentb8fa20d37144dac18174e45aeeffd203f921e1e3 (diff)
Move fixture names to separate namespace
-rw-r--r--guile/nanolight/fixture.scm75
1 files changed, 47 insertions, 28 deletions
diff --git a/guile/nanolight/fixture.scm b/guile/nanolight/fixture.scm
index 81dabcc..b3f1395 100644
--- a/guile/nanolight/fixture.scm
+++ b/guile/nanolight/fixture.scm
@@ -5,7 +5,7 @@
#:use-module (web http)
#:use-module (web uri)
#:export (<fixture> <fixture-attribute>
- make-output patch-fixture patch-many
+ patch-fixture patch-many
fixture-string fixture-address-string
percent->dmxval msb lsb chan
start-addr universe
@@ -52,27 +52,44 @@
(attributes
#:init-value '()
#:init-keyword #:attributes
- #:getter attributes)
+ #:getter get-attributes)
(universe
#:init-value #f
#:init-keyword #:uni
- #:getter universe
+ #:getter get-universe
#:setter set-universe!)
(start-addr
#:init-value #f
#:init-keyword #:sa
- #:getter start-addr
+ #:getter get-start-addr
#:setter set-start-addr!)
(friendly-name
#:init-value "Fixture"
#:init-keyword #:friendly-name
- #:getter friendly-name
+ #:getter get-friendly-name
#:setter set-friendly-name!))
+;; Association list of fixtures
+(define fixtures '())
+
+
+(define (universe fixture-name)
+ (get-universe (assq-ref fixtures fixture-name)))
+
+(define (start-addr fixture-name)
+ (get-start-addr (assq-ref fixtures fixture-name)))
+
+(define (friendly-name fixture-name)
+ (get-friendly-name (assq-ref fixtures fixture-name)))
+
+(define (attributes fixture-name)
+ (get-attributes (assq-ref fixtures fixture-name)))
+
+
(define (find-attribute-by-name attr-list attr-name)
(find
(lambda (a)
@@ -82,10 +99,10 @@
;; Place an attribute of the physical lighting fixture
;; under the control of the given function
-(define (assign-attr! fix attr-name value-func)
+(define (assign-attr! fix-name attr-name value-func)
(set-value-func!
(find-attribute-by-name
- (attributes fix)
+ (attributes fix-name)
attr-name)
value-func))
@@ -111,17 +128,21 @@
(define (home-all-attributes fix)
(for-each home-attribute
- (attributes fix)))
+ (get-attributes fix)))
-(define (patch-fixture output attributes universe start-addr friendly-name)
+(define output #f)
+
+(define (patch-fixture fixture-name attributes universe start-addr friendly-name)
(let ((new-fixture (make <fixture>
#:attributes (copy-tree attributes)
#:uni universe
#:sa start-addr
#:friendly-name friendly-name)))
(home-all-attributes new-fixture)
- (output 'add-fixture new-fixture)
+ (unless output
+ (set! output (make-output)))
+ (output 'add-fixture fixture-name new-fixture)
new-fixture))
@@ -164,15 +185,12 @@
"&d="
(bytevec->string (cdr universe)))))
-
(define (make-output)
- (letrec* (
- (fixtures '())
- (ola-uri (build-uri 'http
- #:host "127.0.0.1"
- #:port 9090
- #:path "/set_dmx"))
- (ola-socket (open-socket-for-uri ola-uri)))
+ (letrec* ((ola-uri (build-uri 'http
+ #:host "127.0.0.1"
+ #:port 9090
+ #:path "/set_dmx"))
+ (ola-socket (open-socket-for-uri ola-uri)))
(define (run-scanout)
(let ((universes '()))
@@ -193,16 +211,17 @@
(round-dmx value)))
;; Scan out all fixtures
- (for-each (lambda (fix)
+ (for-each (lambda (fix-assoc-entry)
;; Scan out one fixture
- (for-each (lambda (attr)
- (let ((trans (translator attr)))
- (trans (universe fix)
- (start-addr fix)
- ((value-func attr))
- set-dmx)))
- (attributes fix)))
+ (let ((fix (cdr fix-assoc-entry)))
+ (for-each (lambda (attr)
+ (let ((trans (translator attr)))
+ (trans (get-universe fix)
+ (get-start-addr fix)
+ ((value-func attr))
+ set-dmx)))
+ (get-attributes fix))))
fixtures)
@@ -220,8 +239,8 @@
(make-thread run-scanout)
;; Method functions
- (define (add-fixture fixture)
- (set! fixtures (cons fixture fixtures)))
+ (define (add-fixture fixture fixture-name)
+ (set! fixtures (acons fixture fixture-name fixtures)))
(lambda args
(apply