From 13db3b17e46aa549856d2f9d901cd7830e979036 Mon Sep 17 00:00:00 2001 From: Alex McLean Date: Wed, 14 May 2025 17:11:41 +0100 Subject: [PATCH 01/10] switch clock actions to TQueue --- tidal-link/src/hs/Sound/Tidal/Clock.hs | 44 ++++++++++---------------- 1 file changed, 16 insertions(+), 28 deletions(-) diff --git a/tidal-link/src/hs/Sound/Tidal/Clock.hs b/tidal-link/src/hs/Sound/Tidal/Clock.hs index 2d596e13..f0064698 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.STM (atomically, registerDelay, TQueue, newTQueue, tryReadTQueue, 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 @@ -71,7 +70,7 @@ defaultConfig = { cFrameTimespan = 1 / 20, cEnableLink = False, cProcessAhead = 3 / 10, - cSkipTicks = 10, + cSkipTicks = 50, cQuantum = 4, cBeatsPerCycle = 4 } @@ -100,7 +99,8 @@ initClock config ac = do let startAt = now + processAhead Link.requestBeatAtTime sessionState 0 startAt (cQuantum config) Link.commitAndDestroyAppSessionState abletonLink sessionState - clockMV <- atomically $ newTVar NoAction + -- tOut <- registerDelay 100 + clockMV <- atomically newTQueue let st = ClockState { ticks = 0, @@ -125,7 +125,7 @@ clockCheck :: Clock () clockCheck = do (ClockMemory config (ClockRef clockMV abletonLink) _) <- ask - action <- liftIO $ atomically $ swapTVar clockMV NoAction + action <- liftIO $ atomically $ tryReadTQueue clockMV processAction action st <- get @@ -188,16 +188,16 @@ clockProcess = do put (st {nowArc = (startCycle, endCycle)}) tick -processAction :: ClockAction -> Clock () -processAction NoAction = pure () -processAction (SetNudge n) = modify (\st -> st {nudged = n}) -processAction (SetTempo bpm) = do +processAction :: Maybe ClockAction -> Clock () +processAction Nothing = pure () +processAction (Just (SetNudge n)) = modify (\st -> st {nudged = n}) +processAction (Just (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 -processAction (SetCycle cyc) = do +processAction (Just (SetCycle cyc)) = do (ClockMemory config (ClockRef _ abletonLink) _) <- ask sessionState <- liftIO $ Link.createAndCaptureAppSessionState abletonLink @@ -304,30 +304,18 @@ 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 where - bpm = cps * 60 * (toRational $ cBeatsPerCycle config) + bpm = cps * 60 * toRational (cBeatsPerCycle 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. From 1247c4adc1c203ceeb04e23c67cb7b6cec97652f Mon Sep 17 00:00:00 2001 From: yaxu Date: Wed, 14 May 2025 16:12:08 +0000 Subject: [PATCH 02/10] automated ormolu reformatting --- tidal-link/src/hs/Sound/Tidal/Clock.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tidal-link/src/hs/Sound/Tidal/Clock.hs b/tidal-link/src/hs/Sound/Tidal/Clock.hs index f0064698..4a67d1d7 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 (atomically, registerDelay, TQueue, newTQueue, tryReadTQueue, writeTQueue) +import Control.Concurrent.STM (TQueue, atomically, newTQueue, registerDelay, tryReadTQueue, writeTQueue) import Control.Monad (when) import Control.Monad.Reader (ReaderT, ask, runReaderT) import Control.Monad.State (StateT, evalStateT, get, liftIO, modify, put) From 0cdfbe2206c58b04bf06372a2c3f7808a42f7288 Mon Sep 17 00:00:00 2001 From: alex Date: Wed, 14 May 2025 20:14:21 +0100 Subject: [PATCH 03/10] first attempt at moving timeout to queue read --- tidal-link/src/hs/Sound/Tidal/Clock.hs | 28 +++++++++++++++++--------- 1 file changed, 18 insertions(+), 10 deletions(-) diff --git a/tidal-link/src/hs/Sound/Tidal/Clock.hs b/tidal-link/src/hs/Sound/Tidal/Clock.hs index 4a67d1d7..016ac9c9 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 (TQueue, atomically, newTQueue, registerDelay, tryReadTQueue, writeTQueue) +import Control.Concurrent (forkIO) +import Control.Concurrent.STM (TQueue, atomically, newTQueue, registerDelay, writeTQueue, readTQueue, readTVar, orElse, check) import Control.Monad (when) import Control.Monad.Reader (ReaderT, ask, runReaderT) import Control.Monad.State (StateT, evalStateT, get, liftIO, modify, put) @@ -78,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 0) -- | runs the clock on the initial state and memory as given -- | by initClock, hands the ClockRef for interaction from outside @@ -113,6 +113,16 @@ initClock config ac = do processAhead = round $ (cProcessAhead config) * 1000000 bpm = (coerce defaultCps) * 60 * (cBeatsPerCycle config) +readTQueueWithTimeout :: TQueue a -> Int -> IO (Maybe a) +readTQueueWithTimeout queue timeoutMicros = do + timeoutVar <- registerDelay timeoutMicros + atomically $ + -- Wait for either an item in the queue or the timeout + (Just <$> readTQueue queue) `orElse` do + timedOut <- readTVar timeoutVar + check timedOut -- Proceed only if the timeout has occurred + return Nothing + -- The reference time Link uses, -- is the time the audio for a certain beat hits the speaker. -- Processing of the nowArc should happen early enough for @@ -121,11 +131,11 @@ initClock config ac = do -- of nowArc. How far ahead is controlled by cProcessAhead. -- previously called checkArc -clockCheck :: Clock () -clockCheck = do +clockCheck :: Int -> Clock () +clockCheck timeout = do (ClockMemory config (ClockRef clockMV abletonLink) _) <- ask - action <- liftIO $ atomically $ tryReadTQueue clockMV + action <- liftIO $ readTQueueWithTimeout clockMV timeout processAction action st <- get @@ -163,11 +173,9 @@ tick = do 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 $ fromIntegral delta -- previously called processArc -- hands the current link operations to the TickAction From 195830646d32637233048237e9ff1ebeebbff338 Mon Sep 17 00:00:00 2001 From: yaxu Date: Wed, 14 May 2025 19:14:37 +0000 Subject: [PATCH 04/10] automated ormolu reformatting --- tidal-link/src/hs/Sound/Tidal/Clock.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/tidal-link/src/hs/Sound/Tidal/Clock.hs b/tidal-link/src/hs/Sound/Tidal/Clock.hs index 016ac9c9..31e30116 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) -import Control.Concurrent.STM (TQueue, atomically, newTQueue, registerDelay, writeTQueue, readTQueue, readTVar, orElse, check) +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) @@ -115,13 +115,13 @@ initClock config ac = do readTQueueWithTimeout :: TQueue a -> Int -> IO (Maybe a) readTQueueWithTimeout queue timeoutMicros = do - timeoutVar <- registerDelay timeoutMicros - atomically $ - -- Wait for either an item in the queue or the timeout - (Just <$> readTQueue queue) `orElse` do - timedOut <- readTVar timeoutVar - check timedOut -- Proceed only if the timeout has occurred - return Nothing + timeoutVar <- registerDelay timeoutMicros + atomically $ + -- Wait for either an item in the queue or the timeout + (Just <$> readTQueue queue) `orElse` do + timedOut <- readTVar timeoutVar + check timedOut -- Proceed only if the timeout has occurred + return Nothing -- The reference time Link uses, -- is the time the audio for a certain beat hits the speaker. From 5c79b10c91b514909fc31b1822fdffd8dc3d3157 Mon Sep 17 00:00:00 2001 From: alex Date: Wed, 14 May 2025 22:06:21 +0100 Subject: [PATCH 05/10] explose muteAll --- src/Sound/Tidal/Boot.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Sound/Tidal/Boot.hs b/src/Sound/Tidal/Boot.hs index a9f249f9..05fbbc50 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 From a652989b790606ee283232b8a6d3dcfb6089032f Mon Sep 17 00:00:00 2001 From: Alex McLean Date: Thu, 15 May 2025 16:23:07 +0100 Subject: [PATCH 06/10] loop reading of action queue --- tidal-link/src/hs/Sound/Tidal/Clock.hs | 62 +++++++++++++------------- 1 file changed, 31 insertions(+), 31 deletions(-) diff --git a/tidal-link/src/hs/Sound/Tidal/Clock.hs b/tidal-link/src/hs/Sound/Tidal/Clock.hs index 31e30116..cf515a8f 100644 --- a/tidal-link/src/hs/Sound/Tidal/Clock.hs +++ b/tidal-link/src/hs/Sound/Tidal/Clock.hs @@ -78,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 0) +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 @@ -99,7 +99,6 @@ initClock config ac = do let startAt = now + processAhead Link.requestBeatAtTime sessionState 0 startAt (cQuantum config) Link.commitAndDestroyAppSessionState abletonLink sessionState - -- tOut <- registerDelay 100 clockMV <- atomically newTQueue let st = ClockState @@ -110,17 +109,16 @@ initClock config ac = do } pure (ClockMemory config (ClockRef clockMV abletonLink) ac, st) where - processAhead = round $ (cProcessAhead config) * 1000000 - bpm = (coerce defaultCps) * 60 * (cBeatsPerCycle config) + processAhead = round $ cProcessAhead config * 1000000 + bpm = coerce defaultCps * 60 * cBeatsPerCycle config readTQueueWithTimeout :: TQueue a -> Int -> IO (Maybe a) readTQueueWithTimeout queue timeoutMicros = do timeoutVar <- registerDelay timeoutMicros atomically $ - -- Wait for either an item in the queue or the timeout (Just <$> readTQueue queue) `orElse` do timedOut <- readTVar timeoutVar - check timedOut -- Proceed only if the timeout has occurred + check timedOut return Nothing -- The reference time Link uses, @@ -131,25 +129,25 @@ readTQueueWithTimeout queue timeoutMicros = do -- of nowArc. How far ahead is controlled by cProcessAhead. -- previously called checkArc -clockCheck :: Int -> Clock () -clockCheck timeout = do +clockCheck :: IO Int -> Clock () +clockCheck getTimeout = do + timeout <- liftIO getTimeout (ClockMemory config (ClockRef clockMV abletonLink) _) <- ask action <- liftIO $ readTQueueWithTimeout clockMV timeout - processAction action - - 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) - then clockProcess - else tick + case action of + Just a -> do processAction a + clockCheck getTimeout + Nothing -> do 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 + then clockProcess + else tick -- tick moves the logical time forward or recalculates the ticks in case -- the logical time is out of sync with Link time. @@ -159,23 +157,26 @@ tick = do (ClockMemory config (ClockRef _ abletonLink) _) <- ask st <- get now <- liftIO $ Link.clock abletonLink - let processAhead = round $ (cProcessAhead config) * 1000000 - frameTimespan = round $ (cFrameTimespan config) * 1000000 + let processAhead = round $ cProcessAhead config * 1000000 + frameTimespan = round $ cFrameTimespan config * 1000000 preferredNewTick = ticks st + 1 logicalNow = logicalTime config (start st) preferredNewTick aheadOfNow = now + processAhead actualTick = (aheadOfNow - start st) `div` frameTimespan - drifted = abs (actualTick - preferredNewTick) > (cSkipTicks config) + drifted = abs (actualTick - preferredNewTick) > cSkipTicks config 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} liftIO $ when drifted $ hPutStrLn stderr $ "skip: " ++ show (actualTick - ticks st) - clockCheck $ fromIntegral delta + clockCheck getDelta -- previously called processArc -- hands the current link operations to the TickAction @@ -196,16 +197,15 @@ clockProcess = do put (st {nowArc = (startCycle, endCycle)}) tick -processAction :: Maybe ClockAction -> Clock () -processAction Nothing = pure () -processAction (Just (SetNudge n)) = modify (\st -> st {nudged = n}) -processAction (Just (SetTempo bpm)) = do +processAction :: ClockAction -> Clock () +processAction (SetNudge n) = modify (\st -> st {nudged = n}) +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 -processAction (Just (SetCycle cyc)) = do +processAction (SetCycle cyc) = do (ClockMemory config (ClockRef _ abletonLink) _) <- ask sessionState <- liftIO $ Link.createAndCaptureAppSessionState abletonLink From 5b2d36f2d3bd55aa792c2fa38b54eec2b97d9719 Mon Sep 17 00:00:00 2001 From: yaxu Date: Thu, 15 May 2025 15:23:25 +0000 Subject: [PATCH 07/10] automated ormolu reformatting --- tidal-link/src/hs/Sound/Tidal/Clock.hs | 30 ++++++++++++++------------ 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/tidal-link/src/hs/Sound/Tidal/Clock.hs b/tidal-link/src/hs/Sound/Tidal/Clock.hs index cf515a8f..d5e9899f 100644 --- a/tidal-link/src/hs/Sound/Tidal/Clock.hs +++ b/tidal-link/src/hs/Sound/Tidal/Clock.hs @@ -137,17 +137,19 @@ clockCheck getTimeout = do action <- liftIO $ readTQueueWithTimeout clockMV timeout case action of - Just a -> do processAction a - clockCheck getTimeout - Nothing -> do 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 - then clockProcess - else tick + Just a -> do + processAction a + clockCheck getTimeout + Nothing -> do + 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 + then clockProcess + else tick -- tick moves the logical time forward or recalculates the ticks in case -- the logical time is out of sync with Link time. @@ -168,9 +170,9 @@ tick = do | drifted = actualTick | otherwise = preferredNewTick -- delta = min frameTimespan (logicalNow - aheadOfNow) - getDelta = do now <- Link.clock abletonLink - return $ fromIntegral $ min frameTimespan (logicalNow - (now + processAhead)) - + getDelta = do + now <- Link.clock abletonLink + return $ fromIntegral $ min frameTimespan (logicalNow - (now + processAhead)) put $ st {ticks = newTick} From e3873507b9b0317b9fd1088536186de21dbc5a91 Mon Sep 17 00:00:00 2001 From: Alex McLean Date: Thu, 15 May 2025 16:25:18 +0100 Subject: [PATCH 08/10] threaded --- tidal.cabal | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tidal.cabal b/tidal.cabal index 5c2926d2..a8ac210b 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 From e6921cd42b6c48b4ce95de452370f619d4fae722 Mon Sep 17 00:00:00 2001 From: alex Date: Thu, 15 May 2025 21:11:01 +0100 Subject: [PATCH 09/10] twiddles --- tidal-tap/app/Main.hs | 72 ++++++++++++++++++++++++++----------------- 1 file changed, 44 insertions(+), 28 deletions(-) diff --git a/tidal-tap/app/Main.hs b/tidal-tap/app/Main.hs index e6b9e867..0871ca5a 100644 --- a/tidal-tap/app/Main.hs +++ b/tidal-tap/app/Main.hs @@ -3,10 +3,26 @@ {-# HLINT ignore "Use newtype instead of data" #-} module Main where -import Control.Monad (when, forever) +-- import Control.Monad (when, forever) -- import qualified Sound.Osc.Time.Timeout as O +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.MVar + ( MVar, + modifyMVar_, + newMVar, + putMVar, + takeMVar, + ) 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 @@ -17,10 +33,7 @@ import qualified Sound.Osc.Fd as O import qualified Sound.Osc.Transport.Fd.Udp as O import qualified Sound.PortMidi as PM import qualified Sound.PortMidi.Simple as PM -import Control.Concurrent.MVar - ( modifyMVar_, newMVar, putMVar, takeMVar, MVar ) -import Control.Concurrent (threadDelay, forkIO) -import System.IO (stderr, hPutStrLn) +import System.IO (hPutStrLn, stderr) data Parameters = Parameters {mididevice :: Maybe PM.DeviceID, showdevices :: Bool} @@ -56,16 +69,18 @@ type TapM = StateT TapState IO newState :: Vty -> (O.Message -> IO ()) -> IO TapState newState v send = - do tapsmv <- newMVar [] - return $ TapState - { lastEv = "", - taps = tapsmv, - vty = v, - running = True, - sender = send, - cps = Nothing, - muted = False - } + do + tapsmv <- newMVar [] + return $ + TapState + { lastEv = "", + taps = tapsmv, + vty = v, + running = True, + sender = send, + cps = Nothing, + muted = False + } resolve :: String -> Int -> IO N.AddrInfo resolve host port = do @@ -204,24 +219,25 @@ printDevices = do doMessage :: MVar [NominalDiffTime] -> (PM.Timestamp, PM.Message) -> IO () doMessage tapsmv (ts, msg@(PM.Channel _ (PM.NoteOn {}))) = - do t <- getPOSIXTime - hPutStrLn stderr $ show ts ++ " : " ++ show msg - modifyMVar_ tapsmv $ \ts -> return $ prepend t ts - return () - where prepend a [] = [a] - prepend a (b:xs) | a == b = b:xs - | otherwise = a:b:xs + do + t <- getPOSIXTime + hPutStrLn stderr $ show ts ++ " : " ++ show msg + modifyMVar_ tapsmv $ \ts -> return $ prepend t ts + return () + where + prepend a [] = [a] + prepend a (b : xs) + | a == b = b : xs + | otherwise = a : b : xs doMessage _ _ = return () - runMidi :: Maybe PM.DeviceID -> MVar [NominalDiffTime] -> IO () runMidi Nothing _ = return () -runMidi (Just input) tapsmv = +runMidi (Just input) tapsmv = PM.withInput input $ \stream -> PM.withReadMessages stream 256 $ \readMessages -> - forever $ do - readMessages >>= mapM_ (doMessage tapsmv) - threadDelay 1000 - + forever $ do + readMessages >>= mapM_ (doMessage tapsmv) + threadDelay 1000 runTap :: Parameters -> IO () runTap (Parameters {showdevices = True}) = printDevices From 25c13b8c8f2a6e962d7cdbcefa794417a9c214f8 Mon Sep 17 00:00:00 2001 From: alex Date: Thu, 22 May 2025 23:20:41 +0100 Subject: [PATCH 10/10] don't continue with frame delay after clock reset --- tidal-link/src/hs/Sound/Tidal/Clock.hs | 31 ++++++++++++++------------ 1 file changed, 17 insertions(+), 14 deletions(-) diff --git a/tidal-link/src/hs/Sound/Tidal/Clock.hs b/tidal-link/src/hs/Sound/Tidal/Clock.hs index d5e9899f..254759e3 100644 --- a/tidal-link/src/hs/Sound/Tidal/Clock.hs +++ b/tidal-link/src/hs/Sound/Tidal/Clock.hs @@ -138,18 +138,19 @@ clockCheck getTimeout = do case action of Just a -> do - processAction a - clockCheck getTimeout - Nothing -> do - 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 - then clockProcess - else tick + 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 + then clockProcess + else tick -- tick moves the logical time forward or recalculates the ticks in case -- the logical time is out of sync with Link time. @@ -199,14 +200,15 @@ clockProcess = do put (st {nowArc = (startCycle, endCycle)}) tick -processAction :: ClockAction -> Clock () -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 @@ -219,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 ------------