{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE KindSignatures #-} import AlsaSeq import Control.Monad.RWS.Strict import Data.List import Data.Maybe import qualified Data.Map.Strict as 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 Time 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 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) 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, _recording :: Recording, _replay :: Recording, _lastTick :: TimeSpec } initializeState :: TimeSpec -> LoopState initializeState now = LoopState False [] Map.empty Nothing createQueue (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 putStrLn "Rock on!" (_, ()) <- execRWST mainLoop env $ initializeState startTimeReal return () mainLoop :: MidiController () mainLoop = do maybeReadLine >>= maybe processMidi processCommand wantExit <- gets _wantExit playScheduled if wantExit then waitThreads else mainLoop waitThreads :: MidiController () waitThreads = gets _waitThreads >>= mapM_ liftIO 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 = Time.consRel $ Time.Real (RealTime.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) processCommand :: String -> MidiController () processCommand "exit" = modify $ \s -> s { _wantExit = True } -- processCommand "" = return () processCommand "" = gets _replay >>= playRecording 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)) 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 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 $ Codec.Midi.exportFile file (toSingleTrackMidi evts) 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 = 2^(15::Int) - 1 ticksPerBeat = 2400 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 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 modify $ \s -> s { _keysDown = newKeys , _recording = recordEvents (_recording s) newEvents , _lastTick = now } whenFlag _printChordKeys $ liftIO $ printChordLn' newKeys filterTriads newKeys -- 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 () filterTriads newKeys = do let newTriad = fmap snd $ listToMaybe $ detectTriads newKeys -- TODO: handle each channel oldTriad <- gets _triad when (newTriad /= oldTriad) $ do forM_ oldTriad $ triadOff >>> sendTriadEvents forM_ newTriad sendTriadEvents modify $ \s -> s { _triad = newTriad } triadOff :: Triad -> Triad triadOff (Triad t p _) = Triad t p (Event.Velocity 0) sendTriadEvents :: Triad -> MidiController () sendTriadEvents (Triad _ (Event.Pitch base) vel) = do forM_ notes (delayNoteEv (TimeSpec 0 0)) return () where notes = fromVel vel <$> fill base fill n = [ x + y | x <- [n, n + 7], y <- [12, -12]] 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 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 _thread <- liftIO $ forkIO (forever $ tryIOError getLine >>= either (const $ putMVar mv "exit") (putMVar mv)) return mv 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 ()