Move 'guile-midi' into Starlet namespace

1 files changed, 182 insertions, 0 deletions

diff --git a/guile/starlet/midi-control/base.scm b/guile/starlet/midi-control/base.scm
new file mode 100644
index 0000000..e77e969
--- /dev/null
+++ b/guile/starlet/midi-control/base.scm
@@ -0,0 +1,182 @@
+(define-module (starlet midi-control base)
+  #:use-module (oop goops)
+  #:use-module (ice-9 atomic)
+  #:use-module (ice-9 threads)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (srfi srfi-1)
+  #:export (start-midi-control
+            make-midi-controller!
+            get-controller-value
+            make-midi-led
+            set-midi-led!
+            all-notes-off!
+            register-midi-note-callback!))
+
+
+(define cc-list (make-atomic-box '()))
+(define callback-list (make-atomic-box '()))
+(define send-queue (make-atomic-box '()))
+
+
+(define-class <midi-led> (<object>)
+
+  (channel
+   #:init-keyword #:channel
+   #:getter get-channel)
+
+  (note-number
+   #:init-keyword #:note-number
+   #:getter get-note-number))
+
+
+(define-class <midi-note-callback> (<object>)
+
+  (channel
+   #:init-keyword #:channel
+   #:getter get-channel)
+
+  (note-number
+   #:init-keyword #:note-number
+   #:getter get-note-number)
+
+  (callback
+   #:init-keyword #:func
+   #:getter get-callback-func))
+
+
+(define-class <midi-control> (<object>)
+
+  (channel
+   #:init-keyword #:channel
+   #:getter get-channel)
+
+  (cc-number
+   #:init-keyword #:cc-number
+   #:getter get-cc-number)
+
+  (value-box
+   #:init-form (make-atomic-box 0)
+   #:getter get-value-box))
+
+
+(define (get-controller-value a)
+  (atomic-box-ref (get-value-box a)))
+
+
+(define* (make-midi-controller!
+          #:key (channel 1) (cc-number 1))
+  (let ((new-controller (make <midi-control>
+                          #:channel channel
+                          #:cc-number cc-number)))
+    (atomic-box-set! cc-list
+                     (cons new-controller
+                           (atomic-box-ref cc-list)))
+    new-controller))
+
+
+(define* (make-midi-led
+          #:key (channel 1) (note-number 1))
+  (let ((new-led (make <midi-led>
+                   #:channel channel
+                   #:note-number note-number)))
+    new-led))
+
+
+(define* (register-midi-note-callback!
+          #:key (channel 1) (note-number 1) (func #f))
+  (let ((new-callback (make <midi-note-callback>
+                        #:channel channel
+                        #:note-number note-number
+                        #:func func)))
+    (atomic-box-set! callback-list
+                     (cons new-callback
+                           (atomic-box-ref callback-list)))
+    new-callback))
+
+
+(define enqueue-midi-bytes!
+  (lambda bytes
+    (unless (eq? (atomic-box-compare-and-swap! send-queue '() bytes)
+                 '())
+      (apply enqueue-midi-bytes! bytes))))
+
+
+(define (set-midi-led! led val)
+  (if val
+
+      ;; Note on
+      (enqueue-midi-bytes! (+ #b10010000 (get-channel led))
+                           (get-note-number led)
+                           127)
+
+      ;; Note off
+      (enqueue-midi-bytes! (+ #b10000000 (get-channel led))
+                           (get-note-number led)
+                           0)))
+
+
+(define (all-notes-off! channel)
+  (let again ((l 0))
+    (enqueue-midi-bytes! (+ #b10000000 channel) l 0)
+    (unless (= l 127)
+      (again (+ l 1)))))
+
+
+(define (handle-cc-change! channel cc-number value)
+  (for-each (lambda (a)
+              (atomic-box-set! (get-value-box a) value))
+            (filter (lambda (a)
+                      (and (eq? cc-number (get-cc-number a))
+                           (eq? channel (get-channel a))))
+                    (atomic-box-ref cc-list))))
+
+
+(define (check-note-callbacks channel note-number)
+  (for-each (lambda (a) ((get-callback-func a)))
+            (filter (lambda (a)
+                      (and (eq? note-number (get-note-number a))
+                           (eq? channel (get-channel a))))
+                    (atomic-box-ref callback-list))))
+
+
+(define (scale-127-100 n)
+  (/ (* n 100) 127))
+
+
+(define (start-midi-control device-name)
+  (let ((midi-port (open-file device-name "r+0b")))
+
+    ;; Read thread
+    (begin-thread
+     (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
+                                      (scale-127-100 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))
+                   bytes-to-send)
+         (usleep 1000)
+         (again))))))