From 0b6dc4c62134c6ad3e94ca2493f9500bb78462b0 Mon Sep 17 00:00:00 2001 From: Thomas White Date: Wed, 23 Dec 2020 11:02:46 +0100 Subject: Move 'guile-midi' into Starlet namespace --- guile/starlet/midi-control/base.scm | 182 ++++++++++++++++++++++++ guile/starlet/midi-control/playback-buttons.scm | 26 ++++ 2 files changed, 208 insertions(+) create mode 100644 guile/starlet/midi-control/base.scm create mode 100644 guile/starlet/midi-control/playback-buttons.scm (limited to 'guile/starlet/midi-control') 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 () + + (channel + #:init-keyword #:channel + #:getter get-channel) + + (note-number + #:init-keyword #:note-number + #:getter get-note-number)) + + +(define-class () + + (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 () + + (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 + #: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 + #: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 + #: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