module Csound.Catalog.Wave.Ac(
    pulseWidth,
    xanadu1, xanadu2, stringPad, toneWheel,
    guitar, harpsichord, xing,
    fmMod, filteredChorus, plainString, fmTubularBell, 
    delayedString, melody, rhodes, 
) where

import Data.List

import Csound.Base
            
-- | 
--
-- > aout = pulseWidth amplitude cps
pulseWidth :: Sig -> Sig -> Sig
pulseWidth amp cps = asignal
    where
        ilforate  = 		2.3					-- LFO SPEED IN Hz
        isawlvl   = 		0.5	 				-- LEVEL OF SAWTOOTH WAVEFORM
        ipwmlvl   = 		0.5	 				-- LEVEL OF PULSE WAVEFORM
        ipwm	  = 		0.2	 				-- DC OFFSET OF PULSE width
        ipwmlfo   = 		0.1	 				-- DEPTH OF PULSE WIDTH MODULATION
        ivcffrq   = 		800	 				-- CUTOFF OF GLOBAL LOW PASS FILTER
        ienvflt   = 		200	 				-- MAX CHANGE IN LPF CUTOFF BY ENVELOPE
        ikbdflt   = 		0.1	 				-- RELATIVE CHANGE IN LPF CUTOFF TO PITCH
        -- the oscillators
        klfo        = kr $ osc ilforate
        asaw        = oscBy (elins [-1, 1]) cps 
        apwm        = table (0.5 + asaw / 2 + (klfo * ipwmlfo + ipwm)) (lins [-1, 50, -1, 0, 1, 50, 1]) `withD` 1
        awaves      = isawlvl * asaw + ipwmlvl * apwm
        -- the envelope
        -- the filters
        asignal     = amp * butlp awaves (ivcffrq + cps * ikbdflt + ienvflt * amp)

giwave :: Tab
giwave = sines [1, 0.5, 0.33, 0.25, 0.0, 0.1, 0.1, 0.1]

xanaduPlucks :: D -> D -> D -> (Sig, Sig, Sig)
xanaduPlucks cps vibrAmp vibrCps = (phi vib, phi shift, phi (-shift))
    where phi asig = pluck 1 (cpsoct $ oct + asig) cps giwave 1
          shift = 8/1200  
          vib = kr $ poscil (sig vibrAmp) (sig vibrCps) cosine
          oct = sig $ octcps cps

-- | 
--
-- > aout <- xanadu1 cps
xanadu1 :: D -> SE Sig
xanadu1 cps = do
    _ <- delayr 2    
    [tap1, tap2, d1, d2] <- mapM deltap3 [f1, f2, 2, 1.1]    
    delayw $ g * damping
    return $ damping * mean [gleft, tap1, d1, gright, tap2, d2]
    where (g, gleft, gright) = xanaduPlucks cps (1/120) (cps/50)
          f1 = expseg [0.01, 10, 1]
          f2 = expseg [0.015, 15, 1.055]
          damping = 1

-- | 
--
-- > aout <- xanadu2 cps
xanadu2 :: D -> SE Sig
xanadu2 cps = do
    _ <- delayr 0.4
    [d1, d2] <- mapM deltap3 [0.07, 0.105]
    delayw $ g * damping
    return $ damping * mean [d1, gleft, d2, gright]
    where (g, gleft, gright) = xanaduPlucks cps (1/80) 6.1
          damping = 1

-- | 
--
-- > stringPad amplitude cps
stringPad :: Sig -> Sig -> Sig
stringPad amp cps = blp (900 + amp * 300) $ chorusPitch 3 0.1 f cps
    where f x = poscil 1 x giwave

-- | Tone wheel organ by Mikelson
--
-- > toneWheel cps
toneWheel :: D -> Sig
toneWheel cps = asignal
    where
        ikey = 12 * int' (cps - 6) + 100 * (cps - 6)
        wheels = 
            [ ifB (ikey - 12 >* 12) gitonewheel1 gitonewheel2
            , ifB (ikey +  7 >* 12) gitonewheel1 gitonewheel2
            , ifB (ikey      >* 12) gitonewheel1 gitonewheel2
            , sine ]
        iphase = 0.5
        harm w fqc tabId phs = poscil (sig w) (sig $ fqc * cps) (wheels !! tabId) `withD` (iphase / (ikey - phs))
        asignal = ( / 9) $ mean $ zipWith4 harm
            [8,   8,      8,   8,   3,      2,     1,      0, 4]
            [0.5, 1.4983, 1,   2,   2.9966, 4, 5.0397, 5.9932, 8]
            ([0, 1, 2, 3] ++ repeat 3)
            [-12, 7, 0, 12, 19, 24, 28, 31, 36]

        gitonewheel1 = sines [1, 0.02, 0.01]
        gitonewheel2 = sines [1, 0, 0.2, 0, 0.1, 0, 0.05, 0, 0.02]

-- | Guitar, Michael Gogins
--
-- > guitar cps
guitar :: D -> Sig
guitar cps = asignal
    where
        asigcomp    = pluck 1 440 440 def 1
        asig        = pluck 1 (sig cps) cps def 1
        af x cf wid = x * reson asig cf wid
        asignal     = balance (0.4 * asig + sum [af 0.6 110 80, af 1 220 100, af 0.6 440 80]) asigcomp

-- Harpsichord, James Kelley
--
-- > harpsicord cps
harpsichord :: D -> Sig
harpsichord cps = 0.5 * asignal
    where
        aenvelope   = ar $ transeg [1, 10, -5.0, 0]
        apluck      = pluck 1 (sig cps) cps def 1
        aharp       = poscil aenvelope (sig cps) (lins [-1, 1024, 1, 1024, -1])
        asignal     = apluck + balance apluck aharp

-- | Xing by Andrew Horner
--
-- > xing cycleDuration cps
xing :: D -> Sig -> Sig
xing xdur cps = asignal
    where
        amps xs dt vib freq phs = ar (loopseg xs (sig $ 1/xdur)) * (1 + poscil vibEnv freq sine `withD` phs)
            where vibEnv = ar $ loopseg [0, dt, vib, sig xdur - dt, 0] (sig $ 1/xdur)

        f vol freq = poscil vol (sig freq * cps) sine

        norm = 32310
        asignal = (sig $ 1 / norm) * sum 
            [ f (amps env1 0.05 0.3 6.7  0.8) 1
            , f (amps env2 0.12 0.5 10.5 0  ) 2.7
            , f (amps env3 0.02 0.8 70   0  ) 4.95
            ]
        
        env1 = [ 0,0.001,5200,0.001,800,0.001,3000,0.0025,1100,0.002
            , 2800,0.0015,1500,0.001,2100,0.011,1600,0.03,1400,0.95
            , 700,1,320,1,180,1,90,1,40,1,20,1,12,1,6,1,3,1,0,1,0]

        env2 = [ 0,0.0009,22000,0.0005,7300,0.0009,11000,0.0004,5500
            , 0.0006,15000,0.0004,5500,0.0008,2200,0.055,7300,0.02
            , 8500,0.38,5000,0.5,300,0.5,73,0.5,5,5,0,1,1]

        env3 = [ 0,0.001,3000,0.001,1000,0.0017,12000,0.0013
            , 3700,0.001,12500,0.0018,3000,0.0012,1200,0.001
            , 1400,0.0017,6000,0.0023,200,0.001,3000,0.001,1200
            , 0.0015,8000,0.001,1800,0.0015,6000,0.08,1200,0.2
            , 200,0.2,40,0.2,10,0.4,0,1,0]

-- | FM modulated left and right detuned chorusing, Thomas Kung
--
-- > fmMod cycleDuration cps
fmMod :: D -> Sig -> Sig
fmMod xdur cps = asignal
    where
        iattack     = 0.25
        irelease    = 0.3333
        ip6         = 0.3
        ip7         = 2.2
        ishift      = 4 / 12000
        ipch        = cps
        ioct        = octcps cps
        amodi       = ar $ loopseg [0, iattack, 5, sig xdur, 2, irelease, 0] (sig $ 1 / xdur) 
        amodr       = ar $ loopseg [ip6, 1, ip7, 1, ip6] (sig $ 0.5 / xdur) 
        a1          = amodi * (amodr - 1 / amodr) / 2
        a2          = amodi * (amodr + 1 / amodr) / 2
        a1ndx       = abs $ a1 / 10
        a3          = tablei a1ndx (skipNorm $ bessels 20) `withD` 1 
        ao1         = poscil a1 ipch cosine
        a4          = exp $ -0.5 * a3 + ao1
        ao2         = poscil (a2 * ipch) cps cosine
        aleft       = poscil a4 (ao2 + cpsoct (ioct + ishift)) sine
        aright      = poscil a4 (ao2 + cpsoct (ioct - ishift)) sine
        asignal     = 0.5 * (aleft + aright)         

-- | Filtered chorus, Michael Bergeman
--
-- > filteredChorus cycleDuration cps
filteredChorus :: D -> Sig -> Sig
filteredChorus xdur cps = asignal
    where 
        a ~~ b = loopseg [sig a, 1, sig b, 1, sig a] (sig $ 1 / (xdur * 2))
        filt cf1 bw1 cf2 bw2 x = balance (bp cf2 bw2 $ bp cf1 bw1 x) x
        harm fqc = poscil ((sig $ idb)) fqc $ sines 
                            [ 0.28, 1, 0.74, 0.66, 0.78, 0.48, 0.05, 0.33, 0.12
                            , 0.08, 0.01, 0.54, 0.19, 0.08, 0.05, 0.16, 0.01, 0.11, 0.3, 0.02, 0.2]
        a1s x = mean $ fmap (harm . (* cpsoct (octcps cps + x))) [1, 0.999, 1.001]
        rvb dt dh x = 0.5 * (x + reverb2 x dt dh) 

        idb = 1.5

        asignal = mean 
            [ rvb 5 0.3 $ filt (40 ~~ 800) 40 (220 ~~ 440) ((440 ~~ 220) * 0.8) $ a1s (-0.01)
            , rvb 4 0.2 $ filt (800 ~~ 40) 40 (440 ~~ 220) ((220 ~~ 440) * 0.8) $ a1s 0.01
            ]

-- | Plain plucked string, Michael Gogins
--
-- > plainString cps
plainString :: D -> Sig
plainString cps = wgpluck2 0.1 1.0 cps 0.25 0.05
   
-- | Rhodes electric piano model, Perry Cook
--
-- > rhodes cps
rhodes :: Sig -> Sig
rhodes cps = asignal
    where
        iindex      = 4.1
        icrossfade  = 3.1
        ivibedepth  = 0.2
        iviberate   = 6
        ifn1        = sine
        ifn2        = cosine
        ifn3        = sine
        ifn4        = sines [0]
        ivibefn     = sine
        asignal     = fmrhode 1 cps iindex icrossfade ivibedepth iviberate ifn1 ifn2 ifn3 ifn4 ivibefn

-- | Tubular bell model, Perry Cook
--
-- > fmTubularBell cps
fmTubularBell :: Sig -> Sig
fmTubularBell cps = asignal
    where
        iindex      = 1.5
        icrossfade  = 2.03
        ivibedepth  = 0.2
        iviberate   = 6
        ifn1        = sine
        ifn2        = sines [1, 0.4, 0.2, 0.1, 0.1, 0.05]
        ifn3        = sine
        ifn4        = sine
        ivibefn     = cosine
        asignal     = fmbell 1 cps iindex icrossfade ivibedepth iviberate `withTabs` [ifn1, ifn2, ifn3, ifn4, ivibefn]

-- | Delayed plucked string, Michael Gogins
--
-- > delayedString cps
delayedString :: D -> Sig
delayedString cps = asignal
    where
        ioctave     = octcps cps
        -- Detuning of strings by 4 cents each way
        idetune     = 4 / 1200
        kvibrato    = poscil (1 / 120) 7 sine
        awave det fn = pluck 1 (cpsoct $ sig ioctave + det) cps fn 1
        ag          = awave kvibrato  sine
        agleft      = awave idetune    sine
        agright     = awave (- idetune) cosine
        imsleft     = 0.2 * 1000
        imsright    = 0.21 * 1000
        noclick x   = linseg [0, 0.1, x, 1, x]
        adelayleft  = vdelay ag (noclick imsleft) (imsleft + 100)
        adelayright = vdelay ag (noclick imsright) (imsright + 100)
        asignal     = mean [agleft, adelayleft, agright, adelayright]


-- | Melody (Chebyshev / FM / additive), Jon Nelson
--
-- > melody cycleDuration cps
melody :: D -> Sig -> SE Sig
melody xdur cps = do
    k1000 <- randi 1 10
    let k100 = cps + loopseg [0, 0.5, 1, sig xdur, 1] (sig $ 1/xdur) * poscil 1 (5 + k1000) sine
        -- a1-3 are for cheby with p6=1-4
        a1   = poscil k1 k100 (sines [1, 0.4, 0.2, 0.1, 0.1, 0.05])
        a2   = tablei a1 ip6 `withDs` [1, 0.5]
        a3   = balance a2 a1
        -- try other waveforms as well
        a4          = foscil 1 (k100 + 0.04) 1 2.005 k20 sine
        a5          = poscil 1 k100 sine
        a6          = a3 * 0.1 + a4 * 0.1 + a5 * 0.8
        a7          = comb a6 0.5 (1 / ir cps)
        a8          = a6 * 0.9 + a7 * 0.1
        asignal     = balance a8 a1
    return asignal
    where
        iattack     = 0.05
        isustain    = xdur
        irelease    = 0.1
        ip6         = skipNorm $ lins [-1, 150, 0.1, 110, 0, 252, 0]
        -- Envelope for driving oscillator
        k1          = linseg [1, xdur, 0.5] * linenr 0.5 (xdur * 0.3) (xdur * 0.2) 0.01
        -- Power to partials
        k20         = linseg [1.485, iattack, 1.5, isustain + irelease, 1.485]