synthesizer-llvm-0.3: src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE Rank2Types #-}
module Synthesizer.LLVM.Server.CausalPacked.Instrument where
import Synthesizer.LLVM.Server.Packed.Instrument
(Vector, vectorTime, vectorSize,
SampleInfo, SampledSound(..), loadSound,
sampleStart, sampleLength,
sampleLoopStart, sampleLoopLength,
stereoNoise, noiseReference, sumNested, )
import Synthesizer.LLVM.Server.Common hiding (Instrument, )
import qualified Synthesizer.LLVM.Storable.Process as PSt
import qualified Synthesizer.CausalIO.ALSA.Process as PAlsa
import qualified Synthesizer.CausalIO.Gate as Gate
import qualified Synthesizer.CausalIO.Process as PIO
import Synthesizer.LLVM.CausalParameterized.Functional (($&), (&|&), )
import qualified Synthesizer.LLVM.Filter.Universal as UniFilter
import qualified Synthesizer.LLVM.Filter.Allpass as Allpass
import qualified Synthesizer.LLVM.Filter.Moog as Moog
import qualified Synthesizer.LLVM.Generator.Exponential2 as Exp
import qualified Synthesizer.LLVM.Frame.Stereo as Stereo
import qualified Synthesizer.LLVM.Frame as Frame
import qualified Synthesizer.LLVM.CausalParameterized.Functional as F
import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS
import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS
import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP
import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS
import qualified Synthesizer.LLVM.Parameterized.Signal as SigP
import qualified Synthesizer.LLVM.Parameter as Param
import qualified Synthesizer.LLVM.Wave as WaveL
import qualified Synthesizer.LLVM.ALSA.BendModulation as BM
import qualified Synthesizer.LLVM.ALSA.MIDI as MIDIL
import qualified Synthesizer.PiecewiseConstant.Signal as PC
import qualified Synthesizer.Generic.Cut as CutG
import qualified Synthesizer.Zip as Zip
import qualified Data.EventList.Relative.BodyTime as EventListBT
import qualified Synthesizer.Storable.Signal as SigSt
import qualified Data.StorableVector.Lazy as SVL
import qualified Data.StorableVector as SV
import System.FilePath ((</>), )
import qualified LLVM.Extra.ScalarOrVector as SoV
import qualified LLVM.Extra.Arithmetic as A
import qualified LLVM.Extra.Monad as LM
import qualified LLVM.Core as LLVM
import qualified Data.TypeLevel.Num as TypeNum
import qualified Data.Traversable as Trav
import Control.Arrow (Arrow, arr, first, second, (&&&), (***), (<<^), (^<<), )
import Control.Category (id, (.), )
import Control.Monad (liftM2, liftM3, (<=<), )
import Control.Applicative (Applicative, pure, liftA2, liftA3, )
import Data.Monoid (mappend, )
import Data.Tuple.HT (swap, mapPair, )
import qualified Number.DimensionTerm as DN
{-
import qualified Numeric.NonNegative.Class as NonNeg
import qualified Numeric.NonNegative.Wrapper as NonNegW
import qualified Numeric.NonNegative.Chunky as NonNegChunky
-}
import qualified Algebra.Additive as Additive
import NumericPrelude.Numeric
import NumericPrelude.Base hiding (id, (.), )
type Param p = Param.T (SampleRate Real, p)
type CausalP p = CausalP.T (SampleRate Real, p)
type Instrument a sig = SampleRate a -> PAlsa.Instrument a sig
type Control = EventListBT.T PC.ShortStrictTime
type Time = DN.Time Real
type Frequency = DN.Frequency Real
stereoFrequenciesFromDetuneBendModulation ::
Param p Real ->
CausalP p
(LLVM.Value Real, BM.T (LLVM.Value Real))
(Stereo.T (LLVM.Value Vector))
stereoFrequenciesFromDetuneBendModulation speed =
CausalP.envelopeStereo
.
(MIDIL.frequencyFromBendModulationPacked speed
***
CausalP.mapSimple (Trav.mapM SoV.replicate)
.
liftA2 Stereo.cons (one + id) (one - id))
.
arr swap
frequencyFromSampleRate :: SampleRate a -> DN.Frequency a
frequencyFromSampleRate (SampleRate sr) = DN.frequency sr
halfLifeControl ::
(Functor f) =>
SampleRate Real ->
f Time ->
f (Exp.ParameterPacked Vector)
halfLifeControl sr =
fmap (Exp.parameterPackedPlain .
flip DN.mulToScalar (frequencyFromSampleRate sr))
frequencyControl ::
(Functor f) =>
SampleRate Real ->
f Frequency ->
f Real
frequencyControl sr =
fmap (flip DN.divToScalar $ frequencyFromSampleRate sr)
takeThreshold ::
Param.T p Real ->
CausalP.T p (LLVM.Value Vector) (LLVM.Value Vector)
takeThreshold =
CausalP.takeWhile
(\threshold y ->
A.cmp LLVM.CmpLE threshold =<< Frame.subsampleVector y)
liftStereo ::
(Applicative f) =>
(f a -> f b) -> f (Stereo.T a) -> f (Stereo.T b)
liftStereo proc freqs =
liftA2 Stereo.cons
(proc $ fmap Stereo.left freqs)
(proc $ fmap Stereo.right freqs)
fanoutShorten ::
(CutG.Transform a, CutG.Transform b, CutG.Transform c) =>
PIO.T a b -> PIO.T a c -> PIO.T a (Zip.T b c)
fanoutShorten a b =
Zip.arrowFirstShorten a .
Zip.arrowSecondShorten b .
arr (\x -> Zip.Cons x x)
reorderEnvelopeControl ::
(Arrow arrow, CutG.Read remainder) =>
arrow
(Zip.T PAlsa.GateChunk
(Zip.T
(Zip.T (Control Time) (Control Time))
remainder))
(Zip.T
(Zip.T PAlsa.GateChunk
(Zip.T (Control Time) (Control Time)))
remainder)
reorderEnvelopeControl =
arr $ \(Zip.Cons gate (Zip.Cons times ctrl)) ->
Zip.consChecked "ping gate ctrl"
(Zip.consChecked "ping gate times" gate times) ctrl
ping :: IO (Instrument Real (SV.Vector Vector))
ping =
fmap (\proc sampleRate vel freq ->
proc (sampleRate, (vel,freq))
.
Gate.toStorableVector) $
CausalP.processIO $
let vel = number fst
freq = frequency snd
in CausalP.fromSignal $
SigP.envelope
(SigPS.exponential2 (timeConst 0.2) (fmap amplitudeFromVelocity vel)) $
SigPS.osciSimple WaveL.saw zero freq
pingReleaseEnvelope ::
IO (Real -> Real ->
SampleRate Real -> Real ->
PIO.T PAlsa.GateChunk (SV.Vector Vector))
pingReleaseEnvelope =
liftM2
(\sustain release dec rel sr vel ->
PSt.continuePacked
(sustain (sr,(dec,vel))
.
Gate.toChunkySize)
(\y ->
release (sr,(rel,y))
.
Gate.allToChunkySize))
(CausalP.processIO $
let vel = number snd
decay = vectorTime fst
in CausalP.fromSignal $
SigPS.exponential2 decay
(fmap amplitudeFromVelocity vel))
(CausalP.processIO $
let level = number snd
release = time fst
in CausalP.take (fmap round (vectorTime (const 1)))
.
CausalP.fromSignal
(SigPS.exponential2 release level))
pingRelease ::
IO (Real -> Real ->
Instrument Real (SV.Vector Vector))
pingRelease =
liftM2
(\osci envelope dec rel sr vel freq ->
osci (sr, freq)
.
envelope dec rel sr vel)
(CausalP.processIO $
let freq = frequency id
in CausalP.envelope
.
CausalP.feedFst (SigPS.osciSimple WaveL.saw zero freq))
pingReleaseEnvelope
pingControlledEnvelope ::
Maybe Real ->
IO (SampleRate Real -> Real ->
PIO.T
(Zip.T PAlsa.GateChunk
(Zip.T (Control Time) (Control Time)))
(SV.Vector Vector))
pingControlledEnvelope threshold =
liftM2
(\sustain release sr vel ->
PSt.continuePacked
(sustain (sr,vel)
.
Gate.shorten
.
Zip.arrowSecond (arr (halfLifeControl sr . Zip.first)))
(\y ->
release (sr,y)
<<^
halfLifeControl sr . Zip.second . Zip.second))
(CausalP.processIO $
let vel = number id
in Exp.causalPackedP
(fmap amplitudeFromVelocity vel))
(CausalP.processIO $
let level = number id
expo = Exp.causalPackedP level
in case threshold of
Just y -> takeThreshold (pure y) . expo
Nothing -> expo)
pingStereoReleaseFM ::
IO (SampleRate Real -> Real -> Real ->
PIO.T
(Zip.T PAlsa.GateChunk
(Zip.T
(Zip.T (Control Time) (Control Time))
(Zip.T
(Zip.T (Control Real) (Control Time))
(Zip.T
(Zip.T (Control Real) (Control Time))
(Zip.T (Control Real) (Control (BM.T Real)))))))
(SV.Vector (Stereo.T Vector)))
pingStereoReleaseFM =
liftA2
(\osc env sr vel freq ->
osc (sr, ())
.
(Zip.arrowSecond $ Zip.arrowSecond $
Zip.arrowSecond $ Zip.arrowSecond $
arr $ transposeModulation sr freq)
.
(Zip.arrowSecond $ Zip.arrowSecond $
Zip.arrowFirst $ Zip.arrowSecond $
arr $ halfLifeControl sr)
.
(Zip.arrowSecond $
Zip.arrowFirst $ Zip.arrowSecond $
arr $ halfLifeControl sr)
.
Zip.arrowFirstShorten (env sr vel)
.
reorderEnvelopeControl)
(CausalP.processIO
(CausalP.envelopeStereo
.
second
(let fm = F.lift (arr (snd.snd))
shape = F.lift (CausalP.mapSimple SoV.replicate . arr (fst.fst))
shapeDecay = F.lift (arr (snd.fst))
shapeCtrl =
1/3.14 + (shape-1/3.14) *
(Exp.causalPackedP (1::Param.T p Real) $& shapeDecay)
freqs =
stereoFrequenciesFromDetuneBendModulation
(frequencyConst 10) $& fm
phase = F.lift (arr (fst.fst.snd))
phaseDecay = F.lift (arr (snd.fst.snd))
expo =
(CausalP.mapSimple SoV.replicate $& phase) *
(Exp.causalPackedP (1::Param.T p Real) $& phaseDecay)
osci = CausalPS.shapeModOsci WaveL.rationalApproxSine1
in F.compile $
liftA2 Stereo.cons
(osci $& shapeCtrl &|& (expo &|& fmap Stereo.left freqs))
(osci $& shapeCtrl &|& (Additive.negate expo &|& fmap Stereo.right freqs)))))
(pingControlledEnvelope (Just 0.01))
filterSawStereoFM ::
IO (SampleRate Real -> Real -> Real ->
PIO.T
(Zip.T PAlsa.GateChunk
(Zip.T
(Zip.T (Control Time) (Control Time))
(Zip.T
(Zip.T (Control Frequency) (Control Time))
(Zip.T (Control Real) (Control (BM.T Real))))))
(SV.Vector (Stereo.T Vector)))
filterSawStereoFM =
liftA2
(\osc env sr vel freq ->
osc (sr, ())
.
(Zip.arrowSecond $ Zip.arrowSecond $
Zip.arrowSecond $
arr $ transposeModulation sr freq)
.
(Zip.arrowSecond $
Zip.arrowFirst $ Zip.arrowSecond $
arr $ halfLifeControl sr)
.
(Zip.arrowSecond $
Zip.arrowFirst $ Zip.arrowFirst $
arr $ frequencyControl sr)
.
Zip.arrowFirstShorten (env sr vel)
.
reorderEnvelopeControl)
(CausalP.processIO
(CausalP.envelopeStereo
.
second
(let fm = F.lift (arr snd)
cutoff = F.lift (CausalP.mapSimple SoV.replicate . arr (fst.fst))
cutoffDecay = F.lift (arr (snd.fst))
freqs =
stereoFrequenciesFromDetuneBendModulation
(frequencyConst 10) $& fm
{- bound control in order to avoid too low resonant frequency,
which makes the filter instable -}
expo =
takeThreshold (frequencyConst 100) $&
(CausalP.mapSimple SoV.replicate $& cutoff) *
(Exp.causalPackedP (1::Param.T p Real) $& cutoffDecay)
in F.compile $
CausalP.stereoFromMonoControlled
(UniFilter.lowpass ^<< CtrlPS.process)
$&
(CausalP.quantizeLift (100 / fromIntegral vectorSize :: Param.T p Real)
(CausalP.mapSimple
(UniFilter.parameter (LLVM.valueOf 10)
<=<
Frame.subsampleVector))
$&
expo)
&|&
(CausalP.stereoFromMono
(CausalPS.osciSimple WaveL.saw . CausalP.feedFst zero) $&
freqs))))
(pingControlledEnvelope (Just 0.01))
tineStereoFM ::
IO (SampleRate Real -> Real -> Real ->
PIO.T
(Zip.T PAlsa.GateChunk
(Zip.T
(Zip.T (Control Time) (Control Time))
(Zip.T
(Zip.T (Control Real) (Control Real))
(Zip.T (Control Real) (Control (BM.T Real))))))
(SV.Vector (Stereo.T Vector)))
tineStereoFM =
liftA2
(\osc env sr vel freq ->
osc (sr, vel)
.
(Zip.arrowSecond $ Zip.arrowSecond $
Zip.arrowSecond $
arr $ transposeModulation sr freq)
.
Zip.arrowFirstShorten (env sr vel)
.
reorderEnvelopeControl)
(CausalP.processIO
(CausalP.envelopeStereo
.
second
(let vel = number id
fm = F.lift (arr snd)
freqs =
stereoFrequenciesFromDetuneBendModulation
(frequencyConst 5) $& fm
index = F.lift (CausalP.mapSimple SoV.replicate . arr (fst.fst))
depth = F.lift (CausalP.mapSimple SoV.replicate . arr (snd.fst))
expo =
F.lift $ CausalP.fromSignal $
SigPS.exponential2 (timeConst 1) (1 + vel)
osci freq =
CausalPS.osciSimple WaveL.approxSine2 $&
expo * depth *
(CausalPS.osciSimple WaveL.approxSine2
$& zero &|& index*freq)
&|&
freq
in F.compile $ liftStereo osci freqs)))
(pingControlledEnvelope (Just 0.01))
bellNoiseStereoFM ::
IO (SampleRate Real -> Real -> Real ->
PIO.T
(Zip.T PAlsa.GateChunk
(Zip.T
(Zip.T (Control Time) (Control Time))
(Zip.T
(Zip.T (Control Real) (Control Real))
(Zip.T (Control Real) (Control (BM.T Real))))))
(SV.Vector (Stereo.T Vector)))
bellNoiseStereoFM =
liftA3
(\osc env envInf sr vel freq ->
osc (sr, ())
.
(Zip.arrowSecond $ Zip.arrowSecond $
Zip.arrowSecond $
arr $ transposeModulation sr freq)
.
Zip.arrowFirstShorten
(fanoutShorten
(env sr (vel*0.5))
(let shortenTimes ::
Real ->
PIO.T
(Zip.T (Control Time) (Control Time))
(Zip.T (Control Time) (Control Time))
shortenTimes n =
let rn = recip n
in (Zip.arrowFirst $ arr $ fmap $ DN.scale rn)
.
(Zip.arrowSecond $ arr $ fmap $ DN.scale rn)
in PIO.zip
(envInf sr (vel*2)
.
Zip.arrowSecond (shortenTimes 4))
(envInf sr (vel*4)
.
Zip.arrowSecond (shortenTimes 7))))
.
reorderEnvelopeControl)
(CausalP.processIO
(let env1 = F.lift (arr (fst.fst))
env4 = F.lift (arr (fst.snd.fst))
env7 = F.lift (arr (snd.snd.fst))
fm = F.lift (arr (snd.snd))
noiseAmp = F.lift (CausalP.mapSimple SoV.replicate . arr (fst.fst.snd))
noiseReson = F.lift (arr (snd.fst.snd))
noiseParam =
CausalP.quantizeLift
(100 / fromIntegral vectorSize :: Param.T p Real)
(CausalP.zipWithSimple (Moog.parameter TypeNum.d8))
noise =
F.lift
(CausalP.fromSignal
(SigPS.noise 12 (noiseReference 20000)))
freqs =
stereoFrequenciesFromDetuneBendModulation
(frequencyConst 5) $& fm
osci amp env n =
CausalPS.amplifyStereo amp $&
CausalP.envelopeStereo $&
env &|&
(CausalP.stereoFromMono
(CausalPS.osciSimple WaveL.approxSine4 .
CausalP.feedFst zero)
$&
CausalPS.amplifyStereo n
$&
freqs)
in F.compile $
(CausalP.envelopeStereo $&
(noiseAmp * env1)
&|&
liftStereo
(\freq ->
CtrlPS.process $&
(noiseParam $& noiseReson &|&
(CausalP.mapSimple Frame.subsampleVector $& freq))
&|&
noise)
freqs)
+ osci 1.00 env1 1
+ osci 0.10 env4 4
+ osci 0.01 env7 7))
(pingControlledEnvelope (Just 0.01))
(pingControlledEnvelope Nothing)
stringControlledEnvelope ::
IO (SampleRate Real -> Real ->
PIO.T
(Zip.T PAlsa.GateChunk
(Zip.T (Control Time) (Control Time)))
(SV.Vector Vector))
stringControlledEnvelope =
liftM3
(\attack sustain release sr vel ->
let amp = amplitudeFromVelocity vel
in PSt.continuePacked
(mappend
(attack (sr,amp))
{- we could also feed the sustain process
with a signal with sample type () -}
(sustain (sr,amp))
.
Gate.shorten
.
Zip.arrowSecond (arr (halfLifeControl sr . Zip.first)))
(\y ->
release (sr,y)
<<^
halfLifeControl sr . Zip.second . Zip.second))
(CausalP.processIO $
let amp = number id
in CausalP.fromSignal (SigPS.constant amp)
-
takeThreshold (1e-4 :: Param.T p Real)
.
Exp.causalPackedP amp)
(CausalP.processIO $
let amp = number id
in CausalP.fromSignal (SigPS.constant amp))
(CausalP.processIO $
let level = number id
in takeThreshold (0.01 :: Param.T p Real)
.
Exp.causalPackedP level)
windCore ::
F.T (SampleRate Real, p) a (LLVM.Value Real) ->
F.T (SampleRate Real, p) a (BM.T (LLVM.Value Real)) ->
F.T (SampleRate Real, p) a (Stereo.T (LLVM.Value Vector))
windCore reson fm =
let modu =
CausalP.mapSimple Frame.subsampleVector $&
(fmap (`asTypeOf` (undefined :: LLVM.Value Vector)) $
(MIDIL.frequencyFromBendModulationPacked
(frequencyConst 0.2) $& fm))
in CausalP.stereoFromMonoControlled CtrlPS.process $&
(CausalP.zipWithSimple
(Moog.parameter TypeNum.d8) $&
reson &|& modu)
&|&
F.lift (CausalP.fromSignal stereoNoise)
wind ::
IO (SampleRate Real -> Real -> Real ->
PIO.T
(Zip.T PAlsa.GateChunk
(Zip.T
(Zip.T (Control Time) (Control Time))
(Zip.T (Control Real) (Control (BM.T Real)))))
(SV.Vector (Stereo.T Vector)))
wind =
liftA2
(\osc env sr vel freq ->
osc (sr, ())
.
(Zip.arrowSecond $ Zip.arrowSecond $
arr $ transposeModulation sr freq)
.
Zip.arrowFirstShorten (env sr vel)
.
reorderEnvelopeControl)
(CausalP.processIO
(let env = F.lift (arr fst)
reson = F.lift (arr (fst.snd))
fm = F.lift (arr (snd.snd))
in F.compile $
CausalP.envelopeStereo $&
env &|&
windCore reson fm))
stringControlledEnvelope
windPhaser ::
IO (SampleRate Real -> Real -> Real ->
PIO.T
(Zip.T PAlsa.GateChunk
(Zip.T
(Zip.T (Control Time) (Control Time))
(Zip.T (Control Real)
(Zip.T (Control Frequency)
(Zip.T (Control Real) (Control (BM.T Real)))))))
(SV.Vector (Stereo.T Vector)))
windPhaser =
liftA2
(\osc env sr vel freq ->
osc (sr, ())
.
(Zip.arrowSecond $ Zip.arrowSecond $
Zip.arrowSecond $ Zip.arrowSecond $
arr $ transposeModulation sr freq)
.
(Zip.arrowSecond $ Zip.arrowSecond $
Zip.arrowFirst $
arr $ fmap (Allpass.flangerParameterPlain TypeNum.d8) .
frequencyControl sr)
.
Zip.arrowFirstShorten (env sr vel)
.
reorderEnvelopeControl)
(CausalP.processIO
(let env = F.lift (arr fst)
phaserMix =
F.lift (CausalP.mapSimple SoV.replicate . arr (fst.snd))
phaserFreq = F.lift (arr (fst.snd.snd))
reson = F.lift (arr (fst.snd.snd.snd))
fm = F.lift (arr (snd.snd.snd.snd))
noise = windCore reson fm
in F.compile $
CausalP.envelopeStereo $&
env &|&
((CausalP.envelopeStereo $& (1 - phaserMix) &|& noise)
+
(CausalP.envelopeStereo $&
phaserMix &|&
(Stereo.arrowFromMonoControlled CtrlPS.process $&
phaserFreq &|& noise)))))
stringControlledEnvelope
phaserOsci ::
(Param.T p Real -> Param.T p Real -> CausalP.T p a (LLVM.Value Vector)) ->
CausalP.T p a (Stereo.T (LLVM.Value Vector))
phaserOsci osci =
CausalPS.amplifyStereo 0.25
.
Trav.traverse sumNested
(Stereo.cons
(zipWith osci [0.1, 0.7, 0.2, 0.3] [1.0, -0.4, 0.5, -0.7])
(zipWith osci [0.4, 0.9, 0.6, 0.5] [0.4, -1.0, 0.7, -0.5]))
type
StringInstrument =
SampleRate Real -> Real -> Real ->
PIO.T
(Zip.T PAlsa.GateChunk
(Zip.T
(Zip.T (Control Time) (Control Time))
(Zip.T
(Control Real)
(Zip.T (Control Real) (Control (BM.T Real))))))
(SV.Vector (Stereo.T Vector))
softStringShapeCore ::
(forall r.
LLVM.Value Vector ->
LLVM.Value Vector ->
LLVM.CodeGenFunction r (LLVM.Value Vector)) ->
IO StringInstrument
softStringShapeCore wave =
liftA2
(\osc env sr vel freq ->
osc (sr, ())
.
(Zip.arrowSecond $ Zip.arrowSecond $
Zip.arrowSecond $
arr $ transposeModulation sr freq)
.
Zip.arrowFirstShorten (env sr vel)
.
reorderEnvelopeControl)
(CausalP.processIO
(CausalP.envelopeStereo
.
second
(let fm = F.lift (arr (snd.snd))
det = F.lift (CausalP.mapSimple SoV.replicate . arr (fst.snd))
shape = F.lift (CausalP.mapSimple SoV.replicate . arr fst)
modu =
MIDIL.frequencyFromBendModulationPacked
(frequencyConst 5) $& fm
osci ::
Param.T (mod,fm) Real ->
Param.T (mod,fm) Real ->
CausalP.T (mod,fm)
(LLVM.Value Vector,
{- wave shape parameter -}
(LLVM.Value Vector, LLVM.Value Vector)
{- detune, frequency modulation -})
(LLVM.Value Vector)
osci p d =
CausalPS.shapeModOsci wave
.
second
(CausalP.feedFst (SigPS.constant p)
.
CausalP.envelope
.
first (one + CausalPS.amplify d))
in F.compile $
phaserOsci osci $& shape &|& det &|& modu)))
stringControlledEnvelope
arcStringStereoFM ::
(forall r.
LLVM.Value Vector ->
LLVM.CodeGenFunction r (LLVM.Value Vector)) ->
IO StringInstrument
arcStringStereoFM wave =
softStringShapeCore
(\k p ->
LM.liftR2 Frame.amplifyMono
(WaveL.approxSine4 =<< WaveL.halfEnvelope p)
(wave =<< WaveL.replicate k p))
softStringShapeFM, cosineStringStereoFM,
arcSawStringStereoFM, arcSineStringStereoFM,
arcSquareStringStereoFM, arcTriangleStringStereoFM ::
IO StringInstrument
softStringShapeFM =
softStringShapeCore WaveL.rationalApproxSine1
cosineStringStereoFM =
softStringShapeCore
(\k p -> WaveL.approxSine2 =<< WaveL.replicate k p)
arcSawStringStereoFM = arcStringStereoFM WaveL.saw
arcSineStringStereoFM = arcStringStereoFM WaveL.approxSine2
arcSquareStringStereoFM = arcStringStereoFM WaveL.square
arcTriangleStringStereoFM = arcStringStereoFM WaveL.triangle
fmStringStereoFM ::
IO (SampleRate Real -> Real -> Real ->
PIO.T
(Zip.T PAlsa.GateChunk
(Zip.T
(Zip.T (Control Time) (Control Time))
(Zip.T
(Zip.T (Control Real) (Control Real))
(Zip.T (Control Real) (Control (BM.T Real))))))
(SV.Vector (Stereo.T Vector)))
fmStringStereoFM =
liftA2
(\osc env sr vel freq ->
osc (sr, ())
.
(Zip.arrowSecond $ Zip.arrowSecond $
Zip.arrowSecond $
arr $ transposeModulation sr freq)
.
Zip.arrowFirstShorten (env sr vel)
.
reorderEnvelopeControl)
(CausalP.processIO
(let env = F.lift (arr fst)
fm = F.lift (arr (snd.snd.snd))
det = F.lift (CausalP.mapSimple SoV.replicate . arr (fst.snd.snd))
shape = F.lift (CausalP.mapSimple SoV.replicate . arr (snd.fst.snd))
depth =
CausalP.envelope $&
env &|&
F.lift (CausalP.mapSimple SoV.replicate . arr (fst.fst.snd))
modu =
MIDIL.frequencyFromBendModulationPacked
(frequencyConst 5) $& fm
osci ::
Param.T (mod,fm) Real ->
Param.T (mod,fm) Real ->
CausalP.T (mod,fm)
((LLVM.Value Vector, LLVM.Value Vector)
{- phase modulation depth, modulator distortion -},
(LLVM.Value Vector, LLVM.Value Vector)
{- detune, frequency modulation -})
(LLVM.Value Vector)
osci p d =
CausalPS.osciSimple WaveL.approxSine2
.
((CausalP.envelope
.
second
(CausalPS.shapeModOsci WaveL.rationalApproxSine1
. second (CausalP.feedFst (SigPS.constant p)))
<<^
(\((dp, ds), f) -> (dp, (ds, f))))
&&& arr snd)
.
second
(CausalP.envelope .
first (one + CausalPS.amplify d))
in F.compile $
CausalP.envelopeStereo $&
env &|&
(phaserOsci osci $& (depth &|& shape) &|& (det &|& modu))))
stringControlledEnvelope
sampledSound ::
IO (SampledSound ->
SampleRate Real -> Real -> Real ->
PIO.T
(Zip.T PAlsa.GateChunk
(Zip.T (Control Real) (Control (BM.T Real))))
(SV.Vector (Stereo.T Vector)))
sampledSound =
liftA2
(\osc freqMod smp sr vel freq ->
{-
We split the frequency modulation signal
in order to get a smooth frequency modulation curve.
Without (periodic) frequency modulation
we could just split the piecewise constant control curve @fm@.
-}
let pos = samplePositions smp
amp = 2 * amplitudeFromVelocity vel
(attack,sustain) =
mapPair
(SigSt.drop (sampleStart pos),
SigSt.take (sampleLoopLength pos)) $
SigSt.splitAt (sampleLoopStart pos) $
sampleData smp
release =
SigSt.drop (sampleLoopStart pos + sampleLoopLength pos) $
SigSt.take (sampleStart pos + sampleLength pos) $
sampleData smp
osci smpBody = osc (sr, (amp, smpBody))
in mappend
(osci
(attack `SigSt.append`
SVL.cycle (SigSt.take (sampleLoopLength pos) sustain))
.
Gate.shorten)
(osci release <<^ Zip.second)
.
Zip.arrowSecond
((id :: PIO.T
(SV.Vector (Stereo.T Vector))
(SV.Vector (Stereo.T Vector)))
.
freqMod (sr, ())
.
(Zip.arrowSecond $ arr $
transposeModulation sr (freq * samplePeriod smp))))
(CausalP.processIO
(let amp = number fst
smp = signal snd
in CausalPS.amplifyStereo amp
.
CausalP.stereoFromMono
(CausalPS.pack
(CausalP.frequencyModulationLinear
{-
(SigP.fromStorableVector $
fmap (SV.concat . SVL.chunks . SVL.take 1000000) smp)
-}
(SigP.fromStorableVectorLazy smp)
{- (SigP.osciSimple WaveL.saw 0 (1 / 324 {- samplePeriod smp -})) -}))))
(CausalP.processIO
(stereoFrequenciesFromDetuneBendModulation (frequencyConst 3)))
makeSampledSounds ::
FilePath ->
SampleInfo ->
IO [SampleRate Real -> Real -> Real ->
PIO.T
(Zip.T PAlsa.GateChunk
(Zip.T (Control Real) (Control (BM.T Real))))
(SV.Vector (Stereo.T Vector))]
makeSampledSounds dir (file, positions, period) = do
liftA2
(\makeSmp smp ->
map (\pos -> makeSmp (SampledSound smp pos period))
positions)
sampledSound
(loadSound (dir </> file))