module Sound.SC3.Server.Transport.Monad where
import Control.Monad
import Data.List
import qualified Data.List.Split as Split
import Data.Maybe
import qualified Data.Tree as Tree
import qualified Safe
import Sound.OSC
import Sound.SC3.Server.Command
import qualified Sound.SC3.Server.Command.Generic as Generic
import qualified Sound.SC3.Server.Enum as Enum
import qualified Sound.SC3.Server.Graphdef as Graphdef
import qualified Sound.SC3.Server.NRT as NRT
import qualified Sound.SC3.Server.Status as Status
import qualified Sound.SC3.Server.Synthdef as Synthdef
import Sound.SC3.UGen.Bindings.Composite (wrapOut)
import Sound.SC3.UGen.Type (UGen)
async :: DuplexOSC m => Message -> m Message
async m = sendMessage m >> waitReply "/done"
async_ :: DuplexOSC m => Message -> m ()
async_ = void . async
maybe_async :: DuplexOSC m => Message -> m ()
maybe_async m = if isAsync m then async_ m else sendMessage m
maybe_async_at :: DuplexOSC m => Time -> Message -> m ()
maybe_async_at t m =
if isAsync m
then async_ m
else sendBundle (bundle t [m])
sc3_default_udp :: IO UDP
sc3_default_udp = openUDP "127.0.0.1" 57110
withSC3 :: Connection UDP a -> IO a
withSC3 = withTransport sc3_default_udp
withSC3_ :: Connection UDP a -> IO ()
withSC3_ = void . withSC3
withSC3_tm :: Double -> Connection UDP a -> IO (Maybe a)
withSC3_tm tm = timeout_r tm . withSC3
stop :: SendOSC m => m ()
stop = sendMessage (g_freeAll [1])
reset :: SendOSC m => m ()
reset =
let m = [clearSched
,n_free [1,2]
,g_new [(1,Enum.AddToHead,0),(2,Enum.AddToTail,0)]]
in sendBundle (bundle immediately m)
type Play_Opt = (Node_Id,Enum.AddAction,Group_Id,[(String,Double)])
play_graphdef_msg :: Play_Opt -> Graphdef.Graphdef -> Message
play_graphdef_msg (nid,act,gid,param) g =
let nm = ascii_to_string (Graphdef.graphdef_name g)
in s_new nm nid act gid param
playGraphdef :: DuplexOSC m => Play_Opt -> Graphdef.Graphdef -> m ()
playGraphdef opt g = async_ (d_recv' g) >> sendMessage (play_graphdef_msg opt g)
play_synthdef_msg :: Play_Opt -> Synthdef.Synthdef -> Message
play_synthdef_msg (nid,act,gid,param) syn = s_new (Synthdef.synthdefName syn) nid act gid param
playSynthdef :: DuplexOSC m => Play_Opt -> Synthdef.Synthdef -> m ()
playSynthdef opt syn = async_ (d_recv syn) >> sendMessage (play_synthdef_msg opt syn)
playUGen :: DuplexOSC m => Play_Opt -> UGen -> m ()
playUGen loc =
playSynthdef loc .
Synthdef.synthdef "Anonymous" .
wrapOut Nothing
run_bundle :: Transport m => Time -> Bundle -> m ()
run_bundle t0 b = do
let t = t0 + bundleTime b
latency = 0.1
liftIO (pauseThreadUntil (t - latency))
mapM_ (maybe_async_at t) (bundleMessages b)
nrt_play :: Transport m => NRT.NRT -> m ()
nrt_play sc = do
t0 <- liftIO time
mapM_ (run_bundle t0) (NRT.nrt_bundles sc)
nrt_play_reorder :: Transport m => NRT.NRT -> m ()
nrt_play_reorder s = do
let (i,r) = NRT.nrt_span (<= 0) s
i' = concatMap bundleMessages i
(a,b) = partition_async i'
mapM_ async a
t <- liftIO time
mapM_ (run_bundle t) (Bundle 0 b : r)
nrt_audition :: NRT.NRT -> IO ()
nrt_audition = withSC3 . nrt_play
class Audible e where
play_at :: Transport m => Play_Opt -> e -> m ()
play :: Transport m => e -> m ()
play = play_at (-1,Enum.AddToHead,1,[])
instance Audible Graphdef.Graphdef where
play_at = playGraphdef
instance Audible Synthdef.Synthdef where
play_at = playSynthdef
instance Audible UGen where
play_at = playUGen
audition_at :: Audible e => Play_Opt -> e -> IO ()
audition_at k = withSC3 . play_at k
audition :: Audible e => e -> IO ()
audition = audition_at (-1,Enum.AddToHead,1,[])
withNotifications :: DuplexOSC m => m a -> m a
withNotifications f = do
async_ (notify True)
r <- f
async_ (notify False)
return r
b_getn1_data :: DuplexOSC m => Int -> (Int,Int) -> m [Double]
b_getn1_data b s = do
let f m = let (_,_,_,r) = unpack_b_setn_err m in r
sendMessage (b_getn1 b s)
liftM f (waitReply "/b_setn")
b_getn1_data_segment :: DuplexOSC m =>
Int -> Int -> (Int,Int) -> m [Double]
b_getn1_data_segment n b (i,j) = do
let ix = b_indices n j i
d <- mapM (b_getn1_data b) ix
return (concat d)
b_fetch :: DuplexOSC m => Int -> Int -> m [[Double]]
b_fetch n b = do
let f m = let (_,nf,nc,_) = unpack_b_info_err m
ix = (0,nf * nc)
deinterleave = transpose . Split.chunksOf nc
in liftM deinterleave (b_getn1_data_segment n b ix)
sendMessage (b_query1 b)
waitReply "/b_info" >>= f
b_fetch1 :: DuplexOSC m => Int -> Int -> m [Double]
b_fetch1 n b = liftM (Safe.headNote "b_fetch1: no data") (b_fetch n b)
b_fetch_hdr :: Transport m => Int -> Int -> m ((Int,Int,Int,Double),[[Double]])
b_fetch_hdr k b = do
q <- b_query1_unpack b
d <- b_fetch k b
return (q,d)
b_query1_unpack_generic :: (DuplexOSC m,Num n,Fractional r) => Int -> m (n,n,n,r)
b_query1_unpack_generic n = do
sendMessage (b_query1 n)
q <- waitReply "/b_info"
return (Generic.unpack_b_info_err q)
b_query1_unpack :: DuplexOSC m => Buffer_Id -> m (Int,Int,Int,Double)
b_query1_unpack = b_query1_unpack_generic
c_getn1_data :: DuplexOSC m => (Int,Int) -> m [Double]
c_getn1_data s = do
let f d = case d of
Int32 _:Int32 _:x -> mapMaybe datum_floating x
_ -> error "c_getn1_data"
sendMessage (c_getn1 s)
liftM f (waitDatum "/c_setn")
n_query1_unpack_f :: Transport m => (Message -> t) -> Node_Id -> m t
n_query1_unpack_f f n = do
sendMessage (n_query [n])
r <- waitReply "/n_info"
return (f r)
n_query1_unpack :: Transport m => Node_Id -> m (Maybe (Int,Int,Int,Int,Int,Maybe (Int,Int)))
n_query1_unpack = n_query1_unpack_f unpack_n_info
n_query1_unpack_plain :: Transport m => Node_Id -> m [Int]
n_query1_unpack_plain = n_query1_unpack_f unpack_n_info_plain
g_queryTree1_unpack :: Transport m => Group_Id -> m Status.Query_Node
g_queryTree1_unpack n = do
sendMessage (g_queryTree [(n,True)])
r <- waitReply "/g_queryTree.reply"
return (Status.queryTree (messageDatum r))
serverStatus :: DuplexOSC m => m [String]
serverStatus = liftM Status.statusFormat serverStatusData
serverSampleRateNominal :: DuplexOSC m => m Double
serverSampleRateNominal = liftM (Status.extractStatusField 7) serverStatusData
serverSampleRateActual :: DuplexOSC m => m Double
serverSampleRateActual = liftM (Status.extractStatusField 8) serverStatusData
serverStatusData :: DuplexOSC m => m [Datum]
serverStatusData = do
sendMessage status
waitDatum "/status.reply"
serverTree :: Transport m => m [String]
serverTree = do
qt <- g_queryTree1_unpack 0
let tr = Status.queryTree_rt qt
return (["***** SuperCollider Server Tree *****",Tree.drawTree (fmap Status.query_node_pp tr)])