module Synthesizer.Plain.Effect.Glass where
import qualified Data.EventList.Relative.TimeBody as EventList
import qualified Number.NonNegative as NonNeg
import qualified Synthesizer.Plain.Oscillator as Osci
import qualified Synthesizer.Basic.Wave as Wave
import qualified Synthesizer.Plain.Cut as Cut
import qualified Synthesizer.Plain.Control as Ctrl
import qualified Synthesizer.Plain.Noise as Noise
import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR
import qualified Algebra.Transcendental as Trans
import qualified Algebra.RealField as RealField
import qualified Algebra.Additive as Additive
import qualified Algebra.Module as Module
import System.Random(randomRs, mkStdGen)
import NumericPrelude.Base
import NumericPrelude.Numeric as NP
glass :: Double -> [Double]
glass sampleRate =
Cut.arrange (particles sampleRate 1500)
particles :: Double -> Double -> EventList.T NonNeg.Int [Double]
particles sampleRate freq =
let sampledDensity =
(2000/sampleRate) *> map densityHeavy [0, (1/sampleRate) ..]
pattern = take (round (0.8*sampleRate))
(Noise.randomPeeks sampledDensity)
times = timeDiffs pattern
chirp = iterate (0.001+) 0
pitches = map ((freq*) . (2**))
(zipWith (+) chirp (randomRs (0,1) (mkStdGen 56)))
amps = map (0.4*) (map (2**) (randomRs (2,0) (mkStdGen 721)))
in EventList.fromPairList $ zip times $
zipWith (particle sampleRate) pitches amps
particle :: (RealField.C a, Trans.C a, Module.C a a) => a -> a -> a -> [a]
particle sampleRate freq amp =
let halfLife = 0.01
in take (round (10*halfLife*sampleRate))
(FiltNR.envelopeVector
(Osci.static Wave.square 0 (freq/sampleRate))
(Ctrl.exponential2 (0.01*sampleRate) amp))
densitySmooth, densityHeavy :: Trans.C a => a -> a
densitySmooth x = x * exp(10*x*x)
densityHeavy x = 0.4 * exp (4*x)
timeDiffsAlt :: [Bool] -> [NonNeg.Int]
timeDiffsAlt =
let diffs n (True : xs) = n : diffs 1 xs
diffs n (False : xs) = diffs (succ n) xs
diffs _ [] = []
in diffs (NonNeg.fromNumber 0)
timeDiffs :: [Bool] -> [NonNeg.Int]
timeDiffs = map (NonNeg.fromNumber . length) . segmentBefore id
segmentBefore :: (a -> Bool) -> [a] -> [[a]]
segmentBefore p =
foldr (\ x ~(y:ys) -> (if p x then ([]:) else id) ((x:y):ys)) [[]]