{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} import AlsaSeq import Control.Monad.RWS.Strict import Data.List import Data.Maybe import qualified Data.Map.Strict as Map import Data.Map.Strict (Map) import qualified Sound.ALSA.Exception as AlsaExc import qualified Sound.ALSA.Sequencer.Event as Event import System.Clock import Control.Applicative import Database.SQLite.Simple import Database.SQLite.Simple.FromRow () import BasePrelude hiding (loop) import Control.Concurrent.Chan () import Prelude hiding (id, (.)) import qualified Sound.ALSA.Sequencer import qualified Sound.ALSA.Sequencer.Address import qualified Sound.ALSA.Sequencer.Port import qualified Sound.ALSA.Sequencer.Queue import qualified Sound.ALSA.Sequencer.Time as AlsaTime import qualified Sound.ALSA.Sequencer.RealTime as AlsaRealTime 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 import Data.Time.Format import Data.Time.LocalTime (utcToLocalZonedTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Time.Clock (picosecondsToDiffTime, UTCTime) import qualified Data.Set as Set import Data.Set (Set) import System.IO import AlsaShutUp verbose :: Bool verbose = False main :: IO () main = main' `AlsaExc.catch` handler where handler e = when verbose $ putStrLn $ "alsa_exception: " ++ AlsaExc.show e data TriadType = Major | Minor deriving (Show, Eq, Ord) data Triad = Triad { _triadType :: TriadType , _triadPitch :: Event.Pitch , _triadVelocity :: Event.Velocity } deriving (Show, Eq, Ord) toPitchClass :: Event.Pitch -> PitchClass toPitchClass = Event.unPitch >>> (`mod` 12) >>> fromIntegral tonic :: Triad -> PitchClass tonic (Triad _ p _) = toPitchClass p data TriadRecorder = TriadNotRecording | AwaitingTriad | AwaitingRelease Event.Pitch TriadType | Recording Event.Pitch TriadType type PitchClass = Int type ScaleDegree = Int data LoopState = LoopState { _wantExit :: Bool, _waitThreads :: [IO (Thread.Result ())], _keysDown :: MidiPitchMap, _triad :: Set Triad, _triadMap :: Map (PitchClass, TriadType) (Set ScaleDegree), _triadRecording :: TriadRecorder, _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 Map.empty TriadNotRecording createQueue Nothing (StartRecording now) (StartRecording now) now data LoopEnv = LoopEnv { _saver :: Chan CompleteRecording, _sqlite :: Connection, _startTime :: TimeSpec, _startTimeReal :: TimeSpec, _h :: Sound.ALSA.Sequencer.T Sound.ALSA.Sequencer.DuplexMode, _public :: Sound.ALSA.Sequencer.Port.T, _private :: Sound.ALSA.Sequencer.Port.T, _q :: Sound.ALSA.Sequencer.Queue.T, _publicAddr :: Sound.ALSA.Sequencer.Address.T, _privateAddr :: Sound.ALSA.Sequencer.Address.T, _doSave :: Bool, _printChordKeys :: Bool, _lineReader :: MVar String } getAbsTime :: MidiController TimeSpec getAbsTime = do startTime <- asks _startTime startTimeReal <- asks _startTimeReal now <- liftIO $ getTime Monotonic return $ now - startTime + startTimeReal createTable :: Query createTable = fromString . concat $ [ "CREATE TABLE IF NOT EXISTS axis_input" , " (id INTEGER PRIMARY KEY," , " start_sec INTEGER," , " start_nsec INTEGER," , " end_sec INTEGER," , " end_nsec INTEGER," , " first_sec INTEGER," , " first_nsec INTEGER," , " last_sec INTEGER," , " last_nsec INTEGER," , " midi BLOB)" ] sqlInsert :: Query sqlInsert = fromString . concat $ [ "INSERT INTO axis_input " , "(start_sec," , " start_nsec," , " end_sec," , " end_nsec," , " first_sec," , " first_nsec," , " last_sec," , " last_nsec," , " midi)" , "VALUES (?,?,?,?, ?,?,?,?, ?)" ] _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 " , "start_sec," , "start_nsec," , "end_sec," , "end_nsec," , "first_sec," , "first_nsec," , "last_sec," , "last_nsec," , "midi" , " FROM axis_input ORDER BY start_sec, start_nsec;" ] main' :: IO () main' = withAlsaInit $ \h public private q publicAddr privateAddr -> do cmdlineAlsaConnect h public startTime <- getTime Monotonic startTimeReal <- getTime Realtime sqlite <- open "test.db" execute_ sqlite createTable saver <- startSaver sqlite lineReader <- startLineReader doSave <- isNothing <$> lookupEnv "NO_SAVE_MIDI" let env = LoopEnv saver sqlite startTime startTimeReal h public private q publicAddr privateAddr doSave False lineReader void shutUp putStrLn "Rock on!" (_, ()) <- execRWST mainLoop env $ initializeState startTimeReal return () mainLoop :: MidiController () mainLoop = do tick <- getAbsTime modify $ \s -> s { _lastTick = tick } maybeReadLine >>= maybe processMidi processCommand wantExit <- gets _wantExit metronome playScheduled if wantExit then waitThreads else delay >> mainLoop where tickDurationMilliseconds = 4 tickDuration = TimeSpec 0 (tickDurationMilliseconds * 10^(6::Int64)) delay = do before <- gets _lastTick liftIO performMinorGC after <- getAbsTime let duration = tickDuration - (after - before) if duration > 0 then liftIO $ threadDelay $ fromIntegral (nsec duration) `div` 1000 else liftIO $ putStrLn "Uh oh! Dropped frame!" mainLoop 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 = ticked + interval prequeue = 10::Int64 intervals :: Int64 -> TimeSpec intervals n = interval * TimeSpec n 0 -- NB. very strange "*" for TimeSpec when (now > next - intervals prequeue) $ do let delay = next - now forM_ [0..prequeue] $ \n -> alsaDelayNoteEv (delay + intervals n) (metronote 127) modify $ \s -> s { _metronome = Just $ Metronome start interval (next + intervals prequeue) } metronote vel = Event.NoteEv Event.NoteOn $ Event.simpleNote (Event.Channel 9) (Event.Pitch 37) (Event.Velocity vel) 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) _playNote :: Bool -> Event.Note -> MidiController () _playNote noteOn note = playNoteEv $ Event.NoteEv onoff note where onoff = if noteOn then Event.NoteOn else Event.NoteOff delayEvent :: Event.T -> TimeSpec -> Event.T delayEvent evt ts = evt {Event.time = AlsaTime.consRel $ AlsaTime.Real (AlsaRealTime.fromInteger nanosecs)} where nanosecs = timeSpecAsNanoSecs ts playNoteEv :: Event.Data -> MidiController () playNoteEv = alsaDelayNoteEv (TimeSpec 0 0) alsaDelayNoteEv :: TimeSpec -> Event.Data -> MidiController () alsaDelayNoteEv delay nevdata = do ms <- getMidiSender publicAddr <- asks _publicAddr liftIO $ ms $ Event.simple publicAddr nevdata `delayEvent` delay' where delay' = max 0 delay queueAction :: (Queue Event.Data -> MidiController (Queue Event.Data)) -> MidiController () queueAction act = do q <- gets _scheduled act q >>= \q' -> modify $ \s -> s { _scheduled = q' } delayNoteEv :: TimeSpec -> Event.Data -> MidiController () delayNoteEv delay nevdata = queueAction $ scheduleEventIO (delay, nevdata) 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 127) chooseFileName :: Recording -> MidiController FilePath chooseFileName r = do let startTime = earliestEvent r zonedTime <- liftIO $ utcToLocalZonedTime $ timeSpecAsUTCTime startTime return $ formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S%Q %Z%z.mid" zonedTime timeSpecAsUTCTime :: TimeSpec -> UTCTime timeSpecAsUTCTime = posixSecondsToUTCTime . fromRational . toRational . picosecondsToDiffTime . (* 1000) . timeSpecAsNanoSecs processCommand :: String -> MidiController () processCommand "exit" = modify $ \s -> s { _wantExit = True } -- processCommand "" = return () processCommand "" = gets _replay >>= playRecording processCommand "save" = do recording <- gets _replay filename <- chooseFileName recording saveRecording filename recording processCommand "dump" = sqlSelectEVERYTHING >>= saveRecording "dumped.mid" . mconcat processCommand "C" = do let notes = (Event.NoteEv Event.NoteOn . mkNote) <$> [60, 64, 67] forM_ notes (delayNoteEv (TimeSpec 0 0)) processCommand "M-t" = gets _triadRecording >>= \case TriadNotRecording -> do liftIO $ putStrLn "Recording triad" modify $ \s -> s { _triadRecording = AwaitingTriad } _ -> do liftIO $ putStrLn "Cancelled ecording triad" modify $ \s -> s { _triadRecording = TriadNotRecording } processCommand "M-m" = do now <- getAbsTime m <- gets _metronome times <- takeNoteTimes 8 <$> gets _replay let deltas = drop 1 . map negate . toDeltas $ times deltas' = dropOutliers deltas len = length deltas' dropOutliers xs@(x:_) = takeWhile (< TimeSpec 2 0 * x) xs dropOutliers [] = [] if isNothing m && (len >= 3) then do let interval = sum deltas' `tsDiv` fromIntegral len nextBeat = now - now `tsMod` interval + interval lastBeat = nextBeat - interval modify $ \s -> s { _metronome = Just $ Metronome lastBeat interval nextBeat } 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)) {- processCommand "C'" = do -- changing the duration seems to do nothing let mkNote pitch = Event.simpleNote (Event.Channel 0) (Event.Pitch pitch) (Event.Velocity 127) setDuration d note = note { Event.noteDuration = Event.Duration d } let notes = (Event.NoteEv Event.NoteOn . setDuration 4290000000 . mkNote) <$> [60, 64, 67] forM_ notes (delayNoteEv (TimeSpec 0 0)) -} 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 saveRecording :: Playable p => FilePath -> p -> MidiController () saveRecording file = saveEvents file . playableEvents fixedOutputChannel :: Maybe Codec.Midi.Channel fixedOutputChannel = Just 0 setOutputChannel :: Codec.Midi.Message -> Codec.Midi.Message setOutputChannel = case fixedOutputChannel of Just n -> setChannel n Nothing -> id backgroundWithWait :: IO () -> MidiController () backgroundWithWait fn = do (_, wait) <- liftIO $ Thread.forkIO fn modify $ \s -> s { _waitThreads = wait:_waitThreads s } saveEvents :: FilePath -> [RecordedEvent] -> MidiController () saveEvents file evts@(_:_) = backgroundWithWait $ do Codec.Midi.exportFile file (toSingleTrackMidi evts) liftIO $ putStrLn $ "Saved to " ++ file saveEvents _ _ = return () -- NOTE: The list must be in ascending order for this to work -- TODO: Check that it is, and use 'last xs' if not. dropLeadingSilence :: [RecordedEvent] -> [RecordedEvent] dropLeadingSilence [] = [] dropLeadingSilence xs@(x:_) = map (first (subtract (fst x))) xs toSingleTrackMidi :: [RecordedEvent] -> Midi toSingleTrackMidi evts = midi where midi = Midi MultiTrack (TicksPerBeat $ fromIntegral ticksPerBeat) [track ++ [(0, Codec.Midi.TrackEnd)]] track = zip (toDeltas $ map conv delays) events (delays, events) = unzip $ fmap setOutputChannel <$> dropLeadingSilence (reverse 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 = 500 -- 1ms resolution. See git blame. playEvents :: [RecordedEvent] -> MidiController () playEvents evts@(_:_) = mapM_ (uncurry delayNoteEv) $ unConvertEvents $ fmap setOutputChannel <$> dropLeadingSilence (reverse evts) -- TODO: do not use fixed channel playEvents _ = return () getMidiSender :: MidiController MidiHook getMidiSender = do h <- asks _h q <- asks _q publicAddr <- asks _publicAddr return $ forwardNoteEvent h q publicAddr processMidi :: MidiController () processMidi = do h <- asks _h oldKeys <- gets _keysDown forwardNOW <- getMidiSender (events, newKeys) <- liftIO $ parseAlsaEvents'' h oldKeys (const $ return ()) when (oldKeys /= newKeys) $ do now <- gets _lastTick let newEvents = map ((,) now . Event.body) events modify $ \s -> s { _keysDown = newKeys, _recording = recordEvents (_recording s) newEvents } whenFlag _printChordKeys $ liftIO $ printChordLn' newKeys let sendKeys = liftIO (mapM_ forwardNOW events) triadRecording <- gets _triadRecording case triadRecording of TriadNotRecording -> filterTriads newKeys >>= bool sendKeys (return ()) AwaitingTriad -> do let detected = snd <$> listToMaybe (detectTriads newKeys) forM_ detected $ \t@(Triad _ p _) -> (modify $ \s -> s { _triadRecording = AwaitingRelease p (_triadType t) }) AwaitingRelease pitch ttype -> do let pc = toPitchClass pitch when (Map.null newKeys) $ modify $ \s -> s { _triadRecording = Recording pitch ttype, _triadMap = Map.delete (pc, ttype) (_triadMap s) } Recording pitch ttype -> do triadMap <- gets _triadMap let f :: Map (Event.Channel, Event.Pitch) Event.Velocity -> Set ScaleDegree f = Set.fromList . map (subtract (fromIntegral $ Event.unPitch pitch) . fromIntegral . Event.unPitch . snd) . Map.keys pc = toPitchClass pitch done = Map.null newKeys && not (Map.null triadMap) if done then do modify $ \s -> s { _triadRecording = TriadNotRecording } liftIO $ putStrLn "Recorded triad" else modify $ \s -> s { _triadMap = Map.insertWith Set.union (pc, ttype) (f newKeys) (_triadMap s) } -- Whenever no keys are pressed, flush any buffered events to the database when (Map.null newKeys) $ do doSave <- asks _doSave when doSave $ gets _recording >>= saveMidi >> return () modify $ \s -> s { _recording = StartRecording now } -- When a key is pressed after 3+ seconds of silence, overwrite the replay buffer with the new keys when (Map.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 } filterTriads :: MidiPitchMap -> MidiController Bool filterTriads newKeys = do let newTriad = Set.fromList $ map snd $ detectTriads newKeys -- TODO: handle each channel oldTriad <- gets _triad when (newTriad /= oldTriad) $ do forM_ (Set.difference oldTriad newTriad) $ triadOff >>> sendTriadEvents forM_ (Set.difference newTriad oldTriad) sendTriadEvents modify $ \s -> s { _triad = newTriad } return $ not $ Set.null newTriad triadOff :: Triad -> Triad triadOff (Triad t p _) = Triad t p (Event.Velocity 0) sendTriadEvents :: Triad -> MidiController () sendTriadEvents t@(Triad ttype (Event.Pitch base) vel) = do mappedNotes <- Map.lookup (tonic t, ttype) <$> gets _triadMap notesOn $ notes (map fromIntegral . Set.toList <$> mappedNotes) where notesOn n = forM_ n (delayNoteEv (TimeSpec 0 0)) notes :: Maybe [Word8] -> [Event.Data] notes mappedNotes = fromVel vel <$> map (base +) (fromMaybe [0, third, 7, 12, -12, 7+12, 7-12] mappedNotes) third = if ttype == Major then 4 else 3 fromVel (Event.Velocity 0) pitch = Event.NoteEv Event.NoteOff $ Event.simpleNote (Event.Channel 0) (Event.Pitch pitch) (Event.Velocity 0) fromVel v pitch = Event.NoteEv Event.NoteOn $ Event.simpleNote (Event.Channel 0) (Event.Pitch pitch) v detectTriads :: MidiPitchMap -> [(Event.Channel, Triad)] detectTriads pitches = concatMap f (Map.keys pitches) where f pitch = do let [first_, minor3, major3, fifth_] = map (getVelocity . getNote) [0, 3, 4, 7] major = sumM [first_, major3, fifth_] minor = sumM [first_, minor3, fifth_] getNote n = Map.lookup (addPitch n pitch) pitches case (major, minor) of (Just n, _) -> [(fst pitch, Triad Major (snd pitch) (Event.Velocity $ fromIntegral $ n `div` 3))] (_, Just n) -> [(fst pitch, Triad Minor (snd pitch) (Event.Velocity $ fromIntegral $ n `div` 3))] _ -> [] addPitch :: Word8 -> (t, Event.Pitch) -> (t, Event.Pitch) addPitch n = fmap (Event.Pitch . (+ n) . Event.unPitch) getVelocity :: Maybe Event.Velocity -> Maybe Int getVelocity = fmap (fromIntegral . Event.unVelocity) sumM :: (Monad m, Num a, Foldable t) => t (m a) -> m a sumM = foldM (fmap . (+)) 0 earliestEvent :: Recording -> TimeSpec earliestEvent (StartRecording x) = x earliestEvent (RecordingInProgress _ x _) = x latestEvent :: Recording -> TimeSpec latestEvent (StartRecording x) = x latestEvent (RecordingInProgress _ x []) = x latestEvent (RecordingInProgress _ _ ((x,_):_)) = x maybeReadLine :: MidiController (Maybe String) maybeReadLine = asks _lineReader >>= liftIO . tryTakeMVar startLineReader :: IO (MVar String) startLineReader = do mv <- liftIO newEmptyMVar 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 now <- gets _lastTick mapM_ (liftIO . writeChan saver) $ stopRecording recording now startSaver :: forall (m :: * -> *). MonadIO m => Connection -> m (Chan CompleteRecording) startSaver sqlite = do chan <- liftIO newChan _thread <- liftIO $ forkIO (saver chan) return chan where saver chan = forever $ do reco <- readChan chan liftIO $ execute sqlite sqlInsert reco return ()