module Sound.SC3.Lang.Control.OverlapTexture where
import Control.Applicative
import Data.List
import Sound.OSC
import Sound.SC3
import Sound.SC3.Lang.Control.Event
import Sound.SC3.Lang.Control.Instrument
import Sound.SC3.Lang.Pattern.ID
mk_env :: UGen -> 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 -> UGen -> UGen
with_env_u g a = out 0 . (*) g . mk_env a
with_env :: (Double,Double) -> UGen -> UGen
with_env (s,t) g = with_env_u g (constant s) (constant t)
type OverlapTexture = (Double,Double,Double,Int)
data OverlapTexture_ =
OverlapTexture {sustain_time :: Double
,transition_time :: Double
,overlaps :: Double
,max_repeats :: Int}
overlapTexture_env :: OverlapTexture -> (Double,Double)
overlapTexture_env (s,t,_,_) = (s,t)
type Texture_DT = (Double,Double)
overlapTexture_dt :: OverlapTexture -> Texture_DT
overlapTexture_dt (s,t,o,_) = (o,(t + s + t) / o)
type XFadeTexture = (Double,Double,Int)
xfadeTexture_env :: XFadeTexture -> (Double,Double)
xfadeTexture_env (s,t,_) = (s,t)
xfadeTexture_dt :: XFadeTexture -> Texture_DT
xfadeTexture_dt (s,t,_) = let r = t + s in ((r + t) / r,r)
gen_synth :: (Double,Double) -> UGen -> Synthdef
gen_synth k g =
let n = show (hashUGen g)
g' = with_env k g
in synthdef n g'
overlapTextureP :: OverlapTexture -> UGen -> P Event
overlapTextureP k g =
let s = gen_synth (overlapTexture_env k) g
(l,d) = overlapTexture_dt k
(_,_,_,c) = k
in pbind [(K_instr,pinstr' (Instr_Def s False))
,(K_dur,pn (return (F_Double d)) c)
,(K_legato,pure (F_Double l))]
overlapTextureU :: OverlapTexture -> UGen -> IO ()
overlapTextureU k = audition . overlapTextureP k
post_process_s :: Int -> (UGen -> UGen) -> Synthdef
post_process_s nc f =
let i = in' nc AR 0
u = replaceOut 0 (f i)
nm = show (hashUGen u)
in synthdef nm u
post_process_a :: (Transport m) => P Event -> Int -> (UGen -> UGen) -> m ()
post_process_a p nc f = do
let s = post_process_s nc f
_ <- async (d_recv s)
send (s_new0 (synthdefName s) (1) AddToTail 2)
play p
type PPF = (UGen -> UGen)
overlapTextureU_pp :: OverlapTexture -> UGen -> Int -> PPF -> IO ()
overlapTextureU_pp k u nc f = do
let p = overlapTextureP k u
withSC3 (post_process_a p nc f)
xfadeTextureP :: XFadeTexture -> UGen -> P Event
xfadeTextureP k g =
let s = gen_synth (xfadeTexture_env k) g
(l,d) = xfadeTexture_dt k
(_,_,c) = k
in pbind [(K_instr,pinstr' (Instr_Def s False))
,(K_dur,pn (return (F_Double d)) c)
,(K_legato,pure (F_Double l))]
xfadeTextureU :: XFadeTexture -> UGen -> IO ()
xfadeTextureU k = audition . xfadeTextureP k
xfadeTextureU_pp :: XFadeTexture -> UGen -> Int -> PPF -> IO ()
xfadeTextureU_pp k u nc f = do
let p = xfadeTextureP k u
withSC3 (post_process_a p nc f)
type USTF st = (st -> (UGen,st))
overlapTextureP_st :: OverlapTexture -> USTF st -> st -> P Event
overlapTextureP_st k u i_st =
let (l,d) = overlapTexture_dt k
(_,_,_,c) = k
g = take c (unfoldr (Just . u) i_st)
i = flip Instr_Def False
s = toP (map (i . gen_synth (overlapTexture_env k)) g)
in pbind [(K_instr,fmap F_Instr s)
,(K_dur,pure (F_Double d))
,(K_legato,pure (F_Double l))]
overlapTextureS :: OverlapTexture -> USTF st -> st -> IO ()
overlapTextureS k u = audition . overlapTextureP_st k u
overlapTextureS_pp :: OverlapTexture -> USTF st -> st -> Int -> PPF -> IO ()
overlapTextureS_pp k u i_st nc f = do
let p = overlapTextureP_st k u i_st
withSC3 (post_process_a p 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 rec (st,t) = do
pauseThreadUntil t
r <- f (st,t)
case r of
Just (st',dt) -> rec (st',t + dt)
Nothing -> return ()
in rec
overlapTextureR :: Transport m =>
OverlapTexture -> IO UGen -> MSTF (Int,Time) m
overlapTextureR k uf =
let nm = "ot_" ++ show k
(_,dt) = overlapTexture_dt k
in \(st,_) -> do
u <- liftIO uf
let g = with_env (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))