module Sound.SC3.Common.Envelope where
import Data.List
import Data.Maybe
import qualified Sound.SC3.Common.Base as Base
import qualified Sound.SC3.Common.Math.Interpolate as I
data Envelope_Curve a = EnvStep
| EnvLin
| EnvExp
| EnvSin
| EnvWelch
| EnvNum a
| EnvSqr
| EnvCub
| EnvHold
deriving (Eq, Show)
type Envelope_Curve_2 a = Base.T2 (Envelope_Curve a)
type Envelope_Curve_3 a = Base.T3 (Envelope_Curve a)
type Envelope_Curve_4 a = Base.T4 (Envelope_Curve a)
env_curve_shape :: Num a => Envelope_Curve a -> a
env_curve_shape e =
case e of
EnvStep -> 0
EnvLin -> 1
EnvExp -> 2
EnvSin -> 3
EnvWelch -> 4
EnvNum _ -> 5
EnvSqr -> 6
EnvCub -> 7
EnvHold -> 8
env_curve_value :: Num a => Envelope_Curve a -> a
env_curve_value e =
case e of
EnvNum u -> u
_ -> 0
env_curve_interpolation_f :: (Ord t, Floating t) => Envelope_Curve t -> I.Interpolation_F t
env_curve_interpolation_f c =
case c of
EnvStep -> I.step
EnvLin -> I.linear
EnvExp -> I.exponential
EnvSin -> I.sine
EnvWelch -> I.welch
EnvNum n -> I.curve n
EnvSqr -> I.squared
EnvCub -> I.cubed
EnvHold -> undefined
env_curve_coerce :: (a -> b) -> Envelope_Curve a -> Envelope_Curve b
env_curve_coerce f e =
case e of
EnvStep -> EnvStep
EnvLin -> EnvLin
EnvExp -> EnvExp
EnvSin -> EnvSin
EnvWelch -> EnvWelch
EnvNum x -> EnvNum (f x)
EnvSqr -> EnvSqr
EnvCub -> EnvCub
EnvHold -> EnvHold
data Envelope a =
Envelope {env_levels :: [a]
,env_times :: [a]
,env_curves :: [Envelope_Curve a]
,env_release_node :: Maybe Int
,env_loop_node :: Maybe Int
,env_offset :: a
}
deriving (Eq,Show)
envelope_coerce :: (a -> b) -> Envelope a -> Envelope b
envelope_coerce f e =
let Envelope l t c rn ln os = e
in Envelope (map f l) (map f t) (map (env_curve_coerce f) c) rn ln (f os)
envelope :: Num a => [a] -> [a] -> [Envelope_Curve a] -> Envelope a
envelope l t c = Envelope l t c Nothing Nothing 0
envelope_duration :: Num n => Envelope n -> n
envelope_duration = sum . env_times
envelope_n_segments :: Integral i => Envelope n -> i
envelope_n_segments = genericLength . env_times
envelope_segment_ix :: (Ord a, Num a) => Envelope a -> a -> Maybe Int
envelope_segment_ix e t =
let d = Base.dx_d (env_times e)
in findIndex (>= t) d
type Envelope_Segment t = (t,t,t,t,Envelope_Curve t)
envelope_segment :: Num t => Envelope t -> Int -> Envelope_Segment t
envelope_segment e i =
let l = env_levels e
t = env_times e
x0 = l !! i
x1 = l !! (i + 1)
t0 = (0 : Base.dx_d t) !! i
t1 = t0 + t !! i
c = envelope_curves e !! i
in (t0,x0,t1,x1,c)
envelope_segments :: Num t => Envelope t -> [Envelope_Segment t]
envelope_segments e =
let n = envelope_n_segments e
in map (envelope_segment e) [0 .. n - 1]
pack_envelope_segments :: Num t => [Envelope_Segment t] -> ([t],[t],[Envelope_Curve t])
pack_envelope_segments s =
case s of
[] -> error ""
[(t0,l0,t1,l1,c)] -> ([l0,l1],[t1 - t0],[c])
(_,l0,_,_,_) : _ ->
let t (t0,_,t1,_,_) = t1 - t0
c (_,_,_,_,x) = x
l (_,_,_,x,_) = x
in (l0 : map l s,map t s,map c s)
envelope_is_normal :: (Eq n,Num n) => Envelope n -> Bool
envelope_is_normal = not . any (== 0) . env_times
envelope_normalise :: (Num a, Ord a) => Envelope a -> Envelope a
envelope_normalise e =
let s = envelope_segments e
f (t0,_,t1,_,_) = t1 <= t0
s' = filter (not . f) s
(l,t,c) = pack_envelope_segments s'
in case e of
Envelope _ _ _ Nothing Nothing os -> Envelope l t c Nothing Nothing os
_ -> error "envelope_normalise: has release or loop node..."
envelope_at :: (Ord t, Floating t) => Envelope t -> t -> t
envelope_at e t =
case envelope_segment_ix e t of
Just n -> let (t0,x0,t1,x1,c) = envelope_segment e n
d = t1 - t0
t' = (t - t0) / d
f = env_curve_interpolation_f c
in if d <= 0
then x1
else f x0 x1 t'
Nothing -> 0
envelope_render :: (Ord t, Floating t, Enum t) => Int -> Envelope t -> [(t,t)]
envelope_render n e =
let d = envelope_duration e
k = d / (fromIntegral n - 1)
t = [0,k .. d]
in zip t (map (envelope_at e) t)
envelope_table :: (Ord t, Floating t, Enum t) => Int -> Envelope t -> [t]
envelope_table n = map snd . envelope_render n
envelope_curves :: Envelope a -> [Envelope_Curve a]
envelope_curves e =
let c = env_curves e
n = envelope_n_segments e
in if null c
then replicate n EnvLin
else take n (cycle c)
envelope_sc3_array :: Num a => Envelope a -> Maybe [a]
envelope_sc3_array e =
let Envelope l t _ rn ln _ = e
n = length t
n' = fromIntegral n
rn' = fromIntegral (fromMaybe (-99) rn)
ln' = fromIntegral (fromMaybe (-99) ln)
c = envelope_curves e
f i j k = [i,j,env_curve_shape k,env_curve_value k]
in case l of
l0:l' -> Just (l0 : n' : rn' : ln' : concat (zipWith3 f l' t c))
_ -> Nothing
envelope_sc3_ienvgen_array :: Num a => Envelope a -> Maybe [a]
envelope_sc3_ienvgen_array e =
let Envelope l t _ _ _ os = e
n = length t
n' = fromIntegral n
c = envelope_curves e
f i j k = [j,env_curve_shape k,env_curve_value k,i]
in case l of
l0:l' -> Just (os : l0 : n' : sum t : concat (zipWith3 f l' t c))
_ -> Nothing
env_is_sustained :: Envelope a -> Bool
env_is_sustained = isJust . env_release_node
env_delay :: Envelope a -> a -> Envelope a
env_delay (Envelope l t c rn ln os) d =
let (l0:_) = l
l' = l0 : l
t' = d : t
c' = EnvLin : c
rn' = fmap (+ 1) rn
ln' = fmap (+ 1) ln
in Envelope l' t' c' rn' ln' os
env_circle_z :: Fractional a => a -> a -> Envelope_Curve a -> Envelope a -> Envelope a
env_circle_z z tc cc (Envelope l t c rn _ os) =
let n = length t
in case rn of
Nothing -> let l' = 0 : l ++ [0]
t' = z * tc : t ++ [1]
c' = cc : take n (cycle c) ++ [EnvLin]
rn' = Just (n + 1)
in Envelope l' t' c' rn' (Just 0) os
Just i -> let l' = 0 : l
t' = z * tc : t
c' = cc : take n (cycle c)
rn' = Just (i + 1)
in Envelope l' t' c' rn' (Just 0) os
env_circle_0 :: Fractional a => Envelope a -> Envelope a
env_circle_0 = env_circle_z 1 0 EnvLin
envTrapezoid_f :: Num t => (t -> t -> t,t -> t -> t) -> t -> t -> t -> t -> Envelope t
envTrapezoid_f (lte_f,gte_f) shape skew dur amp =
let x1 = skew * (1 - shape)
bp = [(0,lte_f skew 0)
,(x1,1)
,(shape + x1,1)
,(1,gte_f skew 1)]
in envCoord bp dur amp EnvLin
envCoord :: Num n => [(n,n)] -> n -> n -> Envelope_Curve n -> Envelope n
envCoord xy dur amp c =
let n = length xy
(times,levels) = unzip xy
times' = map (* dur) (Base.d_dx' times)
levels' = map (* amp) levels
offset = times' !! 0
in Envelope levels' times' (replicate (n - 1) c) Nothing Nothing offset
envPairs :: (Num n,Ord n) => [(n,n)] -> Envelope_Curve n -> Envelope n
envPairs xy c = envCoord (sortOn fst xy) 1 1 c
envPerc_c :: Num a => a -> a -> a -> Envelope_Curve_2 a -> Envelope a
envPerc_c atk rls lvl (c0,c1) =
let c = [c0,c1]
in Envelope [0,lvl,0] [atk,rls] c Nothing Nothing 0
envPerc :: Num a => a -> a -> Envelope a
envPerc atk rls =
let cn = EnvNum (-4)
in envPerc_c atk rls 1 (cn,cn)
envTriangle :: Fractional a => a -> a -> Envelope a
envTriangle dur lvl =
let c = replicate 2 EnvLin
d = replicate 2 (dur / 2)
in Envelope [0,lvl,0] d c Nothing Nothing 0
envSine :: Fractional a => a -> a -> Envelope a
envSine dur lvl =
let c = replicate 2 EnvSin
d = replicate 2 (dur / 2)
in Envelope [0,lvl,0] d c Nothing Nothing 0
data LINEN a = LINEN {linen_attackTime :: a
,linen_sustainTime :: a
,linen_releaseTime :: a
,linen_level :: a
,linen_curve :: Envelope_Curve_3 a}
linen_def :: Fractional t => LINEN t
linen_def = let c = EnvLin in LINEN 0.01 1 1 1 (c,c,c)
envLinen_r :: Num a => LINEN a -> Envelope a
envLinen_r (LINEN aT sT rT lv (c0,c1,c2)) =
let l = [0,lv,lv,0]
t = [aT,sT,rT]
c = [c0,c1,c2]
in Envelope l t c Nothing Nothing 0
envLinen_c :: Num a => a -> a -> a -> a -> Envelope_Curve_3 a -> Envelope a
envLinen_c aT sT rT lv c = envLinen_r (LINEN aT sT rT lv c)
envLinen :: Num a => a -> a -> a -> a -> Envelope a
envLinen aT sT rT lv =
let c = (EnvLin,EnvLin,EnvLin)
in envLinen_c aT sT rT lv c
data ADSR a = ADSR {adsr_attackTime :: a
,adsr_decayTime :: a
,adsr_sustainLevel :: a
,adsr_releaseTime :: a
,adsr_peakLevel :: a
,adsr_curve :: Envelope_Curve_3 a
,adsr_bias :: a}
adsr_def :: Fractional n => ADSR n
adsr_def = let c = EnvNum (-4) in ADSR 0.01 0.3 0.5 1 1 (c,c,c) 0
envADSR :: Num a => a -> a -> a -> a -> a -> Envelope_Curve a -> a -> Envelope a
envADSR aT dT sL rT pL c b = envADSR_r (ADSR aT dT sL rT pL (c,c,c) b)
envADSR_def :: Num a => a -> a -> a -> a -> Envelope a
envADSR_def aT dT sL rT = envADSR aT dT sL rT 1 (EnvNum (-4)) 0
envADSR_r :: Num a => ADSR a -> Envelope a
envADSR_r (ADSR aT dT sL rT pL (c0,c1,c2) b) =
let l = map (+ b) [0,pL,pL*sL,0]
t = [aT,dT,rT]
c = [c0,c1,c2]
in Envelope l t c (Just 2) Nothing 0
data ADSSR a = ADSSR {adssr_attackTime :: a
,adssr_attackLevel :: a
,adssr_decayTime :: a
,adssr_decayLevel :: a
,adssr_slopeTime :: a
,adssr_sustainLevel :: a
,adssr_releaseTime :: a
,adssr_curve :: Envelope_Curve_4 a
,adssr_bias :: a}
envADSSR :: Num a => a -> a -> a -> a -> a -> a -> a -> Envelope_Curve a -> a -> Envelope a
envADSSR t1 l1 t2 l2 t3 l3 t4 c b = envADSSR_r (ADSSR t1 l1 t2 l2 t3 l3 t4 (c,c,c,c) b)
envADSSR_r :: Num a => ADSSR a -> Envelope a
envADSSR_r (ADSSR t1 l1 t2 l2 t3 l3 t4 (c1,c2,c3,c4) b) =
let l = map (+ b) [0,l1,l2,l3,0]
t = [t1,t2,t3,t4]
c = [c1,c2,c3,c4]
in Envelope l t c (Just 3) Nothing 0
data ASR a = ASR {asr_attackTime :: a
,asr_sustainLevel :: a
,asr_releaseTime :: a
,asr_curve :: Envelope_Curve_2 a}
asr_def :: Fractional t => ASR t
asr_def = let c = EnvNum (-4) in ASR 0.01 1 1 (c,c)
envASR_c :: Num a => a -> a -> a -> Envelope_Curve_2 a -> Envelope a
envASR_c aT sL rT c = envASR_r (ASR aT sL rT c)
envASR :: Num a => a -> a -> a -> Envelope_Curve a -> Envelope a
envASR aT sL rT c = envASR_c aT sL rT (c,c)
envASR_r :: Num a => ASR a -> Envelope a
envASR_r (ASR aT sL rT (c0,c1)) =
let l = [0,sL,0]
t = [aT,rT]
c' = [c0,c1]
in Envelope l t c' (Just 1) Nothing 0
envStep :: Num a => [a] -> [a] -> Maybe Int -> Maybe Int -> Envelope a
envStep levels times releaseNode loopNode =
if length levels /= length times
then error "envStep: levels and times must have same size"
else let levels' = head levels : levels
in Envelope levels' times [EnvStep] releaseNode loopNode 0
envXYC :: (Num n,Ord n) => [(n,n,Envelope_Curve n)] -> Envelope n
envXYC xyc =
let n = length xyc
xyc_asc = sortOn (\(x,_,_) -> x) xyc
(times,levels,curves) = unzip3 xyc_asc
offset = times !! 0
in Envelope levels (Base.d_dx' times) (take (n - 1) curves) Nothing Nothing offset