diff --git a/src/Sound/Tidal/Config.hs b/src/Sound/Tidal/Config.hs
index 8e83853b4..4691db603 100644
--- a/src/Sound/Tidal/Config.hs
+++ b/src/Sound/Tidal/Config.hs
@@ -1,7 +1,6 @@
module Sound.Tidal.Config where
-import Data.Int(Int64)
-import Foreign.C.Types (CDouble)
+import qualified Sound.Tidal.Clock as Clock
{-
Config.hs - For default Tidal configuration values.
@@ -25,16 +24,11 @@ data Config = Config {cCtrlListen :: Bool,
cCtrlAddr :: String,
cCtrlPort :: Int,
cCtrlBroadcast :: Bool,
- cFrameTimespan :: Double,
- cEnableLink :: Bool,
- cProcessAhead :: Double,
cTempoAddr :: String,
cTempoPort :: Int,
cTempoClientPort :: Int,
- cSkipTicks :: Int64,
cVerbose :: Bool,
- cQuantum :: CDouble,
- cBeatsPerCycle :: CDouble
+ cClockConfig :: Clock.ClockConfig
}
defaultConfig :: Config
@@ -42,14 +36,9 @@ defaultConfig = Config {cCtrlListen = True,
cCtrlAddr ="127.0.0.1",
cCtrlPort = 6010,
cCtrlBroadcast = False,
- cFrameTimespan = 1/20,
- cEnableLink = True,
- cProcessAhead = 3/10,
cTempoAddr = "127.0.0.1",
cTempoPort = 9160,
cTempoClientPort = 0, -- choose at random
- cSkipTicks = 10,
cVerbose = True,
- cQuantum = 4,
- cBeatsPerCycle = 4
+ cClockConfig = Clock.defaultConfig
}
diff --git a/src/Sound/Tidal/Stream.hs b/src/Sound/Tidal/Stream.hs
index b9d6c2990..5c387b13d 100644
--- a/src/Sound/Tidal/Stream.hs
+++ b/src/Sound/Tidal/Stream.hs
@@ -42,9 +42,9 @@ import Sound.Tidal.Config
import Sound.Tidal.Core (stack, (#))
import Sound.Tidal.ID
import qualified Sound.Tidal.Link as Link
+import qualified Sound.Tidal.Clock as Clock
import Sound.Tidal.Params (pS)
import Sound.Tidal.Pattern
-import qualified Sound.Tidal.Tempo as T
import Sound.Tidal.Utils ((!!!))
import Data.List (sortOn)
import System.Random (getStdRandom, randomR)
@@ -58,10 +58,9 @@ data Stream = Stream {sConfig :: Config,
sBusses :: MVar [Int],
sStateMV :: MVar ValueMap,
-- sOutput :: MVar ControlPattern,
- sLink :: Link.AbletonLink,
+ sClockRef :: Clock.ClockRef,
sListen :: Maybe O.Udp,
sPMapMV :: MVar PlayMap,
- sActionsMV :: MVar [T.TempoAction],
sGlobalFMV :: MVar (ControlPattern -> ControlPattern),
sCxs :: [Cx]
}
@@ -72,7 +71,6 @@ data Cx = Cx {cxTarget :: Target,
cxAddr :: N.AddrInfo,
cxBusAddr :: Maybe N.AddrInfo
}
- deriving (Show)
data StampStyle = BundleStamp
| MessageStamp
@@ -205,7 +203,6 @@ startStream config oscmap
pMapMV <- newMVar Map.empty
bussesMV <- newMVar []
globalFMV <- newMVar id
- actionsMV <- newEmptyMVar
tidal_status_string >>= verbose config
verbose config $ "Listening for external controls on " ++ cCtrlAddr config ++ ":" ++ show (cCtrlPort config)
@@ -221,26 +218,23 @@ startStream config oscmap
) (oAddress target) (oPort target)
return $ Cx {cxUDP = u, cxAddr = remote_addr, cxBusAddr = remote_bus_addr, cxTarget = target, cxOSCs = os}
) oscmap
- let bpm = (coerce defaultCps) * 60 * (cBeatsPerCycle config)
- abletonLink <- Link.create bpm
+
+ clockRef <- Clock.clocked ((cClockConfig config) {Clock.cTickAction = doTick sMapMV bussesMV pMapMV globalFMV cxs listen})
+
let stream = Stream {sConfig = config,
sBusses = bussesMV,
sStateMV = sMapMV,
- sLink = abletonLink,
+ sClockRef = clockRef,
+ -- sLink = abletonLink,
sListen = listen,
sPMapMV = pMapMV,
- sActionsMV = actionsMV,
+ -- sActionsMV = actionsMV,
sGlobalFMV = globalFMV,
sCxs = cxs
}
+
sendHandshakes stream
- let ac = T.ActionHandler {
- T.onTick = onTick stream,
- T.onSingleTick = onSingleTick stream,
- T.updatePattern = updatePattern stream
- }
- -- Spawn a thread that acts as the clock
- _ <- T.clocked config sMapMV pMapMV actionsMV ac abletonLink
+
-- Spawn a thread to handle OSC control messages
_ <- forkIO $ ctrlResponder 0 config stream
return stream
@@ -361,7 +355,7 @@ toOSC busses pe osc@(OSC _ _)
playmsg | peHasOnset pe = do
-- If there is already cps in the event, the union will preserve that.
let extra = Map.fromList [("cps", (VF (coerce $! peCps pe))),
- ("delta", VF (T.addMicrosToOsc (peDelta pe) 0)),
+ ("delta", VF (Clock.addMicrosToOsc (peDelta pe) 0)),
("cycle", VF (fromRational (peCycle pe)))
]
addExtra = Map.union playmap' extra
@@ -400,40 +394,27 @@ toOSC _ pe (OSCContext oscpath)
ts = (peOnWholeOrPartOsc pe) + nudge -- + latency
--- Used for Tempo callback
-updatePattern :: Stream -> ID -> Time -> ControlPattern -> IO ()
-updatePattern stream k !t pat = do
- let x = queryArc pat (Arc 0 0)
- pMap <- seq x $ takeMVar (sPMapMV stream)
- let playState = updatePS $ Map.lookup (fromID k) pMap
- putMVar (sPMapMV stream) $ Map.insert (fromID k) playState pMap
- where updatePS (Just playState) = do playState {pattern = pat', history = pat:(history playState)}
- updatePS Nothing = PlayState pat' False False [pat']
- patControls = Map.singleton patternTimeID (VR t)
- pat' = withQueryControls (Map.union patControls)
- $ pat # pS "_id_" (pure $ fromID k)
-
-processCps :: T.LinkOperations -> [Event ValueMap] -> IO [ProcessedEvent]
+processCps :: Clock.LinkOperations -> [Event ValueMap] -> IO [ProcessedEvent]
processCps ops = mapM processEvent
where
processEvent :: Event ValueMap -> IO ProcessedEvent
processEvent e = do
let wope = wholeOrPart e
partStartCycle = start $ part e
- partStartBeat = (T.cyclesToBeat ops) (realToFrac partStartCycle)
+ partStartBeat = (Clock.cyclesToBeat ops) (realToFrac partStartCycle)
onCycle = start wope
- onBeat = (T.cyclesToBeat ops) (realToFrac onCycle)
+ onBeat = (Clock.cyclesToBeat ops) (realToFrac onCycle)
offCycle = stop wope
- offBeat = (T.cyclesToBeat ops) (realToFrac offCycle)
- on <- (T.timeAtBeat ops) onBeat
- onPart <- (T.timeAtBeat ops) partStartBeat
+ offBeat = (Clock.cyclesToBeat ops) (realToFrac offCycle)
+ on <- (Clock.timeAtBeat ops) onBeat
+ onPart <- (Clock.timeAtBeat ops) partStartBeat
when (eventHasOnset e) (do
let cps' = Map.lookup "cps" (value e) >>= getF
- maybe (return ()) (\newCps -> (T.setTempo ops) ((T.cyclesToBeat ops) (newCps * 60)) on) $ coerce cps'
+ maybe (return ()) (\newCps -> (Clock.setTempo ops) ((Clock.cyclesToBeat ops) (newCps * 60)) on) $ coerce cps'
)
- off <- (T.timeAtBeat ops) offBeat
- bpm <- (T.getTempo ops)
- let cps = ((T.beatToCycles ops) bpm) / 60
+ off <- (Clock.timeAtBeat ops) offBeat
+ bpm <- (Clock.getTempo ops)
+ let cps = ((Clock.beatToCycles ops) bpm) / 60
let delta = off - on
return $! ProcessedEvent {
peHasOnset = eventHasOnset e,
@@ -442,9 +423,9 @@ processCps ops = mapM processEvent
peDelta = delta,
peCycle = onCycle,
peOnWholeOrPart = on,
- peOnWholeOrPartOsc = (T.linkToOscTime ops) on,
+ peOnWholeOrPartOsc = (Clock.linkToOscTime ops) on,
peOnPart = onPart,
- peOnPartOsc = (T.linkToOscTime ops) onPart
+ peOnPartOsc = (Clock.linkToOscTime ops) onPart
}
@@ -453,22 +434,17 @@ streamOnce :: Stream -> ControlPattern -> IO ()
streamOnce st p = do i <- getStdRandom $ randomR (0, 8192)
streamFirst st $ rotL (toRational (i :: Int)) p
--- here let's do modifyMVar_ on actions
streamFirst :: Stream -> ControlPattern -> IO ()
-streamFirst stream pat = modifyMVar_ (sActionsMV stream) (\actions -> return $ (T.SingleTick pat) : actions)
-
--- Used for Tempo callback
-onTick :: Stream -> TickState -> T.LinkOperations -> ValueMap -> IO ValueMap
-onTick stream st ops s
- = doTick stream st ops s
+streamFirst stream pat = onSingleTick (sConfig stream) (sClockRef stream) (sStateMV stream) (sBusses stream) (sPMapMV stream) (sGlobalFMV stream) (sCxs stream) (sListen stream) pat
-- Used for Tempo callback
-- Tempo changes will be applied.
-- However, since the full arc is processed at once and since Link does not support
-- scheduling, tempo change may affect scheduling of events that happen earlier
-- in the normal stream (the one handled by onTick).
-onSingleTick :: Stream -> T.LinkOperations -> ValueMap -> ControlPattern -> IO ValueMap
-onSingleTick stream ops s pat = do
+onSingleTick :: Config -> Clock.ClockRef -> MVar ValueMap -> MVar [Int] -> MVar PlayMap -> MVar (ControlPattern -> ControlPattern) -> [Cx] -> Maybe O.Udp -> ControlPattern -> IO ()
+onSingleTick config clockRef stateMV busMV _ globalFMV cxs listen pat = do
+ ops <- Clock.getZeroedLinkOperations (cClockConfig config) clockRef
pMapMV <- newMVar $ Map.singleton "fake"
(PlayState {pattern = pat,
mute = False,
@@ -476,10 +452,8 @@ onSingleTick stream ops s pat = do
history = []
}
)
-
-- The nowArc is a full cycle
- let state = TickState {tickArc = (Arc 0 1), tickNudge = 0}
- doTick (stream {sPMapMV = pMapMV}) state ops s
+ doTick stateMV busMV pMapMV globalFMV cxs listen (0,1) 0 ops
-- | Query the current pattern (contained in argument @stream :: Stream@)
@@ -495,25 +469,24 @@ onSingleTick stream ops s pat = do
-- this function prints a warning and resets the current pattern
-- to the previous one (or to silence if there isn't one) and continues,
-- because the likely reason is that something is wrong with the current pattern.
-doTick :: Stream -> TickState -> T.LinkOperations -> ValueMap -> IO ValueMap
-doTick stream st ops sMap =
+doTick :: MVar ValueMap -> MVar [Int] -> MVar PlayMap -> MVar (ControlPattern -> ControlPattern) -> [Cx] -> Maybe O.Udp -> (Time,Time) -> Double -> Clock.LinkOperations -> IO ()
+doTick stateMV busMV playMV globalFMV cxs listen (st,end) nudge ops =
E.handle (\ (e :: E.SomeException) -> do
hPutStrLn stderr $ "Failed to Stream.doTick: " ++ show e
hPutStrLn stderr $ "Return to previous pattern."
- setPreviousPatternOrSilence stream
- return sMap) (do
- pMap <- readMVar (sPMapMV stream)
- busses <- readMVar (sBusses stream)
- sGlobalF <- readMVar (sGlobalFMV stream)
- bpm <- (T.getTempo ops)
+ setPreviousPatternOrSilence playMV) (do
+ sMap <- takeMVar stateMV
+ pMap <- readMVar playMV
+ busses <- readMVar busMV
+ sGlobalF <- readMVar globalFMV
+ bpm <- (Clock.getTempo ops)
let
- cxs = sCxs stream
patstack = sGlobalF $ playStack pMap
- cps = ((T.beatToCycles ops) bpm) / 60
+ cps = ((Clock.beatToCycles ops) bpm) / 60
sMap' = Map.insert "_cps" (VF $ coerce cps) sMap
- extraLatency = tickNudge st
+ extraLatency = nudge
-- First the state is used to query the pattern
- es = sortOn (start . part) $ query patstack (State {arc = tickArc st,
+ es = sortOn (start . part) $ query patstack (State {arc = Arc st end,
controls = sMap'
}
)
@@ -528,13 +501,14 @@ doTick stream st ops sMap =
ms = concatMap (\e -> concatMap (toOSC busses e) oscs) tes
-- send the events to the OSC target
forM_ ms $ \ m -> (do
- send (sListen stream) cx latency extraLatency m) `E.catch` \ (e :: E.SomeException) -> do
+ send listen cx latency extraLatency m) `E.catch` \ (e :: E.SomeException) -> do
hPutStrLn stderr $ "Failed to send. Is the '" ++ oName target ++ "' target running? " ++ show e
- sMap'' `seq` return sMap'')
+ putMVar stateMV sMap'')
+
-setPreviousPatternOrSilence :: Stream -> IO ()
-setPreviousPatternOrSilence stream =
- modifyMVar_ (sPMapMV stream) $ return
+setPreviousPatternOrSilence :: MVar PlayMap -> IO ()
+setPreviousPatternOrSilence playMV =
+ modifyMVar_ playMV $ return
. Map.map ( \ pMap -> case history pMap of
_:p:ps -> pMap { pattern = p, history = p:ps }
_ -> pMap { pattern = silence, history = [silence] }
@@ -564,13 +538,28 @@ send listen cx latency extraLatency (time, isBusMsg, m)
-- Interaction
streamNudgeAll :: Stream -> Double -> IO ()
-streamNudgeAll s nudge = T.setNudge (sActionsMV s) nudge
+streamNudgeAll s = Clock.setNudge (sClockRef s)
streamResetCycles :: Stream -> IO ()
streamResetCycles s = streamSetCycle s 0
streamSetCycle :: Stream -> Time -> IO ()
-streamSetCycle s cyc = T.setCycle cyc (sActionsMV s)
+streamSetCycle s = Clock.setClock (sClockRef s)
+
+streamSetBPM :: Stream -> Time -> IO ()
+streamSetBPM s = Clock.setBPM (sClockRef s)
+
+streamSetCPS :: Stream -> Time -> IO ()
+streamSetCPS s = Clock.setCPS (cClockConfig $ sConfig s) (sClockRef s)
+
+streamGetCPS :: Stream -> IO Time
+streamGetCPS s = Clock.getCPS (cClockConfig $ sConfig s)(sClockRef s)
+
+streamGetBPM :: Stream -> IO Time
+streamGetBPM s = Clock.getBPM (sClockRef s)
+
+streamGetNow :: Stream -> IO Time
+streamGetNow s = Clock.getCycleTime (cClockConfig $ sConfig s)(sClockRef s)
hasSolo :: Map.Map k PlayState -> Bool
hasSolo = (>= 1) . length . filter solo . Map.elems
@@ -585,11 +574,26 @@ streamList s = do pMap <- readMVar (sPMapMV s)
showKV False (k, (PlayState {solo = False})) = k ++ "\n"
showKV False (k, _) = "(" ++ k ++ ") - muted\n"
--- Evaluation of pat is forced so exceptions are picked up here, before replacing the existing pattern.
+-- Used for Tempo callback
+updatePattern :: Stream -> ID -> Time -> ControlPattern -> IO ()
+updatePattern stream k !t pat = do
+ let x = queryArc pat (Arc 0 0)
+ pMap <- seq x $ takeMVar (sPMapMV stream)
+ let playState = updatePS $ Map.lookup (fromID k) pMap
+ putMVar (sPMapMV stream) $ Map.insert (fromID k) playState pMap
+ where updatePS (Just playState) = do playState {pattern = pat', history = pat:(history playState)}
+ updatePS Nothing = PlayState pat' False False [pat']
+ patControls = Map.singleton patternTimeID (VR t)
+ pat' = withQueryControls (Map.union patControls)
+ $ pat # pS "_id_" (pure $ fromID k)
+-- Evaluation of pat is forced so exceptions are picked up here, before replacing the existing pattern.
streamReplace :: Stream -> ID -> ControlPattern -> IO ()
-streamReplace s k !pat
- = modifyMVar_ (sActionsMV s) (\actions -> return $ (T.StreamReplace k pat) : actions)
+streamReplace stream k !pat = do
+ t <- Clock.getCycleTime (cClockConfig $ sConfig stream) (sClockRef stream)
+ updatePattern stream k t pat
+
+ -- = modifyMVar_ (sActionsMV s) (\actions -> return $ (T.StreamReplace k pat) : actions)
streamMute :: Stream -> ID -> IO ()
streamMute s k = withPatIds s [k] (\x -> x {mute = True})
@@ -737,31 +741,3 @@ verbose c s = when (cVerbose c) $ putStrLn s
recvMessagesTimeout :: (O.Transport t) => Double -> t -> IO [O.Message]
recvMessagesTimeout n sock = fmap (maybe [] O.packetMessages) $ O.recvPacketTimeout n sock
-
-streamGetcps :: Stream -> IO Double
-streamGetcps s = do
- let config = sConfig s
- ss <- Link.createAndCaptureAppSessionState (sLink s)
- bpm <- Link.getTempo ss
- Link.destroySessionState ss
- return $! coerce $ bpm / (cBeatsPerCycle config) / 60
-
-streamGetnow :: Stream -> IO Double
-streamGetnow s = do
- let config = sConfig s
- ss <- Link.createAndCaptureAppSessionState (sLink s)
- now <- Link.clock (sLink s)
- beat <- Link.beatAtTime ss now (cQuantum config)
- Link.destroySessionState ss
- return $! coerce $ beat / (cBeatsPerCycle config)
-
-getProcessAhead :: Stream -> Link.Micros
-getProcessAhead str = round $ (cProcessAhead $ sConfig str) * 100000
-
-streamGetAhead :: Stream -> IO Double
-streamGetAhead str = do
- ss <- Link.createAndCaptureAppSessionState (sLink str)
- now <- Link.clock (sLink str)
- beat <- Link.beatAtTime ss (now + (getProcessAhead str)) (cQuantum $! sConfig str)
- Link.destroySessionState ss
- return $ coerce $! beat / (cBeatsPerCycle $! sConfig str)
diff --git a/src/Sound/Tidal/Tempo.hs b/src/Sound/Tidal/Tempo.hs
deleted file mode 100644
index 3b505158a..000000000
--- a/src/Sound/Tidal/Tempo.hs
+++ /dev/null
@@ -1,300 +0,0 @@
-{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, FlexibleContexts, ScopedTypeVariables, BangPatterns #-}
-{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns -fno-warn-orphans #-}
-
-
-module Sound.Tidal.Tempo where
-
-import Control.Concurrent.MVar
-import qualified Sound.Tidal.Pattern as P
-import qualified Sound.Osc.Fd as O
-import Control.Concurrent (forkIO, ThreadId, threadDelay)
-import Control.Monad (when)
-import qualified Data.Map.Strict as Map
-import qualified Control.Exception as E
-import Sound.Tidal.ID
-import Sound.Tidal.Config
-import Sound.Tidal.Utils (writeError)
-import qualified Sound.Tidal.Link as Link
-import Foreign.C.Types (CDouble(..))
-import System.IO (hPutStrLn, stderr)
-import Data.Int(Int64)
-
-import Sound.Tidal.StreamTypes
-
-{-
- Tempo.hs - Tidal's scheduler
- Copyright (C) 2020, Alex McLean and contributors
-
- This library is free software: you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation, either version 3 of the License, or
- (at your option) any later version.
-
- This library is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this library. If not, see .
--}
-
-instance Show O.Udp where
- show _ = "-unshowable-"
-
-type TransitionMapper = P.Time -> [P.ControlPattern] -> P.ControlPattern
-
-data TempoAction =
- SetCycle P.Time
- | SingleTick P.ControlPattern
- | SetNudge Double
- | StreamReplace ID P.ControlPattern
- | Transition Bool TransitionMapper ID P.ControlPattern
-
-data State = State {ticks :: Int64,
- start :: Link.Micros,
- nowArc :: P.Arc,
- nudged :: Double
- }
- deriving Show
-
-data ActionHandler =
- ActionHandler {
- onTick :: TickState -> LinkOperations -> P.ValueMap -> IO P.ValueMap,
- onSingleTick :: LinkOperations -> P.ValueMap -> P.ControlPattern -> IO P.ValueMap,
- updatePattern :: ID -> P.Time -> P.ControlPattern -> IO ()
- }
-
-data LinkOperations =
- LinkOperations {
- timeAtBeat :: Link.Beat -> IO Link.Micros,
- timeToCycles :: Link.Micros -> IO P.Time,
- getTempo :: IO Link.BPM,
- setTempo :: Link.BPM -> Link.Micros -> IO (),
- linkToOscTime :: Link.Micros -> O.Time,
- beatToCycles :: CDouble -> CDouble,
- cyclesToBeat :: CDouble -> CDouble
- }
-
-setCycle :: P.Time -> MVar [TempoAction] -> IO ()
-setCycle cyc actionsMV = modifyMVar_ actionsMV (\actions -> return $ SetCycle cyc : actions)
-
-setNudge :: MVar [TempoAction] -> Double -> IO ()
-setNudge actionsMV nudge = modifyMVar_ actionsMV (\actions -> return $ SetNudge nudge : actions)
-
-timeToCycles' :: Config -> Link.SessionState -> Link.Micros -> IO P.Time
-timeToCycles' config ss time = do
- beat <- Link.beatAtTime ss time (cQuantum config)
- return $! (toRational beat) / (toRational (cBeatsPerCycle config))
-
--- At what time does the cycle occur according to Link?
-cyclesToTime :: Config -> Link.SessionState -> P.Time -> IO Link.Micros
-cyclesToTime config ss cyc = do
- let beat = (fromRational cyc) * (cBeatsPerCycle config)
- Link.timeAtBeat ss beat (cQuantum config)
-
-addMicrosToOsc :: Link.Micros -> O.Time -> O.Time
-addMicrosToOsc m t = ((fromIntegral m) / 1000000) + t
-
--- clocked assumes tempoMV is empty
-clocked :: Config -> MVar P.ValueMap -> MVar PlayMap -> MVar [TempoAction] -> ActionHandler -> Link.AbletonLink -> IO [ThreadId]
-clocked config stateMV mapMV actionsMV ac abletonLink
- = do -- TODO - do something with thread id
- clockTid <- forkIO $ loopInit
- return $! [clockTid]
- where frameTimespan :: Link.Micros
- frameTimespan = round $ (cFrameTimespan config) * 1000000
- quantum :: CDouble
- quantum = cQuantum config
- beatsPerCycle :: CDouble
- beatsPerCycle = cBeatsPerCycle config
- loopInit :: IO a
- loopInit =
- do
- when (cEnableLink config) $ Link.enable abletonLink
- sessionState <- Link.createAndCaptureAppSessionState abletonLink
- now <- Link.clock abletonLink
- let startAt = now + processAhead
- Link.requestBeatAtTime sessionState 0 startAt quantum
- Link.commitAndDestroyAppSessionState abletonLink sessionState
- putMVar actionsMV []
- let st = State {ticks = 0,
- start = now,
- nowArc = P.Arc 0 0,
- nudged = 0
- }
- checkArc $! st
- -- Time is processed at a fixed rate according to configuration
- -- logicalTime gives the time when a tick starts based on when
- -- processing first started.
- logicalTime :: Link.Micros -> Int64 -> Link.Micros
- logicalTime startTime ticks' = startTime + ticks' * frameTimespan
- -- tick moves the logical time forward or recalculates the ticks in case
- -- the logical time is out of sync with Link time.
- -- tick delays the thread when logical time is ahead of Link time.
- tick :: State -> IO a
- tick st = do
- now <- Link.clock abletonLink
- let preferredNewTick = ticks st + 1
- logicalNow = logicalTime (start st) preferredNewTick
- aheadOfNow = now + processAhead
- actualTick = (aheadOfNow - start st) `div` frameTimespan
- drifted = abs (actualTick - preferredNewTick) > cSkipTicks config
- newTick | drifted = actualTick
- | otherwise = preferredNewTick
- st' = st {ticks = newTick}
- delta = min frameTimespan (logicalNow - aheadOfNow)
- if drifted
- then writeError $ "skip: " ++ (show (actualTick - ticks st))
- else when (delta > 0) $ threadDelay $ fromIntegral delta
- checkArc st'
- -- 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
- -- all events in the nowArc to hit the speaker, but not too early.
- -- Processing thus needs to happen a short while before the start
- -- of nowArc. How far ahead is controlled by cProcessAhead.
- processAhead :: Link.Micros
- processAhead = round $ (cProcessAhead config) * 1000000
- checkArc :: State -> IO a
- checkArc st = do
- actions <- swapMVar actionsMV []
- st' <- processActions st actions
- let logicalEnd = logicalTime (start st') $ ticks st' + 1
- nextArcStartCycle = P.stop $ nowArc st'
- ss <- Link.createAndCaptureAppSessionState abletonLink
- arcStartTime <- cyclesToTime config ss nextArcStartCycle
- Link.destroySessionState ss
- if (arcStartTime < logicalEnd)
- then processArc st'
- else tick st'
- processArc :: State -> IO a
- processArc st =
- do
- streamState <- takeMVar stateMV
- let logicalEnd = logicalTime (start st) $ ticks st + 1
- startCycle = P.stop $ nowArc st
- sessionState <- Link.createAndCaptureAppSessionState abletonLink
- endCycle <- timeToCycles' config sessionState logicalEnd
- let st' = st {nowArc = P.Arc startCycle endCycle}
- nowOsc <- O.time
- nowLink <- Link.clock abletonLink
- let ops = LinkOperations {
- timeAtBeat = \beat -> Link.timeAtBeat sessionState beat quantum ,
- timeToCycles = timeToCycles' config sessionState,
- getTempo = Link.getTempo sessionState,
- setTempo = Link.setTempo sessionState,
- linkToOscTime = \lt -> addMicrosToOsc (lt - nowLink) nowOsc,
- beatToCycles = btc,
- cyclesToBeat = ctb
- }
- let state = TickState {
- tickArc = nowArc st',
- tickNudge = nudged st'
- }
- streamState' <- (onTick ac) state ops streamState
- Link.commitAndDestroyAppSessionState abletonLink sessionState
- putMVar stateMV streamState'
- tick st'
- btc :: CDouble -> CDouble
- btc beat = beat / beatsPerCycle
- ctb :: CDouble -> CDouble
- ctb cyc = cyc * beatsPerCycle
- processActions :: State -> [TempoAction] -> IO State
- processActions st [] = return $! st
- processActions st actions = do
- streamState <- takeMVar stateMV
- (st', streamState') <- handleActions st actions streamState
- putMVar stateMV streamState'
- return $! st'
- handleActions :: State -> [TempoAction] -> P.ValueMap -> IO (State, P.ValueMap)
- handleActions st [] streamState = return (st, streamState)
- handleActions st (SetCycle cyc : otherActions) streamState =
- do
- (st', streamState') <- handleActions st otherActions streamState
- sessionState <- Link.createAndCaptureAppSessionState abletonLink
-
- now <- Link.clock abletonLink
- let startAt = now + processAhead
- beat = (fromRational cyc) * (cBeatsPerCycle config)
- Link.requestBeatAtTime sessionState beat startAt quantum
- Link.commitAndDestroyAppSessionState abletonLink sessionState
-
-
- let st'' = st' {
- ticks = 0,
- start = now,
- nowArc = P.Arc cyc cyc
- }
-
- return (st'', streamState')
- handleActions st (SingleTick pat : otherActions) streamState =
- do
- (st', streamState') <- handleActions st otherActions streamState
- -- onSingleTick assumes it runs at beat 0.
- -- The best way to achieve that is to use forceBeatAtTime.
- -- But using forceBeatAtTime means we can not commit its session state.
- -- Another session state, which we will commit,
- -- is introduced to keep track of tempo changes.
- sessionState <- Link.createAndCaptureAppSessionState abletonLink
- zeroedSessionState <- Link.createAndCaptureAppSessionState abletonLink
- nowOsc <- O.time
- nowLink <- Link.clock abletonLink
- Link.forceBeatAtTime zeroedSessionState 0 (nowLink + processAhead) quantum
- let ops = LinkOperations {
- timeAtBeat = \beat -> Link.timeAtBeat zeroedSessionState beat quantum,
- timeToCycles = timeToCycles' config zeroedSessionState,
- getTempo = Link.getTempo zeroedSessionState,
- setTempo = \bpm micros ->
- Link.setTempo zeroedSessionState bpm micros >>
- Link.setTempo sessionState bpm micros,
- linkToOscTime = \lt -> addMicrosToOsc (lt - nowLink) nowOsc,
- beatToCycles = btc,
- cyclesToBeat = ctb
- }
- streamState'' <- (onSingleTick ac) ops streamState' pat
- Link.commitAndDestroyAppSessionState abletonLink sessionState
- Link.destroySessionState zeroedSessionState
- return (st', streamState'')
- handleActions st (SetNudge nudge : otherActions) streamState =
- do
- (st', streamState') <- handleActions st otherActions streamState
- let st'' = st' {nudged = nudge}
- return (st'', streamState')
- handleActions st (StreamReplace k pat : otherActions) streamState =
- do
- (st', streamState') <- handleActions st otherActions streamState
- E.catch (
- do
- now <- Link.clock abletonLink
- sessionState <- Link.createAndCaptureAppSessionState abletonLink
- cyc <- timeToCycles' config sessionState now
- Link.destroySessionState sessionState
- (updatePattern ac) k cyc pat
- return (st', streamState')
- )
- (\(e :: E.SomeException) -> do
- hPutStrLn stderr $ "Error in pattern: " ++ show e
- return (st', streamState')
- )
- handleActions st (Transition historyFlag f patId pat : otherActions) streamState =
- do
- (st', streamState') <- handleActions st otherActions streamState
- let
- appendPat flag = if flag then (pat:) else id
- updatePS (Just playState) = playState {history = (appendPat historyFlag) (history playState)}
- updatePS Nothing = PlayState {pattern = P.silence,
- mute = False,
- solo = False,
- history = (appendPat historyFlag) (P.silence:[])
- }
- transition' pat' = do now <- Link.clock abletonLink
- ss <- Link.createAndCaptureAppSessionState abletonLink
- c <- timeToCycles' config ss now
- return $! f c pat'
- pMap <- readMVar mapMV
- let playState = updatePS $ Map.lookup (fromID patId) pMap
- pat' <- transition' $ appendPat (not historyFlag) (history playState)
- let pMap' = Map.insert (fromID patId) (playState {pattern = pat'}) pMap
- _ <- swapMVar mapMV pMap'
- return (st', streamState')
diff --git a/src/Sound/Tidal/Transition.hs b/src/Sound/Tidal/Transition.hs
index c4139325b..1a168cf1f 100644
--- a/src/Sound/Tidal/Transition.hs
+++ b/src/Sound/Tidal/Transition.hs
@@ -4,18 +4,20 @@ module Sound.Tidal.Transition where
import Prelude hiding ((<*), (*>))
-import Control.Concurrent.MVar (modifyMVar_)
+import Control.Concurrent.MVar (readMVar, swapMVar)
import qualified Data.Map.Strict as Map
-- import Data.Maybe (fromJust)
import Sound.Tidal.Control
import Sound.Tidal.Core
+import Sound.Tidal.Config
import Sound.Tidal.ID
import Sound.Tidal.Params (gain, pan)
import Sound.Tidal.Pattern
import Sound.Tidal.Stream
-import Sound.Tidal.Tempo as T
+import qualified Sound.Tidal.Clock as Clock
+-- import Sound.Tidal.Tempo as T
import Sound.Tidal.UI (fadeOutFrom, fadeInFrom)
import Sound.Tidal.Utils (enumerate)
@@ -37,11 +39,30 @@ import Sound.Tidal.Utils (enumerate)
along with this library. If not, see .
-}
+type TransitionMapper = Time -> [ControlPattern] -> ControlPattern
+
-- Evaluation of pat is forced so exceptions are picked up here, before replacing the existing pattern.
-- the "historyFlag" determines if the new pattern should be placed on the history stack or not
-transition :: Stream -> Bool -> (Time -> [ControlPattern] -> ControlPattern) -> ID -> ControlPattern -> IO ()
-transition stream historyFlag f patId !pat =
- modifyMVar_ (sActionsMV stream) (\actions -> return $! (T.Transition historyFlag f patId pat) : actions)
+transition :: Stream -> Bool -> TransitionMapper -> ID -> ControlPattern -> IO ()
+transition stream historyFlag mapper patId !pat = do
+ let
+ appendPat flag = if flag then (pat:) else id
+ updatePS (Just playState) = playState {history = (appendPat historyFlag) (history playState)}
+ updatePS Nothing = PlayState {pattern = silence,
+ mute = False,
+ solo = False,
+ history = (appendPat historyFlag) (silence:[])
+ }
+ transition' pat' = do
+ t <- Clock.getCycleTime (cClockConfig $ sConfig stream) (sClockRef stream)
+ return $! mapper t pat'
+ pMap <- readMVar (sPMapMV stream)
+ let playState = updatePS $ Map.lookup (fromID patId) pMap
+ pat' <- transition' $ appendPat (not historyFlag) (history playState)
+ let pMap' = Map.insert (fromID patId) (playState {pattern = pat'}) pMap
+ _ <- swapMVar (sPMapMV stream) pMap'
+ return ()
+
mortalOverlay :: Time -> Time -> [Pattern a] -> Pattern a
mortalOverlay _ _ [] = silence
diff --git a/tidal.cabal b/tidal.cabal
index d242b7eb7..2ee6aff97 100644
--- a/tidal.cabal
+++ b/tidal.cabal
@@ -44,7 +44,6 @@ library
Sound.Tidal.Simple
Sound.Tidal.Stream
Sound.Tidal.StreamTypes
- Sound.Tidal.Tempo
Sound.Tidal.Time
Sound.Tidal.Transition
Sound.Tidal.UI
@@ -67,7 +66,7 @@ library
, random < 1.3
, exceptions < 0.11
, mtl >= 2.2
- , tidal-link == 1.0.2
+ , tidal-link == 1.0.3
test-suite tests
type: exitcode-stdio-1.0