diff --git a/src/Sound/Tidal/Boot.hs b/src/Sound/Tidal/Boot.hs index 52497047..73161ee1 100644 --- a/src/Sound/Tidal/Boot.hs +++ b/src/Sound/Tidal/Boot.hs @@ -15,6 +15,7 @@ module Sound.Tidal.Boot panic, list, mute, + muteAll, unmute, unmuteAll, unsoloAll, @@ -186,6 +187,10 @@ list = streamList tidal mute :: (Tidally) => ID -> IO () mute = streamMute tidal +-- | See 'Sound.Tidal.Stream.streamMuteAll'. +muteAll :: (Tidally) => IO () +muteAll = streamMuteAll tidal + -- | See 'Sound.Tidal.Stream.streamUnmute'. unmute :: (Tidally) => ID -> IO () unmute = streamUnmute tidal diff --git a/tidal-link/src/hs/Sound/Tidal/Clock.hs b/tidal-link/src/hs/Sound/Tidal/Clock.hs index ec295393..31b78a30 100644 --- a/tidal-link/src/hs/Sound/Tidal/Clock.hs +++ b/tidal-link/src/hs/Sound/Tidal/Clock.hs @@ -1,7 +1,7 @@ module Sound.Tidal.Clock where -import Control.Concurrent (forkIO, threadDelay) -import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVar, readTVar, retry, swapTVar) +import Control.Concurrent (forkIO) +import Control.Concurrent.STM (TQueue, atomically, check, newTQueue, orElse, readTQueue, readTVar, registerDelay, writeTQueue) import Control.Monad (when) import Control.Monad.Reader (ReaderT, ask, runReaderT) import Control.Monad.State (StateT, evalStateT, get, liftIO, modify, put) @@ -36,7 +36,7 @@ data ClockState = ClockState -- | reference to interact with the clock, while it is running data ClockRef = ClockRef - { rAction :: TVar ClockAction, + { rAction :: TQueue ClockAction, rAbletonLink :: Link.AbletonLink } @@ -57,8 +57,7 @@ type TickAction = -- | possible actions for interacting with the clock data ClockAction - = NoAction - | SetCycle Time + = SetCycle Time | SetTempo Time | SetNudge Double @@ -79,7 +78,7 @@ defaultConfig = -- | creates a clock according to the config and runs it -- | in a seperate thread clocked :: ClockConfig -> TickAction -> IO ClockRef -clocked config ac = runClock config ac clockCheck +clocked config ac = runClock config ac (clockCheck $ return 0) -- | runs the clock on the initial state and memory as given -- | by initClock, hands the ClockRef for interaction from outside @@ -100,7 +99,7 @@ initClock config ac = do let startAt = now + processAhead Link.requestBeatAtTime sessionState 0 startAt (clockQuantum config) Link.commitAndDestroyAppSessionState abletonLink sessionState - clockMV <- atomically $ newTVar NoAction + clockMV <- atomically newTQueue let st = ClockState { ticks = 0, @@ -110,8 +109,17 @@ initClock config ac = do } pure (ClockMemory config (ClockRef clockMV abletonLink) ac, st) where - processAhead = round $ (clockProcessAhead config) * 1000000 - bpm = (coerce defaultCps) * 60 * (clockBeatsPerCycle config) + processAhead = round $ clockProcessAhead config * 1000000 + bpm = coerce defaultCps * 60 * clockBeatsPerCycle config + +readTQueueWithTimeout :: TQueue a -> Int -> IO (Maybe a) +readTQueueWithTimeout queue timeoutMicros = do + timeoutVar <- registerDelay timeoutMicros + atomically $ + (Just <$> readTQueue queue) `orElse` do + timedOut <- readTVar timeoutVar + check timedOut + return Nothing -- The reference time Link uses, -- is the time the audio for a certain beat hits the speaker. @@ -121,23 +129,26 @@ initClock config ac = do -- of nowArc. How far ahead is controlled by cProcessAhead. -- previously called checkArc -clockCheck :: Clock () -clockCheck = do +clockCheck :: IO Int -> Clock () +clockCheck getTimeout = do + timeout <- liftIO getTimeout (ClockMemory config (ClockRef clockMV abletonLink) _) <- ask - action <- liftIO $ atomically $ swapTVar clockMV NoAction - processAction action + action <- liftIO $ readTQueueWithTimeout clockMV timeout - st <- get + case action of + Just a -> do + retry <- processAction a + when retry $ clockCheck getTimeout + Nothing -> return () + st <- get let logicalEnd = logicalTime config (start st) $ ticks st + 1 nextArcStartCycle = arcEnd $ nowArc st - ss <- liftIO $ Link.createAndCaptureAppSessionState abletonLink arcStartTime <- liftIO $ cyclesToTime config ss nextArcStartCycle liftIO $ Link.destroySessionState ss - - if (arcStartTime < logicalEnd) + if arcStartTime < logicalEnd then clockProcess else tick @@ -159,15 +170,16 @@ tick = do newTick | drifted = actualTick | otherwise = preferredNewTick - delta = min frameTimespan (logicalNow - aheadOfNow) + -- delta = min frameTimespan (logicalNow - aheadOfNow) + getDelta = do + now <- Link.clock abletonLink + return $ fromIntegral $ min frameTimespan (logicalNow - (now + processAhead)) put $ st {ticks = newTick} - if drifted - then liftIO $ hPutStrLn stderr $ "skip: " ++ (show (actualTick - ticks st)) - else when (delta > 0) $ liftIO $ threadDelay $ fromIntegral delta + liftIO $ when drifted $ hPutStrLn stderr $ "skip: " ++ show (actualTick - ticks st) - clockCheck + clockCheck getDelta -- previously called processArc -- hands the current link operations to the TickAction @@ -188,15 +200,15 @@ clockProcess = do put (st {nowArc = (startCycle, endCycle)}) tick -processAction :: ClockAction -> Clock () -processAction NoAction = pure () -processAction (SetNudge n) = modify (\st -> st {nudged = n}) +processAction :: ClockAction -> Clock (Bool) +processAction (SetNudge n) = modify (\st -> st {nudged = n}) >> return True processAction (SetTempo bpm) = do (ClockMemory _ (ClockRef _ abletonLink) _) <- ask sessionState <- liftIO $ Link.createAndCaptureAppSessionState abletonLink now <- liftIO $ Link.clock abletonLink liftIO $ Link.setTempo sessionState (fromRational bpm) now liftIO $ Link.commitAndDestroyAppSessionState abletonLink sessionState + return True processAction (SetCycle cyc) = do (ClockMemory config (ClockRef _ abletonLink) _) <- ask sessionState <- liftIO $ Link.createAndCaptureAppSessionState abletonLink @@ -209,6 +221,7 @@ processAction (SetCycle cyc) = do liftIO $ Link.commitAndDestroyAppSessionState abletonLink sessionState modify (\st -> st {ticks = 0, start = now, nowArc = (cyc, cyc)}) + return $ cyc /= 0 --------------------------------------------------------------- ----------- functions representing link operations ------------ @@ -304,18 +317,10 @@ resetClock :: ClockRef -> IO () resetClock clock = setClock clock 0 setClock :: ClockRef -> Time -> IO () -setClock (ClockRef clock _) t = atomically $ do - action <- readTVar clock - case action of - NoAction -> modifyTVar' clock (const $ SetCycle t) - _ -> retry +setClock (ClockRef clock _) t = atomically $ writeTQueue clock $ SetCycle t setBPM :: ClockRef -> Time -> IO () -setBPM (ClockRef clock _) t = atomically $ do - action <- readTVar clock - case action of - NoAction -> modifyTVar' clock (const $ SetTempo t) - _ -> retry +setBPM (ClockRef clock _) t = atomically $ writeTQueue clock $ SetTempo t setCPS :: ClockConfig -> ClockRef -> Time -> IO () setCPS config ref cps = setBPM ref bpm @@ -323,11 +328,7 @@ setCPS config ref cps = setBPM ref bpm bpm = cps * 60 * (toRational $ clockBeatsPerCycle config) setNudge :: ClockRef -> Double -> IO () -setNudge (ClockRef clock _) n = atomically $ do - action <- readTVar clock - case action of - NoAction -> modifyTVar' clock (const $ SetNudge n) - _ -> retry +setNudge (ClockRef clock _) n = atomically $ writeTQueue clock $ SetNudge n -- Used for Tempo callback -- Tempo changes will be applied. diff --git a/tidal-tap/app/Main.hs b/tidal-tap/app/Main.hs index 8d5c1779..1eb9c31d 100644 --- a/tidal-tap/app/Main.hs +++ b/tidal-tap/app/Main.hs @@ -3,19 +3,25 @@ {-# HLINT ignore "Use newtype instead of data" #-} module Main where +-- import Control.Monad (when, forever) -- import qualified Sound.Osc.Time.Timeout as O -import Control.Concurrent (forkIO, killThread, newEmptyMVar, threadDelay) +import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Concurrent.MVar ( MVar, - modifyMVar_, - newMVar, + newEmptyMVar, putMVar, - readMVar, takeMVar, ) -import Control.Monad (forever, when) import Control.Monad.State + ( MonadIO (liftIO), + StateT, + evalStateT, + forever, + gets, + modify, + when, + ) import Data.Time (NominalDiffTime) import Data.Time.Clock.POSIX (getPOSIXTime) import Graphics.Vty @@ -25,7 +31,6 @@ import Options.Applicative import qualified Sound.Osc.Fd as O import qualified Sound.Osc.Transport.Fd.Udp as O import qualified Sound.PortMidi as PM -import Sound.PortMidi.Simple (ChannelMessage (controllerNumber)) import qualified Sound.PortMidi.Simple as PM import System.IO (hPrint, hPutStrLn, stderr) @@ -300,7 +305,7 @@ runTap :: Parameters -> IO () runTap (Parameters {showdevices = True}) = printDevices runTap ps = do - PM.initialize + _ <- PM.initialize addr <- resolve "127.0.0.1" 6010 u <- O.udp_socket diff --git a/tidal.cabal b/tidal.cabal index a4b04168..a327b9ec 100644 --- a/tidal.cabal +++ b/tidal.cabal @@ -19,7 +19,7 @@ data-files: BootTidal.hs Extra-source-files: README.md CHANGELOG.md tidal.el library - ghc-options: -Wall + ghc-options: -Wall -threaded hs-source-dirs: src @@ -68,7 +68,7 @@ test-suite tests main-is: Test.hs hs-source-dirs: test - ghc-options: -Wall + ghc-options: -Wall -threaded other-modules: Sound.Tidal.StreamTest TestUtils @@ -109,7 +109,7 @@ benchmark bench-speed tidal, tidal-core - ghc-options: -Wall + ghc-options: -Wall -threaded default-language: Haskell2010 @@ -125,7 +125,7 @@ benchmark bench-memory tidal, tidal-core - ghc-options: -Wall + ghc-options: -Wall -threaded default-language: Haskell2010