Make each MIDI controller into its own object

4 files changed, 255 insertions, 275 deletions

diff --git a/examples/show.scm b/examples/show.scm
index 770beae..1e51a99 100644
--- a/examples/show.scm
+++ b/examples/show.scm
@@ -15,8 +15,7 @@
   (starlet midi-control faders))
 
 ;; Start MIDI control
-(start-midi-control "/dev/snd/midiC1D0"
-            #:channel 14)
+(define controller (make-midi-controller "/dev/snd/midiC0D0" 14))
 
 ;; Fixtures are normal GOOPS objects, fixture types are GOOPS classes
 (patch-fixture! led <generic-rgb> 1 #:universe 4)
@@ -70,7 +69,22 @@
 
 
 ;; Put a lighting state on a MIDI fader
-(state-on-fader 19 my-state)
+(state-on-fader controller 19 my-state)
+
+
+(use-midi-control-map
+  controller
+  (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))))
 
 
 (define pb
@@ -79,37 +93,37 @@
 
 
 ;; Set up MIDI controller buttons to run cues
-(make-go-button pb 12
+(make-go-button controller pb 12
                 #:ready-note 20
                 #:pause-note 16)
-(make-stop-button pb 24
+(make-stop-button controller pb 24
                   #:ready-note 24)
-(make-back-button pb 28
+(make-back-button controller pb 28
                   #:ready-note 28)
 
 ;; A second set of go/stop buttons, because this works well on my controller
-(make-go-button pb 15
+(make-go-button controller pb 15
                 #:ready-note 23
                 #:pause-note 19)
-(make-stop-button pb 27
+(make-stop-button controller pb 27
                   #:ready-note 27)
-(make-back-button pb 31
+(make-back-button controller pb 31
                   #:ready-note 31)
 
 
 ;; Set up some buttons for quick access to fixtures
-(select-on-button 32 ltruss
+(select-on-button controller 32 ltruss
                   #:ready-note 68)
-(select-on-button 33 rtruss
+(select-on-button controller 33 rtruss
                   #:ready-note 69)
-(select-on-button 34 foh
+(select-on-button controller 34 foh
                   #:ready-note 70)
-(select-on-button 35 floor
+(select-on-button controller 35 floor
                   #:ready-note 71)
 
 
 ;; Red button de-selects everything
-(select-on-button 26 #f
+(select-on-button controller 26 #f
                   #:ready-note 26)
 
 (cut-to-cue-number! pb 0)
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)))))))