-- | MIDI sync to an external clock source.
--
-- To avoid confusion:
-- In our terminology, /beat/ means a quarter note (the same thing as the B in BPM).
-- In MIDI terminology however, a \"MIDI beat\" means a sixteenth note.
--
-- With our notion of beats, one bar is 4 beats (in 4/4 signature, that is)
--

module System.MIDI.Sync 
  ( Beats, BPM, openSourceWithSync
  ) 
  where

--------------------------------------------------------------------------------

import Control.Monad
import Control.Concurrent
import Control.Concurrent.MVar

import System.MIDI

--------------------------------------------------------------------------------

-- | Song position measured in beats (that is, quarter notes), starting from zero.
-- So with 120 BPM, you will have song position 120 after one minute.
type Beats = Double

-- | Estimated BPM
type BPM = Double

oneTwentyFourth :: Double
oneTwentyFourth = Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
24 :: Double
lambda :: Double
lambda          = Double
0.05 :: Double  -- ad-hoc speed of bpm adjustement

-- | Opens a midi source with the possibility to sync to it. 
-- 
-- The user callback gets the the song position in /beats/, 
-- and also we return functions to query to song position and 
-- the estimated BPM. You may want to round the BPM to the nearest 
-- integer if that is appropriate. Song position is Nothing when
-- the playback is stopped.
--
-- Note that when first used, it may need some time to calibrate 
-- the bpm correctly, so start your MIDI host, press play, and 
-- wait a few second. Afterwards, it should be reasonably ok.
-- Also if you do fast realtime BPM changes, 
-- it will be a tiny little bit behind.
--
-- Note that we forward all messages (including clock messages) to 
-- the user, so you can implement your own handling of transport
-- (start/stop/continue) or send messages on clock if you want.
--  
openSourceWithSync 
  :: Source                                            -- ^ midi source
  -> (BPM -> Maybe Beats -> MidiEvent -> IO ())        -- ^ user callback
  -> IO (Connection, IO (Maybe Beats), IO BPM)         -- ^ (connection, song_position, estimated_bpm) 
openSourceWithSync :: Source
-> (Double -> Maybe Double -> MidiEvent -> IO ())
-> IO (Connection, IO (Maybe Double), IO Double)
openSourceWithSync Source
src Double -> Maybe Double -> MidiEvent -> IO ()
userCallback = do

  MVar Double
theLastPos    <- Double -> IO (MVar Double)
forall a. a -> IO (MVar a)
newMVar Double
0       :: IO (MVar Beats)        -- last song position 
  MVar Double
theBpmEst     <- Double -> IO (MVar Double)
forall a. a -> IO (MVar a)
newMVar Double
120     :: IO (MVar BPM)          -- last bpm estimation
  MVar Bool
thePlayFlag   <- Bool -> IO (MVar Bool)
forall a. a -> IO (MVar a)
newMVar Bool
False   :: IO (MVar Bool)         -- whether we are playing or stopped
  MVar TimeStamp
theLastClock  <- TimeStamp -> IO (MVar TimeStamp)
forall a. a -> IO (MVar a)
newMVar TimeStamp
0       :: IO (MVar TimeStamp)    -- timestamp of last clock signal  
  MVar Double
theLastQuery  <- Double -> IO (MVar Double)
forall a. a -> IO (MVar a)
newMVar Double
0       :: IO (MVar Beats)        -- last queried pos 
  MVar [TimeStamp]
theLastClocks <- [TimeStamp] -> IO (MVar [TimeStamp])
forall a. a -> IO (MVar a)
newMVar [TimeStamp
0]     :: IO (MVar [TimeStamp])  -- timestamps of last clock signal  
  
  let queryPos :: TimeStamp -> IO (Maybe Double)
queryPos TimeStamp
tstamp = do
        Bool
b <- MVar Bool -> IO Bool
forall a. MVar a -> IO a
readMVar MVar Bool
thePlayFlag
        if Bool
b 
          then do 
            Double
lastpos   <- MVar Double -> IO Double
forall a. MVar a -> IO a
readMVar MVar Double
theLastPos    -- song position at the last clock/start message
            Double
bpm       <- MVar Double -> IO Double
forall a. MVar a -> IO a
readMVar MVar Double
theBpmEst     -- estimated bpm
            TimeStamp
lastclock <- MVar TimeStamp -> IO TimeStamp
forall a. MVar a -> IO a
readMVar MVar TimeStamp
theLastClock  -- time of the last clock/start message
            let tdiff :: Double
tdiff = TimeStamp -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (TimeStamp
tstamp TimeStamp -> TimeStamp -> TimeStamp
forall a. Num a => a -> a -> a
- TimeStamp
lastclock) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
60000.0 :: Double   -- in minutes
            let newpos0 :: Double
newpos0 = Double
lastpos Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
tdiff Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
bpm  -- extrapolate since last clock signal 
            Double
lastquery <- MVar Double -> IO Double
forall a. MVar a -> IO a
takeMVar MVar Double
theLastQuery
            let newpos :: Double
newpos = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
lastquery Double
newpos0   -- make it monotone in time (!)
            MVar Double -> Double -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Double
theLastQuery Double
newpos
            Maybe Double -> IO (Maybe Double)
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
newpos) 
          else Maybe Double -> IO (Maybe Double)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Double
forall a. Maybe a
Nothing
              
  let queryBPM :: IO Double
queryBPM = MVar Double -> IO Double
forall a. MVar a -> IO a
readMVar MVar Double
theBpmEst
        
  let handle :: MidiEvent -> IO ()
handle (MidiEvent TimeStamp
tstamp MidiMessage
msg) = case MidiMessage
msg of
  
        SongPosition Int
midibeats -> do
          let pos :: Double
pos = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
midibeats Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
6
          MVar Double -> Double -> IO ()
forall a. MVar a -> a -> IO ()
replaceMVar MVar Double
theLastPos   Double
pos
          MVar Double -> Double -> IO ()
forall a. MVar a -> a -> IO ()
replaceMVar MVar Double
theLastQuery Double
pos
  
        MidiMessage
SRTStart -> do
          MVar Double -> Double -> IO ()
forall a. MVar a -> a -> IO ()
replaceMVar MVar Double
theLastPos     Double
0
          MVar Double -> Double -> IO ()
forall a. MVar a -> a -> IO ()
replaceMVar MVar Double
theLastQuery   Double
0
          MVar TimeStamp -> TimeStamp -> IO ()
forall a. MVar a -> a -> IO ()
replaceMVar MVar TimeStamp
theLastClock   TimeStamp
tstamp
          MVar [TimeStamp] -> [TimeStamp] -> IO ()
forall a. MVar a -> a -> IO ()
replaceMVar MVar [TimeStamp]
theLastClocks [TimeStamp
tstamp]
          MVar Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
replaceMVar MVar Bool
thePlayFlag    Bool
True
  
        MidiMessage
SRTStop     -> MVar Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
replaceMVar MVar Bool
thePlayFlag Bool
False
        
        MidiMessage
SRTContinue -> do
          MVar TimeStamp -> TimeStamp -> IO ()
forall a. MVar a -> a -> IO ()
replaceMVar MVar TimeStamp
theLastClock TimeStamp
tstamp
          MVar Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
replaceMVar MVar Bool
thePlayFlag  Bool
True
  
        MidiMessage
Reset -> do 
          MVar Double -> Double -> IO ()
forall a. MVar a -> a -> IO ()
replaceMVar MVar Double
theLastPos   Double
0
          MVar Double -> Double -> IO ()
forall a. MVar a -> a -> IO ()
replaceMVar MVar Double
theLastQuery Double
0
          MVar Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
replaceMVar MVar Bool
thePlayFlag  Bool
False
          MVar Double -> Double -> IO ()
forall a. MVar a -> a -> IO ()
replaceMVar MVar Double
theBpmEst    Double
120
          
        MidiMessage
SRTClock -> do
          TimeStamp
lastclock  <- MVar TimeStamp -> IO TimeStamp
forall a. MVar a -> IO a
takeMVar MVar TimeStamp
theLastClock
          [TimeStamp]
lastclocks <- MVar [TimeStamp] -> IO [TimeStamp]
forall a. MVar a -> IO a
takeMVar MVar [TimeStamp]
theLastClocks
          Double
bpm        <- MVar Double -> IO Double
forall a. MVar a -> IO a
takeMVar MVar Double
theBpmEst
          Double
lastpos    <- MVar Double -> IO Double
forall a. MVar a -> IO a
takeMVar MVar Double
theLastPos
          let lastpos' :: Double
lastpos' = Double
lastpos Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
oneTwentyFourth

          let tdiff :: Double
tdiff   = TimeStamp -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (TimeStamp
tstamp TimeStamp -> TimeStamp -> TimeStamp
forall a. Num a => a -> a -> a
- TimeStamp
lastclock       ) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
60000.0 :: Double  
          let tdiff12 :: Double
tdiff12 = if [TimeStamp] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TimeStamp]
lastclocks Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
12 
                          then Double
0
                          else TimeStamp -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (TimeStamp
tstamp TimeStamp -> TimeStamp -> TimeStamp
forall a. Num a => a -> a -> a
- [TimeStamp]
lastclocks [TimeStamp] -> Int -> TimeStamp
forall a. [a] -> Int -> a
!! Int
11) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
60000.0 :: Double  

          let bpm' :: Double
bpm' = if [TimeStamp] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TimeStamp]
lastclocks Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
12
                then (Double
1Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
lambda)Double -> Double -> Double
forall a. Num a => a -> a -> a
*(Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
30 (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
480 Double
bpm) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
lambdaDouble -> Double -> Double
forall a. Num a => a -> a -> a
*(Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
30 (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
480 (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Double
oneTwentyFourthDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
tdiff)                        
                else (Double
1Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
lambda)Double -> Double -> Double
forall a. Num a => a -> a -> a
*(Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
30 (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
480 Double
bpm) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
lambdaDouble -> Double -> Double
forall a. Num a => a -> a -> a
*(Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
30 (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
480 (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Double
0.5Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
tdiff12)
                        
          MVar TimeStamp -> TimeStamp -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar TimeStamp
theLastClock    TimeStamp
tstamp
          MVar [TimeStamp] -> [TimeStamp] -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar [TimeStamp]
theLastClocks ([TimeStamp] -> IO ()) -> [TimeStamp] -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> [TimeStamp] -> [TimeStamp]
forall a. Int -> [a] -> [a]
take Int
24 (TimeStamp
tstampTimeStamp -> [TimeStamp] -> [TimeStamp]
forall a. a -> [a] -> [a]
:[TimeStamp]
lastclocks)
          MVar Double -> Double -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Double
theLastPos Double
lastpos'
          MVar Double -> Double -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Double
theBpmEst  Double
bpm'      
          
          -- print (bpm',(tdiff,1/24/tdiff),(tdiff12,0.5/tdiff12)) 
          
        MidiMessage
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  let syncCallback :: MidiEvent -> IO ()
syncCallback event :: MidiEvent
event@(MidiEvent TimeStamp
tstamp MidiMessage
_) = do
        MidiEvent -> IO ()
handle MidiEvent
event
        Maybe Double
mbpos <- TimeStamp -> IO (Maybe Double)
queryPos TimeStamp
tstamp
        Double
bpm   <- IO Double
queryBPM 
        Double -> Maybe Double -> MidiEvent -> IO ()
userCallback Double
bpm Maybe Double
mbpos MidiEvent
event
          
  Connection
conn <- Source -> Maybe (MidiEvent -> IO ()) -> IO Connection
openSource Source
src ((MidiEvent -> IO ()) -> Maybe (MidiEvent -> IO ())
forall a. a -> Maybe a
Just MidiEvent -> IO ()
syncCallback)
  (Connection, IO (Maybe Double), IO Double)
-> IO (Connection, IO (Maybe Double), IO Double)
forall (m :: * -> *) a. Monad m => a -> m a
return (Connection
conn, Connection -> IO TimeStamp
currentTime Connection
conn IO TimeStamp
-> (TimeStamp -> IO (Maybe Double)) -> IO (Maybe Double)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TimeStamp -> IO (Maybe Double)
queryPos, IO Double
queryBPM)

--------------------------------------------------------------------------------

replaceMVar :: MVar a -> a -> IO ()      
replaceMVar :: MVar a -> a -> IO ()
replaceMVar MVar a
mv a
x = do
  Maybe a
_ <- MVar a -> IO (Maybe a)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar a
mv  
  MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
mv a
x
       
--------------------------------------------------------------------------------