Skip to content
This repository was archived by the owner on Jun 13, 2025. It is now read-only.

Commit c3d9dd3

Browse files
matthewkaneymatthewkaney
committed
Re-implement per-context busses in reorganized Stream code
1 parent 4691224 commit c3d9dd3

File tree

7 files changed

+87
-94
lines changed

7 files changed

+87
-94
lines changed

‎src/Sound/Tidal/Stream/Config.hs‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,7 @@
11
module Sound.Tidal.Stream.Config where
22

3+
import Control.Monad (when)
4+
35
import qualified Sound.Tidal.Clock as Clock
46

57
{-
@@ -42,3 +44,6 @@ defaultConfig = Config {cCtrlListen = True,
4244
cVerbose = True,
4345
cClockConfig = Clock.defaultConfig
4446
}
47+
48+
verbose :: Config -> String -> IO ()
49+
verbose c s = when (cVerbose c) $ putStrLn s

‎src/Sound/Tidal/Stream/Listen.hs‎

Lines changed: 9 additions & 31 deletions
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,11 @@
11
module Sound.Tidal.Stream.Listen where
22

3-
import Data.Maybe (fromJust, catMaybes, isJust)
3+
import Data.Maybe (fromJust)
44
import Control.Concurrent.MVar
55
import Control.Monad (when)
66
import System.IO (hPutStrLn, stderr)
77
import qualified Data.Map as Map
88
import qualified Sound.Osc.Fd as O
9-
import qualified Sound.Osc.Time.Timeout as O
109
import qualified Network.Socket as N
1110
import qualified Control.Exception as E
1211

@@ -50,29 +49,14 @@ openListener c
5049
catchAny = E.catch
5150

5251
-- Listen to and act on OSC control messages
53-
ctrlResponder :: Int -> Config -> Stream -> IO ()
54-
ctrlResponder waits c (stream@(Stream {sListen = Just sock}))
55-
= do ms <- recvMessagesTimeout 2 sock
56-
if (null ms)
57-
then do checkHandshake -- there was a timeout, check handshake
58-
ctrlResponder (waits+1) c stream
59-
else do mapM_ act ms
60-
ctrlResponder 0 c stream
61-
where
62-
checkHandshake = do busses <- readMVar (sBusses stream)
63-
when (null busses) $ do when (waits == 0) $ verbose c $ "Waiting for SuperDirt (v.1.7.2 or higher).."
64-
sendHandshakes stream
65-
66-
act (O.Message "/dirt/hello" _) = sendHandshakes stream
67-
act (O.Message "/dirt/handshake/reply" xs) = do prev <- swapMVar (sBusses stream) $ bufferIndices xs
68-
-- Only report the first time..
69-
when (null prev) $ verbose c $ "Connected to SuperDirt."
70-
return ()
71-
where
72-
bufferIndices [] = []
73-
bufferIndices (x:xs') | x == (O.AsciiString $ O.ascii "&controlBusIndices") = catMaybes $ takeWhile isJust $ map O.datum_integral xs'
74-
| otherwise = bufferIndices xs'
52+
ctrlResponder :: Config -> Stream -> IO ()
53+
ctrlResponder _ (stream@(Stream {sListen = Just sock})) = loop
54+
where
55+
loop :: IO ()
56+
loop = do O.recvMessages sock >>= mapM_ act
57+
loop
7558
-- External controller commands
59+
act :: O.Message -> IO ()
7660
act (O.Message "/ctrl" (O.Int32 k:v:[]))
7761
= act (O.Message "/ctrl" [O.string $ show k,v])
7862
act (O.Message "/ctrl" (O.AsciiString k:v@(O.Float _):[]))
@@ -109,10 +93,4 @@ ctrlResponder waits c (stream@(Stream {sListen = Just sock}))
10993
withID (O.AsciiString k) func = func $ (ID . O.ascii_to_string) k
11094
withID (O.Int32 k) func = func $ (ID . show) k
11195
withID _ _ = return ()
112-
ctrlResponder _ _ _ = return ()
113-
114-
verbose :: Config -> String -> IO ()
115-
verbose c s = when (cVerbose c) $ putStrLn s
116-
117-
recvMessagesTimeout :: (O.Transport t) => Double -> t -> IO [O.Message]
118-
recvMessagesTimeout n sock = fmap (maybe [] O.packetMessages) $ O.recvPacketTimeout n sock
96+
ctrlResponder _ _ = return ()

‎src/Sound/Tidal/Stream/Main.hs‎

Lines changed: 2 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -13,7 +13,6 @@ import Sound.Tidal.Stream.Types
1313
import Sound.Tidal.Stream.Listen
1414
import Sound.Tidal.Stream.Target
1515
import Sound.Tidal.Stream.Process
16-
import Sound.Tidal.Stream.UI
1716

1817
{-
1918
Main.hs - Start tidals stream, listen and act on incoming messages
@@ -45,7 +44,6 @@ startStream :: Config -> [(Target, [OSC])] -> IO Stream
4544
startStream config oscmap = do
4645
sMapMV <- newMVar Map.empty
4746
pMapMV <- newMVar Map.empty
48-
bussesMV <- newMVar []
4947
globalFMV <- newMVar id
5048

5149
tidal_status_string >>= verbose config
@@ -54,10 +52,9 @@ startStream config oscmap = do
5452

5553
cxs <- getCXs config oscmap
5654

57-
clockRef <- Clock.clocked (cClockConfig config) (doTick sMapMV bussesMV pMapMV globalFMV cxs listen)
55+
clockRef <- Clock.clocked (cClockConfig config) (doTick sMapMV pMapMV globalFMV cxs)
5856

5957
let stream = Stream {sConfig = config,
60-
sBusses = bussesMV,
6158
sStateMV = sMapMV,
6259
sClockRef = clockRef,
6360
-- sLink = abletonLink,
@@ -68,10 +65,8 @@ startStream config oscmap = do
6865
sCxs = cxs
6966
}
7067

71-
sendHandshakes stream
72-
7368
-- Spawn a thread to handle OSC control messages
74-
_ <- forkIO $ ctrlResponder 0 config stream
69+
_ <- forkIO $ ctrlResponder config stream
7570
return stream
7671

7772
startMulti :: [Target] -> Config -> IO ()

‎src/Sound/Tidal/Stream/Process.hs‎

Lines changed: 11 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -76,23 +76,20 @@ data ProcessedEvent =
7676
-- because the likely reason is that something is wrong with the current pattern.
7777

7878
doTick :: MVar ValueMap -- pattern state
79-
-> MVar [Int] -- busses
8079
-> MVar PlayMap -- currently playing
8180
-> MVar (ControlPattern -> ControlPattern) -- current global fx
8281
-> [Cx] -- target addresses
83-
-> Maybe O.Udp -- network socket
8482
-> (Time,Time) -- current arc
8583
-> Double -- nudge
8684
-> Clock.LinkOperations -- ableton link operations
8785
-> IO ()
88-
doTick stateMV busMV playMV globalFMV cxs listen (st,end) nudge ops =
86+
doTick stateMV playMV globalFMV cxs (st,end) nudge ops =
8987
E.handle (\ (e :: E.SomeException) -> do
9088
hPutStrLn stderr $ "Failed to Stream.doTick: " ++ show e
9189
hPutStrLn stderr $ "Return to previous pattern."
9290
setPreviousPatternOrSilence playMV) (do
9391
sMap <- takeMVar stateMV
9492
pMap <- readMVar playMV
95-
busses <- readMVar busMV
9693
sGlobalF <- readMVar globalFMV
9794
bpm <- (Clock.getTempo ops)
9895
let
@@ -109,13 +106,14 @@ doTick stateMV busMV playMV globalFMV cxs listen (st,end) nudge ops =
109106
(sMap'', es') = resolveState sMap' es
110107
tes <- processCps ops es'
111108
-- For each OSC target
112-
forM_ cxs $ \cx@(Cx target _ oscs _ _) -> do
109+
forM_ cxs $ \cx@(Cx target _ oscs _ _ bussesMV) -> do
110+
busses <- mapM readMVar bussesMV
113111
-- Latency is configurable per target.
114112
-- Latency is only used when sending events live.
115113
let latency = oLatency target
116114
ms = concatMap (\e -> concatMap (toOSC busses e) oscs) tes
117115
-- send the events to the OSC target
118-
forM_ ms $ \m -> (send listen cx latency extraLatency m) `E.catch` \(e :: E.SomeException) ->
116+
forM_ ms $ \m -> (send cx latency extraLatency m) `E.catch` \(e :: E.SomeException) ->
119117
hPutStrLn stderr $ "Failed to send. Is the '" ++ oName target ++ "' target running? " ++ show e
120118
putMVar stateMV sMap'')
121119

@@ -154,8 +152,8 @@ processCps ops = mapM processEvent
154152
}
155153

156154

157-
toOSC :: [Int] -> ProcessedEvent -> OSC -> [(Double, Bool, O.Message)]
158-
toOSC busses pe osc@(OSC _ _)
155+
toOSC :: Maybe [Int] -> ProcessedEvent -> OSC -> [(Double, Bool, O.Message)]
156+
toOSC maybeBusses pe osc@(OSC _ _)
159157
= catMaybes (playmsg:busmsgs)
160158
-- playmap is a ValueMap where the keys don't start with ^ and are not ""
161159
-- busmap is a ValueMap containing the rest of the keys from the event value
@@ -190,8 +188,8 @@ toOSC busses pe osc@(OSC _ _)
190188
O.Message mungedPath vs
191189
)
192190
| otherwise = Nothing
193-
toBus n | null busses = n
194-
| otherwise = busses !!! n
191+
toBus n | Just busses <- maybeBusses, (not . null) busses = busses !!! n
192+
| otherwise = n
195193
busmsgs = map
196194
(\(('^':k), (VI b)) -> do v <- Map.lookup k playmap
197195
return $ (tsPart,
@@ -282,8 +280,8 @@ hasSolo = (>= 1) . length . filter solo . Map.elems
282280
-- However, since the full arc is processed at once and since Link does not support
283281
-- scheduling, tempo change may affect scheduling of events that happen earlier
284282
-- in the normal stream (the one handled by onTick).
285-
onSingleTick :: Config -> Clock.ClockRef -> MVar ValueMap -> MVar [Int] -> MVar PlayMap -> MVar (ControlPattern -> ControlPattern) -> [Cx] -> Maybe O.Udp -> ControlPattern -> IO ()
286-
onSingleTick config clockRef stateMV busMV _ globalFMV cxs listen pat = do
283+
onSingleTick :: Config -> Clock.ClockRef -> MVar ValueMap -> MVar PlayMap -> MVar (ControlPattern -> ControlPattern) -> [Cx] -> ControlPattern -> IO ()
284+
onSingleTick config clockRef stateMV _ globalFMV cxs pat = do
287285
ops <- Clock.getZeroedLinkOperations (cClockConfig config) clockRef
288286
pMapMV <- newMVar $ Map.singleton "fake"
289287
(PlayState {pattern = pat,
@@ -293,7 +291,7 @@ onSingleTick config clockRef stateMV busMV _ globalFMV cxs listen pat = do
293291
}
294292
)
295293
-- The nowArc is a full cycle
296-
doTick stateMV busMV pMapMV globalFMV cxs listen (0,1) 0 ops
294+
doTick stateMV pMapMV globalFMV cxs (0,1) 0 ops
297295

298296

299297

‎src/Sound/Tidal/Stream/Target.hs‎

Lines changed: 56 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,11 @@
11
module Sound.Tidal.Stream.Target where
22

33
import qualified Sound.Osc.Fd as O
4+
import qualified Sound.Osc.Time.Timeout as O
45
import qualified Network.Socket as N
5-
import Data.Maybe (fromJust, isJust)
6-
import Control.Concurrent (forkOS, threadDelay)
6+
import Data.Maybe (fromJust, isJust, catMaybes)
7+
import Control.Concurrent (newMVar, readMVar, swapMVar, forkIO, forkOS, threadDelay)
8+
import Control.Monad (when)
79
import Foreign (Word8)
810

911
import Sound.Tidal.Pattern
@@ -31,33 +33,65 @@ import Sound.Tidal.Stream.Config
3133

3234
getCXs :: Config -> [(Target, [OSC])] -> IO [Cx]
3335
getCXs config oscmap = mapM (\(target, os) -> do
34-
remote_addr <- resolve (oAddress target) (show $ oPort target)
35-
remote_bus_addr <- if isJust $ oBusPort target
36-
then Just <$> resolve (oAddress target) (show $ fromJust $ oBusPort target)
37-
else return Nothing
36+
remote_addr <- resolve (oAddress target) (oPort target)
37+
remote_bus_addr <- mapM (resolve (oAddress target)) (oBusPort target)
38+
remote_busses <- sequence (oBusPort target >> Just (newMVar []))
39+
3840
let broadcast = if cCtrlBroadcast config then 1 else 0
39-
u <- O.udp_socket (\sock sockaddr -> do N.setSocketOption sock N.Broadcast broadcast
40-
N.connect sock sockaddr
41+
u <- O.udp_socket (\sock _ -> do N.setSocketOption sock N.Broadcast broadcast
4142
) (oAddress target) (oPort target)
42-
return $ Cx {cxUDP = u, cxAddr = remote_addr, cxBusAddr = remote_bus_addr, cxTarget = target, cxOSCs = os}
43+
let cx = Cx {cxUDP = u, cxAddr = remote_addr, cxBusAddr = remote_bus_addr, cxBusses = remote_busses, cxTarget = target, cxOSCs = os}
44+
_ <- forkIO $ handshake cx config
45+
return cx
4346
) oscmap
4447

45-
resolve :: String -> String -> IO N.AddrInfo
48+
resolve :: String -> Int -> IO N.AddrInfo
4649
resolve host port = do let hints = N.defaultHints { N.addrSocketType = N.Stream }
47-
addr:_ <- N.getAddrInfo (Just hints) (Just host) (Just port)
50+
addr:_ <- N.getAddrInfo (Just hints) (Just host) (Just $ show port)
4851
return addr
4952

53+
handshake :: Cx -> Config -> IO ()
54+
handshake Cx { cxUDP = udp, cxBusses = Just bussesMV, cxAddr = addr } c = sendHandshake >> listen 0
55+
where
56+
sendHandshake :: IO ()
57+
sendHandshake = O.sendTo udp (O.Packet_Message $ O.Message "/dirt/handshake" []) (N.addrAddress addr)
58+
listen :: Int -> IO ()
59+
listen waits = do ms <- recvMessagesTimeout 2 udp
60+
if null ms
61+
then do checkHandshake waits -- there was a timeout, check handshake
62+
listen (waits+1)
63+
else do mapM_ respond ms
64+
listen 0
65+
checkHandshake :: Int -> IO ()
66+
checkHandshake waits = do busses <- readMVar bussesMV
67+
when (null busses) $ do when (waits == 0) $ verbose c $ "Waiting for SuperDirt (v.1.7.2 or higher).."
68+
sendHandshake
69+
respond :: O.Message -> IO ()
70+
respond (O.Message "/dirt/hello" _) = sendHandshake
71+
respond (O.Message "/dirt/handshake/reply" xs) = do prev <- swapMVar bussesMV $ bufferIndices xs
72+
-- Only report the first time..
73+
when (null prev) $ verbose c $ "Connected to SuperDirt."
74+
respond _ = return ()
75+
bufferIndices :: [O.Datum] -> [Int]
76+
bufferIndices [] = []
77+
bufferIndices (x:xs') | x == O.AsciiString (O.ascii "&controlBusIndices") = catMaybes $ takeWhile isJust $ map O.datum_integral xs'
78+
| otherwise = bufferIndices xs'
79+
handshake _ _ = return ()
80+
81+
recvMessagesTimeout :: (O.Transport t) => Double -> t -> IO [O.Message]
82+
recvMessagesTimeout n sock = fmap (maybe [] O.packetMessages) $ O.recvPacketTimeout n sock
83+
5084
-- send has three modes:
5185
-- Send events early using timestamp in the OSC bundle - used by Superdirt
5286
-- Send events early by adding timestamp to the OSC message - used by Dirt
5387
-- Send events live by delaying the thread
54-
send :: Maybe O.Udp -> Cx -> Double -> Double -> (Double, Bool, O.Message) -> IO ()
55-
send listen cx latency extraLatency (time, isBusMsg, m)
56-
| oSchedule target == Pre BundleStamp = sendBndl isBusMsg listen cx $ O.Bundle timeWithLatency [m]
57-
| oSchedule target == Pre MessageStamp = sendO isBusMsg listen cx $ addtime m
88+
send :: Cx -> Double -> Double -> (Double, Bool, O.Message) -> IO ()
89+
send cx latency extraLatency (time, isBusMsg, m)
90+
| oSchedule target == Pre BundleStamp = sendBndl isBusMsg cx $ O.Bundle timeWithLatency [m]
91+
| oSchedule target == Pre MessageStamp = sendO isBusMsg cx $ addtime m
5892
| otherwise = do _ <- forkOS $ do now <- O.time
5993
threadDelay $ floor $ (timeWithLatency - now) * 1000000
60-
sendO isBusMsg listen cx m
94+
sendO isBusMsg cx m
6195
return ()
6296
where addtime (O.Message mpath params) = O.Message mpath ((O.int32 sec):((O.int32 usec):params))
6397
ut = O.ntpr_to_posix timeWithLatency
@@ -68,18 +102,15 @@ send listen cx latency extraLatency (time, isBusMsg, m)
68102
target = cxTarget cx
69103
timeWithLatency = time - latency + extraLatency
70104

71-
sendBndl :: Bool -> (Maybe O.Udp) -> Cx -> O.Bundle -> IO ()
72-
sendBndl isBusMsg (Just listen) cx bndl = O.sendTo listen (O.Packet_Bundle bndl) (N.addrAddress addr)
105+
sendBndl :: Bool -> Cx -> O.Bundle -> IO ()
106+
sendBndl isBusMsg cx bndl = O.sendTo (cxUDP cx) (O.Packet_Bundle bndl) (N.addrAddress addr)
73107
where addr | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx
74108
| otherwise = cxAddr cx
75-
sendBndl _ Nothing cx bndl = O.sendBundle (cxUDP cx) bndl
76-
77-
sendO :: Bool -> (Maybe O.Udp) -> Cx -> O.Message -> IO ()
78-
sendO isBusMsg (Just listen) cx msg = O.sendTo listen (O.Packet_Message msg) (N.addrAddress addr)
79-
where addr | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx
80-
| otherwise = cxAddr cx
81-
sendO _ Nothing cx msg = O.sendMessage (cxUDP cx) msg
82109

110+
sendO :: Bool -> Cx -> O.Message -> IO ()
111+
sendO isBusMsg cx msg = O.sendTo (cxUDP cx) (O.Packet_Message msg) (N.addrAddress addr)
112+
where addr | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx
113+
| otherwise = cxAddr cx
83114

84115
superdirtTarget :: Target
85116
superdirtTarget = Target {oName = "SuperDirt",

‎src/Sound/Tidal/Stream/Types.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -13,7 +13,6 @@ import qualified Sound.Tidal.Clock as Clock
1313
import Sound.Tidal.Stream.Config
1414

1515
data Stream = Stream {sConfig :: Config,
16-
sBusses :: MVar [Int],
1716
sStateMV :: MVar ValueMap,
1817
-- sOutput :: MVar ControlPattern,
1918
sClockRef :: Clock.ClockRef,
@@ -27,7 +26,8 @@ data Cx = Cx {cxTarget :: Target,
2726
cxUDP :: O.Udp,
2827
cxOSCs :: [OSC],
2928
cxAddr :: N.AddrInfo,
30-
cxBusAddr :: Maybe N.AddrInfo
29+
cxBusAddr :: Maybe N.AddrInfo,
30+
cxBusses :: Maybe (MVar [Int])
3131
}
3232

3333
data StampStyle = BundleStamp

‎src/Sound/Tidal/Stream/UI.hs‎

Lines changed: 2 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -1,19 +1,16 @@
11
{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
22
module Sound.Tidal.Stream.UI where
33

4-
import Data.Maybe (isJust)
54
import qualified Data.Map as Map
65
import qualified Control.Exception as E
76
import Control.Concurrent.MVar
87
import System.IO (hPutStrLn, stderr)
98
import System.Random (getStdRandom, randomR)
10-
import qualified Sound.Osc.Fd as O
119

1210
import qualified Sound.Tidal.Clock as Clock
1311
import Sound.Tidal.Stream.Types
1412
import Sound.Tidal.Stream.Config
1513
import Sound.Tidal.Stream.Process
16-
import Sound.Tidal.Stream.Target
1714

1815
import Sound.Tidal.Pattern
1916
import Sound.Tidal.ID
@@ -74,7 +71,7 @@ streamOnce st p = do i <- getStdRandom $ randomR (0, 8192)
7471
streamFirst st $ rotL (toRational (i :: Int)) p
7572

7673
streamFirst :: Stream -> ControlPattern -> IO ()
77-
streamFirst stream pat = onSingleTick (sConfig stream) (sClockRef stream) (sStateMV stream) (sBusses stream) (sPMapMV stream) (sGlobalFMV stream) (sCxs stream) (sListen stream) pat
74+
streamFirst stream pat = onSingleTick (sConfig stream) (sClockRef stream) (sStateMV stream) (sPMapMV stream) (sGlobalFMV stream) (sCxs stream) pat
7875

7976
streamMute :: Stream -> ID -> IO ()
8077
streamMute s k = withPatIds s [k] (\x -> x {mute = True})
@@ -140,15 +137,4 @@ streamSetB :: Stream -> String -> Pattern Bool -> IO ()
140137
streamSetB = streamSet
141138

142139
streamSetR :: Stream -> String -> Pattern Rational -> IO ()
143-
streamSetR = streamSet
144-
145-
-- It only really works to handshake with one target at the moment..
146-
sendHandshakes :: Stream -> IO ()
147-
sendHandshakes stream = mapM_ sendHandshake $ filter (oHandshake . cxTarget) (sCxs stream)
148-
where sendHandshake cx = if (isJust $ sListen stream)
149-
then
150-
do -- send it _from_ the udp socket we're listening to, so the
151-
-- replies go back there
152-
sendO False (sListen stream) cx $ O.Message "/dirt/handshake" []
153-
else
154-
hPutStrLn stderr "Can't handshake with SuperCollider without control port."
140+
streamSetR = streamSet

0 commit comments

Comments
 (0)