Implement saving of .mid files

(Currently accessible only under testing command "save".)

2 files changed, 55 insertions, 6 deletions

diff --git a/axis-of-eval.cabal b/axis-of-eval.cabal
index dac8e24..d1aee15 100644
--- a/axis-of-eval.cabal
+++ b/axis-of-eval.cabal
@@ -37,7 +37,7 @@ executable midi-dump
   build-depends:
     base, time, containers, haskore, alsa-seq, alsa-core, mtl, clock,
     sqlite-simple, bytestring, base-prelude, midi-alsa, midi, psqueues,
-    transformers, semigroups, HCodecs
+    transformers, semigroups, HCodecs, threads
   main-is: midi-dump.hs
   other-modules: AlsaSeq, Midi, RealTimeQueue
   ghc-options: -threaded -W -Wall -O2
diff --git a/midi-dump.hs b/midi-dump.hs
index d2b6c15..eacaa03 100644
--- a/midi-dump.hs
+++ b/midi-dump.hs
@@ -31,6 +31,9 @@ import qualified Sound.ALSA.Sequencer.RealTime as RealTime
 import Midi
 import RealTimeQueue as Q hiding (null)
 import qualified Codec.Midi
+import Codec.Midi (Midi(..), FileType(..), TimeDiv(..))
+
+import qualified Control.Concurrent.Thread as Thread
 
 verbose :: Bool
 verbose = False
@@ -45,6 +48,7 @@ data Triad = Triad TriadType Event.Pitch Event.Velocity deriving (Show, Eq)
 
 data LoopState = LoopState {
   _wantExit  :: Bool,
+  _waitThreads :: [IO (Thread.Result ())],
   _keysDown  :: MidiPitchMap,
   _triad     :: Maybe Triad,
   _scheduled :: Q.Queue Event.Data,
@@ -54,7 +58,7 @@ data LoopState = LoopState {
 }
 
 initializeState :: TimeSpec -> LoopState
-initializeState now = LoopState False Map.empty Nothing createQueue (StartRecording now) (StartRecording now) now
+initializeState now = LoopState False [] Map.empty Nothing createQueue (StartRecording now) (StartRecording now) now
 
 data LoopEnv = LoopEnv {
   _saver         :: Chan CompleteRecording,
@@ -109,8 +113,27 @@ sqlInsert = fromString . concat $
   , "VALUES (?,?,?,?, ?,?,?,?, ?)"
   ]
 
-sqlSelectEVERYTHING :: MidiController [CompleteRecording]
-sqlSelectEVERYTHING = do
+sqlSelectRECENT :: MidiController [CompleteRecording]
+sqlSelectRECENT = do
+  conn <- asks _sqlite
+  fmap reverse $ liftIO $ query_ conn $ fromString . concat $
+    [ "SELECT "
+    , "start_sec,"
+    , "start_nsec,"
+    , "end_sec,"
+    , "end_nsec,"
+    , "first_sec,"
+    , "first_nsec,"
+    , "last_sec,"
+    , "last_nsec,"
+    , "midi"
+    , " FROM axis_input",
+      " ORDER BY start_sec DESC, start_nsec DESC ",
+      " LIMIT 10"
+    ]
+
+_sqlSelectEVERYTHING :: MidiController [CompleteRecording]
+_sqlSelectEVERYTHING = do
   conn <- asks _sqlite
   liftIO $ query_ conn $ fromString . concat $
     [ "SELECT "
@@ -151,7 +174,12 @@ mainLoop = do
   maybeReadLine >>= maybe processMidi processCommand
   wantExit <- gets _wantExit
   playScheduled
-  unless wantExit mainLoop
+  if wantExit
+    then waitThreads
+    else mainLoop
+
+waitThreads :: MidiController ()
+waitThreads = gets _waitThreads >>= mapM_ liftIO
 
 playScheduled :: MidiController ()
 playScheduled = queueAction $ runScheduledIO (TimeSpec 1 0) $ uncurry alsaDelayNoteEv
@@ -195,7 +223,8 @@ processCommand :: String -> MidiController ()
 processCommand "exit" = modify $ \s -> s { _wantExit = True }
 -- processCommand "" = return ()
 processCommand "" = gets _replay >>= playRecording
-processCommand "dump" = sqlSelectEVERYTHING >>= playRecording . mconcat
+processCommand "dump" = sqlSelectRECENT >>= playRecording . mconcat
+processCommand "save" = sqlSelectRECENT >>= saveRecording "saved.mid" . mconcat
 processCommand "C" = do
   let notes = (Event.NoteEv Event.NoteOn . mkNote) <$> [60, 64, 67]
   forM_ notes (delayNoteEv (TimeSpec 0 0))
@@ -218,6 +247,9 @@ type MidiController = MidiControllerT IO
 playRecording :: Playable p => p -> MidiController ()
 playRecording = playEvents . playableEvents
 
+saveRecording :: Playable p => FilePath -> p -> MidiController ()
+saveRecording file = saveEvents file . playableEvents
+
 fixedOutputChannel :: Maybe Codec.Midi.Channel
 fixedOutputChannel = Just 0
 
@@ -225,6 +257,23 @@ setOutputChannel :: Codec.Midi.Message -> Codec.Midi.Message
 setOutputChannel = case fixedOutputChannel of Just n -> setChannel n
                                               Nothing -> id
 
+saveEvents :: FilePath -> [RecordedEvent] -> MidiController ()
+saveEvents file evts@(_:_) = do
+  (_, wait) <- liftIO $ Thread.forkIO $ Codec.Midi.exportFile file midi
+  modify $ \s -> s { _waitThreads = wait:_waitThreads s }
+  where
+    midi = Midi MultiTrack (TicksPerBeat $ fromIntegral ticksPerBeat) [track ++ [(0, Codec.Midi.TrackEnd)]]
+    track = zip (toDeltas (conv . subtract (head delays) <$> delays)) events
+    (delays, events) = unzip $ reverse $ (fmap.fmap) setOutputChannel evts -- TODO: do not use fixed channel
+    conv :: TimeSpec -> Int
+    conv = fromIntegral . (`div` (10^(9::Int) `div` ticksPerSecond)) . timeSpecAsNanoSecs
+    ticksPerSecond = ticksPerBeat * beatsPerSecond
+    beatsPerSecond = 120 `div` 60
+    ticksPerBeat :: Integer
+    -- ticksPerBeat = 2^(15::Int) - 1
+    ticksPerBeat = 2400
+saveEvents _ _ = return ()
+
 playEvents :: [RecordedEvent] -> RWST LoopEnv () LoopState IO ()
 playEvents evts@(_:_) =
   mapM_ (uncurry delayNoteEv) (zip (subtract (head delays) <$> delays) events)