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 diff --git a/src/Sound/Tidal/Context.hs b/src/Sound/Tidal/Context.hs index 3d78630f5..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.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 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 aee2ef769..434b87159 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..afb3754dd 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,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 - (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 @@ -79,7 +80,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/Stream.hs b/src/Sound/Tidal/Stream.hs index ff30c0ff3..973cf09fd 100644 --- a/src/Sound/Tidal/Stream.hs +++ b/src/Sound/Tidal/Stream.hs @@ -1,16 +1,23 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-missing-fields #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE StandaloneDeriving #-} - -module Sound.Tidal.Stream (module Sound.Tidal.Stream) where +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.Listen +import Sound.Tidal.Stream.Main +import Sound.Tidal.Stream.Process +import Sound.Tidal.Stream.Target +import Sound.Tidal.Stream.Types +import Sound.Tidal.Stream.UI {- - Stream.hs - Tidal's thingie for turning patterns into OSC streams + 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 @@ -26,750 +33,3 @@ module Sound.Tidal.Stream (module Sound.Tidal.Stream) where 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 -import Control.Concurrent.MVar () -import qualified Control.Exception as E -import Control.Monad (forM_, when) -import Data.Coerce (coerce) -import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes, fromJust, fromMaybe, - isJust) -import Foreign -import Foreign.C.Types -import System.IO (hPutStrLn, stderr) - -import qualified Network.Socket as N -import qualified Sound.Osc.Fd as O -import qualified Sound.Osc.Time.Timeout as O - -import Data.List (sortOn) -import Sound.Tidal.Config -import Sound.Tidal.Core (stack, (#)) -import Sound.Tidal.ID -import qualified Sound.Tidal.Link as Link -import Sound.Tidal.Params (pS) -import Sound.Tidal.Pattern -import Sound.Tidal.Show () -import qualified Sound.Tidal.Tempo as T -import Sound.Tidal.Utils ((!!!)) -import System.Random (getStdRandom, randomR) - -import Sound.Tidal.Version - -import Sound.Tidal.StreamTypes as Sound.Tidal.Stream - -data Stream = Stream {sConfig :: Config, - sBusses :: MVar [Int], - sStateMV :: MVar ValueMap, - -- sOutput :: MVar ControlPattern, - sLink :: Link.AbletonLink, - sListen :: Maybe O.Udp, - sPMapMV :: MVar PlayMap, - sActionsMV :: MVar [T.TempoAction], - sGlobalFMV :: MVar (ControlPattern -> ControlPattern), - sCxs :: [Cx] - } - -data Cx = Cx {cxTarget :: Target, - cxUDP :: O.Udp, - cxOSCs :: [OSC], - cxAddr :: N.AddrInfo, - cxBusAddr :: Maybe N.AddrInfo - } - deriving (Show) - -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 - actionsMV <- newEmptyMVar - - 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 - let bpm = (coerce defaultCps) * 60 * (cBeatsPerCycle config) - abletonLink <- Link.create bpm - let stream = Stream {sConfig = config, - sBusses = bussesMV, - sStateMV = sMapMV, - sLink = abletonLink, - sListen = listen, - sPMapMV = pMapMV, - 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 - --- 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 psPattern) . (filter active) . Map.elems $ pMap - where active pState = if hasSolo pMap - then psSolo pState - else not (psMute 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 (\v -> VS ('c':(show $ toBus $ fromMaybe 0 $ getI v))) 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 (T.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, b) -> do k' <- if (not $ null k) && head k == '^' then Just (tail k) else Nothing - v <- Map.lookup k' playmap - bi <- getI b - return $ (tsPart, - True, -- bus message ? - O.Message "/c_set" [O.int32 bi, 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 - - --- 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 {psPattern = pat', psHistory = pat:(psHistory 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 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) - onCycle = start wope - onBeat = (T.cyclesToBeat ops) (realToFrac onCycle) - offCycle = stop wope - offBeat = (T.cyclesToBeat ops) (realToFrac offCycle) - on <- (T.timeAtBeat ops) onBeat - onPart <- (T.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' - ) - off <- (T.timeAtBeat ops) offBeat - bpm <- (T.getTempo ops) - let cps = ((T.beatToCycles ops) bpm) / 60 - let delta = off - on - return $! ProcessedEvent { - peHasOnset = eventHasOnset e, - peEvent = e, - peCps = cps, - peDelta = delta, - peCycle = onCycle, - peOnWholeOrPart = on, - peOnWholeOrPartOsc = (T.linkToOscTime ops) on, - peOnPart = onPart, - peOnPartOsc = (T.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 - --- 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 - --- 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 - pMapMV <- newMVar $ Map.singleton "fake" - (PlayState {psPattern = pat, - psMute = False, - psSolo = False, - psHistory = [] - } - ) - - -- The nowArc is a full cycle - let state = TickState {tickArc = (Arc 0 1), tickNudge = 0} - doTick (stream {sPMapMV = pMapMV}) state ops s - - --- | 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 :: Stream -> TickState -> T.LinkOperations -> ValueMap -> IO ValueMap -doTick stream st ops sMap = - 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) - let - cxs = sCxs stream - patstack = sGlobalF $ playStack pMap - cps = ((T.beatToCycles ops) bpm) / 60 - sMap' = Map.insert "_cps" (VF $ coerce cps) sMap - extraLatency = tickNudge st - -- First the state is used to query the pattern - es = sortOn (start . part) $ query patstack (State {arc = tickArc st, - 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 (sListen stream) 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'') - -setPreviousPatternOrSilence :: Stream -> IO () -setPreviousPatternOrSilence stream = - modifyMVar_ (sPMapMV stream) $ return - . Map.map ( \ pMap -> case psHistory pMap of - _:p:ps -> pMap { psPattern = p, psHistory = p:ps } - _ -> pMap { psPattern = silence, psHistory = [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 nudge = T.setNudge (sActionsMV s) nudge - -streamResetCycles :: Stream -> IO () -streamResetCycles s = streamSetCycle s 0 - -streamSetCycle :: Stream -> Time -> IO () -streamSetCycle s cyc = T.setCycle cyc (sActionsMV s) - -hasSolo :: Map.Map k PlayState -> Bool -hasSolo = (>= 1) . length . filter psSolo . 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 {psSolo = True})) = k ++ " - solo\n" - showKV True (k, _) = "(" ++ k ++ ")\n" - showKV False (k, (PlayState {psSolo = 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. - -streamReplace :: Stream -> ID -> ControlPattern -> IO () -streamReplace s k !pat - = modifyMVar_ (sActionsMV s) (\actions -> return $ (T.StreamReplace k pat) : actions) - -streamMute :: Stream -> ID -> IO () -streamMute s k = withPatIds s [k] (\x -> x {psMute = True}) - -streamMutes :: Stream -> [ID] -> IO () -streamMutes s ks = withPatIds s ks (\x -> x {psMute = True}) - -streamUnmute :: Stream -> ID -> IO () -streamUnmute s k = withPatIds s [k] (\x -> x {psMute = False}) - -streamSolo :: Stream -> ID -> IO () -streamSolo s k = withPatIds s [k] (\x -> x {psSolo = True}) - -streamUnsolo :: Stream -> ID -> IO () -streamUnsolo s k = withPatIds s [k] (\x -> x {psSolo = 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 {psMute = True}) - -streamHush :: Stream -> IO () -streamHush s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {psPattern = silence, psHistory = silence:psHistory x}) - -streamUnmuteAll :: Stream -> IO () -streamUnmuteAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {psMute = False}) - -streamUnsoloAll :: Stream -> IO () -streamUnsoloAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {psSolo = False}) - -streamSilence :: Stream -> ID -> IO () -streamSilence s k = withPatIds s [k] (\x -> x {psPattern = silence, psHistory = silence:psHistory 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 - -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/Config.hs b/src/Sound/Tidal/Stream/Config.hs similarity index 58% rename from src/Sound/Tidal/Config.hs rename to src/Sound/Tidal/Stream/Config.hs index 8e83853b4..295c41c46 100644 --- a/src/Sound/Tidal/Config.hs +++ b/src/Sound/Tidal/Stream/Config.hs @@ -1,7 +1,6 @@ -module Sound.Tidal.Config where +module Sound.Tidal.Stream.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, + -- cTempoAddr :: String, + -- cTempoPort :: Int, + -- cTempoClientPort :: Int, 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, + -- cTempoAddr = "127.0.0.1", + -- cTempoPort = 9160, + -- cTempoClientPort = 0, -- choose at random cVerbose = True, - cQuantum = 4, - cBeatsPerCycle = 4 + 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/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 new file mode 100644 index 000000000..f5589f353 --- /dev/null +++ b/src/Sound/Tidal/Stream/Types.hs @@ -0,0 +1,79 @@ +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, + history :: [ControlPattern] + } + deriving Show + +type PatId = String +type PlayMap = Map.Map PatId PlayState + +-- 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/StreamTypes.hs b/src/Sound/Tidal/StreamTypes.hs deleted file mode 100644 index b37e6bf40..000000000 --- a/src/Sound/Tidal/StreamTypes.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Sound.Tidal.StreamTypes where - -import qualified Data.Map.Strict as Map -import Sound.Tidal.Pattern -import Sound.Tidal.Show () - -data PlayState = PlayState {psPattern :: ControlPattern, - psMute :: Bool, - psSolo :: Bool, - psHistory :: [ControlPattern] - } - deriving Show - -type PatId = String -type PlayMap = Map.Map PatId PlayState - -data TickState = TickState { - tickArc :: Arc, - tickNudge :: Double - } - deriving Show - -patternTimeID :: String -patternTimeID = "_t_pattern" diff --git a/src/Sound/Tidal/Tempo.hs b/src/Sound/Tidal/Tempo.hs deleted file mode 100644 index 6365c603a..000000000 --- a/src/Sound/Tidal/Tempo.hs +++ /dev/null @@ -1,309 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns -fno-warn-orphans #-} - - -module Sound.Tidal.Tempo where - -import Control.Concurrent (ThreadId, forkIO, threadDelay) -import Control.Concurrent.MVar -import qualified Control.Exception as E -import Control.Monad (when) -import Data.Int (Int64) -import qualified Data.Map.Strict as Map -import Foreign.C.Types (CDouble (..)) -import qualified Sound.Osc.Fd as O -import Sound.Tidal.Config -import Sound.Tidal.ID -import qualified Sound.Tidal.Link as Link -import qualified Sound.Tidal.Pattern as P -import Sound.Tidal.Utils (writeError) -import System.IO (hPutStrLn, stderr) - -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 - } - -{-| - Start cycles from the given cycle number. - - > setCycle 5 - > d1 $ n "6 2 0 8" # s "east" --} -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 {psHistory = (appendPat historyFlag) (psHistory playState)} - updatePS Nothing = PlayState {psPattern = P.silence, - psMute = False, - psSolo = False, - psHistory = (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) (psHistory playState) - let pMap' = Map.insert (fromID patId) (playState {psPattern = pat'}) pMap - _ <- swapMVar mapMV pMap' - return (st', streamState') diff --git a/src/Sound/Tidal/Transition.hs b/src/Sound/Tidal/Transition.hs index c4139325b..b976c72b2 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.Stream.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 Sound.Tidal.Stream.Types +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/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) 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..1fa5db311 --- /dev/null +++ b/tidal-link/src/hs/Sound/Tidal/Clock.hs @@ -0,0 +1,359 @@ +module Sound.Tidal.Clock where + +import qualified Sound.Tidal.Link as Link +import qualified Sound.Osc.Fd as O + +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) + +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 + ,clockAction :: TickAction + } + +-- | 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 :: TVar ClockAction + ,rAbletonLink :: Link.AbletonLink + } + +-- | configuration of the clock +data ClockConfig + = ClockConfig + {cQuantum :: CDouble + ,cBeatsPerCycle :: CDouble + ,cFrameTimespan :: Double + ,cEnableLink :: Bool + ,cSkipTicks :: Int64 + ,cProcessAhead :: Double + } + +-- | 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 :: Double +defaultCps = 0.575 + +defaultConfig :: ClockConfig +defaultConfig = ClockConfig + {cFrameTimespan = 1/20 + ,cEnableLink = False + ,cProcessAhead = 3/10 + ,cSkipTicks = 10 + ,cQuantum = 4 + ,cBeatsPerCycle = 4 + } + +-- | creates a clock according to the config and runs it +-- | in a seperate thread +clocked :: ClockConfig -> TickAction -> IO ClockRef +clocked config ac = runClock config ac clockCheck + +-- | runs the clock on the initial state and memory as given +-- | by initClock, hands the ClockRef for interaction from outside +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 -> TickAction -> IO (ClockMemory, ClockState) +initClock config ac = 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 <- atomically $ newTVar NoAction + let st = ClockState {ticks = 0, + start = now, + nowArc = (0,0), + nudged = 0 + } + return (ClockMemory config (ClockRef clockMV abletonLink) ac, 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 $ atomically $ swapTVar 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) action) <- 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 $ action (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.destroySessionState 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.destroySessionState ss + return $! c + +-- 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 + +setClock :: ClockRef -> Time -> IO () +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 = 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 = atomically $ do + action <- readTVar clock + case action of + NoAction -> modifyTVar' clock (const $ SetNudge n) + _ -> retry + +disableLink :: ClockRef -> IO () +disableLink (ClockRef _ abletonLink) = Link.disable abletonLink + +enableLink :: ClockRef -> IO () +enableLink (ClockRef _ abletonLink) = Link.enable abletonLink diff --git a/tidal-link/tidal-link.cabal b/tidal-link/tidal-link.cabal index 8d2c76518..94c169358 100644 --- a/tidal-link/tidal-link.cabal +++ b/tidal-link/tidal-link.cabal @@ -29,9 +29,13 @@ library default-language: Haskell2010 exposed-modules: Sound.Tidal.Link + Sound.Tidal.Clock build-depends: - base >=4.8 && <5 + base >=4.8 && <5, + hosc, + mtl, + stm if os(windows) extra-libraries: @@ -46,7 +50,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 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 diff --git a/tidal.cabal b/tidal.cabal index 5118d1519..2d020869a 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 @@ -43,8 +42,13 @@ library Sound.Tidal.Show Sound.Tidal.Simple Sound.Tidal.Stream - Sound.Tidal.StreamTypes - Sound.Tidal.Tempo + 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