synthesizer-0.0.3: src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs
{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}
module Main (main) where
-- module Synthesizer.Dimensional.RateAmplitude.Demonstration where
import qualified Synthesizer.Dimensional.Rate.Oscillator as Osci
import qualified Synthesizer.Dimensional.Rate.Filter as Filt
import qualified Synthesizer.Dimensional.RateAmplitude.Displacement as Disp
import qualified Synthesizer.Dimensional.RateAmplitude.Noise as Noise
-- import qualified Synthesizer.SampleRateDimension.Filter.Recursive as FiltR
-- import qualified Synthesizer.SampleRateDimension.Filter.NonRecursive as FiltNR
import qualified Synthesizer.Dimensional.RateAmplitude.Filter as FiltA
import qualified Synthesizer.Dimensional.RateAmplitude.Cut as Cut
import qualified Synthesizer.Dimensional.Amplitude.Cut as CutA
import qualified Synthesizer.Dimensional.Rate.Cut as CutR
import qualified Synthesizer.Dimensional.RateAmplitude.Control as Ctrl
import qualified Synthesizer.Dimensional.Rate.Control as CtrlR
import qualified Synthesizer.Dimensional.Straight.Displacement as DispS
import qualified Synthesizer.Dimensional.Amplitude.Analysis as Ana
import qualified Synthesizer.Dimensional.Process as Proc
import qualified Synthesizer.Dimensional.Cyclic.Signal as SigC
import qualified Synthesizer.Dimensional.Straight.Signal as SigS
import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigA
import qualified Synthesizer.Dimensional.RateAmplitude.File as File
import qualified Synthesizer.Dimensional.RateAmplitude.Play as Play
import qualified Synthesizer.Dimensional.RateWrapper as SigP
import Synthesizer.Dimensional.RateAmplitude.Signal (($-), ($&), (&*^), (&*>^), )
import Synthesizer.Dimensional.Process (($:), ($::), (.:), ($^), (.^), ($#))
import Synthesizer.Dimensional.Amplitude.Control (mapLinear, mapExponential, )
import Synthesizer.Dimensional.RateAmplitude.Instrument (wasp, )
import qualified Synthesizer.Frame.Stereo as Stereo
import qualified Synthesizer.Generic.SampledValue as Sample
import qualified Synthesizer.State.Interpolation as Interpolation
import Synthesizer.Plain.Instrument (choirWave)
import qualified Synthesizer.Basic.WaveSmoothed as WaveSmooth
import qualified Synthesizer.Basic.Wave as Wave
import qualified Synthesizer.Basic.Phase as Phase
import qualified Algebra.DimensionTerm as Dim
import qualified Number.DimensionTerm as DN
import Number.DimensionTerm ((*&))
import qualified Number.NonNegative as NonNeg
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 System.Random (Random, randomRs, mkStdGen)
import Synthesizer.Utility (snd3, thd3, )
import Data.List(zip4)
import PreludeBase
import NumericPrelude
{-# INLINE sineLow #-}
sineLow ::
(RealField.C q, Trans.C q, Module.C q q, Sample.C q) =>
Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)
sineLow =
DN.voltage 1 &*^
Osci.static Wave.sine zero (DN.frequency 440)
{-# INLINE sineHigh #-}
sineHigh ::
(RealField.C q, Trans.C q, Module.C q q, Sample.C q) =>
Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)
sineHigh =
DN.voltage 1 &*^
Osci.static Wave.sine zero (DN.frequency 660)
{-# INLINE sineMix #-}
sineMix ::
(RealField.C q, Trans.C q, Module.C q q, Sample.C q) =>
Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)
sineMix =
FiltA.amplify 0.5 $: (Disp.mix $: sineLow $: sineHigh)
{-# INLINE exponential #-}
exponential ::
(RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>
Proc.T s Dim.Time q (SigS.R s q)
exponential =
CtrlR.exponential (DN.time 0.3)
{-# INLINE ping #-}
ping ::
(RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>
Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)
ping =
Filt.envelope
$: exponential
$: sineLow
{-# INLINE sawWave #-}
sawWave :: (RealField.C a) => Wave.T a a
sawWave = Wave.triangleAsymmetric (-0.9)
{-
{-# INLINE saw #-}
saw ::
(RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>
Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)
saw =
DN.voltage 1 &*^ Osci.static sawWave zero (DN.frequency 440)
-}
{-# INLINE sawVibrato #-}
sawVibrato ::
(RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>
Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)
sawVibrato =
DN.voltage 1 &*^
(Osci.freqMod sawWave zero
$: (mapLinear 0.01 (DN.frequency 440) $^ Osci.static Wave.sine zero (DN.frequency 5)))
{-# INLINE sawChorus #-}
sawChorus ::
(RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>
Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)
sawChorus =
let v = DN.voltage (1/4)
in Disp.mixMulti
$:: (v &*^ Osci.static sawWave (Phase.fromRepresentative 0.00) (DN.frequency 442.0) :
v &*^ Osci.static sawWave (Phase.fromRepresentative 0.25) (DN.frequency 441.2) :
v &*^ Osci.static sawWave (Phase.fromRepresentative 0.50) (DN.frequency 438.7) :
v &*^ Osci.static sawWave (Phase.fromRepresentative 0.75) (DN.frequency 438.1) :
[])
{-# INLINE amplitudeModulationChirp #-}
amplitudeModulationChirp ::
(RealField.C q, Trans.C q) =>
Proc.T s Dim.Time q (SigS.R s q)
amplitudeModulationChirp =
Filt.envelope
$: (Osci.static Wave.sine zero (DN.frequency 440))
$: (Osci.freqMod Wave.sine zero
$: (Ctrl.exponentialFromTo
(DN.time 10)
(DN.frequency 1, DN.frequency 1000)))
{-# INLINE airplane #-}
airplane ::
(RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>
Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)
airplane =
SigA.share
(Noise.white (DN.frequency 20000) (DN.voltage 0.2))
(\noise ->
Cut.take (DN.time 5) $: (Disp.mix
$: noise
$: (Filt.frequencyModulation Interpolation.linear
$- DN.scalar 1.001
$: noise)))
{-# INLINE airplaneFade #-}
airplaneFade ::
Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double Double)
airplaneFade =
Filt.envelope
$: (DispS.map (\t -> recip (1 + 30*(t-1)^2)) $^ CtrlR.linear (DN.time 5))
-- $: Osci.static Wave.sine zero (DN.recip (DN.time 20))
$: (Filt.phaser Interpolation.linear (DN.time 0.01)
$: Ctrl.exponentialFromTo
(DN.time 10)
(DN.unrecip (DN.frequency 5000), DN.unrecip (DN.frequency 100))
$: Noise.white (DN.frequency 20000) (DN.voltage 0.5))
{-# INLINE wind #-}
wind ::
(RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>
Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)
wind =
Filt.lowpassFromUniversal $:
(Filt.universal
$- DN.scalar 20
$: (mapExponential 2 (DN.frequency 1000) $^
(Disp.mix
$: DN.scalar 0.5 &*^ Osci.static Wave.sine zero (DN.frequency 0.2)
$: DN.scalar 1.0 &*^ Osci.static Wave.sine zero (DN.frequency (sqrt 0.2))))
$: Noise.white (DN.frequency 20000) (DN.voltage 0.2))
{-# INLINE windStereo #-}
windStereo ::
(RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>
Proc.T s Dim.Time q (SigA.R s Dim.Voltage q (Stereo.T q))
windStereo =
SigA.share
wind
(\w -> Cut.mergeStereo $: w $: (Cut.drop (DN.time 0.5) $: w))
{-# INLINE glissandoControl #-}
glissandoControl ::
(RealField.C q, Trans.C q, Module.C q q, Random q) =>
Proc.T s Dim.Time q (SigA.R s Dim.Scalar q q)
glissandoControl =
Filt.firstOrderLowpass
$- DN.frequency 4
$: (Cut.concatVolume (DN.scalar 1) $:
mapM (\p ->
Cut.take (DN.time (1/6))
$: Ctrl.constant (DN.scalar (fromInteger p / 12)))
(randomRs (0,24) (mkStdGen 3141)))
{-# INLINE bassFilter #-}
bassFilter ::
(RealField.C q, Trans.C q, Module.C q q, Random q) =>
Proc.T s Dim.Time q (SigA.R s Dim.Voltage q (Stereo.T q))
bassFilter =
Filt.lowpassFromUniversal $:
(Filt.universal
$- DN.scalar 5
{-
$- DN.frequency 440
-}
$: (mapExponential 2 (DN.frequency 440) $^
glissandoControl)
{-
$: (mapExponential 10 (DN.frequency 440) $^
Osci.static Wave.sine zero (DN.frequency 0.2))
-}
$: (Cut.mergeStereo
$: DN.voltage 1 &*^ Osci.static Wave.saw zero (DN.frequency 55.0)
$: DN.voltage 1 &*^ Osci.static Wave.saw zero (DN.frequency 55.1)))
{-# INLINE noiseLowpass #-}
noiseLowpass ::
(RealField.C q, Trans.C q, Module.C q q, Random q) =>
Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)
noiseLowpass =
let noise = Noise.white (DN.frequency 20000) (DN.voltage 0.1)
control =
Ctrl.exponentialFromTo
(DN.time 5)
(DN.frequency 10000, DN.frequency 10)
in Filt.firstOrderLowpass
$: control
$: noise
{-# INLINE noiseHighpass #-}
noiseHighpass ::
(RealField.C q, Trans.C q, Module.C q q, Random q) =>
Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)
noiseHighpass =
let noise = Noise.white (DN.frequency 20000) (DN.voltage 0.1)
control =
Ctrl.exponentialFromTo
(DN.time 5)
(DN.frequency 10000, DN.frequency 10)
in Filt.firstOrderHighpass
$: control
$: noise
{-# INLINE bubbles #-}
bubbles ::
(RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>
Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)
bubbles =
let delay = 0.24
in Filt.comb (DN.time delay) (0.5 `asTypeOf` delay) $:
(DN.voltage 0.5 &*^
(Osci.freqMod Wave.sine zero $:
(mapExponential 0.5 (DN.frequency 440) $^
(Disp.mix
$: DN.scalar 1.5 &*^ Osci.static Wave.saw zero (DN.frequency 0.5)
$: DN.scalar 0.5 &*^ Osci.static Wave.saw zero (DN.frequency 10)))))
{-# INLINE bubblesStereo #-}
bubblesStereo ::
(RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>
Proc.T s Dim.Time q (SigA.R s Dim.Voltage q (Stereo.T q))
bubblesStereo =
let delay = 0.24
{-# INLINE channel #-}
channel f =
DN.voltage 0.5 &*^
(Osci.freqMod Wave.sine zero $:
(mapExponential 0.5 (DN.frequency 440) $^
(Disp.mix
$: DN.scalar 1.5 &*^ Osci.static Wave.saw zero (DN.frequency 0.5)
$: DN.scalar 0.5 &*^ Osci.static Wave.saw zero f)))
in Filt.comb (DN.time delay) (0.5 `asTypeOf` delay) $:
(Cut.mergeStereo
$: channel (DN.frequency 10)
$: channel (DN.frequency 9.23))
{-# INLINE dampedEcho #-}
dampedEcho ::
(RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>
Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)
dampedEcho =
FiltA.combProc (DN.time 0.2)
(Filt.firstOrderLowpass $- DN.frequency 1000)
$: (Filt.envelope
$: CtrlR.exponential2 (DN.time 0.1)
$: DN.voltage 1 &*^ Osci.static Wave.saw zero (DN.frequency 440))
{-# INLINE trapezoid #-}
trapezoid ::
(RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>
Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)
trapezoid =
Filt.mean (DN.frequency 500)
$: (mapExponential 4 (DN.frequency 2000) $^ Osci.static Wave.sine zero (DN.frequency 1))
$: DN.voltage 0.7 &*^ Osci.static (Wave.trapezoid 0.9) zero (DN.frequency 440)
{-
Filt.meanStatic (DN.frequency 440)
$: DN.voltage 1 &*^ Osci.static Wave.square zero (DN.frequency 440)
-}
{-# INLINE staticSine #-}
staticSine ::
(RealField.C q, Trans.C q) =>
Proc.T s Dim.Time q (SigS.R s q)
staticSine =
CutR.take (DN.time 10)
$: (Osci.static Wave.sine zero (DN.frequency 440))
{-# INLINE harmonicTone #-}
harmonicTone ::
(RealField.C q, Trans.C q, Module.C q q) =>
[(DN.Frequency q, q, Phase.T q)] ->
Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)
harmonicTone hs =
let k = recip (sum (map (abs . snd3) hs))
in Disp.mixMulti $::
map (\(f, amp, phase) ->
DN.voltage (amp*k) &*^
Osci.static Wave.sine phase f) hs
newtype Sound q v =
Sound {fromSound :: forall s. Proc.T s Dim.Time q (SigA.R s Dim.Voltage q v)}
{-# INLINE harmonicExamples #-}
harmonicExamples ::
(RealField.C q, Trans.C q, Module.C q q) =>
[(FilePath, Sound q q)]
harmonicExamples =
do expo <- [0,1,2]
(harmName,harm::[Int])
<- [("all", take 10 [1 ..]), ("odd", take 10 [1,3 ..])]
(phaseName,phase)
<- [("sin", Phase.fromRepresentative 0),
("cos", Phase.fromRepresentative (1/4))]
return
("power" ++ show expo ++ harmName ++ "-" ++ phaseName,
Sound
(harmonicTone
(map ((\n -> (n *& DN.frequency 440,
recip (n ^ expo),
phase))
. fromIntegral)
harm)))
{- |
Morphing shapes with constant sound.
By shifting the frequency of all harmonics up by an constant amount,
the periods of the harmonic do no longer match
and recombine only afte a period that depends on the frequency shift.
At the beginning we have the waveform of mixed sines,
after a quarter period of the shift frequency we have mixed cosines and so on.
-}
{-# INLINE harmonicMorph #-}
harmonicMorph ::
(RealField.C q, Trans.C q, Module.C q q) =>
[(FilePath, Sound q q)]
harmonicMorph =
do expo <- [0,1,2]
(harmName,harm::[Int])
<- [("all", take 10 [1 ..]), ("odd", take 10 [1,3 ..])]
return
("power" ++ show expo ++ harmName ++ "-shift",
Sound
(harmonicTone
(map ((\n -> (n *& DN.frequency 440 + DN.frequency 1,
recip (n ^ expo),
zero))
. fromIntegral)
harm)))
{-# INLINE waveforms #-}
waveforms ::
(RealField.C q, Trans.C q, Module.C q q) =>
[(FilePath, Sound q q)]
waveforms =
do (name,wave)
<- ("square", Wave.trapezoid 0.9) :
("triangle", Wave.triangle) :
("saw", sawWave) :
[]
return
(name,
Sound
(DN.voltage 1 &*^ Osci.static wave zero (DN.frequency 440)))
{-# INLINE waveformsBandlimited #-}
waveformsBandlimited ::
(RealField.C q, Trans.C q, Module.C q q) =>
[(FilePath, Sound q q)]
waveformsBandlimited =
do (name,wave)
<- ("square", WaveSmooth.square) :
("triangle", WaveSmooth.triangle) :
("saw", WaveSmooth.saw) :
("sine", WaveSmooth.sine) :
("harmonic", WaveSmooth.composedHarmonics $
let k = 0.5
in [WaveSmooth.harmonic zero 0,
WaveSmooth.harmonic zero k,
WaveSmooth.harmonic zero (k/2),
WaveSmooth.harmonic zero (k/3),
WaveSmooth.harmonic zero (k/4)]) :
[]
return
(name++"-antialias-chirp",
Sound
(DN.voltage 1 &*^ (Osci.freqModAntiAlias wave zero $:
Ctrl.line (DN.time 10) (DN.frequency (-30000), DN.frequency 30000))))
main :: IO ()
main =
do
{-
Play.timeVoltageMonoDoubleR (DN.frequency 44100) bubbles
-}
{-
File.writeTimeVoltage "chirp"
(SigP.runProcess
(DN.frequency (44100::Double))
(DN.voltage 1 &*^ amplitudeModulationChirp))
-}
mapM_
(\(name, sound) ->
putStrLn name >>
File.renderTimeVoltageStereoDouble
(DN.frequency 44100) name (fromSound sound)) $
("bass-filter", Sound (Cut.take (DN.time 15) $: bassFilter)) :
("wind", Sound (Cut.take (DN.time 10) $: windStereo)) :
("bubbles", Sound (Cut.take (DN.time 10) $: bubblesStereo)) :
[]
mapM_
(\(name, sound) ->
putStrLn name >>
File.renderTimeVoltageMonoDouble
(DN.frequency 44100) name (fromSound sound)) $
("sine-low", Sound (Cut.take (DN.time 1) $: sineLow)) :
("sine-high", Sound (Cut.take (DN.time 1) $: sineHigh)) :
("sine-mix", Sound (Cut.take (DN.time 1) $: sineMix)) :
("exponential", Sound (Cut.take (DN.time 1) $: DN.voltage 1 &*^ exponential)) :
("ping", Sound (Cut.take (DN.time 1) $: ping)) :
-- ("saw", Sound (Cut.take (DN.time 2) $: saw)) :
("saw-vibrato", Sound (Cut.take (DN.time 2) $: sawVibrato)) :
("saw-chorus", Sound (Cut.take (DN.time 2) $: sawChorus)) :
("wasp", Sound (Cut.take (DN.time 5) $: wasp (DN.frequency 110))) :
("trapezoid", Sound (Cut.take (DN.time 5) $: trapezoid)) :
("damped-echo", Sound (Cut.take (DN.time 4) $: dampedEcho)) :
("chirp", Sound (DN.voltage 1 &*^ amplitudeModulationChirp)) :
("airplane", Sound airplane) :
{- This becomes considerably faster, if other effects are not rendered.
This is obviously an optimizer bug. -}
("airplane-fade", Sound airplaneFade) :
("noise-lowpass1", Sound noiseLowpass) :
("noise-highpass1", Sound noiseHighpass) :
[]
flip mapM_ waveformsBandlimited $
\(fileName, tone) ->
putStrLn fileName >>
File.renderTimeVoltageMonoDouble
(DN.frequency 44100) fileName
(fromSound tone)
flip mapM_ (harmonicExamples ++ harmonicMorph ++ waveforms) $
\(fileName, tone) ->
putStrLn fileName >>
File.renderTimeVoltageMonoDouble
(DN.frequency 44100) fileName
(Cut.take (DN.time 1) $: fromSound tone)
{-
import installed synthesizer package
ghc-core -f html -- -o dist/build/demonstration/demonstration -Wall -O2 -fexcess-precision -fvia-C -optc-O2 -package synthesizer src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs >dist/build/demonstration/demonstration.html
ghc -o dist/build/demonstration/demonstration -Wall -O2 -fexcess-precision -fvia-C -optc-O2 -ddump-simpl-stats -package synthesizer src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs
ghc -o dist/build/demonstration/demonstration -O -Wall -fexcess-precision -ddump-simpl-stats -package synthesizer src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs
ghc -o dist/build/demonstration/demonstration -O -Wall -fexcess-precision -ddump-simpl -package synthesizer src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs >dist/build/Demonstration.log
with assembly output
ghc -o dist/build/fusiontest/fusiontest -O -Wall -fexcess-precision -ddump-simpl-stats -ddump-asm -package synthesizer speedtest/DemonstrationInlineMono.hs >dist/build/Demonstration.asm
with make and no explicit package specification:
ghc -Idist/build -o dist/build/demonstration/demonstration --make -Wall -O -fexcess-precision -ddump-simpl-stats -i -idist/build/autogen -isrc -odir dist/build/demonstration/demonstration-tmp -hidir dist/build/demonstration/demonstration-tmp src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs
with make and explicit package specification:
ghc --make -Idist/build -o dist/build/demonstration/demonstration -Wall -O -fexcess-precision -ddump-simpl-stats -ddump-simpl-iterations -i -idist/build/autogen -isrc -idist/build/demonstration/demonstration-tmp -odir dist/build/demonstration/demonstration-tmp -hidir dist/build/demonstration/demonstration-tmp -package base-1.0 -package mtl-1.0 -package non-negative-0.0.2 -package numeric-prelude-0.0.3 -package event-list-0.0.7 -package bytestring-0.9.0.5 -package binary-0.4.1 -package storablevector-0.1 src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs >src/Synthesizer/Dimensional/RateAmplitude/Demonstration.log
without make and with detailed simplifier report:
ghc -Idist/build -o dist/build/demonstration/demonstration -Wall -O -fexcess-precision -ddump-simpl-stats -ddump-simpl-iterations -i -idist/build/autogen -isrc -idist/build/demonstration/demonstration-tmp -odir dist/build/demonstration/demonstration-tmp -hidir dist/build/demonstration/demonstration-tmp -package base-1.0 -package mtl-1.0 -package non-negative-0.0.2 -package numeric-prelude-0.0.3 -package event-list-0.0.7 -package HTam-0.0 -package numeric-quest-0.1 -package bytestring-0.9.0.5 -package binary-0.4.1 -package storablevector-0.1 dist/build/HSsynthesizer*.o src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs >src/Synthesizer/Dimensional/RateAmplitude/Demonstration.log
-}