{-# Language FlexibleContexts #-}
-- | Effects
module Csound.Air.Fx(    
    -- * Reverbs
    reverbsc1, rever1, rever2, reverTime,
    smallRoom, smallHall, largeHall, magicCave,
    smallRoom2, smallHall2, largeHall2, magicCave2,

    room, chamber, hall, cave,

    -- ** Impulse Responce convolution reverbs
    --
    -- | Be careful with volumes. Some IRs can require scaling with really small coefficients like 0.01.
    -- 
    monoIR, stereoIR, stereoIR2, pmonoIR, pstereoIR, pstereoIR2, 
    monoIR', stereoIR', stereoIR2',
    ZConvSpec(..), zconv, zconv',

    -- * Delays
    MaxDelayTime, DelayTime, Feedback, Balance,
    echo, fdelay, fvdelay, fvdelays, funDelays, tabDelay,
    PingPongSpec(..), pingPong, pingPong', csdPingPong,

    -- * Distortion
    distortion,

    -- * Chorus
    DepthSig, RateSig, WidthSig, ToneSig,
    chorus,
    -- solinaChorus, testSolinaChorus,

    -- * Flanger
    flange,

    -- * Phase
    phase1, harmPhase, powerPhase,

    -- * Effects with unit parameters
    fxDistort, fxDistort2, stChorus2, fxPhaser, fxPhaser2,
    fxFlanger, fxFlanger2, analogDelay, analogDelay2, fxEcho, fxEcho2,
    fxFilter, fxFilter2,
    fxWhite, fxWhite2, fxPink, fxPink2, equalizer, equalizer2, eq4, eq7,
    fxGain, 

    -- Eq
    audaciousEq,

    -- * Misc
    trackerSplice

) where

import Data.Boolean
import Data.Default

import Csound.Typed
import Csound.Tab(sines4, startEnds, setSize, elins, newTab, tabSizeSecondsPower2, tablewa, sec2rel)
import Csound.Typed.Opcode
import Csound.SigSpace
import Csound.Tab

import Csound.Air.Wave(Lfo, unipolar, oscBy, utri, white, pink)
import Csound.Air.Filter
import Csound.Typed.Plugins

-- | Mono version of the cool reverberation opcode reverbsc.
--
-- > reverbsc1 asig feedbackLevel cutOffFreq
reverbsc1 :: Sig -> Feedback -> ToneSig -> Sig
reverbsc1 x k co = 0.5 * (a + b)
    where (a, b) = ar2 $ reverbsc x x k co


---------------------------------------------------------------------------
-- Reverbs

-- | Reverb with given time.
reverTime :: DelayTime -> Sig -> Sig
reverTime dt a =  nreverb a dt 0.3 

-- | Mono reverb (based on reverbsc)
--
-- > rever1 feedback asig
rever1 :: Feedback -> Sig -> (Sig, Sig)
rever1 fbk a = reverbsc a a fbk 12000

-- | Mono reverb (based on reverbsc)
--
-- > rever2 feedback (asigLeft, asigRight)
rever2 :: Feedback -> Sig2 -> Sig2
rever2 fbk (a1, a2) = (a1 + wa1, a2 + wa2)
    where (wa1, wa2) = reverbsc a1 a2 fbk 12000

-- | Mono reverb for small room.
smallRoom :: Sig -> (Sig, Sig)
smallRoom = rever1 0.6

-- | Mono reverb for small hall.
smallHall :: Sig -> (Sig, Sig)
smallHall = rever1 0.8

-- | Mono reverb for large hall.
largeHall :: Sig -> (Sig, Sig)
largeHall = rever1 0.9

-- | The magic cave reverb (mono).
magicCave :: Sig -> (Sig, Sig)
magicCave = rever1 0.99

-- | Stereo reverb for small room.
smallRoom2 :: Sig2 -> Sig2
smallRoom2 = rever2 0.6

-- | Stereo reverb for small hall.
smallHall2 :: Sig2 -> Sig2
smallHall2 = rever2 0.8

-- | Stereo reverb for large hall.
largeHall2 :: Sig2 -> Sig2
largeHall2 = rever2 0.9

-- | The magic cave reverb (stereo).
magicCave2 :: Sig2 -> Sig2
magicCave2 = rever2 0.99

---------------------------------------------------------------------------------

-- | An alias for 
--
-- > let room dryWet asig = mixAt dryWet smallRoom2 asig
room :: MixAt Sig2 Sig2 a => Sig -> a -> AtOut Sig2 Sig2 a
room mx ain = mixAt mx smallRoom2 ain

-- | An alias for 
--
-- > let room dryWet asig = mixAt dryWet smallHall2 asig
chamber :: MixAt Sig2 Sig2 a => Sig -> a -> AtOut Sig2 Sig2 a
chamber mx ain = mixAt mx smallHall2 ain

-- | An alias for 
--
-- > let room dryWet asig = mixAt dryWet largeHall2 asig
hall :: MixAt Sig2 Sig2 a => Sig -> a -> AtOut Sig2 Sig2 a
hall mx ain = mixAt mx largeHall2 ain

-- | An alias for 
--
-- > let room dryWet asig = mixAt dryWet magicCave2 asig
cave :: MixAt Sig2 Sig2 a => Sig -> a -> AtOut Sig2 Sig2 a
cave mx ain = mixAt mx magicCave2 ain

---------------------------------------------------------------------------------
-- IR reverbs

-- | Fast zero delay convolution with impulse response that is contained in mono-audio file.
--
-- > monoIR irFile ain
monoIR :: FilePath -> Sig -> Sig
monoIR = monoIR' def

-- | Fast zero delay convolution with impulse response that is contained in mono-audio file.
-- We can specify aux parameters for convolution algorithm (see @zconv'@).
--
-- > monoIR' spec irFile ain
monoIR' :: ZConvSpec -> FilePath -> Sig -> Sig
monoIR' spec fileName ain = zconv' spec (wavLeft fileName) ain

-- | Fast zero delay convolution with impulse response that is contained in stereo-audio file.
--
-- > stereoIR irFile ain
stereoIR :: FilePath -> Sig2 -> Sig2
stereoIR = stereoIR' def

-- | Fast zero delay convolution with impulse response that is contained in stereo-audio file.
-- We can specify aux parameters for convolution algorithm (see @zconv'@).
--
-- > stereoIR' spec irFile ain
stereoIR' :: ZConvSpec -> FilePath -> Sig2 -> Sig2
stereoIR' spec fileName (ainL, ainR) = (zconv' spec (wavLeft fileName) ainL, zconv' spec (wavRight fileName) ainR)

-- | If IR is encoded in a couple of mono files.
stereoIR2 :: (FilePath, FilePath) -> Sig2 -> Sig2
stereoIR2 = stereoIR2' def

-- | If IR is encoded in a couple of mono files.
stereoIR2' :: ZConvSpec -> (FilePath, FilePath) -> Sig2 -> Sig2
stereoIR2' spec (file1, file2) (ainL, ainR) = (monoIR' spec file1 ainL, monoIR' spec file2 ainR)

-- | Precise mono IR with pconvolve (requires a lot of CPU).
pmonoIR :: FilePath -> Sig -> Sig
pmonoIR fileName ain = pconvolve ain (text fileName)

-- | Precise stereo IR with pconvolve (requires a lot of CPU).
pstereoIR :: FilePath -> Sig2 -> Sig2
pstereoIR fileName (ainL, ainR) = pconvolve ((ainL + ainR) * 0.5) (text fileName)

pstereoIR2 :: (FilePath, FilePath) -> Sig2 -> Sig2
pstereoIR2 (file1, file2) (ainL, ainR) = (pmonoIR file1 ainL, pmonoIR file2 ainR)
    

---------------------------------------------------------------------------------
-- Delays

-- | The maximum delay time.
type MaxDelayTime = D

-- | The delaya time
type DelayTime = Sig

-- | Feedback for delay
type Feedback = Sig

-- | Dry/Wet mix value (ranges from 0 to 1). The 0 is all dry. The 1 is all wet.
type Balance = Sig

-- | The simplest delay with feedback. Arguments are: delay length and decay ratio.
--
-- > echo delayLength ratio
echo :: MaxDelayTime -> Feedback -> Sig -> SE Sig
echo len fb = fdelay len fb 1

-- | Delay with feedback. 
--
-- > fdelay delayLength decayRatio balance
fdelay :: MaxDelayTime -> Feedback -> Balance -> Sig -> SE Sig
fdelay len = fvdelay len (sig len)

-- | Delay with feedback. 
--
-- > fdelay maxDelayLength delayLength feedback balance
fvdelay :: MaxDelayTime -> DelayTime -> Feedback -> Balance -> Sig -> SE Sig
fvdelay len dt fb mx a = do
    _ <- delayr len
    aDel <- deltap3 dt
    delayw $ a + fb * aDel
    return $ a + (aDel * mx)

-- | Multitap delay. Arguments are: max delay length, list of pairs @(delayLength, decayRatio)@,
-- balance of mixed signal with processed signal.
--
-- > fdelay maxDelayLength  delays balance asig
fvdelays :: MaxDelayTime -> [(DelayTime, Feedback)] -> Balance -> Sig -> SE Sig
fvdelays len dtArgs mx a = funDelays len (zip dts fs) mx a
    where 
        (dts, fbks) = unzip dtArgs
        fs = map (*) fbks


-- | Generic multitap delay. It's just like @fvdelays@ but instead of constant feedbackLevel 
-- it expects a function for processing a delayed signal on the tap.
--
-- > fdelay maxDelayLength  delays balance asig
funDelays :: MaxDelayTime -> [(DelayTime, Sig -> Sig)] -> Balance -> Sig -> SE Sig
funDelays len dtArgs mx a = do
    _ <- delayr len
    aDels <- mapM deltap3 dts
    delayw $ a + sum (zipWith ($) fs aDels)
    return $ a + mx * sum aDels 
    where (dts, fs) = unzip dtArgs

-- | Delay for functions that use some table (as a buffer). As granular synth or mincer.
--
-- > tabDelay fn maxDelayTime delayTime feedback balance asig
tabDelay :: (Tab -> Sig -> SE Sig) -> MaxDelayTime -> DelayTime -> Feedback -> Balance -> Sig -> SE Sig
tabDelay go maxLength delTim  kfeed kbalance asig = do
    buf <- newTab tabLen    
    ptrRef <- newRef (0 :: Sig)
    aresRef <- newRef (0 :: Sig)  
    ptr <- readRef ptrRef
    when1 (ptr >=* sig tabLen) $ do
        writeRef ptrRef 0
    ptr <- readRef ptrRef 

    let kphs = (ptr / sig tabLen) - (delTim/(sig $ tabLen / getSampleRate))
    awet <-go buf (wrap kphs 0 1)
    writeRef aresRef $ asig + kfeed * awet
    ares <- readRef aresRef
    writeRef ptrRef =<< tablewa buf ares 0
    return $ (1 - kbalance) * asig + kbalance * awet
    where
        tabLen = tabSizeSecondsPower2 maxLength

-- | Aux parameters for ping pong delay. 
-- They are maximum delay time, low pass filter center frequency and Pan width.
-- The defaults are @(5 sec, 3500, 0.3)@.
data PingPongSpec = PingPongSpec {
        pingPongMaxTime :: MaxDelayTime,
        pingPongDamp    :: Sig,
        pingPongWidth   :: Sig    
    }

instance Default PingPongSpec where
    def = PingPongSpec {
            pingPongMaxTime = 5,
            pingPongDamp    = 3500,
            pingPongWidth   = 0.3
        }

-- | Ping-pong delay. 
--
-- > pingPong delayTime feedback mixLevel
pingPong :: DelayTime -> Feedback -> Balance -> Sig2 -> SE Sig2
pingPong delTime feedback mixLevel (ainL, ainR) = pingPong' def delTime feedback mixLevel (ainL, ainR)

-- | Ping-pong delay with miscellaneous arguments. 
--
-- > pingPong' spec delayTime feedback mixLevel
pingPong' :: PingPongSpec -> DelayTime -> Feedback -> Balance -> Sig2 -> SE Sig2    
pingPong' (PingPongSpec maxTime damp width) delTime feedback mixLevel (ainL, ainR) = 
    csdPingPong maxTime delTime damp feedback width mixLevel (ainL, ainR)

-- | Ping-pong delay defined in csound style. All arguments are present (nothing is hidden).
-- 
-- > csdPingPong maxTime delTime damp feedback width mixLevel (ainL, ainR)
csdPingPong :: MaxDelayTime -> DelayTime -> Sig -> Feedback -> Sig -> Balance -> Sig2 -> SE Sig2
csdPingPong maxTime delTime damp feedback width mixLevel (ainL, ainR) = do
    afirst <- offsetDelay ainL   
    atapL  <- channelDelay afirst
    atapR  <- channelDelay ainR
    return $ mixControl $ widthControl afirst (atapL, atapR)
    where
        offsetDelay ain = do
            abuf <- delayr maxTime
            afirst <- deltap3 delTime
            let afirst1 = tone afirst damp
            delayw ain
            return afirst1

        channelDelay ain = do
            abuf <- delayr (2 * maxTime)
            atap <- deltap3 (2 * delTime)
            let atap1 = tone atap damp
            delayw (ain + atap1 * feedback)
            return atap1

        widthControl afirst (atapL, atapR) = (afirst + atapL + (1 - width) * atapR, atapR + (1 - width) * atapL)

        mixControl (atapL ,atapR) = (cfd mixLevel ainL atapL, cfd mixLevel ainR atapR)

type DepthSig = Sig
type RateSig  = Sig
type WidthSig  = Sig
type ToneSig  = Sig

-- Distortion

-- | Distortion. 
--
-- > distort distLevel asig
distortion :: Sig -> Sig -> Sig
distortion pre asig = distort1 asig pre 0.5 0 0 `withD` 1

-- Chorus

-- | Chorus.
--
-- > chorus depth rate balance asig
chorus :: DepthSig -> RateSig -> Balance -> Sig -> SE Sig
chorus depth rate mx asig = do
    _ <- delayr 1.2
    adelSig <- deltap3 (0.03 * depth * oscBy fn (3 * rate) + 0.01)
    delayw asig
    return $ ntrpol asig adelSig mx
    where fn = sines4 [(0.5, 1, 180, 1)] -- U-shape parabola

-- Flanger

-- | Flanger. Lfo depth ranges in 0 to 1.
--
-- flanger lfo feedback balance asig
flange :: Lfo -> Feedback -> Balance -> Sig -> Sig
flange alfo fbk mx asig = ntrpol asig (flanger asig ulfo fbk) mx
    where ulfo = 0.0001 + 0.02 * unipolar alfo

-- Phaser

-- | First order phaser.
phase1 :: Sig -> Lfo -> Feedback -> Balance -> Sig -> Sig
phase1 ord alfo fbk mx asig = ntrpol asig (phaser1 asig (20 + unipolar alfo) ord fbk) mx  

-- | Second order phaser. Sweeping gaps in the timbre are placed harmonicaly
harmPhase :: Sig -> Lfo -> Sig -> Sig -> Feedback -> Balance -> Sig -> Sig
harmPhase ord alfo q sep fbk mx asig = ntrpol asig (phaser2 asig (20 + unipolar alfo) q ord 1 sep fbk) mx

-- | Second order phaser. Sweeping gaps in the timbre are placed by powers of the base frequency.
powerPhase :: Sig -> Lfo -> Sig -> Sig -> Feedback -> Balance -> Sig -> Sig
powerPhase ord alfo q sep fbk mx asig = ntrpol asig (phaser2 asig (20 + unipolar alfo) q ord 2 sep fbk) mx


-----------------------------------------------------------------
-- new effects

expScale :: Sig -> (Sig, Sig) -> Sig -> Sig
expScale steep (min, max) a = scale (expcurve a steep) max min

logScale :: Sig -> (Sig, Sig) -> Sig -> Sig
logScale steep (min, max) a = scale (logcurve a steep) max min

dryWetMix :: Sig -> (Sig, Sig)
dryWetMix kmix = (kDry, kWet) 
    where
        iWet = setSize 1024 $ elins [0, 1, 1]
        iDry = setSize 1024 $ elins [1, 1, 0]
        kWet = kr $ table kmix iWet `withD` 1
        kDry = kr $ table kmix iDry `withD` 1

fxWet :: (Num a, SigSpace a) => Sig -> a -> a -> a
fxWet mix ain aout = mul dry ain + mul wet aout
    where (dry, wet) = dryWetMix mix

-- Distortion 

-- | Distortion
--
-- > fxDistort level drive tone sigIn
fxDistort :: Feedback -> Sig -> ToneSig -> Sig -> Sig
fxDistort klevel kdrive ktone ain = aout * (scale klevel 0.8 0) * kGainComp1
    where
        aout = blp kLPF $ distort1 ain kpregain kpostgain 0 0

        drive = expScale 8 (0.01, 0.4) kdrive
        kGainComp1 = logScale 700 (5,1) ktone

        kpregain = 100 * drive
        kpostgain = 0.5 * ((1 - drive) * 0.4 + 0.6)

        kLPF = logScale 700 (200, 12000) ktone

-- | Stereo distortion.
fxDistort2 :: Feedback -> Sig -> ToneSig -> Sig2 -> Sig2
fxDistort2 klevel kdrive ktone (al, ar) = (fx al, fx ar)
    where fx = fxDistort klevel kdrive ktone

-- Stereo chorus


-- | Stereo chorus.
--
-- > stChorus2 mix rate depth width sigIn
stChorus2 :: Balance -> RateSig -> DepthSig -> WidthSig -> Sig2 -> Sig2
stChorus2 kmix krate' kdepth kwidth (al, ar) = fxWet kmix (al, ar) (aoutL, aoutR)
    where 
        krate = expScale 20 (0.001, 7) krate'
        ilfoshape = setSize 131072 $ sines4 [(1, 0.5, 0, 0.5)]
        kporttime = linseg  [0, 0.001, 0.02]
        kChoDepth = interp $ portk  (kdepth*0.01) kporttime
        amodL = osciliktp   krate ilfoshape 0
        amodR = osciliktp   krate ilfoshape (kwidth*0.5)
        vdel mod x = vdelay x (mod * kChoDepth * 1000) (1.2 * 1000)
        aChoL = vdel amodL al
        aChoR = vdel amodR ar
        aoutL = 0.6 * (aChoL + al)
        aoutR = 0.6 * (aChoR + ar)

-- Phaser

-- | Phaser
--
-- > fxPhaser mix rate depth freq feedback sigIn
fxPhaser ::Balance -> Feedback -> RateSig -> DepthSig -> Sig -> Sig -> Sig
fxPhaser kmix fb krate' kdepth kfreq ain = fxWet kmix ain aout
    where       
        krate = expScale 10 (0.01, 14) krate'
        klfo  = kdepth * utri krate
        aout  = phaser1 ain (cpsoct $ klfo + kfreq) 8 fb        

-- | Stereo phaser.
fxPhaser2 :: Balance -> Feedback -> RateSig -> DepthSig -> Sig -> Sig2 -> Sig2
fxPhaser2 kmix fb krate kdepth kfreq (al, ar) = (fx al, fx ar)
    where fx = fxPhaser kmix fb krate kdepth kfreq  

-- Flanger

-- | Flanger
--
-- > fxFlanger mix feedback rate depth delay sigIn
fxFlanger :: Balance -> Feedback -> RateSig -> DepthSig -> DelayTime -> Sig -> Sig
fxFlanger kmix kfback krate' kdepth kdelay' ain = fxWet kmix ain aout
    where
        krate = expScale 50 (0.001, 14) krate'
        kdelay = expScale 200 (0.0001, 0.1) kdelay'
        ilfoshape = setSize 131072 $ sines4 [(0.5, 1, 180, 1)]
        kporttime = linseg  [0, 0.001, 0.1]
        adlt = interp $ portk kdelay kporttime
        kdep = portk (kdepth*0.01) kporttime 
        amod = oscili kdep krate ilfoshape      
        adelsig = flanger ain (adlt + amod) kfback `withD` 1.2
        aout = mean [ain, adelsig]

-- | Stereo flanger
fxFlanger2 :: Balance -> Feedback -> RateSig -> DepthSig -> DelayTime -> Sig2 -> Sig2
fxFlanger2 kmix kfback krate kdepth kdelay  (al ,ar) = (fx al, fx ar)
    where fx = fxFlanger kmix kfback krate kdepth kdelay

-- Analog delay

-- | Analog delay.
--
-- > analogDelay mix feedback time tone sigIn
analogDelay :: Balance -> Feedback -> DelayTime -> ToneSig -> Sig -> SE Sig
analogDelay kmix kfback ktime  ktone'  ain = do
    aBuffer <- delayr 5
    atap <- deltap3 aTime
    let atap1 = tone (clip atap 0 1) kTone
    delayw $ ain + atap1*kfback
    return $ ain*kDry + atap1 * kWet
    where
        ktone = expScale 4 (100, 12000) ktone'
        (kDry, kWet) = dryWetMix kmix
        kporttime = linseg [0,0.001,0.1]
        kTime = portk   ktime  (kporttime*3)
        kTone = portk   ktone kporttime
        aTime = interp  kTime

-- | Stereo analog delay.
analogDelay2 :: Balance -> Feedback -> DelayTime -> ToneSig -> Sig2 -> SE Sig2
analogDelay2 kmix kfback ktime ktone  = bindSig fx
    where fx = analogDelay kmix kfback ktime ktone 

-- Filter

-- | Filter effect (a pair of butterworth low and high pass filters).
--
-- > fxFilter lowPassfFreq highPassFreq gain 
fxFilter :: Sig -> Sig -> Sig -> Sig -> Sig
fxFilter kLPF' kHPF' kgain' ain = mul kgain $ app (blp kLPF) $ app (bhp kHPF) $ ain 
    where 
        app f = f . f
        kLPF = scaleFreq kLPF' 
        kHPF = scaleFreq kHPF' 
        kgain = scale kgain' 20 0
        scaleFreq x = expScale 4 (20, 20000) x

-- | Stereo filter effect (a pair of butterworth low and high pass filters).
fxFilter2 :: Sig -> Sig -> Sig -> Sig2 -> Sig2
fxFilter2 kLPF kHPF kgain (al, ar) = (fx al, fx ar)
    where fx = fxFilter kLPF kHPF kgain

-- Equalizer

-- | Equalizer
--
-- > equalizer gainsAndFrequencies gain sigIn
equalizer :: [(Sig, Sig)] -> Sig -> Sig -> Sig
equalizer fs gain ain0 = case fs of
    []   -> ain
    x:[] -> g 0 x ain
    x:y:[] -> mean [g 1 x ain, g 2 y ain]
    x:xs -> mean $ (g 1 x ain : ) $ (fmap (\y -> g 0 y ain) (init xs)) ++ [g 2 (last xs) ain]
    where
        iQ = 1
        iEQcurve = skipNorm $ setSize 4096 $ startEnds [1/64,4096,7.9,64]
        iGainCurve = skipNorm $ setSize 4096 $ startEnds [0.5,4096,3,4]
        g ty (gain, freq) asig = pareq  asig freq (table gain iEQcurve `withD` 1) iQ `withD` ty
        kgain = table gain iGainCurve `withD` 1
        ain = kgain * ain0

-- | Stereo equalizer.
equalizer2 :: [(Sig, Sig)] -> Sig -> Sig2 -> Sig2
equalizer2 fs gain (al, ar) = (fx al, fx ar)
    where fx = equalizer fs gain

-- | Equalizer with frequencies: 100, 200, 400, 800, 1600, 3200, 6400
eq7 :: [Sig] -> Sig -> Sig2 -> Sig2
eq7 gs = equalizer2 (zip gs $ fmap (100 * ) [1, 2, 4, 8, 16, 32, 64])

-- | Equalizer with frequencies: 100, 400, 1600, 6400
eq4 :: [Sig] -> Sig -> Sig2 -> Sig2
eq4 gs = equalizer2 (zip gs $ fmap (100 * ) [1, 4, 16, 64])

-- | Gain
--
-- > fxGain gain sigIn
fxGain :: Sig -> Sig2 -> Sig2
fxGain = mul


-- Noise

-- | Adds filtered white noize to the signal
--
-- > fxWhite lfoFreq depth sigIn
fxWhite :: Sig -> Sig -> Sig -> SE Sig
fxWhite freq depth ain = do
    noise <- white
    return $ ain + 0.5 * depth * blp cps noise
    where cps = expScale 4 (20, 20000) freq

-- | Adds filtered white noize to the stereo signal
fxWhite2 ::Sig -> Sig -> Sig2 -> SE Sig2
fxWhite2 freq depth = bindSig fx 
    where fx = fxWhite freq depth

-- | Adds filtered pink noize to the signal
--
-- > fxWhite lfoFreq depth sigIn
fxPink :: Sig -> Sig -> Sig -> SE Sig
fxPink freq depth ain = do
    noise <- pink
    return $ ain + 0.5 * depth * blp cps noise
    where cps = expScale 4 (20, 20000) freq

-- | Adds filtered pink noize to the stereo signal
fxPink2 ::Sig -> Sig -> Sig2 -> SE Sig2
fxPink2 freq depth = bindSig fx 
    where fx = fxPink freq depth

-- Echo

-- | Simplified delay
--
-- > fxEcho maxDelayLength delTime feedback sigIn
fxEcho :: D -> Sig -> Sig -> Sig -> SE Sig
fxEcho maxLen ktime fback = fvdelay (5 * maxLen) (sig maxLen * 0.95 * kTime) fback 1  
    where
        kporttime = linseg [0,0.001,0.1]
        kTime = portk   ktime  (kporttime*3)

-- | Simplified stereo delay.
fxEcho2 :: D -> Sig -> Sig -> Sig2 -> SE Sig2
fxEcho2 maxLen ktime fback = bindSig fx
    where fx = fxEcho maxLen ktime fback




-- | Instrument plays an input signal in different modes. 
-- The segments of signal can be played back and forth. 
-- 
-- > trackerSplice maxLength segLength mode
-- 
-- * @maxLength@ -- the maximum length of the played segment (in seconds)
--
-- * @segLength@ -- the segment length in seconds
--
-- * @mode@ -- mode of the playing. If it's 1 - only a part of the sample is plyaed and
--   it's played forward. The portion of the signal starts from the current playback point.
--   It lasts for segLength. If it's 2 - the segment is played in reverse. 
--   Other values produce the normal input signal.
--
-- Original author: Rory Walsh
--
-- Example:
--
-- > main = dac $ do    
-- >    let ev ch1 ch2 dt = fmap (\x -> (x, dt)) $ mconcat [
-- >          fmap (const 1.5) $ charOn ch1 
-- >        , fmap (const 2.5) $ charOn ch2 
-- >        , fmap (const 0) $ charOff ch1 <> charOff ch2]
-- > 
-- >    (k, dt) <- stepper (0, 0.1) $ ev 'q' 'w' 0.1 <> ev 'a' 's' 0.2 <> ev 'z' 'x' 0.4
-- >    mul 1.3 $ trackerSplice 0.8 dt (int' k) $ fst $ loopWav 1 "drumLoop.wav"
trackerSplice :: D -> Sig -> Sig -> Sig -> SE Sig
trackerSplice maxLength segLengthSeconds kmode asig = do
    setksmps 1
    kindxRef <- newRef (0 :: Sig)
    ksampRef <- newRef (1 :: D)
    aoutRef  <- newRef (0 :: Sig)

    buf <- newTab (tabSizeSecondsPower2 maxLength)
    let segLength = segLengthSeconds * sig getSampleRate
        andx = phasor (sig $ getSampleRate / ftlen buf)
        andx1 = delay andx 1
    tabw asig (andx * sig (ftlen buf)) buf
    ksamp <- readRef ksampRef
    let apos = samphold (andx1 * sig (ftlen buf)) (sig ksamp)

    whens [
        (kmode >=* 1 &&* kmode `lessThan` 2, do             
                kindx <- readRef kindxRef                             
                writeRef kindxRef $ ifB (kindx >* segLength) 0 (kindx + 1)                
                kindx <- readRef kindxRef
                when1 (kindx + apos >* sig (ftlen buf)) $ do
                    writeRef kindxRef $ (-segLength)

                kindx <- readRef kindxRef

                writeRef aoutRef $ table (apos + kindx) buf `withDs` [0, 1]
                writeRef ksampRef 0
        ), (kmode >=* 2 &&* kmode `lessThan` 3, do              
                kindx <- readRef kindxRef
                writeRef kindxRef $ ifB ((kindx+apos) <=* 0) (sig (ftlen buf) - apos) (kindx-1)
                kindx <- readRef kindxRef
                writeRef aoutRef $ table (apos+kindx) buf `withDs` [0, 1]
                writeRef ksampRef 0   
        )] (do
                writeRef ksampRef 1
                writeRef aoutRef asig)

    aout <-readRef aoutRef
    return aout



-- | Mean value.
mean :: Fractional a => [a] -> a
mean xs = sum xs / (fromIntegral $ length xs)