From 9adf1aff92e1921203feeedf361deee1984fe2c6 Mon Sep 17 00:00:00 2001
From: Andrew Cady <d@jerkface.net>
Date: Mon, 7 Dec 2015 00:15:02 -0500
Subject: Disable printing the names of keys.

Also whitespace, comments, & other non-functional changes.
---
 Midi.hs      |  8 +++++++
 midi-dump.hs | 71 +++++++++++++++++++++++++++++-------------------------------
 2 files changed, 42 insertions(+), 37 deletions(-)

diff --git a/Midi.hs b/Midi.hs
index e335cd4..402f683 100644
--- a/Midi.hs
+++ b/Midi.hs
@@ -41,6 +41,14 @@ data CompleteRecording = CompleteRecording {
     _recEvents :: [RecordedEvent]
 }
 
+class Playable p where
+    playableEvents :: p -> [RecordedEvent]
+instance Playable Recording where
+    playableEvents (StartRecording _) = []
+    playableEvents (RecordingInProgress _ _ ls) = ls
+instance Playable CompleteRecording where
+    playableEvents = _recEvents
+
 instance FromRow CompleteRecording where
   fromRow = cons <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field
     where
diff --git a/midi-dump.hs b/midi-dump.hs
index b531b97..064ce88 100644
--- a/midi-dump.hs
+++ b/midi-dump.hs
@@ -63,6 +63,7 @@ data LoopEnv = LoopEnv {
   _publicAddr    :: Sound.ALSA.Sequencer.Address.T,
   _privateAddr   :: Sound.ALSA.Sequencer.Address.T,
   _doSave        :: Bool,
+  _printChordKeys :: Bool,
   _lineReader    :: MVar String
 }
 
@@ -122,7 +123,7 @@ main' = withAlsaInit $ \h public private q publicAddr privateAddr -> do
 
   doSave <- isNothing <$> lookupEnv "NO_SAVE_MIDI"
 
-  let env = LoopEnv saver sqlite startTime startTimeReal h public private q publicAddr privateAddr doSave lineReader
+  let env = LoopEnv saver sqlite startTime startTimeReal h public private q publicAddr privateAddr doSave False lineReader
 
   (_, ()) <- execRWST mainLoop env $ initializeState startTimeReal
   return ()
@@ -165,8 +166,8 @@ queueAction act = do
 delayNoteEv :: TimeSpec -> Event.Data -> MidiController ()
 delayNoteEv delay nevdata = queueAction $ scheduleEventIO (delay, nevdata)
 
-_whenFlag :: forall (m :: * -> *) s. MonadState s m => (s -> Bool) -> m () -> m ()
-_whenFlag flag f = gets flag >>= flip when f
+whenFlag :: MonadReader r m => (r -> Bool) -> m () -> m ()
+whenFlag flag f = asks flag >>= flip when f
 
 mkNote :: Word8 -> Event.Note
 mkNote pitch = Event.simpleNote (Event.Channel 0) (Event.Pitch pitch) (Event.Velocity 128)
@@ -194,11 +195,14 @@ processCommand str = liftIO $ putStrLn $ "Unknown command: " ++ str
 type MidiControllerT m = RWST LoopEnv () LoopState m
 type MidiController = MidiControllerT IO
 
-playRecording :: Recording -> MidiController ()
-playRecording (RecordingInProgress _ _ evts@(_:_)) =
+playRecording :: Playable p => p -> MidiController ()
+playRecording = playEvents . playableEvents
+
+playEvents :: [RecordedEvent] -> RWST LoopEnv () LoopState IO ()
+playEvents evts@(_:_) =
   mapM_ (uncurry delayNoteEv) (zip (subtract (head delays) <$> delays) events)
   where (delays, events) = unzip $ reverse $ unConvertEvents evts
-playRecording  _ = return ()
+playEvents  _ = return ()
 
 getMidiSender :: MidiController MidiHook
 getMidiSender = do
@@ -215,29 +219,35 @@ processMidi = do
   (events, newKeys) <- liftIO $ parseAlsaEvents' h oldKeys forwardNOW
 
 
-  if oldKeys == newKeys then
-    liftIO $ threadDelay 15000 -- 15ms.  Seems like a lot, but it sounds OK.  Cuts CPU down to 2%.
-  else do
-    now <- getAbsTime
-    let newEvents = map ((,) now . Event.body)  events
-
-    liftIO $ printChordLn newKeys
-    modify $ \s -> s { keysDown = newKeys, _recording = recordEvents (_recording s) newEvents, _lastTick = now }
+  if oldKeys == newKeys
+    then liftIO $ threadDelay 15000 -- 15ms. Seems like a lot, but it sounds OK. Cuts CPU down to 2%.
+    else do
+      now <- getAbsTime
+      let newEvents = map ((,) now . Event.body) events
 
-    when (Set.null newKeys) $ do
+      modify $ \s ->
+        s
+          { keysDown = newKeys
+          , _recording = recordEvents (_recording s) newEvents
+          , _lastTick = now
+          }
 
-      doSave <- asks _doSave
-      when doSave $ gets _recording >>= saveMidi >> return ()
-      modify $ \s -> s { _recording = StartRecording now }
+      whenFlag _printChordKeys $ liftIO $ printChordLn newKeys
 
-    when (Set.null oldKeys) $ do
+      -- Whenever no keys are pressed, flush any buffered events to the database
+      when (Set.null newKeys) $ do
+        doSave <- asks _doSave
+        when doSave $ gets _recording >>= saveMidi >> return ()
+        modify $ \s -> s { _recording = StartRecording now }
 
-      replay <- gets _replay
-      when (latestEvent replay < (now - TimeSpec 3 0)) $ do
-        modify $ \s -> s { _replay = StartRecording now }
-        return ()
+      -- When a key is pressed after 3+ seconds of silence, overwrite the replay buffer with the new keys
+      when (Set.null oldKeys) $ do
+        replay <- gets _replay
+        when (latestEvent replay < (now - TimeSpec 3 0)) $ do
+          modify $ \s -> s { _replay = StartRecording now }
+          return ()
 
-    modify $ \s -> s { _replay = recordEvents (_replay s) newEvents }
+      modify $ \s -> s { _replay = recordEvents (_replay s) newEvents }
 
 latestEvent :: Recording -> TimeSpec
 latestEvent (StartRecording x) = x
@@ -269,16 +279,3 @@ startSaver sqlite = do
       reco <- readChan chan
       liftIO $ execute sqlite sqlInsert reco
       return ()
-
-
-_getMidiDesc :: Event.T -> Maybe String
-_getMidiDesc (Event.Cons _ _ _ _ _ _ (Event.NoteEv Event.NoteOn  ev)) = return $ ("on:" ++)  $ showPitch $ unPitch $ Event.noteNote ev
-_getMidiDesc (Event.Cons _ _ _ _ _ _ (Event.NoteEv Event.NoteOff ev)) = return $ ("off:" ++) $ showPitch $ unPitch $ Event.noteNote ev
-_getMidiDesc _ = Nothing
-
-_tsDeltas :: [TimeSpec] -> [Integer]
-_tsDeltas [] = []
-_tsDeltas ls@(x:_) = zipWith (-) nsecs (0:nsecs)
-  where
-    nsecs = map timeSpecAsNanoSecs rel
-    rel = map (\y -> y - x) ls
-- 
cgit v1.2.3