module Csound.Catalog.Wave.WoodwindAlg(
    WoodwindSpec(..), RangeSpec(..), HarmSpec(..), AmpSpec(..), WaveSpec,
    fromSpec, byFreq,
    woodwind
) where

import Data.List (transpose, intersperse)
import Control.Monad
import Control.Monad.Trans.State

import Csound.Base hiding (fromSpec)

----------------------------------------------------------------
-- Deterministic random numbers

newtype Rnd a = Rnd { unRnd :: State D a }

instance Functor Rnd where
    fmap f (Rnd a) = Rnd $ fmap f a

instance Applicative Rnd where
    pure = return
    (<*>) = ap

instance Monad Rnd where
    return = Rnd . return
    (Rnd a) >>= f = Rnd $ a >>= unRnd . f

evalRnd :: Rnd a -> D -> a
evalRnd = evalState . unRnd

rndNext :: Rnd ()
rndNext = Rnd $ modify $ frac' . (* 105.947)

rndGet :: Rnd D
rndGet = Rnd $ get

rndWithin :: (D, D) -> Rnd D
rndWithin (imin, imax) = do
    iseed <- rndGet
    rndNext
    return $ imin + (imax - imin) * iseed

----------------------------------------------------------------
-- tools

randiPct :: D -> D -> Sig -> Rnd Sig
randiPct pct cps asig = do
    iseed <- rndWithin (0, 1)
    return $ asig * (1 + (randi (sig pct) (sig cps) `withSeed` iseed))

minDt :: D -> D -> D
minDt n x = maxB x (n / getControlRate)

----------------------------------------------------------------
-- algorithm parameters

-- | Winds algorithm specification.
data WoodwindSpec = WoodwindSpec
    { woodwindRange         :: (D, D, D) -> D -> ([(Sig, Tab)], D)
    , woodwindVibratoDur    :: (D, D, D) -> D
    , woodwindFreqDeviation :: ((D, D), (D, D), (D, D), (D, D)) }

-- | Harmonics per pitch range.
data RangeSpec = RangeSpec
    { rangeFreq     :: D
    , rangeNorm     :: D
    , rangeHarms    :: [HarmSpec] }

-- | The harmonics.
data HarmSpec = HarmSpec
    { harmAmp   :: AmpSpec
    , harmWave  :: WaveSpec }

-- | Envelopes for linseg
data AmpSpec = AmpSpec
    { ampAttack     :: [D]
    , ampSustain    :: [D]
    , ampDecay      :: [D] }

-- | Not scaled sine harmonics.
type WaveSpec = [Double]

----------------------------------------------------------------
-- The algorithm

-- | An emulation of the woodwindinstruments. Parameters
--
-- > woodwind spec seed vibDepth attack sustain decay brightnessLevel cps = 
--
--
-- * spec - a specification of the algorithm
--
-- * seed - a seed for the random signals/numbers. It's in (0, 1)
--
-- * vibDepth -  Amount of the vibrato. It's in [-1, 1]
--
-- * attack - duration of the attack
--
-- * sustain - duration of the sustain
--
-- * decay - duration of the decay
--
-- * brightnessLevel - Controls the frequency of the low-pass filter. It's in (0, 1)
woodwind :: WoodwindSpec -> D -> D -> D -> D -> D -> D -> D -> Sig
woodwind spec seedVal vibPercent attack sustain decay brightnessLevel cps =
    evalRnd (rndWoodwind spec vibPercent attack sustain decay brightnessLevel cps) seedVal

rndWoodwind :: WoodwindSpec -> D -> D -> D -> D -> D -> D -> Rnd Sig
rndWoodwind spec vibCoeff attack sustain decay brightnessLevel cps = do
    iphase  <- rndWithin (0, 1)
    durs    <- initDurations
    kfreq   <- woodwindVibrato (woodwindVibratoDur spec durs) =<< (freqDeviation (woodwindFreqDeviation spec) durs $ sig cps)

    let (harms1, inorm) = woodwindRange spec durs cps
    harms2 <- mapM (ampVarOnHarm 0.02) harms1
    return $ brightness durs brightnessLevel $ sumHarms harms2 inorm iphase kfreq
    where
        initDurations :: Rnd (D, D, D)
        initDurations = do
            iattack <- rndWithin (attack * 0.9, attack * 1.1)
            idecay  <- rndWithin (decay  * 0.9, decay  * 1.1)
            return (minDt 6 iattack, minDt 5 sustain, minDt 6 idecay)

        woodwindVibrato :: D -> Sig -> Rnd Sig
        woodwindVibrato xdur asig = do
            let ivibdepth = abs (vibCoeff * cps)
            kvibdepth <- randiPct 0.1 5 $ sig ivibdepth * linseg [0.1, 0.8 * xdur, 1, 0.2 * xdur, 0.7]
            ~ [ivibr1, ivibr2, ivibr3] <- mapM rndWithin $ replicate 3 (0, 1)
            kvibrate <- randiPct 0.1 5 $
                ifB (sig vibCoeff >* 0)
                    -- if vibrato is positive it gets faster
                    (linseg [2.5 + ivibr1, xdur, 4.5 + ivibr2])
                    -- if vibrato is negative it gets slower
                    (linseg [3.5 + ivibr1, 0.1, 4.5 + ivibr2, xdur - 0.1, 2.5 + ivibr3])
            return $ asig + kvibdepth * osc kvibrate

        freqDeviation :: ((D, D), (D, D), (D, D), (D, D)) -> (D, D, D) -> Sig -> Rnd Sig
        freqDeviation (f1, f2, f3, f4) (iattack, isustain, idecay) asig = do
            ~ [fdev1, fdev2, fdev3, fdev4] <- mapM rndWithin [f1, f2, f3, f4]
            return $ asig * (1 + linseg [fdev1, iattack, fdev2, isustain, fdev3, idecay, fdev4])

        ampVar :: D -> Sig -> Rnd Sig
        ampVar pct = randiPct pct 10

        ampVarOnHarm :: D -> (Sig, Tab) -> Rnd (Sig, Tab)
        ampVarOnHarm perct (amp, wt) = fmap (\x -> (x, wt)) $ ampVar perct amp

        sumHarms :: [(Sig, Tab)] -> D -> D -> Sig -> Sig
        sumHarms hs norm iphase kfreq = ( / sig norm) $ mean $
            fmap (\(amp, wt) -> oscili amp kfreq wt `withD` iphase) hs

        brightness :: (D, D, D) -> D -> Sig -> Sig
        brightness (iattack, isustain, idecay) level asig = balance (tone asig env) asig
            where ifiltcut = tablei (9 * level) (skipNorm $ doubles [40, 40, 80, 160, 320, 640, 1280, 2560, 5120, 10240, 10240])
                  env = linseg [0, iattack, ifiltcut, isustain, ifiltcut, idecay, 0]

----------------------------------------------------------------
-- Converting specification to signals

fromSpec :: [RangeSpec] -> (D, D, D) -> D -> ([(Sig, Tab)], D)
fromSpec specs durs ifreq = (hs, inorm)
    where
        inorm = byFreq ifreq $ fmap (\x -> (rangeFreq x, rangeNorm x)) specs
        hs    = fmap (byFreq ifreq . zip freqs . fmap (fromHarmSpec durs)) $ transpose $ fmap rangeHarms specs

        freqs = fmap rangeFreq specs

byFreq :: Tuple a => D -> [(D, a)] -> a
byFreq ifreq as = guardedTuple (fmap (\(cps, val) -> (sig ifreq `lessThan` sig cps, val)) $ init as) (snd $ last as)


fromHarmSpec :: (D, D, D) -> HarmSpec -> (Sig, Tab)
fromHarmSpec durs spec = (fromAmpSpec durs $ harmAmp spec, fromWaveSpec $ harmWave spec)

fromAmpSpec :: (D, D, D) -> AmpSpec -> Sig
fromAmpSpec (attack, sustain, decay) spec = linseg $ att ++ (tail sus) ++ (tail dec)
    where phi dt select = intersperse (dt / fromIntegral (pred $ length $ select spec)) (select spec)
          att = phi attack  ampAttack
          sus = phi sustain ampSustain
          dec = phi decay   ampDecay

fromWaveSpec :: WaveSpec -> Tab
fromWaveSpec = skipNorm . sines