path: root/midi-dump.hs

{-# 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.Set                       as Set
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)

verbose :: Bool
verbose = False

main :: IO ()
main = main' `AlsaExc.catch` handler
  where
  handler e = when verbose $ putStrLn $ "alsa_exception: " ++ AlsaExc.show e

data LoopState = LoopState {
  _wantExit  :: Bool,
  keysDown   :: MidiPitchSet,
  _playNOW   :: [Event.Data],
  _scheduled :: Q.Queue Event.Data,
  _recording :: Recording,
  _replay    :: Recording,
  _lastTick   :: TimeSpec
}

initializeState :: TimeSpec -> LoopState
initializeState now = LoopState False Set.empty [] 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,
  _lineReader    :: MVar String
}

getAbsTime :: RWST LoopEnv () LoopState IO 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 (?,?,?,?, ?,?,?,?, ?)"]

main' :: IO ()
main' = withAlsaInit $ \h public private q publicAddr privateAddr -> do
  cmdlineAlsaConnect h public

  putStrLn "Rock on!"
  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 lineReader

  (_, ()) <- execRWST mainLoop env $ initializeState startTimeReal
  return ()

mainLoop :: RWST LoopEnv () LoopState IO ()
mainLoop = do
  maybeReadLine >>= maybe processMidi processCommand
  wantExit <- gets _wantExit

  playImmediates
  playScheduled

  unless wantExit mainLoop

playScheduled :: MidiController ()
playScheduled = queueAction $ runScheduledIO (TimeSpec 1 0) $ uncurry alsaDelayNoteEv
-- TODO: flush ALSA output here (and remove flush from playNoteEv)

playImmediates :: MidiController ()
playImmediates = do
  immediate <- gets _playNOW
  unless (null immediate) $ do
    forM_ immediate playNoteEv
    -- TODO: flush ALSA output here (and remove flush from playNoteEv)
    modify $ \s -> s { _playNOW = [] }

_playNote :: Bool -> Event.Note -> RWST LoopEnv () LoopState IO ()
_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 -> RWST LoopEnv () LoopState IO ()
playNoteEv = alsaDelayNoteEv (TimeSpec 0 0)

alsaDelayNoteEv :: TimeSpec -> Event.Data -> RWST LoopEnv () LoopState IO ()
alsaDelayNoteEv delay nevdata = do
  ms <- getMidiSender
  publicAddr <- asks _publicAddr
  liftIO $ ms $ Event.simple publicAddr nevdata `delayEvent` 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 -> RWST LoopEnv () LoopState IO ()
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

mkNote :: Word8 -> Event.Note
mkNote pitch = Event.simpleNote (Event.Channel 0) (Event.Pitch pitch) (Event.Velocity 128)

processCommand :: String -> RWST LoopEnv () LoopState IO ()
processCommand "exit" = modify $ \s -> s { _wantExit = True }
-- processCommand "" = return ()
processCommand "" = gets _replay >>= playRecording
processCommand "C" = do
  let notes = (Event.NoteEv Event.NoteOn . mkNote) <$> [60, 64, 67]
  modify $ \s -> s { _playNOW = notes }
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 128)
      setDuration d note = note { Event.noteDuration = Event.Duration d }
  let notes = (Event.NoteEv Event.NoteOn . setDuration 4290000000 . mkNote) <$> [60, 64, 67]
  modify $ \s -> s { _playNOW = notes }
-}
processCommand str = liftIO $ putStrLn $ "Unknown command: " ++ str

type MidiControllerT m = RWST LoopEnv () LoopState m
type MidiController = MidiControllerT IO

-- playRecording :: Recording -> RWST LoopEnv () LoopState IO ()
playRecording :: Recording -> MidiController ()
playRecording (RecordingInProgress _ _ evts@(_:_)) =
  mapM_ (uncurry delayNoteEv) (zip (subtract (head delays) <$> delays) events)
  where (delays, events) = unzip $ fmap Event.body <$> reverse evts
playRecording  _ = return ()

getMidiSender :: RWST LoopEnv () LoopState IO MidiHook
getMidiSender = do
  h <- asks _h
  q <- asks _q
  publicAddr <- asks _publicAddr
  return $ forwardNoteEvent h q publicAddr

processMidi :: RWST LoopEnv () LoopState IO ()
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) events

    liftIO $ printChordLn newKeys
    modify $ \s -> s { keysDown = newKeys, _recording = recordEvents (_recording s) newEvents, _lastTick = now }

    when (Set.null newKeys) $ do

      doSave <- asks _doSave
      when doSave $ gets _recording >>= saveMidi >> return ()
      modify $ \s -> s { _recording = StartRecording now }

    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 }

latestEvent :: Recording -> TimeSpec
latestEvent (StartRecording x) = x
latestEvent (RecordingInProgress _ x []) = x
latestEvent (RecordingInProgress _ _ ((x,_):_)) = x

maybeReadLine :: RWST LoopEnv () LoopState IO (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 ()


_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