Implement a metronome.

You provide a tempo by playing the metronome on the MIDI keyboard. Then
press M-m to have the sequencer continue the same tempo on the MIDI drum
channel.

1 files changed, 76 insertions, 9 deletions

diff --git a/midi-dump.hs b/midi-dump.hs
index 24d0ef1..5e0859b 100644
--- a/midi-dump.hs
+++ b/midi-dump.hs
@@ -42,6 +42,8 @@ import Data.Time.Clock (picosecondsToDiffTime, UTCTime)
 import qualified Data.Set as Set
 import Data.Set (Set)
 
+import System.IO
+
 verbose :: Bool
 verbose = False
 
@@ -54,18 +56,25 @@ data TriadType = Major | Minor deriving (Show, Eq, Ord)
 data Triad = Triad TriadType Event.Pitch Event.Velocity deriving (Show, Eq, Ord)
 
 data LoopState = LoopState {
-  _wantExit  :: Bool,
+  _wantExit    :: Bool,
   _waitThreads :: [IO (Thread.Result ())],
-  _keysDown  :: MidiPitchMap,
-  _triad     :: Set Triad,
-  _scheduled :: Q.Queue Event.Data,
-  _recording :: Recording,
-  _replay    :: Recording,
-  _lastTick  :: TimeSpec
+  _keysDown    :: MidiPitchMap,
+  _triad       :: Set Triad,
+  _scheduled   :: Q.Queue Event.Data,
+  _metronome   :: Maybe Metronome,
+  _recording   :: Recording,
+  _replay      :: Recording,
+  _lastTick    :: TimeSpec
+}
+
+data Metronome = Metronome {
+  _metronomeStart :: TimeSpec,
+  _metronomeInterval :: TimeSpec,
+  _metronomeTicked :: TimeSpec
 }
 
 initializeState :: TimeSpec -> LoopState
-initializeState now = LoopState False [] Map.empty Set.empty createQueue (StartRecording now) (StartRecording now) now
+initializeState now = LoopState False [] Map.empty Set.empty createQueue Nothing (StartRecording now) (StartRecording now) now
 
 data LoopEnv = LoopEnv {
   _saver         :: Chan CompleteRecording,
@@ -180,6 +189,7 @@ mainLoop :: MidiController ()
 mainLoop = do
   maybeReadLine >>= maybe processMidi processCommand
   wantExit <- gets _wantExit
+  metronome
   playScheduled
   if wantExit
     then waitThreads
@@ -188,6 +198,27 @@ mainLoop = do
 waitThreads :: MidiController ()
 waitThreads = gets _waitThreads >>= mapM_ liftIO
 
+metronome :: MidiController ()
+metronome = gets _metronome >>= mapM_ f
+  where
+    f (Metronome start interval ticked) = do
+      now <- getAbsTime
+      let next = now + interval - (now `tsMod` interval)
+      when (next > ticked) $ do
+        let delay = next - now
+        delayNoteEv delay $ metronote 127
+        -- delayNoteEv (metroDuration + delay) $ metronote 0
+        modify $ \s -> s { _metronome = Just $ Metronome start interval next }
+
+    metronote vel = Event.NoteEv Event.NoteOn $ Event.simpleNote (Event.Channel 9) (Event.Pitch 37) (Event.Velocity vel)
+    -- metroDuration = TimeSpec 0 (1*10^(6::Integer))
+
+tsMod :: forall a. Num a => TimeSpec -> TimeSpec -> a
+tsMod x y = fromInteger (timeSpecAsNanoSecs x `mod` timeSpecAsNanoSecs y)
+
+tsDiv :: forall a. Num a => TimeSpec -> TimeSpec -> a
+tsDiv x y = fromInteger (timeSpecAsNanoSecs x `div` timeSpecAsNanoSecs y)
+
 playScheduled :: MidiController ()
 playScheduled = queueAction $ runScheduledIO (TimeSpec 1 0) $ uncurry alsaDelayNoteEv
 -- TODO: flush ALSA output here (and remove flush from playNoteEv)
@@ -247,6 +278,22 @@ processCommand "dump" = sqlSelectEVERYTHING >>= saveRecording "dumped.mid" . mco
 processCommand "C" = do
   let notes = (Event.NoteEv Event.NoteOn . mkNote) <$> [60, 64, 67]
   forM_ notes (delayNoteEv (TimeSpec 0 0))
+processCommand "M-m" = do
+  now <- getAbsTime
+  m <- gets _metronome
+  times <- takeNoteTimes 8 <$> gets _replay
+  let deltas = drop 1 $ toDeltas times
+      deltas' = dropOutliers deltas
+      len = length deltas'
+      dropOutliers xs@(x:_) = takeWhile ((2 * x) >) xs
+      dropOutliers [] = []
+  if isNothing m && (len >= 3) then do
+    let interval = sum deltas' `tsDiv` fromIntegral len
+        nextTick = now + interval - (now `tsMod` interval)
+        lastTick = nextTick - interval
+    modify $ \s -> s { _metronome = Just $ Metronome lastTick interval nextTick }
+  else
+    modify $ \s -> s { _metronome = Nothing }
 processCommand "C'" = do
   let notes = (Event.NoteEv Event.NoteOn . mkNote) <$> [60, 64, 67]
   forM_ notes (delayNoteEv (TimeSpec 2 0))
@@ -263,6 +310,13 @@ processCommand str = liftIO $ putStrLn $ "Unknown command: " ++ str
 type MidiControllerT m = RWST LoopEnv () LoopState m
 type MidiController = MidiControllerT IO
 
+takeNoteTimes :: Playable p => Int -> p -> [TimeSpec]
+takeNoteTimes n p = fst <$> take n (filter (isNoteReallyOn . snd) (playableEvents p))
+
+isNoteReallyOn :: Codec.Midi.Message -> Bool
+isNoteReallyOn (Codec.Midi.NoteOn _ _ v) | v > 0 = True
+isNoteReallyOn _ = False
+
 playRecording :: Playable p => p -> MidiController ()
 playRecording = playEvents . playableEvents
 
@@ -417,9 +471,22 @@ maybeReadLine = asks _lineReader >>= liftIO . tryTakeMVar
 startLineReader :: IO (MVar String)
 startLineReader = do
   mv <- liftIO newEmptyMVar
-  _thread <- liftIO $ forkIO (forever $ tryIOError getLine >>= either (const $ putMVar mv "exit") (putMVar mv))
+  hSetBuffering stdin NoBuffering
+  _thread <- liftIO $ forkIO (forever $ tryIOError getChLine >>= either (const $ putMVar mv "exit") (putMVar mv))
   return mv
 
+getChLine :: IO String
+getChLine = getChar >>= f ""
+    where
+      f acc '\n'          = return $ reverse acc
+      f _ '\ESC'          = (("M-" ++) . unControlCheck) <$> getChar
+      f "" '\^D'          = return "exit"
+      f _ c | isControl c = return $ unControl c
+      f acc c             = getChar >>= f (c:acc)
+      unControl           = ("C-" ++) . return . chr . (+ (ord 'a' - 1)) . ord
+      unControlCheck c | isControl c = unControl c
+                       | otherwise = return c
+
 saveMidi :: forall (m :: * -> *). (MonadIO m, MonadState LoopState m, MonadReader LoopEnv m) => Recording -> m ()
 saveMidi recording = do
   saver <- asks _saver