{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, FlexibleContexts, ScopedTypeVariables, BangPatterns #-}
{-# OPTIONS_GHC -fno-warn-missing-fields #-}
{-# language DeriveGeneric, StandaloneDeriving #-}

module Sound.Tidal.Stream (module Sound.Tidal.Stream) where

{-
    Stream.hs - Tidal's thingie for turning patterns into OSC streams
    Copyright (C) 2020, Alex McLean and contributors

    This library is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this library.  If not, see <http://www.gnu.org/licenses/>.
-}

import           Control.Applicative ((<|>))
import           Control.Concurrent.MVar
import           Control.Concurrent
import           Control.Monad (forM_, when)
import Data.Coerce (coerce)
import qualified Data.Map.Strict as Map
import           Data.Maybe (fromJust, fromMaybe, catMaybes, isJust)
import qualified Control.Exception as E
import Foreign
import Foreign.C.Types
import           System.IO (hPutStrLn, stderr)

import qualified Sound.OSC.FD as O
import qualified Network.Socket          as N

import           Sound.Tidal.Config
import           Sound.Tidal.Core (stack, silence, (#))
import           Sound.Tidal.ID
import qualified Sound.Tidal.Link as Link
import           Sound.Tidal.Params (pS)
import           Sound.Tidal.Pattern
import qualified Sound.Tidal.Tempo as T
import           Sound.Tidal.Utils ((!!!))
-- import qualified Sound.OSC.Datum as O
import           Data.List (sortOn)
import           System.Random (getStdRandom, randomR)
import           Sound.Tidal.Show ()

import           Sound.Tidal.Version

import Sound.Tidal.StreamTypes as Sound.Tidal.Stream

data Stream = Stream {Stream -> Config
sConfig :: Config,
                      Stream -> MVar [Int]
sBusses :: MVar [Int],
                      Stream -> MVar ValueMap
sStateMV :: MVar ValueMap,
                      -- sOutput :: MVar ControlPattern,
                      Stream -> AbletonLink
sLink :: Link.AbletonLink,
                      Stream -> Maybe UDP
sListen :: Maybe O.UDP,
                      Stream -> MVar PlayMap
sPMapMV :: MVar PlayMap,
                      Stream -> MVar [TempoAction]
sActionsMV :: MVar [T.TempoAction],
                      Stream -> MVar (ControlPattern -> ControlPattern)
sGlobalFMV :: MVar (ControlPattern -> ControlPattern),
                      Stream -> [Cx]
sCxs :: [Cx]
                     }

data Cx = Cx {Cx -> Target
cxTarget :: Target,
              Cx -> UDP
cxUDP :: O.UDP,
              Cx -> [OSC]
cxOSCs :: [OSC],
              Cx -> AddrInfo
cxAddr :: N.AddrInfo,
              Cx -> Maybe AddrInfo
cxBusAddr :: Maybe N.AddrInfo
             }
  deriving (Int -> Cx -> ShowS
[Cx] -> ShowS
Cx -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Cx] -> ShowS
$cshowList :: [Cx] -> ShowS
show :: Cx -> String
$cshow :: Cx -> String
showsPrec :: Int -> Cx -> ShowS
$cshowsPrec :: Int -> Cx -> ShowS
Show)

data StampStyle = BundleStamp
                | MessageStamp
  deriving (StampStyle -> StampStyle -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StampStyle -> StampStyle -> Bool
$c/= :: StampStyle -> StampStyle -> Bool
== :: StampStyle -> StampStyle -> Bool
$c== :: StampStyle -> StampStyle -> Bool
Eq, Int -> StampStyle -> ShowS
[StampStyle] -> ShowS
StampStyle -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StampStyle] -> ShowS
$cshowList :: [StampStyle] -> ShowS
show :: StampStyle -> String
$cshow :: StampStyle -> String
showsPrec :: Int -> StampStyle -> ShowS
$cshowsPrec :: Int -> StampStyle -> ShowS
Show)

data Schedule = Pre StampStyle
              | Live
  deriving (Schedule -> Schedule -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Schedule -> Schedule -> Bool
$c/= :: Schedule -> Schedule -> Bool
== :: Schedule -> Schedule -> Bool
$c== :: Schedule -> Schedule -> Bool
Eq, Int -> Schedule -> ShowS
[Schedule] -> ShowS
Schedule -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Schedule] -> ShowS
$cshowList :: [Schedule] -> ShowS
show :: Schedule -> String
$cshow :: Schedule -> String
showsPrec :: Int -> Schedule -> ShowS
$cshowsPrec :: Int -> Schedule -> ShowS
Show)

data Target = Target {Target -> String
oName :: String,
                      Target -> String
oAddress :: String,
                      Target -> Int
oPort :: Int,
                      Target -> Maybe Int
oBusPort :: Maybe Int,
                      Target -> Double
oLatency :: Double,
                      Target -> Maybe Arc
oWindow :: Maybe Arc,
                      Target -> Schedule
oSchedule :: Schedule,
                      Target -> Bool
oHandshake :: Bool
                     }
                 deriving Int -> Target -> ShowS
[Target] -> ShowS
Target -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Target] -> ShowS
$cshowList :: [Target] -> ShowS
show :: Target -> String
$cshow :: Target -> String
showsPrec :: Int -> Target -> ShowS
$cshowsPrec :: Int -> Target -> ShowS
Show

data Args = Named {Args -> [String]
requiredArgs :: [String]}
          | ArgList [(String, Maybe Value)]
         deriving Int -> Args -> ShowS
[Args] -> ShowS
Args -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Args] -> ShowS
$cshowList :: [Args] -> ShowS
show :: Args -> String
$cshow :: Args -> String
showsPrec :: Int -> Args -> ShowS
$cshowsPrec :: Int -> Args -> ShowS
Show

data OSC = OSC {OSC -> String
path :: String,
                OSC -> Args
args :: Args
               }
         | OSCContext {path :: String}
         deriving Int -> OSC -> ShowS
[OSC] -> ShowS
OSC -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OSC] -> ShowS
$cshowList :: [OSC] -> ShowS
show :: OSC -> String
$cshow :: OSC -> String
showsPrec :: Int -> OSC -> ShowS
$cshowsPrec :: Int -> OSC -> ShowS
Show

data ProcessedEvent =
  ProcessedEvent {
    ProcessedEvent -> Bool
peHasOnset :: Bool,
    ProcessedEvent -> Event ValueMap
peEvent :: Event ValueMap,
    ProcessedEvent -> Beat
peCps :: Link.BPM,
    ProcessedEvent -> Micros
peDelta :: Link.Micros,
    ProcessedEvent -> Rational
peCycle :: Time,
    ProcessedEvent -> Micros
peOnWholeOrPart :: Link.Micros,
    ProcessedEvent -> Double
peOnWholeOrPartOsc :: O.Time,
    ProcessedEvent -> Micros
peOnPart :: Link.Micros,
    ProcessedEvent -> Double
peOnPartOsc :: O.Time
  }

sDefault :: String -> Maybe Value
sDefault :: String -> Maybe Value
sDefault String
x = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> Value
VS String
x
fDefault :: Double -> Maybe Value
fDefault :: Double -> Maybe Value
fDefault Double
x = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Double -> Value
VF Double
x
rDefault :: Rational -> Maybe Value
rDefault :: Rational -> Maybe Value
rDefault Rational
x = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Rational -> Value
VR Rational
x
iDefault :: Int -> Maybe Value
iDefault :: Int -> Maybe Value
iDefault Int
x = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> Value
VI Int
x
bDefault :: Bool -> Maybe Value
bDefault :: Bool -> Maybe Value
bDefault Bool
x = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Bool -> Value
VB Bool
x
xDefault :: [Word8] -> Maybe Value
xDefault :: [Word8] -> Maybe Value
xDefault [Word8]
x = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Word8] -> Value
VX [Word8]
x

required :: Maybe Value
required :: Maybe Value
required = forall a. Maybe a
Nothing

superdirtTarget :: Target
superdirtTarget :: Target
superdirtTarget = Target {oName :: String
oName = String
"SuperDirt",
                          oAddress :: String
oAddress = String
"127.0.0.1",
                          oPort :: Int
oPort = Int
57120,
                          oBusPort :: Maybe Int
oBusPort = forall a. a -> Maybe a
Just Int
57110,
                          oLatency :: Double
oLatency = Double
0.2,
                          oWindow :: Maybe Arc
oWindow = forall a. Maybe a
Nothing,
                          oSchedule :: Schedule
oSchedule = StampStyle -> Schedule
Pre StampStyle
BundleStamp,
                          oHandshake :: Bool
oHandshake = Bool
True
                         }

superdirtShape :: OSC
superdirtShape :: OSC
superdirtShape = String -> Args -> OSC
OSC String
"/dirt/play" forall a b. (a -> b) -> a -> b
$ Named {requiredArgs :: [String]
requiredArgs = [String
"s"]}

dirtTarget :: Target
dirtTarget :: Target
dirtTarget = Target {oName :: String
oName = String
"Dirt",
                     oAddress :: String
oAddress = String
"127.0.0.1",
                     oPort :: Int
oPort = Int
7771,
                     oBusPort :: Maybe Int
oBusPort = forall a. Maybe a
Nothing,
                     oLatency :: Double
oLatency = Double
0.02,
                     oWindow :: Maybe Arc
oWindow = forall a. Maybe a
Nothing,
                     oSchedule :: Schedule
oSchedule = StampStyle -> Schedule
Pre StampStyle
MessageStamp,
                     oHandshake :: Bool
oHandshake = Bool
False
                    }

dirtShape :: OSC
dirtShape :: OSC
dirtShape = String -> Args -> OSC
OSC String
"/play" forall a b. (a -> b) -> a -> b
$ [(String, Maybe Value)] -> Args
ArgList [(String
"cps", Double -> Maybe Value
fDefault Double
0),
                                   (String
"s", Maybe Value
required),
                                   (String
"offset", Double -> Maybe Value
fDefault Double
0),
                                   (String
"begin", Double -> Maybe Value
fDefault Double
0),
                                   (String
"end", Double -> Maybe Value
fDefault Double
1),
                                   (String
"speed", Double -> Maybe Value
fDefault Double
1),
                                   (String
"pan", Double -> Maybe Value
fDefault Double
0.5),
                                   (String
"velocity", Double -> Maybe Value
fDefault Double
0.5),
                                   (String
"vowel", String -> Maybe Value
sDefault String
""),
                                   (String
"cutoff", Double -> Maybe Value
fDefault Double
0),
                                   (String
"resonance", Double -> Maybe Value
fDefault Double
0),
                                   (String
"accelerate", Double -> Maybe Value
fDefault Double
0),
                                   (String
"shape", Double -> Maybe Value
fDefault Double
0),
                                   (String
"kriole", Int -> Maybe Value
iDefault Int
0),
                                   (String
"gain", Double -> Maybe Value
fDefault Double
1),
                                   (String
"cut", Int -> Maybe Value
iDefault Int
0),
                                   (String
"delay", Double -> Maybe Value
fDefault Double
0),
                                   (String
"delaytime", Double -> Maybe Value
fDefault (-Double
1)),
                                   (String
"delayfeedback", Double -> Maybe Value
fDefault (-Double
1)),
                                   (String
"crush", Double -> Maybe Value
fDefault Double
0),
                                   (String
"coarse", Int -> Maybe Value
iDefault Int
0),
                                   (String
"hcutoff", Double -> Maybe Value
fDefault Double
0),
                                   (String
"hresonance", Double -> Maybe Value
fDefault Double
0),
                                   (String
"bandf", Double -> Maybe Value
fDefault Double
0),
                                   (String
"bandq", Double -> Maybe Value
fDefault Double
0),
                                   (String
"unit", String -> Maybe Value
sDefault String
"rate"),
                                   (String
"loop", Double -> Maybe Value
fDefault Double
0),
                                   (String
"n", Double -> Maybe Value
fDefault Double
0),
                                   (String
"attack", Double -> Maybe Value
fDefault (-Double
1)),
                                   (String
"hold", Double -> Maybe Value
fDefault Double
0),
                                   (String
"release", Double -> Maybe Value
fDefault (-Double
1)),
                                   (String
"orbit", Int -> Maybe Value
iDefault Int
0) -- ,
                                   -- ("id", iDefault 0)
                                  ]

defaultCps :: O.Time
defaultCps :: Double
defaultCps = Double
0.5625

-- Start an instance of Tidal
-- Spawns a thread within Tempo that acts as the clock
-- Spawns a thread that listens to and acts on OSC control messages
startStream :: Config -> [(Target, [OSC])] -> IO Stream
startStream :: Config -> [(Target, [OSC])] -> IO Stream
startStream Config
config [(Target, [OSC])]
oscmap 
  = do MVar ValueMap
sMapMV <- forall a. a -> IO (MVar a)
newMVar forall k a. Map k a
Map.empty
       MVar PlayMap
pMapMV <- forall a. a -> IO (MVar a)
newMVar forall k a. Map k a
Map.empty
       MVar [Int]
bussesMV <- forall a. a -> IO (MVar a)
newMVar []
       MVar (ControlPattern -> ControlPattern)
globalFMV <- forall a. a -> IO (MVar a)
newMVar forall a. a -> a
id
       MVar [TempoAction]
actionsMV <- forall a. IO (MVar a)
newEmptyMVar

       IO String
tidal_status_string forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Config -> String -> IO ()
verbose Config
config
       Config -> String -> IO ()
verbose Config
config forall a b. (a -> b) -> a -> b
$ String
"Listening for external controls on " forall a. [a] -> [a] -> [a]
++ Config -> String
cCtrlAddr Config
config forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Config -> Int
cCtrlPort Config
config)
       Maybe UDP
listen <- Config -> IO (Maybe UDP)
openListener Config
config

       [Cx]
cxs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Target
target, [OSC]
os) -> do AddrInfo
remote_addr <- String -> String -> IO AddrInfo
resolve (Target -> String
oAddress Target
target) (forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Target -> Int
oPort Target
target)
                                        Maybe AddrInfo
remote_bus_addr <- if forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ Target -> Maybe Int
oBusPort Target
target
                                                           then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> String -> IO AddrInfo
resolve (Target -> String
oAddress Target
target) (forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ Target -> Maybe Int
oBusPort Target
target)
                                                           else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                                        let broadcast :: Int
broadcast = if Config -> Bool
cCtrlBroadcast Config
config then Int
1 else Int
0
                                        UDP
u <- (Socket -> SockAddr -> IO ()) -> String -> Int -> IO UDP
O.udp_socket (\Socket
sock SockAddr
sockaddr -> do Socket -> SocketOption -> Int -> IO ()
N.setSocketOption Socket
sock SocketOption
N.Broadcast Int
broadcast
                                                                                Socket -> SockAddr -> IO ()
N.connect Socket
sock SockAddr
sockaddr
                                                          ) (Target -> String
oAddress Target
target) (Target -> Int
oPort Target
target)
                                        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Cx {cxUDP :: UDP
cxUDP = UDP
u, cxAddr :: AddrInfo
cxAddr = AddrInfo
remote_addr, cxBusAddr :: Maybe AddrInfo
cxBusAddr = Maybe AddrInfo
remote_bus_addr, cxTarget :: Target
cxTarget = Target
target, cxOSCs :: [OSC]
cxOSCs = [OSC]
os}                                        
                   ) [(Target, [OSC])]
oscmap
       let bpm :: Beat
bpm = (coerce :: forall a b. Coercible a b => a -> b
coerce Double
defaultCps) forall a. Num a => a -> a -> a
* Beat
60 forall a. Num a => a -> a -> a
* (Config -> Beat
cBeatsPerCycle Config
config)
       AbletonLink
abletonLink <- Beat -> IO AbletonLink
Link.create Beat
bpm
       let stream :: Stream
stream = Stream {sConfig :: Config
sConfig = Config
config,
                            sBusses :: MVar [Int]
sBusses = MVar [Int]
bussesMV,
                            sStateMV :: MVar ValueMap
sStateMV  = MVar ValueMap
sMapMV,
                            sLink :: AbletonLink
sLink = AbletonLink
abletonLink,
                            sListen :: Maybe UDP
sListen = Maybe UDP
listen,
                            sPMapMV :: MVar PlayMap
sPMapMV = MVar PlayMap
pMapMV,
                            sActionsMV :: MVar [TempoAction]
sActionsMV = MVar [TempoAction]
actionsMV,
                            sGlobalFMV :: MVar (ControlPattern -> ControlPattern)
sGlobalFMV = MVar (ControlPattern -> ControlPattern)
globalFMV,
                            sCxs :: [Cx]
sCxs = [Cx]
cxs
                           }
       Stream -> IO ()
sendHandshakes Stream
stream
       let ac :: ActionHandler
ac = T.ActionHandler {
         onTick :: TickState -> LinkOperations -> ValueMap -> IO ValueMap
T.onTick = Stream -> TickState -> LinkOperations -> ValueMap -> IO ValueMap
onTick Stream
stream,
         onSingleTick :: LinkOperations -> ValueMap -> ControlPattern -> IO ValueMap
T.onSingleTick = Stream
-> LinkOperations -> ValueMap -> ControlPattern -> IO ValueMap
onSingleTick Stream
stream,
         updatePattern :: ID -> ControlPattern -> IO ()
T.updatePattern = Stream -> ID -> ControlPattern -> IO ()
updatePattern Stream
stream
         }
       -- Spawn a thread that acts as the clock
       [ThreadId]
_ <- Config
-> MVar ValueMap
-> MVar PlayMap
-> MVar [TempoAction]
-> ActionHandler
-> AbletonLink
-> IO [ThreadId]
T.clocked Config
config MVar ValueMap
sMapMV MVar PlayMap
pMapMV MVar [TempoAction]
actionsMV ActionHandler
ac AbletonLink
abletonLink
       -- Spawn a thread to handle OSC control messages
       ThreadId
_ <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ Int -> Config -> Stream -> IO ()
ctrlResponder Int
0 Config
config Stream
stream
       forall (m :: * -> *) a. Monad m => a -> m a
return Stream
stream

-- It only really works to handshake with one target at the moment..
sendHandshakes :: Stream -> IO ()
sendHandshakes :: Stream -> IO ()
sendHandshakes Stream
stream = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Cx -> IO ()
sendHandshake forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Target -> Bool
oHandshake forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cx -> Target
cxTarget) (Stream -> [Cx]
sCxs Stream
stream)
  where sendHandshake :: Cx -> IO ()
sendHandshake Cx
cx = if (forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ Stream -> Maybe UDP
sListen Stream
stream)
                           then                                            
                             do -- send it _from_ the udp socket we're listening to, so the
                                -- replies go back there
                                Bool -> Maybe UDP -> Cx -> Message -> IO ()
sendO Bool
False (Stream -> Maybe UDP
sListen Stream
stream) Cx
cx forall a b. (a -> b) -> a -> b
$ String -> [Datum] -> Message
O.Message String
"/dirt/handshake" []
                           else
                             Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"Can't handshake with SuperCollider without control port."

sendO :: Bool -> (Maybe O.UDP) -> Cx -> O.Message -> IO ()
sendO :: Bool -> Maybe UDP -> Cx -> Message -> IO ()
sendO Bool
isBusMsg (Just UDP
listen) Cx
cx Message
msg = UDP -> Packet -> SockAddr -> IO ()
O.sendTo UDP
listen (Message -> Packet
O.Packet_Message Message
msg) (AddrInfo -> SockAddr
N.addrAddress AddrInfo
addr)
  where addr :: AddrInfo
addr | Bool
isBusMsg Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isJust (Cx -> Maybe AddrInfo
cxBusAddr Cx
cx) = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ Cx -> Maybe AddrInfo
cxBusAddr Cx
cx
             | Bool
otherwise = Cx -> AddrInfo
cxAddr Cx
cx
sendO Bool
_ Maybe UDP
Nothing Cx
cx Message
msg = forall t. Transport t => t -> Message -> IO ()
O.sendMessage (Cx -> UDP
cxUDP Cx
cx) Message
msg

sendBndl :: Bool -> (Maybe O.UDP) -> Cx -> O.Bundle -> IO ()
sendBndl :: Bool -> Maybe UDP -> Cx -> Bundle -> IO ()
sendBndl Bool
isBusMsg (Just UDP
listen) Cx
cx Bundle
bndl = UDP -> Packet -> SockAddr -> IO ()
O.sendTo UDP
listen (Bundle -> Packet
O.Packet_Bundle Bundle
bndl) (AddrInfo -> SockAddr
N.addrAddress AddrInfo
addr)
  where addr :: AddrInfo
addr | Bool
isBusMsg Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isJust (Cx -> Maybe AddrInfo
cxBusAddr Cx
cx) = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ Cx -> Maybe AddrInfo
cxBusAddr Cx
cx
             | Bool
otherwise = Cx -> AddrInfo
cxAddr Cx
cx
sendBndl Bool
_ Maybe UDP
Nothing Cx
cx Bundle
bndl = forall t. Transport t => t -> Bundle -> IO ()
O.sendBundle (Cx -> UDP
cxUDP Cx
cx) Bundle
bndl

resolve :: String -> String -> IO N.AddrInfo
resolve :: String -> String -> IO AddrInfo
resolve String
host String
port = do let hints :: AddrInfo
hints = AddrInfo
N.defaultHints { addrSocketType :: SocketType
N.addrSocketType = SocketType
N.Stream }
                       AddrInfo
addr:[AddrInfo]
_ <- Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
N.getAddrInfo (forall a. a -> Maybe a
Just AddrInfo
hints) (forall a. a -> Maybe a
Just String
host) (forall a. a -> Maybe a
Just String
port)
                       forall (m :: * -> *) a. Monad m => a -> m a
return AddrInfo
addr

-- Start an instance of Tidal with superdirt OSC
startTidal :: Target -> Config -> IO Stream
startTidal :: Target -> Config -> IO Stream
startTidal Target
target Config
config = Config -> [(Target, [OSC])] -> IO Stream
startStream Config
config [(Target
target, [OSC
superdirtShape])]

startMulti :: [Target] -> Config -> IO ()
startMulti :: [Target] -> Config -> IO ()
startMulti [Target]
_ Config
_ = Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"startMulti has been removed, please check the latest documentation on tidalcycles.org"

toDatum :: Value -> O.Datum
toDatum :: Value -> Datum
toDatum (VF Double
x) = forall n. Real n => n -> Datum
O.float Double
x
toDatum (VN Note
x) = forall n. Real n => n -> Datum
O.float Note
x
toDatum (VI Int
x) = forall n. Integral n => n -> Datum
O.int32 Int
x
toDatum (VS String
x) = String -> Datum
O.string String
x
toDatum (VR Rational
x) = forall n. Real n => n -> Datum
O.float forall a b. (a -> b) -> a -> b
$ ((forall a. Fractional a => Rational -> a
fromRational Rational
x) :: Double)
toDatum (VB Bool
True) = forall n. Integral n => n -> Datum
O.int32 (Int
1 :: Int)
toDatum (VB Bool
False) = forall n. Integral n => n -> Datum
O.int32 (Int
0 :: Int)
toDatum (VX [Word8]
xs) = BLOB -> Datum
O.Blob forall a b. (a -> b) -> a -> b
$ [Word8] -> BLOB
O.blob_pack [Word8]
xs
toDatum Value
_ = forall a. HasCallStack => String -> a
error String
"toDatum: unhandled value"
  
toData :: OSC -> Event ValueMap -> Maybe [O.Datum]
toData :: OSC -> Event ValueMap -> Maybe [Datum]
toData (OSC {args :: OSC -> Args
args = ArgList [(String, Maybe Value)]
as}) Event ValueMap
e = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Value -> Datum
toDatum)) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(String
n,Maybe Value
v) -> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
n (forall a b. EventF a b -> b
value Event ValueMap
e) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Value
v) [(String, Maybe Value)]
as
toData (OSC {args :: OSC -> Args
args = Named [String]
rqrd}) Event ValueMap
e
  | [String] -> Bool
hasRequired [String]
rqrd = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(String
n,Value
v) -> [String -> Datum
O.string String
n, Value -> Datum
toDatum Value
v]) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ forall a b. EventF a b -> b
value Event ValueMap
e
  | Bool
otherwise = forall a. Maybe a
Nothing
  where hasRequired :: [String] -> Bool
hasRequired [] = Bool
True
        hasRequired [String]
xs = forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
ks)) [String]
xs
        ks :: [String]
ks = forall k a. Map k a -> [k]
Map.keys (forall a b. EventF a b -> b
value Event ValueMap
e)
toData OSC
_ Event ValueMap
_ = forall a. Maybe a
Nothing

substitutePath :: String -> ValueMap -> Maybe String
substitutePath :: String -> ValueMap -> Maybe String
substitutePath String
str ValueMap
cm = String -> Maybe String
parse String
str
  where parse :: String -> Maybe String
parse [] = forall a. a -> Maybe a
Just []
        parse (Char
'{':String
xs) = String -> Maybe String
parseWord String
xs
        parse (Char
x:String
xs) = do String
xs' <- String -> Maybe String
parse String
xs
                          forall (m :: * -> *) a. Monad m => a -> m a
return (Char
xforall a. a -> [a] -> [a]
:String
xs')
        parseWord :: String -> Maybe String
parseWord String
xs | String
b forall a. Eq a => a -> a -> Bool
== [] = ValueMap -> String -> Maybe String
getString ValueMap
cm String
a
                     | Bool
otherwise = do String
v <- ValueMap -> String -> Maybe String
getString ValueMap
cm String
a
                                      String
xs' <- String -> Maybe String
parse (forall a. [a] -> [a]
tail String
b)
                                      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
v forall a. [a] -> [a] -> [a]
++ String
xs'
          where (String
a,String
b) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'}') String
xs

getString :: ValueMap -> String -> Maybe String
getString :: ValueMap -> String -> Maybe String
getString ValueMap
cm String
s = (Value -> String
simpleShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
param ValueMap
cm) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Maybe String
defaultValue String
dflt
                      where (String
param, String
dflt) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'=') String
s
                            simpleShow :: Value -> String
                            simpleShow :: Value -> String
simpleShow (VS String
str) = String
str
                            simpleShow (VI Int
i) = forall a. Show a => a -> String
show Int
i
                            simpleShow (VF Double
f) = forall a. Show a => a -> String
show Double
f
                            simpleShow (VN Note
n) = forall a. Show a => a -> String
show Note
n
                            simpleShow (VR Rational
r) = forall a. Show a => a -> String
show Rational
r
                            simpleShow (VB Bool
b) = forall a. Show a => a -> String
show Bool
b
                            simpleShow (VX [Word8]
xs) = forall a. Show a => a -> String
show [Word8]
xs
                            simpleShow (VState ValueMap -> (ValueMap, Value)
_) = forall a. Show a => a -> String
show String
"<stateful>"
                            simpleShow (VPattern Pattern Value
_) = forall a. Show a => a -> String
show String
"<pattern>"
                            simpleShow (VList [Value]
_) = forall a. Show a => a -> String
show String
"<list>"
                            defaultValue :: String -> Maybe String
                            defaultValue :: String -> Maybe String
defaultValue (Char
'=':String
dfltVal) = forall a. a -> Maybe a
Just String
dfltVal
                            defaultValue String
_ = forall a. Maybe a
Nothing

playStack :: PlayMap -> ControlPattern
playStack :: PlayMap -> ControlPattern
playStack PlayMap
pMap = forall a. [Pattern a] -> Pattern a
stack forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map PlayState -> ControlPattern
pattern [PlayState]
active
  where active :: [PlayState]
active = forall a. (a -> Bool) -> [a] -> [a]
filter (\PlayState
pState -> if forall k. Map k PlayState -> Bool
hasSolo PlayMap
pMap
                                    then PlayState -> Bool
solo PlayState
pState
                                    else Bool -> Bool
not (PlayState -> Bool
mute PlayState
pState)
                        ) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems PlayMap
pMap

toOSC :: [Int] -> ProcessedEvent -> OSC -> [(Double, Bool, O.Message)]
toOSC :: [Int] -> ProcessedEvent -> OSC -> [(Double, Bool, Message)]
toOSC [Int]
busses ProcessedEvent
pe osc :: OSC
osc@(OSC String
_ Args
_)
  = forall a. [Maybe a] -> [a]
catMaybes (Maybe (Double, Bool, Message)
playmsgforall a. a -> [a] -> [a]
:[Maybe (Double, Bool, Message)]
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
        (ValueMap
playmap, ValueMap
busmap) = forall k a. (k -> a -> Bool) -> Map k a -> (Map k a, Map k a)
Map.partitionWithKey (\String
k Value
_ -> forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
k Bool -> Bool -> Bool
|| forall a. [a] -> a
head String
k forall a. Eq a => a -> a -> Bool
/= Char
'^') forall a b. (a -> b) -> a -> b
$ ProcessedEvent -> ValueMap
val ProcessedEvent
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' :: ValueMap
playmap' = forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\(VI Int
i) -> String -> Value
VS (Char
'c'forall a. a -> [a] -> [a]
:(forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Int -> Int
toBus Int
i))) ValueMap
busmap) ValueMap
playmap
        val :: ProcessedEvent -> ValueMap
val = forall a b. EventF a b -> b
value forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessedEvent -> Event ValueMap
peEvent
        -- Only events that start within the current nowArc are included
        playmsg :: Maybe (Double, Bool, Message)
playmsg | ProcessedEvent -> Bool
peHasOnset ProcessedEvent
pe = do
                  -- If there is already cps in the event, the union will preserve that.
                  let extra :: ValueMap
extra = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String
"cps", (Double -> Value
VF (coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$! ProcessedEvent -> Beat
peCps ProcessedEvent
pe))),
                                          (String
"delta", Double -> Value
VF (Micros -> Double -> Double
T.addMicrosToOsc (ProcessedEvent -> Micros
peDelta ProcessedEvent
pe) Double
0)),
                                          (String
"cycle", Double -> Value
VF (forall a. Fractional a => Rational -> a
fromRational (ProcessedEvent -> Rational
peCycle ProcessedEvent
pe))) 
                                        ]
                      addExtra :: ValueMap
addExtra = forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union ValueMap
playmap' ValueMap
extra
                      ts :: Double
ts = (ProcessedEvent -> Double
peOnWholeOrPartOsc ProcessedEvent
pe) forall a. Num a => a -> a -> a
+ Double
nudge -- + latency
                  [Datum]
vs <- OSC -> Event ValueMap -> Maybe [Datum]
toData OSC
osc ((ProcessedEvent -> Event ValueMap
peEvent ProcessedEvent
pe) {value :: ValueMap
value = ValueMap
addExtra})
                  String
mungedPath <- String -> ValueMap -> Maybe String
substitutePath (OSC -> String
path OSC
osc) ValueMap
playmap'
                  forall (m :: * -> *) a. Monad m => a -> m a
return (Double
ts,
                          Bool
False, -- bus message ?
                          String -> [Datum] -> Message
O.Message String
mungedPath [Datum]
vs
                          )
                | Bool
otherwise = forall a. Maybe a
Nothing
        toBus :: Int -> Int
toBus Int
n | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
busses = Int
n
                | Bool
otherwise = [Int]
busses forall a. [a] -> Int -> a
!!! Int
n
        busmsgs :: [Maybe (Double, Bool, Message)]
busmsgs = forall a b. (a -> b) -> [a] -> [b]
map
                    (\((Char
'^':String
k), (VI Int
b)) -> do Value
v <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
k ValueMap
playmap
                                              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Double
tsPart,
                                                        Bool
True, -- bus message ?
                                                        String -> [Datum] -> Message
O.Message String
"/c_set" [forall n. Integral n => n -> Datum
O.int32 Int
b, Value -> Datum
toDatum Value
v]
                                                      )
                    )
                    (forall k a. Map k a -> [(k, a)]
Map.toList ValueMap
busmap)
          where
            tsPart :: Double
tsPart = (ProcessedEvent -> Double
peOnPartOsc ProcessedEvent
pe) forall a. Num a => a -> a -> a
+ Double
nudge -- + latency
        nudge :: Double
nudge = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ Value -> Maybe Double
getF forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (Double -> Value
VF Double
0) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
"nudge" forall a b. (a -> b) -> a -> b
$ ValueMap
playmap
toOSC [Int]
_ ProcessedEvent
pe (OSCContext String
oscpath)
  = forall a b. (a -> b) -> [a] -> [b]
map ((Int, Int), (Int, Int)) -> (Double, Bool, Message)
cToM forall a b. (a -> b) -> a -> b
$ Context -> [((Int, Int), (Int, Int))]
contextPosition forall a b. (a -> b) -> a -> b
$ forall a b. EventF a b -> Context
context forall a b. (a -> b) -> a -> b
$ ProcessedEvent -> Event ValueMap
peEvent ProcessedEvent
pe
  where cToM :: ((Int,Int),(Int,Int)) -> (Double, Bool, O.Message)
        cToM :: ((Int, Int), (Int, Int)) -> (Double, Bool, Message)
cToM ((Int
x, Int
y), (Int
x',Int
y')) = (Double
ts,
                                  Bool
False, -- bus message ?
                                  String -> [Datum] -> Message
O.Message String
oscpath forall a b. (a -> b) -> a -> b
$ (String -> Datum
O.string String
ident)forall a. a -> [a] -> [a]
:(forall n. Real n => n -> Datum
O.float (ProcessedEvent -> Micros
peDelta ProcessedEvent
pe))forall a. a -> [a] -> [a]
:(forall n. Real n => n -> Datum
O.float Double
cyc)forall a. a -> [a] -> [a]
:(forall a b. (a -> b) -> [a] -> [b]
map forall n. Integral n => n -> Datum
O.int32 [Int
x,Int
y,Int
x',Int
y'])
                                 )
        cyc :: Double
        cyc :: Double
cyc = forall a. Fractional a => Rational -> a
fromRational forall a b. (a -> b) -> a -> b
$ ProcessedEvent -> Rational
peCycle ProcessedEvent
pe
        nudge :: Double
nudge = forall a. a -> Maybe a -> a
fromMaybe Double
0 forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
"nudge" (forall a b. EventF a b -> b
value forall a b. (a -> b) -> a -> b
$ ProcessedEvent -> Event ValueMap
peEvent ProcessedEvent
pe) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Maybe Double
getF
        ident :: String
ident = forall a. a -> Maybe a -> a
fromMaybe String
"unknown" forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
"_id_" (forall a b. EventF a b -> b
value forall a b. (a -> b) -> a -> b
$ ProcessedEvent -> Event ValueMap
peEvent ProcessedEvent
pe) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Maybe String
getS
        ts :: Double
ts = (ProcessedEvent -> Double
peOnWholeOrPartOsc ProcessedEvent
pe) forall a. Num a => a -> a -> a
+ Double
nudge -- + latency

-- Used for Tempo callback
updatePattern :: Stream -> ID -> ControlPattern -> IO ()
updatePattern :: Stream -> ID -> ControlPattern -> IO ()
updatePattern Stream
stream ID
k ControlPattern
pat = do
  let x :: [Event ValueMap]
x = forall a. Pattern a -> Arc -> [Event a]
queryArc ControlPattern
pat (forall a. a -> a -> ArcF a
Arc Rational
0 Rational
0)
  PlayMap
pMap <- seq :: forall a b. a -> b -> b
seq [Event ValueMap]
x forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar (Stream -> MVar PlayMap
sPMapMV Stream
stream)
  let playState :: PlayState
playState = Maybe PlayState -> PlayState
updatePS forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ID -> String
fromID ID
k) PlayMap
pMap
  forall a. MVar a -> a -> IO ()
putMVar (Stream -> MVar PlayMap
sPMapMV Stream
stream) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (ID -> String
fromID ID
k) PlayState
playState PlayMap
pMap
  where updatePS :: Maybe PlayState -> PlayState
updatePS (Just PlayState
playState) = do PlayState
playState {pattern :: ControlPattern
pattern = ControlPattern
pat', history :: [ControlPattern]
history = ControlPattern
patforall a. a -> [a] -> [a]
:(PlayState -> [ControlPattern]
history PlayState
playState)}
        updatePS Maybe PlayState
Nothing = ControlPattern -> Bool -> Bool -> [ControlPattern] -> PlayState
PlayState ControlPattern
pat' Bool
False Bool
False [ControlPattern
pat']
        pat' :: ControlPattern
pat' = ControlPattern
pat forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# String -> Pattern String -> ControlPattern
pS String
"_id_" (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ID -> String
fromID ID
k)

processCps :: T.LinkOperations -> [Event ValueMap] -> IO [ProcessedEvent]
processCps :: LinkOperations -> [Event ValueMap] -> IO [ProcessedEvent]
processCps LinkOperations
ops = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Event ValueMap -> IO ProcessedEvent
processEvent
  where
    processEvent ::  Event ValueMap  -> IO ProcessedEvent
    processEvent :: Event ValueMap -> IO ProcessedEvent
processEvent Event ValueMap
e = do
      let wope :: Arc
wope = forall a. Event a -> Arc
wholeOrPart Event ValueMap
e
          partStartCycle :: Rational
partStartCycle = forall a. ArcF a -> a
start forall a b. (a -> b) -> a -> b
$ forall a b. EventF a b -> a
part Event ValueMap
e
          partStartBeat :: Beat
partStartBeat = (LinkOperations -> Beat -> Beat
T.cyclesToBeat LinkOperations
ops) (forall a b. (Real a, Fractional b) => a -> b
realToFrac Rational
partStartCycle)
          onCycle :: Rational
onCycle = forall a. ArcF a -> a
start Arc
wope
          onBeat :: Beat
onBeat = (LinkOperations -> Beat -> Beat
T.cyclesToBeat LinkOperations
ops) (forall a b. (Real a, Fractional b) => a -> b
realToFrac Rational
onCycle)
          offCycle :: Rational
offCycle = forall a. ArcF a -> a
stop Arc
wope
          offBeat :: Beat
offBeat = (LinkOperations -> Beat -> Beat
T.cyclesToBeat LinkOperations
ops) (forall a b. (Real a, Fractional b) => a -> b
realToFrac Rational
offCycle)
      Micros
on <- (LinkOperations -> Beat -> IO Micros
T.timeAtBeat LinkOperations
ops) Beat
onBeat
      Micros
onPart <- (LinkOperations -> Beat -> IO Micros
T.timeAtBeat LinkOperations
ops) Beat
partStartBeat
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Event a -> Bool
eventHasOnset Event ValueMap
e) (do
        let cps' :: Maybe Double
cps' = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
"cps" (forall a b. EventF a b -> b
value Event ValueMap
e) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Maybe Double
getF
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (\Beat
newCps -> (LinkOperations -> Beat -> Micros -> IO ()
T.setTempo LinkOperations
ops) ((LinkOperations -> Beat -> Beat
T.cyclesToBeat LinkOperations
ops) (Beat
newCps forall a. Num a => a -> a -> a
* Beat
60)) Micros
on) forall a b. (a -> b) -> a -> b
$ coerce :: forall a b. Coercible a b => a -> b
coerce Maybe Double
cps' 
        )
      Micros
off <- (LinkOperations -> Beat -> IO Micros
T.timeAtBeat LinkOperations
ops) Beat
offBeat
      Beat
bpm <- (LinkOperations -> IO Beat
T.getTempo LinkOperations
ops)
      let cps :: Beat
cps = ((LinkOperations -> Beat -> Beat
T.beatToCycles LinkOperations
ops) Beat
bpm) forall a. Fractional a => a -> a -> a
/ Beat
60
      let delta :: Micros
delta = Micros
off forall a. Num a => a -> a -> a
- Micros
on
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ProcessedEvent {
          peHasOnset :: Bool
peHasOnset = forall a. Event a -> Bool
eventHasOnset Event ValueMap
e,
          peEvent :: Event ValueMap
peEvent = Event ValueMap
e,
          peCps :: Beat
peCps = Beat
cps,
          peDelta :: Micros
peDelta = Micros
delta,
          peCycle :: Rational
peCycle = Rational
onCycle,
          peOnWholeOrPart :: Micros
peOnWholeOrPart = Micros
on,
          peOnWholeOrPartOsc :: Double
peOnWholeOrPartOsc = (LinkOperations -> Micros -> Double
T.linkToOscTime LinkOperations
ops) Micros
on,
          peOnPart :: Micros
peOnPart = Micros
onPart,
          peOnPartOsc :: Double
peOnPartOsc = (LinkOperations -> Micros -> Double
T.linkToOscTime LinkOperations
ops) Micros
onPart
        }


-- streamFirst but with random cycle instead of always first cicle
streamOnce :: Stream -> ControlPattern -> IO ()
streamOnce :: Stream -> ControlPattern -> IO ()
streamOnce Stream
st ControlPattern
p = do Int
i <- forall (m :: * -> *) a. MonadIO m => (StdGen -> (a, StdGen)) -> m a
getStdRandom forall a b. (a -> b) -> a -> b
$ forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
0, Int
8192)
                     Stream -> ControlPattern -> IO ()
streamFirst Stream
st forall a b. (a -> b) -> a -> b
$ forall a. Rational -> Pattern a -> Pattern a
rotL (forall a. Real a => a -> Rational
toRational (Int
i :: Int)) ControlPattern
p

-- here let's do modifyMVar_ on actions
streamFirst :: Stream -> ControlPattern -> IO ()
streamFirst :: Stream -> ControlPattern -> IO ()
streamFirst Stream
stream ControlPattern
pat = forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (Stream -> MVar [TempoAction]
sActionsMV Stream
stream) (\[TempoAction]
actions -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (ControlPattern -> TempoAction
T.SingleTick ControlPattern
pat) forall a. a -> [a] -> [a]
: [TempoAction]
actions)

-- Used for Tempo callback
onTick :: Stream -> TickState -> T.LinkOperations -> ValueMap -> IO ValueMap
onTick :: Stream -> TickState -> LinkOperations -> ValueMap -> IO ValueMap
onTick Stream
stream TickState
st LinkOperations
ops ValueMap
s
  = Stream -> TickState -> LinkOperations -> ValueMap -> IO ValueMap
doTick Stream
stream TickState
st LinkOperations
ops ValueMap
s

-- Used for Tempo callback
-- Tempo changes will be applied.
-- However, since the full arc is processed at once and since Link does not support
-- scheduling, tempo change may affect scheduling of events that happen earlier
-- in the normal stream (the one handled by onTick).
onSingleTick :: Stream -> T.LinkOperations -> ValueMap -> ControlPattern -> IO ValueMap
onSingleTick :: Stream
-> LinkOperations -> ValueMap -> ControlPattern -> IO ValueMap
onSingleTick Stream
stream LinkOperations
ops ValueMap
s ControlPattern
pat = do
  MVar PlayMap
pMapMV <- forall a. a -> IO (MVar a)
newMVar forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton String
"fake"
          (PlayState {pattern :: ControlPattern
pattern = ControlPattern
pat,
                      mute :: Bool
mute = Bool
False,
                      solo :: Bool
solo = Bool
False,
                      history :: [ControlPattern]
history = []
                      }
          )

  -- The nowArc is a full cycle
  let state :: TickState
state = TickState {tickArc :: Arc
tickArc = (forall a. a -> a -> ArcF a
Arc Rational
0 Rational
1), tickNudge :: Double
tickNudge = Double
0}
  Stream -> TickState -> LinkOperations -> ValueMap -> IO ValueMap
doTick (Stream
stream {sPMapMV :: MVar PlayMap
sPMapMV = MVar PlayMap
pMapMV}) TickState
state LinkOperations
ops ValueMap
s


-- | Query the current pattern (contained in argument @stream :: Stream@)
-- for the events in the current arc (contained in argument @st :: T.State@),
-- translate them to OSC messages, and send these.
--
-- If an exception occurs during sending,
-- this functions prints a warning and continues, because
-- the likely reason is that the backend (supercollider) isn't running.
-- 
-- If any exception occurs before or outside sending
-- (e.g., while querying the pattern, while computing a message),
-- this function prints a warning and resets the current pattern
-- to the previous one (or to silence if there isn't one) and continues,
-- because the likely reason is that something is wrong with the current pattern.
doTick :: Stream -> TickState -> T.LinkOperations -> ValueMap -> IO ValueMap
doTick :: Stream -> TickState -> LinkOperations -> ValueMap -> IO ValueMap
doTick Stream
stream TickState
st LinkOperations
ops ValueMap
sMap =
  forall e a. Exception e => (e -> IO a) -> IO a -> IO a
E.handle (\ (SomeException
e :: E.SomeException) -> do
    Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"Failed to Stream.doTick: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SomeException
e
    Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"Return to previous pattern."
    Stream -> IO ()
setPreviousPatternOrSilence Stream
stream
    forall (m :: * -> *) a. Monad m => a -> m a
return ValueMap
sMap) (do
      PlayMap
pMap <- forall a. MVar a -> IO a
readMVar (Stream -> MVar PlayMap
sPMapMV Stream
stream)
      [Int]
busses <- forall a. MVar a -> IO a
readMVar (Stream -> MVar [Int]
sBusses Stream
stream)
      ControlPattern -> ControlPattern
sGlobalF <- forall a. MVar a -> IO a
readMVar (Stream -> MVar (ControlPattern -> ControlPattern)
sGlobalFMV Stream
stream)
      Beat
bpm <- (LinkOperations -> IO Beat
T.getTempo LinkOperations
ops)
      let
        cxs :: [Cx]
cxs = Stream -> [Cx]
sCxs Stream
stream
        patstack :: ControlPattern
patstack = ControlPattern -> ControlPattern
sGlobalF forall a b. (a -> b) -> a -> b
$ PlayMap -> ControlPattern
playStack PlayMap
pMap
        cps :: Beat
cps = ((LinkOperations -> Beat -> Beat
T.beatToCycles LinkOperations
ops) Beat
bpm) forall a. Fractional a => a -> a -> a
/ Beat
60
        sMap' :: ValueMap
sMap' = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
"_cps" (Double -> Value
VF forall a b. (a -> b) -> a -> b
$ coerce :: forall a b. Coercible a b => a -> b
coerce Beat
cps) ValueMap
sMap
        extraLatency :: Double
extraLatency = TickState -> Double
tickNudge TickState
st
        -- First the state is used to query the pattern
        es :: [Event ValueMap]
es = forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (forall a. ArcF a -> a
start forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. EventF a b -> a
part) forall a b. (a -> b) -> a -> b
$ forall a. Pattern a -> State -> [Event a]
query ControlPattern
patstack (State {arc :: Arc
arc = TickState -> Arc
tickArc TickState
st,
                                                        controls :: ValueMap
controls = ValueMap
sMap'
                                                      }
                                                )
         -- Then it's passed through the events
        (ValueMap
sMap'', [Event ValueMap]
es') = ValueMap -> [Event ValueMap] -> (ValueMap, [Event ValueMap])
resolveState ValueMap
sMap' [Event ValueMap]
es
      [ProcessedEvent]
tes <- LinkOperations -> [Event ValueMap] -> IO [ProcessedEvent]
processCps LinkOperations
ops [Event ValueMap]
es'
      -- For each OSC target
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Cx]
cxs forall a b. (a -> b) -> a -> b
$ \cx :: Cx
cx@(Cx Target
target UDP
_ [OSC]
oscs AddrInfo
_ Maybe AddrInfo
_) -> do
        -- Latency is configurable per target.
        -- Latency is only used when sending events live.
        let latency :: Double
latency = Target -> Double
oLatency Target
target
            ms :: [(Double, Bool, Message)]
ms = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\ProcessedEvent
e ->  forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Int] -> ProcessedEvent -> OSC -> [(Double, Bool, Message)]
toOSC [Int]
busses ProcessedEvent
e) [OSC]
oscs) [ProcessedEvent]
tes
        -- send the events to the OSC target
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Double, Bool, Message)]
ms forall a b. (a -> b) -> a -> b
$ \ (Double, Bool, Message)
m -> (do
          Maybe UDP
-> Cx -> Double -> Double -> (Double, Bool, Message) -> IO ()
send (Stream -> Maybe UDP
sListen Stream
stream) Cx
cx Double
latency Double
extraLatency (Double, Bool, Message)
m) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \ (SomeException
e :: E.SomeException) -> do
          Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"Failed to send. Is the '" forall a. [a] -> [a] -> [a]
++ Target -> String
oName Target
target forall a. [a] -> [a] -> [a]
++ String
"' target running? " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SomeException
e
      ValueMap
sMap'' seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return ValueMap
sMap'')

setPreviousPatternOrSilence :: Stream -> IO ()
setPreviousPatternOrSilence :: Stream -> IO ()
setPreviousPatternOrSilence Stream
stream =
  forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (Stream -> MVar PlayMap
sPMapMV Stream
stream) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ( \ PlayState
pMap -> case PlayState -> [ControlPattern]
history PlayState
pMap of
      ControlPattern
_:ControlPattern
p:[ControlPattern]
ps -> PlayState
pMap { pattern :: ControlPattern
pattern = ControlPattern
p, history :: [ControlPattern]
history = ControlPattern
pforall a. a -> [a] -> [a]
:[ControlPattern]
ps }
      [ControlPattern]
_ -> PlayState
pMap { pattern :: ControlPattern
pattern = forall a. Pattern a
silence, history :: [ControlPattern]
history = [forall a. Pattern a
silence] }
              )

-- send has three modes:
-- Send events early using timestamp in the OSC bundle - used by Superdirt
-- Send events early by adding timestamp to the OSC message - used by Dirt
-- Send events live by delaying the thread
send :: Maybe O.UDP -> Cx -> Double -> Double -> (Double, Bool, O.Message) -> IO ()
send :: Maybe UDP
-> Cx -> Double -> Double -> (Double, Bool, Message) -> IO ()
send Maybe UDP
listen Cx
cx Double
latency Double
extraLatency (Double
time, Bool
isBusMsg, Message
m)
  | Target -> Schedule
oSchedule Target
target forall a. Eq a => a -> a -> Bool
== StampStyle -> Schedule
Pre StampStyle
BundleStamp = Bool -> Maybe UDP -> Cx -> Bundle -> IO ()
sendBndl Bool
isBusMsg Maybe UDP
listen Cx
cx forall a b. (a -> b) -> a -> b
$ Double -> [Message] -> Bundle
O.Bundle Double
timeWithLatency [Message
m]
  | Target -> Schedule
oSchedule Target
target forall a. Eq a => a -> a -> Bool
== StampStyle -> Schedule
Pre StampStyle
MessageStamp = Bool -> Maybe UDP -> Cx -> Message -> IO ()
sendO Bool
isBusMsg Maybe UDP
listen Cx
cx forall a b. (a -> b) -> a -> b
$ Message -> Message
addtime Message
m
  | Bool
otherwise = do ThreadId
_ <- IO () -> IO ThreadId
forkOS forall a b. (a -> b) -> a -> b
$ do Double
now <- forall (m :: * -> *). MonadIO m => m Double
O.time
                                    Int -> IO ()
threadDelay forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ (Double
timeWithLatency forall a. Num a => a -> a -> a
- Double
now) forall a. Num a => a -> a -> a
* Double
1000000
                                    Bool -> Maybe UDP -> Cx -> Message -> IO ()
sendO Bool
isBusMsg Maybe UDP
listen Cx
cx Message
m
                   forall (m :: * -> *) a. Monad m => a -> m a
return ()
    where addtime :: Message -> Message
addtime (O.Message String
mpath [Datum]
params) = String -> [Datum] -> Message
O.Message String
mpath ((forall n. Integral n => n -> Datum
O.int32 Int
sec)forall a. a -> [a] -> [a]
:((forall n. Integral n => n -> Datum
O.int32 Int
usec)forall a. a -> [a] -> [a]
:[Datum]
params))
          ut :: Double
ut = forall n. Num n => n -> n
O.ntpr_to_ut Double
timeWithLatency
          sec :: Int
          sec :: Int
sec = forall a b. (RealFrac a, Integral b) => a -> b
floor Double
ut
          usec :: Int
          usec :: Int
usec = forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ Double
1000000 forall a. Num a => a -> a -> a
* (Double
ut forall a. Num a => a -> a -> a
- (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sec))
          target :: Target
target = Cx -> Target
cxTarget Cx
cx
          timeWithLatency :: Double
timeWithLatency = Double
time forall a. Num a => a -> a -> a
- Double
latency forall a. Num a => a -> a -> a
+ Double
extraLatency

-- Interaction

streamNudgeAll :: Stream -> Double -> IO ()
streamNudgeAll :: Stream -> Double -> IO ()
streamNudgeAll Stream
s Double
nudge = MVar [TempoAction] -> Double -> IO ()
T.setNudge (Stream -> MVar [TempoAction]
sActionsMV Stream
s) Double
nudge

streamResetCycles :: Stream -> IO ()
streamResetCycles :: Stream -> IO ()
streamResetCycles Stream
s =MVar [TempoAction] -> IO ()
T.resetCycles (Stream -> MVar [TempoAction]
sActionsMV Stream
s)

hasSolo :: Map.Map k PlayState -> Bool
hasSolo :: forall k. Map k PlayState -> Bool
hasSolo = (forall a. Ord a => a -> a -> Bool
>= Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter PlayState -> Bool
solo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems

streamList :: Stream -> IO ()
streamList :: Stream -> IO ()
streamList Stream
s = do PlayMap
pMap <- forall a. MVar a -> IO a
readMVar (Stream -> MVar PlayMap
sPMapMV Stream
s)
                  let hs :: Bool
hs = forall k. Map k PlayState -> Bool
hasSolo PlayMap
pMap
                  String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Bool -> (String, PlayState) -> String
showKV Bool
hs) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList PlayMap
pMap
  where showKV :: Bool -> (PatId, PlayState) -> String
        showKV :: Bool -> (String, PlayState) -> String
showKV Bool
True  (String
k, (PlayState {solo :: PlayState -> Bool
solo = Bool
True})) = String
k forall a. [a] -> [a] -> [a]
++ String
" - solo\n"
        showKV Bool
True  (String
k, PlayState
_) = String
"(" forall a. [a] -> [a] -> [a]
++ String
k forall a. [a] -> [a] -> [a]
++ String
")\n"
        showKV Bool
False (String
k, (PlayState {solo :: PlayState -> Bool
solo = Bool
False})) = String
k forall a. [a] -> [a] -> [a]
++ String
"\n"
        showKV Bool
False (String
k, PlayState
_) = String
"(" forall a. [a] -> [a] -> [a]
++ String
k forall a. [a] -> [a] -> [a]
++ String
") - muted\n"

-- Evaluation of pat is forced so exceptions are picked up here, before replacing the existing pattern.

streamReplace :: Stream -> ID -> ControlPattern -> IO ()
streamReplace :: Stream -> ID -> ControlPattern -> IO ()
streamReplace Stream
s ID
k !ControlPattern
pat
  = forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (Stream -> MVar [TempoAction]
sActionsMV Stream
s) (\[TempoAction]
actions -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (ID -> ControlPattern -> TempoAction
T.StreamReplace ID
k ControlPattern
pat) forall a. a -> [a] -> [a]
: [TempoAction]
actions)

streamMute :: Stream -> ID -> IO ()
streamMute :: Stream -> ID -> IO ()
streamMute Stream
s ID
k = Stream -> [ID] -> (PlayState -> PlayState) -> IO ()
withPatIds Stream
s [ID
k] (\PlayState
x -> PlayState
x {mute :: Bool
mute = Bool
True})

streamMutes :: Stream -> [ID] -> IO ()
streamMutes :: Stream -> [ID] -> IO ()
streamMutes Stream
s [ID]
ks = Stream -> [ID] -> (PlayState -> PlayState) -> IO ()
withPatIds Stream
s [ID]
ks (\PlayState
x -> PlayState
x {mute :: Bool
mute = Bool
True})

streamUnmute :: Stream -> ID -> IO ()
streamUnmute :: Stream -> ID -> IO ()
streamUnmute Stream
s ID
k = Stream -> [ID] -> (PlayState -> PlayState) -> IO ()
withPatIds Stream
s [ID
k] (\PlayState
x -> PlayState
x {mute :: Bool
mute = Bool
False})

streamSolo :: Stream -> ID -> IO ()
streamSolo :: Stream -> ID -> IO ()
streamSolo Stream
s ID
k = Stream -> [ID] -> (PlayState -> PlayState) -> IO ()
withPatIds Stream
s [ID
k] (\PlayState
x -> PlayState
x {solo :: Bool
solo = Bool
True})

streamUnsolo :: Stream -> ID -> IO ()
streamUnsolo :: Stream -> ID -> IO ()
streamUnsolo Stream
s ID
k = Stream -> [ID] -> (PlayState -> PlayState) -> IO ()
withPatIds Stream
s [ID
k] (\PlayState
x -> PlayState
x {solo :: Bool
solo = Bool
False})

withPatIds :: Stream -> [ID] -> (PlayState -> PlayState) -> IO ()
withPatIds :: Stream -> [ID] -> (PlayState -> PlayState) -> IO ()
withPatIds Stream
s [ID]
ks PlayState -> PlayState
f
  = do PlayMap
playMap <- forall a. MVar a -> IO a
takeMVar forall a b. (a -> b) -> a -> b
$ Stream -> MVar PlayMap
sPMapMV Stream
s
       let pMap' :: PlayMap
pMap' = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
Map.update (\PlayState
x -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PlayState -> PlayState
f PlayState
x)) PlayMap
playMap (forall a b. (a -> b) -> [a] -> [b]
map ID -> String
fromID [ID]
ks)
       forall a. MVar a -> a -> IO ()
putMVar (Stream -> MVar PlayMap
sPMapMV Stream
s) PlayMap
pMap'
       forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- TODO - is there a race condition here?
streamMuteAll :: Stream -> IO ()
streamMuteAll :: Stream -> IO ()
streamMuteAll Stream
s = forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (Stream -> MVar PlayMap
sPMapMV Stream
s) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\PlayState
x -> PlayState
x {mute :: Bool
mute = Bool
True})

streamHush :: Stream -> IO ()
streamHush :: Stream -> IO ()
streamHush Stream
s = forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (Stream -> MVar PlayMap
sPMapMV Stream
s) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\PlayState
x -> PlayState
x {pattern :: ControlPattern
pattern = forall a. Pattern a
silence, history :: [ControlPattern]
history = forall a. Pattern a
silenceforall a. a -> [a] -> [a]
:PlayState -> [ControlPattern]
history PlayState
x})

streamUnmuteAll :: Stream -> IO ()
streamUnmuteAll :: Stream -> IO ()
streamUnmuteAll Stream
s = forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (Stream -> MVar PlayMap
sPMapMV Stream
s) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\PlayState
x -> PlayState
x {mute :: Bool
mute = Bool
False})

streamUnsoloAll :: Stream -> IO ()
streamUnsoloAll :: Stream -> IO ()
streamUnsoloAll Stream
s = forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (Stream -> MVar PlayMap
sPMapMV Stream
s) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\PlayState
x -> PlayState
x {solo :: Bool
solo = Bool
False})

streamSilence :: Stream -> ID -> IO ()
streamSilence :: Stream -> ID -> IO ()
streamSilence Stream
s ID
k = Stream -> [ID] -> (PlayState -> PlayState) -> IO ()
withPatIds Stream
s [ID
k] (\PlayState
x -> PlayState
x {pattern :: ControlPattern
pattern = forall a. Pattern a
silence, history :: [ControlPattern]
history = forall a. Pattern a
silenceforall a. a -> [a] -> [a]
:PlayState -> [ControlPattern]
history PlayState
x})

streamAll :: Stream -> (ControlPattern -> ControlPattern) -> IO ()
streamAll :: Stream -> (ControlPattern -> ControlPattern) -> IO ()
streamAll Stream
s ControlPattern -> ControlPattern
f = do ControlPattern -> ControlPattern
_ <- forall a. MVar a -> a -> IO a
swapMVar (Stream -> MVar (ControlPattern -> ControlPattern)
sGlobalFMV Stream
s) ControlPattern -> ControlPattern
f
                   forall (m :: * -> *) a. Monad m => a -> m a
return ()

streamGet :: Stream -> String -> IO (Maybe Value)
streamGet :: Stream -> String -> IO (Maybe Value)
streamGet Stream
s String
k = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
k forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. MVar a -> IO a
readMVar (Stream -> MVar ValueMap
sStateMV Stream
s)

streamSet :: Valuable a => Stream -> String -> Pattern a -> IO ()
streamSet :: forall a. Valuable a => Stream -> String -> Pattern a -> IO ()
streamSet Stream
s String
k Pattern a
pat = do ValueMap
sMap <- forall a. MVar a -> IO a
takeMVar forall a b. (a -> b) -> a -> b
$ Stream -> MVar ValueMap
sStateMV Stream
s
                       let pat' :: Pattern Value
pat' = forall a. Valuable a => a -> Value
toValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a
pat
                           sMap' :: ValueMap
sMap' = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
k (Pattern Value -> Value
VPattern Pattern Value
pat') ValueMap
sMap
                       forall a. MVar a -> a -> IO ()
putMVar (Stream -> MVar ValueMap
sStateMV Stream
s) forall a b. (a -> b) -> a -> b
$ ValueMap
sMap'

streamSetI :: Stream -> String -> Pattern Int -> IO ()
streamSetI :: Stream -> String -> Pattern Int -> IO ()
streamSetI = forall a. Valuable a => Stream -> String -> Pattern a -> IO ()
streamSet

streamSetF :: Stream -> String -> Pattern Double -> IO ()
streamSetF :: Stream -> String -> Pattern Double -> IO ()
streamSetF = forall a. Valuable a => Stream -> String -> Pattern a -> IO ()
streamSet

streamSetS :: Stream -> String -> Pattern String -> IO ()
streamSetS :: Stream -> String -> Pattern String -> IO ()
streamSetS = forall a. Valuable a => Stream -> String -> Pattern a -> IO ()
streamSet

streamSetB :: Stream -> String -> Pattern Bool -> IO ()
streamSetB :: Stream -> String -> Pattern Bool -> IO ()
streamSetB = forall a. Valuable a => Stream -> String -> Pattern a -> IO ()
streamSet

streamSetR :: Stream -> String -> Pattern Rational -> IO ()
streamSetR :: Stream -> String -> Pattern Rational -> IO ()
streamSetR = forall a. Valuable a => Stream -> String -> Pattern a -> IO ()
streamSet

openListener :: Config -> IO (Maybe O.UDP)
openListener :: Config -> IO (Maybe UDP)
openListener Config
c
  | Config -> Bool
cCtrlListen Config
c = forall a. IO a -> (SomeException -> IO a) -> IO a
catchAny IO (Maybe UDP)
run (\SomeException
_ -> do Config -> String -> IO ()
verbose Config
c String
"That port isn't available, perhaps another Tidal instance is already listening on that port?"
                                           forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                                 )
  | Bool
otherwise  = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
  where
        run :: IO (Maybe UDP)
run = do UDP
sock <- String -> Int -> IO UDP
O.udpServer (Config -> String
cCtrlAddr Config
c) (Config -> Int
cCtrlPort Config
c)
                 forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
cCtrlBroadcast Config
c) forall a b. (a -> b) -> a -> b
$ Socket -> SocketOption -> Int -> IO ()
N.setSocketOption (UDP -> Socket
O.udpSocket UDP
sock) SocketOption
N.Broadcast Int
1
                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just UDP
sock
        catchAny :: IO a -> (E.SomeException -> IO a) -> IO a
        catchAny :: forall a. IO a -> (SomeException -> IO a) -> IO a
catchAny = forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch

-- Listen to and act on OSC control messages
ctrlResponder :: Int -> Config -> Stream -> IO ()
ctrlResponder :: Int -> Config -> Stream -> IO ()
ctrlResponder Int
waits Config
c (stream :: Stream
stream@(Stream {sListen :: Stream -> Maybe UDP
sListen = Just UDP
sock}))
  = do [Message]
ms <- forall t. Transport t => Double -> t -> IO [Message]
recvMessagesTimeout Double
2 UDP
sock
       if (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Message]
ms)
         then do IO ()
checkHandshake -- there was a timeout, check handshake
                 Int -> Config -> Stream -> IO ()
ctrlResponder (Int
waitsforall a. Num a => a -> a -> a
+Int
1) Config
c Stream
stream
         else do forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Message -> IO ()
act [Message]
ms
                 Int -> Config -> Stream -> IO ()
ctrlResponder Int
0 Config
c Stream
stream
     where
        checkHandshake :: IO ()
checkHandshake = do [Int]
busses <- forall a. MVar a -> IO a
readMVar (Stream -> MVar [Int]
sBusses Stream
stream)
                            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
busses) forall a b. (a -> b) -> a -> b
$ do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when  (Int
waits forall a. Eq a => a -> a -> Bool
== Int
0) forall a b. (a -> b) -> a -> b
$ Config -> String -> IO ()
verbose Config
c forall a b. (a -> b) -> a -> b
$ String
"Waiting for SuperDirt (v.1.7.2 or higher).."
                                                    Stream -> IO ()
sendHandshakes Stream
stream

        act :: Message -> IO ()
act (O.Message String
"/dirt/hello" [Datum]
_) = Stream -> IO ()
sendHandshakes Stream
stream
        act (O.Message String
"/dirt/handshake/reply" [Datum]
xs) = do [Int]
prev <- forall a. MVar a -> a -> IO a
swapMVar (Stream -> MVar [Int]
sBusses Stream
stream) forall a b. (a -> b) -> a -> b
$ forall {a}. Integral a => [Datum] -> [a]
bufferIndices [Datum]
xs
                                                        -- Only report the first time..
                                                        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
prev) forall a b. (a -> b) -> a -> b
$ Config -> String -> IO ()
verbose Config
c forall a b. (a -> b) -> a -> b
$ String
"Connected to SuperDirt."
                                                        forall (m :: * -> *) a. Monad m => a -> m a
return ()
          where 
            bufferIndices :: [Datum] -> [a]
bufferIndices [] = []
            bufferIndices (Datum
x:[Datum]
xs') | Datum
x forall a. Eq a => a -> a -> Bool
== (ASCII -> Datum
O.ASCII_String forall a b. (a -> b) -> a -> b
$ String -> ASCII
O.ascii String
"&controlBusIndices") = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
takeWhile forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall i. Integral i => Datum -> Maybe i
O.datum_integral [Datum]
xs'
                                  | Bool
otherwise = [Datum] -> [a]
bufferIndices [Datum]
xs'
        -- External controller commands
        act (O.Message String
"/ctrl" (O.Int32 Int32
k:Datum
v:[]))
          = Message -> IO ()
act (String -> [Datum] -> Message
O.Message String
"/ctrl" [String -> Datum
O.string forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int32
k,Datum
v])
        act (O.Message String
"/ctrl" (O.ASCII_String ASCII
k:v :: Datum
v@(O.Float Float
_):[]))
          = String -> Value -> IO ()
add (ASCII -> String
O.ascii_to_string ASCII
k) (Double -> Value
VF (forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall n. Floating n => Datum -> Maybe n
O.datum_floating Datum
v))
        act (O.Message String
"/ctrl" (O.ASCII_String ASCII
k:O.ASCII_String ASCII
v:[]))
          = String -> Value -> IO ()
add (ASCII -> String
O.ascii_to_string ASCII
k) (String -> Value
VS (ASCII -> String
O.ascii_to_string ASCII
v))
        act (O.Message String
"/ctrl" (O.ASCII_String ASCII
k:O.Int32 Int32
v:[]))
          = String -> Value -> IO ()
add (ASCII -> String
O.ascii_to_string ASCII
k) (Int -> Value
VI (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
v))
        -- Stream playback commands
        act (O.Message String
"/mute" (Datum
k:[]))
          = Datum -> (ID -> IO ()) -> IO ()
withID Datum
k forall a b. (a -> b) -> a -> b
$ Stream -> ID -> IO ()
streamMute Stream
stream
        act (O.Message String
"/unmute" (Datum
k:[]))
          = Datum -> (ID -> IO ()) -> IO ()
withID Datum
k forall a b. (a -> b) -> a -> b
$ Stream -> ID -> IO ()
streamUnmute Stream
stream
        act (O.Message String
"/solo" (Datum
k:[]))
          = Datum -> (ID -> IO ()) -> IO ()
withID Datum
k forall a b. (a -> b) -> a -> b
$ Stream -> ID -> IO ()
streamSolo Stream
stream
        act (O.Message String
"/unsolo" (Datum
k:[]))
          = Datum -> (ID -> IO ()) -> IO ()
withID Datum
k forall a b. (a -> b) -> a -> b
$ Stream -> ID -> IO ()
streamUnsolo Stream
stream
        act (O.Message String
"/muteAll" [])
          = Stream -> IO ()
streamMuteAll Stream
stream
        act (O.Message String
"/unmuteAll" [])
          = Stream -> IO ()
streamUnmuteAll Stream
stream
        act (O.Message String
"/unsoloAll" [])
          = Stream -> IO ()
streamUnsoloAll Stream
stream
        act (O.Message String
"/hush" [])
          = Stream -> IO ()
streamHush Stream
stream
        act (O.Message String
"/silence" (Datum
k:[]))
          = Datum -> (ID -> IO ()) -> IO ()
withID Datum
k forall a b. (a -> b) -> a -> b
$ Stream -> ID -> IO ()
streamSilence Stream
stream
        act Message
m = Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"Unhandled OSC: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Message
m
        add :: String -> Value -> IO ()
        add :: String -> Value -> IO ()
add String
k Value
v = do ValueMap
sMap <- forall a. MVar a -> IO a
takeMVar (Stream -> MVar ValueMap
sStateMV Stream
stream)
                     forall a. MVar a -> a -> IO ()
putMVar (Stream -> MVar ValueMap
sStateMV Stream
stream) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
k Value
v ValueMap
sMap
                     forall (m :: * -> *) a. Monad m => a -> m a
return ()
        withID :: O.Datum -> (ID -> IO ()) -> IO ()
        withID :: Datum -> (ID -> IO ()) -> IO ()
withID (O.ASCII_String ASCII
k) ID -> IO ()
func = ID -> IO ()
func forall a b. (a -> b) -> a -> b
$ (String -> ID
ID forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASCII -> String
O.ascii_to_string) ASCII
k
        withID (O.Int32 Int32
k) ID -> IO ()
func = ID -> IO ()
func forall a b. (a -> b) -> a -> b
$ (String -> ID
ID forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) Int32
k
        withID Datum
_ ID -> IO ()
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
ctrlResponder Int
_ Config
_ Stream
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

verbose :: Config -> String -> IO ()
verbose :: Config -> String -> IO ()
verbose Config
c String
s = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
cVerbose Config
c) forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
s

recvMessagesTimeout :: (O.Transport t) => Double -> t -> IO [O.Message]
recvMessagesTimeout :: forall t. Transport t => Double -> t -> IO [Message]
recvMessagesTimeout Double
n t
sock = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Packet -> [Message]
O.packetMessages) forall a b. (a -> b) -> a -> b
$ forall t. Transport t => Double -> t -> IO (Maybe Packet)
O.recvPacketTimeout Double
n t
sock

streamGetcps :: Stream -> IO Double
streamGetcps :: Stream -> IO Double
streamGetcps Stream
s = do
  let config :: Config
config = Stream -> Config
sConfig Stream
s
  SessionState
ss <- AbletonLink -> IO SessionState
Link.createAndCaptureAppSessionState (Stream -> AbletonLink
sLink Stream
s)
  Beat
bpm <- SessionState -> IO Beat
Link.getTempo SessionState
ss
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ Beat
bpm forall a. Fractional a => a -> a -> a
/ (Config -> Beat
cBeatsPerCycle Config
config) forall a. Fractional a => a -> a -> a
/ Beat
60

streamGetnow :: Stream -> IO Double
streamGetnow :: Stream -> IO Double
streamGetnow Stream
s = do
  let config :: Config
config = Stream -> Config
sConfig Stream
s
  SessionState
ss <- AbletonLink -> IO SessionState
Link.createAndCaptureAppSessionState (Stream -> AbletonLink
sLink Stream
s)
  Micros
now <- AbletonLink -> IO Micros
Link.clock (Stream -> AbletonLink
sLink Stream
s)
  Beat
beat <- SessionState -> Micros -> Beat -> IO Beat
Link.beatAtTime SessionState
ss Micros
now (Config -> Beat
cQuantum Config
config)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ Beat
beat forall a. Fractional a => a -> a -> a
/ (Config -> Beat
cBeatsPerCycle Config
config)