From c51d80b3411d482286b8ecd4da407ab59563233e Mon Sep 17 00:00:00 2001
From: Thomas White <taw@bitwiz.me.uk>
Date: Fri, 5 Jun 2020 10:41:11 +0200
Subject: WIP

---
 guile/nanolight/fixture-library/robe.scm | 38 ++++++++++++++++++++++++++++++++
 guile/nanolight/fixture.scm              | 22 +++++-------------
 guile/nanolight/state.scm                | 11 ++++++++-
 3 files changed, 53 insertions(+), 18 deletions(-)
 create mode 100644 guile/nanolight/fixture-library/robe.scm

(limited to 'guile')

diff --git a/guile/nanolight/fixture-library/robe.scm b/guile/nanolight/fixture-library/robe.scm
new file mode 100644
index 0000000..dcdd30b
--- /dev/null
+++ b/guile/nanolight/fixture-library/robe.scm
@@ -0,0 +1,38 @@
+(define-module (nanolight fixture-library robe)
+  #:use-module (oop goops)
+  #:use-module (nanolight fixture)
+  #:export (robe-dl7s-profile-mode1))
+
+
+(define (robe-dl7s-profile-mode1)
+  (list
+
+    (make <fixture-attribute> #:name 'pan
+      #:range '(0 540) #:type 'continuous #:home-value 270
+      #:translator (lambda (universe start-addr value set-dmx)
+                     (set-dmx universe (+ 0 start-addr) 2
+                       (percent->dmxval value))))
+
+    (make <fixture-attribute> #:name 'tilt
+      #:range '(0 270) #:type 'continuous #:home-value 135
+      #:translator (lambda (universe start-addr value set-dmx)
+                     (set-dmx universe (+ 2 start-addr) 2
+                       (percent->dmxval value))))
+
+    (make <fixture-attribute> #:name 'strobe
+      #:range '(#f #t) #:type 'step #:home-value #f
+      #:translator (lambda (universe start-addr value set-dmx)
+                     (set-dmx universe (+ 48 start-addr) 1
+                       (if value 95 32))))
+
+    (make <fixture-attribute> #:name 'intensity
+      #:range '(0 100) #:type 'continuous #:home-value 0
+      #:translator (lambda (universe start-addr value set-dmx)
+                     (set-dmx universe (+ 49 start-addr) 2
+                       (percent->dmxval value))))
+
+    (make <fixture-attribute> #:name 'prism
+      #:range '(#f #t) #:type 'step #:home-value #f
+      #:translator (lambda (universe start-addr value set-dmx)
+                     (set-dmx universe (+ 27 start-addr) 1
+                       (if value 50 0))))))
diff --git a/guile/nanolight/fixture.scm b/guile/nanolight/fixture.scm
index 4a530f7..df4b168 100644
--- a/guile/nanolight/fixture.scm
+++ b/guile/nanolight/fixture.scm
@@ -1,10 +1,9 @@
 (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
+             patch-fixture
              fixture-string get-address-string
              percent->dmxval
              get-start-addr get-universe))
@@ -112,8 +111,7 @@
 
 (define (make-output)
 
-  (let ((fixtures '())
-        (current-state '()))
+  (let ((fixtures '()))
 
     (define (run-scanout)
 
@@ -128,19 +126,13 @@
                               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)))
+            addr (round-dmx value)
+
                 (trans
                   (get-universe (fixture state-assignment))
                   (get-start-addr (fixture state-assignment))
                   ((value-func state-assignment))
-                  set-dmx)))))
+                  set-dmx)))
 
 
         (for-each execute-state-assignment current-state)
@@ -155,16 +147,12 @@
     (make-thread run-scanout)
 
     ; Method functions
-    (define (show-state state)
-      (set! current-state state))
-
     (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..bddff72 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 show-state
              merge-states merge-rule-htp merge-rule-ltp
              merge-htp merge-ltp
              int flash pan tilt
@@ -97,6 +97,15 @@
     '() (apply append list-of-states)))
 
 
+(define (show-state state)
+  (for-each (lambda (a)
+              (set-value-func!
+               (let ((attr (find-attribute)
+                        (fixture state-assignment)
+                        (attribute state-assignment))))))
+            (when attr
+              (let ((trans (translator attr)))))))
+
 (define (compare-addr a b)
   (or
     (< (get-universe (fixture a)) (get-universe (fixture b)))
-- 
cgit v1.2.3