module Sound.SC3.Server.State.Monad.Command (
Request
, R.exec
, R.exec_
, Result
, R.extract
, status
, statusM
, PrintLevel(..)
, dumpOSC
, clearSched
, ErrorScope(..)
, ErrorMode(..)
, errorMode
, SynthDef(name)
, d_named
, d_default
, d_recv
, d_load
, d_loadDir
, d_free
, Node(..)
, AddAction(..)
, AbstractNode
, node
, n_after
, n_before
, n_fill
, n_free
, BusMapping(..)
, n_query_
, n_query
, n_queryM
, n_run_
, n_set
, n_setn
, n_trace
, n_order
, Synth(..)
, s_new
, s_new_
, s_release
, s_get
, s_getn
, s_noid
, Group(..)
, rootNode
, g_new
, g_new_
, g_deepFree
, g_freeAll
, g_head
, g_tail
, g_dumpTree
, cmd
, u_cmd
, Buffer
, bufferId
, b_alloc
, b_allocRead
, b_allocReadChannel
, b_read
, b_readChannel
, SoundFileFormat(..)
, SampleFormat(..)
, b_write
, b_free
, b_zero
, b_set
, b_setn
, b_fill
, b_gen
, b_gen_sine1
, b_gen_sine2
, b_gen_sine3
, b_gen_cheby
, b_gen_copy
, b_close
, b_query
, b_queryM
, Bus(..)
, AudioBus(audioBusIdRange)
, audioBusId
, inputBus
, outputBus
, newAudioBus
, ControlBus(controlBusIdRange)
, controlBusId
, newControlBus
) where
import Control.Arrow (first)
import Control.Failure (Failure, failure)
import Control.Monad (liftM, unless)
import Control.Monad.IO.Class (MonadIO)
import Data.Int
import Sound.OSC (Datum(..), OSC(..))
import Sound.SC3 (Rate(..), UGen)
import Sound.SC3.Server.Allocator.Range (Range)
import qualified Sound.SC3.Server.Allocator.Range as Range
import qualified Sound.SC3.Server.Synthdef as Synthdef
import Sound.SC3.Server.Allocator (AllocFailure(..))
import Sound.SC3.Server.Enum (AddAction(..), B_Gen, ErrorScope(..), ErrorMode(..), PrintLevel(..))
import qualified Sound.SC3.Server.Command as C
import qualified Sound.SC3.Server.Command.Completion as CC
import Sound.SC3.Server.Enum (SoundFileFormat(..), SampleFormat(..))
import qualified Sound.SC3.Server.Notification as N
import Sound.SC3.Server.Process.Options (ServerOptions(..))
import Sound.SC3.Server.State (AudioBusId, BufferId, ControlBusId, NodeId)
import Sound.SC3.Server.State.Monad (sendOSC)
import qualified Sound.SC3.Server.State.Monad as M
import Sound.SC3.Server.State.Monad.Class (MonadIdAllocator, MonadServer, RequestOSC, serverOption)
import Sound.SC3.Server.State.Monad.Request (Request, Result, after_, finally, mkAsync, mkAsync_, mkSync, waitFor)
import qualified Sound.SC3.Server.State.Monad.Request as R
mkC :: OSC o => a -> (o -> a) -> (Maybe o -> a)
mkC f _ Nothing = f
mkC _ f (Just osc) = f osc
get :: (MonadIdAllocator m, RequestOSC m, MonadIO m) => Request m (Result a) -> m a
get m = R.exec_ m >>= R.extract
withSync :: MonadIdAllocator m => OSC o => o -> Request m ()
withSync c = do
sendOSC c
sendOSC =<< mkSync
status :: MonadIO m => Request m (Result N.Status)
status = do
sendOSC C.status
waitFor N.status_reply
statusM :: (MonadIdAllocator m, RequestOSC m, MonadIO m) => m N.Status
statusM = get status
dumpOSC :: MonadIdAllocator m => PrintLevel -> Request m ()
dumpOSC p = withSync (C.dumpOSC p)
clearSched :: Monad m => Request m ()
clearSched = sendOSC C.clearSched
errorMode :: Monad m => ErrorScope -> ErrorMode -> Request m ()
errorMode scope = sendOSC . C.errorMode scope
newtype SynthDef = SynthDef {
name :: String
} deriving (Eq, Show)
d_named :: String -> SynthDef
d_named = SynthDef
d_default :: SynthDef
d_default = d_named "default"
d_recv :: Monad m => String -> UGen -> Request m SynthDef
d_recv name ugen
| length name < 255 = mkAsync $ return (SynthDef name, f)
| otherwise = error "d_recv: name too long, resulting string exceeds 255 characters"
where
f osc = (mkC C.d_recv CC.d_recv' osc) (Synthdef.synthdef name ugen)
d_load :: Monad m => FilePath -> Request m ()
d_load fp = mkAsync_ $ \osc -> mkC C.d_load CC.d_load' osc $ fp
d_loadDir :: Monad m => FilePath -> Request m ()
d_loadDir fp = mkAsync_ $ \osc -> mkC C.d_loadDir CC.d_loadDir' osc $ fp
d_free :: Monad m => SynthDef -> Request m ()
d_free = sendOSC . C.d_free . (:[]) . name
class Node a where
nodeId :: a -> NodeId
data AbstractNode = forall n . (Eq n, Node n, Show n) => AbstractNode n
instance Eq AbstractNode where
(AbstractNode a) == (AbstractNode b) = nodeId a == nodeId b
instance Node AbstractNode where
nodeId (AbstractNode n) = nodeId n
instance Show AbstractNode where
show (AbstractNode n) = show n
node :: (Eq n, Node n, Show n) => n -> AbstractNode
node = AbstractNode
n_after :: (Node a, Node b, Monad m) => a -> b -> Request m ()
n_after a b = sendOSC $ C.n_after [(fromIntegral (nodeId a), fromIntegral (nodeId b))]
n_before :: (Node a, Node b, Monad m) => a -> b -> Request m ()
n_before a b = sendOSC $ C.n_after [(fromIntegral (nodeId a), fromIntegral (nodeId b))]
n_fill :: (Node a, Monad m) => a -> [(String, Int, Double)] -> Request m ()
n_fill n = sendOSC . C.n_fill (fromIntegral (nodeId n))
n_free :: (Node a, MonadIdAllocator m) => a -> Request m ()
n_free n = do
sendOSC $ C.n_free [fromIntegral (nodeId n)]
finally $ M.free M.nodeIdAllocator (nodeId n)
class BusMapping n b where
n_map :: (Node n, Bus b, Monad m) => n -> String -> b -> Request m ()
n_unmap :: (Node n, Bus b, Monad m) => n -> String -> b -> Request m ()
instance BusMapping n ControlBus where
n_map n c b = sendOSC msg
where
nid = fromIntegral (nodeId n)
bid = fromIntegral (controlBusId b)
msg = if numChannels b > 1
then C.n_mapn nid [(c, bid, numChannels b)]
else C.n_map nid [(c, bid)]
n_unmap n c b = sendOSC msg
where
nid = fromIntegral (nodeId n)
msg = if numChannels b > 1
then C.n_mapn nid [(c, 1, numChannels b)]
else C.n_map nid [(c, 1)]
instance BusMapping n AudioBus where
n_map n c b = sendOSC msg
where
nid = fromIntegral (nodeId n)
bid = fromIntegral (audioBusId b)
msg = if numChannels b > 1
then C.n_mapan nid [(c, bid, numChannels b)]
else C.n_mapa nid [(c, bid)]
n_unmap n c b = sendOSC msg
where
nid = fromIntegral (nodeId n)
msg = if numChannels b > 1
then C.n_mapan nid [(c, 1, numChannels b)]
else C.n_mapa nid [(c, 1)]
n_query_ :: (Node a, Monad m) => a -> Request m ()
n_query_ n = sendOSC (C.n_query [fromIntegral (nodeId n)])
n_query :: (Node a, MonadIO m) => a -> Request m (Result N.NodeNotification)
n_query n = do
n_query_ n
waitFor (N.n_info (nodeId n))
n_queryM :: (Node a, MonadIdAllocator m, RequestOSC m, MonadIO m) => a -> m N.NodeNotification
n_queryM = get . n_query
n_run_ :: (Node a, Monad m) => a -> Bool -> Request m ()
n_run_ n b = sendOSC $ C.n_run [(fromIntegral (nodeId n), b)]
n_set :: (Node a, Monad m) => a -> [(String, Double)] -> Request m ()
n_set n = sendOSC . C.n_set (fromIntegral (nodeId n))
n_setn :: (Node a, Monad m) => a -> [(String, [Double])] -> Request m ()
n_setn n = sendOSC . C.n_setn (fromIntegral (nodeId n))
n_trace :: (Node a, Monad m) => a -> Request m ()
n_trace n = sendOSC $ C.n_trace [fromIntegral (nodeId n)]
n_order :: (Node n, Monad m) => AddAction -> n -> [AbstractNode] -> Request m ()
n_order a n = sendOSC . C.n_order a (fromIntegral (nodeId n)) . map (fromIntegral.nodeId)
newtype Synth = Synth NodeId deriving (Eq, Ord, Show)
instance Node Synth where
nodeId (Synth nid) = nid
s_new :: MonadIdAllocator m => SynthDef -> AddAction -> Group -> [(String, Double)] -> Request m Synth
s_new d a g xs = do
nid <- M.alloc M.nodeIdAllocator
sendOSC $ C.s_new (name d) (fromIntegral nid) a (fromIntegral (nodeId g)) xs
return $ Synth nid
s_new_ :: (MonadServer m, MonadIdAllocator m) => SynthDef -> AddAction -> [(String, Double)] -> Request m Synth
s_new_ d a xs = rootNode >>= \g -> s_new d a g xs
s_release :: MonadIdAllocator m => Double -> Synth -> Request m ()
s_release r s = do
sendOSC (C.n_set1 (fromIntegral nid) "gate" r)
after_ (N.n_end_ nid) (M.free M.nodeIdAllocator nid)
where nid = nodeId s
s_get :: MonadIO m => Synth -> [String] -> Request m (Result [(Either Int32 String, Float)])
s_get s cs = do
sendOSC (C.s_get (fromIntegral nid) cs)
waitFor (N.n_set nid)
where nid = nodeId s
s_getn :: MonadIO m => Synth -> [(String, Int)] -> Request m (Result [(Either Int32 String, [Float])])
s_getn s cs = do
sendOSC (C.s_getn (fromIntegral nid) cs)
waitFor (N.n_setn nid)
where nid = nodeId s
s_noid :: MonadIdAllocator m => Synth -> Request m ()
s_noid s = do
sendOSC (C.s_noid [fromIntegral nid])
M.free M.nodeIdAllocator nid
where nid = nodeId s
newtype Group = Group NodeId deriving (Eq, Ord, Show)
instance Node Group where
nodeId (Group nid) = nid
rootNode :: MonadServer m => m Group
rootNode = liftM Group M.rootNodeId
g_new :: MonadIdAllocator m => AddAction -> Group -> Request m Group
g_new a p = do
nid <- M.alloc M.nodeIdAllocator
sendOSC $ C.g_new [(fromIntegral nid, a, fromIntegral (nodeId p))]
return $ Group nid
g_new_ :: (MonadServer m, MonadIdAllocator m) => AddAction -> Request m Group
g_new_ a = rootNode >>= g_new a
g_deepFree :: Monad m => Group -> Request m ()
g_deepFree g = sendOSC $ C.g_deepFree [fromIntegral (nodeId g)]
g_freeAll :: Monad m => Group -> Request m ()
g_freeAll g = sendOSC $ C.g_freeAll [fromIntegral (nodeId g)]
g_head :: (Node n, Monad m) => Group -> n -> Request m ()
g_head g n = sendOSC $ C.g_head [(fromIntegral (nodeId g), fromIntegral (nodeId n))]
g_tail :: (Node n, Monad m) => Group -> n -> Request m ()
g_tail g n = sendOSC $ C.g_tail [(fromIntegral (nodeId g), fromIntegral (nodeId n))]
g_dumpTree :: Monad m => [(Group, Bool)] -> Request m ()
g_dumpTree = sendOSC . C.g_dumpTree . map (first (fromIntegral . nodeId))
cmd :: Monad m => String -> [Datum] -> Request m ()
cmd s = sendOSC . C.cmd s
u_cmd :: Monad m => AbstractNode -> Int -> String -> [Datum] -> Request m ()
u_cmd n i s = sendOSC . C.u_cmd (fromIntegral (nodeId n)) i s
newtype Buffer = Buffer { bufferId :: BufferId } deriving (Eq, Ord, Show)
b_alloc :: MonadIdAllocator m => Int -> Int -> Request m Buffer
b_alloc n c = mkAsync $ do
bid <- M.alloc M.bufferIdAllocator
let f osc = (mkC C.b_alloc CC.b_alloc' osc) (fromIntegral bid) n c
return (Buffer bid, f)
b_allocRead :: MonadIdAllocator m => FilePath -> Maybe Int -> Maybe Int -> Request m Buffer
b_allocRead path fileOffset numFrames = mkAsync $ do
bid <- M.alloc M.bufferIdAllocator
let f osc = (mkC C.b_allocRead CC.b_allocRead' osc)
(fromIntegral bid) path
(maybe 0 id fileOffset)
(maybe (1) id numFrames)
return (Buffer bid, f)
b_allocReadChannel :: MonadIdAllocator m => FilePath -> Maybe Int -> Maybe Int -> [Int] -> Request m Buffer
b_allocReadChannel path fileOffset numFrames channels = mkAsync $ do
bid <- M.alloc M.bufferIdAllocator
let f osc = (mkC C.b_allocReadChannel CC.b_allocReadChannel' osc)
(fromIntegral bid) path
(maybe 0 id fileOffset)
(maybe (1) id numFrames)
channels
return (Buffer bid, f)
b_read :: Monad m =>
Buffer
-> FilePath
-> Maybe Int
-> Maybe Int
-> Maybe Int
-> Bool
-> Request m ()
b_read (Buffer bid) path fileOffset numFrames bufferOffset leaveOpen =
mkAsync_ $ \osc -> (mkC C.b_read CC.b_read' osc)
(fromIntegral bid) path
(maybe 0 id fileOffset)
(maybe (1) id numFrames)
(maybe 0 id bufferOffset)
leaveOpen
b_readChannel :: MonadIO m =>
Buffer
-> FilePath
-> Maybe Int
-> Maybe Int
-> Maybe Int
-> Bool
-> [Int]
-> Request m ()
b_readChannel (Buffer bid) path fileOffset numFrames bufferOffset leaveOpen channels =
mkAsync_ $ \osc -> (mkC C.b_readChannel CC.b_readChannel' osc)
(fromIntegral bid) path
(maybe 0 id fileOffset)
(maybe (1) id numFrames)
(maybe 0 id bufferOffset)
leaveOpen
channels
b_write :: MonadIO m =>
Buffer
-> FilePath
-> SoundFileFormat
-> SampleFormat
-> Maybe Int
-> Maybe Int
-> Bool
-> Request m ()
b_write (Buffer bid) path
soundFileFormat sampleFormat
fileOffset numFrames
leaveOpen = mkAsync_ f
where
f osc = (mkC C.b_write CC.b_write' osc)
(fromIntegral bid) path
soundFileFormat
sampleFormat
(maybe 0 id fileOffset)
(maybe (1) id numFrames)
leaveOpen
b_free :: MonadIdAllocator m => Buffer -> Request m ()
b_free b = mkAsync $ do
let bid = bufferId b
M.free M.bufferIdAllocator bid
let f osc = (mkC C.b_free CC.b_free' osc) (fromIntegral bid)
return ((), f)
b_zero :: MonadIO m => Buffer -> Request m ()
b_zero buffer = mkAsync_ $ \osc ->
(mkC C.b_zero CC.b_zero' osc)
(fromIntegral (bufferId buffer))
b_set :: Monad m => Buffer -> [(Int, Double)] -> Request m ()
b_set buffer = sendOSC . C.b_set (fromIntegral (bufferId buffer))
b_setn :: Monad m => Buffer -> [(Int, [Double])] -> Request m ()
b_setn buffer = sendOSC . C.b_setn (fromIntegral (bufferId buffer))
b_fill :: Monad m => Buffer -> [(Int, Int, Double)] -> Request m ()
b_fill buffer = sendOSC . C.b_fill (fromIntegral (bufferId buffer))
b_gen :: MonadIdAllocator m => Buffer -> String -> [Datum] -> Request m ()
b_gen buffer cmd = withSync . C.b_gen (fromIntegral (bufferId buffer)) cmd
b_gen_sine1 :: MonadIdAllocator m => Buffer -> [B_Gen] -> [Double] -> Request m ()
b_gen_sine1 buffer flags = withSync . C.b_gen_sine1 (fromIntegral (bufferId buffer)) flags
b_gen_sine2 :: MonadIdAllocator m => Buffer -> [B_Gen] -> [(Double, Double)] -> Request m ()
b_gen_sine2 buffer flags = withSync . C.b_gen_sine2 (fromIntegral (bufferId buffer)) flags
b_gen_sine3 :: MonadIdAllocator m => Buffer -> [B_Gen] -> [(Double, Double, Double)] -> Request m ()
b_gen_sine3 buffer flags = withSync . C.b_gen_sine3 (fromIntegral (bufferId buffer)) flags
b_gen_cheby :: MonadIdAllocator m => Buffer -> [B_Gen] -> [Double] -> Request m ()
b_gen_cheby buffer flags = withSync . C.b_gen_cheby (fromIntegral (bufferId buffer)) flags
b_gen_copy :: MonadIdAllocator m => Buffer -> Int -> Buffer -> Int -> Maybe Int -> Request m ()
b_gen_copy buffer sampleOffset srcBuffer srcSampleOffset numSamples =
withSync $ C.b_gen_copy (fromIntegral (bufferId buffer))
sampleOffset
(fromIntegral (bufferId srcBuffer))
srcSampleOffset
numSamples
b_close :: Monad m => Buffer -> Request m ()
b_close buffer = mkAsync_ $ \osc ->
mkC C.b_close CC.b_close' osc $ fromIntegral (bufferId buffer)
b_query :: MonadIO m => Buffer -> Request m (Result N.BufferInfo)
b_query (Buffer bid) = do
sendOSC (C.b_query [fromIntegral bid])
waitFor (N.b_info bid)
b_queryM :: (MonadIdAllocator m, RequestOSC m, MonadIO m) => Buffer -> m N.BufferInfo
b_queryM = get . b_query
class Bus a where
rate :: a -> Rate
numChannels :: a -> Int
freeBus :: (MonadServer m, MonadIdAllocator m) => a -> m ()
newtype AudioBus = AudioBus { audioBusIdRange :: Range AudioBusId } deriving (Eq, Show)
audioBusId :: AudioBus -> AudioBusId
audioBusId = Range.begin . audioBusIdRange
instance Bus AudioBus where
rate _ = AR
numChannels = Range.size . audioBusIdRange
freeBus b = do
hw <- isHardwareBus b
unless hw $ M.freeRange M.audioBusIdAllocator (audioBusIdRange b)
newAudioBus :: MonadIdAllocator m => Int -> m AudioBus
newAudioBus = liftM AudioBus . M.allocRange M.audioBusIdAllocator
isHardwareBus :: MonadServer m => AudioBus -> m Bool
isHardwareBus b = do
no <- serverOption numberOfOutputBusChannels
ni <- serverOption numberOfInputBusChannels
return $ audioBusId b >= 0 && audioBusId b < fromIntegral (no + ni)
inputBus :: (MonadServer m, Failure AllocFailure m) => Int -> Int -> m AudioBus
inputBus n i = do
k <- serverOption numberOfOutputBusChannels
m <- serverOption numberOfInputBusChannels
let r = Range.sized n (fromIntegral (k+i))
if Range.begin r < fromIntegral k || Range.end r > fromIntegral (k+m)
then failure InvalidId
else return (AudioBus r)
outputBus :: (MonadServer m, Failure AllocFailure m) => Int -> Int -> m AudioBus
outputBus n i = do
k <- serverOption numberOfOutputBusChannels
let r = Range.sized n (fromIntegral i)
if Range.begin r < 0 || Range.end r > fromIntegral k
then failure InvalidId
else return (AudioBus r)
newtype ControlBus = ControlBus { controlBusIdRange :: Range ControlBusId } deriving (Eq, Show)
controlBusId :: ControlBus -> ControlBusId
controlBusId = Range.begin . controlBusIdRange
instance Bus ControlBus where
rate _ = KR
numChannels = Range.size . controlBusIdRange
freeBus = M.freeRange M.controlBusIdAllocator . controlBusIdRange
newControlBus :: MonadIdAllocator m => Int -> m ControlBus
newControlBus = liftM ControlBus . M.allocRange M.controlBusIdAllocator