From 746b0c880ce786ba6ceb900228abbab0eed1dd54 Mon Sep 17 00:00:00 2001
From: Thomas White <taw@physics.org>
Date: Tue, 16 Jun 2020 22:45:04 +0200
Subject: Move fixture names to separate namespace

---
 guile/nanolight/fixture.scm | 75 ++++++++++++++++++++++++++++-----------------
 1 file 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
-- 
cgit v1.2.3