-- | Envelope generators.
module Sound.SC3.Common.Envelope where

import Data.List {- base -}
import Data.Maybe {- base -}

import qualified Sound.SC3.Common.Base as Base
import qualified Sound.SC3.Common.Math.Interpolate as I

-- * Curve

-- | Envelope curve indicator input.
data Envelope_Curve a = EnvStep
                      | EnvLin
                      | EnvExp
                      | EnvSin
                      | EnvWelch -- ^ Note: not implemented at SC3
                      | EnvNum a
                      | EnvSqr
                      | EnvCub
                      | EnvHold
                        deriving (Eq, Show)

-- | Envelope curve pair.
type Envelope_Curve_2 a = Base.T2 (Envelope_Curve a)

-- | Envelope curve triple.
type Envelope_Curve_3 a = Base.T3 (Envelope_Curve a)

-- | Envelope curve quadruple.
type Envelope_Curve_4 a = Base.T4 (Envelope_Curve a)

-- | Convert 'Envelope_Curve' to shape value.
--
-- > map env_curve_shape [EnvSin,EnvSqr] == [3,6]
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

-- | The /value/ of 'EnvCurve' is non-zero for 'EnvNum'.
--
-- > map env_curve_value [EnvWelch,EnvNum 2] == [0,2]
env_curve_value :: Num a => Envelope_Curve a -> a
env_curve_value e =
    case e of
      EnvNum u -> u
      _ -> 0

-- | 'Interpolation_F' of 'Envelope_Curve'.
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

-- | Apply /f/ to 'EnvNum' value.
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

-- * Envelope

-- | SC3 envelope segment model
data Envelope a =
    Envelope {env_levels :: [a] -- ^ Set of /n/ levels, n is >= 1
             ,env_times :: [a] -- ^ Set of /n-1/ time intervals
             ,env_curves :: [Envelope_Curve a] -- ^ Possibly empty curve set
             ,env_release_node :: Maybe Int -- ^ Maybe index to release node
             ,env_loop_node :: Maybe Int -- ^ Maybe index to loop node
             ,env_offset :: a -- ^ An offset for all time values (IEnvGen only)
             }
    deriving (Eq,Show)

-- | Apply /f/ to all /a/ at 'Envelope'.
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)

-- | fmap = 'envelope_coerce'
instance Functor Envelope where
  fmap = envelope_coerce

-- | Variant without release and loop node inputs (defaulting to nil).
envelope :: Num a => [a] -> [a] -> [Envelope_Curve a] -> Envelope a
envelope l t c = Envelope l t c Nothing Nothing 0

-- | Duration of 'Envelope', ie. 'sum' '.' 'env_times'.
envelope_duration :: Num n => Envelope n -> n
envelope_duration = sum . env_times

-- | Number of segments at 'Envelope', ie. 'length' '.' 'env_times'.
envelope_n_segments :: Integral i => Envelope n -> i
envelope_n_segments = genericLength . env_times

-- | Determine which envelope segment a given time /t/ falls in.
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

-- | A set of start time, start level, end time, end level and curve.
type Envelope_Segment t = (t,t,t,t,Envelope_Curve t)

-- | Extract envelope segment given at index /i/.
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)

-- | Extract all segments.
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]

-- | Transform list of 'Envelope_Segment's into lists ('env_levels','env_times','env_curves').
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)

-- | An envelope is /normal/ if it has no segments with zero duration.
envelope_is_normal :: (Eq n,Num n) => Envelope n -> Bool
envelope_is_normal = not . any (== 0) . env_times

-- | Normalise envelope by deleting segments of zero duration.
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..."

-- | Get value for 'Envelope' at time /t/, or zero if /t/ is out of
-- range.  By convention if the envelope has a segment of zero
-- duration we give the rightmost value.
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

-- | Render 'Envelope' to breakpoint set of /n/ equi-distant places.
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)

-- | Contruct a lookup table of /n/ places from 'Envelope'.
envelope_table :: (Ord t, Floating t, Enum t) => Int -> Envelope t -> [t]
envelope_table n = map snd . envelope_render n

-- | Variant on 'env_curves' that expands the, possibly empty, user
-- list by cycling (if not empty) or by filling with 'EnvLin'.
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)

-- | Linear SC3 form of 'Envelope' data.
--
-- Form is: l0 #t reset loop l1 t0 c0 c0' ...
--
-- > let {l = [0,0.6,0.3,1.0,0]
-- >     ;t = [0.1,0.02,0.4,1.1]
-- >     ;c = [EnvLin,EnvExp,EnvNum (-6),EnvSin]
-- >     ;e = Envelope l t c Nothing Nothing
-- >     ;r = [0,4,-99,-99,0.6,0.1,1,0,0.3,0.02,2,0,1,0.4,5,-6,0,1.1,3,0]}
-- > in envelope_sc3_array e == Just r
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

-- | @IEnvGen@ SC3 form of 'Envelope' data.
--
-- > let {l = [0,0.6,0.3,1.0,0]
-- >     ;t = [0.1,0.02,0.4,1.1]
-- >     ;c = [EnvLin,EnvExp,EnvNum (-6),EnvSin]
-- >     ;e = Envelope l t c Nothing Nothing
-- >     ;r = [0,0,4,1.62,0.1,1,0,0.6,0.02,2,0,0.3,0.4,5,-6,1,1.1,3,0,0]}
-- > in envelope_sc3_ienvgen_array e == Just r
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

-- | 'True' if 'env_release_node' is not 'Nothing'.
env_is_sustained :: Envelope a -> Bool
env_is_sustained = isJust . env_release_node

-- | Delay the onset of the envelope (add initial segment).
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

-- | Connect releaseNode (or end) to first node of envelope.
-- z is a value that is first zero and thereafter one.
-- tc & cc are time and curve from first to last.
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] -- inf (but drawings are poor)
                        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_z with cycle time of zero.
env_circle_0 :: Fractional a => Envelope a -> Envelope a
env_circle_0 = env_circle_z 1 0 EnvLin

-- * Construct

{- | Trapezoidal envelope generator.

Requires (<=) and (>=) functions returning @1@ for true and @0@ for false.

The arguments are: 1. @shape@ determines the sustain time as a
proportion of @dur@, zero is a triangular envelope, one a rectangular
envelope; 2. @skew@ determines the attack\/decay ratio, zero is an
immediate attack and a slow decay, one a slow attack and an immediate
decay; 3. @duration@ in seconds; 4. @amplitude@ as linear gain.

-}
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

{- | Co-ordinate based static envelope generator.  Points are (time,value) pairs.

> let e = envCoord [(0,0),(1/4,1),(1,0)] 1 1 EnvLin
> envelope_sc3_array e == Just [0,2,-99,-99,1,1/4,1,0,0,3/4,1,0]

> import Sound.SC3.Plot {- hsc3-plot -}

> plotEnvelope [envCoord [(0,0),(1/4,1),(1,0)] 1 1 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

-- | Segments given as pairs of (time,level).
--   The input is sorted by time before processing.
--
-- > envPairs [(0, 1), (3, 1.4), (2.1, 0.5)] EnvSin
envPairs :: (Num n,Ord n) => [(n,n)] -> Envelope_Curve n -> Envelope n
envPairs xy c = envCoord (sortOn fst xy) 1 1 c

-- | Variant 'envPerc' with user specified 'Envelope_Curve a'.
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

-- | Percussive envelope, with attack, release, level and curve
--   inputs.
envPerc :: Num a => a -> a -> Envelope a
envPerc atk rls =
    let cn = EnvNum (-4)
    in envPerc_c atk rls 1 (cn,cn)

-- | Triangular envelope, with duration and level inputs.
--
-- > let e = envTriangle 1 0.1
-- > in envelope_sc3_array e = Just [0,2,-99,-99,0.1,0.5,1,0,0,0.5,1,0]
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

-- | Sine envelope, with duration and level inputs.
--
-- > let e = envSine 0 0.1
-- > in envelope_sc3_array e == Just [0,2,-99,-99,0.1,0,3.0,0,0,0,3,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

-- | Parameters for LINEN envelopes.
data LINEN a = LINEN {linen_attackTime :: a
                     ,linen_sustainTime :: a
                     ,linen_releaseTime :: a
                     ,linen_level :: a
                     ,linen_curve :: Envelope_Curve_3 a}

-- | SC3 defaults for LINEN.
linen_def :: Fractional t => LINEN t
linen_def = let c = EnvLin in LINEN 0.01 1 1 1 (c,c,c)

-- | Record ('LINEN') variant of 'envLinen'.
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

-- | Variant of 'envLinen' with user specified 'Envelope_Curve a'.
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)

-- | Linear envelope parameter constructor.
--
-- > let {e = envLinen 0 1 0 1
-- >     ;s = envelope_segments e
-- >     ;p = pack_envelope_segments s}
-- > in p == (env_levels e,env_times e,env_curves e)
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

-- | Parameters for ADSR envelopes.
--   The sustain level is given as a proportion of the peak level.
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}

-- | SC3 defaults for ADSR.
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

-- | Attack, decay, sustain, release envelope parameter constructor.
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)

-- | Variant with defaults for pL, c and 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

-- | Record ('ADSR') variant of 'envADSR'.
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

-- | Parameters for Roland type ADSSR envelopes.
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}

-- | Attack, decay, slope, sustain, release envelope parameter constructor.
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)

-- | Record ('ADSSR') variant of 'envADSSR'.
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

-- | Parameters for ASR envelopes.
data ASR a = ASR {asr_attackTime :: a
                 ,asr_sustainLevel :: a
                 ,asr_releaseTime :: a
                 ,asr_curve :: Envelope_Curve_2 a}

-- | SC3 default values for ASR.
asr_def :: Fractional t => ASR t
asr_def = let c = EnvNum (-4) in ASR 0.01 1 1 (c,c)

-- | SC3 .asr has singular curve argument, hence _c suffix.
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)

-- | Attack, sustain, release envelope parameter constructor.
--
-- > let {c = 3
-- >     ;r = Just [0,2,1,-99,0.1,3,c,0,0,2,c,0]}
-- > in envelope_sc3_array (envASR 3 0.1 2 EnvSin) == r
envASR :: Num a => a -> a -> a -> Envelope_Curve a -> Envelope a
envASR aT sL rT c = envASR_c aT sL rT (c,c)

-- | Record ('ASR') variant of 'envASR'.
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

-- | All segments are horizontal lines.
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

-- | Segments given as triples of (time,level,curve).  The final curve
-- is ignored. The input is sorted by time before processing.
--
-- > envXYC [(0, 1, EnvSin), (3, 1.4, EnvLin), (2.1, 0.5, EnvLin)]
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