diff options
Diffstat (limited to 'guile')
-rw-r--r-- | guile/starlet/midi-control/base.scm | 320 | ||||
-rw-r--r-- | guile/starlet/midi-control/button-utils.scm | 36 | ||||
-rw-r--r-- | guile/starlet/midi-control/faders.scm | 132 |
3 files changed, 227 insertions, 261 deletions
diff --git a/guile/starlet/midi-control/base.scm b/guile/starlet/midi-control/base.scm index f0947aa..08310ae 100644 --- a/guile/starlet/midi-control/base.scm +++ b/guile/starlet/midi-control/base.scm @@ -25,7 +25,7 @@ #:use-module (ice-9 exceptions) #:use-module (ice-9 binary-ports) #:use-module (srfi srfi-1) - #:export (start-midi-control + #:export (make-midi-controller get-cc-value ccval->percent percent->ccval @@ -36,21 +36,30 @@ remove-midi-callback!)) -(define cc-arrays (make-atomic-box '())) -(define callback-list (make-atomic-box '())) -(define send-queue (make-atomic-box '())) +(define-class <midi-control-surface> (<object>) + (cc-values + #:init-form (make-vector 128 #f) + #:getter get-cc-values) + (channel + #:init-form (error "MIDI channel must be specified for controller") + #:init-keyword #:channel + #:getter get-channel) + + (callbacks + #:init-form (make-atomic-box '()) + #:getter get-callbacks) + + (send-queue + #:init-form (make-atomic-box '()) + #:getter get-send-queue)) -(define-class <midi-callback> (<object>) +(define-class <midi-callback> (<object>) (type #:init-keyword #:type #:getter get-type) - (channel - #:init-keyword #:channel - #:getter get-channel) - (note-or-cc-number #:init-keyword #:note-or-cc-number #:getter get-note-or-cc-number) @@ -59,137 +68,127 @@ #:init-keyword #:func #:getter get-callback-func)) -(define (find-cc-callbacks channel cc-number) + +(define (find-cc-callbacks controller cc-number) (filter (lambda (a) (and (eq? cc-number (get-note-or-cc-number a)) - (eq? channel (get-channel a)) (eq? 'cc (get-type a)))) - (atomic-box-ref callback-list))) + (atomic-box-ref (get-callbacks controller)))) -(define (find-note-callbacks channel note-number) +(define (find-note-callbacks controller note-number) (filter (lambda (a) (and (eq? note-number (get-note-or-cc-number a)) - (eq? channel (get-channel a)) (eq? 'note (get-type a)))) - (atomic-box-ref callback-list))) + (atomic-box-ref (get-callbacks controller)))) -(define (remove-midi-callback! callback) - (atomic-box-set! callback-list - (delq callback - (atomic-box-ref callback-list)))) +(define (remove-midi-callback! controller callback) + (when controller + (atomic-box-set! (get-callbacks controller) + (delq callback + (atomic-box-ref (get-callbacks controller)))))) -(define (register-midi-callback! type - channel +(define (register-midi-callback! controller + type note-or-cc-number func) (let ((new-callback (make <midi-callback> - #:type type - #:channel (if channel channel default-channel) - #:note-or-cc-number note-or-cc-number - #:func func))) - (atomic-box-set! callback-list - (cons new-callback - (atomic-box-ref callback-list))) + #:type type + #:note-or-cc-number note-or-cc-number + #:func func))) + (let ((callback-list-box (get-callbacks controller))) + (atomic-box-set! callback-list-box + (cons new-callback + (atomic-box-ref callback-list-box)))) new-callback)) (define* (register-midi-note-callback! - #:key (channel #f) (note-number 1) (func #f) (unique #t)) - (when unique - (for-each remove-midi-callback! (find-note-callbacks - (if channel channel default-channel) - note-number))) - (register-midi-callback! 'note channel note-number func)) + controller + #:key (note-number 1) (func #f) (unique #t)) + (when controller + (when unique + (for-each (lambda (callback) + (remove-midi-callback! controller callback)) + (find-note-callbacks + controller + note-number))) + (register-midi-callback! controller 'note note-number func))) (define* (register-midi-cc-callback! - #:key (channel #f) (cc-number 1) (func #f) (unique #t)) - (when unique - (for-each remove-midi-callback! (find-cc-callbacks - (if channel channel default-channel) - cc-number))) - (register-midi-callback! 'cc channel cc-number func)) + controller + #:key (cc-number 1) (func #f) (unique #t)) + (when controller + (when unique + (for-each (lambda (callback) + (remove-midi-callback! controller callback)) + (find-cc-callbacks + controller + cc-number))) + (register-midi-callback! controller 'cc cc-number func))) (define enqueue-midi-bytes! - (lambda bytes - (let* ((old-queue (atomic-box-ref send-queue)) + (lambda (controller . bytes) + (let* ((send-queue (get-send-queue controller)) + (old-queue (atomic-box-ref send-queue)) (new-queue (append old-queue bytes))) (unless (eq? (atomic-box-compare-and-swap! send-queue old-queue new-queue) old-queue) - (apply enqueue-midi-bytes! bytes))))) + (apply enqueue-midi-bytes! (cons controller bytes)))))) -(define* (send-note-on note - #:key (channel #f)) - (when note - (enqueue-midi-bytes! (+ #b10010000 - (if channel channel default-channel)) +(define* (send-note-on controller note) + (when (and controller note) + (enqueue-midi-bytes! controller + (+ #b10010000 (get-channel controller)) note 127))) -(define* (send-note-off note - #:key (channel #f)) - (when note - (enqueue-midi-bytes! (+ #b10000000 - (if channel channel default-channel)) +(define* (send-note-off controller note) + (when (and controller note) + (enqueue-midi-bytes! controller + (+ #b10000000 (get-channel controller)) note 0))) -(define (all-notes-off! channel) - (let again ((l 0)) - (enqueue-midi-bytes! (+ #b10000000 channel) l 0) - (unless (= l 127) - (again (+ l 1))))) +(define (all-notes-off! controller) + (for-each (lambda (l) + (enqueue-midi-bytes! controller + (+ #b10000000 (get-channel controller)) + l + 0)) + (iota 128))) -(define (ensure-cc-array channel) - (let ((old-list (atomic-box-ref cc-arrays))) - (unless (assq channel old-list) - (unless (eq? - old-list - (atomic-box-compare-and-swap! cc-arrays - old-list - (acons channel - (make-vector 128 #f) - old-list))) - ;; CAS failed - try again - (ensure-cc-array channel))))) - - -(define (check-cc-callbacks channel cc-number old-val new-val) +(define (check-cc-callbacks controller cc-number old-val new-val) (for-each (lambda (a) ((get-callback-func a) old-val new-val)) - (find-cc-callbacks channel cc-number))) + (find-cc-callbacks controller cc-number))) -(define (handle-cc-change! channel cc-number value) - (ensure-cc-array channel) - (let* ((cc-array (assq-ref (atomic-box-ref cc-arrays) channel)) - (old-value (vector-ref cc-array cc-number))) - (vector-set! cc-array cc-number value) - (check-cc-callbacks channel cc-number old-value value))) +(define (handle-cc-change! controller cc-number value) + (let* ((ccvals (get-cc-values controller)) + (old-value (vector-ref ccvals cc-number))) + (vector-set! ccvals cc-number value) + (check-cc-callbacks controller cc-number old-value value))) -(define* (get-cc-value cc-number - #:key (channel #f)) - (let ((cc-arrays (atomic-box-ref cc-arrays))) - (let ((ccs (assq-ref cc-arrays - (if channel channel default-channel)))) - (if ccs - (vector-ref ccs cc-number) - #f)))) +(define* (get-cc-value controller cc-number) + (if controller + (vector-ref (get-cc-values controller) cc-number) + #f)) -(define (check-note-callbacks channel note-number) +(define (check-note-callbacks controller note-number) (for-each (lambda (a) ((get-callback-func a))) - (find-note-callbacks channel note-number))) + (find-note-callbacks controller note-number))) (define (ccval->percent n) @@ -200,87 +199,68 @@ (inexact->exact (round (/ (* n 127) 100)))) -(define default-channel 0) - -(define (start-midi-control-real device-name channel) - (let ((midi-port (open-file device-name "r+0b"))) - - ;; Read thread - (begin-thread - (with-exception-handler - (lambda (exn) - (backtrace) - (raise-exception exn)) - (lambda () - (let again () - - (let* ((status-byte (get-u8 midi-port)) - (channel (bit-extract status-byte 0 4)) - (command (bit-extract status-byte 4 8))) - - (case command - - ;; Note on - ((9) (let* ((note (get-u8 midi-port)) - (vel (get-u8 midi-port))) - (check-note-callbacks channel note))) - - ;; Control value - ((11) (let* ((cc-number (get-u8 midi-port)) - (value (get-u8 midi-port))) - (handle-cc-change! channel - cc-number - value)))) - - (yield) - (again)))))) - - ;; Write thread - (begin-thread - (let again () - (let ((bytes-to-send (atomic-box-swap! send-queue '()))) - (for-each (lambda (a) - (put-u8 midi-port a) - (usleep 1)) - bytes-to-send) - (usleep 1000) - (again)))) - - (all-notes-off! default-channel))) - - -(define midi-running #f) - -(define (start-dummy-midi) - (display "Using dummy MIDI control\n") - (begin-thread - (let again () - (let ((bytes-to-send (atomic-box-swap! send-queue '()))) - (usleep 1000) - (again)))) - (set! midi-running #t)) - -(define* (start-midi-control device-name - #:key (channel #f)) - - - (if midi-running - - (format #t "MIDI already running\n") - - (begin - (when channel - (set! default-channel channel)) +(define (make-midi-controller-real device-name channel) + (let ((controller (make <midi-control-surface> + #:channel channel))) + (let ((midi-port (open-file device-name "r+0b"))) + ;; Read thread + (begin-thread (with-exception-handler - (lambda (exn) - (format #t "Couldn't start MIDI ~a\n" - (exception-irritants exn)) - (start-dummy-midi)) - + (backtrace) + (raise-exception exn)) (lambda () - (start-midi-control-real device-name channel) - (set! midi-running #t)) - - #:unwind? #t)))) + (let again () + + (let* ((status-byte (get-u8 midi-port)) + (channel (bit-extract status-byte 0 4)) + (command (bit-extract status-byte 4 8))) + + (case command + + ;; Note on + ((9) (let* ((note (get-u8 midi-port)) + (vel (get-u8 midi-port))) + (check-note-callbacks controller note))) + + ;; Control value + ((11) (let* ((cc-number (get-u8 midi-port)) + (value (get-u8 midi-port))) + (handle-cc-change! controller + cc-number + value)))) + + (yield) + (again)))))) + + ;; Write thread + (begin-thread + (let again () + (let ((bytes-to-send + (atomic-box-swap! + (get-send-queue controller) + '()))) + (for-each (lambda (a) + (put-u8 midi-port a) + (usleep 1)) + bytes-to-send) + (usleep 1000) + (again)))) + + (all-notes-off! controller) + controller))) + + +(define* (make-midi-controller device-name channel) + (with-exception-handler + + (lambda (exn) + (format #t "Couldn't start MIDI ~a\n" + (exception-irritants exn)) + #f) + + (lambda () + (make-midi-controller-real device-name channel)) + + #:unwind? #t)) diff --git a/guile/starlet/midi-control/button-utils.scm b/guile/starlet/midi-control/button-utils.scm index 449a164..8462e3e 100644 --- a/guile/starlet/midi-control/button-utils.scm +++ b/guile/starlet/midi-control/button-utils.scm @@ -28,13 +28,12 @@ select-on-button)) -(define* (make-go-button pb button +(define* (make-go-button controller pb button #:key - (channel #f) (ready-note #f) (pause-note #f)) (register-midi-note-callback! - #:channel channel + controller #:note-number button #:func (lambda () (go! pb))) @@ -44,21 +43,20 @@ (lambda (new-state) (cond ((eq? new-state 'pause) - (send-note-on pause-note)) + (send-note-on controller pause-note)) ((eq? new-state 'ready) - (send-note-on ready-note)) + (send-note-on controller ready-note)) ((eq? new-state 'running) - (send-note-on ready-note)) + (send-note-on controller ready-note)) (else - (send-note-off ready-note))))))) + (send-note-off controller ready-note))))))) -(define* (make-stop-button pb button +(define* (make-stop-button controller pb button #:key - (channel #f) (ready-note #f)) (register-midi-note-callback! - #:channel channel + controller #:note-number button #:func (lambda () (stop! pb))) @@ -67,31 +65,29 @@ (state-change-hook pb) (lambda (new-state) (if (eq? new-state 'running) - (send-note-on ready-note) - (send-note-off ready-note)))))) + (send-note-on controller ready-note) + (send-note-off controller ready-note)))))) -(define* (make-back-button pb button +(define* (make-back-button controller pb button #:key - (channel #f) (ready-note #f)) (register-midi-note-callback! - #:channel channel + controller #:note-number button #:func (lambda () (back! pb))) (when ready-note - (send-note-on ready-note))) + (send-note-on controller ready-note))) -(define* (select-on-button button fixture +(define* (select-on-button controller button fixture #:key - (channel #f) (ready-note #f)) (register-midi-note-callback! - #:channel channel + controller #:note-number button #:func (lambda () (sel fixture))) (when ready-note - (send-note-on ready-note))) + (send-note-on controller ready-note))) diff --git a/guile/starlet/midi-control/faders.scm b/guile/starlet/midi-control/faders.scm index e0108ba..8745688 100644 --- a/guile/starlet/midi-control/faders.scm +++ b/guile/starlet/midi-control/faders.scm @@ -26,27 +26,21 @@ #:use-module (starlet scanout) #:use-module (starlet utils) #:use-module (srfi srfi-1) - #:export (state-on-fader)) + #:export (use-midi-control-map + state-on-fader)) -(define (channel-number->string channel) - (if channel - (number->string channel) - "default")) +(define (name-for-fader-state controller cc-number) + (call-with-output-string + (lambda (port) + (format port "faderstate-~a-cc~a" + controller + cc-number)))) -(define (name-for-fader-state channel cc-number) - (string->symbol - (string-append - "faderstate-ch" - (channel-number->string channel) - "-cc" - (number->string cc-number)))) - - -(define* (state-on-fader cc-number - state - #:key (channel #f)) +(define* (state-on-fader controller + cc-number + state) (register-state! (lighting-state (state-for-each @@ -54,7 +48,7 @@ (at fix attr (lambda () - (let ((cc-val (get-cc-value cc-number #:channel channel))) + (let ((cc-val (get-cc-value controller cc-number))) ;; Fader position known? (if cc-val @@ -74,7 +68,7 @@ 'no-value))))) state)) - #:unique-name (name-for-fader-state channel cc-number))) + #:unique-name (name-for-fader-state controller cc-number))) (define (current-values fixture-list attr-name) @@ -101,7 +95,10 @@ val)))) -(define* (at-midi-jogwheel fixture-list attr cc-number +(define* (at-midi-jogwheel controller + fixture-list + attr + cc-number #:key (led #f)) (define (ccval->offset a) @@ -113,11 +110,12 @@ (unless (null? fixtures) (when led - (send-note-on led)) + (send-note-on controller led)) (let ((old-vals (current-values fixtures attr)) (offset 0)) (register-midi-cc-callback! + controller #:cc-number cc-number #:func (lambda (prev-cc-val new-cc-value) (set! offset (+ offset (ccval->offset new-cc-value))) @@ -191,7 +189,8 @@ gradients)) -(define* (at-midi-fader fixture-list +(define* (at-midi-fader controller + fixture-list attr-name cc-number #:key @@ -206,14 +205,15 @@ (congruent-val (fader-congruent initial-vals attrs)) (up-gradients (fader-up-gradients initial-vals attrs congruent-val)) (dn-gradients (fader-down-gradients initial-vals attrs congruent-val)) - (cc-val (get-cc-value cc-number)) + (cc-val (get-cc-value controller cc-number)) (congruent (and cc-val (= cc-val congruent-val)))) (if congruent - (send-note-on led) - (send-note-on led-incongruent)) + (send-note-on controller led) + (send-note-on controller led-incongruent)) (register-midi-cc-callback! + controller #:cc-number cc-number #:func (lambda (prev-cc-val new-cc-value) @@ -240,65 +240,55 @@ prev-cc-val new-cc-value))) (set! congruent #t) - (send-note-on led))))))))) - - -(define control-map - (list - (list 'intensity 'fader 16 '(108 72)) - (list 'pan 'jogwheel 0 124) - (list 'tilt 'jogwheel 1 125) - (list (colour-component-id 'cyan) 'fader 4 '(120 84)) - (list (colour-component-id 'magenta) 'fader 5 '(121 85)) - (list (colour-component-id 'yellow) 'fader 6 '(122 86)) - (list 'cto 'fader 7 '(123 87)) - (list 'iris 'fader 8 '(116 80)) - (list 'zoom 'fader 9 '(117 81)) - (list 'focus 'fader 10 '(118 82)))) + (send-note-on controller led))))))))) -(define (midi-control-attr control-spec fixture-list) +(define (midi-control-attr controller control-spec fixture-list) (cond ((eq? 'jogwheel (cadr control-spec)) - (at-midi-jogwheel fixture-list + (at-midi-jogwheel controller + fixture-list (car control-spec) (caddr control-spec) #:led (cadddr control-spec))) ((eq? 'fader (cadr control-spec)) - (at-midi-fader fixture-list + (at-midi-fader controller + fixture-list (car control-spec) (caddr control-spec) #:led (car (cadddr control-spec)) #:led-incongruent (cadr (cadddr control-spec)))))) -;; Stuff to clear up when we're done with selected fixtures -(define midi-callbacks '()) - - -(define (select-midi fixture-list) - - (define (led-off leds) - (cond - ((list? leds) - (for-each send-note-off leds)) - ((number? leds) - (send-note-off leds)))) - - (for-each remove-midi-callback! midi-callbacks) - - (for-each (lambda (control-spec) - (led-off (cadddr control-spec))) - control-map) - - (set! midi-callbacks '()) - - (unless (nil? fixture-list) - (set! midi-callbacks - (map (partial midi-control-attr fixture-list) - control-map)))) - - -(add-hook! selection-hook select-midi) +(define (led-off controller leds) + (cond + ((list? leds) + (for-each (lambda (note) + (send-note-off controller note)) + leds)) + ((number? leds) + (send-note-off controller leds)))) + + +(define (use-midi-control-map controller control-map) + (let ((midi-callbacks '())) + (add-hook! selection-hook + (lambda (fixture-list) + + (for-each (lambda (callback) + (remove-midi-callback! controller callback)) + midi-callbacks) + + (for-each (lambda (control-spec) + (led-off controller (cadddr control-spec))) + control-map) + + (set! midi-callbacks '()) + + (unless (nil? fixture-list) + (set! midi-callbacks + (map (lambda (control-spec) + (midi-control-attr controller control-spec fixture-list)) + control-map))))))) |