{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}
module Synthesizer.Plain.Instrument where

import Synthesizer.Plain.Displacement (mixMulti, )
import Synthesizer.Plain.Control (exponential2)
import qualified Synthesizer.Plain.Oscillator as Osci
import qualified Synthesizer.Basic.Wave       as Wave
import qualified Synthesizer.Plain.Noise      as Noise
import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1
import qualified Synthesizer.Plain.Filter.Recursive.Allpass    as Allpass
import qualified Synthesizer.Plain.Filter.Recursive.Universal  as UniFilter
import qualified Synthesizer.Plain.Filter.Recursive.Moog       as Moog
import qualified Synthesizer.Plain.Filter.Recursive.Comb       as Comb
import qualified Synthesizer.Plain.Filter.Recursive    as FiltR
import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR
import qualified Synthesizer.Plain.Interpolation as Interpolation
import Data.List(zipWith4)

import System.Random

import qualified Algebra.Transcendental as Trans
import qualified Algebra.Module         as Module
import qualified Algebra.RealField      as RealField
import qualified Algebra.Field          as Field
import qualified Algebra.Ring           as Ring

import PreludeBase
import NumericPrelude



{-| Create a sound of a slightly changed frequency
    just as needed for a simple stereo sound. -}
stereoPhaser :: Ring.C a =>
       (a -> [b])  {- ^ A function mapping a frequency to a signal. -}
    -> a           {- ^ The factor to the frequency, should be close to 1. -}
    -> a           {- ^ The base (undeviated) frequency of the sound. -}
    -> [b]
stereoPhaser sound dif freq = sound (freq*dif)



allpassPlain :: (RealField.C a, Trans.C a, Module.C a a) =>
                   a -> a -> a -> a -> [a]
allpassPlain sampleRate halfLife k freq =
    Allpass.cascade 10
        (map Allpass.Parameter (exponential2 (halfLife*sampleRate) k))
        (simpleSaw sampleRate freq)

allpassDown :: (RealField.C a, Trans.C a, Module.C a a) =>
                  a -> Int -> a -> a -> a -> [a]
allpassDown sampleRate order halfLife filterfreq freq =
    let x = simpleSaw sampleRate freq
    in  map (0.3*) (zipWith (+) x
            (Allpass.cascade order
                (map (Allpass.flangerParameter order)
                     (exponential2 (halfLife*sampleRate) (filterfreq/sampleRate)))
                x))


moogDown, moogReso ::
   (RealField.C a, Trans.C a, Module.C a a) =>
      a -> Int -> a -> a -> a -> [a]
moogDown sampleRate order halfLife filterfreq freq =
    Moog.lowpass order
        (map (Moog.parameter order) (map (FiltR.Pole 10)
            (exponential2 (halfLife*sampleRate) (filterfreq/sampleRate))))
        (simpleSaw sampleRate freq)

moogReso sampleRate order halfLife filterfreq freq =
    Moog.lowpass order
        (map (Moog.parameter order) (zipWith FiltR.Pole
            (exponential2 (halfLife*sampleRate) 100)
            (repeat (filterfreq/sampleRate))))
        (simpleSaw sampleRate freq)

bell :: (Trans.C a, RealField.C a) => a -> a -> [a]
bell sampleRate freq =
    let halfLife = 0.5
    in  zipWith3 (\x y z -> (x+y+z)/3)
            (bellHarmonic sampleRate 1 halfLife freq)
            (bellHarmonic sampleRate 4 halfLife freq)
            (bellHarmonic sampleRate 7 halfLife freq)

bellHarmonic :: (Trans.C a, RealField.C a) => a -> a -> a -> a -> [a]
bellHarmonic sampleRate n halfLife freq =
    zipWith (*) (Osci.freqModSine 0 (map (\modu -> freq/sampleRate*n*(1+0.005*modu))
                                    (Osci.staticSine 0 (5.0/sampleRate))))
                (exponential2 (halfLife/n*sampleRate) 1)


fastBell, squareBell, moogGuitar, moogGuitarSoft, simpleSaw, fatSaw ::
    (RealField.C a, Trans.C a, Module.C a a) => a -> a -> [a]

fastBell sampleRate freq =
    zipWith (*) (Osci.staticSine 0 (freq/sampleRate))
                (exponential2 (0.2*sampleRate) 1)

filterSaw :: (Module.C a a, Trans.C a, RealField.C a) =>
             a -> a -> a -> [a]
filterSaw sampleRate filterFreq freq =
    map (\r -> UniFilter.lowpass r * 0.1)
        (UniFilter.run (map (UniFilter.parameter . FiltR.Pole 10)
                        (exponential2 (0.1*sampleRate) (filterFreq/sampleRate)))
                   (Osci.staticSaw 0 (freq/sampleRate)))

squareBell sampleRate freq = Filt1.lowpass
         (map Filt1.parameter
              (exponential2 (sampleRate/10) (4000/sampleRate)))
--       (Osci.freqModSample Interpolation.cubic [0, 0.7, -0.3, 0.7, 0, -0.7, 0.3, -0.7] 0
         (Osci.freqModSample Interpolation.linear [0, 0.5, 0.6, 0.8, 0, -0.5, -0.6, -0.8] 0
                  (map (\modu -> freq/sampleRate*(1+modu/100))
                       (Osci.staticSine 0 (5.0/sampleRate))))

fmBell :: (RealField.C a, Trans.C a) => a -> a -> a -> a -> [a]
fmBell sampleRate depth freqRatio freq =
   let modul = FiltNR.envelope (exponential2 (0.2*sampleRate) depth)
                        (Osci.staticSine 0 (freqRatio*freq/sampleRate))
       env   = exponential2 (0.5*sampleRate) 1
   in  FiltNR.envelope env (Osci.phaseModSine (freq/sampleRate) modul)

moogGuitar sampleRate freq =
   let moogOrder = 4
       filterControl =
          map (Moog.parameter moogOrder)
              (map (FiltR.Pole 10) (exponential2
                               (0.5*sampleRate)
                               (4000/sampleRate)))
       tone = Osci.freqModSaw 0 (map (\modu -> freq/sampleRate*(1+0.005*modu))
                                (Osci.staticSine 0 (5.0/sampleRate)))
   in  Moog.lowpass moogOrder filterControl tone

moogGuitarSoft sampleRate freq =
   FiltNR.envelope (map (1-) (exponential2 (0.003*sampleRate) 1))
            (moogGuitar sampleRate freq)



{-| low pass with resonance -}
filterSweep :: (Field.C v, Module.C a v, Trans.C a, RealField.C a) =>
                  a -> a -> [v] -> [v]
filterSweep sampleRate phase =
    map (\r -> UniFilter.lowpass r / 2) .
    UniFilter.run
        (map (\freq ->
                UniFilter.parameter (FiltR.Pole 10 ((1800/sampleRate)*2**freq)))
             (Osci.staticSine phase (1/16/sampleRate))
        )


fatSawChordFilter, fatSawChord ::
   (RealField.C a, Trans.C a, Module.C a a) => a -> a -> [a]

fatSawChordFilter sampleRate freq =
    map (\r -> UniFilter.lowpass r / 2)
        (UniFilter.run (filterDown sampleRate)
                   (fatSawChord sampleRate freq))

fatSawChord sampleRate freq =
    zipWith3 (\x y z -> (x+y+z)/3)
             (fatSaw sampleRate (1  *freq))
             (fatSaw sampleRate (5/4*freq))
             (fatSaw sampleRate (3/2*freq))

filterDown :: (RealField.C a, Trans.C a) => a -> [UniFilter.Parameter a]

filterDown sampleRate =
    map UniFilter.parameter $
    map (FiltR.Pole 10) $
    exponential2 (sampleRate/3) (4000/sampleRate)

simpleSaw sampleRate freq = 
    Osci.staticSaw 0 (freq/sampleRate)

{-| accumulate multiple similar saw sounds and observe the increase of volume
    The oscillator @osc@ must accept relative frequencies. -}
modulatedWave :: (Trans.C a, RealField.C a) =>
   a -> (a -> [a] -> [a]) -> a -> a -> a -> a -> a -> [a]
modulatedWave sampleRate osc freq start depth phase speed =
   osc start (map (\x -> freq/sampleRate*(1+x*depth))
                  (Osci.staticSine phase (speed/sampleRate)))

accumulatedSaws :: (Random a, Trans.C a, RealField.C a) => a -> a -> [[a]]
accumulatedSaws sampleRate freq =
   let starts = randomRs (0,1)     (mkStdGen 48251)
       depths = randomRs (0,0.02)  (mkStdGen 12354)
       phases = randomRs (0,1)     (mkStdGen 74389)
       speeds = randomRs (0.1,0.3) (mkStdGen 03445)
       saws   = zipWith4 (modulatedWave sampleRate Osci.freqModSaw freq)
                         starts depths phases speeds
   in  scanl1 (zipWith (+)) saws

choirWave :: Field.C a => [a]
choirWave =
   [0.702727421560071, 0.7378359559947721, 0.7826845805704197, 0.6755514176072053,
   0.4513448069764686, 0.3272995923197175, 0.3404887595570093, 0.41416011004660863,
   0.44593673999775735, 0.4803528740412951, 0.48761174828621334, 0.44076701468836754,
   0.39642906530439503, 0.35467843549395706, 0.38054627445988315, 0.3888748481589558,
   0.35303993804564215, 0.3725196582177455, 0.44980257249714667, 0.5421204370443772,
   0.627630436752643, 0.6589491426946169, 0.619819155051891, 0.5821754728547365,
   0.5495877076869761, 0.5324446834830168, 0.47242861142812065, 0.3686685958119909,
   0.2781440436733245, 0.2582500464201269, 0.1955614176372372, 0.038373557320540604,
   -0.13132155046556182, -0.21867394831598339, -0.24302145520904606, -0.3096437514614372,
   -0.44774961666697943, -0.5889830267579028, -0.7168993833444837, -0.816723038671071,
   -0.8330283834679535, -0.8384077057999397, -0.8834813451725689, -0.9159391171556484,
   -0.9189751669797644, -0.8932026446626791, -0.8909164153221475, -0.9716732300637536,
   -1, -0.9253833606736654, -0.8568630538844477, -0.863932337623625,
   -0.857811827480001, -0.8131204084064676, -0.7839286071242304, -0.7036632045472225,
   -0.5824648346845637, -0.46123726085299827, -0.41391985851146285, -0.45323938111069567,
   -0.5336689022602625, -0.5831307769323063, -0.5693896103843189, -0.48596981886424745,
   -0.35791155598992863, -0.2661471984133689, -0.24158092840946802, -0.23965213828744264,
   -0.23421368394531547, -0.25130667896294306, -0.3116359503337366, -0.31263345635966144,
   -0.1879031874103659, -0.00020936838180399674, 0.18567090309156153, 0.2713525359068149,
   0.2979908042971701, 0.2957704726566382, 0.28820375086489286, 0.364513508557745,
   0.4520234711163569, 0.43210542988077005, 0.4064955825278379, 0.4416784798648095,
   0.5240917981530765, 0.6496469543088884, 0.7658103369723797, 0.8012776441058732,
   0.7824042138292476, 0.752678361663059, 0.760211176708886, 0.7308266231622353]


choir :: (Random a, Trans.C a, RealField.C a) => a -> a -> [a]
choir sampleRate freq =
   let starts = randomRs (0,1)     (mkStdGen 48251)
       depths = randomRs (0,0.02)  (mkStdGen 12354)
       phases = randomRs (0,1)     (mkStdGen 74389)
       speeds = randomRs (0.1,0.3) (mkStdGen 03445)
       voices = zipWith4 (modulatedWave sampleRate
                            (Osci.freqModSample Interpolation.constant choirWave) freq)
                         starts depths phases speeds
   in  map (*0.2) ((scanl1 (zipWith (+)) voices) !! 10)


fatSaw sampleRate freq =
    {- a simplified version of modulatedWave -}
    let partial depth modPhase modFreq =
           osciDoubleSaw sampleRate
              (map (\x -> freq*(1+x*depth))
                   (Osci.staticSine modPhase (modFreq/sampleRate)))
    in  zipWith3 (((((/3).).(+)).).(+))
            (partial 0.00311 0.0 20)
            (partial 0.00532 0.3 17)
            (partial 0.00981 0.9  6)

osciDoubleSaw :: (RealField.C a, Module.C a a) => a -> [a] -> [a]
osciDoubleSaw sampleRate =
    Osci.freqModSample Interpolation.linear [-1, -0.2, 0.5, -0.5, 0.2, 1.0] 0
      . map (/sampleRate)


{-| A tone with a waveform with roughly the dependency x -> x**p,
    where the waveform is normalized to constant quadratic norm -}
osciSharp :: (RealField.C a, Trans.C a) => a -> a -> [a]
osciSharp sampleRate freq =
   let --control = iterate (+ (-1/sampleRate)) 4
       control = exponential2 (0.01*sampleRate) 10
   in  Osci.shapeMod Wave.powerNormed 0 (freq/sampleRate) control

{-| Build a saw sound from its harmonics and modulate it.
    Different to normal modulation
    I modulate each harmonic with the same depth rather than a proportional one. -}
osciAbsModSaw :: (RealField.C a, Trans.C a) => a -> a -> [a]
osciAbsModSaw sampleRate freq =
   let ratios     = map fromIntegral [(1::Int)..20]
       harmonic n = FiltNR.amplify (0.25/n)
          (Osci.freqModSine 0 (map (\x -> (n+0.03*x)*freq/sampleRate)
                              (Osci.staticSine 0 (1/sampleRate))))
   in  mixMulti (map harmonic ratios)

{-| Short pulsed Noise.white,
    i.e. Noise.white amplified with pulses of varying H\/L ratio. -}
pulsedNoise :: (Ring.C a, Random a, RealField.C a, Trans.C a) =>
       a
   ->  a   {-^ frequency of the pulses, interesting ones are around 100 Hz and below -}
   -> [a]
pulsedNoise sampleRate freq =
   zipWith3 (\thr0 thr1 x -> if thr0+1 < (thr1+1)*0.2 then x else 0)
            (Osci.staticSine 0 (freq/sampleRate)) (Osci.staticSine 0 (0.1/sampleRate)) Noise.white

noiseBass :: (Ring.C a, Random a, RealField.C a, Trans.C a, Module.C a a) =>
       a
   ->  a
   -> [a]
noiseBass sampleRate freq =
   let y  = FiltNR.envelope (exponential2 (0.1*sampleRate) 1) Noise.white
       ks = Comb.runProc (round (sampleRate/freq))
               (Filt1.lowpass
                   (repeat (Filt1.parameter (2000/sampleRate)))) y
   in  ks

{-| Drum sound using the Karplus-Strong-Algorithm
    This is a Noise.white enveloped by an exponential2
    which is piped through the Karplus-Strong machine
    for generating some frequency.
    The whole thing is then frequency modulated
    to give a falling frequency. -}
electroTom :: (Ring.C a, Random a, RealField.C a, Trans.C a, Module.C a a) =>
   a -> [a]
electroTom sampleRate =
   let y  = FiltNR.envelope (exponential2 (0.1*sampleRate) 1) Noise.white
       ks = Comb.runProc (round (sampleRate/30))
                     (Filt1.lowpass
                         (repeat $ Filt1.parameter (1000/sampleRate))) y
   in  Interpolation.multiRelativeZeroPadLinear 0 (exponential2 (0.3*sampleRate) 1) ks