From 521212e50ddc47a66f15c65bd4d39f446eb814f5 Mon Sep 17 00:00:00 2001 From: polymorphicengine Date: Thu, 28 Dec 2023 09:22:02 +0100 Subject: [PATCH 01/14] bump version and add dependencies --- tidal-link/tidal-link.cabal | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/tidal-link/tidal-link.cabal b/tidal-link/tidal-link.cabal index 5f3e80f6d..956092eea 100644 --- a/tidal-link/tidal-link.cabal +++ b/tidal-link/tidal-link.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: tidal-link -version: 1.0.2 +version: 1.0.3 synopsis: Ableton Link integration for Tidal -- description: homepage: http://tidalcycles.org/ @@ -29,9 +29,12 @@ library default-language: Haskell2010 exposed-modules: Sound.Tidal.Link + Sound.Tidal.Clock build-depends: - base >=4.8 && <5 + base >=4.8 && <5, + hosc, + mtl if os(windows) extra-libraries: @@ -46,7 +49,7 @@ library else cxx-options: -DLINK_PLATFORM_LINUX=1 -std=c++14 -Wno-multichar -Wno-subobject-linkage - + if impl(ghc >= 9.4) build-depends: system-cxx-std-lib else From 96a25497ed377f1bd7bdf677e219c82eb167a3a2 Mon Sep 17 00:00:00 2001 From: polymorphicengine Date: Thu, 28 Dec 2023 09:47:36 +0100 Subject: [PATCH 02/14] add clock module as a replacement for the Tempo.hs module. doesn't rely on tidals types and can act as a general purpose ableton link based clock for timed processes --- tidal-link/src/hs/Sound/Tidal/Clock.hs | 323 +++++++++++++++++++++++++ 1 file changed, 323 insertions(+) create mode 100644 tidal-link/src/hs/Sound/Tidal/Clock.hs diff --git a/tidal-link/src/hs/Sound/Tidal/Clock.hs b/tidal-link/src/hs/Sound/Tidal/Clock.hs new file mode 100644 index 000000000..247308375 --- /dev/null +++ b/tidal-link/src/hs/Sound/Tidal/Clock.hs @@ -0,0 +1,323 @@ +module Sound.Tidal.Clock where + +import qualified Sound.Tidal.Link as Link +import qualified Sound.Osc.Fd as O + +import Control.Concurrent +import Control.Monad (when) +import Control.Monad.Reader (ReaderT, runReaderT, ask) +import Control.Monad.State (StateT, liftIO, evalStateT, get, put, modify) + +import Foreign.C.Types (CDouble (..)) +import Data.Int (Int64) +import Data.Coerce (coerce) +import System.IO (hPutStrLn, stderr) + +type Time = Rational + +-- | representation of a tick based clock +type Clock + = ReaderT ClockMemory (StateT ClockState IO) + +-- | internal read-only memory of the clock +data ClockMemory + = ClockMemory + {clockConfig :: ClockConfig + ,clockRef :: ClockRef + } + +-- | internal mutable state of the clock +data ClockState + = ClockState + {ticks :: Int64 + ,start :: Link.Micros + ,nowArc :: (Time, Time) + ,nudged :: Double + } deriving Show + +-- | reference to interact with the clock, while it is running +data ClockRef + = ClockRef + {rAction :: MVar ClockAction + ,rAbletonLink :: Link.AbletonLink + } + +-- | configuration of the clock +data ClockConfig + = ClockConfig + {cQuantum :: CDouble + ,cBeatsPerCycle :: CDouble + ,cFrameTimespan :: Double + ,cEnableLink :: Bool + ,cSkipTicks :: Int64 + ,cProcessAhead :: Double + ,cTickAction :: TickAction + } + +-- | action to be executed on a tick, +-- | given the current timespan and nudge +type TickAction + = (Time,Time) -> Double -> LinkOperations -> IO () + +-- | link operations for easy interaction with the clock +data LinkOperations + = LinkOperations + {timeAtBeat :: Link.Beat -> IO Link.Micros + ,timeToCycles :: Link.Micros -> IO Time + ,getTempo :: IO Link.BPM + ,setTempo :: Link.BPM -> Link.Micros -> IO () + ,linkToOscTime :: Link.Micros -> O.Time + ,beatToCycles :: CDouble -> CDouble + ,cyclesToBeat :: CDouble -> CDouble + } + +-- | possible actions for interacting with the clock +data ClockAction + = NoAction + | SetCycle Time + | SetTempo Time + | SetNudge Double + deriving Show + +defaultCps :: O.Time +defaultCps = 0.575 + +defaultConfig :: ClockConfig +defaultConfig = ClockConfig + {cFrameTimespan = 1/20 + ,cEnableLink = True + ,cProcessAhead = 3/10 + ,cSkipTicks = 10 + ,cQuantum = 4 + ,cBeatsPerCycle = 4 + ,cTickAction = \_ _ _ -> return () + } + +-- | creates a clock according to the config and runs it +-- | in a seperate thread +clocked :: ClockConfig -> IO ClockRef +clocked config = runClock config clockCheck + +-- | runs the clock on the initial state and memory as given +-- | by initClock, hands the ClockRef for interaction from outside +runClock :: ClockConfig -> Clock () -> IO ClockRef +runClock config clock = do + (mem, st) <- initClock config + _ <- forkIO $ evalStateT (runReaderT clock mem) st + return (clockRef mem) + +-- | creates a ableton link instance and an MVar for interacting +-- | with the clock from outside and computes the initial clock state +initClock :: ClockConfig -> IO (ClockMemory, ClockState) +initClock config = do + abletonLink <- Link.create bpm + when (cEnableLink config) $ Link.enable abletonLink + sessionState <- Link.createAndCaptureAppSessionState abletonLink + now <- Link.clock abletonLink + let startAt = now + processAhead + Link.requestBeatAtTime sessionState 0 startAt (cQuantum config) + Link.commitAndDestroyAppSessionState abletonLink sessionState + clockMV <- newMVar NoAction + let st = ClockState {ticks = 0, + start = now, + nowArc = (0,0), + nudged = 0 + } + return (ClockMemory config (ClockRef clockMV abletonLink), st) + where processAhead = round $ (cProcessAhead config) * 1000000 + bpm = (coerce defaultCps) * 60 * (cBeatsPerCycle config) + + +-- 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. + +-- previously called checkArc +clockCheck :: Clock () +clockCheck = do + (ClockMemory config (ClockRef clockMV abletonLink)) <- ask + + action <- liftIO $ swapMVar clockMV NoAction + 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 + +-- 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 :: Clock () +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 + 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) + newTick | drifted = actualTick + | otherwise = preferredNewTick + delta = min frameTimespan (logicalNow - aheadOfNow) + + put $ st {ticks = newTick} + + if drifted + then liftIO $ hPutStrLn stderr $ "skip: " ++ (show (actualTick - ticks st)) + else when (delta > 0) $ liftIO $ threadDelay $ fromIntegral delta + + clockCheck + +-- previously called processArc +-- hands the current link operations to the TickAction +clockProcess :: Clock () +clockProcess = do + (ClockMemory config (ClockRef _ abletonLink)) <- ask + st <- get + let logicalEnd = logicalTime config (start st) $ ticks st + 1 + startCycle = arcEnd $ nowArc st + + sessionState <- liftIO $ Link.createAndCaptureAppSessionState abletonLink + endCycle <- liftIO $ timeToCycles' config sessionState logicalEnd + + let st' = st {nowArc = (startCycle,endCycle)} + + nowOsc <- O.time + nowLink <- liftIO $ Link.clock abletonLink + + let ops = LinkOperations { + timeAtBeat = \beat -> Link.timeAtBeat sessionState beat (cQuantum config) , + timeToCycles = timeToCycles' config sessionState, + getTempo = Link.getTempo sessionState, + setTempo = Link.setTempo sessionState, + linkToOscTime = \lt -> addMicrosToOsc (lt - nowLink) nowOsc, + beatToCycles = \beat -> beat / (cBeatsPerCycle config), + cyclesToBeat = \cyc -> cyc * (cBeatsPerCycle config) + } + + liftIO $ (cTickAction config) (nowArc st') (nudged st') ops + + liftIO $ Link.commitAndDestroyAppSessionState abletonLink sessionState + + put st' + tick + +processAction :: ClockAction -> Clock () +processAction NoAction = return () +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 (SetCycle cyc) = do + (ClockMemory config (ClockRef _ abletonLink)) <- ask + sessionState <- liftIO $ Link.createAndCaptureAppSessionState abletonLink + + now <- liftIO $ Link.clock abletonLink + let processAhead = round $ (cProcessAhead config) * 1000000 + startAt = now + processAhead + beat = (fromRational cyc) * (cBeatsPerCycle config) + liftIO $ Link.requestBeatAtTime sessionState beat startAt (cQuantum config) + liftIO $ Link.commitAndDestroyAppSessionState abletonLink sessionState + + modify (\st -> st {ticks = 0, start = now, nowArc = (cyc,cyc)}) + +--------------------------------------------------------------- +-------------------- helper functions ------------------------- +--------------------------------------------------------------- + +arcStart :: (Time, Time) -> Time +arcStart = fst + +arcEnd :: (Time, Time) -> Time +arcEnd = snd + +timeToCycles' :: ClockConfig -> Link.SessionState -> Link.Micros -> IO 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 :: ClockConfig -> Link.SessionState -> 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 + +-- 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 :: ClockConfig -> Link.Micros -> Int64 -> Link.Micros +logicalTime config startTime ticks' = startTime + ticks' * frameTimespan + where frameTimespan = round $ (cFrameTimespan config) * 1000000 + +--------------------------------------------------------------- +----------- functions for interacting with the clock ---------- +--------------------------------------------------------------- + +getBPM :: ClockRef -> IO Time +getBPM (ClockRef _ abletonLink) = do + ss <- Link.createAndCaptureAppSessionState abletonLink + bpm <- Link.getTempo ss + Link.commitAndDestroyAppSessionState abletonLink ss + return $! toRational bpm + +getCPS :: ClockConfig -> ClockRef -> IO Time +getCPS config ref = fmap (\bpm -> bpm / (toRational $ cBeatsPerCycle config) / 60) (getBPM ref) + +getCycleTime :: ClockConfig -> ClockRef -> IO Time +getCycleTime config (ClockRef _ abletonLink) = do + now <- Link.clock abletonLink + ss <- Link.createAndCaptureAppSessionState abletonLink + c <- timeToCycles' config ss now + Link.commitAndDestroyAppSessionState abletonLink ss + return $! c + +getLinkOperations :: ClockConfig -> ClockRef -> IO LinkOperations +getLinkOperations config (ClockRef _ abletonLink) = do + sessionState <- Link.createAndCaptureAppSessionState abletonLink + + nowOsc <- O.time + nowLink <- Link.clock abletonLink + Link.commitAndDestroyAppSessionState abletonLink sessionState + + return $ LinkOperations { + timeAtBeat = \beat -> Link.timeAtBeat sessionState beat (cQuantum config) , + timeToCycles = timeToCycles' config sessionState, + getTempo = Link.getTempo sessionState, + setTempo = Link.setTempo sessionState, + linkToOscTime = \lt -> addMicrosToOsc (lt - nowLink) nowOsc, + beatToCycles = \beat -> beat / (cBeatsPerCycle config), + cyclesToBeat = \cyc -> cyc * (cBeatsPerCycle config) + } + +resetClock :: ClockRef -> IO () +resetClock clock = setClock clock 0 + +setClock :: ClockRef -> Time -> IO () +setClock (ClockRef clock _) t = modifyMVar_ clock (const $ return $ SetCycle t) + +setBPM :: ClockRef -> Time -> IO () +setBPM (ClockRef clock _) t = modifyMVar_ clock (const $ return $ SetTempo t) + +setNudge :: ClockRef -> Double -> IO () +setNudge (ClockRef clock _) n = modifyMVar_ clock (const $ return $ SetNudge n) From dcc7ddfa00d50dcb2f2e592443a82518797b5efe Mon Sep 17 00:00:00 2001 From: polymorphicengine Date: Fri, 29 Dec 2023 14:07:37 +0100 Subject: [PATCH 03/14] fix getLinkOperations --- tidal-link/src/hs/Sound/Tidal/Clock.hs | 56 +++++++++++++++++--------- 1 file changed, 37 insertions(+), 19 deletions(-) diff --git a/tidal-link/src/hs/Sound/Tidal/Clock.hs b/tidal-link/src/hs/Sound/Tidal/Clock.hs index 247308375..f09374298 100644 --- a/tidal-link/src/hs/Sound/Tidal/Clock.hs +++ b/tidal-link/src/hs/Sound/Tidal/Clock.hs @@ -278,7 +278,7 @@ getBPM :: ClockRef -> IO Time getBPM (ClockRef _ abletonLink) = do ss <- Link.createAndCaptureAppSessionState abletonLink bpm <- Link.getTempo ss - Link.commitAndDestroyAppSessionState abletonLink ss + Link.destroySessionState ss return $! toRational bpm getCPS :: ClockConfig -> ClockRef -> IO Time @@ -289,26 +289,40 @@ getCycleTime config (ClockRef _ abletonLink) = do now <- Link.clock abletonLink ss <- Link.createAndCaptureAppSessionState abletonLink c <- timeToCycles' config ss now - Link.commitAndDestroyAppSessionState abletonLink ss + Link.destroySessionState ss return $! c -getLinkOperations :: ClockConfig -> ClockRef -> IO LinkOperations -getLinkOperations config (ClockRef _ abletonLink) = do - sessionState <- Link.createAndCaptureAppSessionState abletonLink - - nowOsc <- O.time - nowLink <- Link.clock abletonLink - Link.commitAndDestroyAppSessionState abletonLink sessionState - - return $ LinkOperations { - timeAtBeat = \beat -> Link.timeAtBeat sessionState beat (cQuantum config) , - timeToCycles = timeToCycles' config sessionState, - getTempo = Link.getTempo sessionState, - setTempo = Link.setTempo sessionState, - linkToOscTime = \lt -> addMicrosToOsc (lt - nowLink) nowOsc, - beatToCycles = \beat -> beat / (cBeatsPerCycle config), - cyclesToBeat = \cyc -> cyc * (cBeatsPerCycle config) - } +-- 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. +getZeroedLinkOperations :: ClockConfig -> ClockRef -> IO LinkOperations +getZeroedLinkOperations config (ClockRef _ abletonLink) = do + sessionState <- Link.createAndCaptureAppSessionState abletonLink + zeroedSessionState <- Link.createAndCaptureAppSessionState abletonLink + + nowOsc <- O.time + nowLink <- Link.clock abletonLink + + Link.forceBeatAtTime zeroedSessionState 0 (nowLink + processAhead) (cQuantum config) + + Link.commitAndDestroyAppSessionState abletonLink sessionState + Link.destroySessionState zeroedSessionState + + return $ LinkOperations { + timeAtBeat = \beat -> Link.timeAtBeat zeroedSessionState beat (cQuantum config), + 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 = \beat -> beat / (cBeatsPerCycle config), + cyclesToBeat = \cyc -> cyc * (cBeatsPerCycle config) + } + where processAhead = round $ (cProcessAhead config) * 1000000 + resetClock :: ClockRef -> IO () resetClock clock = setClock clock 0 @@ -319,5 +333,9 @@ setClock (ClockRef clock _) t = modifyMVar_ clock (const $ return $ SetCycle t) setBPM :: ClockRef -> Time -> IO () setBPM (ClockRef clock _) t = modifyMVar_ clock (const $ return $ SetTempo t) +setCPS :: ClockConfig -> ClockRef -> Time -> IO () +setCPS config ref cps = setBPM ref bpm + where bpm = cps * 60 * (toRational $ cBeatsPerCycle config) + setNudge :: ClockRef -> Double -> IO () setNudge (ClockRef clock _) n = modifyMVar_ clock (const $ return $ SetNudge n) From 2817b228840920190a659ece588584d876e1c826 Mon Sep 17 00:00:00 2001 From: polymorphicengine Date: Fri, 29 Dec 2023 14:08:22 +0100 Subject: [PATCH 04/14] remove Tempo.hs in favor of the new Clock module from tidal-link and reintegrate everything --- src/Sound/Tidal/Config.hs | 17 +- src/Sound/Tidal/Stream.hs | 184 +++++++++------------ src/Sound/Tidal/Tempo.hs | 300 ---------------------------------- src/Sound/Tidal/Transition.hs | 31 +++- tidal.cabal | 3 +- 5 files changed, 110 insertions(+), 425 deletions(-) delete mode 100644 src/Sound/Tidal/Tempo.hs 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 From 02883d5dc20f08ec896b0b06b6231d9da7e567f4 Mon Sep 17 00:00:00 2001 From: polymorphicengine Date: Fri, 29 Dec 2023 17:46:10 +0100 Subject: [PATCH 05/14] fix listener --- tidal-listener/src/Sound/Tidal/Listener.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tidal-listener/src/Sound/Tidal/Listener.hs b/tidal-listener/src/Sound/Tidal/Listener.hs index 33f1e8277..db514fef6 100644 --- a/tidal-listener/src/Sound/Tidal/Listener.hs +++ b/tidal-listener/src/Sound/Tidal/Listener.hs @@ -1,7 +1,7 @@ {-# LANGUAGE RecordWildCards #-} module Sound.Tidal.Listener where -import Sound.Tidal.Stream (streamGetcps) +import Sound.Tidal.Stream (streamGetCPS) import qualified Sound.Tidal.Context as T import Sound.Tidal.Hint import Sound.Tidal.Listener.Config @@ -92,7 +92,7 @@ act st (Just (Message "/ping" [])) = -- get the current cps of the running stream act st (Just (Message "/cps" [])) = - do cps <- streamGetcps (sStream st) + do cps <- streamGetCPS (sStream st) O.sendTo (sLocal st) (O.p_message "/cps" [float cps]) (sRemote st) return st From e73b570aba600a7543c8f7e4e1f6523bb8a4f84d Mon Sep 17 00:00:00 2001 From: polymorphicengine Date: Sat, 30 Dec 2023 16:25:27 +0100 Subject: [PATCH 06/14] change defaultCps to Double --- 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 f09374298..b103b5d54 100644 --- a/tidal-link/src/hs/Sound/Tidal/Clock.hs +++ b/tidal-link/src/hs/Sound/Tidal/Clock.hs @@ -79,7 +79,7 @@ data ClockAction | SetNudge Double deriving Show -defaultCps :: O.Time +defaultCps :: Double defaultCps = 0.575 defaultConfig :: ClockConfig From 95b1763bd58a940b242fa94393b594aaff82af6a Mon Sep 17 00:00:00 2001 From: polymorphicengine Date: Sat, 30 Dec 2023 16:30:28 +0100 Subject: [PATCH 07/14] move tickAction outside of config --- src/Sound/Tidal/Stream.hs | 2 +- tidal-link/src/hs/Sound/Tidal/Clock.hs | 31 +++++++++++++------------- 2 files changed, 16 insertions(+), 17 deletions(-) diff --git a/src/Sound/Tidal/Stream.hs b/src/Sound/Tidal/Stream.hs index 5c387b13d..8ea81ff84 100644 --- a/src/Sound/Tidal/Stream.hs +++ b/src/Sound/Tidal/Stream.hs @@ -219,7 +219,7 @@ startStream config oscmap return $ Cx {cxUDP = u, cxAddr = remote_addr, cxBusAddr = remote_bus_addr, cxTarget = target, cxOSCs = os} ) oscmap - clockRef <- Clock.clocked ((cClockConfig config) {Clock.cTickAction = doTick sMapMV bussesMV pMapMV globalFMV cxs listen}) + clockRef <- Clock.clocked (cClockConfig config) (doTick sMapMV bussesMV pMapMV globalFMV cxs listen) let stream = Stream {sConfig = config, sBusses = bussesMV, diff --git a/tidal-link/src/hs/Sound/Tidal/Clock.hs b/tidal-link/src/hs/Sound/Tidal/Clock.hs index b103b5d54..e610c8016 100644 --- a/tidal-link/src/hs/Sound/Tidal/Clock.hs +++ b/tidal-link/src/hs/Sound/Tidal/Clock.hs @@ -24,6 +24,7 @@ data ClockMemory = ClockMemory {clockConfig :: ClockConfig ,clockRef :: ClockRef + ,clockAction :: TickAction } -- | internal mutable state of the clock @@ -51,7 +52,6 @@ data ClockConfig ,cEnableLink :: Bool ,cSkipTicks :: Int64 ,cProcessAhead :: Double - ,cTickAction :: TickAction } -- | action to be executed on a tick, @@ -90,26 +90,25 @@ defaultConfig = ClockConfig ,cSkipTicks = 10 ,cQuantum = 4 ,cBeatsPerCycle = 4 - ,cTickAction = \_ _ _ -> return () } -- | creates a clock according to the config and runs it -- | in a seperate thread -clocked :: ClockConfig -> IO ClockRef -clocked config = runClock config clockCheck +clocked :: ClockConfig -> TickAction -> IO ClockRef +clocked config ac = runClock config ac clockCheck -- | runs the clock on the initial state and memory as given -- | by initClock, hands the ClockRef for interaction from outside -runClock :: ClockConfig -> Clock () -> IO ClockRef -runClock config clock = do - (mem, st) <- initClock config +runClock :: ClockConfig -> TickAction -> Clock () -> IO ClockRef +runClock config ac clock = do + (mem, st) <- initClock config ac _ <- forkIO $ evalStateT (runReaderT clock mem) st return (clockRef mem) -- | creates a ableton link instance and an MVar for interacting -- | with the clock from outside and computes the initial clock state -initClock :: ClockConfig -> IO (ClockMemory, ClockState) -initClock config = do +initClock :: ClockConfig -> TickAction -> IO (ClockMemory, ClockState) +initClock config ac = do abletonLink <- Link.create bpm when (cEnableLink config) $ Link.enable abletonLink sessionState <- Link.createAndCaptureAppSessionState abletonLink @@ -123,7 +122,7 @@ initClock config = do nowArc = (0,0), nudged = 0 } - return (ClockMemory config (ClockRef clockMV abletonLink), st) + return (ClockMemory config (ClockRef clockMV abletonLink) ac, st) where processAhead = round $ (cProcessAhead config) * 1000000 bpm = (coerce defaultCps) * 60 * (cBeatsPerCycle config) @@ -138,7 +137,7 @@ initClock config = do -- previously called checkArc clockCheck :: Clock () clockCheck = do - (ClockMemory config (ClockRef clockMV abletonLink)) <- ask + (ClockMemory config (ClockRef clockMV abletonLink) _) <- ask action <- liftIO $ swapMVar clockMV NoAction processAction action @@ -161,7 +160,7 @@ clockCheck = do -- tick delays the thread when logical time is ahead of Link time. tick :: Clock () tick = do - (ClockMemory config (ClockRef _ abletonLink)) <- ask + (ClockMemory config (ClockRef _ abletonLink) _) <- ask st <- get now <- liftIO $ Link.clock abletonLink let processAhead = round $ (cProcessAhead config) * 1000000 @@ -187,7 +186,7 @@ tick = do -- hands the current link operations to the TickAction clockProcess :: Clock () clockProcess = do - (ClockMemory config (ClockRef _ abletonLink)) <- ask + (ClockMemory config (ClockRef _ abletonLink) action) <- ask st <- get let logicalEnd = logicalTime config (start st) $ ticks st + 1 startCycle = arcEnd $ nowArc st @@ -210,7 +209,7 @@ clockProcess = do cyclesToBeat = \cyc -> cyc * (cBeatsPerCycle config) } - liftIO $ (cTickAction config) (nowArc st') (nudged st') ops + liftIO $ action (nowArc st') (nudged st') ops liftIO $ Link.commitAndDestroyAppSessionState abletonLink sessionState @@ -221,13 +220,13 @@ processAction :: ClockAction -> Clock () processAction NoAction = return () processAction (SetNudge n) = modify (\st -> st {nudged = n}) processAction (SetTempo bpm) = do - (ClockMemory _ (ClockRef _ abletonLink)) <- ask + (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 - (ClockMemory config (ClockRef _ abletonLink)) <- ask + (ClockMemory config (ClockRef _ abletonLink) _) <- ask sessionState <- liftIO $ Link.createAndCaptureAppSessionState abletonLink now <- liftIO $ Link.clock abletonLink From cf95e13a15678050b0fb0f36174b6bf3d7953fdf Mon Sep 17 00:00:00 2001 From: polymorphicengine Date: Sat, 30 Dec 2023 18:51:49 +0100 Subject: [PATCH 08/14] fix dontcrash --- test/dontcrash.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/dontcrash.hs b/test/dontcrash.hs index 166ebd956..e6194110b 100644 --- a/test/dontcrash.hs +++ b/test/dontcrash.hs @@ -9,7 +9,7 @@ import Sound.Tidal.Context main = do - tidal <- startTidal (superdirtTarget {oLatency = 0.1, oAddress = "127.0.0.1", oPort = 57120}) (defaultConfig {cFrameTimespan = 1/20}) + tidal <- startTidal (superdirtTarget {oLatency = 0.1, oAddress = "127.0.0.1", oPort = 57120}) (defaultConfig) let p = streamReplace tidal d1 = p 1 . (|< orbit 0) From 3fedf105adea5d26b0bd2c13afbb61e2f8ba21db Mon Sep 17 00:00:00 2001 From: polymorphicengine Date: Sat, 30 Dec 2023 18:58:04 +0100 Subject: [PATCH 09/14] add ability to enable/disable link clock and make default link False, see #1060 --- src/Sound/Tidal/Stream.hs | 6 ++++++ tidal-link/src/hs/Sound/Tidal/Clock.hs | 8 +++++++- 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/src/Sound/Tidal/Stream.hs b/src/Sound/Tidal/Stream.hs index 8ea81ff84..918c2b1f7 100644 --- a/src/Sound/Tidal/Stream.hs +++ b/src/Sound/Tidal/Stream.hs @@ -561,6 +561,12 @@ streamGetBPM s = Clock.getBPM (sClockRef s) streamGetNow :: Stream -> IO Time streamGetNow s = Clock.getCycleTime (cClockConfig $ sConfig s)(sClockRef s) +streamEnableLink :: Stream -> IO () +streamEnableLink s = Clock.enableLink (sClockRef s) + +streamDisableLink :: Stream -> IO () +streamDisableLink s = Clock.disableLink (sClockRef s) + hasSolo :: Map.Map k PlayState -> Bool hasSolo = (>= 1) . length . filter solo . Map.elems diff --git a/tidal-link/src/hs/Sound/Tidal/Clock.hs b/tidal-link/src/hs/Sound/Tidal/Clock.hs index e610c8016..da7726c35 100644 --- a/tidal-link/src/hs/Sound/Tidal/Clock.hs +++ b/tidal-link/src/hs/Sound/Tidal/Clock.hs @@ -85,7 +85,7 @@ defaultCps = 0.575 defaultConfig :: ClockConfig defaultConfig = ClockConfig {cFrameTimespan = 1/20 - ,cEnableLink = True + ,cEnableLink = False ,cProcessAhead = 3/10 ,cSkipTicks = 10 ,cQuantum = 4 @@ -338,3 +338,9 @@ setCPS config ref cps = setBPM ref bpm setNudge :: ClockRef -> Double -> IO () setNudge (ClockRef clock _) n = modifyMVar_ clock (const $ return $ SetNudge n) + +disableLink :: ClockRef -> IO () +disableLink (ClockRef _ abletonLink) = Link.disable abletonLink + +enableLink :: ClockRef -> IO () +enableLink (ClockRef _ abletonLink) = Link.enable abletonLink From cbf79f720d4873b84a29bd87303ef539f8f6c39e Mon Sep 17 00:00:00 2001 From: polymorphicengine Date: Sat, 30 Dec 2023 20:10:41 +0100 Subject: [PATCH 10/14] fix bootfile --- BootTidal.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/BootTidal.hs b/BootTidal.hs index 1157ec015..c2548d2d3 100644 --- a/BootTidal.hs +++ b/BootTidal.hs @@ -29,8 +29,8 @@ let only = (hush >>) resetCycles = streamResetCycles tidal setCycle = streamSetCycle tidal setcps = asap . cps - getcps = streamGetcps tidal - getnow = streamGetnow tidal + getcps = streamGetCPS tidal + getnow = streamGetNow tidal xfade i = transition tidal True (Sound.Tidal.Transition.xfadeIn 4) i xfadeIn i t = transition tidal True (Sound.Tidal.Transition.xfadeIn t) i histpan i t = transition tidal True (Sound.Tidal.Transition.histpan t) i From 8548cb74015ecb95c08f9e70a0b10f4350160f2c Mon Sep 17 00:00:00 2001 From: polymorphicengine Date: Sat, 30 Dec 2023 20:29:39 +0100 Subject: [PATCH 11/14] catch errors in streamReplace --- src/Sound/Tidal/Stream.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Sound/Tidal/Stream.hs b/src/Sound/Tidal/Stream.hs index 918c2b1f7..d66686048 100644 --- a/src/Sound/Tidal/Stream.hs +++ b/src/Sound/Tidal/Stream.hs @@ -593,11 +593,13 @@ updatePattern stream k !t pat = do 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 stream k !pat = do t <- Clock.getCycleTime (cClockConfig $ sConfig stream) (sClockRef stream) - updatePattern stream k t pat + E.handle (\ (e :: E.SomeException) -> do + hPutStrLn stderr $ "Failed to Stream.streamReplace: " ++ show e + hPutStrLn stderr $ "Return to previous pattern." + setPreviousPatternOrSilence (sPMapMV stream)) (updatePattern stream k t pat) -- = modifyMVar_ (sActionsMV s) (\actions -> return $ (T.StreamReplace k pat) : actions) From 3e4f864e323aa08c013163b77d3638392bf528aa Mon Sep 17 00:00:00 2001 From: polymorphicengine Date: Tue, 2 Jan 2024 10:07:21 +0100 Subject: [PATCH 12/14] switch to TVars to avoid race conditions --- tidal-link/src/hs/Sound/Tidal/Clock.hs | 41 +++++++++++++++++--------- tidal-link/tidal-link.cabal | 3 +- 2 files changed, 29 insertions(+), 15 deletions(-) diff --git a/tidal-link/src/hs/Sound/Tidal/Clock.hs b/tidal-link/src/hs/Sound/Tidal/Clock.hs index da7726c35..1fa5db311 100644 --- a/tidal-link/src/hs/Sound/Tidal/Clock.hs +++ b/tidal-link/src/hs/Sound/Tidal/Clock.hs @@ -3,15 +3,16 @@ module Sound.Tidal.Clock where import qualified Sound.Tidal.Link as Link import qualified Sound.Osc.Fd as O -import Control.Concurrent -import Control.Monad (when) -import Control.Monad.Reader (ReaderT, runReaderT, ask) -import Control.Monad.State (StateT, liftIO, evalStateT, get, put, modify) +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.STM (TVar, atomically, readTVar, newTVar, modifyTVar', swapTVar, retry) +import Control.Monad (when) +import Control.Monad.Reader (ReaderT, runReaderT, ask) +import Control.Monad.State (StateT, liftIO, evalStateT, get, put, modify) -import Foreign.C.Types (CDouble (..)) -import Data.Int (Int64) -import Data.Coerce (coerce) -import System.IO (hPutStrLn, stderr) +import Foreign.C.Types (CDouble (..)) +import Data.Int (Int64) +import Data.Coerce (coerce) +import System.IO (hPutStrLn, stderr) type Time = Rational @@ -39,7 +40,7 @@ data ClockState -- | reference to interact with the clock, while it is running data ClockRef = ClockRef - {rAction :: MVar ClockAction + {rAction :: TVar ClockAction ,rAbletonLink :: Link.AbletonLink } @@ -116,7 +117,7 @@ initClock config ac = do let startAt = now + processAhead Link.requestBeatAtTime sessionState 0 startAt (cQuantum config) Link.commitAndDestroyAppSessionState abletonLink sessionState - clockMV <- newMVar NoAction + clockMV <- atomically $ newTVar NoAction let st = ClockState {ticks = 0, start = now, nowArc = (0,0), @@ -139,7 +140,7 @@ clockCheck :: Clock () clockCheck = do (ClockMemory config (ClockRef clockMV abletonLink) _) <- ask - action <- liftIO $ swapMVar clockMV NoAction + action <- liftIO $ atomically $ swapTVar clockMV NoAction processAction action st <- get @@ -327,17 +328,29 @@ resetClock :: ClockRef -> IO () resetClock clock = setClock clock 0 setClock :: ClockRef -> Time -> IO () -setClock (ClockRef clock _) t = modifyMVar_ clock (const $ return $ SetCycle t) +setClock (ClockRef clock _) t = atomically $ do + action <- readTVar clock + case action of + NoAction -> modifyTVar' clock (const $ SetCycle t) + _ -> retry setBPM :: ClockRef -> Time -> IO () -setBPM (ClockRef clock _) t = modifyMVar_ clock (const $ return $ SetTempo t) +setBPM (ClockRef clock _) t = atomically $ do + action <- readTVar clock + case action of + NoAction -> modifyTVar' clock (const $ SetTempo t) + _ -> retry setCPS :: ClockConfig -> ClockRef -> Time -> IO () setCPS config ref cps = setBPM ref bpm where bpm = cps * 60 * (toRational $ cBeatsPerCycle config) setNudge :: ClockRef -> Double -> IO () -setNudge (ClockRef clock _) n = modifyMVar_ clock (const $ return $ SetNudge n) +setNudge (ClockRef clock _) n = atomically $ do + action <- readTVar clock + case action of + NoAction -> modifyTVar' clock (const $ SetNudge n) + _ -> retry disableLink :: ClockRef -> IO () disableLink (ClockRef _ abletonLink) = Link.disable abletonLink diff --git a/tidal-link/tidal-link.cabal b/tidal-link/tidal-link.cabal index 956092eea..94c169358 100644 --- a/tidal-link/tidal-link.cabal +++ b/tidal-link/tidal-link.cabal @@ -34,7 +34,8 @@ library build-depends: base >=4.8 && <5, hosc, - mtl + mtl, + stm if os(windows) extra-libraries: From 4e7b4ebd2dcfd8205d57326c8a181809a4ffbeaa Mon Sep 17 00:00:00 2001 From: polymorphicengine Date: Fri, 23 Feb 2024 14:24:44 +0100 Subject: [PATCH 13/14] move everything stream related to it's own folder --- src/Sound/Tidal/Context.hs | 4 ++-- src/Sound/Tidal/Control.hs | 2 +- src/Sound/Tidal/Safe/Context.hs | 6 +++--- src/Sound/Tidal/{ => Stream}/Config.hs | 2 +- src/Sound/Tidal/{ => Stream}/Stream.hs | 6 +++--- src/Sound/Tidal/{StreamTypes.hs => Stream/Types.hs} | 2 +- src/Sound/Tidal/Transition.hs | 5 +++-- tidal.cabal | 6 +++--- 8 files changed, 17 insertions(+), 16 deletions(-) rename src/Sound/Tidal/{ => Stream}/Config.hs (97%) rename src/Sound/Tidal/{ => Stream}/Stream.hs (99%) rename src/Sound/Tidal/{StreamTypes.hs => Stream/Types.hs} (94%) diff --git a/src/Sound/Tidal/Context.hs b/src/Sound/Tidal/Context.hs index 3d78630f5..08e63811d 100644 --- a/src/Sound/Tidal/Context.hs +++ b/src/Sound/Tidal/Context.hs @@ -22,7 +22,7 @@ import Prelude hiding ((<*), (*>)) import Data.Ratio as C -import Sound.Tidal.Config as C +import Sound.Tidal.Stream.Config as C import Sound.Tidal.Control as C import Sound.Tidal.Core as C import Sound.Tidal.Params as C @@ -31,7 +31,7 @@ import Sound.Tidal.Pattern as C import Sound.Tidal.Scales as C import Sound.Tidal.Show as C import Sound.Tidal.Simple as C -import Sound.Tidal.Stream as C +import Sound.Tidal.Stream.Stream as C import Sound.Tidal.Transition as C import Sound.Tidal.UI as C import Sound.Tidal.Version as C diff --git a/src/Sound/Tidal/Control.hs b/src/Sound/Tidal/Control.hs index 578051799..603f32e48 100644 --- a/src/Sound/Tidal/Control.hs +++ b/src/Sound/Tidal/Control.hs @@ -29,7 +29,7 @@ import Data.Ratio import Sound.Tidal.Pattern import Sound.Tidal.Core -import Sound.Tidal.StreamTypes (patternTimeID) +import Sound.Tidal.Stream.Types (patternTimeID) import Sound.Tidal.UI import qualified Sound.Tidal.Params as P import Sound.Tidal.Utils diff --git a/src/Sound/Tidal/Safe/Context.hs b/src/Sound/Tidal/Safe/Context.hs index 941a105af..e8d723dfb 100644 --- a/src/Sound/Tidal/Safe/Context.hs +++ b/src/Sound/Tidal/Safe/Context.hs @@ -53,7 +53,7 @@ module Sound.Tidal.Safe.Context where import Data.Ratio as C -import Sound.Tidal.Config as C +import Sound.Tidal.Stream.Config as C import Sound.Tidal.Control as C import Sound.Tidal.Core as C import Sound.Tidal.Params as C @@ -61,7 +61,7 @@ import Sound.Tidal.ParseBP as C import Sound.Tidal.Pattern as C import Sound.Tidal.Scales as C import Sound.Tidal.Simple as C -import Sound.Tidal.Stream +import Sound.Tidal.Stream.Stream (startTidal, superdirtTarget, Target(..)) -- import Sound.Tidal.Transition as C import Sound.Tidal.UI as C @@ -79,7 +79,7 @@ exec :: Stream -> Op r -> IO r exec stream (Op m) = runReaderT m stream op1 f = Op $ do a <- ask; lift $ f a -op2 f b = Op $ do a <- ask; lift $ f a b +op2 f b = Op $ do a <- ask; lift $ f a b op3 f b c = Op $ do a <- ask; lift $ f a b c op4 f b c d = Op $ do a <- ask; lift $ f a b c d op5 f b c d e = Op $ do a <- ask; lift $ f a b c d e diff --git a/src/Sound/Tidal/Config.hs b/src/Sound/Tidal/Stream/Config.hs similarity index 97% rename from src/Sound/Tidal/Config.hs rename to src/Sound/Tidal/Stream/Config.hs index 4691db603..7dcc62f55 100644 --- a/src/Sound/Tidal/Config.hs +++ b/src/Sound/Tidal/Stream/Config.hs @@ -1,4 +1,4 @@ -module Sound.Tidal.Config where +module Sound.Tidal.Stream.Config where import qualified Sound.Tidal.Clock as Clock diff --git a/src/Sound/Tidal/Stream.hs b/src/Sound/Tidal/Stream/Stream.hs similarity index 99% rename from src/Sound/Tidal/Stream.hs rename to src/Sound/Tidal/Stream/Stream.hs index d66686048..8c3e64e38 100644 --- a/src/Sound/Tidal/Stream.hs +++ b/src/Sound/Tidal/Stream/Stream.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-missing-fields #-} {-# language DeriveGeneric, StandaloneDeriving #-} -module Sound.Tidal.Stream (module Sound.Tidal.Stream) where +module Sound.Tidal.Stream.Stream (module Sound.Tidal.Stream.Stream) where {- Stream.hs - Tidal's thingie for turning patterns into OSC streams @@ -38,7 +38,7 @@ import qualified Sound.Osc.Fd as O import qualified Sound.Osc.Time.Timeout as O import qualified Network.Socket as N -import Sound.Tidal.Config +import Sound.Tidal.Stream.Config import Sound.Tidal.Core (stack, (#)) import Sound.Tidal.ID import qualified Sound.Tidal.Link as Link @@ -52,7 +52,7 @@ import Sound.Tidal.Show () import Sound.Tidal.Version -import Sound.Tidal.StreamTypes as Sound.Tidal.Stream +import Sound.Tidal.Stream.Types as Sound.Tidal.Stream data Stream = Stream {sConfig :: Config, sBusses :: MVar [Int], diff --git a/src/Sound/Tidal/StreamTypes.hs b/src/Sound/Tidal/Stream/Types.hs similarity index 94% rename from src/Sound/Tidal/StreamTypes.hs rename to src/Sound/Tidal/Stream/Types.hs index 6b4fa76ea..ba0c789a0 100644 --- a/src/Sound/Tidal/StreamTypes.hs +++ b/src/Sound/Tidal/Stream/Types.hs @@ -1,4 +1,4 @@ -module Sound.Tidal.StreamTypes where +module Sound.Tidal.Stream.Types where import qualified Data.Map.Strict as Map import Sound.Tidal.Pattern diff --git a/src/Sound/Tidal/Transition.hs b/src/Sound/Tidal/Transition.hs index 1a168cf1f..47f6fd1a9 100644 --- a/src/Sound/Tidal/Transition.hs +++ b/src/Sound/Tidal/Transition.hs @@ -11,11 +11,12 @@ import qualified Data.Map.Strict as Map import Sound.Tidal.Control import Sound.Tidal.Core -import Sound.Tidal.Config +import Sound.Tidal.Stream.Config import Sound.Tidal.ID import Sound.Tidal.Params (gain, pan) import Sound.Tidal.Pattern -import Sound.Tidal.Stream +import Sound.Tidal.Stream.Stream +import Sound.Tidal.Stream.Types import qualified Sound.Tidal.Clock as Clock -- import Sound.Tidal.Tempo as T import Sound.Tidal.UI (fadeOutFrom, fadeInFrom) diff --git a/tidal.cabal b/tidal.cabal index 2ee6aff97..e12d00b10 100644 --- a/tidal.cabal +++ b/tidal.cabal @@ -29,7 +29,6 @@ library Exposed-modules: Sound.Tidal.Bjorklund Sound.Tidal.Chords - Sound.Tidal.Config Sound.Tidal.Control Sound.Tidal.Context Sound.Tidal.Core @@ -42,8 +41,9 @@ library Sound.Tidal.Safe.Boot Sound.Tidal.Show Sound.Tidal.Simple - Sound.Tidal.Stream - Sound.Tidal.StreamTypes + Sound.Tidal.Stream.Stream + Sound.Tidal.Stream.Types + Sound.Tidal.Stream.Config Sound.Tidal.Time Sound.Tidal.Transition Sound.Tidal.UI From 8d6bf14ffcb68232a63e849dac33e2981feccced Mon Sep 17 00:00:00 2001 From: polymorphicengine Date: Fri, 23 Feb 2024 18:17:14 +0100 Subject: [PATCH 14/14] complete restructuring of the stream module into separate sub modules --- src/Sound/Tidal/Context.hs | 3 +- src/Sound/Tidal/Safe/Context.hs | 5 +- src/Sound/Tidal/Stream.hs | 35 ++ src/Sound/Tidal/Stream/Config.hs | 12 +- src/Sound/Tidal/Stream/Listen.hs | 118 +++++ src/Sound/Tidal/Stream/Main.hs | 78 ++++ src/Sound/Tidal/Stream/Process.hs | 319 +++++++++++++ src/Sound/Tidal/Stream/Stream.hs | 751 ------------------------------ src/Sound/Tidal/Stream/Target.hs | 156 +++++++ src/Sound/Tidal/Stream/Types.hs | 65 ++- src/Sound/Tidal/Stream/UI.hs | 154 ++++++ src/Sound/Tidal/Transition.hs | 1 - tidal.cabal | 9 +- 13 files changed, 937 insertions(+), 769 deletions(-) create mode 100644 src/Sound/Tidal/Stream.hs create mode 100644 src/Sound/Tidal/Stream/Listen.hs create mode 100644 src/Sound/Tidal/Stream/Main.hs create mode 100644 src/Sound/Tidal/Stream/Process.hs delete mode 100644 src/Sound/Tidal/Stream/Stream.hs create mode 100644 src/Sound/Tidal/Stream/Target.hs create mode 100644 src/Sound/Tidal/Stream/UI.hs diff --git a/src/Sound/Tidal/Context.hs b/src/Sound/Tidal/Context.hs index 08e63811d..057f76061 100644 --- a/src/Sound/Tidal/Context.hs +++ b/src/Sound/Tidal/Context.hs @@ -22,7 +22,7 @@ import Prelude hiding ((<*), (*>)) import Data.Ratio as C -import Sound.Tidal.Stream.Config as C +import Sound.Tidal.Stream as C import Sound.Tidal.Control as C import Sound.Tidal.Core as C import Sound.Tidal.Params as C @@ -31,7 +31,6 @@ import Sound.Tidal.Pattern as C import Sound.Tidal.Scales as C import Sound.Tidal.Show as C import Sound.Tidal.Simple as C -import Sound.Tidal.Stream.Stream as C import Sound.Tidal.Transition as C import Sound.Tidal.UI as C import Sound.Tidal.Version as C diff --git a/src/Sound/Tidal/Safe/Context.hs b/src/Sound/Tidal/Safe/Context.hs index e8d723dfb..afb3754dd 100644 --- a/src/Sound/Tidal/Safe/Context.hs +++ b/src/Sound/Tidal/Safe/Context.hs @@ -61,8 +61,9 @@ import Sound.Tidal.ParseBP as C import Sound.Tidal.Pattern as C import Sound.Tidal.Scales as C import Sound.Tidal.Simple as C -import Sound.Tidal.Stream.Stream - (startTidal, superdirtTarget, Target(..)) +import Sound.Tidal.Stream.Target (superdirtTarget) +import Sound.Tidal.Stream.Types (Target(..)) +import Sound.Tidal.Stream.Main (startTidal) -- import Sound.Tidal.Transition as C import Sound.Tidal.UI as C import Sound.Tidal.Version as C diff --git a/src/Sound/Tidal/Stream.hs b/src/Sound/Tidal/Stream.hs new file mode 100644 index 000000000..318951cf0 --- /dev/null +++ b/src/Sound/Tidal/Stream.hs @@ -0,0 +1,35 @@ +module Sound.Tidal.Stream + (module Sound.Tidal.Stream.Config + ,module Sound.Tidal.Stream.Types + ,module Sound.Tidal.Stream.Process + ,module Sound.Tidal.Stream.Target + ,module Sound.Tidal.Stream.UI + ,module Sound.Tidal.Stream.Listen + ,module Sound.Tidal.Stream.Main + ) where + +import Sound.Tidal.Stream.Config +import Sound.Tidal.Stream.Types +import Sound.Tidal.Stream.Process +import Sound.Tidal.Stream.Target +import Sound.Tidal.Stream.UI +import Sound.Tidal.Stream.Listen +import Sound.Tidal.Stream.Main + +{- + Stream.hs - re-exports of all stream modules + 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 . +-} diff --git a/src/Sound/Tidal/Stream/Config.hs b/src/Sound/Tidal/Stream/Config.hs index 7dcc62f55..295c41c46 100644 --- a/src/Sound/Tidal/Stream/Config.hs +++ b/src/Sound/Tidal/Stream/Config.hs @@ -24,9 +24,9 @@ data Config = Config {cCtrlListen :: Bool, cCtrlAddr :: String, cCtrlPort :: Int, cCtrlBroadcast :: Bool, - cTempoAddr :: String, - cTempoPort :: Int, - cTempoClientPort :: Int, + -- cTempoAddr :: String, + -- cTempoPort :: Int, + -- cTempoClientPort :: Int, cVerbose :: Bool, cClockConfig :: Clock.ClockConfig } @@ -36,9 +36,9 @@ defaultConfig = Config {cCtrlListen = True, cCtrlAddr ="127.0.0.1", cCtrlPort = 6010, cCtrlBroadcast = False, - cTempoAddr = "127.0.0.1", - cTempoPort = 9160, - cTempoClientPort = 0, -- choose at random + -- cTempoAddr = "127.0.0.1", + -- cTempoPort = 9160, + -- cTempoClientPort = 0, -- choose at random cVerbose = True, cClockConfig = Clock.defaultConfig } diff --git a/src/Sound/Tidal/Stream/Listen.hs b/src/Sound/Tidal/Stream/Listen.hs new file mode 100644 index 000000000..8fa61cd47 --- /dev/null +++ b/src/Sound/Tidal/Stream/Listen.hs @@ -0,0 +1,118 @@ +module Sound.Tidal.Stream.Listen where + +import Data.Maybe (fromJust, catMaybes, isJust) +import Control.Concurrent.MVar +import Control.Monad (when) +import System.IO (hPutStrLn, stderr) +import qualified Data.Map as Map +import qualified Sound.Osc.Fd as O +import qualified Sound.Osc.Time.Timeout as O +import qualified Network.Socket as N +import qualified Control.Exception as E + +import Sound.Tidal.ID +import Sound.Tidal.Pattern + +import Sound.Tidal.Stream.Config +import Sound.Tidal.Stream.Types +import Sound.Tidal.Stream.UI + +{- + Listen.hs - logic for listening and acting on incoming OSC messages + 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 . +-} + + +openListener :: Config -> IO (Maybe O.Udp) +openListener c + | cCtrlListen c = catchAny run (\_ -> do verbose c "That port isn't available, perhaps another Tidal instance is already listening on that port?" + return Nothing + ) + | otherwise = return Nothing + where + run = do sock <- O.udpServer (cCtrlAddr c) (cCtrlPort c) + when (cCtrlBroadcast c) $ N.setSocketOption (O.udpSocket sock) N.Broadcast 1 + return $ Just sock + catchAny :: IO a -> (E.SomeException -> IO a) -> IO a + catchAny = E.catch + +-- Listen to and act on OSC control messages +ctrlResponder :: Int -> Config -> Stream -> IO () +ctrlResponder waits c (stream@(Stream {sListen = Just sock})) + = do ms <- recvMessagesTimeout 2 sock + if (null ms) + then do checkHandshake -- there was a timeout, check handshake + ctrlResponder (waits+1) c stream + else do mapM_ act ms + ctrlResponder 0 c stream + where + checkHandshake = do busses <- readMVar (sBusses stream) + when (null busses) $ do when (waits == 0) $ verbose c $ "Waiting for SuperDirt (v.1.7.2 or higher).." + sendHandshakes stream + + act (O.Message "/dirt/hello" _) = sendHandshakes stream + act (O.Message "/dirt/handshake/reply" xs) = do prev <- swapMVar (sBusses stream) $ bufferIndices xs + -- Only report the first time.. + when (null prev) $ verbose c $ "Connected to SuperDirt." + return () + where + bufferIndices [] = [] + bufferIndices (x:xs') | x == (O.AsciiString $ O.ascii "&controlBusIndices") = catMaybes $ takeWhile isJust $ map O.datum_integral xs' + | otherwise = bufferIndices xs' + -- External controller commands + act (O.Message "/ctrl" (O.Int32 k:v:[])) + = act (O.Message "/ctrl" [O.string $ show k,v]) + act (O.Message "/ctrl" (O.AsciiString k:v@(O.Float _):[])) + = add (O.ascii_to_string k) (VF (fromJust $ O.datum_floating v)) + act (O.Message "/ctrl" (O.AsciiString k:O.AsciiString v:[])) + = add (O.ascii_to_string k) (VS (O.ascii_to_string v)) + act (O.Message "/ctrl" (O.AsciiString k:O.Int32 v:[])) + = add (O.ascii_to_string k) (VI (fromIntegral v)) + -- Stream playback commands + act (O.Message "/mute" (k:[])) + = withID k $ streamMute stream + act (O.Message "/unmute" (k:[])) + = withID k $ streamUnmute stream + act (O.Message "/solo" (k:[])) + = withID k $ streamSolo stream + act (O.Message "/unsolo" (k:[])) + = withID k $ streamUnsolo stream + act (O.Message "/muteAll" []) + = streamMuteAll stream + act (O.Message "/unmuteAll" []) + = streamUnmuteAll stream + act (O.Message "/unsoloAll" []) + = streamUnsoloAll stream + act (O.Message "/hush" []) + = streamHush stream + act (O.Message "/silence" (k:[])) + = withID k $ streamSilence stream + act m = hPutStrLn stderr $ "Unhandled OSC: " ++ show m + add :: String -> Value -> IO () + add k v = do sMap <- takeMVar (sStateMV stream) + putMVar (sStateMV stream) $ Map.insert k v sMap + return () + withID :: O.Datum -> (ID -> IO ()) -> IO () + withID (O.AsciiString k) func = func $ (ID . O.ascii_to_string) k + withID (O.Int32 k) func = func $ (ID . show) k + withID _ _ = return () +ctrlResponder _ _ _ = return () + +verbose :: Config -> String -> IO () +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 diff --git a/src/Sound/Tidal/Stream/Main.hs b/src/Sound/Tidal/Stream/Main.hs new file mode 100644 index 000000000..e4dd41c09 --- /dev/null +++ b/src/Sound/Tidal/Stream/Main.hs @@ -0,0 +1,78 @@ +module Sound.Tidal.Stream.Main where + +import qualified Data.Map as Map +import qualified Sound.Tidal.Clock as Clock +import Control.Concurrent.MVar +import Control.Concurrent +import System.IO (hPutStrLn, stderr) + + +import Sound.Tidal.Version (tidal_status_string) +import Sound.Tidal.Stream.Config +import Sound.Tidal.Stream.Types +import Sound.Tidal.Stream.Listen +import Sound.Tidal.Stream.Target +import Sound.Tidal.Stream.Process +import Sound.Tidal.Stream.UI + +{- + Main.hs - Start tidals stream, listen and act on incoming messages + 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 . +-} + + +-- Start an instance of Tidal with superdirt OSC +startTidal :: Target -> Config -> IO Stream +startTidal target config = startStream config [(target, [superdirtShape])] + +-- Start an instance of Tidal +-- Spawns a thread within Tempo that acts as the clock +-- Spawns a thread that listens to and acts on OSC control messages +startStream :: Config -> [(Target, [OSC])] -> IO Stream +startStream config oscmap = do + sMapMV <- newMVar Map.empty + pMapMV <- newMVar Map.empty + bussesMV <- newMVar [] + globalFMV <- newMVar id + + tidal_status_string >>= verbose config + verbose config $ "Listening for external controls on " ++ cCtrlAddr config ++ ":" ++ show (cCtrlPort config) + listen <- openListener config + + cxs <- getCXs config oscmap + + clockRef <- Clock.clocked (cClockConfig config) (doTick sMapMV bussesMV pMapMV globalFMV cxs listen) + + let stream = Stream {sConfig = config, + sBusses = bussesMV, + sStateMV = sMapMV, + sClockRef = clockRef, + -- sLink = abletonLink, + sListen = listen, + sPMapMV = pMapMV, + -- sActionsMV = actionsMV, + sGlobalFMV = globalFMV, + sCxs = cxs + } + + sendHandshakes stream + + -- Spawn a thread to handle OSC control messages + _ <- forkIO $ ctrlResponder 0 config stream + return stream + +startMulti :: [Target] -> Config -> IO () +startMulti _ _ = hPutStrLn stderr $ "startMulti has been removed, please check the latest documentation on tidalcycles.org" diff --git a/src/Sound/Tidal/Stream/Process.hs b/src/Sound/Tidal/Stream/Process.hs new file mode 100644 index 000000000..cb661c3bb --- /dev/null +++ b/src/Sound/Tidal/Stream/Process.hs @@ -0,0 +1,319 @@ +{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, FlexibleContexts, ScopedTypeVariables, BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-missing-fields #-} +{-# language DeriveGeneric, StandaloneDeriving #-} + +module Sound.Tidal.Stream.Process where + +{- + Process.hs - Tidal's thingie for turning patterns into OSC streams + 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 . +-} + +import Control.Applicative ((<|>)) +import Control.Concurrent.MVar +import Control.Monad (forM_, when) +import Data.Coerce (coerce) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromJust, fromMaybe, catMaybes) +import qualified Control.Exception as E +import Foreign.C.Types +import System.IO (hPutStrLn, stderr) + +import qualified Sound.Osc.Fd as O + +import Sound.Tidal.Stream.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 Sound.Tidal.Utils ((!!!)) +import Data.List (sortOn) +import Sound.Tidal.Show () + +import Sound.Tidal.Stream.Types +import Sound.Tidal.Stream.Target + +data ProcessedEvent = + ProcessedEvent { + peHasOnset :: Bool, + peEvent :: Event ValueMap, + peCps :: Link.BPM, + peDelta :: Link.Micros, + peCycle :: Time, + peOnWholeOrPart :: Link.Micros, + peOnWholeOrPartOsc :: O.Time, + peOnPart :: Link.Micros, + peOnPartOsc :: O.Time + } + +-- | Query the current pattern (contained in argument @stream :: Stream@) +-- for the events in the current arc (contained in argument @st :: T.State@), +-- translate them to OSC messages, and send these. +-- +-- If an exception occurs during sending, +-- this functions prints a warning and continues, because +-- the likely reason is that the backend (supercollider) isn't running. +-- +-- If any exception occurs before or outside sending +-- (e.g., while querying the pattern, while computing a message), +-- 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 :: MVar ValueMap -- pattern state + -> MVar [Int] -- busses + -> MVar PlayMap -- currently playing + -> MVar (ControlPattern -> ControlPattern) -- current global fx + -> [Cx] -- target addresses + -> Maybe O.Udp -- network socket + -> (Time,Time) -- current arc + -> Double -- nudge + -> Clock.LinkOperations -- ableton link operations + -> 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 playMV) (do + sMap <- takeMVar stateMV + pMap <- readMVar playMV + busses <- readMVar busMV + sGlobalF <- readMVar globalFMV + bpm <- (Clock.getTempo ops) + let + patstack = sGlobalF $ playStack pMap + cps = ((Clock.beatToCycles ops) bpm) / 60 + sMap' = Map.insert "_cps" (VF $ coerce cps) sMap + extraLatency = nudge + -- First the state is used to query the pattern + es = sortOn (start . part) $ query patstack (State {arc = Arc st end, + controls = sMap' + } + ) + -- Then it's passed through the events + (sMap'', es') = resolveState sMap' es + tes <- processCps ops es' + -- For each OSC target + forM_ cxs $ \cx@(Cx target _ oscs _ _) -> do + -- Latency is configurable per target. + -- Latency is only used when sending events live. + let latency = oLatency target + ms = concatMap (\e -> concatMap (toOSC busses e) oscs) tes + -- send the events to the OSC target + forM_ ms $ \m -> (send listen cx latency extraLatency m) `E.catch` \(e :: E.SomeException) -> + hPutStrLn stderr $ "Failed to send. Is the '" ++ oName target ++ "' target running? " ++ show e + putMVar stateMV sMap'') + +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 = (Clock.cyclesToBeat ops) (realToFrac partStartCycle) + onCycle = start wope + onBeat = (Clock.cyclesToBeat ops) (realToFrac onCycle) + offCycle = stop wope + 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 -> (Clock.setTempo ops) ((Clock.cyclesToBeat ops) (newCps * 60)) on) $ coerce cps' + ) + 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, + peEvent = e, + peCps = cps, + peDelta = delta, + peCycle = onCycle, + peOnWholeOrPart = on, + peOnWholeOrPartOsc = (Clock.linkToOscTime ops) on, + peOnPart = onPart, + peOnPartOsc = (Clock.linkToOscTime ops) onPart + } + + +toOSC :: [Int] -> ProcessedEvent -> OSC -> [(Double, Bool, O.Message)] +toOSC busses pe osc@(OSC _ _) + = catMaybes (playmsg:busmsgs) + -- playmap is a ValueMap where the keys don't start with ^ and are not "" + -- busmap is a ValueMap containing the rest of the keys from the event value + -- The partition is performed in order to have special handling of bus ids. + where + (playmap, busmap) = Map.partitionWithKey (\k _ -> null k || head k /= '^') $ val pe + -- Map in bus ids where needed. + -- + -- Bus ids are integers + -- If busses is empty, the ids to send are directly contained in the the values of the busmap. + -- Otherwise, the ids to send are contained in busses at the indices of the values of the busmap. + -- Both cases require that the values of the busmap are only ever integers, + -- that is, they are Values with constructor VI + -- (but perhaps we should explicitly crash with an error message if it contains something else?). + -- Map.mapKeys tail is used to remove ^ from the keys. + -- In case (value e) has the key "", we will get a crash here. + playmap' = Map.union (Map.mapKeys tail $ Map.map (\(VI i) -> VS ('c':(show $ toBus i))) busmap) playmap + val = value . peEvent + -- Only events that start within the current nowArc are included + 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 (Clock.addMicrosToOsc (peDelta pe) 0)), + ("cycle", VF (fromRational (peCycle pe))) + ] + addExtra = Map.union playmap' extra + ts = (peOnWholeOrPartOsc pe) + nudge -- + latency + vs <- toData osc ((peEvent pe) {value = addExtra}) + mungedPath <- substitutePath (path osc) playmap' + return (ts, + False, -- bus message ? + O.Message mungedPath vs + ) + | otherwise = Nothing + toBus n | null busses = n + | otherwise = busses !!! n + busmsgs = map + (\(('^':k), (VI b)) -> do v <- Map.lookup k playmap + return $ (tsPart, + True, -- bus message ? + O.Message "/c_set" [O.int32 b, toDatum v] + ) + ) + (Map.toList busmap) + where + tsPart = (peOnPartOsc pe) + nudge -- + latency + nudge = fromJust $ getF $ fromMaybe (VF 0) $ Map.lookup "nudge" $ playmap +toOSC _ pe (OSCContext oscpath) + = map cToM $ contextPosition $ context $ peEvent pe + where cToM :: ((Int,Int),(Int,Int)) -> (Double, Bool, O.Message) + cToM ((x, y), (x',y')) = (ts, + False, -- bus message ? + O.Message oscpath $ (O.string ident):(O.float (peDelta pe)):(O.float cyc):(map O.int32 [x,y,x',y']) + ) + cyc :: Double + cyc = fromRational $ peCycle pe + nudge = fromMaybe 0 $ Map.lookup "nudge" (value $ peEvent pe) >>= getF + ident = fromMaybe "unknown" $ Map.lookup "_id_" (value $ peEvent pe) >>= getS + ts = (peOnWholeOrPartOsc pe) + nudge -- + latency + +toData :: OSC -> Event ValueMap -> Maybe [O.Datum] +toData (OSC {args = ArgList as}) e = fmap (fmap (toDatum)) $ sequence $ map (\(n,v) -> Map.lookup n (value e) <|> v) as +toData (OSC {args = Named rqrd}) e + | hasRequired rqrd = Just $ concatMap (\(n,v) -> [O.string n, toDatum v]) $ Map.toList $ value e + | otherwise = Nothing + where hasRequired [] = True + hasRequired xs = null $ filter (not . (`elem` ks)) xs + ks = Map.keys (value e) +toData _ _ = Nothing + +toDatum :: Value -> O.Datum +toDatum (VF x) = O.float x +toDatum (VN x) = O.float x +toDatum (VI x) = O.int32 x +toDatum (VS x) = O.string x +toDatum (VR x) = O.float $ ((fromRational x) :: Double) +toDatum (VB True) = O.int32 (1 :: Int) +toDatum (VB False) = O.int32 (0 :: Int) +toDatum (VX xs) = O.Blob $ O.blob_pack xs +toDatum _ = error "toDatum: unhandled value" + +substitutePath :: String -> ValueMap -> Maybe String +substitutePath str cm = parse str + where parse [] = Just [] + parse ('{':xs) = parseWord xs + parse (x:xs) = do xs' <- parse xs + return (x:xs') + parseWord xs | b == [] = getString cm a + | otherwise = do v <- getString cm a + xs' <- parse (tail b) + return $ v ++ xs' + where (a,b) = break (== '}') xs + +getString :: ValueMap -> String -> Maybe String +getString cm s = (simpleShow <$> Map.lookup param cm) <|> defaultValue dflt + where (param, dflt) = break (== '=') s + simpleShow :: Value -> String + simpleShow (VS str) = str + simpleShow (VI i) = show i + simpleShow (VF f) = show f + simpleShow (VN n) = show n + simpleShow (VR r) = show r + simpleShow (VB b) = show b + simpleShow (VX xs) = show xs + simpleShow (VState _) = show "" + simpleShow (VPattern _) = show "" + simpleShow (VList _) = show "" + defaultValue :: String -> Maybe String + defaultValue ('=':dfltVal) = Just dfltVal + defaultValue _ = Nothing + +playStack :: PlayMap -> ControlPattern +playStack pMap = stack . (map pattern) . (filter active) . Map.elems $ pMap + where active pState = if hasSolo pMap + then solo pState + else not (mute pState) + +hasSolo :: Map.Map k PlayState -> Bool +hasSolo = (>= 1) . length . filter solo . Map.elems + + +-- 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 :: 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, + solo = False, + history = [] + } + ) + -- The nowArc is a full cycle + doTick stateMV busMV pMapMV globalFMV cxs listen (0,1) 0 ops + + + +-- 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) + +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] } + ) diff --git a/src/Sound/Tidal/Stream/Stream.hs b/src/Sound/Tidal/Stream/Stream.hs deleted file mode 100644 index 8c3e64e38..000000000 --- a/src/Sound/Tidal/Stream/Stream.hs +++ /dev/null @@ -1,751 +0,0 @@ -{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, FlexibleContexts, ScopedTypeVariables, BangPatterns #-} -{-# OPTIONS_GHC -fno-warn-missing-fields #-} -{-# language DeriveGeneric, StandaloneDeriving #-} - -module Sound.Tidal.Stream.Stream (module Sound.Tidal.Stream.Stream) where - -{- - Stream.hs - Tidal's thingie for turning patterns into OSC streams - 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 . --} - -import Control.Applicative ((<|>)) -import Control.Concurrent.MVar -import Control.Concurrent -import Control.Monad (forM_, when) -import Data.Coerce (coerce) -import qualified Data.Map.Strict as Map -import Data.Maybe (fromJust, fromMaybe, catMaybes, isJust) -import qualified Control.Exception as E -import Foreign -import Foreign.C.Types -import System.IO (hPutStrLn, stderr) - -import qualified Sound.Osc.Fd as O -import qualified Sound.Osc.Time.Timeout as O -import qualified Network.Socket as N - -import Sound.Tidal.Stream.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 Sound.Tidal.Utils ((!!!)) -import Data.List (sortOn) -import System.Random (getStdRandom, randomR) -import Sound.Tidal.Show () - -import Sound.Tidal.Version - -import Sound.Tidal.Stream.Types as Sound.Tidal.Stream - -data Stream = Stream {sConfig :: Config, - sBusses :: MVar [Int], - sStateMV :: MVar ValueMap, - -- sOutput :: MVar ControlPattern, - sClockRef :: Clock.ClockRef, - sListen :: Maybe O.Udp, - sPMapMV :: MVar PlayMap, - sGlobalFMV :: MVar (ControlPattern -> ControlPattern), - sCxs :: [Cx] - } - -data Cx = Cx {cxTarget :: Target, - cxUDP :: O.Udp, - cxOSCs :: [OSC], - cxAddr :: N.AddrInfo, - cxBusAddr :: Maybe N.AddrInfo - } - -data StampStyle = BundleStamp - | MessageStamp - deriving (Eq, Show) - -data Schedule = Pre StampStyle - | Live - deriving (Eq, Show) - -data Target = Target {oName :: String, - oAddress :: String, - oPort :: Int, - oBusPort :: Maybe Int, - oLatency :: Double, - oWindow :: Maybe Arc, - oSchedule :: Schedule, - oHandshake :: Bool - } - deriving Show - -data Args = Named {requiredArgs :: [String]} - | ArgList [(String, Maybe Value)] - deriving Show - -data OSC = OSC {path :: String, - args :: Args - } - | OSCContext {path :: String} - deriving Show - -data ProcessedEvent = - ProcessedEvent { - peHasOnset :: Bool, - peEvent :: Event ValueMap, - peCps :: Link.BPM, - peDelta :: Link.Micros, - peCycle :: Time, - peOnWholeOrPart :: Link.Micros, - peOnWholeOrPartOsc :: O.Time, - peOnPart :: Link.Micros, - peOnPartOsc :: O.Time - } - -sDefault :: String -> Maybe Value -sDefault x = Just $ VS x -fDefault :: Double -> Maybe Value -fDefault x = Just $ VF x -rDefault :: Rational -> Maybe Value -rDefault x = Just $ VR x -iDefault :: Int -> Maybe Value -iDefault x = Just $ VI x -bDefault :: Bool -> Maybe Value -bDefault x = Just $ VB x -xDefault :: [Word8] -> Maybe Value -xDefault x = Just $ VX x - -required :: Maybe Value -required = Nothing - -superdirtTarget :: Target -superdirtTarget = Target {oName = "SuperDirt", - oAddress = "127.0.0.1", - oPort = 57120, - oBusPort = Just 57110, - oLatency = 0.2, - oWindow = Nothing, - oSchedule = Pre BundleStamp, - oHandshake = True - } - -superdirtShape :: OSC -superdirtShape = OSC "/dirt/play" $ Named {requiredArgs = ["s"]} - -dirtTarget :: Target -dirtTarget = Target {oName = "Dirt", - oAddress = "127.0.0.1", - oPort = 7771, - oBusPort = Nothing, - oLatency = 0.02, - oWindow = Nothing, - oSchedule = Pre MessageStamp, - oHandshake = False - } - -dirtShape :: OSC -dirtShape = OSC "/play" $ ArgList [("cps", fDefault 0), - ("s", required), - ("offset", fDefault 0), - ("begin", fDefault 0), - ("end", fDefault 1), - ("speed", fDefault 1), - ("pan", fDefault 0.5), - ("velocity", fDefault 0.5), - ("vowel", sDefault ""), - ("cutoff", fDefault 0), - ("resonance", fDefault 0), - ("accelerate", fDefault 0), - ("shape", fDefault 0), - ("kriole", iDefault 0), - ("gain", fDefault 1), - ("cut", iDefault 0), - ("delay", fDefault 0), - ("delaytime", fDefault (-1)), - ("delayfeedback", fDefault (-1)), - ("crush", fDefault 0), - ("coarse", iDefault 0), - ("hcutoff", fDefault 0), - ("hresonance", fDefault 0), - ("bandf", fDefault 0), - ("bandq", fDefault 0), - ("unit", sDefault "rate"), - ("loop", fDefault 0), - ("n", fDefault 0), - ("attack", fDefault (-1)), - ("hold", fDefault 0), - ("release", fDefault (-1)), - ("orbit", iDefault 0) -- , - -- ("id", iDefault 0) - ] - -defaultCps :: O.Time -defaultCps = 0.5625 - --- Start an instance of Tidal --- Spawns a thread within Tempo that acts as the clock --- Spawns a thread that listens to and acts on OSC control messages -startStream :: Config -> [(Target, [OSC])] -> IO Stream -startStream config oscmap - = do sMapMV <- newMVar Map.empty - pMapMV <- newMVar Map.empty - bussesMV <- newMVar [] - globalFMV <- newMVar id - - tidal_status_string >>= verbose config - verbose config $ "Listening for external controls on " ++ cCtrlAddr config ++ ":" ++ show (cCtrlPort config) - listen <- openListener config - - cxs <- mapM (\(target, os) -> do remote_addr <- resolve (oAddress target) (show $ oPort target) - remote_bus_addr <- if isJust $ oBusPort target - then Just <$> resolve (oAddress target) (show $ fromJust $ oBusPort target) - else return Nothing - let broadcast = if cCtrlBroadcast config then 1 else 0 - u <- O.udp_socket (\sock sockaddr -> do N.setSocketOption sock N.Broadcast broadcast - N.connect sock sockaddr - ) (oAddress target) (oPort target) - return $ Cx {cxUDP = u, cxAddr = remote_addr, cxBusAddr = remote_bus_addr, cxTarget = target, cxOSCs = os} - ) oscmap - - clockRef <- Clock.clocked (cClockConfig config) (doTick sMapMV bussesMV pMapMV globalFMV cxs listen) - - let stream = Stream {sConfig = config, - sBusses = bussesMV, - sStateMV = sMapMV, - sClockRef = clockRef, - -- sLink = abletonLink, - sListen = listen, - sPMapMV = pMapMV, - -- sActionsMV = actionsMV, - sGlobalFMV = globalFMV, - sCxs = cxs - } - - sendHandshakes stream - - -- Spawn a thread to handle OSC control messages - _ <- forkIO $ ctrlResponder 0 config stream - return stream - --- It only really works to handshake with one target at the moment.. -sendHandshakes :: Stream -> IO () -sendHandshakes stream = mapM_ sendHandshake $ filter (oHandshake . cxTarget) (sCxs stream) - where sendHandshake cx = if (isJust $ sListen stream) - then - do -- send it _from_ the udp socket we're listening to, so the - -- replies go back there - sendO False (sListen stream) cx $ O.Message "/dirt/handshake" [] - else - hPutStrLn stderr "Can't handshake with SuperCollider without control port." - -sendO :: Bool -> (Maybe O.Udp) -> Cx -> O.Message -> IO () -sendO isBusMsg (Just listen) cx msg = O.sendTo listen (O.Packet_Message msg) (N.addrAddress addr) - where addr | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx - | otherwise = cxAddr cx -sendO _ Nothing cx msg = O.sendMessage (cxUDP cx) msg - -sendBndl :: Bool -> (Maybe O.Udp) -> Cx -> O.Bundle -> IO () -sendBndl isBusMsg (Just listen) cx bndl = O.sendTo listen (O.Packet_Bundle bndl) (N.addrAddress addr) - where addr | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx - | otherwise = cxAddr cx -sendBndl _ Nothing cx bndl = O.sendBundle (cxUDP cx) bndl - -resolve :: String -> String -> IO N.AddrInfo -resolve host port = do let hints = N.defaultHints { N.addrSocketType = N.Stream } - addr:_ <- N.getAddrInfo (Just hints) (Just host) (Just port) - return addr - --- Start an instance of Tidal with superdirt OSC -startTidal :: Target -> Config -> IO Stream -startTidal target config = startStream config [(target, [superdirtShape])] - -startMulti :: [Target] -> Config -> IO () -startMulti _ _ = hPutStrLn stderr $ "startMulti has been removed, please check the latest documentation on tidalcycles.org" - -toDatum :: Value -> O.Datum -toDatum (VF x) = O.float x -toDatum (VN x) = O.float x -toDatum (VI x) = O.int32 x -toDatum (VS x) = O.string x -toDatum (VR x) = O.float $ ((fromRational x) :: Double) -toDatum (VB True) = O.int32 (1 :: Int) -toDatum (VB False) = O.int32 (0 :: Int) -toDatum (VX xs) = O.Blob $ O.blob_pack xs -toDatum _ = error "toDatum: unhandled value" - -toData :: OSC -> Event ValueMap -> Maybe [O.Datum] -toData (OSC {args = ArgList as}) e = fmap (fmap (toDatum)) $ sequence $ map (\(n,v) -> Map.lookup n (value e) <|> v) as -toData (OSC {args = Named rqrd}) e - | hasRequired rqrd = Just $ concatMap (\(n,v) -> [O.string n, toDatum v]) $ Map.toList $ value e - | otherwise = Nothing - where hasRequired [] = True - hasRequired xs = null $ filter (not . (`elem` ks)) xs - ks = Map.keys (value e) -toData _ _ = Nothing - -substitutePath :: String -> ValueMap -> Maybe String -substitutePath str cm = parse str - where parse [] = Just [] - parse ('{':xs) = parseWord xs - parse (x:xs) = do xs' <- parse xs - return (x:xs') - parseWord xs | b == [] = getString cm a - | otherwise = do v <- getString cm a - xs' <- parse (tail b) - return $ v ++ xs' - where (a,b) = break (== '}') xs - -getString :: ValueMap -> String -> Maybe String -getString cm s = (simpleShow <$> Map.lookup param cm) <|> defaultValue dflt - where (param, dflt) = break (== '=') s - simpleShow :: Value -> String - simpleShow (VS str) = str - simpleShow (VI i) = show i - simpleShow (VF f) = show f - simpleShow (VN n) = show n - simpleShow (VR r) = show r - simpleShow (VB b) = show b - simpleShow (VX xs) = show xs - simpleShow (VState _) = show "" - simpleShow (VPattern _) = show "" - simpleShow (VList _) = show "" - defaultValue :: String -> Maybe String - defaultValue ('=':dfltVal) = Just dfltVal - defaultValue _ = Nothing - -playStack :: PlayMap -> ControlPattern -playStack pMap = stack . (map pattern) . (filter active) . Map.elems $ pMap - where active pState = if hasSolo pMap - then solo pState - else not (mute pState) - -toOSC :: [Int] -> ProcessedEvent -> OSC -> [(Double, Bool, O.Message)] -toOSC busses pe osc@(OSC _ _) - = catMaybes (playmsg:busmsgs) - -- playmap is a ValueMap where the keys don't start with ^ and are not "" - -- busmap is a ValueMap containing the rest of the keys from the event value - -- The partition is performed in order to have special handling of bus ids. - where - (playmap, busmap) = Map.partitionWithKey (\k _ -> null k || head k /= '^') $ val pe - -- Map in bus ids where needed. - -- - -- Bus ids are integers - -- If busses is empty, the ids to send are directly contained in the the values of the busmap. - -- Otherwise, the ids to send are contained in busses at the indices of the values of the busmap. - -- Both cases require that the values of the busmap are only ever integers, - -- that is, they are Values with constructor VI - -- (but perhaps we should explicitly crash with an error message if it contains something else?). - -- Map.mapKeys tail is used to remove ^ from the keys. - -- In case (value e) has the key "", we will get a crash here. - playmap' = Map.union (Map.mapKeys tail $ Map.map (\(VI i) -> VS ('c':(show $ toBus i))) busmap) playmap - val = value . peEvent - -- Only events that start within the current nowArc are included - 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 (Clock.addMicrosToOsc (peDelta pe) 0)), - ("cycle", VF (fromRational (peCycle pe))) - ] - addExtra = Map.union playmap' extra - ts = (peOnWholeOrPartOsc pe) + nudge -- + latency - vs <- toData osc ((peEvent pe) {value = addExtra}) - mungedPath <- substitutePath (path osc) playmap' - return (ts, - False, -- bus message ? - O.Message mungedPath vs - ) - | otherwise = Nothing - toBus n | null busses = n - | otherwise = busses !!! n - busmsgs = map - (\(('^':k), (VI b)) -> do v <- Map.lookup k playmap - return $ (tsPart, - True, -- bus message ? - O.Message "/c_set" [O.int32 b, toDatum v] - ) - ) - (Map.toList busmap) - where - tsPart = (peOnPartOsc pe) + nudge -- + latency - nudge = fromJust $ getF $ fromMaybe (VF 0) $ Map.lookup "nudge" $ playmap -toOSC _ pe (OSCContext oscpath) - = map cToM $ contextPosition $ context $ peEvent pe - where cToM :: ((Int,Int),(Int,Int)) -> (Double, Bool, O.Message) - cToM ((x, y), (x',y')) = (ts, - False, -- bus message ? - O.Message oscpath $ (O.string ident):(O.float (peDelta pe)):(O.float cyc):(map O.int32 [x,y,x',y']) - ) - cyc :: Double - cyc = fromRational $ peCycle pe - nudge = fromMaybe 0 $ Map.lookup "nudge" (value $ peEvent pe) >>= getF - ident = fromMaybe "unknown" $ Map.lookup "_id_" (value $ peEvent pe) >>= getS - ts = (peOnWholeOrPartOsc pe) + nudge -- + latency - - -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 = (Clock.cyclesToBeat ops) (realToFrac partStartCycle) - onCycle = start wope - onBeat = (Clock.cyclesToBeat ops) (realToFrac onCycle) - offCycle = stop wope - 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 -> (Clock.setTempo ops) ((Clock.cyclesToBeat ops) (newCps * 60)) on) $ coerce cps' - ) - 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, - peEvent = e, - peCps = cps, - peDelta = delta, - peCycle = onCycle, - peOnWholeOrPart = on, - peOnWholeOrPartOsc = (Clock.linkToOscTime ops) on, - peOnPart = onPart, - peOnPartOsc = (Clock.linkToOscTime ops) onPart - } - - --- streamFirst but with random cycle instead of always first cicle -streamOnce :: Stream -> ControlPattern -> IO () -streamOnce st p = do i <- getStdRandom $ randomR (0, 8192) - streamFirst st $ rotL (toRational (i :: Int)) p - -streamFirst :: Stream -> ControlPattern -> IO () -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 :: 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, - solo = False, - history = [] - } - ) - -- The nowArc is a full cycle - doTick stateMV busMV pMapMV globalFMV cxs listen (0,1) 0 ops - - --- | Query the current pattern (contained in argument @stream :: Stream@) --- for the events in the current arc (contained in argument @st :: T.State@), --- translate them to OSC messages, and send these. --- --- If an exception occurs during sending, --- this functions prints a warning and continues, because --- the likely reason is that the backend (supercollider) isn't running. --- --- If any exception occurs before or outside sending --- (e.g., while querying the pattern, while computing a message), --- 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 :: 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 playMV) (do - sMap <- takeMVar stateMV - pMap <- readMVar playMV - busses <- readMVar busMV - sGlobalF <- readMVar globalFMV - bpm <- (Clock.getTempo ops) - let - patstack = sGlobalF $ playStack pMap - cps = ((Clock.beatToCycles ops) bpm) / 60 - sMap' = Map.insert "_cps" (VF $ coerce cps) sMap - extraLatency = nudge - -- First the state is used to query the pattern - es = sortOn (start . part) $ query patstack (State {arc = Arc st end, - controls = sMap' - } - ) - -- Then it's passed through the events - (sMap'', es') = resolveState sMap' es - tes <- processCps ops es' - -- For each OSC target - forM_ cxs $ \cx@(Cx target _ oscs _ _) -> do - -- Latency is configurable per target. - -- Latency is only used when sending events live. - let latency = oLatency target - ms = concatMap (\e -> concatMap (toOSC busses e) oscs) tes - -- send the events to the OSC target - forM_ ms $ \ m -> (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 - putMVar stateMV sMap'') - - -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] } - ) - --- send has three modes: --- Send events early using timestamp in the OSC bundle - used by Superdirt --- Send events early by adding timestamp to the OSC message - used by Dirt --- Send events live by delaying the thread -send :: Maybe O.Udp -> Cx -> Double -> Double -> (Double, Bool, O.Message) -> IO () -send listen cx latency extraLatency (time, isBusMsg, m) - | oSchedule target == Pre BundleStamp = sendBndl isBusMsg listen cx $ O.Bundle timeWithLatency [m] - | oSchedule target == Pre MessageStamp = sendO isBusMsg listen cx $ addtime m - | otherwise = do _ <- forkOS $ do now <- O.time - threadDelay $ floor $ (timeWithLatency - now) * 1000000 - sendO isBusMsg listen cx m - return () - where addtime (O.Message mpath params) = O.Message mpath ((O.int32 sec):((O.int32 usec):params)) - ut = O.ntpr_to_posix timeWithLatency - sec :: Int - sec = floor ut - usec :: Int - usec = floor $ 1000000 * (ut - (fromIntegral sec)) - target = cxTarget cx - timeWithLatency = time - latency + extraLatency - --- Interaction - -streamNudgeAll :: Stream -> Double -> IO () -streamNudgeAll s = Clock.setNudge (sClockRef s) - -streamResetCycles :: Stream -> IO () -streamResetCycles s = streamSetCycle s 0 - -streamSetCycle :: Stream -> Time -> IO () -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) - -streamEnableLink :: Stream -> IO () -streamEnableLink s = Clock.enableLink (sClockRef s) - -streamDisableLink :: Stream -> IO () -streamDisableLink s = Clock.disableLink (sClockRef s) - -hasSolo :: Map.Map k PlayState -> Bool -hasSolo = (>= 1) . length . filter solo . Map.elems - -streamList :: Stream -> IO () -streamList s = do pMap <- readMVar (sPMapMV s) - let hs = hasSolo pMap - putStrLn $ concatMap (showKV hs) $ Map.toList pMap - where showKV :: Bool -> (PatId, PlayState) -> String - showKV True (k, (PlayState {solo = True})) = k ++ " - solo\n" - showKV True (k, _) = "(" ++ k ++ ")\n" - showKV False (k, (PlayState {solo = False})) = k ++ "\n" - showKV False (k, _) = "(" ++ k ++ ") - muted\n" - --- 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) - -streamReplace :: Stream -> ID -> ControlPattern -> IO () -streamReplace stream k !pat = do - t <- Clock.getCycleTime (cClockConfig $ sConfig stream) (sClockRef stream) - E.handle (\ (e :: E.SomeException) -> do - hPutStrLn stderr $ "Failed to Stream.streamReplace: " ++ show e - hPutStrLn stderr $ "Return to previous pattern." - setPreviousPatternOrSilence (sPMapMV 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}) - -streamMutes :: Stream -> [ID] -> IO () -streamMutes s ks = withPatIds s ks (\x -> x {mute = True}) - -streamUnmute :: Stream -> ID -> IO () -streamUnmute s k = withPatIds s [k] (\x -> x {mute = False}) - -streamSolo :: Stream -> ID -> IO () -streamSolo s k = withPatIds s [k] (\x -> x {solo = True}) - -streamUnsolo :: Stream -> ID -> IO () -streamUnsolo s k = withPatIds s [k] (\x -> x {solo = False}) - -withPatIds :: Stream -> [ID] -> (PlayState -> PlayState) -> IO () -withPatIds s ks f - = do playMap <- takeMVar $ sPMapMV s - let pMap' = foldr (Map.update (\x -> Just $ f x)) playMap (map fromID ks) - putMVar (sPMapMV s) pMap' - return () - --- TODO - is there a race condition here? -streamMuteAll :: Stream -> IO () -streamMuteAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {mute = True}) - -streamHush :: Stream -> IO () -streamHush s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {pattern = silence, history = silence:history x}) - -streamUnmuteAll :: Stream -> IO () -streamUnmuteAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {mute = False}) - -streamUnsoloAll :: Stream -> IO () -streamUnsoloAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {solo = False}) - -streamSilence :: Stream -> ID -> IO () -streamSilence s k = withPatIds s [k] (\x -> x {pattern = silence, history = silence:history x}) - -streamAll :: Stream -> (ControlPattern -> ControlPattern) -> IO () -streamAll s f = do _ <- swapMVar (sGlobalFMV s) f - return () - -streamGet :: Stream -> String -> IO (Maybe Value) -streamGet s k = Map.lookup k <$> readMVar (sStateMV s) - -streamSet :: Valuable a => Stream -> String -> Pattern a -> IO () -streamSet s k pat = do sMap <- takeMVar $ sStateMV s - let pat' = toValue <$> pat - sMap' = Map.insert k (VPattern pat') sMap - putMVar (sStateMV s) $ sMap' - -streamSetI :: Stream -> String -> Pattern Int -> IO () -streamSetI = streamSet - -streamSetF :: Stream -> String -> Pattern Double -> IO () -streamSetF = streamSet - -streamSetS :: Stream -> String -> Pattern String -> IO () -streamSetS = streamSet - -streamSetB :: Stream -> String -> Pattern Bool -> IO () -streamSetB = streamSet - -streamSetR :: Stream -> String -> Pattern Rational -> IO () -streamSetR = streamSet - -openListener :: Config -> IO (Maybe O.Udp) -openListener c - | cCtrlListen c = catchAny run (\_ -> do verbose c "That port isn't available, perhaps another Tidal instance is already listening on that port?" - return Nothing - ) - | otherwise = return Nothing - where - run = do sock <- O.udpServer (cCtrlAddr c) (cCtrlPort c) - when (cCtrlBroadcast c) $ N.setSocketOption (O.udpSocket sock) N.Broadcast 1 - return $ Just sock - catchAny :: IO a -> (E.SomeException -> IO a) -> IO a - catchAny = E.catch - --- Listen to and act on OSC control messages -ctrlResponder :: Int -> Config -> Stream -> IO () -ctrlResponder waits c (stream@(Stream {sListen = Just sock})) - = do ms <- recvMessagesTimeout 2 sock - if (null ms) - then do checkHandshake -- there was a timeout, check handshake - ctrlResponder (waits+1) c stream - else do mapM_ act ms - ctrlResponder 0 c stream - where - checkHandshake = do busses <- readMVar (sBusses stream) - when (null busses) $ do when (waits == 0) $ verbose c $ "Waiting for SuperDirt (v.1.7.2 or higher).." - sendHandshakes stream - - act (O.Message "/dirt/hello" _) = sendHandshakes stream - act (O.Message "/dirt/handshake/reply" xs) = do prev <- swapMVar (sBusses stream) $ bufferIndices xs - -- Only report the first time.. - when (null prev) $ verbose c $ "Connected to SuperDirt." - return () - where - bufferIndices [] = [] - bufferIndices (x:xs') | x == (O.AsciiString $ O.ascii "&controlBusIndices") = catMaybes $ takeWhile isJust $ map O.datum_integral xs' - | otherwise = bufferIndices xs' - -- External controller commands - act (O.Message "/ctrl" (O.Int32 k:v:[])) - = act (O.Message "/ctrl" [O.string $ show k,v]) - act (O.Message "/ctrl" (O.AsciiString k:v@(O.Float _):[])) - = add (O.ascii_to_string k) (VF (fromJust $ O.datum_floating v)) - act (O.Message "/ctrl" (O.AsciiString k:O.AsciiString v:[])) - = add (O.ascii_to_string k) (VS (O.ascii_to_string v)) - act (O.Message "/ctrl" (O.AsciiString k:O.Int32 v:[])) - = add (O.ascii_to_string k) (VI (fromIntegral v)) - -- Stream playback commands - act (O.Message "/mute" (k:[])) - = withID k $ streamMute stream - act (O.Message "/unmute" (k:[])) - = withID k $ streamUnmute stream - act (O.Message "/solo" (k:[])) - = withID k $ streamSolo stream - act (O.Message "/unsolo" (k:[])) - = withID k $ streamUnsolo stream - act (O.Message "/muteAll" []) - = streamMuteAll stream - act (O.Message "/unmuteAll" []) - = streamUnmuteAll stream - act (O.Message "/unsoloAll" []) - = streamUnsoloAll stream - act (O.Message "/hush" []) - = streamHush stream - act (O.Message "/silence" (k:[])) - = withID k $ streamSilence stream - act m = hPutStrLn stderr $ "Unhandled OSC: " ++ show m - add :: String -> Value -> IO () - add k v = do sMap <- takeMVar (sStateMV stream) - putMVar (sStateMV stream) $ Map.insert k v sMap - return () - withID :: O.Datum -> (ID -> IO ()) -> IO () - withID (O.AsciiString k) func = func $ (ID . O.ascii_to_string) k - withID (O.Int32 k) func = func $ (ID . show) k - withID _ _ = return () -ctrlResponder _ _ _ = return () - -verbose :: Config -> String -> IO () -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 diff --git a/src/Sound/Tidal/Stream/Target.hs b/src/Sound/Tidal/Stream/Target.hs new file mode 100644 index 000000000..964cb992f --- /dev/null +++ b/src/Sound/Tidal/Stream/Target.hs @@ -0,0 +1,156 @@ +module Sound.Tidal.Stream.Target where + +import qualified Sound.Osc.Fd as O +import qualified Network.Socket as N +import Data.Maybe (fromJust, isJust) +import Control.Concurrent (forkOS, threadDelay) +import Foreign (Word8) + +import Sound.Tidal.Pattern +import Sound.Tidal.Stream.Types +import Sound.Tidal.Stream.Config + +{- + Target.hs - Create and send to OSC targets + 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 . +-} + + +getCXs :: Config -> [(Target, [OSC])] -> IO [Cx] +getCXs config oscmap = mapM (\(target, os) -> do + remote_addr <- resolve (oAddress target) (show $ oPort target) + remote_bus_addr <- if isJust $ oBusPort target + then Just <$> resolve (oAddress target) (show $ fromJust $ oBusPort target) + else return Nothing + let broadcast = if cCtrlBroadcast config then 1 else 0 + u <- O.udp_socket (\sock sockaddr -> do N.setSocketOption sock N.Broadcast broadcast + N.connect sock sockaddr + ) (oAddress target) (oPort target) + return $ Cx {cxUDP = u, cxAddr = remote_addr, cxBusAddr = remote_bus_addr, cxTarget = target, cxOSCs = os} + ) oscmap + +resolve :: String -> String -> IO N.AddrInfo +resolve host port = do let hints = N.defaultHints { N.addrSocketType = N.Stream } + addr:_ <- N.getAddrInfo (Just hints) (Just host) (Just port) + return addr + +-- send has three modes: +-- Send events early using timestamp in the OSC bundle - used by Superdirt +-- Send events early by adding timestamp to the OSC message - used by Dirt +-- Send events live by delaying the thread +send :: Maybe O.Udp -> Cx -> Double -> Double -> (Double, Bool, O.Message) -> IO () +send listen cx latency extraLatency (time, isBusMsg, m) + | oSchedule target == Pre BundleStamp = sendBndl isBusMsg listen cx $ O.Bundle timeWithLatency [m] + | oSchedule target == Pre MessageStamp = sendO isBusMsg listen cx $ addtime m + | otherwise = do _ <- forkOS $ do now <- O.time + threadDelay $ floor $ (timeWithLatency - now) * 1000000 + sendO isBusMsg listen cx m + return () + where addtime (O.Message mpath params) = O.Message mpath ((O.int32 sec):((O.int32 usec):params)) + ut = O.ntpr_to_posix timeWithLatency + sec :: Int + sec = floor ut + usec :: Int + usec = floor $ 1000000 * (ut - (fromIntegral sec)) + target = cxTarget cx + timeWithLatency = time - latency + extraLatency + +sendBndl :: Bool -> (Maybe O.Udp) -> Cx -> O.Bundle -> IO () +sendBndl isBusMsg (Just listen) cx bndl = O.sendTo listen (O.Packet_Bundle bndl) (N.addrAddress addr) + where addr | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx + | otherwise = cxAddr cx +sendBndl _ Nothing cx bndl = O.sendBundle (cxUDP cx) bndl + +sendO :: Bool -> (Maybe O.Udp) -> Cx -> O.Message -> IO () +sendO isBusMsg (Just listen) cx msg = O.sendTo listen (O.Packet_Message msg) (N.addrAddress addr) + where addr | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx + | otherwise = cxAddr cx +sendO _ Nothing cx msg = O.sendMessage (cxUDP cx) msg + + +superdirtTarget :: Target +superdirtTarget = Target {oName = "SuperDirt", + oAddress = "127.0.0.1", + oPort = 57120, + oBusPort = Just 57110, + oLatency = 0.2, + oWindow = Nothing, + oSchedule = Pre BundleStamp, + oHandshake = True + } + +superdirtShape :: OSC +superdirtShape = OSC "/dirt/play" $ Named {requiredArgs = ["s"]} + +dirtTarget :: Target +dirtTarget = Target {oName = "Dirt", + oAddress = "127.0.0.1", + oPort = 7771, + oBusPort = Nothing, + oLatency = 0.02, + oWindow = Nothing, + oSchedule = Pre MessageStamp, + oHandshake = False + } + +dirtShape :: OSC +dirtShape = OSC "/play" $ ArgList [("cps", fDefault 0), + ("s", Nothing), + ("offset", fDefault 0), + ("begin", fDefault 0), + ("end", fDefault 1), + ("speed", fDefault 1), + ("pan", fDefault 0.5), + ("velocity", fDefault 0.5), + ("vowel", sDefault ""), + ("cutoff", fDefault 0), + ("resonance", fDefault 0), + ("accelerate", fDefault 0), + ("shape", fDefault 0), + ("kriole", iDefault 0), + ("gain", fDefault 1), + ("cut", iDefault 0), + ("delay", fDefault 0), + ("delaytime", fDefault (-1)), + ("delayfeedback", fDefault (-1)), + ("crush", fDefault 0), + ("coarse", iDefault 0), + ("hcutoff", fDefault 0), + ("hresonance", fDefault 0), + ("bandf", fDefault 0), + ("bandq", fDefault 0), + ("unit", sDefault "rate"), + ("loop", fDefault 0), + ("n", fDefault 0), + ("attack", fDefault (-1)), + ("hold", fDefault 0), + ("release", fDefault (-1)), + ("orbit", iDefault 0) -- , + -- ("id", iDefault 0) + ] + +sDefault :: String -> Maybe Value +sDefault x = Just $ VS x +fDefault :: Double -> Maybe Value +fDefault x = Just $ VF x +rDefault :: Rational -> Maybe Value +rDefault x = Just $ VR x +iDefault :: Int -> Maybe Value +iDefault x = Just $ VI x +bDefault :: Bool -> Maybe Value +bDefault x = Just $ VB x +xDefault :: [Word8] -> Maybe Value +xDefault x = Just $ VX x diff --git a/src/Sound/Tidal/Stream/Types.hs b/src/Sound/Tidal/Stream/Types.hs index ba0c789a0..f5589f353 100644 --- a/src/Sound/Tidal/Stream/Types.hs +++ b/src/Sound/Tidal/Stream/Types.hs @@ -1,9 +1,64 @@ module Sound.Tidal.Stream.Types where +import Control.Concurrent.MVar import qualified Data.Map.Strict as Map import Sound.Tidal.Pattern import Sound.Tidal.Show () +import qualified Sound.Osc.Fd as O +import qualified Network.Socket as N + +import qualified Sound.Tidal.Clock as Clock + +import Sound.Tidal.Stream.Config + +data Stream = Stream {sConfig :: Config, + sBusses :: MVar [Int], + sStateMV :: MVar ValueMap, + -- sOutput :: MVar ControlPattern, + sClockRef :: Clock.ClockRef, + sListen :: Maybe O.Udp, + sPMapMV :: MVar PlayMap, + sGlobalFMV :: MVar (ControlPattern -> ControlPattern), + sCxs :: [Cx] + } + +data Cx = Cx {cxTarget :: Target, + cxUDP :: O.Udp, + cxOSCs :: [OSC], + cxAddr :: N.AddrInfo, + cxBusAddr :: Maybe N.AddrInfo + } + +data StampStyle = BundleStamp + | MessageStamp + deriving (Eq, Show) + +data Schedule = Pre StampStyle + | Live + deriving (Eq, Show) + +data Target = Target {oName :: String, + oAddress :: String, + oPort :: Int, + oBusPort :: Maybe Int, + oLatency :: Double, + oWindow :: Maybe Arc, + oSchedule :: Schedule, + oHandshake :: Bool + } + deriving Show + +data Args = Named {requiredArgs :: [String]} + | ArgList [(String, Maybe Value)] + deriving Show + +data OSC = OSC {path :: String, + args :: Args + } + | OSCContext {path :: String} + deriving Show + data PlayState = PlayState {pattern :: ControlPattern, mute :: Bool, solo :: Bool, @@ -14,11 +69,11 @@ data PlayState = PlayState {pattern :: ControlPattern, type PatId = String type PlayMap = Map.Map PatId PlayState -data TickState = TickState { - tickArc :: Arc, - tickNudge :: Double - } - deriving Show +-- data TickState = TickState { +-- tickArc :: Arc, +-- tickNudge :: Double +-- } +-- deriving Show patternTimeID :: String patternTimeID = "_t_pattern" diff --git a/src/Sound/Tidal/Stream/UI.hs b/src/Sound/Tidal/Stream/UI.hs new file mode 100644 index 000000000..1ebeb4553 --- /dev/null +++ b/src/Sound/Tidal/Stream/UI.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} +module Sound.Tidal.Stream.UI where + +import Data.Maybe (isJust) +import qualified Data.Map as Map +import qualified Control.Exception as E +import Control.Concurrent.MVar +import System.IO (hPutStrLn, stderr) +import System.Random (getStdRandom, randomR) +import qualified Sound.Osc.Fd as O + +import qualified Sound.Tidal.Clock as Clock +import Sound.Tidal.Stream.Types +import Sound.Tidal.Stream.Config +import Sound.Tidal.Stream.Process +import Sound.Tidal.Stream.Target + +import Sound.Tidal.Pattern +import Sound.Tidal.ID + +streamNudgeAll :: Stream -> Double -> IO () +streamNudgeAll s = Clock.setNudge (sClockRef s) + +streamResetCycles :: Stream -> IO () +streamResetCycles s = streamSetCycle s 0 + +streamSetCycle :: Stream -> Time -> IO () +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) + +streamEnableLink :: Stream -> IO () +streamEnableLink s = Clock.enableLink (sClockRef s) + +streamDisableLink :: Stream -> IO () +streamDisableLink s = Clock.disableLink (sClockRef s) + +streamList :: Stream -> IO () +streamList s = do pMap <- readMVar (sPMapMV s) + let hs = hasSolo pMap + putStrLn $ concatMap (showKV hs) $ Map.toList pMap + where showKV :: Bool -> (PatId, PlayState) -> String + showKV True (k, (PlayState {solo = True})) = k ++ " - solo\n" + showKV True (k, _) = "(" ++ k ++ ")\n" + showKV False (k, (PlayState {solo = False})) = k ++ "\n" + showKV False (k, _) = "(" ++ k ++ ") - muted\n" + +streamReplace :: Stream -> ID -> ControlPattern -> IO () +streamReplace stream k !pat = do + t <- Clock.getCycleTime (cClockConfig $ sConfig stream) (sClockRef stream) + E.handle (\ (e :: E.SomeException) -> do + hPutStrLn stderr $ "Failed to Stream.streamReplace: " ++ show e + hPutStrLn stderr $ "Return to previous pattern." + setPreviousPatternOrSilence (sPMapMV stream)) (updatePattern stream k t pat) + + -- = modifyMVar_ (sActionsMV s) (\actions -> return $ (T.StreamReplace k pat) : actions) + +-- streamFirst but with random cycle instead of always first cicle +streamOnce :: Stream -> ControlPattern -> IO () +streamOnce st p = do i <- getStdRandom $ randomR (0, 8192) + streamFirst st $ rotL (toRational (i :: Int)) p + +streamFirst :: Stream -> ControlPattern -> IO () +streamFirst stream pat = onSingleTick (sConfig stream) (sClockRef stream) (sStateMV stream) (sBusses stream) (sPMapMV stream) (sGlobalFMV stream) (sCxs stream) (sListen stream) pat + +streamMute :: Stream -> ID -> IO () +streamMute s k = withPatIds s [k] (\x -> x {mute = True}) + +streamMutes :: Stream -> [ID] -> IO () +streamMutes s ks = withPatIds s ks (\x -> x {mute = True}) + +streamUnmute :: Stream -> ID -> IO () +streamUnmute s k = withPatIds s [k] (\x -> x {mute = False}) + +streamSolo :: Stream -> ID -> IO () +streamSolo s k = withPatIds s [k] (\x -> x {solo = True}) + +streamUnsolo :: Stream -> ID -> IO () +streamUnsolo s k = withPatIds s [k] (\x -> x {solo = False}) + +withPatIds :: Stream -> [ID] -> (PlayState -> PlayState) -> IO () +withPatIds s ks f + = do playMap <- takeMVar $ sPMapMV s + let pMap' = foldr (Map.update (\x -> Just $ f x)) playMap (map fromID ks) + putMVar (sPMapMV s) pMap' + return () + +-- TODO - is there a race condition here? +streamMuteAll :: Stream -> IO () +streamMuteAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {mute = True}) + +streamHush :: Stream -> IO () +streamHush s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {pattern = silence, history = silence:history x}) + +streamUnmuteAll :: Stream -> IO () +streamUnmuteAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {mute = False}) + +streamUnsoloAll :: Stream -> IO () +streamUnsoloAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {solo = False}) + +streamSilence :: Stream -> ID -> IO () +streamSilence s k = withPatIds s [k] (\x -> x {pattern = silence, history = silence:history x}) + +streamAll :: Stream -> (ControlPattern -> ControlPattern) -> IO () +streamAll s f = do _ <- swapMVar (sGlobalFMV s) f + return () + +streamGet :: Stream -> String -> IO (Maybe Value) +streamGet s k = Map.lookup k <$> readMVar (sStateMV s) + +streamSet :: Valuable a => Stream -> String -> Pattern a -> IO () +streamSet s k pat = do sMap <- takeMVar $ sStateMV s + let pat' = toValue <$> pat + sMap' = Map.insert k (VPattern pat') sMap + putMVar (sStateMV s) $ sMap' + +streamSetI :: Stream -> String -> Pattern Int -> IO () +streamSetI = streamSet + +streamSetF :: Stream -> String -> Pattern Double -> IO () +streamSetF = streamSet + +streamSetS :: Stream -> String -> Pattern String -> IO () +streamSetS = streamSet + +streamSetB :: Stream -> String -> Pattern Bool -> IO () +streamSetB = streamSet + +streamSetR :: Stream -> String -> Pattern Rational -> IO () +streamSetR = streamSet + +-- It only really works to handshake with one target at the moment.. +sendHandshakes :: Stream -> IO () +sendHandshakes stream = mapM_ sendHandshake $ filter (oHandshake . cxTarget) (sCxs stream) + where sendHandshake cx = if (isJust $ sListen stream) + then + do -- send it _from_ the udp socket we're listening to, so the + -- replies go back there + sendO False (sListen stream) cx $ O.Message "/dirt/handshake" [] + else + hPutStrLn stderr "Can't handshake with SuperCollider without control port." diff --git a/src/Sound/Tidal/Transition.hs b/src/Sound/Tidal/Transition.hs index 47f6fd1a9..b976c72b2 100644 --- a/src/Sound/Tidal/Transition.hs +++ b/src/Sound/Tidal/Transition.hs @@ -15,7 +15,6 @@ import Sound.Tidal.Stream.Config import Sound.Tidal.ID import Sound.Tidal.Params (gain, pan) import Sound.Tidal.Pattern -import Sound.Tidal.Stream.Stream import Sound.Tidal.Stream.Types import qualified Sound.Tidal.Clock as Clock -- import Sound.Tidal.Tempo as T diff --git a/tidal.cabal b/tidal.cabal index e12d00b10..ccc7fe1f2 100644 --- a/tidal.cabal +++ b/tidal.cabal @@ -41,9 +41,14 @@ library Sound.Tidal.Safe.Boot Sound.Tidal.Show Sound.Tidal.Simple - Sound.Tidal.Stream.Stream - Sound.Tidal.Stream.Types + Sound.Tidal.Stream Sound.Tidal.Stream.Config + Sound.Tidal.Stream.Listen + Sound.Tidal.Stream.Main + Sound.Tidal.Stream.Process + Sound.Tidal.Stream.Types + Sound.Tidal.Stream.Target + Sound.Tidal.Stream.UI Sound.Tidal.Time Sound.Tidal.Transition Sound.Tidal.UI