From 0b6dc4c62134c6ad3e94ca2493f9500bb78462b0 Mon Sep 17 00:00:00 2001
From: Thomas White <taw@bitwiz.me.uk>
Date: Wed, 23 Dec 2020 11:02:46 +0100
Subject: Move 'guile-midi' into Starlet namespace

---
 guile/guile-midi/control.scm                    | 182 ------------------------
 guile/starlet/midi-control/base.scm             | 182 ++++++++++++++++++++++++
 guile/starlet/midi-control/playback-buttons.scm |  26 ++++
 3 files changed, 208 insertions(+), 182 deletions(-)
 delete mode 100644 guile/guile-midi/control.scm
 create mode 100644 guile/starlet/midi-control/base.scm
 create mode 100644 guile/starlet/midi-control/playback-buttons.scm

diff --git a/guile/guile-midi/control.scm b/guile/guile-midi/control.scm
deleted file mode 100644
index 548eead..0000000
--- a/guile/guile-midi/control.scm
+++ /dev/null
@@ -1,182 +0,0 @@
-(define-module (guile-midi control)
-  #: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))))))
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))))))
diff --git a/guile/starlet/midi-control/playback-buttons.scm b/guile/starlet/midi-control/playback-buttons.scm
new file mode 100644
index 0000000..a28293a
--- /dev/null
+++ b/guile/starlet/midi-control/playback-buttons.scm
@@ -0,0 +1,26 @@
+(define-module (starlet midi-control playback-buttons)
+  #:use-module (starlet midi-control base)
+  #:use-module (starlet playback)
+  #:export (make-midi-playback-buttons))
+
+
+(define (make-midi-playback-buttons playback
+                                    chan
+                                    go-led-note
+                                    go-button-note
+                                    stop-led-note
+                                    stop-button-note)
+  (let ((go-led (make-midi-led #:channel chan
+                               #:note-number go-led-note))
+        (stop-led (make-midi-led #:channel chan
+                                 #:note-number stop-led-note)))
+    (set-midi-led! go-led #t)
+    (set-midi-led! stop-led #t)
+    (register-midi-note-callback!
+     #:channel chan
+     #:note-number go-button-note
+     #:func (lambda () (go! playback)))
+    (register-midi-note-callback!
+     #:channel chan
+     #:note-number stop-button-note
+     #:func (lambda () (display "Stop/back!\n")))))
-- 
cgit v1.2.3