module System.MIDI.Sync
( Beats, BPM, openSourceWithSync
)
where
import Control.Monad
import Control.Concurrent
import Control.Concurrent.MVar
import System.MIDI
type Beats = Double
type BPM = Double
oneTwentyFourth = 1/24 :: Double
lambda = 0.05 :: Double
openSourceWithSync
:: Source
-> (Maybe Beats -> MidiEvent -> IO ())
-> IO (Connection, IO (Maybe Beats), IO BPM)
openSourceWithSync src userCallback = do
theLastPos <- newMVar 0 :: IO (MVar Beats)
theBpmEst <- newMVar 120 :: IO (MVar BPM)
thePlayFlag <- newMVar False :: IO (MVar Bool)
theLastClock <- newMVar 0 :: IO (MVar TimeStamp)
theLastQuery <- newMVar 0 :: IO (MVar Beats)
let queryPos tstamp = do
b <- readMVar thePlayFlag
if b
then do
lastpos <- readMVar theLastPos
bpm <- readMVar theBpmEst
lastclock <- readMVar theLastClock
let tdiff = fromIntegral (tstamp lastclock) / 60000.0 :: Double
let newpos0 = lastpos + tdiff * bpm
lastquery <- takeMVar theLastQuery
let newpos = max lastquery newpos0
putMVar theLastQuery newpos
return (Just newpos)
else return Nothing
let queryBPM = readMVar theBpmEst
let handle (MidiEvent tstamp msg) = case msg of
SongPosition midibeats -> do
let pos = fromIntegral midibeats / 6
replaceMVar theLastPos pos
replaceMVar theLastQuery pos
SRTStart -> do
replaceMVar theLastPos 0
replaceMVar theLastQuery 0
replaceMVar theLastClock tstamp
replaceMVar thePlayFlag True
SRTStop -> replaceMVar thePlayFlag False
SRTContinue -> do
replaceMVar theLastClock tstamp
replaceMVar thePlayFlag True
Reset -> do
replaceMVar theLastPos 0
replaceMVar theLastQuery 0
replaceMVar thePlayFlag False
replaceMVar theBpmEst 120
SRTClock -> do
lastclock <- takeMVar theLastClock
bpm <- takeMVar theBpmEst
lastpos <- takeMVar theLastPos
let lastpos' = lastpos + oneTwentyFourth
let tdiff = fromIntegral (tstamp lastclock) / 60000.0 :: Double
let bpm' = (1lambda)*bpm + lambda*(oneTwentyFourth/tdiff)
putMVar theLastClock tstamp
putMVar theLastPos lastpos'
putMVar theBpmEst bpm'
print (bpm',tdiff,1/24/tdiff)
_ -> return ()
let syncCallback event@(MidiEvent tstamp _) = do
handle event
mbpos <- queryPos tstamp
userCallback mbpos event
conn <- openSource src (Just syncCallback)
return (conn, currentTime conn >>= queryPos, queryBPM)
replaceMVar :: MVar a -> a -> IO ()
replaceMVar mv x = do
_ <- tryTakeMVar mv
putMVar mv x