From 7f964d297995103eabe758516296f805f2c8b0a3 Mon Sep 17 00:00:00 2001 From: Andrew Cady Date: Sat, 12 Dec 2015 11:43:00 -0500 Subject: 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. --- midi-dump.hs | 85 +++++++++++++++++++++++++++++++++++++++++++++++++++++------- 1 file 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 -- cgit v1.2.3