module Sound.SC3.Auditor.Smplr where
import qualified Music.Theory.Tuning as T
import Sound.OSC
import Sound.SC3
fold_midi :: (Ord n,Num n,Num r,Fractional r) => (n,n) -> (r,n) -> (r,n)
fold_midi (l,r) (rt,mn) =
if mn < l
then fold_midi (l,r) (rt / 2,mn + 12)
else if mn > r
then fold_midi (l,r) (rt * 2,mn 12)
else (rt,mn)
type Param = [(String,Double)]
param_merge :: Param -> Param -> Param
param_merge p1 p2 =
let p2_k = map fst p2
p1' = filter (\(k,_) -> k `notElem` p2_k) p1
in p1' ++ p2
smplr :: (Bool,Bool) -> Synthdef
smplr (use_pan,use_gate) =
let b = control KR "bufnum" 0
l = control KR "pan" 0
a = control KR "amp" 0.1
r = control KR "rate" 1
m = control KR "rdelay" 0
v = control KR "ramplitude" 0
w = control KR "rpan" 0
u = control KR "attack" 0
y = control KR "decay" 0.5
g = control KR "gate" 1
sp = control KR "startpos" 0
bus = control KR "bus" 0
r' = bufRateScale KR b * r
lp = if use_gate then Loop else NoLoop
p = playBuf 1 AR b r' 1 sp lp DoNothing
e = if use_gate
then envGen KR g 1 0 1 RemoveSynth (envASR u 1 y EnvSin)
else let sus = control KR "sustain" 1
in envGen KR 1 1 0 1 RemoveSynth (envLinen u (sus u y) y 1)
d = delayC (p * e) m (rand 'a' 0 m)
s = d * (a + rand 'b' 0 v)
o = out bus (if use_pan then pan2 s (l + rand 'c' (w) w) 1 else s)
nm = if use_gate then "smplr-gt" else "smplr-du"
nm' = nm ++ if use_pan then "-pn" else "-ch"
in synthdef nm' o
mcons :: Maybe a -> [a] -> [a]
mcons e l = maybe l (: l) e
type SMPLR_OPT = ((Int,Int),String,Int,Int,(Double,Double),Int,Int,Param)
smplr_msg :: SMPLR_OPT -> (Int,Double) -> Maybe Double -> Double -> Message
smplr_msg (rng,ch,nid,b0,(aT,rT),bus,grp,p2) (m,dt) du g =
let (r,m') = fold_midi rng (1,m)
r' = r * T.cents_to_ratio dt
z = fst rng
i = m' z
b = b0 + i
sus = fmap (\du' -> ("sustain",realToFrac du')) du
p1 = [("bufnum",fromIntegral b)
,("rate",r')
,("amp",g)
,("attack",aT)
,("decay",rT)
,("rdelay",0.0015)
,("ramplitude",g * dbAmp (15))
,("bus",fromIntegral bus)
,("startpos",0)
]
nm = maybe "smplr-gt" (const "smplr-du") du
nm' = nm ++ "-" ++ ch
in s_new nm' nid AddToHead grp (mcons sus (param_merge p1 p2))
smplr_recv_all_msg :: [Message]
smplr_recv_all_msg =
let u = [False,True]
opt = [(a,b) | a <- u, b <- u]
in map (d_recv . smplr) opt
smplr_load_all :: IO ()
smplr_load_all = withSC3 (mapM_ async smplr_recv_all_msg)
smplr_nc_osc :: Int -> Message
smplr_nc_osc nc = d_recv (synthdef "smplr" (smplr_nc nc))
smplr_nc_load :: Int -> IO Message
smplr_nc_load nc = withSC3 (async (smplr_nc_osc nc))
smplr_nc :: Int -> UGen
smplr_nc nc =
let b = control KR "bufnum" 0
a = control KR "amp" 1
o = control KR "bus" 0
b_d = bufDur KR b
b_r = bufRateScale KR b
c = envCoord [(0,1),(1,1)] b_d 1 EnvLin
e = envGen KR 1 a 0 1 RemoveSynth c
in out o (playBuf nc AR b b_r 1 0 NoLoop DoNothing * e)