summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorThomas White <taw@bitwiz.me.uk>2020-06-05 10:41:11 +0200
committerThomas White <taw@bitwiz.me.uk>2020-06-05 10:41:23 +0200
commitc51d80b3411d482286b8ecd4da407ab59563233e (patch)
tree00b62c330c5680a4131c2a537d4302412e5307b7
parentdda44b52d0566ece360d4647398bcb01677d6912 (diff)
WIPtemp
-rw-r--r--examples/demo.scm62
-rw-r--r--guile/nanolight/fixture-library/robe.scm38
-rw-r--r--guile/nanolight/fixture.scm22
-rw-r--r--guile/nanolight/state.scm11
4 files changed, 115 insertions, 18 deletions
diff --git a/examples/demo.scm b/examples/demo.scm
new file mode 100644
index 0000000..72eadbb
--- /dev/null
+++ b/examples/demo.scm
@@ -0,0 +1,62 @@
+(add-to-load-path "/home/taw/nanolight/guile")
+
+(use-modules
+ (nanolight fixture)
+ (nanolight fixture-library generic)
+ (nanolight fixture-library robe)
+ (nanolight state)
+ (ice-9 textual-ports))
+
+(define output (make-output))
+
+(define mh1 (patch-fixture output (robe-dl7s-profile-mode1) 1 1 "Robe DL7S"))
+(define mh2 (patch-fixture output (robe-dl7s-profile-mode1) 1 52 "Robe DL7S"))
+(define mh3 (patch-fixture output (robe-dl7s-profile-mode1) 1 103 "Robe DL7S"))
+(define mh4 (patch-fixture output (robe-dl7s-profile-mode1) 1 154 "Robe DL7S"))
+
+(define dim1 (patch-fixture output (generic-dimmer) 1 256 "Dimmer"))
+(define dim2 (patch-fixture output (generic-dimmer) 1 257 "Dimmer"))
+(define dim3 (patch-fixture output (generic-dimmer) 1 258 "Dimmer"))
+(define dim4 (patch-fixture output (generic-dimmer) 1 259 "Dimmer"))
+(define dim5 (patch-fixture output (generic-dimmer) 1 260 "Dimmer"))
+(define dim6 (patch-fixture output (generic-dimmer) 1 261 "Dimmer"))
+
+(define-state exstate
+ (flash 2 mh1)
+ (int 0 mh2)
+ (int (+ 30 30) mh3)
+ (int 32 mh4)
+ (int 50 dim1)
+ (int 12 dim2))
+
+(print-state exstate)
+(show-state output exstate)
+
+; (def-cue lx5.7
+; (xf 'up 10 'down 5 example-state))
+
+(display "Press enter to continue\n")
+(get-char (current-input-port))
+
+(define-state exstate2
+ exstate
+ (int 100 mh1)
+ (int 0 mh4))
+
+(print-state exstate2)
+(show-state output exstate2)
+
+(display "Press enter to continue\n")
+(get-char (current-input-port))
+
+(define-state exstate3
+ (merge-ltp
+ exstate
+ (int 5 mh1)
+ (int 5 mh4)))
+
+(print-state exstate3)
+(show-state output exstate3)
+
+(display "Press enter to continue\n")
+(get-char (current-input-port))
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)))