Nicer scanout

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 <fixture-attribute> #: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 (<fixture> <fixture-attribute>
-             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 <fixture>
-                       #: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)