module Sound.SC3.Lang.Control.OverlapTexture where
import Data.List
import Data.Hashable
import Sound.OSC
import Sound.SC3
type Env_ST n = (n,n)
type Loc_GB = (Int,UGen)
mk_env :: Env_ST UGen -> UGen
mk_env (s,t) =
let c = EnvNum 4
p = envLinen' t s t 1 (c,c,c)
in envGen KR 1 1 0 1 RemoveSynth p
with_env_u :: UGen -> UGen -> Env_ST UGen -> UGen
with_env_u bus sig = out bus . (* sig) . mk_env
with_env :: UGen -> Env_ST Double -> UGen -> UGen
with_env bus (s,t) sig = with_env_u bus sig (constant s,constant t)
gen_nm :: UGen -> String
gen_nm = show . hash . show
gen_synth :: UGen -> Maybe (Env_ST Double) -> UGen -> Synthdef
gen_synth bus k g =
let g' = maybe (out bus g) (flip (with_env bus) g) k
in synthdef (gen_nm g) g'
gen_synth' :: UGen -> Env_ST Double -> UGen -> Synthdef
gen_synth' bus k = gen_synth bus (Just k)
nrt_sy1 :: Int -> Synthdef -> [Double] -> NRT
nrt_sy1 grp sy dur =
let tm = dx_d' dur
f t = bundle t [s_new0 (synthdefName sy) (1) AddToHead grp]
in NRT (bundle 0 [d_recv sy] : map f tm)
nrt_sy :: Int -> [Synthdef] -> [Time] -> NRT
nrt_sy grp sy dur =
let tm = dx_d' dur
f t s = bundle t [d_recv s
,s_new0 (synthdefName s) (1) AddToHead grp]
in NRT (zipWith f tm sy)
type OverlapTexture = (Double,Double,Double,Int)
data OverlapTexture_ =
OverlapTexture {sustain_time :: Double
,transition_time :: Double
,overlaps :: Double
,max_repeats :: Int}
overlapTexture_env :: OverlapTexture -> Env_ST Double
overlapTexture_env (s,t,_,_) = (s,t)
overlapTexture_iot :: OverlapTexture -> Double
overlapTexture_iot (s,t,o,_) = (t + s + t) / o
overlapTexture_nrt :: Loc_GB -> OverlapTexture -> UGen -> NRT
overlapTexture_nrt (grp,bus) k g =
let s = gen_synth' bus (overlapTexture_env k) g
d = overlapTexture_iot k
(_,_,_,c) = k
in nrt_sy1 grp s (replicate c d)
overlapTextureU :: OverlapTexture -> UGen -> IO ()
overlapTextureU t = audition . overlapTexture_nrt (1,0) t
type XFadeTexture = (Double,Double,Int)
xfadeTexture_env :: XFadeTexture -> Env_ST Double
xfadeTexture_env (s,t,_) = (s,t)
xfadeTexture_iot :: XFadeTexture -> Double
xfadeTexture_iot (s,t,_) = s + t
xfadeTexture_nrt :: Loc_GB -> XFadeTexture -> UGen -> NRT
xfadeTexture_nrt (grp,bus) k g =
let s = gen_synth' bus (xfadeTexture_env k) g
d = xfadeTexture_iot k
(_,_,c) = k
in nrt_sy1 grp s (replicate c d)
xfadeTextureU :: XFadeTexture -> UGen -> IO ()
xfadeTextureU t = audition . xfadeTexture_nrt (1,0) t
type Spawn_Texture = (Int -> Double,Int)
spawnTexture_nrt :: Loc_GB -> Spawn_Texture -> UGen -> NRT
spawnTexture_nrt (grp,bus) (t,c) g = nrt_sy1 grp (gen_synth bus Nothing g) (map t [0 .. c 1])
spawnTextureU :: Spawn_Texture -> UGen -> IO ()
spawnTextureU sp = audition . spawnTexture_nrt (1,0) sp
type PP_Bus = Either UGen (UGen,UGen)
post_process_s :: Int -> PP_Bus -> (UGen -> UGen) -> Synthdef
post_process_s nc b f =
let (src,dst,wr) = case b of
Left b' -> (b',b',replaceOut)
Right (b',b'') -> (b',b'',out)
i = in' nc AR src
u = wr dst (f i)
in synthdef (gen_nm u) u
post_process :: (Transport m) => Int -> PP_Bus -> Int -> (UGen -> UGen) -> m ()
post_process nc bus grp f = do
let s = post_process_s nc bus f
_ <- async (d_recv s)
send (s_new0 (synthdefName s) (1) AddToTail grp)
post_process_nrt :: (Transport m) => Loc_GB -> NRT -> Int -> (UGen -> UGen) -> m ()
post_process_nrt (grp,bus) sc nc f = post_process nc (Left bus) grp f >> play sc
type PPF = (UGen -> UGen)
overlapTextureU_pp :: OverlapTexture -> UGen -> Int -> PPF -> IO ()
overlapTextureU_pp k u nc f = do
let p = overlapTexture_nrt (1,0) k u
withSC3 (post_process_nrt (1,0) p nc f)
xfadeTextureU_pp :: XFadeTexture -> UGen -> Int -> PPF -> IO ()
xfadeTextureU_pp k u nc f = do
let p = xfadeTexture_nrt (1,0) k u
withSC3 (post_process_nrt (1,0) p nc f)
type USTF st = (st -> (UGen,st))
overlapTexture_nrt_st :: Loc_GB -> OverlapTexture -> USTF st -> st -> NRT
overlapTexture_nrt_st (grp,bus) k u i_st =
let d = overlapTexture_iot k
(_,_,_,c) = k
g = take c (unfoldr (Just . u) i_st)
s = map (gen_synth' bus (overlapTexture_env k)) g
in nrt_sy grp s (replicate c d)
overlapTextureS :: OverlapTexture -> USTF st -> st -> IO ()
overlapTextureS t f = audition . overlapTexture_nrt_st (1,0) t f
overlapTextureS_pp :: OverlapTexture -> USTF st -> st -> Int -> PPF -> IO ()
overlapTextureS_pp k u i_st nc f = do
let sc = overlapTexture_nrt_st (1,0) k u i_st
withSC3 (post_process_nrt (1,0) sc nc f)
type MSTF st m = (st -> m (Maybe st))
dt_rescheduler_m :: MonadIO m => MSTF (st,Time) m -> (st,Time) -> m ()
dt_rescheduler_m f =
let recur (st,t) = do
pauseThreadUntil t
r <- f (st,t)
case r of
Just (st',dt) -> recur (st',t + dt)
Nothing -> return ()
in recur
overlapTextureR :: Transport m =>
OverlapTexture -> IO UGen -> MSTF (Int,Time) m
overlapTextureR k uf =
let nm = "ot_" ++ show k
dt = overlapTexture_iot k
in \(st,_) -> do
u <- liftIO uf
let g = with_env 0 (overlapTexture_env k) u
_ <- async (d_recv (synthdef nm g))
send (s_new0 nm (1) AddToTail 1)
case st of
0 -> return Nothing
_ -> return (Just (st1,dt))
overlapTextureM :: OverlapTexture -> IO UGen -> IO ()
overlapTextureM k u = do
t <- time
let (_,_,_,c) = k
withSC3 (dt_rescheduler_m (overlapTextureR k u) (c,t))