From f0eb4b86e3e3e198eb933334d128ae62bdd94338 Mon Sep 17 00:00:00 2001 From: Matthew Kaney Date: Wed, 5 Jul 2023 16:44:16 -0400 Subject: [PATCH 01/12] Move bus handshake to per-target implementation --- src/Sound/Tidal/Stream.hs | 222 +++++++++++++++++++------------------- 1 file changed, 110 insertions(+), 112 deletions(-) diff --git a/src/Sound/Tidal/Stream.hs b/src/Sound/Tidal/Stream.hs index b9d6c2990..5cfd2a505 100644 --- a/src/Sound/Tidal/Stream.hs +++ b/src/Sound/Tidal/Stream.hs @@ -54,25 +54,24 @@ import Sound.Tidal.Version import Sound.Tidal.StreamTypes as Sound.Tidal.Stream -data Stream = Stream {sConfig :: Config, - sBusses :: MVar [Int], - sStateMV :: MVar ValueMap, +data Stream = Stream {sConfig :: Config, + sStateMV :: MVar ValueMap, -- sOutput :: MVar ControlPattern, - sLink :: Link.AbletonLink, - sListen :: Maybe O.Udp, - sPMapMV :: MVar PlayMap, + 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 +data Cx = Cx {cxTarget :: Target, + cxUDP :: O.Udp, + cxOSCs :: [OSC], + cxAddr :: N.AddrInfo, + cxBusAddr :: Maybe N.AddrInfo, + cxBusses :: Maybe (MVar [Int]) } - deriving (Show) data StampStyle = BundleStamp | MessageStamp @@ -203,7 +202,6 @@ 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 @@ -211,20 +209,20 @@ startStream config oscmap 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 + cxs <- mapM (\(target, os) -> do remote_addr <- resolve (oAddress target) (oPort target) + remote_bus_addr <- sequence (resolve (oAddress target) <$> (oBusPort target)) + remote_busses <- sequence (oBusPort target >> (Just $ newMVar [])) 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} + let cx = Cx {cxUDP = u, cxAddr = remote_addr, cxBusAddr = remote_bus_addr, cxBusses = remote_busses, cxTarget = target, cxOSCs = os} + handshake cx config + return cx ) 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, @@ -233,7 +231,6 @@ startStream config oscmap sGlobalFMV = globalFMV, sCxs = cxs } - sendHandshakes stream let ac = T.ActionHandler { T.onTick = onTick stream, T.onSingleTick = onSingleTick stream, @@ -242,35 +239,51 @@ startStream config oscmap -- 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 + _ <- forkIO $ ctrlResponder 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) +handshake :: Cx -> Config -> IO () +handshake Cx { cxUDP = udp, cxBusses = Just bussesMV } c = sendHandshake >> listen 0 + where + sendHandshake :: IO () + sendHandshake = O.sendMessage udp (O.Message "/dirt/handshake" []) + listen :: Int -> IO () + listen waits = do ms <- recvMessagesTimeout 2 udp + if (null ms) + then do checkHandshake waits -- there was a timeout, check handshake + listen (waits+1) + else do mapM_ respond ms + listen 0 + checkHandshake :: Int -> IO () + checkHandshake waits = do busses <- readMVar bussesMV + when (null busses) $ do when (waits == 0) $ verbose c $ "Waiting for SuperDirt (v.1.7.2 or higher).." + sendHandshake + respond :: O.Message -> IO () + respond (O.Message "/dirt/hello" _) = sendHandshake + respond (O.Message "/dirt/handshake/reply" xs) = do prev <- swapMVar bussesMV $ bufferIndices xs + -- Only report the first time.. + when (null prev) $ verbose c $ "Connected to SuperDirt." + return () + respond _ = return () + bufferIndices :: [O.Datum] -> [Int] + bufferIndices [] = [] + bufferIndices (x:xs') | x == (O.AsciiString $ O.ascii "&controlBusIndices") = catMaybes $ takeWhile isJust $ map O.datum_integral xs' + | otherwise = bufferIndices xs' +handshake _ _ = return () + +sendO :: Bool -> Cx -> O.Message -> IO () +sendO isBusMsg cx msg = O.sendTo (cxUDP cx) (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) +sendBndl :: Bool -> Cx -> O.Bundle -> IO () +sendBndl isBusMsg cx bndl = O.sendTo (cxUDP cx) (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 :: String -> Int -> IO N.AddrInfo resolve host port = do let hints = N.defaultHints { N.addrSocketType = N.Stream } - addr:_ <- N.getAddrInfo (Just hints) (Just host) (Just port) + addr:_ <- N.getAddrInfo (Just hints) (Just host) (Just $ show port) return addr -- Start an instance of Tidal with superdirt OSC @@ -337,8 +350,8 @@ playStack pMap = stack . (map pattern) . (filter active) . Map.elems $ pMap then solo pState else not (mute pState) -toOSC :: [Int] -> ProcessedEvent -> OSC -> [(Double, Bool, O.Message)] -toOSC busses pe osc@(OSC _ _) +toOSC :: Maybe [Int] -> ProcessedEvent -> OSC -> [(Double, Bool, O.Message)] +toOSC maybeBusses 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 @@ -373,8 +386,8 @@ toOSC busses pe osc@(OSC _ _) O.Message mungedPath vs ) | otherwise = Nothing - toBus n | null busses = n - | otherwise = busses !!! n + toBus n | Just busses <- maybeBusses, (not . null) busses = busses !!! n + | otherwise = n busmsgs = map (\(('^':k), (VI b)) -> do v <- Map.lookup k playmap return $ (tsPart, @@ -503,7 +516,6 @@ doTick stream st ops sMap = setPreviousPatternOrSilence stream return sMap) (do pMap <- readMVar (sPMapMV stream) - busses <- readMVar (sBusses stream) sGlobalF <- readMVar (sGlobalFMV stream) bpm <- (T.getTempo ops) let @@ -521,14 +533,15 @@ doTick stream st ops sMap = (sMap'', es') = resolveState sMap' es tes <- processCps ops es' -- For each OSC target - forM_ cxs $ \cx@(Cx target _ oscs _ _) -> do + forM_ cxs $ \cx@(Cx target _ oscs _ _ bussesMV) -> do + busses <- mapM readMVar bussesMV -- 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 + send 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'') @@ -544,13 +557,13 @@ setPreviousPatternOrSilence stream = -- 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 +send :: Cx -> Double -> Double -> (Double, Bool, O.Message) -> IO () +send cx latency extraLatency (time, isBusMsg, m) + | oSchedule target == Pre BundleStamp = sendBndl isBusMsg cx $ O.Bundle timeWithLatency [m] + | oSchedule target == Pre MessageStamp = sendO isBusMsg cx $ addtime m | otherwise = do _ <- forkOS $ do now <- O.time threadDelay $ floor $ (timeWithLatency - now) * 1000000 - sendO isBusMsg listen cx m + sendO isBusMsg 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 @@ -671,66 +684,51 @@ openListener c 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 () +ctrlResponder :: Config -> Stream -> IO () +ctrlResponder c (stream@(Stream {sListen = Just sock})) = loop + where + loop :: IO () + loop = do O.recvMessages sock >>= mapM_ act + loop + -- External controller commands + act :: O.Message -> IO () + 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 From 18791d751671d5e5d3cde85b575996d915701dde Mon Sep 17 00:00:00 2001 From: Matthew Kaney Date: Thu, 6 Jul 2023 18:45:06 -0400 Subject: [PATCH 02/12] Start adding tests for handshake --- test/Sound/Tidal/StreamTest.hs | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/test/Sound/Tidal/StreamTest.hs b/test/Sound/Tidal/StreamTest.hs index 06dd610b9..3ce881c28 100644 --- a/test/Sound/Tidal/StreamTest.hs +++ b/test/Sound/Tidal/StreamTest.hs @@ -3,13 +3,16 @@ module Sound.Tidal.StreamTest where import Test.Microspec + +import Sound.Tidal.Config import Sound.Tidal.Stream import Sound.Tidal.Pattern import qualified Sound.Osc.Fd as O import qualified Data.Map.Strict as M +import Control.Concurrent.MVar -run :: Microspec () -run = +main :: Microspec () +main = describe "Sound.Tidal.Stream" $ do describe "toDatum" $ do it "should convert VN to osc float" $ do @@ -34,3 +37,9 @@ run = getString (M.singleton "s" (VS "sn")) "s=bd" `shouldBe` Just "sn" it "should work for missing params with fallback expressions" $ do getString M.empty "s=bd" `shouldBe` Just "bd" + + describe "handshake" $ do + it "should only handshake when a busPort is set" $ monadicIO $ do + superdirtHandshake <- run $ newMVar False + run $ startStream defaultConfig [(superdirtTarget, [superdirtShape])] + (== True) <$> run (readMVar superdirtHandshake) \ No newline at end of file From 753142e179171d4894f809804ba4031815e3a2f2 Mon Sep 17 00:00:00 2001 From: Matthew Kaney Date: Mon, 17 Jul 2023 17:10:32 -0400 Subject: [PATCH 03/12] Fix bugs with per-context busmaps --- src/Sound/Tidal/Stream.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Sound/Tidal/Stream.hs b/src/Sound/Tidal/Stream.hs index 5cfd2a505..ebe81ba37 100644 --- a/src/Sound/Tidal/Stream.hs +++ b/src/Sound/Tidal/Stream.hs @@ -214,10 +214,10 @@ startStream config oscmap remote_busses <- sequence (oBusPort target >> (Just $ newMVar [])) 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 + -- N.connect sock sockaddr ) (oAddress target) (oPort target) let cx = Cx {cxUDP = u, cxAddr = remote_addr, cxBusAddr = remote_bus_addr, cxBusses = remote_busses, cxTarget = target, cxOSCs = os} - handshake cx config + _ <- forkIO $ handshake cx config return cx ) oscmap let bpm = (coerce defaultCps) * 60 * (cBeatsPerCycle config) @@ -243,10 +243,10 @@ startStream config oscmap return stream handshake :: Cx -> Config -> IO () -handshake Cx { cxUDP = udp, cxBusses = Just bussesMV } c = sendHandshake >> listen 0 +handshake Cx { cxUDP = udp, cxBusses = Just bussesMV, cxAddr = addr } c = sendHandshake >> listen 0 where sendHandshake :: IO () - sendHandshake = O.sendMessage udp (O.Message "/dirt/handshake" []) + sendHandshake = O.sendTo udp (O.Packet_Message $ O.Message "/dirt/handshake" []) (N.addrAddress addr) listen :: Int -> IO () listen waits = do ms <- recvMessagesTimeout 2 udp if (null ms) From 73ed26e55ba9c42aeea6c09fee1ba225fe675e70 Mon Sep 17 00:00:00 2001 From: Matthew Kaney Date: Mon, 17 Jul 2023 20:50:46 -0400 Subject: [PATCH 04/12] Remove handshake tests for now This reverts commit 8f6e3f72a7c1ad2bbd87637921577c19cb2e39d6. --- test/Sound/Tidal/StreamTest.hs | 12 ++---------- 1 file changed, 2 insertions(+), 10 deletions(-) diff --git a/test/Sound/Tidal/StreamTest.hs b/test/Sound/Tidal/StreamTest.hs index 3ce881c28..83f0fa47b 100644 --- a/test/Sound/Tidal/StreamTest.hs +++ b/test/Sound/Tidal/StreamTest.hs @@ -4,15 +4,13 @@ module Sound.Tidal.StreamTest where import Test.Microspec -import Sound.Tidal.Config import Sound.Tidal.Stream import Sound.Tidal.Pattern import qualified Sound.Osc.Fd as O import qualified Data.Map.Strict as M -import Control.Concurrent.MVar -main :: Microspec () -main = +run :: Microspec () +run = describe "Sound.Tidal.Stream" $ do describe "toDatum" $ do it "should convert VN to osc float" $ do @@ -37,9 +35,3 @@ main = getString (M.singleton "s" (VS "sn")) "s=bd" `shouldBe` Just "sn" it "should work for missing params with fallback expressions" $ do getString M.empty "s=bd" `shouldBe` Just "bd" - - describe "handshake" $ do - it "should only handshake when a busPort is set" $ monadicIO $ do - superdirtHandshake <- run $ newMVar False - run $ startStream defaultConfig [(superdirtTarget, [superdirtShape])] - (== True) <$> run (readMVar superdirtHandshake) \ No newline at end of file From c3d9dd33f79c1974961f154864ebfc05af48ad3c Mon Sep 17 00:00:00 2001 From: Matthew Kaney Date: Thu, 11 Apr 2024 20:07:32 -0400 Subject: [PATCH 05/12] Re-implement per-context busses in reorganized Stream code --- src/Sound/Tidal/Stream/Config.hs | 5 ++ src/Sound/Tidal/Stream/Listen.hs | 40 ++++----------- src/Sound/Tidal/Stream/Main.hs | 9 +--- src/Sound/Tidal/Stream/Process.hs | 24 +++++---- src/Sound/Tidal/Stream/Target.hs | 81 +++++++++++++++++++++---------- src/Sound/Tidal/Stream/Types.hs | 4 +- src/Sound/Tidal/Stream/UI.hs | 18 +------ 7 files changed, 87 insertions(+), 94 deletions(-) diff --git a/src/Sound/Tidal/Stream/Config.hs b/src/Sound/Tidal/Stream/Config.hs index 295c41c46..b0b9e45a9 100644 --- a/src/Sound/Tidal/Stream/Config.hs +++ b/src/Sound/Tidal/Stream/Config.hs @@ -1,5 +1,7 @@ module Sound.Tidal.Stream.Config where +import Control.Monad (when) + import qualified Sound.Tidal.Clock as Clock {- @@ -42,3 +44,6 @@ defaultConfig = Config {cCtrlListen = True, cVerbose = True, cClockConfig = Clock.defaultConfig } + +verbose :: Config -> String -> IO () +verbose c s = when (cVerbose c) $ putStrLn s \ No newline at end of file diff --git a/src/Sound/Tidal/Stream/Listen.hs b/src/Sound/Tidal/Stream/Listen.hs index 8fa61cd47..1ef6f7bd8 100644 --- a/src/Sound/Tidal/Stream/Listen.hs +++ b/src/Sound/Tidal/Stream/Listen.hs @@ -1,12 +1,11 @@ module Sound.Tidal.Stream.Listen where -import Data.Maybe (fromJust, catMaybes, isJust) +import Data.Maybe (fromJust) 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 @@ -50,29 +49,14 @@ openListener c 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' +ctrlResponder :: Config -> Stream -> IO () +ctrlResponder _ (stream@(Stream {sListen = Just sock})) = loop + where + loop :: IO () + loop = do O.recvMessages sock >>= mapM_ act + loop -- External controller commands + act :: O.Message -> IO () 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 _):[])) @@ -109,10 +93,4 @@ ctrlResponder waits c (stream@(Stream {sListen = Just sock})) 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 +ctrlResponder _ _ = return () diff --git a/src/Sound/Tidal/Stream/Main.hs b/src/Sound/Tidal/Stream/Main.hs index e4dd41c09..902212a39 100644 --- a/src/Sound/Tidal/Stream/Main.hs +++ b/src/Sound/Tidal/Stream/Main.hs @@ -13,7 +13,6 @@ 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 @@ -45,7 +44,6 @@ 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 @@ -54,10 +52,9 @@ startStream config oscmap = do cxs <- getCXs config oscmap - clockRef <- Clock.clocked (cClockConfig config) (doTick sMapMV bussesMV pMapMV globalFMV cxs listen) + clockRef <- Clock.clocked (cClockConfig config) (doTick sMapMV pMapMV globalFMV cxs) let stream = Stream {sConfig = config, - sBusses = bussesMV, sStateMV = sMapMV, sClockRef = clockRef, -- sLink = abletonLink, @@ -68,10 +65,8 @@ startStream config oscmap = do sCxs = cxs } - sendHandshakes stream - -- Spawn a thread to handle OSC control messages - _ <- forkIO $ ctrlResponder 0 config stream + _ <- forkIO $ ctrlResponder config stream return stream startMulti :: [Target] -> Config -> IO () diff --git a/src/Sound/Tidal/Stream/Process.hs b/src/Sound/Tidal/Stream/Process.hs index cb661c3bb..2a6116679 100644 --- a/src/Sound/Tidal/Stream/Process.hs +++ b/src/Sound/Tidal/Stream/Process.hs @@ -76,23 +76,20 @@ data ProcessedEvent = -- 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 = +doTick stateMV playMV globalFMV cxs (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 @@ -109,13 +106,14 @@ doTick stateMV busMV playMV globalFMV cxs listen (st,end) nudge ops = (sMap'', es') = resolveState sMap' es tes <- processCps ops es' -- For each OSC target - forM_ cxs $ \cx@(Cx target _ oscs _ _) -> do + forM_ cxs $ \cx@(Cx target _ oscs _ _ bussesMV) -> do + busses <- mapM readMVar bussesMV -- 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) -> + forM_ ms $ \m -> (send 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'') @@ -154,8 +152,8 @@ processCps ops = mapM processEvent } -toOSC :: [Int] -> ProcessedEvent -> OSC -> [(Double, Bool, O.Message)] -toOSC busses pe osc@(OSC _ _) +toOSC :: Maybe [Int] -> ProcessedEvent -> OSC -> [(Double, Bool, O.Message)] +toOSC maybeBusses 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 @@ -190,8 +188,8 @@ toOSC busses pe osc@(OSC _ _) O.Message mungedPath vs ) | otherwise = Nothing - toBus n | null busses = n - | otherwise = busses !!! n + toBus n | Just busses <- maybeBusses, (not . null) busses = busses !!! n + | otherwise = n busmsgs = map (\(('^':k), (VI b)) -> do v <- Map.lookup k playmap return $ (tsPart, @@ -282,8 +280,8 @@ hasSolo = (>= 1) . length . filter solo . Map.elems -- 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 +onSingleTick :: Config -> Clock.ClockRef -> MVar ValueMap -> MVar PlayMap -> MVar (ControlPattern -> ControlPattern) -> [Cx] -> ControlPattern -> IO () +onSingleTick config clockRef stateMV _ globalFMV cxs pat = do ops <- Clock.getZeroedLinkOperations (cClockConfig config) clockRef pMapMV <- newMVar $ Map.singleton "fake" (PlayState {pattern = pat, @@ -293,7 +291,7 @@ onSingleTick config clockRef stateMV busMV _ globalFMV cxs listen pat = do } ) -- The nowArc is a full cycle - doTick stateMV busMV pMapMV globalFMV cxs listen (0,1) 0 ops + doTick stateMV pMapMV globalFMV cxs (0,1) 0 ops diff --git a/src/Sound/Tidal/Stream/Target.hs b/src/Sound/Tidal/Stream/Target.hs index 964cb992f..dc9bfdfe4 100644 --- a/src/Sound/Tidal/Stream/Target.hs +++ b/src/Sound/Tidal/Stream/Target.hs @@ -1,9 +1,11 @@ module Sound.Tidal.Stream.Target where import qualified Sound.Osc.Fd as O +import qualified Sound.Osc.Time.Timeout as O import qualified Network.Socket as N -import Data.Maybe (fromJust, isJust) -import Control.Concurrent (forkOS, threadDelay) +import Data.Maybe (fromJust, isJust, catMaybes) +import Control.Concurrent (newMVar, readMVar, swapMVar, forkIO, forkOS, threadDelay) +import Control.Monad (when) import Foreign (Word8) import Sound.Tidal.Pattern @@ -31,33 +33,65 @@ import Sound.Tidal.Stream.Config 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 + remote_addr <- resolve (oAddress target) (oPort target) + remote_bus_addr <- mapM (resolve (oAddress target)) (oBusPort target) + remote_busses <- sequence (oBusPort target >> Just (newMVar [])) + 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 + u <- O.udp_socket (\sock _ -> do N.setSocketOption sock N.Broadcast broadcast ) (oAddress target) (oPort target) - return $ Cx {cxUDP = u, cxAddr = remote_addr, cxBusAddr = remote_bus_addr, cxTarget = target, cxOSCs = os} + let cx = Cx {cxUDP = u, cxAddr = remote_addr, cxBusAddr = remote_bus_addr, cxBusses = remote_busses, cxTarget = target, cxOSCs = os} + _ <- forkIO $ handshake cx config + return cx ) oscmap -resolve :: String -> String -> IO N.AddrInfo +resolve :: String -> Int -> IO N.AddrInfo resolve host port = do let hints = N.defaultHints { N.addrSocketType = N.Stream } - addr:_ <- N.getAddrInfo (Just hints) (Just host) (Just port) + addr:_ <- N.getAddrInfo (Just hints) (Just host) (Just $ show port) return addr +handshake :: Cx -> Config -> IO () +handshake Cx { cxUDP = udp, cxBusses = Just bussesMV, cxAddr = addr } c = sendHandshake >> listen 0 + where + sendHandshake :: IO () + sendHandshake = O.sendTo udp (O.Packet_Message $ O.Message "/dirt/handshake" []) (N.addrAddress addr) + listen :: Int -> IO () + listen waits = do ms <- recvMessagesTimeout 2 udp + if null ms + then do checkHandshake waits -- there was a timeout, check handshake + listen (waits+1) + else do mapM_ respond ms + listen 0 + checkHandshake :: Int -> IO () + checkHandshake waits = do busses <- readMVar bussesMV + when (null busses) $ do when (waits == 0) $ verbose c $ "Waiting for SuperDirt (v.1.7.2 or higher).." + sendHandshake + respond :: O.Message -> IO () + respond (O.Message "/dirt/hello" _) = sendHandshake + respond (O.Message "/dirt/handshake/reply" xs) = do prev <- swapMVar bussesMV $ bufferIndices xs + -- Only report the first time.. + when (null prev) $ verbose c $ "Connected to SuperDirt." + respond _ = return () + bufferIndices :: [O.Datum] -> [Int] + bufferIndices [] = [] + bufferIndices (x:xs') | x == O.AsciiString (O.ascii "&controlBusIndices") = catMaybes $ takeWhile isJust $ map O.datum_integral xs' + | otherwise = bufferIndices xs' +handshake _ _ = return () + +recvMessagesTimeout :: (O.Transport t) => Double -> t -> IO [O.Message] +recvMessagesTimeout n sock = fmap (maybe [] O.packetMessages) $ O.recvPacketTimeout n sock + -- 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 +send :: Cx -> Double -> Double -> (Double, Bool, O.Message) -> IO () +send cx latency extraLatency (time, isBusMsg, m) + | oSchedule target == Pre BundleStamp = sendBndl isBusMsg cx $ O.Bundle timeWithLatency [m] + | oSchedule target == Pre MessageStamp = sendO isBusMsg cx $ addtime m | otherwise = do _ <- forkOS $ do now <- O.time threadDelay $ floor $ (timeWithLatency - now) * 1000000 - sendO isBusMsg listen cx m + sendO isBusMsg 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 @@ -68,18 +102,15 @@ send listen cx latency extraLatency (time, isBusMsg, m) 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) +sendBndl :: Bool -> Cx -> O.Bundle -> IO () +sendBndl isBusMsg cx bndl = O.sendTo (cxUDP cx) (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 +sendO :: Bool -> Cx -> O.Message -> IO () +sendO isBusMsg cx msg = O.sendTo (cxUDP cx) (O.Packet_Message msg) (N.addrAddress addr) + where addr | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx + | otherwise = cxAddr cx superdirtTarget :: Target superdirtTarget = Target {oName = "SuperDirt", diff --git a/src/Sound/Tidal/Stream/Types.hs b/src/Sound/Tidal/Stream/Types.hs index f5589f353..74db70f4a 100644 --- a/src/Sound/Tidal/Stream/Types.hs +++ b/src/Sound/Tidal/Stream/Types.hs @@ -13,7 +13,6 @@ 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, @@ -27,7 +26,8 @@ data Cx = Cx {cxTarget :: Target, cxUDP :: O.Udp, cxOSCs :: [OSC], cxAddr :: N.AddrInfo, - cxBusAddr :: Maybe N.AddrInfo + cxBusAddr :: Maybe N.AddrInfo, + cxBusses :: Maybe (MVar [Int]) } data StampStyle = BundleStamp diff --git a/src/Sound/Tidal/Stream/UI.hs b/src/Sound/Tidal/Stream/UI.hs index 1ebeb4553..3df86126f 100644 --- a/src/Sound/Tidal/Stream/UI.hs +++ b/src/Sound/Tidal/Stream/UI.hs @@ -1,19 +1,16 @@ {-# 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 @@ -74,7 +71,7 @@ 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 +streamFirst stream pat = onSingleTick (sConfig stream) (sClockRef stream) (sStateMV stream) (sPMapMV stream) (sGlobalFMV stream) (sCxs stream) pat streamMute :: Stream -> ID -> IO () streamMute s k = withPatIds s [k] (\x -> x {mute = True}) @@ -140,15 +137,4 @@ 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." +streamSetR = streamSet \ No newline at end of file From 9eca1d63c30ab09a6d4d05f762b612ba1a47ed8e Mon Sep 17 00:00:00 2001 From: Matthew Kaney Date: Thu, 18 Apr 2024 19:47:55 -0400 Subject: [PATCH 06/12] Use mapped bus id --- src/Sound/Tidal/Stream/Process.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Sound/Tidal/Stream/Process.hs b/src/Sound/Tidal/Stream/Process.hs index 2a6116679..7c295edce 100644 --- a/src/Sound/Tidal/Stream/Process.hs +++ b/src/Sound/Tidal/Stream/Process.hs @@ -194,7 +194,7 @@ toOSC maybeBusses pe osc@(OSC _ _) (\(('^':k), (VI b)) -> do v <- Map.lookup k playmap return $ (tsPart, True, -- bus message ? - O.Message "/c_set" [O.int32 b, toDatum v] + O.Message "/c_set" [O.int32 (toBus b), toDatum v] ) ) (Map.toList busmap) From 7d3a08e6cb4a73bbf2046649c5e75d6e42d550d4 Mon Sep 17 00:00:00 2001 From: Matthew Kaney Date: Thu, 18 Apr 2024 20:17:05 -0400 Subject: [PATCH 07/12] Apply stylish-haskell to Stream modules --- src/Sound/Tidal/Stream/Config.hs | 14 ++--- src/Sound/Tidal/Stream/Listen.hs | 18 +++--- src/Sound/Tidal/Stream/Main.hs | 14 ++--- src/Sound/Tidal/Stream/Process.hs | 99 ++++++++++++++++--------------- src/Sound/Tidal/Stream/Target.hs | 17 +++--- src/Sound/Tidal/Stream/Types.hs | 54 ++++++++--------- src/Sound/Tidal/Stream/UI.hs | 25 ++++---- 7 files changed, 124 insertions(+), 117 deletions(-) diff --git a/src/Sound/Tidal/Stream/Config.hs b/src/Sound/Tidal/Stream/Config.hs index b0b9e45a9..ef86309cb 100644 --- a/src/Sound/Tidal/Stream/Config.hs +++ b/src/Sound/Tidal/Stream/Config.hs @@ -1,6 +1,6 @@ module Sound.Tidal.Stream.Config where -import Control.Monad (when) +import Control.Monad (when) import qualified Sound.Tidal.Clock as Clock @@ -22,15 +22,15 @@ import qualified Sound.Tidal.Clock as Clock along with this library. If not, see . -} -data Config = Config {cCtrlListen :: Bool, - cCtrlAddr :: String, - cCtrlPort :: Int, +data Config = Config {cCtrlListen :: Bool, + cCtrlAddr :: String, + cCtrlPort :: Int, cCtrlBroadcast :: Bool, -- cTempoAddr :: String, -- cTempoPort :: Int, -- cTempoClientPort :: Int, - cVerbose :: Bool, - cClockConfig :: Clock.ClockConfig + cVerbose :: Bool, + cClockConfig :: Clock.ClockConfig } defaultConfig :: Config @@ -46,4 +46,4 @@ defaultConfig = Config {cCtrlListen = True, } verbose :: Config -> String -> IO () -verbose c s = when (cVerbose c) $ putStrLn s \ No newline at end of file +verbose c s = when (cVerbose c) $ putStrLn s diff --git a/src/Sound/Tidal/Stream/Listen.hs b/src/Sound/Tidal/Stream/Listen.hs index 1ef6f7bd8..5cc035a55 100644 --- a/src/Sound/Tidal/Stream/Listen.hs +++ b/src/Sound/Tidal/Stream/Listen.hs @@ -1,13 +1,13 @@ module Sound.Tidal.Stream.Listen where -import Data.Maybe (fromJust) 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 Network.Socket as N -import qualified Control.Exception as E +import qualified Control.Exception as E +import Control.Monad (when) +import qualified Data.Map as Map +import Data.Maybe (fromJust) +import qualified Network.Socket as N +import qualified Sound.Osc.Fd as O +import System.IO (hPutStrLn, stderr) import Sound.Tidal.ID import Sound.Tidal.Pattern @@ -91,6 +91,6 @@ ctrlResponder _ (stream@(Stream {sListen = Just sock})) = loop 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 () + withID (O.Int32 k) func = func $ (ID . show) k + withID _ _ = return () ctrlResponder _ _ = return () diff --git a/src/Sound/Tidal/Stream/Main.hs b/src/Sound/Tidal/Stream/Main.hs index 902212a39..8f99baa5e 100644 --- a/src/Sound/Tidal/Stream/Main.hs +++ b/src/Sound/Tidal/Stream/Main.hs @@ -1,18 +1,18 @@ 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 Control.Concurrent.MVar +import qualified Data.Map as Map +import qualified Sound.Tidal.Clock as Clock +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.Target +import Sound.Tidal.Stream.Types +import Sound.Tidal.Version (tidal_status_string) {- Main.hs - Start tidals stream, listen and act on incoming messages diff --git a/src/Sound/Tidal/Stream/Process.hs b/src/Sound/Tidal/Stream/Process.hs index 7c295edce..b002eb686 100644 --- a/src/Sound/Tidal/Stream/Process.hs +++ b/src/Sound/Tidal/Stream/Process.hs @@ -1,6 +1,11 @@ -{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, FlexibleContexts, ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} -{-# language DeriveGeneric, StandaloneDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} module Sound.Tidal.Stream.Process where @@ -22,43 +27,43 @@ module Sound.Tidal.Stream.Process where along with this library. If not, see . -} -import Control.Applicative ((<|>)) +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 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) import Foreign.C.Types -import System.IO (hPutStrLn, stderr) +import System.IO (hPutStrLn, stderr) -import qualified Sound.Osc.Fd as O +import qualified Sound.Osc.Fd as O -import Sound.Tidal.Stream.Config -import Sound.Tidal.Core (stack, (#)) +import Data.List (sortOn) +import qualified Sound.Tidal.Clock as Clock +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 qualified Sound.Tidal.Link as Link +import Sound.Tidal.Params (pS) import Sound.Tidal.Pattern -import Sound.Tidal.Utils ((!!!)) -import Data.List (sortOn) -import Sound.Tidal.Show () +import Sound.Tidal.Show () +import Sound.Tidal.Stream.Config +import Sound.Tidal.Utils ((!!!)) -import Sound.Tidal.Stream.Types import Sound.Tidal.Stream.Target +import Sound.Tidal.Stream.Types data ProcessedEvent = ProcessedEvent { - peHasOnset :: Bool, - peEvent :: Event ValueMap, - peCps :: Link.BPM, - peDelta :: Link.Micros, - peCycle :: Time, - peOnWholeOrPart :: Link.Micros, + 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 + peOnPart :: Link.Micros, + peOnPartOsc :: O.Time } -- | Query the current pattern (contained in argument @stream :: Stream@) @@ -107,7 +112,7 @@ doTick stateMV playMV globalFMV cxs (st,end) nudge ops = tes <- processCps ops es' -- For each OSC target forM_ cxs $ \cx@(Cx target _ oscs _ _ bussesMV) -> do - busses <- mapM readMVar bussesMV + busses <- mapM readMVar bussesMV -- Latency is configurable per target. -- Latency is only used when sending events live. let latency = oLatency target @@ -225,15 +230,15 @@ toData (OSC {args = Named rqrd}) 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 (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" +toDatum (VX xs) = O.Blob $ O.blob_pack xs +toDatum _ = error "toDatum: unhandled value" substitutePath :: String -> ValueMap -> Maybe String substitutePath str cm = parse str @@ -251,19 +256,19 @@ 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 (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 "" + simpleShow (VList _) = show "" defaultValue :: String -> Maybe String defaultValue ('=':dfltVal) = Just dfltVal - defaultValue _ = Nothing + defaultValue _ = Nothing playStack :: PlayMap -> ControlPattern playStack pMap = stack . (map pattern) . (filter active) . Map.elems $ pMap @@ -313,5 +318,5 @@ 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] } + _ -> pMap { pattern = silence, history = [silence] } ) diff --git a/src/Sound/Tidal/Stream/Target.hs b/src/Sound/Tidal/Stream/Target.hs index dc9bfdfe4..35f640563 100644 --- a/src/Sound/Tidal/Stream/Target.hs +++ b/src/Sound/Tidal/Stream/Target.hs @@ -1,16 +1,17 @@ module Sound.Tidal.Stream.Target where -import qualified Sound.Osc.Fd as O -import qualified Sound.Osc.Time.Timeout as O -import qualified Network.Socket as N -import Data.Maybe (fromJust, isJust, catMaybes) -import Control.Concurrent (newMVar, readMVar, swapMVar, forkIO, forkOS, threadDelay) -import Control.Monad (when) -import Foreign (Word8) +import Control.Concurrent (forkIO, forkOS, newMVar, readMVar, + swapMVar, threadDelay) +import Control.Monad (when) +import Data.Maybe (catMaybes, fromJust, isJust) +import Foreign (Word8) +import qualified Network.Socket as N +import qualified Sound.Osc.Fd as O +import qualified Sound.Osc.Time.Timeout as O import Sound.Tidal.Pattern -import Sound.Tidal.Stream.Types import Sound.Tidal.Stream.Config +import Sound.Tidal.Stream.Types {- Target.hs - Create and send to OSC targets diff --git a/src/Sound/Tidal/Stream/Types.hs b/src/Sound/Tidal/Stream/Types.hs index 74db70f4a..9189ab41c 100644 --- a/src/Sound/Tidal/Stream/Types.hs +++ b/src/Sound/Tidal/Stream/Types.hs @@ -1,33 +1,33 @@ 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 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 Network.Socket as N +import qualified Sound.Osc.Fd as O -import qualified Sound.Tidal.Clock as Clock +import qualified Sound.Tidal.Clock as Clock -import Sound.Tidal.Stream.Config +import Sound.Tidal.Stream.Config -data Stream = Stream {sConfig :: Config, - sStateMV :: MVar ValueMap, +data Stream = Stream {sConfig :: Config, + sStateMV :: MVar ValueMap, -- sOutput :: MVar ControlPattern, - sClockRef :: Clock.ClockRef, - sListen :: Maybe O.Udp, - sPMapMV :: MVar PlayMap, + sClockRef :: Clock.ClockRef, + sListen :: Maybe O.Udp, + sPMapMV :: MVar PlayMap, sGlobalFMV :: MVar (ControlPattern -> ControlPattern), - sCxs :: [Cx] + sCxs :: [Cx] } -data Cx = Cx {cxTarget :: Target, - cxUDP :: O.Udp, - cxOSCs :: [OSC], - cxAddr :: N.AddrInfo, +data Cx = Cx {cxTarget :: Target, + cxUDP :: O.Udp, + cxOSCs :: [OSC], + cxAddr :: N.AddrInfo, cxBusAddr :: Maybe N.AddrInfo, - cxBusses :: Maybe (MVar [Int]) + cxBusses :: Maybe (MVar [Int]) } data StampStyle = BundleStamp @@ -38,13 +38,13 @@ 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, +data Target = Target {oName :: String, + oAddress :: String, + oPort :: Int, + oBusPort :: Maybe Int, + oLatency :: Double, + oWindow :: Maybe Arc, + oSchedule :: Schedule, oHandshake :: Bool } deriving Show @@ -60,8 +60,8 @@ data OSC = OSC {path :: String, deriving Show data PlayState = PlayState {pattern :: ControlPattern, - mute :: Bool, - solo :: Bool, + mute :: Bool, + solo :: Bool, history :: [ControlPattern] } deriving Show diff --git a/src/Sound/Tidal/Stream/UI.hs b/src/Sound/Tidal/Stream/UI.hs index 3df86126f..cc0158140 100644 --- a/src/Sound/Tidal/Stream/UI.hs +++ b/src/Sound/Tidal/Stream/UI.hs @@ -1,19 +1,20 @@ -{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} module Sound.Tidal.Stream.UI where -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 Control.Exception as E +import qualified Data.Map as Map +import System.IO (hPutStrLn, stderr) +import System.Random (getStdRandom, randomR) -import qualified Sound.Tidal.Clock as Clock -import Sound.Tidal.Stream.Types +import qualified Sound.Tidal.Clock as Clock import Sound.Tidal.Stream.Config import Sound.Tidal.Stream.Process +import Sound.Tidal.Stream.Types -import Sound.Tidal.Pattern import Sound.Tidal.ID +import Sound.Tidal.Pattern streamNudgeAll :: Stream -> Double -> IO () streamNudgeAll s = Clock.setNudge (sClockRef s) @@ -50,10 +51,10 @@ 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 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" + showKV False (k, _) = "(" ++ k ++ ") - muted\n" streamReplace :: Stream -> ID -> ControlPattern -> IO () streamReplace stream k !pat = do @@ -137,4 +138,4 @@ streamSetB :: Stream -> String -> Pattern Bool -> IO () streamSetB = streamSet streamSetR :: Stream -> String -> Pattern Rational -> IO () -streamSetR = streamSet \ No newline at end of file +streamSetR = streamSet From 77a6c286673bf7e74e4fe03e961f92cfffe7c78f Mon Sep 17 00:00:00 2001 From: Matthew Kaney Date: Fri, 31 Jan 2025 23:27:21 -0500 Subject: [PATCH 08/12] Reformat updated Stream files --- src/Sound/Tidal/Stream/Config.hs | 46 +-- src/Sound/Tidal/Stream/Listen.hs | 138 ++++----- src/Sound/Tidal/Stream/Main.hs | 79 +++-- src/Sound/Tidal/Stream/Process.hs | 474 ++++++++++++++++-------------- src/Sound/Tidal/Stream/Target.hs | 260 +++++++++------- src/Sound/Tidal/Stream/Types.hs | 117 ++++---- src/Sound/Tidal/Stream/UI.hs | 100 ++++--- test/Sound/Tidal/StreamTest.hs | 13 +- 8 files changed, 658 insertions(+), 569 deletions(-) diff --git a/src/Sound/Tidal/Stream/Config.hs b/src/Sound/Tidal/Stream/Config.hs index ef86309cb..ccb4fda81 100644 --- a/src/Sound/Tidal/Stream/Config.hs +++ b/src/Sound/Tidal/Stream/Config.hs @@ -1,7 +1,6 @@ module Sound.Tidal.Stream.Config where -import Control.Monad (when) - +import Control.Monad (when) import qualified Sound.Tidal.Clock as Clock {- @@ -22,28 +21,31 @@ import qualified Sound.Tidal.Clock as Clock along with this library. If not, see . -} -data Config = Config {cCtrlListen :: Bool, - cCtrlAddr :: String, - cCtrlPort :: Int, - cCtrlBroadcast :: Bool, - -- cTempoAddr :: String, - -- cTempoPort :: Int, - -- cTempoClientPort :: Int, - cVerbose :: Bool, - cClockConfig :: Clock.ClockConfig - } +data Config = Config + { cCtrlListen :: Bool, + cCtrlAddr :: String, + cCtrlPort :: Int, + cCtrlBroadcast :: Bool, + -- cTempoAddr :: String, + -- cTempoPort :: Int, + -- cTempoClientPort :: Int, + cVerbose :: Bool, + cClockConfig :: Clock.ClockConfig + } defaultConfig :: Config -defaultConfig = Config {cCtrlListen = True, - cCtrlAddr ="127.0.0.1", - cCtrlPort = 6010, - cCtrlBroadcast = False, - -- cTempoAddr = "127.0.0.1", - -- cTempoPort = 9160, - -- cTempoClientPort = 0, -- choose at random - cVerbose = True, - cClockConfig = Clock.defaultConfig - } +defaultConfig = + Config + { cCtrlListen = True, + cCtrlAddr = "127.0.0.1", + cCtrlPort = 6010, + cCtrlBroadcast = False, + -- cTempoAddr = "127.0.0.1", + -- cTempoPort = 9160, + -- cTempoClientPort = 0, -- choose at random + cVerbose = True, + cClockConfig = Clock.defaultConfig + } verbose :: Config -> String -> IO () verbose c s = when (cVerbose c) $ putStrLn s diff --git a/src/Sound/Tidal/Stream/Listen.hs b/src/Sound/Tidal/Stream/Listen.hs index 5cc035a55..099e99170 100644 --- a/src/Sound/Tidal/Stream/Listen.hs +++ b/src/Sound/Tidal/Stream/Listen.hs @@ -1,20 +1,18 @@ module Sound.Tidal.Stream.Listen where -import Control.Concurrent.MVar -import qualified Control.Exception as E -import Control.Monad (when) -import qualified Data.Map as Map -import Data.Maybe (fromJust) -import qualified Network.Socket as N -import qualified Sound.Osc.Fd as O -import System.IO (hPutStrLn, stderr) - -import Sound.Tidal.ID -import Sound.Tidal.Pattern - -import Sound.Tidal.Stream.Config -import Sound.Tidal.Stream.Types -import Sound.Tidal.Stream.UI +import Control.Concurrent.MVar +import qualified Control.Exception as E +import Control.Monad (when) +import qualified Data.Map as Map +import Data.Maybe (fromJust) +import qualified Network.Socket as N +import qualified Sound.Osc.Fd as O +import Sound.Tidal.ID +import Sound.Tidal.Pattern +import Sound.Tidal.Stream.Config +import Sound.Tidal.Stream.Types +import Sound.Tidal.Stream.UI +import System.IO (hPutStrLn, stderr) {- Listen.hs - logic for listening and acting on incoming OSC messages @@ -34,63 +32,69 @@ import Sound.Tidal.Stream.UI 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 + | 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 + 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 :: Config -> Stream -> IO () ctrlResponder _ (stream@(Stream {sListen = Just sock})) = loop - where - loop :: IO () - loop = do O.recvMessages sock >>= mapM_ act - loop - -- External controller commands - act :: O.Message -> IO () - 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 () + where + loop :: IO () + loop = do + O.recvMessages sock >>= mapM_ act + loop + -- External controller commands + act :: O.Message -> IO () + 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 () diff --git a/src/Sound/Tidal/Stream/Main.hs b/src/Sound/Tidal/Stream/Main.hs index 8f99baa5e..0a1738941 100644 --- a/src/Sound/Tidal/Stream/Main.hs +++ b/src/Sound/Tidal/Stream/Main.hs @@ -1,18 +1,16 @@ module Sound.Tidal.Stream.Main where -import Control.Concurrent -import Control.Concurrent.MVar -import qualified Data.Map as Map -import qualified Sound.Tidal.Clock as Clock -import System.IO (hPutStrLn, stderr) - - -import Sound.Tidal.Stream.Config -import Sound.Tidal.Stream.Listen -import Sound.Tidal.Stream.Process -import Sound.Tidal.Stream.Target -import Sound.Tidal.Stream.Types -import Sound.Tidal.Version (tidal_status_string) +import Control.Concurrent +import Control.Concurrent.MVar +import qualified Data.Map as Map +import qualified Sound.Tidal.Clock as Clock +import Sound.Tidal.Stream.Config +import Sound.Tidal.Stream.Listen +import Sound.Tidal.Stream.Process +import Sound.Tidal.Stream.Target +import Sound.Tidal.Stream.Types +import Sound.Tidal.Version (tidal_status_string) +import System.IO (hPutStrLn, stderr) {- Main.hs - Start tidals stream, listen and act on incoming messages @@ -32,7 +30,6 @@ import Sound.Tidal.Version (tidal_status_string) 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])] @@ -42,32 +39,34 @@ startTidal target config = startStream config [(target, [superdirtShape])] -- 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 - 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 pMapMV globalFMV cxs) - - let stream = Stream {sConfig = config, - sStateMV = sMapMV, - sClockRef = clockRef, - -- sLink = abletonLink, - sListen = listen, - sPMapMV = pMapMV, - -- sActionsMV = actionsMV, - sGlobalFMV = globalFMV, - sCxs = cxs - } - - -- Spawn a thread to handle OSC control messages - _ <- forkIO $ ctrlResponder config stream - return stream + sMapMV <- newMVar Map.empty + pMapMV <- newMVar Map.empty + 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 pMapMV globalFMV cxs) + + let stream = + Stream + { sConfig = config, + sStateMV = sMapMV, + sClockRef = clockRef, + -- sLink = abletonLink, + sListen = listen, + sPMapMV = pMapMV, + -- sActionsMV = actionsMV, + sGlobalFMV = globalFMV, + sCxs = cxs + } + + -- Spawn a thread to handle OSC control messages + _ <- forkIO $ ctrlResponder 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 index 9d4e45983..bbc6eccbb 100644 --- a/src/Sound/Tidal/Stream/Process.hs +++ b/src/Sound/Tidal/Stream/Process.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE StandaloneDeriving #-} module Sound.Tidal.Stream.Process where @@ -27,43 +27,39 @@ module Sound.Tidal.Stream.Process where along with this library. If not, see . -} -import Control.Applicative ((<|>)) -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) -import Foreign.C.Types -import System.IO (hPutStrLn, stderr) +import Control.Applicative ((<|>)) +import Control.Concurrent.MVar +import qualified Control.Exception as E +import Control.Monad (forM_, when) +import Data.Coerce (coerce) +import Data.List (sortOn) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes, fromJust, fromMaybe) +import Foreign.C.Types +import qualified Sound.Osc.Fd as O +import qualified Sound.Tidal.Clock as Clock +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 Sound.Tidal.Stream.Config +import Sound.Tidal.Stream.Target +import Sound.Tidal.Stream.Types +import Sound.Tidal.Utils ((!!!)) +import System.IO (hPutStrLn, stderr) -import qualified Sound.Osc.Fd as O - -import Data.List (sortOn) -import qualified Sound.Tidal.Clock as Clock -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 Sound.Tidal.Stream.Config -import Sound.Tidal.Utils ((!!!)) - -import Sound.Tidal.Stream.Target -import Sound.Tidal.Stream.Types - -data ProcessedEvent = - ProcessedEvent { - peHasOnset :: Bool, - peEvent :: Event ValueMap, - peCps :: Link.BPM, - peDelta :: Link.Micros, - peCycle :: Time, - peOnWholeOrPart :: Link.Micros, +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 + peOnPart :: Link.Micros, + peOnPartOsc :: O.Time } -- | Query the current pattern (contained in argument @stream :: Stream@) @@ -79,53 +75,62 @@ data ProcessedEvent = -- 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 PlayMap -- currently playing - -> MVar (ControlPattern -> ControlPattern) -- current global fx - -> [Cx] -- target addresses - -> (Time,Time) -- current arc - -> Double -- nudge - -> Clock.LinkOperations -- ableton link operations - -> IO () -doTick stateMV playMV globalFMV cxs (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 - 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 _ _ bussesMV) -> do - busses <- mapM readMVar bussesMV - -- 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 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'') +doTick :: + MVar ValueMap -> -- pattern state + MVar PlayMap -> -- currently playing + MVar (ControlPattern -> ControlPattern) -> -- current global fx + [Cx] -> -- target addresses + (Time, Time) -> -- current arc + Double -> -- nudge + Clock.LinkOperations -> -- ableton link operations + IO () +doTick stateMV playMV globalFMV cxs (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 + 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 _ _ bussesMV) -> do + busses <- mapM readMVar bussesMV + -- 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 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 :: Event ValueMap -> IO ProcessedEvent processEvent e = do let wope = wholeOrPart e partStartCycle = start $ part e @@ -136,152 +141,173 @@ processCps ops = mapM processEvent 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' + 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 - } - + 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 :: Maybe [Int] -> ProcessedEvent -> OSC -> [(Double, Bool, O.Message)] -toOSC maybeBusses 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. +toOSC maybeBusses pe osc@(OSC _ _) = + catMaybes (playmsg : busmsgs) + where + -- 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. + + (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 (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 + | Just busses <- maybeBusses, (not . null) busses = busses !!! n + | otherwise = 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 (toBus bi), toDatum v] + ) + ) + (Map.toList busmap) 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 (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 | Just busses <- maybeBusses, (not . null) busses = busses !!! n - | otherwise = 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 (toBus 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 + 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 = 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 + | 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) + 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 (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" +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 + 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 + 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) + where + active pState = + if hasSolo pMap + then psSolo pState + else not (psMute pState) hasSolo :: Map.Map k PlayState -> Bool hasSolo = (>= 1) . length . filter psSolo . 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 @@ -290,17 +316,19 @@ hasSolo = (>= 1) . length . filter psSolo . Map.elems onSingleTick :: Config -> Clock.ClockRef -> MVar ValueMap -> MVar PlayMap -> MVar (ControlPattern -> ControlPattern) -> [Cx] -> ControlPattern -> IO () onSingleTick config clockRef stateMV _ globalFMV cxs pat = do ops <- Clock.getZeroedLinkOperations (cClockConfig config) clockRef - pMapMV <- newMVar $ Map.singleton "fake" - (PlayState {psPattern = pat, - psMute = False, - psSolo = False, - psHistory = [] - } - ) + pMapMV <- + newMVar $ + Map.singleton + "fake" + ( PlayState + { psPattern = pat, + psMute = False, + psSolo = False, + psHistory = [] + } + ) -- The nowArc is a full cycle - doTick stateMV pMapMV globalFMV cxs (0,1) 0 ops - - + doTick stateMV pMapMV globalFMV cxs (0, 1) 0 ops -- Used for Tempo callback updatePattern :: Stream -> ID -> Time -> ControlPattern -> IO () @@ -309,16 +337,20 @@ updatePattern stream k !t pat = do 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) + 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) setPreviousPatternOrSilence :: MVar PlayMap -> IO () setPreviousPatternOrSilence playMV = - modifyMVar_ playMV $ return - . Map.map ( \ pMap -> case psHistory pMap of - _:p:ps -> pMap { psPattern = p, psHistory = p:ps } - _ -> pMap { psPattern = silence, psHistory = [silence] } - ) + modifyMVar_ playMV $ + return + . Map.map + ( \pMap -> case psHistory pMap of + _ : p : ps -> pMap {psPattern = p, psHistory = p : ps} + _ -> pMap {psPattern = silence, psHistory = [silence]} + ) diff --git a/src/Sound/Tidal/Stream/Target.hs b/src/Sound/Tidal/Stream/Target.hs index 35f640563..c248a9625 100644 --- a/src/Sound/Tidal/Stream/Target.hs +++ b/src/Sound/Tidal/Stream/Target.hs @@ -1,17 +1,22 @@ module Sound.Tidal.Stream.Target where -import Control.Concurrent (forkIO, forkOS, newMVar, readMVar, - swapMVar, threadDelay) -import Control.Monad (when) -import Data.Maybe (catMaybes, fromJust, isJust) -import Foreign (Word8) -import qualified Network.Socket as N -import qualified Sound.Osc.Fd as O -import qualified Sound.Osc.Time.Timeout as O - -import Sound.Tidal.Pattern -import Sound.Tidal.Stream.Config -import Sound.Tidal.Stream.Types +import Control.Concurrent + ( forkIO, + forkOS, + newMVar, + readMVar, + swapMVar, + threadDelay, + ) +import Control.Monad (when) +import Data.Maybe (catMaybes, fromJust, isJust) +import Foreign (Word8) +import qualified Network.Socket as N +import qualified Sound.Osc.Fd as O +import qualified Sound.Osc.Time.Timeout as O +import Sound.Tidal.Pattern +import Sound.Tidal.Stream.Config +import Sound.Tidal.Stream.Types {- Target.hs - Create and send to OSC targets @@ -31,52 +36,66 @@ import Sound.Tidal.Stream.Types 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) (oPort target) - remote_bus_addr <- mapM (resolve (oAddress target)) (oBusPort target) - remote_busses <- sequence (oBusPort target >> Just (newMVar [])) - - let broadcast = if cCtrlBroadcast config then 1 else 0 - u <- O.udp_socket (\sock _ -> do N.setSocketOption sock N.Broadcast broadcast - ) (oAddress target) (oPort target) - let cx = Cx {cxUDP = u, cxAddr = remote_addr, cxBusAddr = remote_bus_addr, cxBusses = remote_busses, cxTarget = target, cxOSCs = os} - _ <- forkIO $ handshake cx config - return cx - ) oscmap +getCXs config oscmap = + mapM + ( \(target, os) -> do + remote_addr <- resolve (oAddress target) (oPort target) + remote_bus_addr <- mapM (resolve (oAddress target)) (oBusPort target) + remote_busses <- sequence (oBusPort target >> Just (newMVar [])) + + let broadcast = if cCtrlBroadcast config then 1 else 0 + u <- + O.udp_socket + ( \sock _ -> do N.setSocketOption sock N.Broadcast broadcast + ) + (oAddress target) + (oPort target) + let cx = Cx {cxUDP = u, cxAddr = remote_addr, cxBusAddr = remote_bus_addr, cxBusses = remote_busses, cxTarget = target, cxOSCs = os} + _ <- forkIO $ handshake cx config + return cx + ) + oscmap resolve :: String -> Int -> IO N.AddrInfo -resolve host port = do let hints = N.defaultHints { N.addrSocketType = N.Stream } - addr:_ <- N.getAddrInfo (Just hints) (Just host) (Just $ show port) - return addr +resolve host port = do + let hints = N.defaultHints {N.addrSocketType = N.Stream} + addr : _ <- N.getAddrInfo (Just hints) (Just host) (Just $ show port) + return addr handshake :: Cx -> Config -> IO () -handshake Cx { cxUDP = udp, cxBusses = Just bussesMV, cxAddr = addr } c = sendHandshake >> listen 0 +handshake Cx {cxUDP = udp, cxBusses = Just bussesMV, cxAddr = addr} c = sendHandshake >> listen 0 where sendHandshake :: IO () sendHandshake = O.sendTo udp (O.Packet_Message $ O.Message "/dirt/handshake" []) (N.addrAddress addr) listen :: Int -> IO () - listen waits = do ms <- recvMessagesTimeout 2 udp - if null ms - then do checkHandshake waits -- there was a timeout, check handshake - listen (waits+1) - else do mapM_ respond ms - listen 0 + listen waits = do + ms <- recvMessagesTimeout 2 udp + if null ms + then do + checkHandshake waits -- there was a timeout, check handshake + listen (waits + 1) + else do + mapM_ respond ms + listen 0 checkHandshake :: Int -> IO () - checkHandshake waits = do busses <- readMVar bussesMV - when (null busses) $ do when (waits == 0) $ verbose c $ "Waiting for SuperDirt (v.1.7.2 or higher).." - sendHandshake + checkHandshake waits = do + busses <- readMVar bussesMV + when (null busses) $ do + when (waits == 0) $ verbose c $ "Waiting for SuperDirt (v.1.7.2 or higher).." + sendHandshake respond :: O.Message -> IO () respond (O.Message "/dirt/hello" _) = sendHandshake - respond (O.Message "/dirt/handshake/reply" xs) = do prev <- swapMVar bussesMV $ bufferIndices xs - -- Only report the first time.. - when (null prev) $ verbose c $ "Connected to SuperDirt." + respond (O.Message "/dirt/handshake/reply" xs) = do + prev <- swapMVar bussesMV $ bufferIndices xs + -- Only report the first time.. + when (null prev) $ verbose c $ "Connected to SuperDirt." respond _ = return () bufferIndices :: [O.Datum] -> [Int] bufferIndices [] = [] - bufferIndices (x:xs') | x == O.AsciiString (O.ascii "&controlBusIndices") = catMaybes $ takeWhile isJust $ map O.datum_integral xs' - | otherwise = bufferIndices xs' + bufferIndices (x : xs') + | x == O.AsciiString (O.ascii "&controlBusIndices") = catMaybes $ takeWhile isJust $ map O.datum_integral xs' + | otherwise = bufferIndices xs' handshake _ _ = return () recvMessagesTimeout :: (O.Transport t) => Double -> t -> IO [O.Message] @@ -90,99 +109,118 @@ send :: Cx -> Double -> Double -> (Double, Bool, O.Message) -> IO () send cx latency extraLatency (time, isBusMsg, m) | oSchedule target == Pre BundleStamp = sendBndl isBusMsg cx $ O.Bundle timeWithLatency [m] | oSchedule target == Pre MessageStamp = sendO isBusMsg cx $ addtime m - | otherwise = do _ <- forkOS $ do now <- O.time - threadDelay $ floor $ (timeWithLatency - now) * 1000000 - sendO isBusMsg 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 + | otherwise = do + _ <- forkOS $ do + now <- O.time + threadDelay $ floor $ (timeWithLatency - now) * 1000000 + sendO isBusMsg 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 -> Cx -> O.Bundle -> IO () sendBndl isBusMsg cx bndl = O.sendTo (cxUDP cx) (O.Packet_Bundle bndl) (N.addrAddress addr) - where addr | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx - | otherwise = cxAddr cx + where + addr + | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx + | otherwise = cxAddr cx sendO :: Bool -> Cx -> O.Message -> IO () sendO isBusMsg cx msg = O.sendTo (cxUDP cx) (O.Packet_Message msg) (N.addrAddress addr) - where addr | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx - | otherwise = cxAddr cx + where + addr + | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx + | otherwise = cxAddr cx 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 - } +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 - } +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) - ] +dirtShape = + OSC "/play" $ + ArgList + [ ("cps", fDefault 0), + ("s", Nothing), + ("offset", fDefault 0), + ("begin", fDefault 0), + ("end", fDefault 1), + ("speed", fDefault 1), + ("pan", fDefault 0.5), + ("velocity", fDefault 0.5), + ("vowel", sDefault ""), + ("cutoff", fDefault 0), + ("resonance", fDefault 0), + ("accelerate", fDefault 0), + ("shape", fDefault 0), + ("kriole", iDefault 0), + ("gain", fDefault 1), + ("cut", iDefault 0), + ("delay", fDefault 0), + ("delaytime", fDefault (-1)), + ("delayfeedback", fDefault (-1)), + ("crush", fDefault 0), + ("coarse", iDefault 0), + ("hcutoff", fDefault 0), + ("hresonance", fDefault 0), + ("bandf", fDefault 0), + ("bandq", fDefault 0), + ("unit", sDefault "rate"), + ("loop", fDefault 0), + ("n", fDefault 0), + ("attack", fDefault (-1)), + ("hold", fDefault 0), + ("release", fDefault (-1)), + ("orbit", iDefault 0) -- , + -- ("id", iDefault 0) + ] sDefault :: String -> Maybe Value sDefault x = Just $ VS x + fDefault :: Double -> Maybe Value fDefault x = Just $ VF x + rDefault :: Rational -> Maybe Value rDefault x = Just $ VR x + iDefault :: Int -> Maybe Value iDefault x = Just $ VI x + bDefault :: Bool -> Maybe Value bDefault x = Just $ VB x + xDefault :: [Word8] -> Maybe Value xDefault x = Just $ VX x diff --git a/src/Sound/Tidal/Stream/Types.hs b/src/Sound/Tidal/Stream/Types.hs index 2c4275312..118faad7c 100644 --- a/src/Sound/Tidal/Stream/Types.hs +++ b/src/Sound/Tidal/Stream/Types.hs @@ -1,72 +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 Control.Concurrent.MVar +import qualified Data.Map.Strict as Map +import qualified Network.Socket as N +import qualified Sound.Osc.Fd as O +import qualified Sound.Tidal.Clock as Clock +import Sound.Tidal.Pattern +import Sound.Tidal.Show () +import Sound.Tidal.Stream.Config -import qualified Network.Socket as N -import qualified Sound.Osc.Fd as O +data Stream = Stream + { sConfig :: Config, + sStateMV :: MVar ValueMap, + -- sOutput :: MVar ControlPattern, + sClockRef :: Clock.ClockRef, + sListen :: Maybe O.Udp, + sPMapMV :: MVar PlayMap, + sGlobalFMV :: MVar (ControlPattern -> ControlPattern), + sCxs :: [Cx] + } -import qualified Sound.Tidal.Clock as Clock +data Cx = Cx + { cxTarget :: Target, + cxUDP :: O.Udp, + cxOSCs :: [OSC], + cxAddr :: N.AddrInfo, + cxBusAddr :: Maybe N.AddrInfo, + cxBusses :: Maybe (MVar [Int]) + } -import Sound.Tidal.Stream.Config - -data Stream = Stream {sConfig :: Config, - 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, - cxBusses :: Maybe (MVar [Int]) - } - -data StampStyle = BundleStamp - | MessageStamp +data StampStyle + = BundleStamp + | MessageStamp deriving (Eq, Show) -data Schedule = Pre StampStyle - | Live +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 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 Args + = Named {requiredArgs :: [String]} + | ArgList [(String, Maybe Value)] + deriving (Show) -data OSC = OSC {path :: String, - args :: Args - } - | OSCContext {path :: String} - deriving Show +data OSC + = OSC + { path :: String, + args :: Args + } + | OSCContext {path :: String} + deriving (Show) -data PlayState = PlayState {psPattern :: ControlPattern, - psMute :: Bool, - psSolo :: Bool, - psHistory :: [ControlPattern] - } - deriving 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 { diff --git a/src/Sound/Tidal/Stream/UI.hs b/src/Sound/Tidal/Stream/UI.hs index 119041167..5190d7c7f 100644 --- a/src/Sound/Tidal/Stream/UI.hs +++ b/src/Sound/Tidal/Stream/UI.hs @@ -1,20 +1,19 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} -module Sound.Tidal.Stream.UI where - -import Control.Concurrent.MVar -import qualified Control.Exception as E -import qualified Data.Map as Map -import System.IO (hPutStrLn, stderr) -import System.Random (getStdRandom, randomR) -import qualified Sound.Tidal.Clock as Clock -import Sound.Tidal.Stream.Config -import Sound.Tidal.Stream.Process -import Sound.Tidal.Stream.Types +module Sound.Tidal.Stream.UI where -import Sound.Tidal.ID -import Sound.Tidal.Pattern +import Control.Concurrent.MVar +import qualified Control.Exception as E +import qualified Data.Map as Map +import qualified Sound.Tidal.Clock as Clock +import Sound.Tidal.ID +import Sound.Tidal.Pattern +import Sound.Tidal.Stream.Config +import Sound.Tidal.Stream.Process +import Sound.Tidal.Stream.Types +import System.IO (hPutStrLn, stderr) +import System.Random (getStdRandom, randomR) streamNudgeAll :: Stream -> Double -> IO () streamNudgeAll s = Clock.setNudge (sClockRef s) @@ -32,13 +31,13 @@ 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) +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) +streamGetNow s = Clock.getCycleTime (cClockConfig $ sConfig s) (sClockRef s) streamEnableLink :: Stream -> IO () streamEnableLink s = Clock.enableLink (sClockRef s) @@ -47,29 +46,35 @@ 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 {psSolo = True})) = k ++ " - solo\n" - showKV True (k, _) = "(" ++ k ++ ")\n" - showKV False (k, (PlayState {psSolo = False})) = k ++ "\n" - showKV False (k, _) = "(" ++ k ++ ") - muted\n" +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" 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) + 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) +-- = 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 +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) (sPMapMV stream) (sGlobalFMV stream) (sCxs stream) pat @@ -90,18 +95,19 @@ 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 () +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}) +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}) @@ -110,20 +116,22 @@ 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}) +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 () +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' +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 diff --git a/test/Sound/Tidal/StreamTest.hs b/test/Sound/Tidal/StreamTest.hs index 83f0fa47b..81d4c10c5 100644 --- a/test/Sound/Tidal/StreamTest.hs +++ b/test/Sound/Tidal/StreamTest.hs @@ -2,12 +2,11 @@ module Sound.Tidal.StreamTest where -import Test.Microspec - -import Sound.Tidal.Stream -import Sound.Tidal.Pattern -import qualified Sound.Osc.Fd as O import qualified Data.Map.Strict as M +import qualified Sound.Osc.Fd as O +import Sound.Tidal.Pattern +import Sound.Tidal.Stream +import Test.Microspec run :: Microspec () run = @@ -15,7 +14,7 @@ run = describe "toDatum" $ do it "should convert VN to osc float" $ do toDatum (VN (Note 3.5)) `shouldBe` O.float (3.5 :: Double) - + describe "substitutePath" $ do -- ValueMap let state = M.fromList [("sound", VS "sn"), ("n", VI 8)] @@ -25,7 +24,7 @@ run = substitutePath "/{sound}/{n}/vol" state `shouldBe` Just "/sn/8/vol" it "should return Nothing if a param is not present" $ do substitutePath "/{sound}/{inst}" state `shouldBe` Nothing - + describe "getString" $ do it "should return Nothing for missing params" $ do getString M.empty "s" `shouldBe` Nothing From 6e5b63baa2402ae04b71dd9dbf4171c9fa3b7d5a Mon Sep 17 00:00:00 2001 From: Matthew Kaney Date: Sat, 1 Feb 2025 11:39:07 -0500 Subject: [PATCH 09/12] Revert "Reformat updated Stream files" This reverts commit 77a6c286673bf7e74e4fe03e961f92cfffe7c78f. --- src/Sound/Tidal/Stream/Config.hs | 46 ++- src/Sound/Tidal/Stream/Listen.hs | 138 +++++---- src/Sound/Tidal/Stream/Main.hs | 79 ++--- src/Sound/Tidal/Stream/Process.hs | 474 ++++++++++++++---------------- src/Sound/Tidal/Stream/Target.hs | 260 +++++++--------- src/Sound/Tidal/Stream/Types.hs | 117 ++++---- src/Sound/Tidal/Stream/UI.hs | 100 +++---- test/Sound/Tidal/StreamTest.hs | 13 +- 8 files changed, 569 insertions(+), 658 deletions(-) diff --git a/src/Sound/Tidal/Stream/Config.hs b/src/Sound/Tidal/Stream/Config.hs index ccb4fda81..ef86309cb 100644 --- a/src/Sound/Tidal/Stream/Config.hs +++ b/src/Sound/Tidal/Stream/Config.hs @@ -1,6 +1,7 @@ module Sound.Tidal.Stream.Config where -import Control.Monad (when) +import Control.Monad (when) + import qualified Sound.Tidal.Clock as Clock {- @@ -21,31 +22,28 @@ import qualified Sound.Tidal.Clock as Clock along with this library. If not, see . -} -data Config = Config - { cCtrlListen :: Bool, - cCtrlAddr :: String, - cCtrlPort :: Int, - cCtrlBroadcast :: Bool, - -- cTempoAddr :: String, - -- cTempoPort :: Int, - -- cTempoClientPort :: Int, - cVerbose :: Bool, - cClockConfig :: Clock.ClockConfig - } +data Config = Config {cCtrlListen :: Bool, + cCtrlAddr :: String, + cCtrlPort :: Int, + cCtrlBroadcast :: Bool, + -- cTempoAddr :: String, + -- cTempoPort :: Int, + -- cTempoClientPort :: Int, + cVerbose :: Bool, + cClockConfig :: Clock.ClockConfig + } defaultConfig :: Config -defaultConfig = - Config - { cCtrlListen = True, - cCtrlAddr = "127.0.0.1", - cCtrlPort = 6010, - cCtrlBroadcast = False, - -- cTempoAddr = "127.0.0.1", - -- cTempoPort = 9160, - -- cTempoClientPort = 0, -- choose at random - cVerbose = True, - cClockConfig = Clock.defaultConfig - } +defaultConfig = Config {cCtrlListen = True, + cCtrlAddr ="127.0.0.1", + cCtrlPort = 6010, + cCtrlBroadcast = False, + -- cTempoAddr = "127.0.0.1", + -- cTempoPort = 9160, + -- cTempoClientPort = 0, -- choose at random + cVerbose = True, + cClockConfig = Clock.defaultConfig + } verbose :: Config -> String -> IO () verbose c s = when (cVerbose c) $ putStrLn s diff --git a/src/Sound/Tidal/Stream/Listen.hs b/src/Sound/Tidal/Stream/Listen.hs index 099e99170..5cc035a55 100644 --- a/src/Sound/Tidal/Stream/Listen.hs +++ b/src/Sound/Tidal/Stream/Listen.hs @@ -1,18 +1,20 @@ module Sound.Tidal.Stream.Listen where -import Control.Concurrent.MVar -import qualified Control.Exception as E -import Control.Monad (when) -import qualified Data.Map as Map -import Data.Maybe (fromJust) -import qualified Network.Socket as N -import qualified Sound.Osc.Fd as O -import Sound.Tidal.ID -import Sound.Tidal.Pattern -import Sound.Tidal.Stream.Config -import Sound.Tidal.Stream.Types -import Sound.Tidal.Stream.UI -import System.IO (hPutStrLn, stderr) +import Control.Concurrent.MVar +import qualified Control.Exception as E +import Control.Monad (when) +import qualified Data.Map as Map +import Data.Maybe (fromJust) +import qualified Network.Socket as N +import qualified Sound.Osc.Fd as O +import System.IO (hPutStrLn, stderr) + +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 @@ -32,69 +34,63 @@ import System.IO (hPutStrLn, stderr) 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 + | 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 + 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 :: Config -> Stream -> IO () ctrlResponder _ (stream@(Stream {sListen = Just sock})) = loop - where - loop :: IO () - loop = do - O.recvMessages sock >>= mapM_ act - loop - -- External controller commands - act :: O.Message -> IO () - 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 () + where + loop :: IO () + loop = do O.recvMessages sock >>= mapM_ act + loop + -- External controller commands + act :: O.Message -> IO () + 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 () diff --git a/src/Sound/Tidal/Stream/Main.hs b/src/Sound/Tidal/Stream/Main.hs index 0a1738941..8f99baa5e 100644 --- a/src/Sound/Tidal/Stream/Main.hs +++ b/src/Sound/Tidal/Stream/Main.hs @@ -1,16 +1,18 @@ module Sound.Tidal.Stream.Main where -import Control.Concurrent -import Control.Concurrent.MVar -import qualified Data.Map as Map -import qualified Sound.Tidal.Clock as Clock -import Sound.Tidal.Stream.Config -import Sound.Tidal.Stream.Listen -import Sound.Tidal.Stream.Process -import Sound.Tidal.Stream.Target -import Sound.Tidal.Stream.Types -import Sound.Tidal.Version (tidal_status_string) -import System.IO (hPutStrLn, stderr) +import Control.Concurrent +import Control.Concurrent.MVar +import qualified Data.Map as Map +import qualified Sound.Tidal.Clock as Clock +import System.IO (hPutStrLn, stderr) + + +import Sound.Tidal.Stream.Config +import Sound.Tidal.Stream.Listen +import Sound.Tidal.Stream.Process +import Sound.Tidal.Stream.Target +import Sound.Tidal.Stream.Types +import Sound.Tidal.Version (tidal_status_string) {- Main.hs - Start tidals stream, listen and act on incoming messages @@ -30,6 +32,7 @@ import System.IO (hPutStrLn, stderr) 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])] @@ -39,34 +42,32 @@ startTidal target config = startStream config [(target, [superdirtShape])] -- 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 - 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 pMapMV globalFMV cxs) - - let stream = - Stream - { sConfig = config, - sStateMV = sMapMV, - sClockRef = clockRef, - -- sLink = abletonLink, - sListen = listen, - sPMapMV = pMapMV, - -- sActionsMV = actionsMV, - sGlobalFMV = globalFMV, - sCxs = cxs - } - - -- Spawn a thread to handle OSC control messages - _ <- forkIO $ ctrlResponder config stream - return stream + sMapMV <- newMVar Map.empty + pMapMV <- newMVar Map.empty + 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 pMapMV globalFMV cxs) + + let stream = Stream {sConfig = config, + sStateMV = sMapMV, + sClockRef = clockRef, + -- sLink = abletonLink, + sListen = listen, + sPMapMV = pMapMV, + -- sActionsMV = actionsMV, + sGlobalFMV = globalFMV, + sCxs = cxs + } + + -- Spawn a thread to handle OSC control messages + _ <- forkIO $ ctrlResponder 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 index bbc6eccbb..9d4e45983 100644 --- a/src/Sound/Tidal/Stream/Process.hs +++ b/src/Sound/Tidal/Stream/Process.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} module Sound.Tidal.Stream.Process where @@ -27,39 +27,43 @@ module Sound.Tidal.Stream.Process where along with this library. If not, see . -} -import Control.Applicative ((<|>)) -import Control.Concurrent.MVar -import qualified Control.Exception as E -import Control.Monad (forM_, when) -import Data.Coerce (coerce) -import Data.List (sortOn) -import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes, fromJust, fromMaybe) -import Foreign.C.Types -import qualified Sound.Osc.Fd as O -import qualified Sound.Tidal.Clock as Clock -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 Sound.Tidal.Stream.Config -import Sound.Tidal.Stream.Target -import Sound.Tidal.Stream.Types -import Sound.Tidal.Utils ((!!!)) -import System.IO (hPutStrLn, stderr) +import Control.Applicative ((<|>)) +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) +import Foreign.C.Types +import System.IO (hPutStrLn, stderr) -data ProcessedEvent = ProcessedEvent - { peHasOnset :: Bool, - peEvent :: Event ValueMap, - peCps :: Link.BPM, - peDelta :: Link.Micros, - peCycle :: Time, - peOnWholeOrPart :: Link.Micros, +import qualified Sound.Osc.Fd as O + +import Data.List (sortOn) +import qualified Sound.Tidal.Clock as Clock +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 Sound.Tidal.Stream.Config +import Sound.Tidal.Utils ((!!!)) + +import Sound.Tidal.Stream.Target +import Sound.Tidal.Stream.Types + +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 + peOnPart :: Link.Micros, + peOnPartOsc :: O.Time } -- | Query the current pattern (contained in argument @stream :: Stream@) @@ -75,62 +79,53 @@ data ProcessedEvent = ProcessedEvent -- 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 PlayMap -> -- currently playing - MVar (ControlPattern -> ControlPattern) -> -- current global fx - [Cx] -> -- target addresses - (Time, Time) -> -- current arc - Double -> -- nudge - Clock.LinkOperations -> -- ableton link operations - IO () -doTick stateMV playMV globalFMV cxs (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 - 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 _ _ bussesMV) -> do - busses <- mapM readMVar bussesMV - -- 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 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'' - ) + +doTick :: MVar ValueMap -- pattern state + -> MVar PlayMap -- currently playing + -> MVar (ControlPattern -> ControlPattern) -- current global fx + -> [Cx] -- target addresses + -> (Time,Time) -- current arc + -> Double -- nudge + -> Clock.LinkOperations -- ableton link operations + -> IO () +doTick stateMV playMV globalFMV cxs (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 + 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 _ _ bussesMV) -> do + busses <- mapM readMVar bussesMV + -- 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 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 :: Event ValueMap -> IO ProcessedEvent processEvent e = do let wope = wholeOrPart e partStartCycle = start $ part e @@ -141,173 +136,152 @@ processCps ops = mapM processEvent 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' + 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 - } + 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 :: Maybe [Int] -> ProcessedEvent -> OSC -> [(Double, Bool, O.Message)] -toOSC maybeBusses pe osc@(OSC _ _) = - catMaybes (playmsg : busmsgs) - where - -- 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. - (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 (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 - | Just busses <- maybeBusses, (not . null) busses = busses !!! n - | otherwise = 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 (toBus bi), toDatum v] - ) - ) - (Map.toList busmap) +toOSC :: Maybe [Int] -> ProcessedEvent -> OSC -> [(Double, Bool, O.Message)] +toOSC maybeBusses 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 - 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 + (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 (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 | Just busses <- maybeBusses, (not . null) busses = busses !!! n + | otherwise = 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 (toBus 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 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 = 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 + | 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) + 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 (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" +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 + 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 + 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) + where active pState = if hasSolo pMap + then psSolo pState + else not (psMute pState) hasSolo :: Map.Map k PlayState -> Bool hasSolo = (>= 1) . length . filter psSolo . 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 @@ -316,19 +290,17 @@ hasSolo = (>= 1) . length . filter psSolo . Map.elems onSingleTick :: Config -> Clock.ClockRef -> MVar ValueMap -> MVar PlayMap -> MVar (ControlPattern -> ControlPattern) -> [Cx] -> ControlPattern -> IO () onSingleTick config clockRef stateMV _ globalFMV cxs pat = do ops <- Clock.getZeroedLinkOperations (cClockConfig config) clockRef - pMapMV <- - newMVar $ - Map.singleton - "fake" - ( PlayState - { psPattern = pat, - psMute = False, - psSolo = False, - psHistory = [] - } - ) + pMapMV <- newMVar $ Map.singleton "fake" + (PlayState {psPattern = pat, + psMute = False, + psSolo = False, + psHistory = [] + } + ) -- The nowArc is a full cycle - doTick stateMV pMapMV globalFMV cxs (0, 1) 0 ops + doTick stateMV pMapMV globalFMV cxs (0,1) 0 ops + + -- Used for Tempo callback updatePattern :: Stream -> ID -> Time -> ControlPattern -> IO () @@ -337,20 +309,16 @@ updatePattern stream k !t pat = do 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) + 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) setPreviousPatternOrSilence :: MVar PlayMap -> IO () setPreviousPatternOrSilence playMV = - modifyMVar_ playMV $ - return - . Map.map - ( \pMap -> case psHistory pMap of - _ : p : ps -> pMap {psPattern = p, psHistory = p : ps} - _ -> pMap {psPattern = silence, psHistory = [silence]} - ) + modifyMVar_ playMV $ return + . Map.map ( \ pMap -> case psHistory pMap of + _:p:ps -> pMap { psPattern = p, psHistory = p:ps } + _ -> pMap { psPattern = silence, psHistory = [silence] } + ) diff --git a/src/Sound/Tidal/Stream/Target.hs b/src/Sound/Tidal/Stream/Target.hs index c248a9625..35f640563 100644 --- a/src/Sound/Tidal/Stream/Target.hs +++ b/src/Sound/Tidal/Stream/Target.hs @@ -1,22 +1,17 @@ module Sound.Tidal.Stream.Target where -import Control.Concurrent - ( forkIO, - forkOS, - newMVar, - readMVar, - swapMVar, - threadDelay, - ) -import Control.Monad (when) -import Data.Maybe (catMaybes, fromJust, isJust) -import Foreign (Word8) -import qualified Network.Socket as N -import qualified Sound.Osc.Fd as O -import qualified Sound.Osc.Time.Timeout as O -import Sound.Tidal.Pattern -import Sound.Tidal.Stream.Config -import Sound.Tidal.Stream.Types +import Control.Concurrent (forkIO, forkOS, newMVar, readMVar, + swapMVar, threadDelay) +import Control.Monad (when) +import Data.Maybe (catMaybes, fromJust, isJust) +import Foreign (Word8) +import qualified Network.Socket as N +import qualified Sound.Osc.Fd as O +import qualified Sound.Osc.Time.Timeout as O + +import Sound.Tidal.Pattern +import Sound.Tidal.Stream.Config +import Sound.Tidal.Stream.Types {- Target.hs - Create and send to OSC targets @@ -36,66 +31,52 @@ import Sound.Tidal.Stream.Types 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) (oPort target) - remote_bus_addr <- mapM (resolve (oAddress target)) (oBusPort target) - remote_busses <- sequence (oBusPort target >> Just (newMVar [])) - - let broadcast = if cCtrlBroadcast config then 1 else 0 - u <- - O.udp_socket - ( \sock _ -> do N.setSocketOption sock N.Broadcast broadcast - ) - (oAddress target) - (oPort target) - let cx = Cx {cxUDP = u, cxAddr = remote_addr, cxBusAddr = remote_bus_addr, cxBusses = remote_busses, cxTarget = target, cxOSCs = os} - _ <- forkIO $ handshake cx config - return cx - ) - oscmap +getCXs config oscmap = mapM (\(target, os) -> do + remote_addr <- resolve (oAddress target) (oPort target) + remote_bus_addr <- mapM (resolve (oAddress target)) (oBusPort target) + remote_busses <- sequence (oBusPort target >> Just (newMVar [])) + + let broadcast = if cCtrlBroadcast config then 1 else 0 + u <- O.udp_socket (\sock _ -> do N.setSocketOption sock N.Broadcast broadcast + ) (oAddress target) (oPort target) + let cx = Cx {cxUDP = u, cxAddr = remote_addr, cxBusAddr = remote_bus_addr, cxBusses = remote_busses, cxTarget = target, cxOSCs = os} + _ <- forkIO $ handshake cx config + return cx + ) oscmap resolve :: String -> Int -> IO N.AddrInfo -resolve host port = do - let hints = N.defaultHints {N.addrSocketType = N.Stream} - addr : _ <- N.getAddrInfo (Just hints) (Just host) (Just $ show port) - return addr +resolve host port = do let hints = N.defaultHints { N.addrSocketType = N.Stream } + addr:_ <- N.getAddrInfo (Just hints) (Just host) (Just $ show port) + return addr handshake :: Cx -> Config -> IO () -handshake Cx {cxUDP = udp, cxBusses = Just bussesMV, cxAddr = addr} c = sendHandshake >> listen 0 +handshake Cx { cxUDP = udp, cxBusses = Just bussesMV, cxAddr = addr } c = sendHandshake >> listen 0 where sendHandshake :: IO () sendHandshake = O.sendTo udp (O.Packet_Message $ O.Message "/dirt/handshake" []) (N.addrAddress addr) listen :: Int -> IO () - listen waits = do - ms <- recvMessagesTimeout 2 udp - if null ms - then do - checkHandshake waits -- there was a timeout, check handshake - listen (waits + 1) - else do - mapM_ respond ms - listen 0 + listen waits = do ms <- recvMessagesTimeout 2 udp + if null ms + then do checkHandshake waits -- there was a timeout, check handshake + listen (waits+1) + else do mapM_ respond ms + listen 0 checkHandshake :: Int -> IO () - checkHandshake waits = do - busses <- readMVar bussesMV - when (null busses) $ do - when (waits == 0) $ verbose c $ "Waiting for SuperDirt (v.1.7.2 or higher).." - sendHandshake + checkHandshake waits = do busses <- readMVar bussesMV + when (null busses) $ do when (waits == 0) $ verbose c $ "Waiting for SuperDirt (v.1.7.2 or higher).." + sendHandshake respond :: O.Message -> IO () respond (O.Message "/dirt/hello" _) = sendHandshake - respond (O.Message "/dirt/handshake/reply" xs) = do - prev <- swapMVar bussesMV $ bufferIndices xs - -- Only report the first time.. - when (null prev) $ verbose c $ "Connected to SuperDirt." + respond (O.Message "/dirt/handshake/reply" xs) = do prev <- swapMVar bussesMV $ bufferIndices xs + -- Only report the first time.. + when (null prev) $ verbose c $ "Connected to SuperDirt." respond _ = return () bufferIndices :: [O.Datum] -> [Int] bufferIndices [] = [] - bufferIndices (x : xs') - | x == O.AsciiString (O.ascii "&controlBusIndices") = catMaybes $ takeWhile isJust $ map O.datum_integral xs' - | otherwise = bufferIndices xs' + bufferIndices (x:xs') | x == O.AsciiString (O.ascii "&controlBusIndices") = catMaybes $ takeWhile isJust $ map O.datum_integral xs' + | otherwise = bufferIndices xs' handshake _ _ = return () recvMessagesTimeout :: (O.Transport t) => Double -> t -> IO [O.Message] @@ -109,118 +90,99 @@ send :: Cx -> Double -> Double -> (Double, Bool, O.Message) -> IO () send cx latency extraLatency (time, isBusMsg, m) | oSchedule target == Pre BundleStamp = sendBndl isBusMsg cx $ O.Bundle timeWithLatency [m] | oSchedule target == Pre MessageStamp = sendO isBusMsg cx $ addtime m - | otherwise = do - _ <- forkOS $ do - now <- O.time - threadDelay $ floor $ (timeWithLatency - now) * 1000000 - sendO isBusMsg 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 + | otherwise = do _ <- forkOS $ do now <- O.time + threadDelay $ floor $ (timeWithLatency - now) * 1000000 + sendO isBusMsg 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 -> Cx -> O.Bundle -> IO () sendBndl isBusMsg cx bndl = O.sendTo (cxUDP cx) (O.Packet_Bundle bndl) (N.addrAddress addr) - where - addr - | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx - | otherwise = cxAddr cx + where addr | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx + | otherwise = cxAddr cx sendO :: Bool -> Cx -> O.Message -> IO () sendO isBusMsg cx msg = O.sendTo (cxUDP cx) (O.Packet_Message msg) (N.addrAddress addr) - where - addr - | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx - | otherwise = cxAddr cx + where addr | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx + | otherwise = cxAddr cx 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 - } +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 - } +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) - ] +dirtShape = OSC "/play" $ ArgList [("cps", fDefault 0), + ("s", Nothing), + ("offset", fDefault 0), + ("begin", fDefault 0), + ("end", fDefault 1), + ("speed", fDefault 1), + ("pan", fDefault 0.5), + ("velocity", fDefault 0.5), + ("vowel", sDefault ""), + ("cutoff", fDefault 0), + ("resonance", fDefault 0), + ("accelerate", fDefault 0), + ("shape", fDefault 0), + ("kriole", iDefault 0), + ("gain", fDefault 1), + ("cut", iDefault 0), + ("delay", fDefault 0), + ("delaytime", fDefault (-1)), + ("delayfeedback", fDefault (-1)), + ("crush", fDefault 0), + ("coarse", iDefault 0), + ("hcutoff", fDefault 0), + ("hresonance", fDefault 0), + ("bandf", fDefault 0), + ("bandq", fDefault 0), + ("unit", sDefault "rate"), + ("loop", fDefault 0), + ("n", fDefault 0), + ("attack", fDefault (-1)), + ("hold", fDefault 0), + ("release", fDefault (-1)), + ("orbit", iDefault 0) -- , + -- ("id", iDefault 0) + ] sDefault :: String -> Maybe Value sDefault x = Just $ VS x - fDefault :: Double -> Maybe Value fDefault x = Just $ VF x - rDefault :: Rational -> Maybe Value rDefault x = Just $ VR x - iDefault :: Int -> Maybe Value iDefault x = Just $ VI x - bDefault :: Bool -> Maybe Value bDefault x = Just $ VB x - xDefault :: [Word8] -> Maybe Value xDefault x = Just $ VX x diff --git a/src/Sound/Tidal/Stream/Types.hs b/src/Sound/Tidal/Stream/Types.hs index 118faad7c..2c4275312 100644 --- a/src/Sound/Tidal/Stream/Types.hs +++ b/src/Sound/Tidal/Stream/Types.hs @@ -1,79 +1,72 @@ module Sound.Tidal.Stream.Types where -import Control.Concurrent.MVar -import qualified Data.Map.Strict as Map -import qualified Network.Socket as N -import qualified Sound.Osc.Fd as O -import qualified Sound.Tidal.Clock as Clock -import Sound.Tidal.Pattern -import Sound.Tidal.Show () -import Sound.Tidal.Stream.Config +import Control.Concurrent.MVar +import qualified Data.Map.Strict as Map +import Sound.Tidal.Pattern +import Sound.Tidal.Show () -data Stream = Stream - { sConfig :: Config, - sStateMV :: MVar ValueMap, - -- sOutput :: MVar ControlPattern, - sClockRef :: Clock.ClockRef, - sListen :: Maybe O.Udp, - sPMapMV :: MVar PlayMap, - sGlobalFMV :: MVar (ControlPattern -> ControlPattern), - sCxs :: [Cx] - } +import qualified Network.Socket as N +import qualified Sound.Osc.Fd as O -data Cx = Cx - { cxTarget :: Target, - cxUDP :: O.Udp, - cxOSCs :: [OSC], - cxAddr :: N.AddrInfo, - cxBusAddr :: Maybe N.AddrInfo, - cxBusses :: Maybe (MVar [Int]) - } +import qualified Sound.Tidal.Clock as Clock -data StampStyle - = BundleStamp - | MessageStamp +import Sound.Tidal.Stream.Config + +data Stream = Stream {sConfig :: Config, + 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, + cxBusses :: Maybe (MVar [Int]) + } + +data StampStyle = BundleStamp + | MessageStamp deriving (Eq, Show) -data Schedule - = Pre StampStyle - | Live +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 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 Args = Named {requiredArgs :: [String]} + | ArgList [(String, Maybe Value)] + deriving Show -data OSC - = OSC - { path :: String, - args :: Args - } - | OSCContext {path :: String} - deriving (Show) +data OSC = OSC {path :: String, + args :: Args + } + | OSCContext {path :: String} + deriving Show -data PlayState = PlayState - { psPattern :: ControlPattern, - psMute :: Bool, - psSolo :: Bool, - psHistory :: [ControlPattern] - } - deriving (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 { diff --git a/src/Sound/Tidal/Stream/UI.hs b/src/Sound/Tidal/Stream/UI.hs index 5190d7c7f..119041167 100644 --- a/src/Sound/Tidal/Stream/UI.hs +++ b/src/Sound/Tidal/Stream/UI.hs @@ -1,19 +1,20 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} - module Sound.Tidal.Stream.UI where -import Control.Concurrent.MVar -import qualified Control.Exception as E -import qualified Data.Map as Map -import qualified Sound.Tidal.Clock as Clock -import Sound.Tidal.ID -import Sound.Tidal.Pattern -import Sound.Tidal.Stream.Config -import Sound.Tidal.Stream.Process -import Sound.Tidal.Stream.Types -import System.IO (hPutStrLn, stderr) -import System.Random (getStdRandom, randomR) +import Control.Concurrent.MVar +import qualified Control.Exception as E +import qualified Data.Map as Map +import System.IO (hPutStrLn, stderr) +import System.Random (getStdRandom, randomR) + +import qualified Sound.Tidal.Clock as Clock +import Sound.Tidal.Stream.Config +import Sound.Tidal.Stream.Process +import Sound.Tidal.Stream.Types + +import Sound.Tidal.ID +import Sound.Tidal.Pattern streamNudgeAll :: Stream -> Double -> IO () streamNudgeAll s = Clock.setNudge (sClockRef s) @@ -31,13 +32,13 @@ 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) +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) +streamGetNow s = Clock.getCycleTime (cClockConfig $ sConfig s)(sClockRef s) streamEnableLink :: Stream -> IO () streamEnableLink s = Clock.enableLink (sClockRef s) @@ -46,35 +47,29 @@ 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 {psSolo = True})) = k ++ " - solo\n" - showKV True (k, _) = "(" ++ k ++ ")\n" - showKV False (k, (PlayState {psSolo = False})) = k ++ "\n" - showKV False (k, _) = "(" ++ k ++ ") - muted\n" +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" 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) + 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) + -- = 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 +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) (sPMapMV stream) (sGlobalFMV stream) (sCxs stream) pat @@ -95,19 +90,18 @@ 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 () +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}) +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}) @@ -116,22 +110,20 @@ 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}) +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 () +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' +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 diff --git a/test/Sound/Tidal/StreamTest.hs b/test/Sound/Tidal/StreamTest.hs index 81d4c10c5..83f0fa47b 100644 --- a/test/Sound/Tidal/StreamTest.hs +++ b/test/Sound/Tidal/StreamTest.hs @@ -2,19 +2,20 @@ module Sound.Tidal.StreamTest where -import qualified Data.Map.Strict as M -import qualified Sound.Osc.Fd as O -import Sound.Tidal.Pattern -import Sound.Tidal.Stream import Test.Microspec +import Sound.Tidal.Stream +import Sound.Tidal.Pattern +import qualified Sound.Osc.Fd as O +import qualified Data.Map.Strict as M + run :: Microspec () run = describe "Sound.Tidal.Stream" $ do describe "toDatum" $ do it "should convert VN to osc float" $ do toDatum (VN (Note 3.5)) `shouldBe` O.float (3.5 :: Double) - + describe "substitutePath" $ do -- ValueMap let state = M.fromList [("sound", VS "sn"), ("n", VI 8)] @@ -24,7 +25,7 @@ run = substitutePath "/{sound}/{n}/vol" state `shouldBe` Just "/sn/8/vol" it "should return Nothing if a param is not present" $ do substitutePath "/{sound}/{inst}" state `shouldBe` Nothing - + describe "getString" $ do it "should return Nothing for missing params" $ do getString M.empty "s" `shouldBe` Nothing From cad3ab236fd7c8635755ef72321eedee2a24d351 Mon Sep 17 00:00:00 2001 From: Matthew Kaney Date: Sun, 2 Feb 2025 18:55:05 -0500 Subject: [PATCH 10/12] Redo formatting --- src/Sound/Tidal/Safe/Boot.hs | 121 +++++--- src/Sound/Tidal/Safe/Context.hs | 104 ++++--- src/Sound/Tidal/Stream/Config.hs | 46 ++-- src/Sound/Tidal/Stream/Listen.hs | 158 +++++------ src/Sound/Tidal/Stream/Main.hs | 79 +++--- src/Sound/Tidal/Stream/Process.hs | 442 ++++++++++++++++-------------- src/Sound/Tidal/Stream/Target.hs | 260 ++++++++++-------- src/Sound/Tidal/Stream/Types.hs | 115 ++++---- src/Sound/Tidal/Stream/UI.hs | 98 ++++--- 9 files changed, 787 insertions(+), 636 deletions(-) diff --git a/src/Sound/Tidal/Safe/Boot.hs b/src/Sound/Tidal/Safe/Boot.hs index b9a33bed0..e69405f38 100644 --- a/src/Sound/Tidal/Safe/Boot.hs +++ b/src/Sound/Tidal/Safe/Boot.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} {- Safe/Boot.hs - as in BootTidal but in the Op monad Copyright (C) 2021 Johannes Waldmann and contributors @@ -18,9 +19,7 @@ You should have received a copy of the GNU General Public License along with this library. If not, see . -} - {-# OPTIONS_GHC -Wno-missing-signatures #-} -{-# language NoMonomorphismRestriction #-} module Sound.Tidal.Safe.Boot where @@ -31,98 +30,142 @@ import qualified Sound.Tidal.Transition -- this will be provided by the Reader monad p = streamReplace + hush = streamHush + list = streamList + mute = streamMute + unmute = streamUnmute + solo = streamSolo + unsolo = streamUnsolo + once = streamOnce + first = streamFirst -asap = once -nudgeAll = streamNudgeAll -all = streamAll -{-| - Resets the cycle count back to 0. - Useful to make sure a pattern or set of patterns start from the beginning: +asap = once - > do - > resetCycles - > d1 $ s "bd hh hh hh" - > d2 $ s "ade" # cut 1 +nudgeAll = streamNudgeAll - Cycle count affects all patterns, so if there are any active, all of them will immediately jump to the beginning. - @resetCycles@ is also userful in multi-user Tidal. +all = streamAll - Also see 'setCycle', 'getnow'. --} +-- | +-- Resets the cycle count back to 0. +-- Useful to make sure a pattern or set of patterns start from the beginning: +-- +-- > do +-- > resetCycles +-- > d1 $ s "bd hh hh hh" +-- > d2 $ s "ade" # cut 1 +-- +-- Cycle count affects all patterns, so if there are any active, all of them will immediately jump to the beginning. +-- @resetCycles@ is also userful in multi-user Tidal. +-- +-- Also see 'setCycle', 'getnow'. resetCycles = streamResetCycles -{-| - Adjusts the number of cycles per second, i.e., tempo. - Accepts integers, decimals, and fractions. - - The default number of cycles per second is 0.5625, equivalent to 135\/60\/4, i.e., - 135 beats per minute if there are 4 beats per cycle. - - Representing cycles per second using fractions has the advantage of being more - human-readable and more closely aligned with how tempo is commonly represented - in music as beats per minute (bpm). For example, techno has a typical range of - 120-140 bpm and house has a range of 115-130 bpm. To set the tempo in Tidal to - fast house, e.g.,: @setcps (130\/60\/4)@. - - The following sound the same: - - > setcps (130/60/4) - > d1 $ n "1" # s "kick kick kick kick" - - and - - > setcps (130/60/1) - > d1 $ n "1" # s "kick" --} +-- | +-- Adjusts the number of cycles per second, i.e., tempo. +-- Accepts integers, decimals, and fractions. +-- +-- The default number of cycles per second is 0.5625, equivalent to 135\/60\/4, i.e., +-- 135 beats per minute if there are 4 beats per cycle. +-- +-- Representing cycles per second using fractions has the advantage of being more +-- human-readable and more closely aligned with how tempo is commonly represented +-- in music as beats per minute (bpm). For example, techno has a typical range of +-- 120-140 bpm and house has a range of 115-130 bpm. To set the tempo in Tidal to +-- fast house, e.g.,: @setcps (130\/60\/4)@. +-- +-- The following sound the same: +-- +-- > setcps (130/60/4) +-- > d1 $ n "1" # s "kick kick kick kick" +-- +-- and +-- +-- > setcps (130/60/1) +-- > d1 $ n "1" # s "kick" setcps = asap . cps -- * Transitions xfade i = transition True (Sound.Tidal.Transition.xfadeIn 4) i + xfadeIn i t = transition True (Sound.Tidal.Transition.xfadeIn t) i + histpan i t = transition True (Sound.Tidal.Transition.histpan t) i + wait i t = transition True (Sound.Tidal.Transition.wait t) i + waitT i f t = transition True (Sound.Tidal.Transition.waitT f t) i + jump i = transition True (Sound.Tidal.Transition.jump) i + jumpIn i t = transition True (Sound.Tidal.Transition.jumpIn t) i + jumpIn' i t = transition True (Sound.Tidal.Transition.jumpIn' t) i + jumpMod i t = transition True (Sound.Tidal.Transition.jumpMod t) i + mortal i lifespan releaseTime = transition True (Sound.Tidal.Transition.mortal lifespan releaseTime) i + interpolate i = transition True (Sound.Tidal.Transition.interpolate) i + interpolateIn i t = transition True (Sound.Tidal.Transition.interpolateIn t) i + clutch i = transition True (Sound.Tidal.Transition.clutch) i + clutchIn i t = transition True (Sound.Tidal.Transition.clutchIn t) i + anticipate i = transition True (Sound.Tidal.Transition.anticipate) i + anticipateIn i t = transition True (Sound.Tidal.Transition.anticipateIn t) i + forId i t = transition False (Sound.Tidal.Transition.mortalOverlay t) i d1 = p 1 . (|< orbit 0) + d2 = p 2 . (|< orbit 1) + d3 = p 3 . (|< orbit 2) + d4 = p 4 . (|< orbit 3) + d5 = p 5 . (|< orbit 4) + d6 = p 6 . (|< orbit 5) + d7 = p 7 . (|< orbit 6) + d8 = p 8 . (|< orbit 7) + d9 = p 9 . (|< orbit 8) + d10 = p 10 . (|< orbit 9) + d11 = p 11 . (|< orbit 10) + d12 = p 12 . (|< orbit 11) + d13 = p 13 + d14 = p 14 + d15 = p 15 + d16 = p 16 setI = streamSetI + setF = streamSetF + setS = streamSetS + setR = streamSetR + setB = streamSetB diff --git a/src/Sound/Tidal/Safe/Context.hs b/src/Sound/Tidal/Safe/Context.hs index afb3754dd..cf5c1ce0e 100644 --- a/src/Sound/Tidal/Safe/Context.hs +++ b/src/Sound/Tidal/Safe/Context.hs @@ -18,42 +18,46 @@ You should have received a copy of the GNU General Public License along with this library. If not, see . -} - -{-# language GeneralizedNewtypeDeriving #-} -{-# language NoMonomorphismRestriction #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoMonomorphismRestriction #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} module Sound.Tidal.Safe.Context - ( Op () -- do not export constructor, - -- so the user has no way of putting arbitraty IO stuff - -- in "Op", and below "run" - , exec - , streamReplace - , streamHush - , streamList - , streamMute - , streamUnmute - , streamSolo - , streamUnsolo - , streamOnce - , streamFirst - , streamNudgeAll - , streamAll - , streamResetCycles - , streamSetI - , streamSetF - , streamSetS - , streamSetR - , streamSetB - , transition - , module C - , Target(..) + ( Op (), -- do not export constructor, + -- so the user has no way of putting arbitraty IO stuff + -- in "Op", and below "run" + exec, + streamReplace, + streamHush, + streamList, + streamMute, + streamUnmute, + streamSolo, + streamUnsolo, + streamOnce, + streamFirst, + streamNudgeAll, + streamAll, + streamResetCycles, + streamSetI, + streamSetF, + streamSetS, + streamSetR, + streamSetB, + transition, + module C, + Target (..), ) where +-- import Sound.Tidal.Transition as C + +import Control.Monad.Catch +import Control.Monad.Reader import Data.Ratio as C -import Sound.Tidal.Stream.Config as C +import Sound.Tidal.Context (Stream) +import qualified Sound.Tidal.Context as C import Sound.Tidal.Control as C import Sound.Tidal.Core as C import Sound.Tidal.Params as C @@ -61,45 +65,61 @@ 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.Target (superdirtTarget) -import Sound.Tidal.Stream.Types (Target(..)) +import Sound.Tidal.Stream.Config as C import Sound.Tidal.Stream.Main (startTidal) --- import Sound.Tidal.Transition as C +import Sound.Tidal.Stream.Target (superdirtTarget) +import Sound.Tidal.Stream.Types (Target (..)) import Sound.Tidal.UI as C import Sound.Tidal.Version as C -import qualified Sound.Tidal.Context as C -import Sound.Tidal.Context (Stream) -import Control.Monad.Reader -import Control.Monad.Catch - -newtype Op r = Op ( ReaderT Stream IO r ) - deriving (Functor, Applicative, Monad, MonadCatch,MonadThrow) +newtype Op r = Op (ReaderT Stream IO r) + deriving (Functor, Applicative, Monad, MonadCatch, MonadThrow) 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 -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 +op1 f = Op $ do a <- ask; lift $ f a + +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 streamReplace = op3 C.streamReplace + streamHush = op1 C.streamHush + streamList = op1 C.streamList + streamMute = op2 C.streamMute + streamUnmute = op2 C.streamUnmute + streamSolo = op2 C.streamSolo + streamUnsolo = op2 C.streamUnsolo + streamOnce = op2 C.streamOnce + streamFirst = op2 C.streamFirst + streamNudgeAll = op2 C.streamNudgeAll + streamAll = op2 C.streamAll + streamResetCycles = op1 C.streamResetCycles + transition = op5 C.transition + streamSetI = op3 C.streamSetI + streamSetF = op3 C.streamSetF + streamSetS = op3 C.streamSetS + streamSetR = op3 C.streamSetR + streamSetB = op3 C.streamSetB diff --git a/src/Sound/Tidal/Stream/Config.hs b/src/Sound/Tidal/Stream/Config.hs index ef86309cb..ccb4fda81 100644 --- a/src/Sound/Tidal/Stream/Config.hs +++ b/src/Sound/Tidal/Stream/Config.hs @@ -1,7 +1,6 @@ module Sound.Tidal.Stream.Config where -import Control.Monad (when) - +import Control.Monad (when) import qualified Sound.Tidal.Clock as Clock {- @@ -22,28 +21,31 @@ import qualified Sound.Tidal.Clock as Clock along with this library. If not, see . -} -data Config = Config {cCtrlListen :: Bool, - cCtrlAddr :: String, - cCtrlPort :: Int, - cCtrlBroadcast :: Bool, - -- cTempoAddr :: String, - -- cTempoPort :: Int, - -- cTempoClientPort :: Int, - cVerbose :: Bool, - cClockConfig :: Clock.ClockConfig - } +data Config = Config + { cCtrlListen :: Bool, + cCtrlAddr :: String, + cCtrlPort :: Int, + cCtrlBroadcast :: Bool, + -- cTempoAddr :: String, + -- cTempoPort :: Int, + -- cTempoClientPort :: Int, + cVerbose :: Bool, + cClockConfig :: Clock.ClockConfig + } defaultConfig :: Config -defaultConfig = Config {cCtrlListen = True, - cCtrlAddr ="127.0.0.1", - cCtrlPort = 6010, - cCtrlBroadcast = False, - -- cTempoAddr = "127.0.0.1", - -- cTempoPort = 9160, - -- cTempoClientPort = 0, -- choose at random - cVerbose = True, - cClockConfig = Clock.defaultConfig - } +defaultConfig = + Config + { cCtrlListen = True, + cCtrlAddr = "127.0.0.1", + cCtrlPort = 6010, + cCtrlBroadcast = False, + -- cTempoAddr = "127.0.0.1", + -- cTempoPort = 9160, + -- cTempoClientPort = 0, -- choose at random + cVerbose = True, + cClockConfig = Clock.defaultConfig + } verbose :: Config -> String -> IO () verbose c s = when (cVerbose c) $ putStrLn s diff --git a/src/Sound/Tidal/Stream/Listen.hs b/src/Sound/Tidal/Stream/Listen.hs index 1171c998b..e667189ab 100644 --- a/src/Sound/Tidal/Stream/Listen.hs +++ b/src/Sound/Tidal/Stream/Listen.hs @@ -1,21 +1,19 @@ module Sound.Tidal.Stream.Listen where -import Control.Concurrent.MVar -import Control.Monad (when) -import System.IO (hPutStrLn, stderr) +import Control.Concurrent.MVar +import qualified Control.Exception as E +import Control.Monad (when) import qualified Data.Map as Map -import Data.Maybe (fromJust) +import Data.Maybe (fromJust) +import qualified Network.Socket as N import qualified Sound.Osc.Fd as O import qualified Sound.Osc.Transport.Fd.Udp 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 +import Sound.Tidal.ID +import Sound.Tidal.Pattern +import Sound.Tidal.Stream.Config +import Sound.Tidal.Stream.Types +import Sound.Tidal.Stream.UI +import System.IO (hPutStrLn, stderr) {- Listen.hs - logic for listening and acting on incoming OSC messages @@ -35,75 +33,81 @@ import Sound.Tidal.Stream.UI 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 + | 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 + 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 :: Config -> Stream -> IO () ctrlResponder _ (stream@(Stream {sListen = Just sock})) = loop - where - loop :: IO () - loop = do O.recvMessages sock >>= mapM_ act - loop - -- External controller commands - act :: O.Message -> IO () - 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 - -- Cycle properties commands - act (O.Message "/setcps" [O.Float k]) - = streamSetCPS stream $ toTime k - act (O.Message "/setbpm" [O.Float k]) - = streamSetBPM stream $ toTime k - act (O.Message "/setCycle" [O.Float k]) - = streamSetCycle stream $ toTime k - act (O.Message "/resetCycles" _) - = streamResetCycles stream - -- Nudge all command - act (O.Message "/nudgeAll" [O.Double k]) - = streamNudgeAll stream k - 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 () + where + loop :: IO () + loop = do + O.recvMessages sock >>= mapM_ act + loop + -- External controller commands + act :: O.Message -> IO () + 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 + -- Cycle properties commands + act (O.Message "/setcps" [O.Float k]) = + streamSetCPS stream $ toTime k + act (O.Message "/setbpm" [O.Float k]) = + streamSetBPM stream $ toTime k + act (O.Message "/setCycle" [O.Float k]) = + streamSetCycle stream $ toTime k + act (O.Message "/resetCycles" _) = + streamResetCycles stream + -- Nudge all command + act (O.Message "/nudgeAll" [O.Double k]) = + streamNudgeAll stream k + 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 () diff --git a/src/Sound/Tidal/Stream/Main.hs b/src/Sound/Tidal/Stream/Main.hs index 8f99baa5e..0a1738941 100644 --- a/src/Sound/Tidal/Stream/Main.hs +++ b/src/Sound/Tidal/Stream/Main.hs @@ -1,18 +1,16 @@ module Sound.Tidal.Stream.Main where -import Control.Concurrent -import Control.Concurrent.MVar -import qualified Data.Map as Map -import qualified Sound.Tidal.Clock as Clock -import System.IO (hPutStrLn, stderr) - - -import Sound.Tidal.Stream.Config -import Sound.Tidal.Stream.Listen -import Sound.Tidal.Stream.Process -import Sound.Tidal.Stream.Target -import Sound.Tidal.Stream.Types -import Sound.Tidal.Version (tidal_status_string) +import Control.Concurrent +import Control.Concurrent.MVar +import qualified Data.Map as Map +import qualified Sound.Tidal.Clock as Clock +import Sound.Tidal.Stream.Config +import Sound.Tidal.Stream.Listen +import Sound.Tidal.Stream.Process +import Sound.Tidal.Stream.Target +import Sound.Tidal.Stream.Types +import Sound.Tidal.Version (tidal_status_string) +import System.IO (hPutStrLn, stderr) {- Main.hs - Start tidals stream, listen and act on incoming messages @@ -32,7 +30,6 @@ import Sound.Tidal.Version (tidal_status_string) 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])] @@ -42,32 +39,34 @@ startTidal target config = startStream config [(target, [superdirtShape])] -- 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 - 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 pMapMV globalFMV cxs) - - let stream = Stream {sConfig = config, - sStateMV = sMapMV, - sClockRef = clockRef, - -- sLink = abletonLink, - sListen = listen, - sPMapMV = pMapMV, - -- sActionsMV = actionsMV, - sGlobalFMV = globalFMV, - sCxs = cxs - } - - -- Spawn a thread to handle OSC control messages - _ <- forkIO $ ctrlResponder config stream - return stream + sMapMV <- newMVar Map.empty + pMapMV <- newMVar Map.empty + 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 pMapMV globalFMV cxs) + + let stream = + Stream + { sConfig = config, + sStateMV = sMapMV, + sClockRef = clockRef, + -- sLink = abletonLink, + sListen = listen, + sPMapMV = pMapMV, + -- sActionsMV = actionsMV, + sGlobalFMV = globalFMV, + sCxs = cxs + } + + -- Spawn a thread to handle OSC control messages + _ <- forkIO $ ctrlResponder 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 index cf9112344..6db6be51c 100644 --- a/src/Sound/Tidal/Stream/Process.hs +++ b/src/Sound/Tidal/Stream/Process.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE StandaloneDeriving #-} module Sound.Tidal.Stream.Process where @@ -27,42 +27,38 @@ module Sound.Tidal.Stream.Process where along with this library. If not, see . -} -import Control.Applicative ((<|>)) -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) -import System.IO (hPutStrLn, stderr) - -import qualified Sound.Osc.Fd as O +import Control.Applicative ((<|>)) +import Control.Concurrent.MVar +import qualified Control.Exception as E +import Control.Monad (forM_, when) +import Data.Coerce (coerce) +import Data.List (sortOn) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes, fromJust, fromMaybe) +import qualified Sound.Osc.Fd as O import qualified Sound.Osc.Transport.Fd.Udp as O +import qualified Sound.Tidal.Clock as Clock +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 Sound.Tidal.Stream.Target +import Sound.Tidal.Stream.Types +import Sound.Tidal.Utils ((!!!)) +import System.IO (hPutStrLn, stderr) -import Data.List (sortOn) -import qualified Sound.Tidal.Clock as Clock -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 Sound.Tidal.Utils ((!!!)) - -import Sound.Tidal.Stream.Target -import Sound.Tidal.Stream.Types - -data ProcessedEvent = - ProcessedEvent { - peHasOnset :: Bool, - peEvent :: Event ValueMap, - peCps :: Double, - peDelta :: Link.Micros, - peCycle :: Time, - peOnWholeOrPart :: Link.Micros, +data ProcessedEvent = ProcessedEvent + { peHasOnset :: Bool, + peEvent :: Event ValueMap, + peCps :: Double, + peDelta :: Link.Micros, + peCycle :: Time, + peOnWholeOrPart :: Link.Micros, peOnWholeOrPartOsc :: O.Time, - peOnPart :: Link.Micros, - peOnPartOsc :: O.Time + peOnPart :: Link.Micros, + peOnPartOsc :: O.Time } -- | Query the current pattern (contained in argument @stream :: Stream@) @@ -78,46 +74,51 @@ data ProcessedEvent = -- 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 PlayMap -- currently playing - -> MVar (ControlPattern -> ControlPattern) -- current global fx - -> [Cx] -- target addresses - -> (Time,Time) -- current arc - -> Double -- nudge - -> Clock.ClockConfig -- config of the clock - -> Clock.ClockRef -- reference to the clock - -> (Link.SessionState, Link.SessionState) -- second session state is for keeping track of tempo changes - -> IO () -doTick stateMV playMV globalFMV cxs (st,end) nudge cconf cref (ss, temposs) = +doTick :: + MVar ValueMap -> -- pattern state + MVar PlayMap -> -- currently playing + MVar (ControlPattern -> ControlPattern) -> -- current global fx + [Cx] -> -- target addresses + (Time, Time) -> -- current arc + Double -> -- nudge + Clock.ClockConfig -> -- config of the clock + Clock.ClockRef -> -- reference to the clock + (Link.SessionState, Link.SessionState) -> -- second session state is for keeping track of tempo changes + IO () +doTick stateMV playMV globalFMV cxs (st, end) nudge cconf cref (ss, temposs) = E.handle handleException $ do modifyMVar_ stateMV $ \sMap -> do pMap <- readMVar playMV sGlobalF <- readMVar globalFMV bpm <- Clock.getTempo ss - let - patstack = sGlobalF $ playStack pMap - cps = ((Clock.beatToCycles cconf) $ fromRational 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 + let patstack = sGlobalF $ playStack pMap + cps = ((Clock.beatToCycles cconf) $ fromRational 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 cconf cref (ss, temposs) es' -- For each OSC target forM_ cxs $ \cx@(Cx target _ oscs _ _ bussesMV) -> do - busses <- mapM readMVar bussesMV - -- 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 cx latency extraLatency m) `E.catch` \(e :: E.SomeException) -> - hPutStrLn stderr $ "Failed to send. Is the '" ++ oName target ++ "' target running? " ++ show e + busses <- mapM readMVar bussesMV + -- 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 cx latency extraLatency m) `E.catch` \(e :: E.SomeException) -> + hPutStrLn stderr $ "Failed to send. Is the '" ++ oName target ++ "' target running? " ++ show e return sMap'' where handleException :: E.SomeException -> IO () @@ -129,7 +130,7 @@ doTick stateMV playMV globalFMV cxs (st,end) nudge cconf cref (ss, temposs) = processCps :: Clock.ClockConfig -> Clock.ClockRef -> (Link.SessionState, Link.SessionState) -> [Event ValueMap] -> IO [ProcessedEvent] processCps cconf cref (ss, temposs) = mapM processEvent where - processEvent :: Event ValueMap -> IO ProcessedEvent + processEvent :: Event ValueMap -> IO ProcessedEvent processEvent e = do let wope = wholeOrPart e partStartCycle = start $ part e @@ -140,9 +141,11 @@ processCps cconf cref (ss, temposs) = mapM processEvent offBeat = (Clock.cyclesToBeat cconf) (realToFrac offCycle) on <- Clock.timeAtBeat cconf ss onBeat onPart <- Clock.timeAtBeat cconf ss partStartBeat - when (eventHasOnset e) (do - let cps' = Map.lookup "cps" (value e) >>= getF - maybe (return ()) (\newCps -> Clock.setTempoCPS newCps on cconf temposs) (fmap toRational cps') + when + (eventHasOnset e) + ( do + let cps' = Map.lookup "cps" (value e) >>= getF + maybe (return ()) (\newCps -> Clock.setTempoCPS newCps on cconf temposs) (fmap toRational cps') ) off <- Clock.timeAtBeat cconf ss offBeat bpm <- Clock.getTempo ss @@ -150,155 +153,178 @@ processCps cconf cref (ss, temposs) = mapM processEvent onPartOsc <- Clock.linkToOscTime cref onPart let cps = ((Clock.beatToCycles cconf) $ fromRational bpm) / 60 let delta = off - on - return $! ProcessedEvent { - peHasOnset = eventHasOnset e, - peEvent = e, - peCps = cps, - peDelta = delta, - peCycle = onCycle, - peOnWholeOrPart = on, - peOnWholeOrPartOsc = wholeOrPartOsc, - peOnPart = onPart, - peOnPartOsc = onPartOsc - } - + return $! + ProcessedEvent + { peHasOnset = eventHasOnset e, + peEvent = e, + peCps = cps, + peDelta = delta, + peCycle = onCycle, + peOnWholeOrPart = on, + peOnWholeOrPartOsc = wholeOrPartOsc, + peOnPart = onPart, + peOnPartOsc = onPartOsc + } toOSC :: Maybe [Int] -> ProcessedEvent -> OSC -> [(Double, Bool, O.Message)] -toOSC maybeBusses 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. +toOSC maybeBusses pe osc@(OSC _ _) = + catMaybes (playmsg : busmsgs) + where + -- 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. + + (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 (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 + | Just busses <- maybeBusses, (not . null) busses = busses !!! n + | otherwise = 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 (toBus bi), toDatum v] + ) + ) + (Map.toList busmap) 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 (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 | Just busses <- maybeBusses, (not . null) busses = busses !!! n - | otherwise = 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 (toBus 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 + 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 = 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 + | 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) + 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 (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" +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 + 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 + 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) + where + active pState = + if hasSolo pMap + then psSolo pState + else not (psMute pState) hasSolo :: Map.Map k PlayState -> Bool hasSolo = (>= 1) . length . filter psSolo . Map.elems onSingleTick :: Clock.ClockConfig -> Clock.ClockRef -> MVar ValueMap -> MVar PlayMap -> MVar (ControlPattern -> ControlPattern) -> [Cx] -> ControlPattern -> IO () onSingleTick clockConfig clockRef stateMV _ globalFMV cxs pat = do - pMapMV <- newMVar $ Map.singleton "fake" - (PlayState {psPattern = pat, - psMute = False, - psSolo = False, - psHistory = [] - } - ) + pMapMV <- + newMVar $ + Map.singleton + "fake" + ( PlayState + { psPattern = pat, + psMute = False, + psSolo = False, + psHistory = [] + } + ) Clock.clockOnce (doTick stateMV pMapMV globalFMV cxs) clockConfig clockRef - -- Used for Tempo callback updatePattern :: Stream -> ID -> Time -> ControlPattern -> IO () updatePattern stream k !t pat = do @@ -306,16 +332,20 @@ updatePattern stream k !t pat = do 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) + 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) setPreviousPatternOrSilence :: MVar PlayMap -> IO () setPreviousPatternOrSilence playMV = - modifyMVar_ playMV $ return - . Map.map ( \ pMap -> case psHistory pMap of - _:p:ps -> pMap { psPattern = p, psHistory = p:ps } - _ -> pMap { psPattern = silence, psHistory = [silence] } - ) + modifyMVar_ playMV $ + return + . Map.map + ( \pMap -> case psHistory pMap of + _ : p : ps -> pMap {psPattern = p, psHistory = p : ps} + _ -> pMap {psPattern = silence, psHistory = [silence]} + ) diff --git a/src/Sound/Tidal/Stream/Target.hs b/src/Sound/Tidal/Stream/Target.hs index 27dc1e2d8..ea927266a 100644 --- a/src/Sound/Tidal/Stream/Target.hs +++ b/src/Sound/Tidal/Stream/Target.hs @@ -1,18 +1,23 @@ module Sound.Tidal.Stream.Target where -import Control.Concurrent (forkIO, forkOS, newMVar, readMVar, - swapMVar, threadDelay) -import Control.Monad (when) -import Data.Maybe (catMaybes, fromJust, isJust) -import Foreign (Word8) -import qualified Network.Socket as N -import qualified Sound.Osc.Fd as O -import qualified Sound.Osc.Time.Timeout as O +import Control.Concurrent + ( forkIO, + forkOS, + newMVar, + readMVar, + swapMVar, + threadDelay, + ) +import Control.Monad (when) +import Data.Maybe (catMaybes, fromJust, isJust) +import Foreign (Word8) +import qualified Network.Socket as N +import qualified Sound.Osc.Fd as O +import qualified Sound.Osc.Time.Timeout as O import qualified Sound.Osc.Transport.Fd.Udp as O - -import Sound.Tidal.Pattern -import Sound.Tidal.Stream.Config -import Sound.Tidal.Stream.Types +import Sound.Tidal.Pattern +import Sound.Tidal.Stream.Config +import Sound.Tidal.Stream.Types {- Target.hs - Create and send to OSC targets @@ -32,52 +37,66 @@ import Sound.Tidal.Stream.Types 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) (oPort target) - remote_bus_addr <- mapM (resolve (oAddress target)) (oBusPort target) - remote_busses <- sequence (oBusPort target >> Just (newMVar [])) - - let broadcast = if cCtrlBroadcast config then 1 else 0 - u <- O.udp_socket (\sock _ -> do N.setSocketOption sock N.Broadcast broadcast - ) (oAddress target) (oPort target) - let cx = Cx {cxUDP = u, cxAddr = remote_addr, cxBusAddr = remote_bus_addr, cxBusses = remote_busses, cxTarget = target, cxOSCs = os} - _ <- forkIO $ handshake cx config - return cx - ) oscmap +getCXs config oscmap = + mapM + ( \(target, os) -> do + remote_addr <- resolve (oAddress target) (oPort target) + remote_bus_addr <- mapM (resolve (oAddress target)) (oBusPort target) + remote_busses <- sequence (oBusPort target >> Just (newMVar [])) + + let broadcast = if cCtrlBroadcast config then 1 else 0 + u <- + O.udp_socket + ( \sock _ -> do N.setSocketOption sock N.Broadcast broadcast + ) + (oAddress target) + (oPort target) + let cx = Cx {cxUDP = u, cxAddr = remote_addr, cxBusAddr = remote_bus_addr, cxBusses = remote_busses, cxTarget = target, cxOSCs = os} + _ <- forkIO $ handshake cx config + return cx + ) + oscmap resolve :: String -> Int -> IO N.AddrInfo -resolve host port = do let hints = N.defaultHints { N.addrSocketType = N.Stream } - addr:_ <- N.getAddrInfo (Just hints) (Just host) (Just $ show port) - return addr +resolve host port = do + let hints = N.defaultHints {N.addrSocketType = N.Stream} + addr : _ <- N.getAddrInfo (Just hints) (Just host) (Just $ show port) + return addr handshake :: Cx -> Config -> IO () -handshake Cx { cxUDP = udp, cxBusses = Just bussesMV, cxAddr = addr } c = sendHandshake >> listen 0 +handshake Cx {cxUDP = udp, cxBusses = Just bussesMV, cxAddr = addr} c = sendHandshake >> listen 0 where sendHandshake :: IO () sendHandshake = O.sendTo udp (O.Packet_Message $ O.Message "/dirt/handshake" []) (N.addrAddress addr) listen :: Int -> IO () - listen waits = do ms <- recvMessagesTimeout 2 udp - if null ms - then do checkHandshake waits -- there was a timeout, check handshake - listen (waits+1) - else do mapM_ respond ms - listen 0 + listen waits = do + ms <- recvMessagesTimeout 2 udp + if null ms + then do + checkHandshake waits -- there was a timeout, check handshake + listen (waits + 1) + else do + mapM_ respond ms + listen 0 checkHandshake :: Int -> IO () - checkHandshake waits = do busses <- readMVar bussesMV - when (null busses) $ do when (waits == 0) $ verbose c $ "Waiting for SuperDirt (v.1.7.2 or higher).." - sendHandshake + checkHandshake waits = do + busses <- readMVar bussesMV + when (null busses) $ do + when (waits == 0) $ verbose c $ "Waiting for SuperDirt (v.1.7.2 or higher).." + sendHandshake respond :: O.Message -> IO () respond (O.Message "/dirt/hello" _) = sendHandshake - respond (O.Message "/dirt/handshake/reply" xs) = do prev <- swapMVar bussesMV $ bufferIndices xs - -- Only report the first time.. - when (null prev) $ verbose c $ "Connected to SuperDirt." + respond (O.Message "/dirt/handshake/reply" xs) = do + prev <- swapMVar bussesMV $ bufferIndices xs + -- Only report the first time.. + when (null prev) $ verbose c $ "Connected to SuperDirt." respond _ = return () bufferIndices :: [O.Datum] -> [Int] bufferIndices [] = [] - bufferIndices (x:xs') | x == O.AsciiString (O.ascii "&controlBusIndices") = catMaybes $ takeWhile isJust $ map O.datum_integral xs' - | otherwise = bufferIndices xs' + bufferIndices (x : xs') + | x == O.AsciiString (O.ascii "&controlBusIndices") = catMaybes $ takeWhile isJust $ map O.datum_integral xs' + | otherwise = bufferIndices xs' handshake _ _ = return () recvMessagesTimeout :: (O.Transport t) => Double -> t -> IO [O.Message] @@ -91,99 +110,118 @@ send :: Cx -> Double -> Double -> (Double, Bool, O.Message) -> IO () send cx latency extraLatency (time, isBusMsg, m) | oSchedule target == Pre BundleStamp = sendBndl isBusMsg cx $ O.Bundle timeWithLatency [m] | oSchedule target == Pre MessageStamp = sendO isBusMsg cx $ addtime m - | otherwise = do _ <- forkOS $ do now <- O.time - threadDelay $ floor $ (timeWithLatency - now) * 1000000 - sendO isBusMsg 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 + | otherwise = do + _ <- forkOS $ do + now <- O.time + threadDelay $ floor $ (timeWithLatency - now) * 1000000 + sendO isBusMsg 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 -> Cx -> O.Bundle -> IO () sendBndl isBusMsg cx bndl = O.sendTo (cxUDP cx) (O.Packet_Bundle bndl) (N.addrAddress addr) - where addr | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx - | otherwise = cxAddr cx + where + addr + | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx + | otherwise = cxAddr cx sendO :: Bool -> Cx -> O.Message -> IO () sendO isBusMsg cx msg = O.sendTo (cxUDP cx) (O.Packet_Message msg) (N.addrAddress addr) - where addr | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx - | otherwise = cxAddr cx + where + addr + | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx + | otherwise = cxAddr cx 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 - } +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 - } +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) - ] +dirtShape = + OSC "/play" $ + ArgList + [ ("cps", fDefault 0), + ("s", Nothing), + ("offset", fDefault 0), + ("begin", fDefault 0), + ("end", fDefault 1), + ("speed", fDefault 1), + ("pan", fDefault 0.5), + ("velocity", fDefault 0.5), + ("vowel", sDefault ""), + ("cutoff", fDefault 0), + ("resonance", fDefault 0), + ("accelerate", fDefault 0), + ("shape", fDefault 0), + ("kriole", iDefault 0), + ("gain", fDefault 1), + ("cut", iDefault 0), + ("delay", fDefault 0), + ("delaytime", fDefault (-1)), + ("delayfeedback", fDefault (-1)), + ("crush", fDefault 0), + ("coarse", iDefault 0), + ("hcutoff", fDefault 0), + ("hresonance", fDefault 0), + ("bandf", fDefault 0), + ("bandq", fDefault 0), + ("unit", sDefault "rate"), + ("loop", fDefault 0), + ("n", fDefault 0), + ("attack", fDefault (-1)), + ("hold", fDefault 0), + ("release", fDefault (-1)), + ("orbit", iDefault 0) -- , + -- ("id", iDefault 0) + ] sDefault :: String -> Maybe Value sDefault x = Just $ VS x + fDefault :: Double -> Maybe Value fDefault x = Just $ VF x + rDefault :: Rational -> Maybe Value rDefault x = Just $ VR x + iDefault :: Int -> Maybe Value iDefault x = Just $ VI x + bDefault :: Bool -> Maybe Value bDefault x = Just $ VB x + xDefault :: [Word8] -> Maybe Value xDefault x = Just $ VX x diff --git a/src/Sound/Tidal/Stream/Types.hs b/src/Sound/Tidal/Stream/Types.hs index 34f79f053..60dae6d81 100644 --- a/src/Sound/Tidal/Stream/Types.hs +++ b/src/Sound/Tidal/Stream/Types.hs @@ -1,72 +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 Network.Socket as N +import Control.Concurrent.MVar +import qualified Data.Map.Strict as Map +import qualified Network.Socket as N import qualified Sound.Osc.Transport.Fd.Udp as O +import qualified Sound.Tidal.Clock as Clock +import Sound.Tidal.Pattern +import Sound.Tidal.Show () +import Sound.Tidal.Stream.Config -import qualified Sound.Tidal.Clock as Clock - -import Sound.Tidal.Stream.Config +data Stream = Stream + { sConfig :: Config, + sStateMV :: MVar ValueMap, + -- sOutput :: MVar ControlPattern, + sClockRef :: Clock.ClockRef, + sListen :: Maybe O.Udp, + sPMapMV :: MVar PlayMap, + sGlobalFMV :: MVar (ControlPattern -> ControlPattern), + sCxs :: [Cx] + } -data Stream = Stream {sConfig :: Config, - 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, + cxBusses :: Maybe (MVar [Int]) + } -data Cx = Cx {cxTarget :: Target, - cxUDP :: O.Udp, - cxOSCs :: [OSC], - cxAddr :: N.AddrInfo, - cxBusAddr :: Maybe N.AddrInfo, - cxBusses :: Maybe (MVar [Int]) - } - -data StampStyle = BundleStamp - | MessageStamp +data StampStyle + = BundleStamp + | MessageStamp deriving (Eq, Show) -data Schedule = Pre StampStyle - | Live +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 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 Args + = Named {requiredArgs :: [String]} + | ArgList [(String, Maybe Value)] + deriving (Show) -data OSC = OSC {path :: String, - args :: Args - } - | OSCContext {path :: String} - deriving Show +data OSC + = OSC + { path :: String, + args :: Args + } + | OSCContext {path :: String} + deriving (Show) -data PlayState = PlayState {psPattern :: ControlPattern, - psMute :: Bool, - psSolo :: Bool, - psHistory :: [ControlPattern] - } - deriving 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 { diff --git a/src/Sound/Tidal/Stream/UI.hs b/src/Sound/Tidal/Stream/UI.hs index 3eb19ffab..3e022334c 100644 --- a/src/Sound/Tidal/Stream/UI.hs +++ b/src/Sound/Tidal/Stream/UI.hs @@ -1,20 +1,19 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} -module Sound.Tidal.Stream.UI where - -import Control.Concurrent.MVar -import qualified Control.Exception as E -import qualified Data.Map as Map -import System.IO (hPutStrLn, stderr) -import System.Random (getStdRandom, randomR) -import qualified Sound.Tidal.Clock as Clock -import Sound.Tidal.Stream.Config -import Sound.Tidal.Stream.Process -import Sound.Tidal.Stream.Types +module Sound.Tidal.Stream.UI where -import Sound.Tidal.ID -import Sound.Tidal.Pattern +import Control.Concurrent.MVar +import qualified Control.Exception as E +import qualified Data.Map as Map +import qualified Sound.Tidal.Clock as Clock +import Sound.Tidal.ID +import Sound.Tidal.Pattern +import Sound.Tidal.Stream.Config +import Sound.Tidal.Stream.Process +import Sound.Tidal.Stream.Types +import System.IO (hPutStrLn, stderr) +import System.Random (getStdRandom, randomR) streamNudgeAll :: Stream -> Double -> IO () streamNudgeAll s = Clock.setNudge (sClockRef s) @@ -32,13 +31,13 @@ streamSetBPM :: Stream -> Time -> IO () streamSetBPM s = Clock.setBPM (sClockRef s) streamGetCPS :: Stream -> IO Time -streamGetCPS s = Clock.getCPS (cClockConfig $ sConfig s)(sClockRef s) +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) +streamGetNow s = Clock.getCycleTime (cClockConfig $ sConfig s) (sClockRef s) streamEnableLink :: Stream -> IO () streamEnableLink s = Clock.enableLink (sClockRef s) @@ -47,27 +46,33 @@ 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 {psSolo = True})) = k ++ " - solo\n" - showKV True (k, _) = "(" ++ k ++ ")\n" - showKV False (k, (PlayState {psSolo = False})) = k ++ "\n" - showKV False (k, _) = "(" ++ k ++ ") - muted\n" +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" 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) + 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) -- 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 +streamOnce st p = do + i <- getStdRandom $ randomR (0, 8192) + streamFirst st $ rotL (toRational (i :: Int)) p streamFirst :: Stream -> ControlPattern -> IO () streamFirst stream pat = onSingleTick (cClockConfig $ sConfig stream) (sClockRef stream) (sStateMV stream) (sPMapMV stream) (sGlobalFMV stream) (sCxs stream) pat @@ -88,18 +93,19 @@ 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 () +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}) +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}) @@ -108,20 +114,22 @@ 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}) +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 () +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' +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 From e1eaab3fcc4420319713b821fa1a28a1ecde962b Mon Sep 17 00:00:00 2001 From: Matthew Kaney Date: Sun, 2 Feb 2025 21:34:00 -0500 Subject: [PATCH 11/12] One bit of formatting --- src/Sound/Tidal/Stream/Main.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Sound/Tidal/Stream/Main.hs b/src/Sound/Tidal/Stream/Main.hs index e53e98fb8..2cee4d1ae 100644 --- a/src/Sound/Tidal/Stream/Main.hs +++ b/src/Sound/Tidal/Stream/Main.hs @@ -4,11 +4,12 @@ import Control.Concurrent (forkIO, newMVar) import qualified Data.Map as Map import qualified Sound.Tidal.Clock as Clock import Sound.Tidal.Stream.Config - ( Config (cClockConfig, cCtrlAddr, cCtrlPort),verbose + ( Config (cClockConfig, cCtrlAddr, cCtrlPort), + verbose, ) import Sound.Tidal.Stream.Listen ( ctrlResponder, - openListener + openListener, ) import Sound.Tidal.Stream.Process (doTick) import Sound.Tidal.Stream.Target (getCXs, superdirtShape) From b61702dd6e7d38937e38edaa29ab057e08f45d87 Mon Sep 17 00:00:00 2001 From: matthewkaney Date: Mon, 3 Feb 2025 02:34:23 +0000 Subject: [PATCH 12/12] automated ormolu reformatting --- src/Sound/Tidal/Stream/Target.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Sound/Tidal/Stream/Target.hs b/src/Sound/Tidal/Stream/Target.hs index ea927266a..44035b9c3 100644 --- a/src/Sound/Tidal/Stream/Target.hs +++ b/src/Sound/Tidal/Stream/Target.hs @@ -48,8 +48,7 @@ getCXs config oscmap = let broadcast = if cCtrlBroadcast config then 1 else 0 u <- O.udp_socket - ( \sock _ -> do N.setSocketOption sock N.Broadcast broadcast - ) + (\sock _ -> do N.setSocketOption sock N.Broadcast broadcast) (oAddress target) (oPort target) let cx = Cx {cxUDP = u, cxAddr = remote_addr, cxBusAddr = remote_bus_addr, cxBusses = remote_busses, cxTarget = target, cxOSCs = os}