Initial import (basic fixture patching/attributes)

3 files changed, 324 insertions, 0 deletions

diff --git a/guile/dsil/fixture-library/generic.scm b/guile/dsil/fixture-library/generic.scm
new file mode 100644
index 0000000..4670f11
--- /dev/null
+++ b/guile/dsil/fixture-library/generic.scm
@@ -0,0 +1,16 @@
+(define-module (dsil fixture-library generic)
+  #:use-module (oop goops)
+  #:use-module (dsil fixture)
+  #:export (<generic-dimmer>))
+
+(define-class <generic-dimmer> (<fixture>)
+
+  (attributes
+   #:init-form
+   (list
+
+    (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
+                                  (percent->dmxval value)))))))
diff --git a/guile/dsil/fixture.scm b/guile/dsil/fixture.scm
new file mode 100644
index 0000000..f1216ae
--- /dev/null
+++ b/guile/dsil/fixture.scm
@@ -0,0 +1,207 @@
+(define-module (dsil fixture)
+  #:use-module (oop goops)
+  #:use-module (ice-9 threads)
+  #:use-module (ice-9 atomic)
+  #:use-module (web client)
+  #:use-module (web http)
+  #:use-module (web uri)
+  #:export (<fixture> <fixture-attribute>
+             start-ola-output patch-fixture
+             set-attr!
+             percent->dmxval msb lsb chan))
+
+(use-modules (srfi srfi-1))
+
+(define-class <fixture-attribute> (<object>)
+
+  (name
+    #:init-value 'unnamed-attribute
+    #:init-keyword #:name
+    #:getter get-attr-name)
+
+  (range
+    #:init-value '()
+    #:init-keyword #:range
+    #:getter get-attr-range)
+
+  (translator
+    #:init-value (lambda (universe start-addr value set-dmx) #f)
+    #:init-keyword #:translator
+    #:getter get-attr-translator)
+
+  (type
+    #:init-value 'continuous
+    #:init-keyword #:type
+    #:getter get-attr-type)
+
+  (home-value
+    #:init-value 0
+    #:init-keyword #:home-value
+    #:getter get-attr-home-value
+    #:setter set-attr-home-value!)
+
+  (value
+    #:init-value 0
+    #:getter get-attr-value
+    #:setter set-attr-value!))
+
+
+(define-class <fixture> (<object>)
+
+  (universe
+    #:init-value #f
+    #:init-keyword #:uni
+    #:getter get-fixture-universe
+    #:setter set-fixture-universe!)
+
+  (start-addr
+    #:init-value #f
+    #:init-keyword #:sa
+    #:getter get-fixture-addr
+    #:setter set-fixture-addr!)
+
+  (friendly-name
+    #:init-value "Fixture"
+    #:init-keyword #:friendly-name
+    #:getter get-fixture-friendly-name
+    #:setter set-fixture-friendly-name!))
+
+
+;; List of fixtures
+(define patched-fixture-list (make-atomic-box '()))
+
+
+(define (get-attributes fix)
+  (slot-ref fix 'attributes))
+
+
+;; Set a single attribute to home position
+(define (home-attr! attr)
+  (set-attr-value! attr
+                   (get-attr-home-value attr)))
+
+
+;; Set all attributes of a fixture to home position
+(define (home-all! fix)
+  (for-each home-attr!
+            (get-attributes fix)))
+
+
+(define (find-attr fix attr-name)
+  (find (lambda (a)
+          (eq? (get-attr-name a)
+               attr-name))
+        (get-attributes fix)))
+
+
+(define (set-attr! fix attr-name value)
+  (let ((attr (find-attr fix attr-name)))
+    (when attr (set-attr-value! attr value))))
+
+
+(define* (patch-fixture class
+                        start-addr
+                        #:key (universe 1) (friendly-name "Fixture"))
+  (let ((new-fixture (make class
+                       #:sa start-addr
+                       #:uni universe
+                       #:friendly-name friendly-name)))
+    (home-all! new-fixture)
+    (atomic-box-set! patched-fixture-list
+                     (cons new-fixture
+                           (atomic-box-ref patched-fixture-list)))
+    new-fixture))
+
+
+;; Helper functions for attribute translators
+(define (round-dmx a)
+  (min 255 (max 0 (round a))))
+
+(define (percent->dmxval val)
+  (round-dmx (/ (* 256 val) 100)))
+
+(define (msb val)
+  (round-dmx (/ val 256)))
+
+(define (lsb val)
+  (round-dmx (logand (round val) #b11111111)))
+
+(define (chan channel start-addr)
+  (- (+ channel start-addr) 1))
+
+
+;; Scanout
+
+(define (bytevec->string bv)
+  (string-join
+    (map
+      number->string
+      (u8vector->list bv))
+    ","))
+
+
+(define (send-to-ola ola-uri ola-socket universe)
+  (http-post
+    ola-uri
+    #:port ola-socket
+    #:keep-alive? #t
+    #:headers (acons 'content-type
+                     (parse-header 'content-type
+                                   "application/x-www-form-urlencoded")
+                     '())
+    #:body (string-append "u="
+                          (number->string (car universe))
+                          "&d="
+                          (bytevec->string (cdr universe)))))
+
+(define (start-ola-output)
+  (letrec* ((ola-uri (build-uri 'http
+                                #:host "127.0.0.1"
+                                #:port 9090
+                                #:path "/set_dmx"))
+            (ola-socket (open-socket-for-uri ola-uri)))
+
+    (begin-thread
+     (let scanout-loop ()
+
+        (let ((universes '()))
+
+
+          ;; 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 1)                   ; u8vector-set indexing starts from zero
+                           (round-dmx value)))
+
+          ;; Scan out all fixtures
+          (for-each (lambda (fix)
+
+                      ;; Scan out one fixture
+                      (for-each (lambda (attr)
+
+                                  ;; Scan out one attribute
+                                  (let ((trans (get-attr-translator attr)))
+                                    (trans (get-fixture-universe fix)
+                                           (get-fixture-addr fix)
+                                           (get-attr-value attr)
+                                           set-dmx)))
+                                (get-attributes fix)))
+
+                    (atomic-box-ref patched-fixture-list))
+
+          ;; Send everything to OLA
+          (for-each (lambda (a)
+                      (send-to-ola ola-uri ola-socket a))
+                    universes))
+
+        (yield)
+        (scanout-loop)))))
diff --git a/guile/guile-midi/control.scm b/guile/guile-midi/control.scm
new file mode 100644
index 0000000..fc7d4c2
--- /dev/null
+++ b/guile/guile-midi/control.scm
@@ -0,0 +1,101 @@
+(define-module (guile-midi control)
+  #:use-module (ice-9 threads)
+  #:use-module (ice-9 binary-ports)
+  #:export (make-midi-port
+            midi-cc-value
+            send-midi-note))
+
+
+(define (make-midi-port device-name listen-channel)
+
+  (let ((cc-vals (make-array 0 128))
+        (midi-port (open-file device-name "r+0b")))
+
+
+    ;; Send a note off command
+    (define (send-noteoff note)
+      (put-u8 midi-port
+              (+ #b10000000 listen-channel))
+      (put-u8 midi-port note)
+      (put-u8 midi-port 0))
+
+
+    ;; Send a note on command
+    (define (send-note note velocity)
+      (put-u8 midi-port
+              (+ #b10010000 listen-channel))
+      (put-u8 midi-port note)
+      (put-u8 midi-port velocity))
+
+
+    ;; Get a CC value
+    (define (get-cc-value controller-number)
+      (array-ref cc-vals
+                 controller-number))
+
+
+    (define (run-midi)
+
+        (let again ()
+          (letrec* ((status-byte (get-u8 midi-port))
+                    (channel (bit-extract status-byte 0 4))
+                    (command (bit-extract status-byte 4 8)))
+
+            (when (eq? channel listen-channel)
+              (case command
+
+                ;; Note on
+                ((9) (let ((note (get-u8 midi-port))
+                           (vel (get-u8 midi-port)))
+                       (display "Note = ")
+                       (display (number->string note 16))
+                       (display " velocity = ")
+                       (display vel)
+                       (newline)))
+
+                ;; Control value
+                ((11) (let* ((controller-number (get-u8 midi-port))
+                             (value (get-u8 midi-port)))
+                        (array-set! cc-vals
+                                    value
+                                    controller-number)))))
+
+
+            (again))))
+
+    ;; Clear out any LEDs by first sending note-on with velocity zero
+    (for-each (lambda (n)
+                (send-note n 0))
+              (iota 128 0))
+
+    ;; ... and subsequently sending note-off
+    (for-each (lambda (n)
+                (send-noteoff n))
+              (iota 128 0))
+
+    (make-thread run-midi)
+
+    (lambda args
+      (apply
+       (case (car args)
+         ((get-cc-value) get-cc-value)
+         ((send-note) send-note))
+       (cdr args)))))
+
+
+(define-syntax midi-cc-value
+  (lambda (x)
+    (syntax-case x ()
+      ((_ port controller-number)
+       #'(port 'get-cc-value controller-number)))))
+
+
+(define-syntax send-midi-note
+  (lambda (x)
+    (syntax-case x ()
+
+      ((_ port note velocity)
+       #'(port 'send-note note velocity))
+
+      ((_ port note)
+       #'(port 'send-note note 127)))))