diff options
author | Thomas White <taw@physics.org> | 2020-07-21 17:02:21 +0200 |
---|---|---|
committer | Thomas White <taw@physics.org> | 2020-07-21 17:02:21 +0200 |
commit | 701abb86f5cd8088e1a8be69c4459479782c4b15 (patch) | |
tree | 38d9d0a025421843bd490e67476e8b5595efcf27 /guile |
Initial import (basic fixture patching/attributes)
Diffstat (limited to 'guile')
-rw-r--r-- | guile/dsil/fixture-library/generic.scm | 16 | ||||
-rw-r--r-- | guile/dsil/fixture.scm | 207 | ||||
-rw-r--r-- | guile/guile-midi/control.scm | 101 |
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))))) |