From dda44b52d0566ece360d4647398bcb01677d6912 Mon Sep 17 00:00:00 2001
From: Thomas White <taw@bitwiz.me.uk>
Date: Thu, 4 Jun 2020 21:30:31 +0200
Subject: Scanout plumbing

---
 guile/nanolight/fixture.scm | 91 +++++++++++++++++++++++++++++++--------------
 guile/nanolight/state.scm   |  3 +-
 2 files changed, 66 insertions(+), 28 deletions(-)

diff --git a/guile/nanolight/fixture.scm b/guile/nanolight/fixture.scm
index 6eb3c29..4a530f7 100644
--- a/guile/nanolight/fixture.scm
+++ b/guile/nanolight/fixture.scm
@@ -1,5 +1,6 @@
 (define-module (nanolight fixture)
   #:use-module (oop goops)
+  #:use-module (nanolight state)
   #:use-module (ice-9 threads)
   #:export (<fixture> <fixture-attribute>
              make-output
@@ -8,6 +9,7 @@
              percent->dmxval
              get-start-addr get-universe))
 
+(use-modules (srfi srfi-1))
 
 (define-class <fixture-attribute> (<object>)
 
@@ -16,28 +18,33 @@
     #:init-keyword #:name
     #:getter name)
 
-  (offset
-    #:init-value 0
-    #:init-keyword #:offset
-    #:getter offset)
+  (range
+    #:init-value '()
+    #:init-keyword #:range
+    #:getter range)
 
-  (continuous
-    #:init-value #t
-    #:init-keyword #:continuous
-    #:getter continuous)
+  (type
+    #:init-value 'continuous
+    #:init-keyword #:type
+    #:getter type)
 
-  (steps
-    #:init-value '()
-    #:init-keyword #:steps
-    #:getter steps
-    #:setter set-steps!))
+  (home-value
+    #:init-value 0
+    #:init-keyword #:home-value
+    #:getter home-value)
+
+  (translator
+    #:init-value (lambda (universe start-addr value set-dmx) #f)
+    #:init-keyword #:translator
+    #:getter translator))
 
 
 (define-class <fixture> (<object>)
 
   (attributes
     #:init-value '()
-    #:init-keyword #:attributes)
+    #:init-keyword #:attributes
+    #:getter attributes)
 
   (universe
     #:init-value #f
@@ -94,32 +101,62 @@
 (define (show-state output state)
   (output 'show-state state))
 
+(define (find-attribute fix attr)
+  (find (lambda (a)
+          (eq? (name a) attr))
+    (attributes fix)))
 
-(define (scanout fixture-list)
-
-  (define (set-dmx universe addr nbytes value)
-    #f)
-
-  (define (scanout-fixture fixture)
-    #f)
-
-  (for-each scanout-fixture fixture-list))
 
+(define (round-dmx a)
+  (min 255 (max 0 (round a))))
 
 (define (make-output)
 
-  ; List of all patched fixtures (for scanout)
-  (let ((fixtures '()))
+  (let ((fixtures '())
+        (current-state '()))
 
     (define (run-scanout)
-      (scanout fixtures)
+
+      (let ((universes '()))
+
+        (define (set-dmx universe addr nbytes value)
+          ; FIXME: 16 bit values
+          (unless (assq universe universes)
+            (set! universes (acons
+                              universe
+                              (make-u8vector 512 0)
+                              universes)))
+          (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)))))
+
+
+        (for-each execute-state-assignment current-state)
+
+        (display universes)
+        (display "\r"))
+
       (yield)
       (run-scanout))
 
+    ; Start sending output
     (make-thread run-scanout)
 
+    ; Method functions
     (define (show-state state)
-      (display "Applying state:\n"))
+      (set! current-state state))
 
     (define (add-fixture fixture)
       (set! fixtures (cons fixture fixtures)))
diff --git a/guile/nanolight/state.scm b/guile/nanolight/state.scm
index a005685..405a19c 100644
--- a/guile/nanolight/state.scm
+++ b/guile/nanolight/state.scm
@@ -3,7 +3,8 @@
   #:export (print-state define-state
              merge-states merge-rule-htp merge-rule-ltp
              merge-htp merge-ltp
-             int flash pan tilt))
+             int flash pan tilt
+             fixture attribute value-func))
 
 (use-modules (nanolight fixture))
 (use-modules (srfi srfi-1))
-- 
cgit v1.2.3