aboutsummaryrefslogtreecommitdiff
path: root/guile
diff options
context:
space:
mode:
Diffstat (limited to 'guile')
-rw-r--r--guile/starlet/midi-control/base.scm320
-rw-r--r--guile/starlet/midi-control/button-utils.scm36
-rw-r--r--guile/starlet/midi-control/faders.scm132
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)))))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-10-31 04:10:24 +0000