synthesizer-llvm-0.8.1.1: example/Synthesizer/LLVM/Test.hs
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeFamilies #-}
module Main where
import Synthesizer.LLVM.LAC2011 ()
import qualified Synthesizer.LLVM.Server.Default as Default
import qualified Synthesizer.LLVM.Server.SampledSound as Sample
import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked as BandPass
import qualified Synthesizer.LLVM.Filter.Allpass as Allpass
import qualified Synthesizer.LLVM.Filter.Butterworth as Butterworth
import qualified Synthesizer.LLVM.Filter.Chebyshev as Chebyshev
import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1
import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2
import qualified Synthesizer.LLVM.Filter.SecondOrderPacked as Filt2P
import qualified Synthesizer.LLVM.Filter.Moog as Moog
import qualified Synthesizer.LLVM.Filter.Universal as UniFilter
import qualified Synthesizer.LLVM.Filter.NonRecursive as FiltNR
import qualified Synthesizer.LLVM.CausalParameterized.Controlled as CtrlP
import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS
import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS
import qualified Synthesizer.LLVM.CausalParameterized.ProcessValue as CausalPV
import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP
import qualified Synthesizer.LLVM.CausalParameterized.Functional as Func
import qualified Synthesizer.LLVM.CausalParameterized.Helix as Helix
import qualified Synthesizer.LLVM.Causal.ProcessValue as CausalV
import qualified Synthesizer.LLVM.Causal.Process as Causal
import qualified Synthesizer.LLVM.Interpolation as Interpolation
import qualified Synthesizer.LLVM.Simple.Signal as Sig
import qualified Synthesizer.LLVM.Simple.Value as Value
import qualified Synthesizer.LLVM.Storable.Signal as SigStL
import qualified Synthesizer.LLVM.Wave as Wave
import qualified Synthesizer.LLVM.Parameter as Param
import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS
import qualified Synthesizer.LLVM.Parameterized.Signal as SigP
import Synthesizer.LLVM.CausalParameterized.Functional (($&), (&|&), )
import Synthesizer.LLVM.Causal.Process (($<), ($>), ($*), ($*#), )
import Synthesizer.LLVM.Simple.Value ((%>), (%&&), )
import Synthesizer.LLVM.Parameter (($#), )
import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt
import qualified Synthesizer.LLVM.Frame.Stereo as Stereo
import qualified Synthesizer.LLVM.Frame.SerialVector as Serial
import qualified Synthesizer.LLVM.Frame as Frame
import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.Arithmetic as A
import qualified LLVM.Extra.Maybe as Maybe
import qualified LLVM.Core as LLVM
import LLVM.Core (Value, valueOf, Vector, )
import LLVM.Util.Arithmetic () -- Floating instance for TValue
import qualified Type.Data.Num.Decimal as TypeNum
import Type.Data.Num.Decimal (D4, D8, D16, )
import Type.Base.Proxy (Proxy, )
import qualified Synthesizer.CausalIO.Process as PIO
import qualified Synthesizer.Causal.Class as CausalClass
import qualified Synthesizer.Zip as Zip
import qualified Synthesizer.State.Control as CtrlS
import qualified Synthesizer.State.Signal as SigS
import qualified Synthesizer.Plain.Filter.Recursive as FiltR
import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1Core
import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2Core
import Control.Arrow (Arrow, arr, (&&&), (^<<), (<<^), (***), )
import Control.Category ((<<<), (.), id, )
import Control.Applicative (pure, liftA2, )
import Control.Functor.HT (void, )
import Control.Monad (when, )
import qualified Data.StorableVector.Lazy as SVL
import qualified Data.StorableVector as SV
import Foreign.Storable (Storable, )
import qualified Data.EventList.Relative.TimeBody as EventList
import qualified Data.EventList.Relative.BodyTime as EventListBT
import qualified Data.EventList.Relative.MixedTime as EventListMT
import qualified Data.EventList.Relative.TimeMixed as EventListTM
import qualified Numeric.NonNegative.Wrapper as NonNeg
import qualified Sound.Sox.Option.Format as SoxOption
import qualified Sound.Sox.Play as SoxPlay
-- import qualified Synthesizer.ALSA.Storable.Play as Play
import qualified Data.NonEmpty.Class as NonEmptyC
import qualified Data.NonEmpty as NonEmpty
import qualified Data.Empty as Empty
import Data.NonEmpty ((!:), )
import Data.Traversable (sequenceA, )
import Data.Word (Word32, )
-- import qualified Data.Function.HT as F
import Data.List (genericLength, )
import System.Path ((</>), )
import System.Random (randomRs, mkStdGen, )
import qualified System.IO as IO
import Control.Exception (bracket, )
-- import System.Exit (ExitCode, )
import Prelude hiding (fst, snd, id, (.), )
import qualified NumericPrelude.Numeric as NP
import qualified Prelude as P
asMono :: vector Float -> vector Float
asMono = id
asStereo :: vector (Stereo.T Float) -> vector (Stereo.T Float)
asStereo = id
asMonoPacked :: vector (Serial.Plain D4 Float) -> vector (Serial.Plain D4 Float)
asMonoPacked = id
asMonoPacked16 :: vector (Serial.Plain D16 Float) -> vector (Serial.Plain D16 Float)
asMonoPacked16 = id
asStereoInterleaved :: vector (StereoInt.T D4 Float) -> vector (StereoInt.T D4 Float)
asStereoInterleaved = id
asWord32 :: vector Word32 -> vector Word32
asWord32 = id
asWord32Packed :: vector (Serial.Plain D4 Word32) -> vector (Serial.Plain D4 Word32)
asWord32Packed = id
{- |
> playStereo (Sig.amplifyStereo 0.3 $ stereoOsciSaw 0.01)
Unfortunately: If you call :reload,
then the next attempt to play something will be answered by:
ghci: JITEmitter.cpp:110: <unnamed>::JITResolver::JITResolver(llvm::JIT&): Assertion `TheJITResolver == 0 && "Multiple JIT resolvers?"' failed.
-}
playStereo :: Sig.T (Stereo.T (Value Float)) -> IO ()
playStereo =
playStereoVector .
Sig.renderChunky (SVL.chunkSize 100000)
playStereoVector :: SVL.Vector (Stereo.T Float) -> IO ()
playStereoVector =
void . SoxPlay.simple SVL.hPut SoxOption.none 44100
playMono :: Sig.T (Value Float) -> IO ()
playMono =
playMonoVector .
Sig.renderChunky (SVL.chunkSize 100000)
playMonoVector :: SVL.Vector Float -> IO ()
playMonoVector =
void . SoxPlay.simple SVL.hPut SoxOption.none 44100
playFileMono :: FilePath -> IO ()
playFileMono fileName = do
IO.withFile fileName IO.ReadMode $ \h ->
playStereo .
Sig.fromStorableVectorLazy .
asStereo . snd
=<< SVL.hGetContentsAsync (SVL.chunkSize 4321) h
return ()
frequency :: Float -> Param.T p Float
frequency = return
{- |
Assist GHC-7.10.3 with determining the type of causal processes.
GHC-7.8.4 and GHC-8.0.1 do not need it.
-}
causalP :: CausalP.T p a b -> CausalP.T p a b
causalP = id
constant :: Float -> IO ()
constant y =
SV.writeFile "speedtest.f32" $ asMono $ flip Sig.render 1000 $ Sig.constant y
saw :: IO ()
saw =
SV.writeFile "speedtest.f32" $
asMono $
flip Sig.render 10000000 $
Sig.osciSaw 0 0.01
exponential :: IO ()
exponential =
SV.writeFile "speedtest.f32" $
asMono $
flip Sig.render 10000000 $
Sig.exponential2 50000 1
triangle :: IO ()
triangle =
SV.writeFile "speedtest.f32" $
asMono $
flip Sig.render 10000000 $
Sig.osci Wave.triangle 0.25 0.01
trianglePack :: IO ()
trianglePack =
SV.writeFile "speedtest.f32" $
asMonoPacked $
(\xs -> SigP.render xs (div 10000000 4) ()) $
Sig.map Wave.triangle $
SigPS.packSmall $
SigP.osciCore 0.25 (frequency 4.015803e-4)
trianglePacked :: IO ()
trianglePacked =
SV.writeFile "speedtest.f32" $
asMonoPacked $
(\xs -> SigP.render xs (div 10000000 4) ()) $
(causalP (CausalPS.osciSimple Wave.triangle)
$< SigPS.constant 0.25
$* SigPS.constant 0.01)
triangleReplicate :: IO ()
triangleReplicate =
SV.writeFile "speedtest.f32" $
asMonoPacked $
(\xs -> SigP.render xs (div 10000000 4) ()) $
(causalP
(CausalPS.shapeModOsci
(\k p -> do
x <- Wave.triangle =<< Wave.replicate k p
y <- Wave.approxSine4 =<< Wave.halfEnvelope p
A.mul x y))
$< SigPS.rampInf 1000000
$< SigPS.constant 0
$* SigPS.constant 0.01)
rationalSine :: IO ()
rationalSine =
SV.writeFile "speedtest.f32" $
asMonoPacked $
(\xs -> SigP.render xs (div 10000000 4) ()) $
(causalP (CausalPS.shapeModOsci Wave.rationalApproxSine1)
$< (0.001 + SigPS.rampInf 10000000)
$< SigPS.constant 0
$* SigPS.constant 0.01)
rationalSineStereo :: IO ()
rationalSineStereo =
SV.writeFile "speedtest.f32" $
SigStL.unpackStereoStrict $
asStereoInterleaved $
(\xs -> SigP.render xs (div 10000000 4) ()) $
Sig.map StereoInt.interleave $
liftA2 Stereo.cons
(causalP (CausalPS.shapeModOsci Wave.rationalApproxSine1)
$< (0.001 + SigPS.rampInf 10000000)
$< SigPS.constant (-0.25)
$* SigPS.constant 0.00999)
(causalP (CausalPS.shapeModOsci Wave.rationalApproxSine1)
$< (0.001 + SigPS.rampInf 10000000)
$< SigPS.constant 0.25
$* SigPS.constant 0.01001)
pingSig :: Float -> Sig.T (Value Float)
pingSig freq =
Sig.envelope
(Sig.exponential2 50000 1)
(Sig.osciSaw 0.5 freq)
pingSigP :: Param.T p Float -> SigP.T p (Value Float)
pingSigP freq =
SigP.envelope
(SigP.exponential2 50000 1)
(SigP.osciSaw 0.5 freq)
ping :: IO ()
ping =
SV.writeFile "speedtest.f32" $
asMono $
flip Sig.render 10000000 $
pingSig 0.01
pingSigPacked :: SigP.T Float (Serial.Value D4 Float)
pingSigPacked =
let freq = id
in SigP.envelope
(SigPS.exponential2 50000 1)
(SigPS.osciSimple Wave.saw 0 freq)
pingPacked :: IO ()
pingPacked =
SV.writeFile "speedtest.f32" $
asMonoPacked $
(\xs -> SigP.render xs (div 10000000 4) 0.01) $
pingSigPacked
pingUnpack :: IO ()
pingUnpack =
SV.writeFile "speedtest.f32" $
asMono $
(\xs -> SigP.render xs 10000000 0.01) $
SigPS.unpack $
pingSigPacked
pingSmooth :: IO ()
pingSmooth =
SV.writeFile "speedtest-scalar.f32" $
asMono $
(\xs -> SigP.render xs 10000000 ()) $
(causalP Filt1.lowpassCausal
$< (fmap Filt1Core.Parameter $
1 - (Sig.exponential2 50000 1))
$* SigP.osciSimple Wave.triangle 0 (frequency 0.01))
pingSmoothPacked :: IO ()
pingSmoothPacked =
SV.writeFile "speedtest-vector.f32" $
asMonoPacked $
(\xs -> SigP.render xs (div 10000000 4) ()) $
(causalP Filt1.lowpassCausalPacked
$< (fmap Filt1Core.Parameter $
1 - (Sig.exponential2 (50000/4) 1))
$* SigPS.osciSimple Wave.triangle 0 (frequency 0.01))
stereoOsciSaw :: Float -> Sig.T (Stereo.T (Value Float))
stereoOsciSaw freq =
liftA2 Stereo.cons
(Sig.osciSaw 0.0 (freq*1.001) `Sig.mix`
Sig.osciSaw 0.2 (freq*1.003) `Sig.mix`
Sig.osciSaw 0.1 (freq*0.995))
(Sig.osciSaw 0.1 (freq*1.005) `Sig.mix`
Sig.osciSaw 0.7 (freq*0.997) `Sig.mix`
Sig.osciSaw 0.5 (freq*0.999))
stereoOsciSawPacked :: Float -> Sig.T (Stereo.T (Value Float))
stereoOsciSawPacked freq =
let mix4 =
Frame.mixVector .
flip asTypeOf (undefined :: Value (Vector D4 Float))
in liftA2 Stereo.cons
(Sig.map mix4 $
Sig.osciPlain Wave.saw
(valueOf $ LLVM.vector $ 0.0 !: 0.2 !: 0.1 !: 0.4 !: Empty.Cons)
(valueOf $ LLVM.vector $ fmap (freq*) $
1.001 !: 1.003 !: 0.995 !: 0.996 !: Empty.Cons))
(Sig.map mix4 $
Sig.osciPlain Wave.saw
(valueOf $ LLVM.vector $ 0.1 !: 0.7 !: 0.5 !: 0.7 !: Empty.Cons)
(valueOf $ LLVM.vector $ fmap (freq*) $
1.005 !: 0.997 !: 0.999 !: 1.001 !: Empty.Cons))
stereoOsciSawPacked2 :: Float -> Sig.T (Stereo.T (Value Float))
stereoOsciSawPacked2 freq =
Sig.map (Frame.mixVectorToStereo .
flip asTypeOf (undefined :: Value (Vector D8 Float))) $
Sig.osciPlain (Wave.trapezoidSkew (A.fromRational' 0.2))
(valueOf $
LLVM.toVector (0.0, 0.2, 0.1, 0.4, 0.1, 0.7, 0.5, 0.7))
(valueOf $ LLVM.vector $ fmap (freq*) $
1.001 !: 1.003 !: 0.995 !: 0.996 !: 1.005 !: 0.997 !: 0.999 !: 1.001 !: Empty.Cons)
stereo :: IO ()
stereo =
SV.writeFile "speedtest.f32" $
asStereo $
flip Sig.render 10000000 $
Sig.amplifyStereo 0.25 $
stereoOsciSawPacked2 0.01
lazy :: IO ()
lazy =
SVL.writeFile "speedtest.f32" $
SVL.take 10000000 $
asMono $
Sig.renderChunky (SVL.chunkSize 100000)
{- SVL.defaultChunkSize - too slow -} $
Sig.envelope
(Sig.exponential2 50000 1)
(Sig.osci Wave.sine 0.5 0.01 :: Sig.T (Value Float))
lazyStereo :: IO ()
lazyStereo =
SVL.writeFile "speedtest.f32" $
SVL.take 10000000 $
asStereo $
Sig.renderChunky (SVL.chunkSize 100000) $
Sig.amplifyStereo 0.25 $
stereoOsciSawPacked 0.01
packTake :: IO ()
packTake =
SVL.writeFile "speedtest.f32" $
asMonoPacked $
flip (SigP.renderChunky (SVL.chunkSize 1000)) () $
SigPS.packRotate $
(CausalP.take 5 $*
SigP.osciSimple Wave.saw 0 (frequency 0.01))
chord :: Float -> Sig.T (Stereo.T (Value Float))
chord base =
{-
This exceeds available vector registers
and thus needs more stack accesses.
Thus it needs twice as much time as the simple mixing.
However doing all 32 oscillators in parallel
and mix them in one go might be still faster.
foldl1 (Sig.zipWith Frame.mixStereoV) $
-}
NonEmpty.foldBalanced Sig.mix $
fmap (\f -> stereoOsciSawPacked2 (base*f)) $
0.25 !: 1.00 : 1.25 : 1.50 : []
lazyChord :: IO ()
lazyChord =
SVL.writeFile "speedtest.f32" $
SVL.take 10000000 $
asStereo $
Sig.renderChunky (SVL.chunkSize 100000) $
Sig.amplifyStereo 0.1 $
chord 0.005
filterSweepComplex :: IO ()
filterSweepComplex =
SVL.writeFile "speedtest.f32" $
SVL.take 10000000 $
asStereo $
Sig.renderChunky (SVL.chunkSize 100000) $
Sig.amplifyStereo 0.3 $
Causal.apply BandPass.causal $
Sig.zip
(Sig.map (BandPass.parameter (valueOf 100)) $
Sig.map (\x -> 0.01 * exp (2 * return x)) $
Sig.osci Wave.sine 0 (0.1/44100)) $
chord 0.005
lfoSineCausal ::
CausalP.T p (Value Float) a -> Param.T p Float -> SigP.T p a
lfoSineCausal f reduct =
CausalP.apply f $
Sig.map (\x -> 0.01 * exp (2 * return x)) $
SigP.osciSimple Wave.sine 0 (reduct * 0.1/44100)
lfoSine ::
(Memory.C a) =>
(forall r. Value Float -> LLVM.CodeGenFunction r a) ->
Param.T p Float ->
SigP.T p a
lfoSine f = lfoSineCausal (Causal.map f)
filterSweep :: IO ()
filterSweep =
SVL.writeFile "speedtest.f32" $
SVL.take 10000000 $
asMono $
flip (SigP.renderChunky (SVL.chunkSize 10000)) () $
(0.2 *
CtrlP.processCtrlRate 128
(lfoSine (Filt2.bandpassParameter (valueOf 100)))
$* SigP.osciSimple Wave.saw 0 (frequency 0.01))
filterSweepPacked :: IO ()
filterSweepPacked =
SVL.writeFile "speedtest.f32" $
SVL.take (div 10000000 4) $
asMonoPacked $
flip (SigP.renderChunky (SVL.chunkSize 10000)) () $
(0.2 *
CtrlPS.processCtrlRate 128
(lfoSine (Filt2.bandpassParameter (valueOf 100)))
$* SigPS.osciSimple Wave.saw 0 0.01)
exponentialFilter2Packed :: IO ()
exponentialFilter2Packed =
SVL.writeFile "speedtest.f32" $
SVL.take (div 10000000 16) $
asMonoPacked16 $
flip (SigP.renderChunky (SVL.chunkSize 10000)) () $
(causalP Filt2.causalPacked
$< (SigP.constant $#
Filt2Core.Parameter (1::Float) 0 0 0 0.99)
$* (
-- (CausalP.delay1 $# Serial.fromFixedList (0.1 !: 0.01 !: 0.001 !: 0.0001 !: Empty.Cons))
-- (CausalP.delay1 $# Serial.replicate (1::Float))
(CausalP.delay1 $# Serial.fromFixedList ((1::Float) !: NonEmptyC.repeat 0))
$* 0))
filterSweepPacked2 :: IO ()
filterSweepPacked2 =
SVL.writeFile "speedtest.f32" $
SVL.take 10000000 $
asMono $
flip (SigP.renderChunky (SVL.chunkSize 10000)) () $
(0.2 *
CtrlP.processCtrlRate 128
(lfoSine (Filt2P.bandpassParameter (valueOf 100)))
$* SigP.osciSimple Wave.saw 0 (frequency 0.01))
butterworthNoisePacked :: IO ()
butterworthNoisePacked =
SVL.writeFile "speedtest.f32" $
SVL.take (div 10000000 4) $
asMonoPacked $
flip (SigP.renderChunky (SVL.chunkSize 10000)) () $
(CausalPS.amplify 0.2 .
CtrlPS.processCtrlRate 128
(lfoSineCausal
(CausalClass.applyConstFst
(Butterworth.parameterCausal TypeNum.d3 FiltR.Lowpass)
(valueOf 0.5)))
$* SigPS.noise 0 0.3)
chebyshevNoisePacked :: IO ()
chebyshevNoisePacked =
SVL.writeFile "speedtest.f32" $
SVL.take (div 10000000 4) $
asMonoPacked $
flip (SigP.renderChunky (SVL.chunkSize 10000)) () $
(CausalPS.amplify 0.2 .
CtrlPS.processCtrlRate 128
(lfoSineCausal
(CausalClass.applyConstFst
(Chebyshev.parameterCausalA TypeNum.d5 FiltR.Lowpass)
(valueOf 0.5)))
$* SigPS.noise 0 0.3)
{-
Provoke non-aligned vector accesses by calling alloca for a record of 5 floats
in LLVM-2.6.
However, the vector accesses are those of noise.
Using scalar Noise there is no problem.
-}
noiseAllocaBug :: IO ()
noiseAllocaBug =
SVL.writeFile "speedtest.f32" $
SVL.take (div 10000000 4) $
asMonoPacked $
flip (SigP.renderChunky (SVL.chunkSize 10000)) () $
(CausalPS.amplify 0.2 . Filt2.causalPacked
$< (Sig.map (const $ Memory.load =<< LLVM.alloca) $
(Sig.constant (0::Float)))
$* SigPS.noise 0 0.3)
noiseAllocaScalar :: IO ()
noiseAllocaScalar =
SVL.writeFile "speedtest.f32" $
SVL.take 10000000 $
asMono $
flip (SigP.renderChunky (SVL.chunkSize 10000)) () $
(0.2 * causalP Filt2.causal
$< (Sig.map (const $
(Memory.load =<< LLVM.alloca ::
LLVM.CodeGenFunction r (Filt2.Parameter (Value Float)))) $
(Sig.constant (0::Float)))
$* SigP.noise 0 0.3)
upsample :: IO ()
upsample =
SVL.writeFile "speedtest.f32" $
SVL.take 10000000 $
asMono $
Sig.renderChunky (SVL.chunkSize 100000) $
(let reduct = 128 :: Float
in flip Causal.applyConst reduct $ Causal.interpolateConstant $
Sig.osci Wave.sine 0 (reduct*0.1/44100))
filterSweepControlRateCausal ::
Causal.T
(Stereo.T (Value Float))
(Stereo.T (Value Float))
filterSweepControlRateCausal =
Causal.amplifyStereo 0.3 <<<
BandPass.causal <<<
Causal.feedFst
(let reduct = 128
in flip Causal.applyConst reduct $ Causal.interpolateConstant $
Sig.map (BandPass.parameter (valueOf 100)) $
Sig.map (\x -> 0.01 * exp (2 * return x)) $
Sig.osci Wave.sine 0 (reduct*0.1/44100))
filterSweepControlRateProc ::
Sig.T (Stereo.T (Value Float)) ->
Sig.T (Stereo.T (Value Float))
filterSweepControlRateProc =
Causal.apply filterSweepControlRateCausal
{- |
Trigonometric functions are very slow in LLVM
because they are translated to calls to C's math library.
Thus it is advantageous to compute filter parameters
at a lower rate and interpolate constantly.
-}
filterSweepControlRate :: IO ()
filterSweepControlRate =
SVL.writeFile "speedtest.f32" $
asStereo $
SVL.take 10000000 $
Sig.renderChunky (SVL.chunkSize 100000) $
filterSweepControlRateProc $
chord 0.005
filterSweepMusic :: IO ()
filterSweepMusic = do
music <- SV.readFile "lichter.f32"
SVL.writeFile "speedtest.f32" $
asStereo $
Sig.renderChunky (SVL.chunkSize 100000) $
Sig.amplifyStereo 20 $
filterSweepControlRateProc $
Sig.fromStorableVector $
(music :: SV.Vector (Stereo.T Float))
playFilterSweepMusicLazy :: IO ()
playFilterSweepMusicLazy = do
IO.withFile "lichter.f32" IO.ReadMode $ \h ->
playStereo .
-- Sig.amplifyStereo 1.125 .
Sig.amplifyStereo 20 .
filterSweepControlRateProc .
Sig.fromStorableVectorLazy .
asStereo . snd
=<< SVL.hGetContentsAsync (SVL.chunkSize 4321) h
return ()
playFilterSweepMusicCausal :: IO ()
playFilterSweepMusicCausal = do
music <- SV.readFile "lichter.f32"
_ <- SoxPlay.simple SV.hPut SoxOption.none 44100 $
asStereo $
Causal.applyStorable
(Causal.amplifyStereo 20 <<< filterSweepControlRateCausal) $
(music :: SV.Vector (Stereo.T Float))
return ()
playFilterSweepMusicCausalLazy :: IO ()
playFilterSweepMusicCausalLazy = do
IO.withFile "lichter.f32" IO.ReadMode $ \h ->
playStereoVector .
Causal.applyStorableChunky
(Causal.amplifyStereo 20 <<< filterSweepControlRateCausal) .
asStereo . snd
=<< SVL.hGetContentsAsync (SVL.chunkSize 43210) h
return ()
deinterleaveProc ::
IO (Float ->
PIO.T
(SV.Vector (StereoInt.T D4 Float))
(Zip.T
(SV.Vector (StereoInt.T D4 Float))
(SV.Vector (StereoInt.T D4 Float))))
deinterleaveProc =
CausalP.processIO deinterleaveCausal
deinterleaveCausal ::
CausalP.T Float
(StereoInt.Value D4 Float)
(StereoInt.Value D4 Float, StereoInt.Value D4 Float)
deinterleaveCausal =
Func.withArgs $ \input ->
let env =
Func.fromSignal $
0.5 * (1 + SigPS.osciSimple (Wave.triangleSquarePower 4) 0 id)
in (Causal.zipWith StereoInt.envelope $& env &|& input)
&|&
(Causal.zipWith StereoInt.envelope $& (1-env) &|& input)
deinterleave :: IO ()
deinterleave = do
proc <- deinterleaveProc
runSplitProcess (proc (2/44100))
disturbProc, disturbFMProc ::
IO (PIO.T
(SV.Vector (StereoInt.T D4 Float))
(Zip.T
(SV.Vector (StereoInt.T D4 Float))
(SV.Vector (StereoInt.T D4 Float))))
disturbProc =
fmap ($()) $ CausalP.processIO $ crossMix disturbCausal
disturbCausal, disturbFMCausal ::
CausalP.T p (StereoInt.Value D4 Float) (StereoInt.Value D4 Float)
disturbCausal =
Func.withArgs $ \inputInt ->
let tone =
Func.fromSignal $
SigPS.osciSimple Wave.triangle 0 (440/44100)
getEnvelope x =
Filt1.lowpassCausalPacked $&
(Func.fromSignal $
(SigP.constant $# Filt1Core.parameter (1/44100::Float)))
&|&
(CausalV.map abs $& x)
envelopedTone x = getEnvelope x * tone
in Causal.map StereoInt.interleave $&
CausalPS.amplifyStereo 5 $&
Stereo.liftApplicative envelopedTone
(Causal.map StereoInt.deinterleave $& inputInt)
disturbFMProc =
fmap ($()) $ CausalP.processIO $ crossMix disturbFMCausal
disturbFMCausal =
Func.withArgs $ \inputInt ->
let getEnvelope x =
Filt1.lowpassCausalPacked $&
(Func.fromSignal $
(SigP.constant $# Filt1Core.parameter (1/44100::Float)))
&|&
(CausalV.map abs $& x)
modulatedTone x =
getEnvelope x *
(CausalPS.osciSimple Wave.triangle $&
NP.zero
&|&
10 *
getEnvelope
((CausalPS.differentiate $# (0 :: Float)) $& x))
in Causal.map StereoInt.interleave $&
CausalPS.amplifyStereo 5 $&
Stereo.liftApplicative modulatedTone
(Causal.map StereoInt.deinterleave $& inputInt)
disturb :: IO ()
disturb =
runSplitProcess =<< disturbFMProc
wowFlutterProc ::
IO (PIO.T
(SV.Vector (StereoInt.T D4 Float))
(Zip.T
(SV.Vector (StereoInt.T D4 Float))
(SV.Vector (StereoInt.T D4 Float))))
wowFlutterProc =
fmap ($()) $ CausalP.processIO $ crossMix wowFlutterCausal
wowFlutterCausal ::
CausalP.T p (StereoInt.Value D4 Float) (StereoInt.Value D4 Float)
wowFlutterCausal =
Func.withArgs $ \inputInt ->
let freq =
Func.fromSignal $ (44100*) $
0.01 * (1 + SigPS.osciSimple Wave.triangle 0 (1/44100 :: Param.T p Float)) +
0.01 * (1 + SigPS.osciSimple Wave.approxSine2 0 (1.23/44100 :: Param.T p Float))
modulatedTone x =
CausalPS.pack
(CausalP.delayControlledInterpolated Interpolation.linear
(0 :: Param.T p Float) (441*2*2+10))
$&
freq &|& x
in Causal.map StereoInt.interleave $&
Stereo.liftApplicative modulatedTone
(Causal.map StereoInt.deinterleave $& inputInt)
crossMix ::
CausalP.T p (StereoInt.Value D4 Float) (StereoInt.Value D4 Float) ->
CausalP.T p
(StereoInt.Value D4 Float)
(StereoInt.Value D4 Float, StereoInt.Value D4 Float)
crossMix proc =
((fst NP.+ snd) &&& (fst NP.- snd))
.
(id &&& proc)
.
Causal.map (StereoInt.amplify 0.5)
wowFlutter :: IO ()
wowFlutter =
runSplitProcess =<< wowFlutterProc
scrambleProc0, scrambleProc1 ::
IO (Float ->
PIO.T
(SV.Vector (StereoInt.T D4 Float))
(Zip.T
(SV.Vector (StereoInt.T D4 Float))
(SV.Vector (StereoInt.T D4 Float))))
scrambleProc0 =
CausalP.processIO $
deinterleaveCausal NP.+
(id &&& NP.negate id) .
Causal.map (StereoInt.amplify 0.5) . wowFlutterCausal
scrambleProc1 =
CausalP.processIO $
deinterleaveCausal NP.+
(id &&& NP.negate id) .
Causal.map (StereoInt.amplify 0.3) .
(wowFlutterCausal NP.+ disturbFMCausal)
scramble :: IO ()
scramble = do
proc <- scrambleProc1
runSplitProcess (proc (2/44100))
runSplitProcess ::
(Storable a) =>
PIO.T (SV.Vector a) (Zip.T (SV.Vector a) (SV.Vector a)) ->
IO ()
runSplitProcess proc = do
void $
IO.withFile "/tmp/test.f32" IO.ReadMode $ \h ->
IO.withFile "/tmp/even.f32" IO.WriteMode $ \h0 ->
IO.withFile "/tmp/odd.f32" IO.WriteMode $ \h1 ->
case proc of
PIO.Cons next create delete ->
{-
Is the use of 'bracket' correct?
I think 'delete' must be called with the final state,
not with the initial one.
-}
bracket create delete $
let chunkSize = 543210
loop s0 = do
chunk <- SV.hGet h chunkSize
(Zip.Cons y0 y1, s1) <- next chunk s0
SV.hPut h0 y0
SV.hPut h1 y1
when
(SV.length y0 >= SV.length chunk &&
SV.length y1 >= SV.length chunk &&
SV.length chunk >= chunkSize)
(loop s1)
in loop
antimixProc ::
IO (SVL.Vector (StereoInt.T D4 Float) ->
PIO.T
(SV.Vector (StereoInt.T D4 Float))
(Zip.T
(SV.Vector (StereoInt.T D4 Float))
(SV.Vector (StereoInt.T D4 Float))))
antimixProc =
CausalP.processIO $ crossMix $
Causal.map (StereoInt.amplify 0.5) .
(CausalP.fromSignal $ SigP.fromStorableVectorLazy id)
antimix :: IO ()
antimix = do
proc <- antimixProc
void $
IO.withFile "/tmp/test.f32" IO.ReadMode $ \h ->
IO.withFile "/tmp/even.f32" IO.WriteMode $ \h0 ->
IO.withFile "/tmp/odd.f32" IO.WriteMode $ \h1 -> do
let chunkSize = SVL.chunkSize 543210
input <- fmap snd $ SVL.hGetContentsAsync chunkSize h
let vectorSize = 4
additive = SVL.drop (div 44100 vectorSize) input
{-
additive =
case SVL.splitAt (div 44100 vectorSize) input of
(prefix, suffix) ->
SVL.append suffix $
SVL.replicate chunkSize (SVL.length prefix) StereoInt.zero
-}
{-
additive =
case SVL.splitAt (div 44100 vectorSize) input of
(prefix, suffix) -> SVL.append suffix prefix
-}
case proc additive of
PIO.Cons next create delete ->
{-
Is the use of 'bracket' correct?
I think 'delete' must be called with the final state,
not with the initial one.
-}
bracket create delete $ \state ->
let loop cs0 s0 =
case cs0 of
[] -> return ()
c : cs -> do
(Zip.Cons y0 y1, s1) <- next c s0
SV.hPut h0 y0
SV.hPut h1 y1
when
(SV.length y0 >= SV.length c &&
SV.length y1 >= SV.length c)
(loop cs s1)
in loop (SVL.chunks input) state
arrangeLazy :: IO ()
arrangeLazy = do
IO.hSetBuffering IO.stdout IO.NoBuffering
arrange <- SigStL.makeArranger
print $
arrange (SVL.chunkSize 2) $
EventList.fromPairList $
(0, SVL.pack (SVL.chunkSize 2) [1,2::Double]) :
(0, SVL.pack (SVL.chunkSize 2) [3,4,5,6]) :
(2, SVL.pack (SVL.chunkSize 2) [7,8,9,10]) :
-- repeat (2, SVL.empty)
-- (2, SVL.empty) :
-- (2, SVL.empty) :
-- (2::NonNeg.Int, error "undefined sound") :
error "end of list"
-- []
{- |
This is inefficient because pingSig is compiled by LLVM
for every occurence of the sound!
randomTones :: IO ()
randomTones = do
playMonoVector $
SigStL.arrange (SVL.chunkSize 12345) $
EventList.fromPairList $ zip
(cycle $ map (flip div 16 . (44100*)) [1,2,3])
(cycle $ map (SVL.take 44100 . Sig.renderChunky (SVL.chunkSize 54321) .
pingSig . (0.01*))
[1,1.25,1.5,2])
return ()
-}
{- |
So far we have not managed to compile signals
that depend on parameters.
Thus in order to avoid much recompilation,
we compile and render a few sounds in advance.
-}
pingTones :: [SVL.Vector Float]
pingTones =
map (SVL.take 44100 . Sig.renderChunky (SVL.chunkSize 4321) .
pingSig . (0.01*))
[1,1.25,1.5,2]
pingTonesIO :: IO [SVL.Vector Float]
pingTonesIO =
fmap
(\pingVec ->
map
(SVL.take 44100 .
pingVec (SVL.chunkSize 4321) .
(0.01*))
[1,1.25,1.5,2])
(SigP.runChunky $ pingSigP id)
{-
Arrange itself does not seem to have a space leak with temporary data.
However it may leak sound data.
This is not very likely because this would result in a large memory leak.
Generate random tones in order to see whether generated sounds leak.
How does 'arrange' compare with 'concat'?
-}
cycleTones :: IO ()
cycleTones = do
-- playMono $
pings <- pingTonesIO
SVL.writeFile "test.f32" $
-- Play.auto (0.01::Double) 44100 $
asMono $
{-
after 13min runtime memory consumption increased from 2.5 to 3.9
and we get lot of buffer underruns with this implementation of amplification
(renderChunky . amplify . fromStorableVector)
-}
Sig.renderChunky (SVL.chunkSize 432109) $
Sig.amplify 0.1 $
Sig.fromStorableVectorLazy $
{-
after 20min memory consumption increased from 2.5 to 3.4
and we get lot of buffer underruns with applyStorableChunky
-}
{-
applyStorableChunky applied to concatenated zero vectors
starts with memory consumption 1.0 and after an hour, it's still 1.1
without buffer underruns.
-}
{-
CausalP.applyStorableChunky (CausalP.amplify $# (0.1::Float)) () $
asMono $
-}
{-
with chunksize 12345678
after 50min runtime the memory consumption increased from 12.0 to 26.2
with chunksize 123
after 25min runtime the memory consumption is constant 7.4
however at start time there 5 buffer underruns, but no more
probably due to initial LLVM compilation
with chunksize 1234567 and SVL.replicate instead of pingTones
we get memory consumption from 1.3 to 3.2 in 15min,
while producing lots of buffer underruns.
After 45min in total, it is still 3.2 of memory consumption.
Is this a memory leak, or isn't it?
with chunksize 12345678 and SVL.replicate
we get from 5.6 to 10.2 in 3min
to 14.9 after total 13min.
-}
{-
SigStL.arrange (SVL.chunkSize 12345678) $
EventList.fromPairList $ zip
(repeat (div 44100 8))
-- (cycle $ map (flip div 4 . (44100*)) [1,2,3])
-}
{-
With plain concatenation of those zero vectors
we stay constantly at 0.4 memory consumption and no buffer underruns over 30min.
-}
SVL.concat
(cycle pings)
-- (repeat $ SVL.replicate (SVL.chunkSize 44100) 44100 0)
return ()
tonesChunkSize :: SVL.ChunkSize
numTones :: Int
{-
For one-time-compiled fill functions,
larger chunks have no relevant effect on the processing speed.
-}
(tonesChunkSize, numTones) =
(SVL.chunkSize 441, 200)
-- (SVL.chunkSize 44100, 200)
fst :: Arrow arrow => arrow (a,b) a
fst = arr P.fst
snd :: Arrow arrow => arrow (a,b) b
snd = arr P.snd
{-# NOINLINE makePing #-}
makePing :: IO ((Float,Float) -> SVL.Vector Float)
makePing =
let freq = snd
halfLife = fst
in fmap ($tonesChunkSize) $
SigP.runChunky
(SigP.envelope
(SigP.exponential2 halfLife 1)
(SigP.osciSaw 0.5 freq))
tonesDown :: IO ()
tonesDown = do
let dist = div 44100 10
pingp <- makePing
arrange <- SigStL.makeArranger
playMonoVector $
CausalP.applyStorableChunky (CausalP.amplify id) (0.03::Float) $
arrange tonesChunkSize $
EventList.fromPairList $ zip
(repeat (NonNeg.fromNumber dist))
(map (SVL.take (numTones * dist) . curry pingp 50000) $
iterate (0.999*) 0.01)
return ()
vibes :: SigP.T (Float,Float) (Value Float)
vibes =
let freq = snd
modDepth = fst
halfLife = 5000
-- sine = Wave.sine
sine = Wave.approxSine4
in causalP CausalP.envelope
$< SigP.exponential2 halfLife 1
$* (((CausalP.osciSimple sine
$< (causalP CausalP.envelope
$< SigP.exponential2 halfLife modDepth
$* (CausalP.osciSimple sine
$* SigP.constant (return (0::Float) &&& (2*freq)))))
<<<
CausalP.mapLinear (0.01*freq) freq
<<<
CausalP.osciSimple sine)
$* SigP.constant (return (0::Float, 0.0001::Float)))
makeVibes :: IO ((Float,Float) -> SVL.Vector Float)
makeVibes =
fmap ($tonesChunkSize) $
SigP.runChunky vibes
vibesCycleVector :: ((Float,Float) -> SVL.Vector Float) -> IO (SVL.Vector Float)
vibesCycleVector pingp =
(\evs -> fmap (\arrange -> arrange tonesChunkSize evs) SigStL.makeArranger) $
EventList.fromPairList $ zip
(repeat 5000)
(map (SVL.take 50000 . pingp) $
zip
(map (\k -> 0.5 * (1 - cos k)) $ iterate (0.05+) 0)
(cycle $ map (0.01*) [1, 1.25, 1.5, 2]))
vibesCycle :: IO ()
vibesCycle = do
sig <- vibesCycleVector =<< makeVibes
playMonoVector $
CausalP.applyStorableChunky (CausalP.amplify id) (0.2::Float) sig
return ()
vibesEcho :: IO ()
vibesEcho = do
sig <- vibesCycleVector =<< makeVibes
playMonoVector $
CausalP.applyStorableChunky
(CausalP.amplify id <<<
CausalP.comb (0.5 :: Param.T p Float) 7000)
(0.2::Float) sig
return ()
vibesReverb :: IO ()
vibesReverb = do
sig <- vibesCycleVector =<< makeVibes
playMonoVector $
CausalP.applyStorableChunky
(CausalP.amplify id <<<
CausalP.reverbSimple (mkStdGen 142) 16 (0.9,0.97) (400,1000))
(0.3::Float) sig
return ()
vibesReverbEfficient :: IO ()
vibesReverbEfficient = do
sig <- vibesCycleVector =<< makeVibes
playMonoVector $
CausalP.applyStorableChunky
(CausalP.amplify id <<<
(CausalP.reverb $# mkStdGen 142 $# 16 $# (0.9,0.97) $# (400,1000)))
(0.3::Float) sig
return ()
vibesReverbStereo :: IO ()
vibesReverbStereo = do
sig <- vibesCycleVector =<< makeVibes
void $ playStereoVector $
CausalP.applyStorableChunky
(CausalP.stereoFromMonoParameterized
(\amp seed ->
CausalP.amplify amp
<<<
CausalP.reverb (fmap mkStdGen seed)
16 (pure (0.9,0.97)) (pure (400,1000)))
(pure $ Stereo.cons 142 857)
<<^
(\x -> Stereo.cons x x))
(0.3::Float) sig
stair :: IO ()
stair =
SVL.writeFile "speedtest.f32" $
SVL.take 10000000 $
asMono $
flip (SigP.renderChunky tonesChunkSize) () $
SigP.piecewiseConstant $
return $
EventListBT.fromPairList $
zip
(iterate (/2) (1::Float))
(iterate (2*) (1::NonNeg.Int))
filterBass :: IO ()
filterBass =
void $
playStereoVector $
asStereo $
flip (SigP.renderChunky tonesChunkSize) () $
CausalP.apply
(BandPass.causal
<<<
CausalP.feedSnd
(liftA2 Stereo.cons
(SigP.osciSimple Wave.saw 0 (frequency 0.001499))
(SigP.osciSimple Wave.saw 0 (frequency 0.001501)))
<<<
Causal.map (BandPass.parameter (valueOf (100::Float)))) $
SigP.piecewiseConstant $
return $ EventListBT.fromPairList $
zip
(map (((0.01::Float)*) . (2**) . (/12) . fromInteger) $
randomRs (0,24) (mkStdGen 998))
(repeat (6300::NonNeg.Int))
{- |
This function is not very efficient,
since it compiles an LLVM mixing routine
for every pair of mixer inputs.
-}
mixVectorRecompile ::
SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float
mixVectorRecompile xs ys =
Sig.renderChunky tonesChunkSize $
Sig.mix
(Sig.fromStorableVectorLazy xs)
(Sig.fromStorableVectorLazy ys)
mixVectorParamIO ::
IO (SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float)
mixVectorParamIO =
fmap curry $
fmap ($tonesChunkSize) $
SigP.runChunky
(SigP.mix
(SigP.fromStorableVectorLazy fst)
(SigP.fromStorableVectorLazy snd))
mixVectorCausalIO ::
IO (SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float)
mixVectorCausalIO =
CausalP.runStorableChunky
(CausalP.mix $<
SigP.fromStorableVectorLazy id)
mixVectorCausal ::
SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float
mixVectorCausal =
CausalP.applyStorableChunky
(CausalP.mix $<
SigP.fromStorableVectorLazy id)
mixVectorStereo ::
SVL.Vector (Stereo.T Float) ->
SVL.Vector (Stereo.T Float) ->
SVL.Vector (Stereo.T Float)
mixVectorStereo =
CausalP.applyStorableChunky
(CausalP.mix $< SigP.fromStorableVectorLazy id)
mixVectorStereoIO ::
IO (SVL.Vector (Stereo.T Float) ->
SVL.Vector (Stereo.T Float) ->
SVL.Vector (Stereo.T Float))
mixVectorStereoIO =
CausalP.runStorableChunky
(CausalP.mix $< SigP.fromStorableVectorLazy id)
{-
slightly slower than mixVectorParam
-}
mixVectorHaskell ::
SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float
mixVectorHaskell = SVL.zipWith (+)
toneMix :: IO ()
toneMix = do
pingp <- makePing
mix <- mixVectorCausalIO
playMonoVector $
Causal.applyStorableChunky (Causal.amplify 0.1) $
foldl1 mix $
map (curry pingp 1000000) $
take numTones $
iterate (*(2/3)) 0.01
return ()
fadeEnvelope :: SigP.T (Int, Int) (Value Float)
fadeEnvelope =
let dur :: Param.T (Int, Int) Float
dur = fmap fromIntegral fst
in SigP.parabolaFadeIn dur
`SigP.append`
(CausalP.take snd $* Sig.constant 1)
`SigP.append`
SigP.parabolaFadeOut dur
fadeEnvelopeWrite :: IO ()
fadeEnvelopeWrite =
SVL.writeFile "speedtest.f32" $
asMono $
SigP.renderChunky (SVL.chunkSize 1234)
fadeEnvelope (100000, 200000)
-- | normalize a list of numbers, such that they have a specific average
-- Cf. haskore-supercollider/src/Haskore/Interface/SuperCollider/Example.hs
normalizeLevel :: Fractional a => a -> [a] -> [a]
normalizeLevel newAvrg xs =
let avrg = sum xs / genericLength xs
in map ((newAvrg-avrg)+) xs
stereoOsciSawP :: SigP.T Float (Stereo.T (Value Float))
stereoOsciSawP =
let n = 5
volume :: Float
volume = recip $ sqrt $ fromIntegral n
detunes :: [Float]
detunes =
normalizeLevel 1 $ take (2*n) $
randomRs (0,0.03) $ mkStdGen 912
phases :: [Float]
phases = randomRs (0,1) $ mkStdGen 54
in stereoFromMonoParameterizedSignal
(\_ params ->
(SigP.amplify $# volume) $
multiMixSignal
(\_ phaseFreq ->
SigP.osciSaw
(fmap fst phaseFreq)
(fmap snd phaseFreq))
params)
(arr
(\freq ->
uncurry Stereo.cons $ splitAt n $
zipWith
(\phase detune -> (phase, detune*freq))
phases detunes))
stereoFromMonoParameterizedSignal ::
(forall q. Param.T q p -> Param.T q x -> SigP.T q (Value Float)) ->
Param.T p (Stereo.T x) -> SigP.T p (Stereo.T (Value Float))
stereoFromMonoParameterizedSignal f ps =
CausalP.toSignal $
CausalP.stereoFromMonoParameterized (\p -> CausalP.fromSignal . f p) ps
<<^
(\() -> Stereo.cons () ())
multiMixSignal ::
(forall q. Param.T q p -> Param.T q x -> SigP.T q (Value Float)) ->
Param.T p [x] -> SigP.T p (Value Float)
multiMixSignal f =
CausalP.toSignal . multiMix (\p x -> CausalP.fromSignal $ f p x)
multiMix ::
(forall q. Param.T q p -> Param.T q x -> CausalP.T q a (Value Float)) ->
Param.T p [x] -> CausalP.T p a (Value Float)
multiMix f ps =
CausalP.replicateControlledParam
(\p x -> CausalP.mix <<< CausalP.first (f p x)) ps
<<^
(\a -> (a, A.zero))
stereoOsciSawVector :: Float -> SVL.Vector (Stereo.T Float)
stereoOsciSawVector =
SigP.renderChunky tonesChunkSize stereoOsciSawP
stereoOsciSawChord :: NonEmpty.T [] Float -> SVL.Vector (Stereo.T Float)
stereoOsciSawChord =
NonEmpty.foldBalanced mixVectorStereo . fmap stereoOsciSawVector
stereoOsciSawPad :: Int -> NonEmpty.T [] Float -> SVL.Vector (Stereo.T Float)
stereoOsciSawPad dur pitches =
let attack = 20000
in CausalP.applyStorableChunky
(CausalP.envelopeStereo $< fadeEnvelope)
(attack, dur-attack)
(stereoOsciSawChord pitches)
a0, as0, b0, c1, cs1, d1, ds1, e1, f1, fs1, g1, gs1,
a1, as1, b1, c2, cs2, d2, ds2, e2, f2, fs2, g2, gs2,
a2, as2, b2, c3, cs3, d3, ds3, e3, f3, fs3, g3, gs3,
a3, as3, b3, c4, cs4, d4, ds4, e4, f4, fs4, g4, gs4 :: Float
a0 : as0 : b0 : c1 : cs1 : d1 : ds1 : e1 : f1 : fs1 : g1 : gs1 :
a1 : as1 : b1 : c2 : cs2 : d2 : ds2 : e2 : f2 : fs2 : g2 : gs2 :
a2 : as2 : b2 : c3 : cs3 : d3 : ds3 : e3 : f3 : fs3 : g3 : gs3 :
a3 : as3 : b3 : c4 : cs4 : d4 : ds4 : e4 : f4 : fs4 : g4 : gs4 : _ =
iterate ((2 ** recip 12) *) (55/44100)
chordSequence :: [(Int, NonEmpty.T [] Float)]
chordSequence =
(2, f1 !: f2 : a2 : c3 : []) :
(1, g1 !: g2 : b2 : d3 : []) :
(2, c2 !: g2 : c3 : e3 : []) :
(1, f1 !: a2 : c3 : f3 : []) :
(2, g1 !: g2 : b2 : d3 : []) :
(1, gs1 !: gs2 : b2 : e3 : []) :
(2, a1 !: e2 : a2 : c3 : []) :
(1, g1 !: g2 : b2 : d3 : []) :
(3, c2 !: g2 : c3 : e3 : []) :
(2, f1 !: f2 : a2 : c3 : []) :
(1, g1 !: g2 : b2 : d3 : []) :
(2, c2 !: g2 : c3 : e3 : []) :
(1, f1 !: a2 : c3 : f3 : []) :
(2, g1 !: g2 : b2 : d3 : []) :
(1, gs1 !: gs2 : b2 : e3 : []) :
(2, a1 !: e2 : a2 : c3 : []) :
(1, g1 !: g2 : b2 : e3 : []) :
(3, c2 !: e2 : g2 : c3 : []) :
[]
withDur :: (Int -> a -> v) -> Int -> a -> (v, NonNeg.Int)
withDur f d ps =
let dur = d*30000
in (f dur ps, NonNeg.fromNumber dur)
padMusic :: IO ()
padMusic = do
arrange <- SigStL.makeArranger
playStereoVector $
CausalP.applyStorableChunky (CausalP.amplifyStereo id) (0.1::Float) $
arrange tonesChunkSize $
EventListTM.switchTimeR const $
EventListMT.consTime 0 $
EventListBT.fromPairList $
map (\(d,ps) -> withDur stereoOsciSawPad d ps)
chordSequence
return ()
lowpassSweepControlRateCausal ::
CausalP.T p
(Stereo.T (Value Float))
(Stereo.T (Value Float))
lowpassSweepControlRateCausal =
-- CausalP.stereoFromVector $
CausalP.stereoFromMono $
UniFilter.lowpass ^<<
CtrlP.processCtrlRate 128
(lfoSine (UniFilter.parameter (valueOf (10::Float))))
moogSweepControlRateCausal ::
CausalP.T p
(Stereo.T (Value Float))
(Stereo.T (Value Float))
moogSweepControlRateCausal =
-- CausalP.stereoFromVector $
CausalP.stereoFromMono $
CtrlP.processCtrlRate 128
(lfoSine (Moog.parameter TypeNum.d8 (valueOf (10::Float))))
filterMusic :: IO ()
filterMusic = do
arrange <- SigStL.makeArranger
pad <- stereoOsciSawPadIO
void $ playStereoVector $
CausalP.applyStorableChunky
(CausalP.amplifyStereo id <<<
moogSweepControlRateCausal) (0.05::Float) $
arrange tonesChunkSize $
EventListTM.switchTimeR const $
EventListMT.consTime 0 $
EventListBT.fromPairList $
map (\(d,ps) -> withDur pad d ps)
chordSequence
stereoOsciSawVectorIO :: IO (Float -> SVL.Vector (Stereo.T Float))
stereoOsciSawVectorIO =
fmap ($tonesChunkSize) $
SigP.runChunky $
stereoOsciSawP
applyFadeEnvelopeIO ::
IO (Int -> SVL.Vector (Stereo.T Float) -> SVL.Vector (Stereo.T Float))
applyFadeEnvelopeIO =
fmap
(\envelope dur sig ->
let attack = 20000
in envelope (attack, dur-attack) sig)
(CausalP.runStorableChunky
(CausalP.envelopeStereo $< fadeEnvelope))
stereoOsciSawChordIO :: IO (NonEmpty.T [] Float -> SVL.Vector (Stereo.T Float))
stereoOsciSawChordIO = do
sawv <- stereoOsciSawVectorIO
mix <- mixVectorStereoIO
return (NonEmpty.foldBalanced mix . fmap sawv)
stereoOsciSawPadIO ::
IO (Int -> NonEmpty.T [] Float -> SVL.Vector (Stereo.T Float))
stereoOsciSawPadIO = do
chrd <- stereoOsciSawChordIO
envelope <- applyFadeEnvelopeIO
return $
\ dur pitches -> envelope dur (chrd pitches)
padMusicIO :: IO ()
padMusicIO = do
arrange <- SigStL.makeArranger
pad <- stereoOsciSawPadIO
playStereoVector $
CausalP.applyStorableChunky (CausalP.amplifyStereo id) (0.08::Float) $
arrange tonesChunkSize $
EventListTM.switchTimeR const $
EventListMT.consTime 0 $
EventListBT.fromPairList $
map (uncurry (withDur pad)) $
chordSequence
return ()
{-
Apply the envelope separately to each tone of the chord
and mix all tones by 'arrange'.
-}
padMusicSeparate :: IO ()
padMusicSeparate = do
arrange <- SigStL.makeArranger
osci <- stereoOsciSawVectorIO
env <- applyFadeEnvelopeIO
playStereoVector $
CausalP.applyStorableChunky (CausalP.amplifyStereo id) (0.08::Float) $
arrange tonesChunkSize $
EventList.flatten $
EventListTM.switchTimeR const $
EventListMT.consTime 0 $
EventListBT.fromPairList $
map (uncurry (withDur (\d ps ->
map (\p -> env d (osci p)) $ NonEmpty.flatten ps))) $
chordSequence
return ()
delay :: IO ()
delay =
SVL.writeFile "speedtest.f32" $
asMono $
flip (SigP.renderChunky tonesChunkSize) (0, 10000) $
(CausalP.delayZero fst . CausalP.take snd
$*
SigP.osciSaw 0 (frequency 0.01))
delayStereo :: IO ()
delayStereo =
SVL.writeFile "speedtest.f32" $
asStereo $
flip (SigP.renderChunky tonesChunkSize) (7, 10000) $
(CausalP.take snd . liftA2 Stereo.cons id (CausalP.delayZero fst)
$*
SigP.osciSaw 0 (frequency 0.01))
delayPhaser :: IO ()
delayPhaser =
SVL.writeFile "speedtest.f32" $
asStereo $
flip (SigP.renderChunky tonesChunkSize) 40000 $
Func.compileSignal $
let osci = Func.fromSignal $ SigP.osciSaw 0 (frequency 0.01)
ctrl =
Func.fromSignal $
SigP.osciSimple Wave.triangle 0 $ frequency (1/20000)
in CausalP.take id $&
liftA2 Stereo.cons
osci
(CausalP.delayControlledInterpolated Interpolation.cubic
(0 :: Param.T p Float) 100
$&
(50+50*ctrl) &|& osci)
allpassControl ::
(TypeNum.Natural n) =>
Proxy n ->
SigP.T Float (Allpass.CascadeParameter n (Value Float))
allpassControl order =
let reduct = id
in SigP.interpolateConstant reduct $
lfoSine (Allpass.flangerParameter order) reduct
allpassPhaserCausal, allpassPhaserPipeline ::
SigP.T Float (Value Float) ->
SigP.T Float (Value Float)
allpassPhaserCausal =
let order = TypeNum.d16
in CausalP.apply
(0.5 * Allpass.phaser $< allpassControl order)
allpassPhaserPipeline =
let order = TypeNum.d16
in -- (F.nest (TypeNum.integralFromProxy order) SigP.tail .) $
SigP.drop (return $ TypeNum.integralFromProxy order) .
CausalP.apply
(0.5 * Allpass.phaserPipeline $< allpassControl order)
allpassPhaser :: IO ()
allpassPhaser =
SVL.writeFile "speedtest.f32" $
asMono $
SVL.take 10000000 $
flip (SigP.renderChunky (SVL.chunkSize 100000)) 128 $
allpassPhaserPipeline $
SigP.osciSaw 0 (frequency 0.01)
noise :: IO ()
noise =
SVL.writeFile "speedtest.f32" $
asMono $
SVL.take 10000000 $
flip (SigP.renderChunky (SVL.chunkSize 100000)) () $
(SigP.noise 0 0.3)
noisePacked :: IO ()
noisePacked =
SVL.writeFile "speedtest.f32" $
asMonoPacked $
SVL.take (div 10000000 4) $
flip (SigP.renderChunky (SVL.chunkSize 100000)) () $
(SigPS.noise 0 0.3)
-- (SigPS.pack (SigP.noise 0 0.3))
-- (SigPS.packSmall (SigP.noise 0 0.3))
frequencyModulationStorable :: IO ()
frequencyModulationStorable = do
smp <- SigP.runChunky (SigP.osciSaw 0 (frequency 0.01))
SVL.writeFile "speedtest.f32" $
asMono $
flip (SigP.renderChunky (SVL.chunkSize 100000)) () $
(CausalP.frequencyModulationLinear
(SigP.fromStorableVectorLazy $#
(SVL.take 1000000 $ asMono $
smp (SVL.chunkSize 1000) ()))
$*# (0.3::Float))
frequencyModulation :: IO ()
frequencyModulation =
SVL.writeFile "speedtest.f32" $
asMono $
SVL.take 10000000 $
flip (SigP.renderChunky (SVL.chunkSize 100000)) () $
(CausalP.frequencyModulationLinear
(SigP.osciSaw 0 (frequency 0.01))
$* Sig.exponential2 500000 1)
frequencyModulationStereo :: IO ()
frequencyModulationStereo = do
smp <- SigP.runChunky (SigP.osciSaw 0 (frequency 0.01))
SVL.writeFile "speedtest.f32" $
asStereo $
flip (SigP.renderChunky (SVL.chunkSize 100000)) () $
(CausalP.stereoFromMono
(CausalP.frequencyModulationLinear
(SigP.fromStorableVectorLazy $#
(SVL.take 1000000 $ asMono $
smp (SVL.chunkSize 1000) ())))
$*# Stereo.cons (0.2999::Float) 0.3001)
frequencyModulationProcess :: IO ()
frequencyModulationProcess =
SVL.writeFile "speedtest.f32" .
asMono .
(\f ->
f () $ asMono $
SigP.renderChunky (SVL.chunkSize 512)
(1 + 0.1 * SigP.osciSimple Wave.approxSine2 (pure (0::Float)) 0.0001)
()) =<<
CausalP.runStorableChunky
(CausalP.frequencyModulationLinear
(CausalP.take 50000 $*
SigP.osciSaw 0 (frequency 0.01)))
quantize :: IO ()
quantize =
{-
SV.writeFile "speedtest.f32" $
asMono $
(\xs -> SigP.render xs 10000000 ()) $
-}
SVL.writeFile "speedtest.f32" $
asMono $
SVL.take 10000000 $
flip (SigP.renderChunky (SVL.chunkSize 100000)) () $
((CausalP.quantizeLift $# (5.5::Float)) id $*
SigP.osciSaw 0 (frequency 0.01))
quantizedFilterControl :: IO ()
quantizedFilterControl =
SVL.writeFile "speedtest.f32" $
asMono $
SVL.take 10000000 $
flip (SigP.renderChunky (SVL.chunkSize 100000)) () $
CausalP.apply (0.3 * (UniFilter.lowpass ^<< CtrlP.process)) $
SigP.zip
((CausalP.quantizeLift $# (128::Float))
(Causal.map (UniFilter.parameter (valueOf 100)) <<<
-- (Causal.map (Moog.parameter TypeNum.d8 (valueOf 100)) <<<
CausalV.map (\x -> 0.01 * exp (2 * x)))
$* SigP.osciSimple Wave.approxSine2 0 (frequency (0.1/44100))) $
SigP.osciSaw 0 (frequency 0.01)
arrowNonShared :: IO ()
arrowNonShared =
SVL.writeFile "speedtest.f32" $
asStereo $
SVL.take 10000000 $
flip (SigP.renderChunky (SVL.chunkSize 100000)) () $
(let osci = CausalP.osciSimple Wave.approxSine2
in liftA2 Stereo.cons osci osci $*
SigP.constant (return (0::Float, 0.01::Float)))
arrowShared :: IO ()
arrowShared =
SVL.writeFile "speedtest.f32" $
asStereo $
SVL.take 10000000 $
flip (SigP.renderChunky (SVL.chunkSize 100000)) () $
(let osci = Func.lift (CausalP.osciSimple Wave.approxSine2)
in Func.compile (liftA2 Stereo.cons osci osci) $*
SigP.constant (return (0::Float, 0.01::Float)))
arrowIndependent :: IO ()
arrowIndependent =
SVL.writeFile "speedtest.f32" $
asStereo $
SVL.take 10000000 $
flip (SigP.renderChunky (SVL.chunkSize 100000)) () $
(let osci = CausalP.osciSimple Wave.approxSine2
in Func.compile
(fmap (uncurry Stereo.cons) $
osci *** osci $&
Func.lift id) $*
SigP.constant (return ((0::Float, 0.01::Float), (0.25::Float, 0.01001::Float))))
rampDown :: Int -> SV.Vector Float
rampDown n =
SigS.toStrictStorableSignal n $
CtrlS.line n (1, 0)
impulses :: Int -> Float -> SVL.Vector Float
impulses n x =
SVL.fromChunks $
concatMap (\k -> [SV.singleton x, SV.replicate k 0]) $
take n $ iterate (2*) 1
convolution :: IO ()
convolution =
SVL.writeFile "speedtest.f32" $
asMono $
CausalP.applyStorableChunky
(FiltNR.convolve id)
(rampDown 1000)
(impulses 18 0.1)
convolutionPacked :: IO ()
convolutionPacked =
SVL.writeFile "speedtest.f32" $
asMonoPacked $
CausalP.applyStorableChunky
(FiltNR.convolvePacked id)
(rampDown 1000)
(asMonoPacked $
(\xs -> SigP.renderChunky SVL.defaultChunkSize xs ()) $
SigPS.pack $
SigP.fromStorableVectorLazy $
pure $ impulses 18 0.1)
helixSaw :: IO ()
helixSaw = do
let srcFreq = 0.01
srcLength :: Float
srcLength = 40000
osci <- SigP.run $ SigP.osciSaw 0 (pure srcFreq) * (1-SigP.ramp id)
let perc = asMono $ osci (round srcLength) srcLength
SV.writeFile "osci-saw.f32" perc
stretched <-
SigP.runChunky $
Func.compileSignal $
(Helix.static Interpolation.cubic Interpolation.cubic
100 (pure $ recip srcFreq) snd
$&
(Func.fromSignal $ Sig.amplify srcLength $ SigP.ramp fst)
&|&
(CausalP.osciCore $& 0 &|& 0.01))
SVL.writeFile "osci-stretched.f32" $ asMono $
stretched SVL.defaultChunkSize (80000 :: Float, perc)
loadTomato :: IO (Float, SVL.Vector Float)
loadTomato = do
let Sample.Info name _sampleRate positions = Sample.tomatensalat
word <- Sample.load (Default.sampleDirectory </> name)
return (Sample.period $ head positions, word)
helixOsci :: Param.T p Float -> Func.T p a (Value Float)
helixOsci period =
CausalP.osciCore $&
0 &|& Func.fromSignal (SigP.constant (recip period))
helixSpeechStaticSig ::
Func.T p () (Value Float) ->
Param.T p (SVL.Vector Float) ->
Param.T p Float ->
SigP.T p (Value Float)
helixSpeechStaticSig shape word period =
Func.compileSignal
(Helix.static Interpolation.linear Interpolation.linear
(fmap round period) period
(fmap (SV.concat . SVL.chunks) word)
$&
shape
&|&
helixOsci period)
helixSpeechStaticSpeed ::
Param.T p Float ->
Param.T p (SVL.Vector Float) ->
Param.T p Float ->
SigP.T p (Value Float)
helixSpeechStaticSpeed speed word =
helixSpeechStaticSig
(Func.fromSignal
(CausalPV.takeWhile (%>)
(fmap ((fromIntegral :: Int -> Float) . SVL.length) word) $*
SigP.rampSlope speed))
word
helixSpeechStatic :: IO ()
helixSpeechStatic = do
let speed = fst
word = snd . snd
period = fst . snd
smp <- loadTomato
stretched <- SigP.runChunky $ helixSpeechStaticSpeed speed word period
SVL.writeFile "speech-stretched.f32" $ asMono $
stretched SVL.defaultChunkSize (0.5, smp)
helixSpeechDynamicSig ::
Func.T p () (Value Float) ->
Param.T p (SVL.Vector Float) ->
Param.T p Float ->
SigP.T p (Value Float)
helixSpeechDynamicSig shape word period =
Func.compileSignal
(Helix.dynamicLimited Interpolation.linear Interpolation.linear
(fmap round period) period (SigP.fromStorableVectorLazy word)
$&
shape
&|&
helixOsci period)
helixSpeechDynamicSpeed ::
Param.T p Float ->
Param.T p (SVL.Vector Float) ->
Param.T p Float ->
SigP.T p (Value Float)
helixSpeechDynamicSpeed speed =
helixSpeechDynamicSig (Func.fromSignal $ SigP.constant speed)
helixSpeechDynamic :: IO ()
helixSpeechDynamic = do
let speed = fst
word = snd . snd
period = fst . snd
smp <- loadTomato
stretched <- SigP.runChunky $ helixSpeechDynamicSpeed speed word period
SVL.writeFile "speech-stretched.f32" $ asMono $
stretched SVL.defaultChunkSize (0.5, smp)
helixSpeechCompare :: IO ()
helixSpeechCompare = do
let speed = fst
word = snd . snd
period = fst . snd
smp <- loadTomato
stretched <-
SigP.runChunky $ sequenceA $
Stereo.cons
(helixSpeechStaticSpeed speed word period)
(helixSpeechDynamicSpeed speed word period)
SVL.writeFile "speech-stretched.f32" $ asStereo $
stretched SVL.defaultChunkSize (0.5, smp)
helixSpeechVariCompare :: IO ()
helixSpeechVariCompare = do
let word = snd
period = fst
smp <- loadTomato
stretched <-
SigP.runChunky $ sequenceA $
let speed =
Func.fromSignal $ SigP.cycle $
SigP.fromStorableVector $ pure $
SV.pack [0.2, 0.5, 1, 1.5, 1.8 :: Float]
in Stereo.cons
(helixSpeechStaticSig
((CausalP.integrate $# (0::Float)) $& speed) word period)
(helixSpeechDynamicSig speed word period)
SVL.writeFile "speech-stretched.f32" $ asStereo $
stretched SVL.defaultChunkSize smp
helixLimited :: IO ()
helixLimited = do
let period = 100
srcLength = 500
dstLength = 5000
speed :: Param.T p Float
speed = 0.5
osci =
0.5
*
SigP.ramp (pure (fromIntegral srcLength :: Float))
*
SigP.osciSimple Wave.approxSine2 0 (recip period)
renderOsci <- SigP.run osci
let osciVec = renderOsci srcLength ()
SV.writeFile "helix-orig.f32" $ asMono osciVec
let stretchedStatic =
Helix.static Interpolation.linear Interpolation.linear
(fmap round period) period (pure osciVec)
$&
Func.fromSignal (SigP.rampSlope speed)
&|&
helixOsci period
stretchedDynamic =
Helix.dynamic Interpolation.linear Interpolation.linear
(fmap round period) period osci
$&
Func.fromSignal (SigP.constant speed)
&|&
helixOsci period
stretched = liftA2 Stereo.cons stretchedStatic stretchedDynamic
renderHelix <- SigP.run $ Func.compileSignal stretched
SV.writeFile "helix-stretched.f32" $ asStereo $ renderHelix dstLength ()
cycleRamp :: IO ()
cycleRamp =
SVL.writeFile "speedtest.f32" . asMono .
(\f -> f SVL.defaultChunkSize (10000::Float)) =<<
SigP.runChunky
(CausalP.take 100000 $*
(SigP.cycle $ SigP.append (SigP.ramp id) (1 - SigP.ramp id)))
zigZag :: IO ()
zigZag =
SVL.writeFile "speedtest.f32" . asMono .
(\f -> f SVL.defaultChunkSize (-3::Float)) =<<
SigP.runChunky
(CausalP.take 100000 $* (Helix.zigZag id $* 0.0001))
zigZagPacked :: IO ()
zigZagPacked =
SVL.writeFile "speedtest.f32" . asMonoPacked .
(\f -> f SVL.defaultChunkSize (-3::Float)) =<<
SigP.runChunky
(let vectorSize = 4
in CausalP.take (pure $ div 100000 vectorSize) $*
(Helix.zigZagPacked id $* 0.0001))
trigger :: IO ()
trigger =
SVL.writeFile "speedtest.f32" . asMono .
(\f -> f SVL.defaultChunkSize (0.01 :: Float)) =<<
SigP.runChunky
(let pause len =
CausalClass.applyConst (CausalP.take len) Maybe.nothing
pulse :: Float -> Param.T p Int -> SigP.T p (Maybe.T (Value Float))
pulse freq len =
CausalP.take len .
arr (flip Maybe.fromBool (valueOf freq)) .
CausalP.delay1 (pure True) $*# False
in Sig.zipWith (flip Maybe.select) (SigP.noise 0 0.01) $
(CausalP.trigger
(\_ freq -> CausalP.take 150000 $* pingSigP freq) $*
pause 50000 `SigP.append`
pulse 0.004 100000 `SigP.append`
pulse 0.005 200000 `SigP.append`
pulse 0.006 400000))
triggerLFO :: SigP.T p (Value Float)
triggerLFO =
SigP.osciSimple Wave.approxSine2 0 (pure (0.00015 :: Float))
+
SigP.osciSimple Wave.approxSine2 0 (pure (0.000037 :: Float))
trackZeros :: CausalP.T p (Value Float) (Value Bool)
trackZeros =
CausalV.zipWith (\x y -> x %&& Value.not y) .
(id &&& CausalP.delay1 (pure False)) .
CausalV.map (%> 0)
fmPingSig :: Param.T p Float -> Param.T p Float -> SigP.T p (Value Float)
fmPingSig freq depth =
SigP.envelope
(Sig.exponential2 5000 1)
((CausalP.osciSimple Wave.approxSine2 $> SigP.constant freq)
$*
(SigP.constant depth * SigP.osciSimple Wave.approxSine2 0 (2*freq)))
sweepTrigger :: IO ()
sweepTrigger =
SVL.writeFile "speedtest.f32" . asMono .
(\f -> f SVL.defaultChunkSize (0.01 :: Float)) =<<
SigP.runChunky
(Sig.zipWith (flip Maybe.select) (SigP.noise 0 0.01) $
(CausalP.trigger (const $ fmPingSig (pure (0.005 :: Float))) $*
liftA2 Maybe.fromBool
(CausalP.take 10000000 . trackZeros $* triggerLFO)
(5 * SigP.osciSimple Wave.approxSine2 0 (pure (0.00001 :: Float)))))
main :: IO ()
main = do
LLVM.initializeNativeTarget
filterSweepComplex