Organize namespaces

1 files changed, 310 insertions, 0 deletions

diff --git a/src/unheard/midi.clj b/src/unheard/midi.clj
new file mode 100644
index 0000000..1e135a2
--- /dev/null
+++ b/src/unheard/midi.clj
@@ -0,0 +1,310 @@
+(ns unheard.midi
+  (:require [missionary.core :as m]
+            [taoensso.trove :as log])
+  (:import [javax.sound.midi MidiSystem Receiver ShortMessage MidiDevice$Info MidiDevice Transmitter MidiMessage]
+           [uk.co.xfactorylibrarians.coremidi4j CoreMidiDeviceProvider]))
+
+(defn get-all-midi-device-info []
+  (CoreMidiDeviceProvider/getMidiDeviceInfo))
+
+;; Move to tools.repl
+(defn print-all-midi-devices
+  "Prints the names of all MIDI devices attached to the computer."
+  []
+  (doseq [^MidiDevice$Info device-info (get-all-midi-device-info)]
+    (println (.getName device-info))))
+
+(defn select-devices
+  "Given device info list `devices`, return seq where device name is `device-name`.
+  If tx? is true, returned devices will have unlimited transmitters.
+  If rx? is true, returned devices will have unlimited receivers."
+  [devices device-name tx? rx?]
+  (->> devices
+       (filter (fn [^MidiDevice$Info di]
+                 (let [d (MidiSystem/getMidiDevice di)]
+                   (and
+                    (= device-name (.getName di))
+                    (or (not tx?) (= -1 (.getMaxTransmitters d)))
+                    (or (not rx?) (= -1 (.getMaxReceivers d)))))))
+       (map #(MidiSystem/getMidiDevice %))))
+
+;; TODO: git-bug d317eca
+(defn with-device
+  "Open `device` and then run task returned by invoking `tfn` with `device` as its sole argument."
+  [^MidiDevice device tfn]
+  (m/sp
+   (try
+     (m/? (m/via m/blk (.open device)))
+     (log/log! {:level :info, :id :midi/device-opened, :data {:device (str device)}})
+     (m/? (tfn device))
+     (finally
+       (log/log! {:level :info, :id :midi/closing-device})
+       ;; NOTE:
+       ;; Be careful, (.close device) will wait for (.send receiver ...) to return.
+       ;; This can lead to deadlocks during cancellation.
+       (m/? (m/via m/blk (.close device)))
+       (log/log! {:level :info, :id :midi/device-closed, :data {:device (str device)}})))))
+
+(defn with-tx
+  "Feed a transmitter device (e.g. a MIDI keyboard) into a consumer `t`.
+
+  `t` is a function taking a flow of MIDI ShortMessages as its sole argument
+  and returning a task completing with consumption of that flow.
+
+  When invoked, `with-tx` will open the transmitter.
+
+  Upon cancellation or flow termination, the transmitter will be closed.
+
+  Returns a task."
+  [^MidiDevice device t]
+  (m/sp
+   (let [^Transmitter transmitter
+         (m/? (m/via m/blk (.getTransmitter device)))
+         rv (m/mbx)
+         receiver
+         (reify Receiver
+           (send [_this midi-message _timestamp]
+             (log/log! {:level :debug, :id :midi/sending-message})
+             ;; NOTE:
+             ;; Be careful, (.close device) will wait for (.send receiver ...) to return.
+             ;; This can lead to deadlocks during cancellation.
+             ;;
+             ;; TODO: git-bug a1652f9
+             (rv midi-message)
+             (log/log! {:level :debug, :id :midi/message-sent}))
+           (close [_this]))]
+     (log/log! {:level :debug, :id :midi/rx-object-defined, :data {:receiver (str receiver)}})
+     (try
+       (log/log! {:level :debug, :id :midi/setting-receiver})
+       (m/? (m/via m/blk (.setReceiver transmitter receiver)))
+       (log/log! {:level :debug, :id :midi/receiver-set})
+       (m/?
+        (t (m/ap
+            (loop []
+              (m/amb
+               (do
+                 (log/log! {:level :debug, :id :midi/tx-awaiting-value})
+                 (m/amb))
+               (let [v (m/? rv)]
+                 (log/log! {:level :debug, :id :midi/tx-received-value, :data {:value (str v)}})
+                 v)
+               (recur))))))
+       (finally
+         (log/log! {:level :info, :id :midi/closing-tx})
+         (m/? (m/via m/blk (.close transmitter)))
+         (log/log! {:level :info, :id :midi/tx-closed}))))))
+
+(def UNSCHEDULED-EVENT -1)
+
+(defn with-rx
+  "Feed a flow of midi messages into a receiver device (e.g. a synthesizer).
+
+  `f` is a flow of midi ShortMessages.
+
+  When invoked, `with-rx` will open the receiver.
+
+  Upon cancellation or flow termination, the receiver will be closed.
+
+  Returns a task.
+  "
+  [^MidiDevice device f]
+  (m/sp
+   (let [^Receiver receiver
+         (m/? (m/via m/blk (.getReceiver device)))]
+     (log/log! {:level :info, :id :midi/receiver-mounted})
+     (try
+       (m/?
+        (m/reduce {} nil
+                  (m/ap
+                   (let [^MidiMessage v (m/?< f)]
+                     (log/log! {:level :debug, :id :midi/rx-received-value, :data {:value (str v)}})
+                     (m/? (m/via m/blk (.send receiver v UNSCHEDULED-EVENT)))
+                     (log/log! {:level :debug, :id :midi/send-returned})))))
+       (finally
+         (log/log! {:level :info, :id :midi/closing-rx})
+         (m/? (m/via m/blk (.close receiver)))
+         (log/log! {:level :info, :id :midi/rx-closed}))))))
+
+(defn >bus
+  "Opens device named `name`.
+
+  Device will consume `flow`, a flow of Message objects."
+  [name flow]
+  (let [device
+        (first
+         (select-devices (get-all-midi-device-info)
+                         name false true))]
+    (with-device device
+      (fn [d]
+        (with-rx d flow)))))
+
+(defn <bus
+  "Opens device named `name`.
+
+  Calls `flow-handler` with a flow of midi messages.
+
+  `flow-handler` should return a flow."
+  [name flow-handler]
+  (let [device
+        (first
+         (select-devices (get-all-midi-device-info)
+                         name true false))]
+    (with-device device
+      (fn [d]
+        (with-tx d
+          (fn [f]
+            (m/reduce prn nil (flow-handler f))))))))
+
+(defn echo
+  "Echo test."
+  [name from-ch to-ch]
+  (m/sp
+   (let [rv (m/rdv)]
+     (m/?
+      (m/join vector
+              (<bus name
+                    (fn [f]
+                      (m/ap
+                       (let [v (m/?< f)]
+                         (if  (= (class v) ShortMessage)
+                           (let [v ^ShortMessage v]
+                             (if (and (= from-ch (.getChannel v))
+                                      (#{ShortMessage/NOTE_ON ShortMessage/NOTE_OFF} (.getCommand v)))
+                               (let [new-msg (ShortMessage. (.getCommand v) to-ch
+                                                            (.getData1 v)
+                                                            (.getData2 v))]
+                                 (m/? (rv new-msg)))
+                               (m/amb)))
+                           (m/amb)))
+
+                       (log/log! {:level :debug, :id :midi/value-sent}))))
+              (>bus name
+                    (m/ap
+                     (m/amb=
+                      (m/? m/never)
+                      (loop []
+                        (log/log! {:level :debug, :id :midi/echo-rx-awaiting-value})
+                        (m/amb
+                         (m/? rv)
+                         (recur)))))))))))
+
+;; CoreMidiSource is TX Device
+;; CoreMidiDestination is RX Device
+
+#_(defn >midi-messages->ch-stream
+    [>midi-messages]
+    (m/signal
+     (m/ap
+      (let [device (new-device)]
+        (m/amb= device
+                (do
+                  (let [v (m/?< >midi-messages)]
+                    (cond (instance? ShortMessage v)
+                          (let [channel (.getChannel ^ShortMessage v)
+                                command (.getCommand ^ShortMessage v)
+                                data-1 (.getData1 ^ShortMessage v)]
+                            (cond (= command ShortMessage/NOTE_ON)
+                                  (swap! (first (get device channel)) conj data-1)
+                                  (= command ShortMessage/NOTE_OFF)
+                                  (swap! (first (get device channel)) disj data-1)))
+                          :else :other))
+                  (m/amb)))))))
+(defn >midi-messages->ch-stream
+  [>midi-messages]
+  (m/ap
+   (let [device (atom #{})
+         v (m/?< >midi-messages)]
+     (cond (instance? ShortMessage v)
+           (let [channel (.getChannel ^ShortMessage v)
+                 command (.getCommand ^ShortMessage v)
+                 data-1 (.getData1 ^ShortMessage v)]
+             (cond (= command ShortMessage/NOTE_ON)
+                   (swap! device conj data-1)
+                   (= command ShortMessage/NOTE_OFF)
+                   (swap! device disj data-1)))
+           :else (m/amb)))))
+
+(defn |short-messages
+  "Filter down to midi short messages"
+  [>messages]
+  (m/eduction (filter #(instance? ShortMessage %)) >messages))
+
+(defn |group-by-channel
+  [>messages]
+  (m/group-by #(.getChannel ^ShortMessage %) >messages))
+
+(defn |group-by-data-1
+  [>messages]
+  (m/group-by #(.getData1 ^ShortMessage %) >messages))
+
+(defn |matching-commands
+  [>messages commands]
+  (m/eduction (filter (fn [^ShortMessage v]
+                        (contains? commands (.getCommand v)))) >messages))
+
+(def note-commands
+  #{ShortMessage/NOTE_OFF
+    ShortMessage/NOTE_ON
+    ShortMessage/POLY_PRESSURE})
+
+(def control-commands
+  #{ShortMessage/CONTROL_CHANGE})
+
+(defn keyboard
+  [f]
+  (m/relieve
+   (m/group-by
+    first
+    (m/ap
+      (let [[ch ch-messages]
+            (m/?> 128 (|group-by-channel (|short-messages (m/stream f))))
+            ch-messages (m/stream ch-messages)]
+        (m/amb=
+         (let [[note note-messages]
+               (m/?> 128 (-> ch-messages
+                             (|matching-commands note-commands)
+                             (|group-by-data-1)))]
+           ;; TODO: Where to relieve in here?
+           [:key ch note
+            (m/?<
+             (m/reductions
+              (fn [_prev curr]
+                (when (some? curr)
+                  (let [cmd (.getCommand ^ShortMessage curr)]
+                    (cond
+                      (= cmd ShortMessage/NOTE_ON)
+                      (.getData2 ^ShortMessage curr)
+                      (= cmd ShortMessage/POLY_PRESSURE)
+                      (.getData2 ^ShortMessage curr)
+                      (= cmd ShortMessage/NOTE_OFF)
+                      nil)))) nil note-messages))])
+
+         (let [[control-number control-messages]
+               (m/?> 128 (-> ch-messages
+                             (|matching-commands control-commands)
+                             (|group-by-data-1)))]
+           [:control ch control-number (.getData2 ^ShortMessage (m/?< control-messages))])))))))
+
+#_(defn >ch-stream [>device ch]
+    (m/cp (m/?< (second (get >device ch)))))
+
+#_{ch {:notes {note aftertouch}
+       :pitch v
+       :control {controller value}
+       :program program}}
+
+;; Goal:
+;; Create function called `(receive-from-bus bus-name)`.
+;; `bus-name` is the name of a midi bus on this machine. If a bus with that name
+;; exists, the signal returned by `bus` will contain a map of {ch val}, where ch
+;; is a midi channel number and val is a signal of sets representing active
+;; notes on that channel.
+;;
+;; Create another function, `(send-to-bus bus-name sigs)`. `bus-name` is the
+;; name of a midi bus on this machine.  If a bus with that name exists, it will
+;; start reading note values from `sigs`.
+;;
+;; Here, `sigs` is a map of {ch val}, where `ch` is a midi channel number and
+;; `val` is a signal of sets representing active notes on that channel.
+;;
+