module Sound.SC3.Server.Transport.FD where
import Control.Monad
import Sound.OpenSoundControl.Time
import Sound.OpenSoundControl.Type
import Sound.OSC.Transport.FD
import Sound.OSC.Transport.FD.UDP
import Sound.SC3.Server.Command
import Sound.SC3.Server.NRT
import Sound.SC3.Server.Status
import Sound.SC3.Server.Synthdef
import Sound.SC3.Server.Synthdef.Type
import Sound.SC3.UGen.Type
send :: (Transport t) => t -> Message -> IO ()
send = sendMessage
wait :: Transport t => t -> String -> IO Message
wait = waitReply
async :: Transport t => t -> Message -> IO Message
async fd m = sendMessage fd m >> wait fd "/done"
withSC3 :: (UDP -> IO a) -> IO a
withSC3 = withTransport (openUDP "127.0.0.1" 57110)
stop :: Transport t => t -> IO ()
stop fd = sendMessage fd (g_freeAll [1])
reset :: Transport t => t -> IO ()
reset fd = do
sendMessage fd (g_freeAll [1,2])
sendMessage fd (g_new [(1,AddToTail,0),(2,AddToTail,0)])
playSynthdef :: Transport t => t -> Synthdef -> IO ()
playSynthdef fd s = do
_ <- async fd (d_recv s)
sendMessage fd (s_new (synthdefName s) (1) AddToTail 1 [])
playUGen :: Transport t => t -> UGen -> IO ()
playUGen fd = playSynthdef fd . synthdef "Anonymous"
run_bundle :: Transport t => t -> Double -> Bundle -> IO ()
run_bundle fd i (Bundle t x) =
let wr m = if isAsync m
then void (async fd m)
else sendMessage fd m
in case t of
NTPr n -> do
pauseThreadUntil (i + n)
mapM_ wr x
_ -> error "run_bundle: non-NTPr bundle"
performNRT :: Transport t => t -> NRT -> IO ()
performNRT fd s = utcr >>= \i -> mapM_ (run_bundle fd i) (nrt_bundles s)
class Audible e where
play :: Transport t => t -> e -> IO ()
audition :: e -> IO ()
audition e = withSC3 (`play` e)
instance Audible Graph where
play fd g = playSynthdef fd (Synthdef "Anonymous" g)
instance Audible Synthdef where
play = playSynthdef
instance Audible UGen where
play = playUGen
instance Audible NRT where
play = performNRT
withNotifications :: Transport t => t -> (t -> IO a) -> IO a
withNotifications fd f = do
_ <- async fd (notify True)
r <- f fd
_ <- async fd (notify False)
return r
b_getn1_data :: Transport t => t -> Int -> (Int,Int) -> IO [Double]
b_getn1_data fd b s = do
let f d = case d of
Int _:Int _:Int _:x -> map datum_real_err x
_ -> error "b_getn1_data"
sendMessage fd (b_getn1 b s)
fmap f (waitDatum fd "/b_setn")
b_getn1_data_segment :: Transport t => t -> Int -> Int -> (Int,Int) -> IO [Double]
b_getn1_data_segment fd n b (i,j) = do
let ix = b_indices n j i
d <- mapM (b_getn1_data fd b) ix
return (concat d)
b_fetch :: Transport t => t -> Int -> Int -> IO [Double]
b_fetch fd n b = do
let f d = case d of
[Int _,Int nf,Int nc,Float _] ->
let ix = (0,nf * nc)
in b_getn1_data_segment fd n b ix
_ -> error "b_fetch"
sendMessage fd (b_query1 b)
waitDatum fd "/b_info" >>= f
serverStatus :: Transport t => t -> IO [String]
serverStatus = liftM statusFormat . serverStatusData
serverSampleRateNominal :: (Transport t) => t -> IO Double
serverSampleRateNominal = liftM (extractStatusField 7) . serverStatusData
serverSampleRateActual :: (Transport t) => t -> IO Double
serverSampleRateActual = liftM (extractStatusField 8) . serverStatusData
serverStatusData :: Transport t => t -> IO [Datum]
serverStatusData fd = do
sendMessage fd status
waitDatum fd "/status.reply"