tidal 0.5.2 → 0.5.3
raw patch · 2 files changed
+79/−37 lines, 2 files
Files
- Sound/Tidal/Tempo.hs +78/−36
- tidal.cabal +1/−1
Sound/Tidal/Tempo.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} module Sound.Tidal.Tempo where -import Data.Time (getCurrentTime, UTCTime, diffUTCTime)+import Data.Time (getCurrentTime, UTCTime, NominalDiffTime, diffUTCTime, addUTCTime) import Data.Time.Clock.POSIX import Control.Monad (forM_, forever, void) import Control.Monad.IO.Class (liftIO)@@ -19,15 +19,18 @@ import Sound.Tidal.Utils -data Tempo = Tempo {at :: UTCTime, beat :: Double, cps :: Double}+data Tempo = Tempo {at :: UTCTime, beat :: Double, cps :: Double, paused :: Bool, clockLatency :: Double} type ClientState = [WS.Connection] instance Eq WS.Connection instance Show Tempo where- show x = show (at x) ++ "," ++ show (beat x) ++ "," ++ show (cps x)+ show x = show (at x) ++ "," ++ show (beat x) ++ "," ++ show (cps x) ++ "," ++ show (paused x) ++ "," ++ (show $ clockLatency x) +getLatency :: IO Double+getLatency = fmap (read) (getEnvDefault "0.04" "TIDAL_CLOCK_LATENCY")+ getClockIp :: IO String getClockIp = getEnvDefault "127.0.0.1" "TIDAL_TEMPO_IP" @@ -35,8 +38,8 @@ getServerPort = fmap read (getEnvDefault "9160" "TIDAL_TEMPO_PORT") readTempo :: String -> Tempo-readTempo x = Tempo (read a) (read b) (read c)- where (a:b:c:_) = wordsBy (== ',') x+readTempo x = Tempo (read a) (read b) (read c) (read d) (read e)+ where (a:b:c:d:e:_) = wordsBy (== ',') x logicalTime :: Tempo -> Double -> Double logicalTime t b = changeT + timeDelta@@ -46,7 +49,8 @@ tempoMVar :: IO (MVar (Tempo)) tempoMVar = do now <- getCurrentTime- mv <- newMVar (Tempo now 0 0.5)+ l <- getLatency+ mv <- newMVar (Tempo now 0 0.5 False l) forkIO $ clocked $ f mv return mv where f mv change _ = do swapMVar mv change@@ -61,19 +65,23 @@ clientApp :: MVar Tempo -> MVar Double -> WS.ClientApp () clientApp mTempo mCps conn = do --sink <- WS.getSink- liftIO $ forkIO $ sendCps conn mCps+ liftIO $ forkIO $ sendCps conn mTempo mCps forever loop where loop = do msg <- WS.receiveData conn- let tempo = readTempo $ T.unpack msg+ let s = T.unpack msg+ let tempo = readTempo $ s+ --putStrLn $ "to: " ++ show tempo liftIO $ tryTakeMVar mTempo liftIO $ putMVar mTempo tempo -sendCps :: WS.Connection -> MVar Double -> IO ()-sendCps conn mCps = forever $ do- cps <- takeMVar mCps - WS.sendTextData conn (T.pack $ show cps)+sendCps :: WS.Connection -> MVar Tempo -> MVar Double -> IO ()+sendCps conn mTempo mCps = forever $ do+ cps <- takeMVar mCps+ t <- readMVar mTempo+ t' <- updateTempo t cps+ WS.sendTextData conn (T.pack $ show t') connectClient :: Bool -> String -> MVar Tempo -> MVar Double -> IO () connectClient secondTry ip mTempo mCps = do @@ -116,8 +124,10 @@ cpsSetter :: IO (Double -> IO ()) cpsSetter = do (f, _) <- cpsUtils return f- clocked :: (Tempo -> Int -> IO ()) -> IO ()+clocked = clockedTick 1++{- clocked callback = do (mTempo, mCps) <- runClient t <- readMVar mTempo@@ -130,15 +140,21 @@ loop mTempo nextBeat where loop mTempo b = do t <- readMVar mTempo- now <- getCurrentTime+ b' <- doSlice t b+ loop mTempo $ b'+ -- wait an eighth of a cycle if we're paused+ doSlice t b | paused t = threadDelay $ floor ((0.125 / cps t) * 1000000)+ | otherwise =+ do now <- getCurrentTime let delta = realToFrac $ diffUTCTime now (at t) actualBeat = (beat t) + ((cps t) * delta) beatDelta = (fromIntegral b) - actualBeat delay = beatDelta / (cps t) threadDelay $ floor (delay * 1000000) callback t b- loop mTempo $ b + 1-+ return $ b + 1+-}+ clockedTick :: Int -> (Tempo -> Int -> IO ()) -> IO () clockedTick tpb callback = do (mTempo, mCps) <- runClient@@ -151,26 +167,50 @@ -- next4 = nextBeat + (4 - (nextBeat `mod` 4)) loop mTempo nextTick where loop mTempo tick = - do t <- readMVar mTempo- now <- getCurrentTime- let tps = (fromIntegral tpb) * cps t- delta = realToFrac $ diffUTCTime now (at t)- actualTick = ((fromIntegral tpb) * beat t) + (tps * delta)+ do tempo <- readMVar mTempo+ tick' <- doTick tempo tick+ loop mTempo tick'+ doTick tempo tick | paused tempo =+ do let pause = 0.01+ -- TODO - do this via blocking read on the mvar somehow+ -- rather than polling+ threadDelay $ floor (pause * 1000000)+ -- reset tick to 0 if cps is negative+ return $ if cps tempo < 0 then 0 else tick+ | otherwise =+ do now <- getCurrentTime+ let tps = (fromIntegral tpb) * cps tempo+ delta = realToFrac $ diffUTCTime now (at tempo)+ actualTick = ((fromIntegral tpb) * beat tempo) + (tps * delta) tickDelta = (fromIntegral tick) - actualTick delay = tickDelta / tps+ --putStrLn ("Delay: " ++ show delay ++ "s Beat: " ++ show (beat tempo)) threadDelay $ floor (delay * 1000000)- callback t tick- loop mTempo $ tick + 1+ callback tempo tick+ return $ tick + 1 -updateTempo :: MVar Tempo -> Maybe Double -> IO ()-updateTempo mt Nothing = return ()-updateTempo mt (Just cps') = do t <- takeMVar mt- now <- getCurrentTime- let delta = realToFrac $ diffUTCTime now (at t)- beat' = (beat t) + ((cps t) * delta)- putMVar mt $ Tempo now beat' cps'+--updateTempo :: MVar Tempo -> Maybe Double -> IO ()+--updateTempo mt Nothing = return ()+--updateTempo mt (Just cps') = do t <- takeMVar mt+-- now <- getCurrentTime+-- let delta = realToFrac $ diffUTCTime now (at t)+-- beat' = (beat t) + ((cps t) * delta)+-- putMVar mt $ Tempo now beat' cps' (paused t) -addClient :: WS.Connection -> ClientState -> ClientState++updateTempo :: Tempo -> Double -> IO (Tempo)+updateTempo t cps'+ | paused t == True && cps' > 0 =+ -- unpause+ do now <- getCurrentTime+ return $ t {at = addUTCTime (realToFrac $ clockLatency t) now, cps = cps', paused = False}+ | otherwise = + do now <- getCurrentTime+ let delta = realToFrac $ diffUTCTime now (at t)+ beat' = (beat t) + ((cps t) * delta)+ beat'' = if cps' < 0 then 0 else beat'+ return $ t {at = now, beat = beat'', cps = cps', paused = (cps' <= 0)}+ addClient client clients = client : clients removeClient :: WS.Connection -> ClientState -> ClientState@@ -178,14 +218,15 @@ broadcast :: Text -> ClientState -> IO () broadcast message clients = do- T.putStrLn message+ -- T.putStrLn message forM_ clients $ \conn -> WS.sendTextData conn $ message startServer :: IO (ThreadId) startServer = do serverPort <- getServerPort start <- getCurrentTime- tempoState <- newMVar (Tempo start 0 1)+ l <- getLatency+ tempoState <- newMVar (Tempo start 0 1 False l) clientState <- newMVar [] forkIO $ WS.runServer "0.0.0.0" serverPort $ serverApp tempoState clientState @@ -202,9 +243,10 @@ serverLoop conn tempoState clientState = E.handle catchDisconnect $ forever $ do msg <- WS.receiveData conn- liftIO $ updateTempo tempoState $ maybeRead $ T.unpack msg- tempo <- liftIO $ readMVar tempoState- liftIO $ readMVar clientState >>= broadcast (T.pack $ show tempo) + --liftIO $ updateTempo tempoState $ maybeRead $ T.unpack msg+ liftIO $ readMVar clientState >>= broadcast msg+ --tempo <- liftIO $ readMVar tempoState+ -- liftIO $ readMVar clientState >>= broadcast (T.pack $ show tempo) where catchDisconnect e = case E.fromException e of Just WS.ConnectionClosed -> liftIO $ modifyMVar_ clientState $ \s -> do
tidal.cabal view
@@ -1,5 +1,5 @@ name: tidal-version: 0.5.2+version: 0.5.3 synopsis: Pattern language for improvised music -- description: homepage: http://tidal.lurk.org/