Smplr.hs

-- | Auditor sampler synthdef.
module Sound.SC3.Auditor.Smplr where

import qualified Music.Theory.Tuning as T {- hmt -}

import Sound.OSC {- hosc -}
import Sound.SC3 {- hsc3 -}

-- | If a note is not in range, shift until it is in range and set playback rate.
--
-- map (fold_midi (59,87)) [(1,50.5),(1,60.5),(1,90.5)] == [(0.5,62.5),(1.0,60.5),(2.0,78.5)]
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)]

-- | Right biased
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

{- | Trivial file playback instrument.  The /rdelay/ parameter sets
the maximum pre-delay time (in seconds), each instance is randomly
pre-delayed betwee zero and the indicated time.  The /ramplitude/
parameter sets the maximum amplitude offset of the /amp/ parameter,
each instance is randomly amplified between zero and the indicated
value.

If /use_gate/ is 'True' the synth ends either when the sound file
ends or the gate closes, else there is a /sustain/ parameter and a
linear envelope with a decay time of /decay/ is applied.

If /pan/ is 'True' the sampler pans according to the @pan@
parameter, else it writes directly to @bus@.

> let {u = [False,True]; opt = [(a,b) | a <- u, b <- u]}
> in withSC3 (mapM_ async (map (d_recv . smplr) opt))

> import Sound.SC3.Lang.Control.Event
> import Sound.SC3.Lang.Pattern.ID

> audition (pbind [(K_instr,psynth (smplr (True,True)))
>                 ,(K_param "bufnum",pseries 0 1 (29 * 3))
>                 ,(K_param "attack",0.25)
>                 ,(K_param "decay",0.15)
>                 ,(K_dur,0.35)])

> audition (pbind [(K_instr,psynth (smplr (True,True)))
>                 ,(K_param "bufnum",pwhitei 'a' 0 (6 * 6) inf)
>                 ,(K_param "startpos",0.15 * 48000)
>                 ,(K_param "attack",0.15)
>                 ,(K_amp,pwhite 'b' 0.15 0.65 inf)
>                 ,(K_param "pan",pwhite 'c' (-1) 1 inf)
>                 ,(K_dur,pwhite 'd' 0.15 1.65 inf)])

-}
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 -- frames
        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 (Just 0) [1..3] == [0..3]
mcons :: Maybe a -> [a] -> [a]
mcons e l = maybe l (: l) e

-- | Sampler options, (rng,ch,nid,b0,(aT,rT),bus,grp,p2)
--
-- ch = channel assignment mode, nid = node id, b0 = buffer zero, aT =
-- attack time, rT = release time, bus = output bus, grp = group to
-- allocate node at, p2 = further synthesis parameters
type SMPLR_OPT = ((Int,Int),String,Int,Int,(Double,Double),Int,Int,Param)

-- | Make @smplr@ control 'Message'.
--
-- m = midi note number, dt = detune (cents), du = duration, g = gain,
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) -- 0.05
             ,("decay",rT) -- 0.15
             ,("rdelay",0.0015)
             ,("ramplitude",g * dbAmp (-15))
             ,("bus",fromIntegral bus)
             ,("startpos",0) -- frames
             ]
        nm = maybe "smplr-gt" (const "smplr-du") du
        nm' = nm ++ "-" ++ ch
    in s_new nm' nid AddToHead grp (mcons sus (param_merge p1 p2))

-- | 'd_recv' messages for all smplr variants.
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

-- | Load all smplr variants.
smplr_load_all :: IO ()
smplr_load_all = withSC3 (mapM_ async smplr_recv_all_msg)

-- * NC

-- > withSC3 (async (smplr_nc_osc 2))
smplr_nc_osc :: Int -> Message
smplr_nc_osc nc = d_recv (synthdef "smplr" (smplr_nc nc))

-- > smplr_nc_load 2
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 -- buffer
        a = control KR "amp" 1 -- amplitude
        o = control KR "bus" 0 -- output channel
        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)