synthesizer-llvm 0.5.0.2 → 0.6
raw patch · 74 files changed
+7200/−2414 lines, 74 filesdep +gnuplotdep +non-emptydep −sample-framedep −sample-frame-npdep ~filepathdep ~llvm-extradep ~numeric-preludenew-component:exe:synthi-llvm-samplenew-component:exe:synthi-llvm-speech
Dependencies added: gnuplot, non-empty
Dependencies removed: sample-frame, sample-frame-np
Dependency ranges changed: filepath, llvm-extra, numeric-prelude, sox, storablevector, synthesizer-core, utility-ht
Files
- alsa/Synthesizer/LLVM/Server.hs +5/−1
- alsa/Synthesizer/LLVM/Server/CausalPacked/Run.hs +51/−13
- alsa/Synthesizer/LLVM/Server/CausalPacked/Test.hs +102/−58
- alsa/Synthesizer/LLVM/Server/Packed/Run.hs +13/−9
- alsa/Synthesizer/LLVM/Server/Packed/Test.hs +28/−31
- example/Synthesizer/LLVM/LAC2011.hs +7/−8
- example/Synthesizer/LLVM/LNdW2011.hs +12/−15
- example/Synthesizer/LLVM/Test.hs +678/−126
- jack/Synthesizer/LLVM/Server/JACK.hs +30/−3
- render/Synthesizer/LLVM/Server/Render.hs +5/−37
- src/Synthesizer/LLVM/Causal/Process.hs +260/−69
- src/Synthesizer/LLVM/Causal/ProcessPrivate.hs +20/−0
- src/Synthesizer/LLVM/Causal/ProcessValue.hs +44/−0
- src/Synthesizer/LLVM/CausalParameterized/Controlled.hs +21/−44
- src/Synthesizer/LLVM/CausalParameterized/ControlledPacked.hs +20/−34
- src/Synthesizer/LLVM/CausalParameterized/Functional.hs +74/−61
- src/Synthesizer/LLVM/CausalParameterized/FunctionalPlug.hs +29/−32
- src/Synthesizer/LLVM/CausalParameterized/Helix.hs +646/−0
- src/Synthesizer/LLVM/CausalParameterized/Process.hs +576/−344
- src/Synthesizer/LLVM/CausalParameterized/ProcessPacked.hs +66/−60
- src/Synthesizer/LLVM/CausalParameterized/ProcessPrivate.hs +294/−93
- src/Synthesizer/LLVM/CausalParameterized/ProcessValue.hs +33/−16
- src/Synthesizer/LLVM/ConstantPiece.hs +15/−25
- src/Synthesizer/LLVM/EventIterator.hs +21/−14
- src/Synthesizer/LLVM/Filter/Allpass.hs +165/−88
- src/Synthesizer/LLVM/Filter/Butterworth.hs +6/−20
- src/Synthesizer/LLVM/Filter/Chebyshev.hs +8/−13
- src/Synthesizer/LLVM/Filter/ComplexFirstOrder.hs +5/−4
- src/Synthesizer/LLVM/Filter/ComplexFirstOrderPacked.hs +12/−30
- src/Synthesizer/LLVM/Filter/FirstOrder.hs +99/−41
- src/Synthesizer/LLVM/Filter/Moog.hs +60/−71
- src/Synthesizer/LLVM/Filter/NonRecursive.hs +180/−0
- src/Synthesizer/LLVM/Filter/SecondOrder.hs +43/−23
- src/Synthesizer/LLVM/Filter/SecondOrderCascade.hs +121/−32
- src/Synthesizer/LLVM/Filter/SecondOrderPacked.hs +12/−17
- src/Synthesizer/LLVM/Filter/Universal.hs +19/−14
- src/Synthesizer/LLVM/Frame/SerialVector.hs +70/−15
- src/Synthesizer/LLVM/Frame/Stereo.hs +6/−23
- src/Synthesizer/LLVM/Frame/StereoInterleaved.hs +30/−2
- src/Synthesizer/LLVM/Generator/Exponential2.hs +6/−9
- src/Synthesizer/LLVM/Interpolation.hs +269/−0
- src/Synthesizer/LLVM/MIDI.hs +28/−16
- src/Synthesizer/LLVM/Parameter.hs +38/−1
- src/Synthesizer/LLVM/Parameterized/Signal.hs +210/−234
- src/Synthesizer/LLVM/Parameterized/SignalPacked.hs +34/−30
- src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs +169/−61
- src/Synthesizer/LLVM/Plug/Input.hs +3/−7
- src/Synthesizer/LLVM/Plug/Output.hs +4/−8
- src/Synthesizer/LLVM/Random.hs +4/−5
- src/Synthesizer/LLVM/RingBuffer.hs +100/−41
- src/Synthesizer/LLVM/RingBufferForward.hs +293/−0
- src/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs +272/−46
- src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs +201/−164
- src/Synthesizer/LLVM/Server/CausalPacked/InstrumentPlug.hs +46/−5
- src/Synthesizer/LLVM/Server/CausalPacked/Speech.hs +314/−20
- src/Synthesizer/LLVM/Server/CausalPacked/SpeechExplore.hs +358/−0
- src/Synthesizer/LLVM/Server/Common.hs +16/−10
- src/Synthesizer/LLVM/Server/CommonPacked.hs +7/−16
- src/Synthesizer/LLVM/Server/Packed/Instrument.hs +3/−27
- src/Synthesizer/LLVM/Server/SampledSound.hs +46/−22
- src/Synthesizer/LLVM/Server/SampledSoundAnalysis.hs +143/−0
- src/Synthesizer/LLVM/Simple/Signal.hs +57/−54
- src/Synthesizer/LLVM/Simple/Value.hs +226/−59
- src/Synthesizer/LLVM/Simple/Vanilla.hs +3/−4
- src/Synthesizer/LLVM/Storable/ChunkIterator.hs +28/−26
- src/Synthesizer/LLVM/Storable/Signal.hs +3/−4
- src/Synthesizer/LLVM/Storable/Vector.hs +25/−0
- src/Synthesizer/LLVM/Wave.hs +27/−0
- synthesizer-llvm.cabal +75/−30
- testsuite/Test/Main.hs +4/−0
- testsuite/Test/Synthesizer/LLVM/Filter.hs +42/−18
- testsuite/Test/Synthesizer/LLVM/Helix.hs +115/−0
- testsuite/Test/Synthesizer/LLVM/Packed.hs +10/−11
- testsuite/Test/Synthesizer/LLVM/RingBufferForward.hs +135/−0
alsa/Synthesizer/LLVM/Server.hs view
@@ -34,8 +34,12 @@ 151 -> ServerCausal.keyboardFM 152 -> ServerCausal.keyboardDetuneFM 153 -> ServerCausal.keyboardMultiChannel- 154 -> ServerCausal.voder+ 154 -> ServerCausal.voderBand 155 -> ServerCausal.formant+ 156 -> ServerCausal.voderMask+ 157 -> ServerCausal.voderMaskEnv+ 158 -> ServerCausal.voderMaskSeparated+ 159 -> ServerCausal.voderMaskMulti 200 -> ServerScalarTest.pitchBend0 201 -> ServerScalarTest.pitchBend1 202 -> ServerScalarTest.pitchBend2
alsa/Synthesizer/LLVM/Server/CausalPacked/Run.hs view
@@ -12,6 +12,8 @@ import Synthesizer.LLVM.Server.Common import qualified Sound.ALSA.Sequencer.Event as Event+import Sound.MIDI.ALSA.Query ()+import Sound.MIDI.ALSA.Construct () import qualified Synthesizer.MIDI.CausalIO.ControllerSet as MCS import qualified Synthesizer.MIDI.CausalIO.Process as MIO@@ -32,7 +34,7 @@ import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg import qualified Sound.MIDI.Message.Channel as ChannelMsg -import Control.Arrow (Arrow, (<<<), (^<<), arr, )+import Control.Arrow ((<<<), (^<<), arr, ) import Control.Category (id, ) import qualified Number.DimensionTerm as DN@@ -106,26 +108,41 @@ keyboardMultiChannel :: IO () keyboardMultiChannel = do opt <- Option.get- proc <- keyboardDetuneFMCore opt- mix <- CausalP.processIO CausalP.mix+ proc <- Arrange.keyboardMultiChannel (Option.sampleDirectory opt)+ playFromEvents opt proc ++voderBand :: IO ()+voderBand = do+ opt <- Option.get+ proc <-+ Arrange.voderBand+ (CausalP.mapSimple StereoInt.interleave)+ (Option.sampleDirectory opt)+ playFromEvents opt $ \ sampleRate -> arr SigStL.unpackStereoStrict <<<- foldl1- (\x y -> mix () <<< Zip.arrowFanout x y)- (map- (\chan ->- proc (ChannelMsg.toChannel chan) (VoiceMsg.toProgram 0)- sampleRate)- [0 .. 3])+ proc (Option.channel opt) (VoiceMsg.toProgram 4) sampleRate +voderMask :: IO ()+voderMask = do+ opt <- Option.get+ proc <-+ Arrange.voderMask+ (CausalP.mapSimple StereoInt.interleave)+ (Option.sampleDirectory opt) -voder :: IO ()-voder = do+ playFromEvents opt $ \ sampleRate ->+ arr SigStL.unpackStereoStrict+ <<<+ proc (Option.channel opt) (VoiceMsg.toProgram 4) sampleRate++voderMaskEnv :: IO ()+voderMaskEnv = do opt <- Option.get proc <-- Arrange.voder+ Arrange.voderMaskEnv (CausalP.mapSimple StereoInt.interleave) (Option.sampleDirectory opt) @@ -133,6 +150,27 @@ arr SigStL.unpackStereoStrict <<< proc (Option.channel opt) (VoiceMsg.toProgram 4) sampleRate++voderMaskSeparated :: IO ()+voderMaskSeparated = do+ opt <- Option.get+ proc <-+ Arrange.voderMaskSeparated+ (CausalP.mapSimple StereoInt.interleave)+ (Option.sampleDirectory opt)++ playFromEvents opt $ \ sampleRate ->+ arr SigStL.unpackStereoStrict+ <<<+ proc+ (Option.channel opt) (Option.extraChannel opt)+ (VoiceMsg.toProgram 4) sampleRate++voderMaskMulti :: IO ()+voderMaskMulti = do+ opt <- Option.get+ proc <- Arrange.voderMaskMulti $ Option.sampleDirectory opt+ playFromEvents opt proc formant :: IO ()
alsa/Synthesizer/LLVM/Server/CausalPacked/Test.hs view
@@ -1,5 +1,6 @@ module Synthesizer.LLVM.Server.CausalPacked.Test where +import qualified Synthesizer.LLVM.Server.CausalPacked.Speech as Speech import qualified Synthesizer.LLVM.Server.CausalPacked.InstrumentPlug as InstrFP import qualified Synthesizer.LLVM.Server.CausalPacked.Instrument as Instr import qualified Synthesizer.LLVM.Server.SampledSound as Sample@@ -32,6 +33,7 @@ import qualified Synthesizer.MIDI.PiecewiseConstant.ControllerSet as PCS import qualified Synthesizer.MIDI.CausalIO.ControllerSet as MCS import qualified Synthesizer.MIDI.CausalIO.Process as MIO+import qualified Synthesizer.PiecewiseConstant.Signal as PC import qualified Synthesizer.CausalIO.Process as PIO import qualified Synthesizer.LLVM.CausalParameterized.FunctionalPlug as FP@@ -56,7 +58,7 @@ import Control.Arrow ((<<<), (<<^), (^<<), arr, first, ) import Control.Category (id, )-import Control.Applicative (pure, )+import Control.Applicative (pure, liftA2, ) import Control.Monad (when, ) import Control.Monad.Trans.State (evalState, ) @@ -302,6 +304,17 @@ map (ctrlEvent 0 1) [0..127] +makeSampledSounds ::+ Option.T ->+ IO [SampleRate Real -> Real -> Real ->+ PIO.T+ (Zip.T MIO.GateChunk Instr.DetuneBendModControl)+ Instr.StereoChunk]+makeSampledSounds opt =+ liftA2 map Instr.sampledSound $+ Sample.loadRanges (Option.sampleDirectory opt) Sample.tomatensalat++ sampledSound :: IO () sampledSound = do opt <- Option.get@@ -310,8 +323,7 @@ CausalP.processIO (CausalP.mapSimple StereoInt.interleave) - tomatoSmps <-- Instr.makeSampledSounds (Option.sampleDirectory opt) Sample.tomatensalat+ tomatoSmps <- makeSampledSounds opt let tomato smp vel freq = smp sampleRate vel freq@@ -336,19 +348,26 @@ Just (100, VoiceMsg.normalVelocity) : replicate 4 Nothing +loadTomato :: Option.T -> IO (SVL.Vector Real)+loadTomato opt =+ case Sample.tomatensalat of+ Sample.Info name _sampleRate _positions ->+ Sample.load (Option.sampleDirectory opt ++ "/" ++ name)+ sampledSoundMono :: IO () sampledSoundMono = do opt <- Option.get case Sample.tomatensalat of- (name, positions, period) -> do- smp <- Sample.load (Option.sampleDirectory opt ++ "/" ++ name)- case Sample.parts (Sample.Cons smp (last positions) period) of+ Sample.Info _name rate positions -> do+ smp <- loadTomato opt+ case Sample.parts (Sample.Cons smp (DN.frequency rate) (last positions)) of (_attack, _sustain, release) -> SVL.writeFile "/tmp/release.f32" release tomatoSmps <-- Instr.makeSampledSoundsMono (Option.sampleDirectory opt) Sample.tomatensalat+ liftA2 map Instr.sampledSoundMono $+ Sample.loadRanges (Option.sampleDirectory opt) Sample.tomatensalat let tomato smp vel freq = smp sampleRate vel freq@@ -376,8 +395,7 @@ CausalP.processIO (CausalP.mapSimple StereoInt.interleave) - tomatoSmps <-- Instr.makeSampledSounds (Option.sampleDirectory opt) Sample.tomatensalat+ tomatoSmps <- makeSampledSounds opt let tomato smp vel freq = smp sampleRate vel freq@@ -415,10 +433,7 @@ frequencyModulation :: IO () frequencyModulation = do opt <- Option.get- smp <-- case Sample.tomatensalat of- (name, _positions, _period) ->- Sample.load (Option.sampleDirectory opt ++ "/" ++ name)+ smp <- loadTomato opt SVL.writeFile "/tmp/test.f32" . asMono .@@ -431,10 +446,7 @@ frequencyModulationIO :: IO () frequencyModulationIO = do opt <- Option.get- smp <-- case Sample.tomatensalat of- (name, _positions, _period) ->- Sample.load (Option.sampleDirectory opt ++ "/" ++ name)+ smp <- loadTomato opt proc <- CausalP.processIO@@ -447,10 +459,7 @@ frequencyModulationStrictIO :: IO () frequencyModulationStrictIO = do opt <- Option.get- smp <-- case Sample.tomatensalat of- (name, _positions, _period) ->- Sample.load (Option.sampleDirectory opt ++ "/" ++ name)+ smp <- loadTomato opt proc <- CausalP.processIO@@ -475,10 +484,7 @@ envelopeIO :: IO () envelopeIO = do opt <- Option.get- smp <-- case Sample.tomatensalat of- (name, _positions, _period) ->- Sample.load (Option.sampleDirectory opt ++ "/" ++ name)+ smp <- loadTomato opt proc <- CausalP.processIO@@ -493,11 +499,9 @@ phaser <- CausalP.processIO $ F.withArgs $ \ratio -> let freq = frequency id- noise =- F.lift $ CausalP.fromSignal $- SigP.noise 12 (recip freq)+ noise = F.fromSignal $ SigP.noise 12 (recip freq) in (1-ratio) * noise +- ratio * (CausalP.delay (pure (0::Float)) 100 F.$& noise)+ ratio * (CausalP.delayZero 100 F.$& noise) writeTest (phaser (sampleRate, 200000) ::@@ -514,7 +518,7 @@ ratio = FP.plug ratio0 noise = FP.fromSignal $ SigP.noise 12 (recip freq) in (1-ratio) * noise +- ratio * (CausalP.delay (pure (0::Float)) 100 FP.$& noise)+ ratio * (CausalP.delayZero 100 FP.$& noise) writeTest (phaser () (sampleRate, 200000) ::@@ -536,44 +540,84 @@ SigStL.makeUnpackGenericStrict -} +functionalTineControl ::+ Instr.WithEnvelopeControl+ (Zip.T+ (Zip.T (Instr.Control Real) (Instr.Control Real))+ Instr.DetuneBendModControl)+functionalTineControl =+ let cs :: Num a => a+ cs = 512+ in Zip.Cons+ (Gate.chunk cs Nothing)+ (Zip.Cons+ (Zip.Cons+ (EventListBT.singleton (DN.time 1) cs)+ (EventListBT.singleton (DN.time 1) cs))+ (Zip.Cons+ (Zip.Cons+ (EventListBT.singleton 2 cs)+ (EventListBT.singleton 1 cs))+ (Zip.Cons+ (EventListBT.singleton 0.001 cs)+ (EventListBT.singleton (BM.Cons 1 0.01) cs))))+ functionalTine :: IO () functionalTine = do ping <- Instr.tineStereoFM unpack <- makeUnpackStereoStrict- let cs = 512 writeTest (unpack <<< ping sampleRate 0 440) $- replicate 100 $- Zip.Cons- (Gate.chunk 512 Nothing)- (Zip.Cons- (Zip.Cons- (EventListBT.singleton (DN.time 1) cs)- (EventListBT.singleton (DN.time 1) cs))- (Zip.Cons- (Zip.Cons- (EventListBT.singleton 2 cs)- (EventListBT.singleton 1 cs))- (Zip.Cons- (EventListBT.singleton 0.001 cs)- (EventListBT.singleton (BM.Cons 1 0.01) cs))))+ replicate 100 functionalTineControl functionalPlugTine :: IO () functionalPlugTine = do ping <- InstrFP.tineStereoFM unpack <- makeUnpackStereoStrict- let cs = 512 writeTest (unpack <<< ping sampleRate 0 440) $- replicate 100 $- Zip.Cons- (Gate.chunk 512 Nothing)+ replicate 100 functionalTineControl+++stringControl ::+ PC.ShortStrictTime ->+ Instr.WithEnvelopeControl+ (Zip.T (Instr.Control Real) Instr.DetuneBendModControl)+stringControl cs =+ Zip.Cons+ (Gate.chunk (PC.longFromShortTime cs) Nothing)+ (Zip.Cons (Zip.Cons- (Zip.Cons- (EventListBT.singleton (DN.time 1) cs)- (EventListBT.singleton (DN.time 1) cs))+ (EventListBT.singleton (DN.time 0.5) cs)+ (EventListBT.singleton (DN.time 1) cs))+ (Zip.Cons+ (EventListBT.singleton 10 cs) (Zip.Cons- (Zip.Cons- (EventListBT.singleton 2 cs)- (EventListBT.singleton 1 cs))- (Zip.Cons- (EventListBT.singleton 0.001 cs)- (EventListBT.singleton (BM.Cons 1 0.01) cs))))+ (EventListBT.singleton 0.001 cs)+ (EventListBT.singleton (BM.Cons 1 0) cs))))++phonemeControl ::+ PC.ShortStrictTime ->+ (PC.ShortStrictTime -> ctrl) ->+ Instr.WithEnvelopeControl ctrl+phonemeControl cs ctrl =+ Zip.Cons+ (Gate.chunk (PC.longFromShortTime cs) Nothing)+ (Zip.Cons+ (Zip.Cons+ (EventListBT.singleton (DN.time 0.5) cs)+ (EventListBT.singleton (DN.time 0.02) cs))+ (ctrl cs))++speech :: IO ()+speech = do+ string <- Instr.softStringShapeFM+ unpack <- makeUnpackStereoStrict+ when False $+ writeTest (unpack <<< string sampleRate 0 440) $+ replicate 100 $ stringControl 512++ phoneme <- Speech.phonemeMask+ masks <- Speech.loadMasks Speech.maskNamesGrouped+ writeTest+ (unpack <<< phoneme masks sampleRate 0 (VoiceMsg.toPitch 64) <<<+ Zip.arrowSecond (Zip.arrowSecond (string sampleRate 0 440))) $+ replicate 100 $ phonemeControl 512 stringControl
alsa/Synthesizer/LLVM/Server/Packed/Run.hs view
@@ -26,7 +26,7 @@ import qualified Synthesizer.LLVM.Storable.Signal as SigStL import qualified Synthesizer.LLVM.Wave as WaveL import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*), )-import Synthesizer.LLVM.Parameterized.Signal (($#), )+import Synthesizer.LLVM.Parameter (($#), ) import qualified Synthesizer.Storable.Signal as SigSt import qualified Data.StorableVector.Lazy as SVL@@ -43,7 +43,7 @@ import Synthesizer.ApplicativeUtility (liftA4, liftA5, liftA6, ) import Control.Arrow ((<<<), (^<<), arr, )-import Control.Applicative (pure, {- liftA, liftA2, -} liftA3, (<*>), )+import Control.Applicative (pure, liftA2, liftA3, (<*>), ) import Control.Monad.Trans.State (evalState, ) import Control.Exception (bracket, )@@ -230,11 +230,17 @@ ben0 <- Instr.bellNoiseStereoFM flt0 <- Instr.filterSawStereoFM brs0 <- Instr.brass- tmt0 <- Instr.makeSampledSounds smpDir Sample.tomatensalat- hal0 <- Instr.makeSampledSounds smpDir Sample.hal- grp0 <- Instr.makeSampledSounds smpDir Sample.graphentheorie + syllables <-+ liftA2 map Instr.sampledSound $+ fmap concat $+ mapM (Sample.loadRanges smpDir) $+ Sample.tomatensalat :+ Sample.hal :+ Sample.graphentheorie :+ [] + arrange <- SigStL.makeArranger amp <- CausalP.runStorableChunky@@ -424,9 +430,7 @@ (map (\sound fm -> sound fm $ sr) $ [tnc, fnd, pngFM, flt, bel, ben, sqr, brs, ssh, fms, css, asn, atr, asq, asw, wnp] ++- map (.freqMod) tmt0 ++- map (.freqMod) hal0 ++- map (.freqMod) grp0 +++ map (.freqMod) syllables ++ [str, wnd, png, rfm, tin, tnb]) @@ -455,7 +459,7 @@ -- CausalPS.amplifyStereo 0.1 <<< CausalPS.pack (CausalP.stereoFromMonoControlled- (UniFilter.lowpass ^<< UniFilterL.causalP) $<+ (UniFilter.lowpass ^<< UniFilterL.causal) $< (SigP.interpolateConstant $# (fromIntegral vectorSize :: Real)) (piecewiseConstant (arr id))) <<<
alsa/Synthesizer/LLVM/Server/Packed/Test.hs view
@@ -52,6 +52,8 @@ import qualified Algebra.Additive as Additive -} +import qualified Number.DimensionTerm as DN+ -- import NumericPrelude.Numeric (zero, round, (^?), ) import Prelude hiding (Real, round, break, ) @@ -255,7 +257,7 @@ Sample.body smp in SVP.take (chunkSizesFromLazyTime dur) $ osc Option.defaultChunkSize- (sampleRate, (body, (fm, freq * Sample.period smp))))+ (sampleRate, (body, (fm, freq * Sample.period pos)))) (SigP.runChunky (let smp = signal fst fm = Instr.modulation snd@@ -285,7 +287,7 @@ let (sustainFM, releaseFM) = SVP.splitAt (chunkSizesFromLazyTime dur) $ (SigSt.repeat Option.defaultChunkSize- (Serial.fromList [freq*Sample.period smp/sampleRatePlain])+ (Serial.fromList [freq*Sample.period pos/sampleRatePlain]) :: SigSt.T Vector) pos = Sample.positions smp amp = 2 * amplitudeFromVelocity vel@@ -328,7 +330,8 @@ SVP.splitAt (chunkSizesFromLazyTime dur) $ (freqMod (chunkSizesFromLazyTime (PC.duration fm))- (sampleRate, (fm, freq*Sample.period smp)) :: SigSt.T Vector)+ (sampleRate, (fm, freq*Sample.period pos)) :: SigSt.T Vector)+ pos = Sample.positions smp in SigSt.map (\x -> Stereo.cons x x) (sustainFM `SigSt.append` releaseFM))@@ -353,7 +356,7 @@ SVP.splitAt (chunkSizesFromLazyTime dur) $ (freqMod (chunkSizesFromLazyTime (PC.duration fm))- (sampleRate, (fm, freq*Sample.period smp)) :: SigSt.T Vector)+ (sampleRate, (fm, freq*Sample.period pos)) :: SigSt.T Vector) pos = Sample.positions smp amp = 2 * amplitudeFromVelocity vel (attack, sustain, release) = Sample.parts smp@@ -381,8 +384,9 @@ let (sustainFM, releaseFM) = SVP.splitAt (chunkSizesFromLazyTime dur) $ (SigSt.repeat Option.defaultChunkSize- (Serial.fromList [freq*Sample.period smp/sampleRatePlain])+ (Serial.fromList [freq*Sample.period pos/sampleRatePlain]) :: SigSt.T Vector)+ pos = Sample.positions smp in osc () sustainFM `SigSt.append` SigSt.map (\x -> Stereo.cons x x) releaseFM)@@ -398,7 +402,7 @@ (\osc smp _fm _vel freq dur -> case SVP.splitAt (chunkSizesFromLazyTime dur) $ (SigSt.repeat Option.defaultChunkSize- (Serial.fromList [freq*Sample.period smp/sampleRatePlain])+ (Serial.fromList [freq*Sample.period (Sample.positions smp) / sampleRatePlain]) :: SigSt.T Vector) of (sustainFM, releaseFM) -> osc () sustainFM@@ -417,8 +421,9 @@ let (sustainFM, releaseFM) = SVP.splitAt (chunkSizesFromLazyTime dur) $ (SigSt.repeat Option.defaultChunkSize- (Serial.fromList [freq*Sample.period smp/sampleRatePlain])+ (Serial.fromList [freq*Sample.period pos/sampleRatePlain]) :: SigSt.T Vector)+ pos = Sample.positions smp in SigSt.map (\x -> Stereo.cons x x) sustainFM `SigSt.append` SigSt.map (\x -> Stereo.cons x x) releaseFM)@@ -437,8 +442,9 @@ let (sustainFM, releaseFM) = SVP.splitAt (chunkSizesFromLazyTime dur) $ (SigSt.repeat Option.defaultChunkSize- (Serial.fromList [freq*Sample.period smp/sampleRatePlain])+ (Serial.fromList [freq*Sample.period pos/sampleRatePlain]) :: SigSt.T Vector)+ pos = Sample.positions smp in osc () (amplifySVL sustainFM `SigSt.append`@@ -456,8 +462,9 @@ let (sustainFM, releaseFM) = SVP.splitAt (chunkSizesFromLazyTime dur) $ (SigSt.repeat Option.defaultChunkSize- (Serial.fromList [freq*Sample.period smp/sampleRatePlain])+ (Serial.fromList [freq*Sample.period pos/sampleRatePlain]) :: SigSt.T Vector)+ pos = Sample.positions smp in osc () sustainFM `SigSt.append` osc () releaseFM)@@ -480,7 +487,7 @@ let (sustainFM, releaseFM) = SVP.splitAt (chunkSizesFromLazyTime dur) $ (SigSt.repeat Option.defaultChunkSize- (Serial.fromList [freq*Sample.period smp/sampleRatePlain])+ (Serial.fromList [freq*Sample.period pos/sampleRatePlain]) :: SigSt.T Vector) pos = Sample.positions smp amp = 2 * amplitudeFromVelocity vel@@ -495,16 +502,18 @@ (CausalP.runStorableChunky (arr (\x -> Stereo.cons x x))) -+makeSample :: Int -> Sample.T+makeSample size =+ Sample.Cons+ (SigSt.replicate Option.defaultChunkSize size 0)+ (DN.frequency 44100)+ (Sample.Positions 0 100000 50000 50000 100) sequenceSample :: IO () sequenceSample = do arrange <- SigStL.makeArranger sampler <- sampledSoundTest2- let sound =- sampler (Sample.Cons (SigSt.replicate Option.defaultChunkSize 100000 0)- (Sample.Positions 0 100000 50000 50000)- 100)+ let sound = sampler $ makeSample 100000 SVL.writeFile "test.f32" $ arrange vectorChunkSize $ evalState@@ -547,10 +556,7 @@ sequenceSample1 :: IO () sequenceSample1 = do sampler <- sampledSoundSmallSpaceLeak4a- let sound =- sampler (Sample.Cons (SigSt.replicate Option.defaultChunkSize 100000 0)- (Sample.Positions 0 100000 50000 50000)- 100)+ let sound = sampler $ makeSample 100000 SVL.writeFile "test.f32" $ sound (let evs = EventListBT.cons (BM.Cons 0.01 0.001) 1 evs@@ -594,10 +600,7 @@ sequenceSample2 = do arrange <- SigStL.makeArranger sampler <- sampledSoundTest2- let sound =- sampler (Sample.Cons (SigSt.replicate Option.defaultChunkSize 100000 0)- (Sample.Positions 0 100000 50000 50000)- 100)+ let sound = sampler $ makeSample 100000 SVL.writeFile "test.f32" $ arrange vectorChunkSize $ evalState@@ -617,10 +620,7 @@ sequenceSample3 = do arrange <- SigStL.makeArranger sampler <- sampledSoundTest2- let sound =- sampler (Sample.Cons (SigSt.replicate Option.defaultChunkSize 100000 0)- (Sample.Positions 0 100000 50000 50000)- 100)+ let sound = sampler $ makeSample 100000 SVL.writeFile "test.f32" $ arrange vectorChunkSize $ evalState@@ -635,10 +635,7 @@ arrange <- SigStL.makeArranger sampler <- Instr.sampledSound -- sampler <- sampledSoundTest2- let sound =- sampler (Sample.Cons (SigSt.replicate Option.defaultChunkSize 100000 0)- (Sample.Positions 0 100000 50000 50000)- 100)+ let sound = sampler $ makeSample 100000 SVL.writeFile "test.f32" $ arrange vectorChunkSize $ evalState
example/Synthesizer/LLVM/LAC2011.hs view
@@ -14,7 +14,9 @@ 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.Causal.ProcessValue as CausalV import qualified Synthesizer.LLVM.Causal.Process as Causal import qualified Synthesizer.LLVM.Simple.Signal as Gen import qualified Synthesizer.LLVM.Storable.Signal as SigStL@@ -36,7 +38,7 @@ import qualified Synthesizer.LLVM.Parameterized.SignalPacked as GenPS import qualified Synthesizer.LLVM.Parameterized.Signal as GenP import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*), ($*#), )-import Synthesizer.LLVM.Parameterized.Signal (($#), )+import Synthesizer.LLVM.Parameter (($#), ) import qualified Synthesizer.Plain.Filter.Recursive as FiltR import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1Core@@ -250,7 +252,7 @@ retard :: GenP.T p (Value Float) -> GenP.T p (Value Float) retard xs = CausalP.frequencyModulationLinear xs .- CausalP.mapSimple (A.fdiv (LLVM.valueOf 1)) $*+ CausalV.map Field.recip $* GenP.rampCore (1 / secondP 10) 1 playRetarded :: IO ()@@ -265,11 +267,8 @@ GenP.exponential2 (second 0.5) 0.7 * GenP.osciSimple Wave.triangle 0 (hertzP 440) -zerop :: Param.T p Float-zerop = pure zero- delayp :: Param.T p Int -> CausalP.T p (Value Float) (Value Float)-delayp = CausalP.delay zerop+delayp = CausalP.delayZero delay :: IO () delay =@@ -284,7 +283,7 @@ comb :: IO () comb = playMonoParam $- (CausalP.loop zerop+ (CausalP.loopZero (id &&& 0.7 * delayp (intSecond 0.5) <<< CausalP.mix) $* pingGen)@@ -294,7 +293,7 @@ Param.T p Float -> GenP.T p (Moog.Parameter D8 (Value Float)) lfoSine reduct =- CausalP.mapSimple (Moog.parameter d8 (valueOf (30::Float))) .+ Causal.map (Moog.parameter d8 (valueOf (30::Float))) . CausalP.mapExponential 2 (hertz 700) $* GenP.osciSimple Wave.sine 0 (reduct * hertz 0.1)
example/Synthesizer/LLVM/LNdW2011.hs view
@@ -52,7 +52,7 @@ import qualified Synthesizer.LLVM.Parameterized.SignalPacked as GenPS import qualified Synthesizer.LLVM.Parameterized.Signal as GenP import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*), ($*#), ($<#), )-import Synthesizer.LLVM.Parameterized.Signal (($#), )+import Synthesizer.LLVM.Parameter (($#), ) import qualified Synthesizer.Plain.Filter.Recursive as FiltR import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1Core@@ -259,7 +259,7 @@ CausalP.processIO (0.95 * (CausalPS.osciSimple Wave.approxSine4 $< 0) .- CausalP.mapSimple Serial.upsample)+ Causal.map Serial.upsample) playFromEvents 0.01 (vectorBlockSize/sampleRate) (arr SigStL.unpackStrict .@@ -388,23 +388,20 @@ that cannot be satisfied with @LLVM.Vector@s. -} moveAround2dLifted ::- (A.Transcendental v, A.PseudoModule v v,+ (A.Transcendental v, v ~ A.Scalar v, A.PseudoModule v, A.Real v, A.RationalConstant v) => Value.T v -> Value.T v -> (Value.T v, Value.T v) -> CausalP.T p (v, v) (v, v) moveAround2dLifted att sonicDelay ear =- CausalP.mapSimple- (uncurry (liftM2 (,)) .- mapPair (Value.decons, Value.decons) .- Spatial.moveAround att sonicDelay ear .- mapPair (Value.constantValue, Value.constantValue))+ Causal.map+ (uncurry $ Value.unlift2 $ curry $ Spatial.moveAround att sonicDelay ear) moveAround2d :: (A.Algebraic v, A.RationalConstant v) => Value.T v -> Value.T v -> (Value.T v, Value.T v) -> CausalP.T p (v, v) (v, v) moveAround2d att sonicDelay ear =- CausalP.mapSimple $ Value.flattenFunction $+ Causal.map $ Value.flattenFunction $ (\dist -> (sonicDelay*dist, 1/(att+dist)^2)) . euclideanNorm2d . subtract ear @@ -419,7 +416,7 @@ (a -> b) -> CausalP.T p (Value.Registers a) (Value.Registers b) mapFunc f =- CausalP.mapSimple (Value.flattenFunction f)+ Causal.map (Value.flattenFunction f) flyChannel :: (Value.T (Value Float), Value.T (Value Float)) ->@@ -443,10 +440,10 @@ fly :: IO () fly = do let slow =- Filt1.lowpassCausalP $<#+ Filt1.lowpassCausal $<# Filt1Core.parameter (1/sampleRate::Float) let fast =- Filt1.lowpassCausalP $<#+ Filt1.lowpassCausal $<# Filt1Core.parameter (30/sampleRate::Float) proc <- CausalP.processIOCore@@ -508,10 +505,10 @@ flyPacked :: IO () flyPacked = do let slow =- Filt1.lowpassCausalPackedP $<#+ Filt1.lowpassCausalPacked $<# Filt1Core.parameter (1/sampleRate::Float) let fast =- Filt1.lowpassCausalPackedP $<#+ Filt1.lowpassCausalPacked $<# Filt1Core.parameter (30/sampleRate::Float) proc <- CausalP.processIOCore@@ -535,7 +532,7 @@ >>> CausalP.envelopeStereo >>>- CausalP.mapSimple StereoInt.interleave)+ Causal.map StereoInt.interleave) POut.storableVector playFromEvents 0.01 (vectorBlockSize/sampleRate) (arr SigStL.unpackStereoStrict
example/Synthesizer/LLVM/Test.hs view
@@ -2,7 +2,7 @@ module Main where import Synthesizer.LLVM.LAC2011 ()-import qualified Synthesizer.LLVM.LNdW2011 as LNdW2011+import Synthesizer.LLVM.LNdW2011 () import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked as BandPass import qualified Synthesizer.LLVM.Filter.Allpass as Allpass@@ -13,19 +13,29 @@ 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.Storable.Signal as SigStL-import qualified Synthesizer.LLVM.Frame as Frame import qualified Synthesizer.LLVM.Wave as Wave-import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import qualified Synthesizer.LLVM.Parameter as Param +import qualified Synthesizer.LLVM.Server.SampledSound as Sample++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 LLVM.Core (Value, value, valueOf, Vector, constVector, constOf, )@@ -36,20 +46,30 @@ import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS import qualified Synthesizer.LLVM.Parameterized.Signal as SigP-import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*), ($*#), )-import Synthesizer.LLVM.Parameterized.Signal (($#), )+import Synthesizer.LLVM.CausalParameterized.Process (($*#), )+import Synthesizer.LLVM.CausalParameterized.Functional (($&), (&|&), )+import Synthesizer.LLVM.Simple.Value ((%>), )+import Synthesizer.LLVM.Parameter (($#), ) +import qualified Synthesizer.CausalIO.Process as PIO+import qualified Synthesizer.Zip as Zip+import qualified Synthesizer.State.Control as CtrlS+import qualified Synthesizer.State.Signal as SigS+import Synthesizer.Causal.Class (($<), ($*), )+ 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.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@@ -61,18 +81,21 @@ import qualified Sound.Sox.Play as SoxPlay -- import qualified Synthesizer.ALSA.Storable.Play as Play -import qualified Synthesizer.LLVM.Frame.Stereo as Stereo-import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt-+import qualified Data.NonEmpty as NonEmpty+import Data.NonEmpty ((!:), )+import Data.Traversable (sequenceA, ) import Data.Word (Word32, ) -- import qualified Data.Function.HT as F import Data.List (genericLength, )+import System.FilePath ((</>), ) 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 @@ -267,10 +290,9 @@ SV.writeFile "speedtest-scalar.f32" $ asMono $ (\xs -> SigP.render xs 10000000 ()) $- (Filt1.lowpassCausalP+ (Filt1.lowpassCausal $< (fmap Filt1Core.Parameter $- SigP.mapSimple (A.sub (valueOf 1))- (SigP.exponential2 50000 $# (1::Float)))+ 1 - (SigP.exponential2 50000 $# (1::Float))) $* SigP.osciSimple Wave.triangle 0 (frequency 0.01)) pingSmoothPacked :: IO ()@@ -278,11 +300,10 @@ SV.writeFile "speedtest-vector.f32" $ asMonoPacked $ (\xs -> SigP.render xs (div 10000000 4) ()) $- (Filt1.lowpassCausalPackedP+ (Filt1.lowpassCausalPacked $< (fmap Filt1Core.Parameter $- SigP.mapSimple (A.sub (valueOf 1))- (SigP.exponential2 (50000/4) $# (1::Float)))- $* SigPS.osciSimple Wave.triangle 0 0.01)+ 1 - (SigP.exponential2 (50000/4) $# (1::Float)))+ $* SigPS.osciSimple Wave.triangle 0 (frequency 0.01)) stereoOsciSaw :: Float -> Sig.T (Stereo.T (Value Float)) stereoOsciSaw freq =@@ -370,9 +391,9 @@ foldl1 (Sig.zipWith Frame.mixStereoV) $ -}- foldl1 Sig.mix $- map (\f -> stereoOsciSawPacked2 (base*f)) $- 0.25 : 1.00 : 1.25 : 1.50 : []+ NonEmpty.foldBalanced Sig.mix $+ fmap (\f -> stereoOsciSawPacked2 (base*f)) $+ 0.25 !: 1.00 : 1.25 : 1.50 : [] lazyChord :: IO () lazyChord =@@ -435,7 +456,7 @@ SVL.take (div 10000000 16) $ asMonoPacked16 $ flip (SigP.renderChunky (SVL.chunkSize 10000)) () $- (Filt2.causalPackedP+ (Filt2.causalPacked $< (SigP.constant $# Filt2Core.Parameter (1::Float) 0 0 0 0.99) $* (@@ -489,7 +510,7 @@ SVL.take (div 10000000 4) $ asMonoPacked $ flip (SigP.renderChunky (SVL.chunkSize 10000)) () $- (CausalPS.amplify 0.2 . Filt2.causalPackedP+ (CausalPS.amplify 0.2 . Filt2.causalPacked $< (SigP.mapSimple (const $ Memory.load =<< LLVM.alloca) $ (SigP.constant $# (0::Float))) $* SigPS.noise 0 0.3)@@ -500,7 +521,7 @@ SVL.take 10000000 $ asMono $ flip (SigP.renderChunky (SVL.chunkSize 10000)) () $- (0.2 * Filt2.causalP+ (0.2 * Filt2.causal $< (SigP.mapSimple (const $ (Memory.load =<< LLVM.alloca :: LLVM.CodeGenFunction r (Filt2.Parameter (Value Float)))) $@@ -556,15 +577,15 @@ 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))+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 ()@@ -581,13 +602,13 @@ playFilterSweepMusicCausal :: IO () playFilterSweepMusicCausal = do- 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 ()+ 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@@ -599,6 +620,254 @@ =<< 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@@ -820,7 +1089,7 @@ playMonoVector $ CausalP.applyStorableChunky (CausalP.amplify id <<<- CausalP.comb 0.5 7000)+ CausalP.comb (0.5 :: Param.T p Float) 7000) (0.2::Float) sig return () @@ -834,18 +1103,31 @@ (0.3::Float) sig return () +vibesReverbEfficient :: IO ()+vibesReverbEfficient = do+ sig <- vibesCycleVector =<< makeVibes+ playMonoVector $+ CausalP.applyStorableChunky+ (CausalP.amplify id <<<+ (CausalP.reverbEfficient $# mkStdGen 142 $# 16 $# (0.9,0.97) $# (400,1000)))+ (0.3::Float) sig+ return ()+ vibesReverbStereo :: IO () vibesReverbStereo = do sig <- vibesCycleVector =<< makeVibes- playStereoVector $+ void $ playStereoVector $ CausalP.applyStorableChunky- (CausalP.amplifyStereo id <<<- CausalP.stereoFromChannels- (CausalP.reverb (mkStdGen 142) 16 (0.9,0.97) (400,1000))- (CausalP.reverb (mkStdGen 857) 16 (0.9,0.97) (400,1000)) <<<- CausalP.mapSimple Frame.stereoFromMono)+ (CausalP.stereoFromMonoParameterized+ (\amp seed ->+ CausalP.amplify amp+ <<<+ CausalP.reverbEfficient (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- return () @@ -864,27 +1146,26 @@ filterBass :: IO ()-filterBass = do+filterBass =+ void $ playStereoVector $ asStereo $ flip (SigP.renderChunky tonesChunkSize) () $ CausalP.apply- (BandPass.causalP+ (BandPass.causal <<< CausalP.feedSnd (liftA2 Stereo.cons (SigP.osciSimple Wave.saw 0 (frequency 0.001499)) (SigP.osciSimple Wave.saw 0 (frequency 0.001501))) <<<- CausalP.mapSimple (BandPass.parameter (valueOf (100::Float)))) $+ Causal.map (BandPass.parameter (valueOf (100::Float)))) $ SigP.piecewiseConstant $ return $ EventListBT.fromPairList $ zip- (map (((0.03::Float)*) . (2**) . (/12) . fromInteger) $- randomRs (0,12) (mkStdGen 998))- (repeat (10000::NonNeg.Int))-- return ()+ (map (((0.01::Float)*) . (2**) . (/12) . fromInteger) $+ randomRs (0,24) (mkStdGen 998))+ (repeat (6300::NonNeg.Int)) {- |@@ -930,8 +1211,7 @@ SVL.Vector (Stereo.T Float) mixVectorStereo = CausalP.applyStorableChunky- (CausalP.mix $<- SigP.fromStorableVectorLazy id)+ (CausalP.mix $< SigP.fromStorableVectorLazy id) mixVectorStereoIO :: IO (SVL.Vector (Stereo.T Float) ->@@ -939,8 +1219,7 @@ SVL.Vector (Stereo.T Float)) mixVectorStereoIO = CausalP.runStorableChunky- (CausalP.mix $<- SigP.fromStorableVectorLazy id)+ (CausalP.mix $< SigP.fromStorableVectorLazy id) {- slightly slower than mixVectorParam@@ -988,34 +1267,64 @@ stereoOsciSawP :: SigP.T Float (Stereo.T (Value Float)) stereoOsciSawP =- let freq = id- n = 5- volume = pure $ recip $ sqrt $ fromIntegral n :: Param.T p Float+ 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 =- randomRs (0,1) $ mkStdGen 54- tones =- zipWith- (\phase detune ->- (SigP.osciSaw $# phase) (fmap (detune*) freq))- phases detunes- (tonesLeft,tonesRight) = splitAt n tones- in SigP.amplifyStereo volume $- liftA2 Stereo.cons- (foldl1 SigP.mix tonesLeft)- (foldl1 SigP.mix tonesRight)+ 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 :: [Float] -> SVL.Vector (Stereo.T Float)+stereoOsciSawChord :: NonEmpty.T [] Float -> SVL.Vector (Stereo.T Float) stereoOsciSawChord =- foldl1 mixVectorStereo . map stereoOsciSawVector+ NonEmpty.foldBalanced mixVectorStereo . fmap stereoOsciSawVector -stereoOsciSawPad :: Int -> [Float] -> SVL.Vector (Stereo.T Float)+stereoOsciSawPad :: Int -> NonEmpty.T [] Float -> SVL.Vector (Stereo.T Float) stereoOsciSawPad dur pitches = let attack = 20000 in CausalP.applyStorableChunky@@ -1034,27 +1343,27 @@ iterate ((2 ** recip 12) *) (55/44100) -chordSequence :: [(Int, [Float])]+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 : 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]) :+ (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 : []) : [] @@ -1104,7 +1413,8 @@ filterMusic :: IO () filterMusic = do arrange <- SigStL.makeArranger- playStereoVector $+ pad <- stereoOsciSawPadIO+ void $ playStereoVector $ CausalP.applyStorableChunky (CausalP.amplifyStereo id <<< moogSweepControlRateCausal) (0.05::Float) $@@ -1112,9 +1422,8 @@ EventListTM.switchTimeR const $ EventListMT.consTime 0 $ EventListBT.fromPairList $- map (\(d,ps) -> withDur stereoOsciSawPad d ps)+ map (\(d,ps) -> withDur pad d ps) chordSequence- return () @@ -1134,13 +1443,14 @@ (CausalP.runStorableChunky (CausalP.envelopeStereo $< fadeEnvelope)) -stereoOsciSawChordIO :: IO ([Float] -> SVL.Vector (Stereo.T Float))+stereoOsciSawChordIO :: IO (NonEmpty.T [] Float -> SVL.Vector (Stereo.T Float)) stereoOsciSawChordIO = do sawv <- stereoOsciSawVectorIO mix <- mixVectorStereoIO- return (foldl1 mix . map sawv)+ return (NonEmpty.foldBalanced mix . fmap sawv) -stereoOsciSawPadIO :: IO (Int -> [Float] -> SVL.Vector (Stereo.T Float))+stereoOsciSawPadIO ::+ IO (Int -> NonEmpty.T [] Float -> SVL.Vector (Stereo.T Float)) stereoOsciSawPadIO = do chrd <- stereoOsciSawChordIO envelope <- applyFadeEnvelopeIO@@ -1177,7 +1487,8 @@ EventListTM.switchTimeR const $ EventListMT.consTime 0 $ EventListBT.fromPairList $- map (uncurry (withDur (\d ps -> map (\p -> env d (osci p)) ps))) $+ map (uncurry (withDur (\d ps ->+ map (\p -> env d (osci p)) $ NonEmpty.flatten ps))) $ chordSequence return () @@ -1187,25 +1498,39 @@ SVL.writeFile "speedtest.f32" $ asMono $ flip (SigP.renderChunky tonesChunkSize) (0, 10000) $- CausalP.apply- ((CausalP.delay $# (0::Float)) fst- <<< CausalP.take snd) $- SigP.osciSaw 0 (frequency 0.01)+ (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.apply- (CausalP.take snd- <<<- liftA2 Stereo.cons- id ((CausalP.delay $# (0::Float)) fst)) $- SigP.osciSaw 0 (frequency 0.01)+ (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.NaturalT n) => n ->@@ -1220,19 +1545,15 @@ SigP.T Float (Value Float) allpassPhaserCausal = let order = TypeNum.d16- in CausalP.apply $- 0.5 *- Allpass.phaserP <<<- CausalP.feedFst (allpassControl order)+ in CausalP.apply+ (0.5 * Allpass.phaser $< allpassControl order) allpassPhaserPipeline = let order = TypeNum.d16 in -- (F.nest (TypeNum.fromIntegerT order) SigP.tail .) $- (SigP.drop (return $ TypeNum.fromIntegerT order) .) $- CausalP.apply $- 0.5 *- Allpass.phaserPipelineP <<<- CausalP.feedFst (allpassControl order)+ SigP.drop (return $ TypeNum.fromIntegerT order) .+ CausalP.apply+ (0.5 * Allpass.phaserPipeline $< allpassControl order) allpassPhaser :: IO () allpassPhaser =@@ -1335,9 +1656,9 @@ CausalP.apply (0.3 * (UniFilter.lowpass ^<< CtrlP.process)) $ SigP.zip ((CausalP.quantizeLift $# (128::Float))- (CausalP.mapSimple (UniFilter.parameter (valueOf 100)) <<<--- (CausalP.mapSimple (Moog.parameter TypeNum.d8 (valueOf 100)) <<<- CausalP.mapSimple (\x -> 0.01 * exp (2 * return x)))+ (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) @@ -1371,12 +1692,243 @@ (let osci = CausalP.osciSimple Wave.approxSine2 in Func.compile (fmap (uncurry Stereo.cons) $- osci *** osci Func.$&+ 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 $ SigP.amplify (pure 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 ("speech" </> 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))++ main :: IO () main = do LLVM.initializeNativeTarget- arrowIndependent+ convolutionPacked
jack/Synthesizer/LLVM/Server/JACK.hs view
@@ -11,6 +11,7 @@ import qualified Synthesizer.MIDI.CausalIO.Process as MIO import qualified Synthesizer.CausalIO.Process as PIO +import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Storable.Signal as SigStL @@ -42,7 +43,10 @@ import qualified Control.Monad.Trans.Class as MT import Control.Arrow (Arrow, (<<<), (^<<), arr, )+import Control.Category (id, )+import Control.Applicative (pure, ) +import qualified System.Random as Random {- import qualified Numeric.NonNegative.Class as NonNeg import qualified Numeric.NonNegative.Chunky as NonNegChunky@@ -211,16 +215,39 @@ [0 .. 3]) -voder :: IO ()-voder = do+voderBand :: IO ()+voderBand = do opt <- Option.get proc <-- Arrange.voder+ Arrange.voderBand (arr unconsStereo) (Option.sampleDirectory opt) playStereoFromEvents opt $ \ sampleRate -> proc (Option.channel opt) (VoiceMsg.toProgram 5) sampleRate+++voderMaskSeparated :: IO ()+voderMaskSeparated = do+ opt <- Option.get+ let postProcessing =+ if True+ then+ let reverb seed =+ CausalP.reverbEfficient+ (pure $ Random.mkStdGen seed) 16 (pure (0.92,0.98))+ (fmap (\(SampleRate rate) -> (round (rate/200), round (rate/40))) id)+ in CausalPS.pack (Stereo.arrowFromChannels (reverb 42) (reverb 23))+ else id+ proc <-+ Arrange.voderMaskSeparated+ (arr unconsStereo <<< postProcessing)+ (Option.sampleDirectory opt)++ playStereoFromEvents opt $ \ sampleRate ->+ proc+ (Option.channel opt) (Option.extraChannel opt)+ (VoiceMsg.toProgram 4) sampleRate main :: IO ()
render/Synthesizer/LLVM/Server/Render.hs view
@@ -6,29 +6,17 @@ (vectorSize, vectorRate, ) import qualified Synthesizer.LLVM.Server.Option as Option+import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import Synthesizer.LLVM.Server.Common -import qualified Synthesizer.MIDI.CausalIO.Process as MIO import qualified Synthesizer.CausalIO.Process as PIO import qualified Synthesizer.PiecewiseConstant.Signal as PC -import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.Storable.Signal as SigStL--import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt-import qualified Synthesizer.LLVM.Frame.Stereo as Stereo- import qualified Data.StorableVector.Lazy as SVL-import qualified Data.StorableVector as SV import qualified Data.EventList.Relative.TimeBody as EventList import qualified Data.EventList.Relative.TimeMixed as EventListTM -import qualified Synthesizer.Zip as Zip--import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg-import qualified Sound.MIDI.Message.Channel as ChannelMsg- import qualified Sound.MIDI.File as MidiFile import qualified Sound.MIDI.File.Event as FileEvent import qualified Sound.MIDI.File.Load as Load@@ -36,7 +24,6 @@ import qualified Sound.Sox.Write as SoxWrite import qualified Sound.Sox.Play as SoxPlay -import Control.Arrow (Arrow, (<<<), arr, ) import Control.Applicative ((<*>), ) import Data.Monoid (mempty, )@@ -59,28 +46,6 @@ NonNegW.fromNumberMsg "strictTimeFromNFrames" $ fromIntegral n -keyboardMultiChannel ::- Option.T ->- IO (SampleRate Real ->- PIO.T (MIO.Events ChannelMsg.T) (SV.Vector (Stereo.T Real)))-keyboardMultiChannel opt = do- proc <-- Arrange.keyboardDetuneFMCore- (CausalP.mapSimple StereoInt.interleave)- (Option.sampleDirectory opt)- mix <- CausalP.processIO CausalP.mix-- return $ \ sampleRate ->- arr SigStL.unpackStereoStrict- <<<- foldl1- (\x y -> mix () <<< Zip.arrowFanout x y)- (map- (\chan ->- proc (ChannelMsg.toChannel chan) (VoiceMsg.toProgram 0)- sampleRate)- [0 .. 3])- {- This is the duration of rendering after the last MIDI event. @@ -98,7 +63,10 @@ Option.T -> IO (MidiFile.T -> SVL.Vector (Stereo.T Real)) render opt = do- proc <- keyboardMultiChannel opt+ proc <-+ case 0::Int of+ 0 -> Arrange.keyboardMultiChannel $ Option.sampleDirectory opt+ _ -> Arrange.voderMaskMulti $ Option.sampleDirectory opt run <- PIO.runCont $ proc $ fmap fromIntegral $ Option.sampleRate opt return $ SVL.fromChunks .
src/Synthesizer/LLVM/Causal/Process.hs view
@@ -2,40 +2,89 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ForeignFunctionInterface #-}-module Synthesizer.LLVM.Causal.Process where+module Synthesizer.LLVM.Causal.Process (+ C(simple, loopConst, replicateControlled),+ T,+ amplify,+ amplifyStereo,+ apply,+ applyFst,+ applySnd,+ compose,+ envelope,+ envelopeStereo,+ feedFst,+ feedSnd,+ fromModifier,+ fromSignal,+ toSignal,+ loopZero,+ feedbackControlledZero,+ map,+ mapAccum,+ zipWith,+ mix,+ pipeline,+ stereoFromVector,+ vectorize,+ replaceChannel,+ arrayElement,+ element,+ applyStorable,+ applyStorableChunky,+ runStorableChunky,+ ) where import qualified Synthesizer.LLVM.Simple.Signal as Sig+import qualified Synthesizer.LLVM.Simple.Value as Value+import qualified Synthesizer.LLVM.Causal.ProcessPrivate as Causal+import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Frame as Frame import qualified Synthesizer.LLVM.Execution as Exec -import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.MaybeContinuation as Maybe-import qualified LLVM.Extra.ForeignPtr as ForeignPtr-import qualified LLVM.Extra.Memory as Memory--- import qualified LLVM.Extra.Control as U-import LLVM.Extra.Class (MakeValueTuple, ValueTuple, )+import qualified Synthesizer.Plain.Modifier as Modifier+import qualified Synthesizer.Causal.Class as CausalClass import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector as SV import qualified Data.StorableVector.Base as SVB -import qualified Synthesizer.LLVM.Frame.Stereo as Stereo+import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Vector as Vector+import qualified LLVM.Extra.MaybeContinuation as MaybeCont+import qualified LLVM.Extra.Maybe as Maybe+import qualified LLVM.Extra.ForeignPtr as ForeignPtr+import qualified LLVM.Extra.Memory as Memory+import LLVM.Extra.Class (Undefined, MakeValueTuple, ValueTuple, ) -import LLVM.Core as LLVM-import LLVM.Util.Loop (Phi, )+import qualified LLVM.Core as LLVM import LLVM.ExecutionEngine (simpleFunction, )+import LLVM.Util.Loop (Phi, )+import LLVM.Core+ (CodeGenFunction, ret, Value, valueOf,+ IsConst, IsFirstClass, IsArithmetic, IsPrimitive,+ Linkage(ExternalLinkage), createNamedFunction) +import qualified Types.Data.Num as TypeNum+import qualified Types.Data.Bool as TypeBool+import Types.Data.Num (D2, )+import Types.Data.Ord ((:<:), )+ import qualified Control.Arrow as Arr import qualified Control.Category as Cat-import Control.Arrow ((<<<), (^<<), (&&&), )+import Control.Monad.Trans.State (runState, )+import Control.Arrow ((<<<), (^<<), (>>>), (&&&), ) import Control.Monad (liftM2, liftM3, ) import Control.Applicative (Applicative, pure, (<*>), ) +import qualified Data.List as List import Data.Word (Word32, ) import Foreign.Storable (Storable, ) import Foreign.ForeignPtr (withForeignPtr, touchForeignPtr, )-import Foreign.Ptr (FunPtr, )+import Foreign.Ptr (FunPtr, Ptr, ) import Control.Exception (bracket, ) import qualified System.Unsafe as Unsafe @@ -45,7 +94,7 @@ import qualified Algebra.Additive as Additive import NumericPrelude.Numeric-import NumericPrelude.Base hiding (and, map, zip, zipWith, )+import NumericPrelude.Base hiding (and, map, zip, zipWith, init, ) import qualified Prelude as P @@ -56,7 +105,7 @@ Cons (forall r c. (Phi c) => ioContext ->- a -> state -> Maybe.T r c (b, state))+ a -> state -> MaybeCont.T r c (b, state)) -- compute next value (forall r. ioContext ->@@ -67,20 +116,52 @@ (ioContext -> IO ()) -- finalization from IO monad -simple ::- (Memory.C state) =>- (forall r c.- (Phi c) =>- a -> state -> Maybe.T r c (b, state)) ->- (forall r. CodeGenFunction r state) ->- T a b-simple next start =- Cons- (const next)- (const start)- (return ())- (const $ return ()) +class CausalClass.C process => C process where+ simple ::+ (Memory.C state) =>+ (forall r c.+ (Phi c) =>+ a -> state -> MaybeCont.T r c (b, state)) ->+ (forall r. CodeGenFunction r state) ->+ process a b+ {- |+ Like 'Synthesizer.LLVM.CausalParameterized.loop'+ but uses zero as initial value+ and it does not need a zero as Haskell value.+ -}+ loopConst ::+ (Memory.C c) =>+ c -> process (a,c) (b,c) -> process a b+ replicateControlled ::+ (Undefined x, Phi x) =>+ Int -> process (c,x) x -> process (c,x) x++instance CausalClass.C T where+ type SignalOf T = Sig.T+ type ProcessOf Sig.T = T+ toSignal = toSignal+ fromSignal = fromSignal++instance C T where+ simple next start =+ Cons+ (const next)+ (const start)+ (return ())+ (const $ return ())+ loopConst init (Cons next start create delete) =+ Cons+ (Causal.loopNext next)+ (fmap ((,) init) . start)+ create+ delete+ {-+ Could be implemented with a machine code loop like in CausalParameterized.+ But to this end we would need a 'stop' function.+ -}+ replicateControlled = CausalClass.replicateControlled+ toSignal :: T () a -> Sig.T a toSignal (Cons next start createIOContext deleteIOContext) = Sig.Cons (\ioContext -> next ioContext ())@@ -95,47 +176,61 @@ map ::+ (C process) => (forall r. a -> CodeGenFunction r b) ->- T a b+ process a b map f = mapAccum (\a s -> fmap (flip (,) s) $ f a) (return ()) mapAccum ::- (Memory.C state) =>+ (C process, Memory.C state) => (forall r. a -> state -> CodeGenFunction r (b, state)) -> (forall r. CodeGenFunction r state) ->- T a b+ process a b mapAccum next =- simple (\a s -> Maybe.lift $ next a s)+ simple (\a s -> MaybeCont.lift $ next a s) zipWith ::+ (C process) => (forall r. a -> b -> CodeGenFunction r c) ->- T (a,b) c+ process (a,b) c zipWith f = map (uncurry f) -apply ::- T a b -> Sig.T a -> Sig.T b-apply proc sig =- toSignal (proc <<< fromSignal sig)+fromModifier ::+ (C process) =>+ (Value.Flatten ah, Value.Registers ah ~ al,+ Value.Flatten bh, Value.Registers bh ~ bl,+ Value.Flatten ch, Value.Registers ch ~ cl,+ Value.Flatten sh, Value.Registers sh ~ sl,+ Memory.C sl) =>+ Modifier.Simple sh ch ah bh -> process (cl,al) bl+fromModifier (Modifier.Simple initial step) =+ mapAccum+ (\(c,a) s ->+ Value.flatten $+ runState+ (step (Value.unfold c) (Value.unfold a))+ (Value.unfold s))+ (Value.flatten initial) ++apply :: T a b -> Sig.T a -> Sig.T b+apply = CausalClass.apply+ feedFst :: Sig.T a -> T b (a,b)-feedFst sig =- fromSignal sig &&& Cat.id+feedFst = CausalClass.feedFst feedSnd :: Sig.T a -> T b (b,a)-feedSnd sig =- Cat.id &&& fromSignal sig+feedSnd = CausalClass.feedSnd applyFst :: T (a,b) c -> Sig.T a -> T b c-applyFst proc sig =- proc <<< feedFst sig+applyFst = CausalClass.applyFst applySnd :: T (a,b) c -> Sig.T b -> T a c-applySnd proc sig =- proc <<< feedSnd sig+applySnd = CausalClass.applySnd compose :: T a b -> T b c -> T a c compose@@ -216,35 +311,136 @@ mix ::- (A.Additive a) =>- T (a, a) a+ (C process, A.Additive a) =>+ process (a, a) a mix = zipWith Frame.mix envelope ::- (A.PseudoRing a) =>- T (a, a) a+ (C process, A.PseudoRing a) =>+ process (a, a) a envelope = zipWith Frame.amplifyMono envelopeStereo ::- (A.PseudoRing a) =>- T (a, Stereo.T a) (Stereo.T a)+ (C process, A.PseudoRing a) =>+ process (a, Stereo.T a) (Stereo.T a) envelopeStereo = zipWith Frame.amplifyStereo amplify ::- (IsArithmetic a, IsConst a) =>- a -> T (Value a) (Value a)+ (C process, IsArithmetic a, IsConst a) =>+ a -> process (Value a) (Value a) amplify x = map (Frame.amplifyMono (valueOf x)) amplifyStereo ::- (IsArithmetic a, IsConst a) =>- a -> T (Stereo.T (Value a)) (Stereo.T (Value a))+ (C process, IsArithmetic a, IsConst a) =>+ a -> process (Stereo.T (Value a)) (Stereo.T (Value a)) amplifyStereo x = map (Frame.amplifyStereo (valueOf x)) +loopZero ::+ (C process, A.Additive c, Memory.C c) =>+ process (a,c) (b,c) -> process a b+loopZero = loopConst A.zero++pipeline ::+ (C process,+ Vector.C v, a ~ Vector.Element v,+ Class.Zero v, Memory.C v) =>+ process v v -> process a a+pipeline vectorProcess =+ loopConst Class.zeroTuple $+ map (uncurry Vector.shiftUp)+ >>>+ Arr.second vectorProcess+++feedbackControlledZero ::+ (C process, A.Additive c, Memory.C c) =>+ process ((ctrl,a),c) b -> process (ctrl,b) c -> process (ctrl,a) b+feedbackControlledZero forth back =+ loopZero (Causal.feedbackControlledAux forth back)+++{-+In order to let this work we have to give the disable-mmx option somewhere,+but where?+-}+stereoFromVector ::+ (C process, IsPrimitive a, IsPrimitive b) =>+ process (Value (LLVM.Vector D2 a)) (Value (LLVM.Vector D2 b)) ->+ process (Stereo.T (Value a)) (Stereo.T (Value b))+stereoFromVector proc =+ map Frame.stereoFromVector <<<+ proc <<<+ map Frame.vectorFromStereo+++{-+insert and extract instructions will be in opposite order,+no matter whether we use foldr or foldl+and independent from the order of proc and channel in replaceChannel.+However, LLVM neglects the order anyway.+-}+vectorize ::+ (C process,+ Vector.C va, n ~ Vector.Size va, a ~ Vector.Element va,+ Vector.C vb, n ~ Vector.Size vb, b ~ Vector.Element vb) =>+ process a b -> process va vb+vectorize proc =+ withSize $ \n ->+ foldl+ (\acc i -> replaceChannel i proc acc)+ (Arr.arr (const $ Class.undefTuple)) $+ List.take (TypeNum.fromIntegerT n) [0 ..]++withSize ::+ (Vector.Size bv -> f bv) ->+ f bv+withSize f = f undefined++{- |+Given a vector process, replace the i-th output by output+that is generated by a scalar process from the i-th input.+-}+replaceChannel ::+ (C process,+ Vector.C va, n ~ Vector.Size va, a ~ Vector.Element va,+ Vector.C vb, n ~ Vector.Size vb, b ~ Vector.Element vb) =>+ Int -> process a b -> process va vb -> process va vb+replaceChannel i channel proc =+ let li = valueOf $ fromIntegral i+ in zipWith (Vector.insert li) <<<+ (channel <<< map (Vector.extract li)) &&&+ proc++{- |+Read the i-th element from each array.+-}+arrayElement ::+ (C process,+ LLVM.Array dim a ~ array,+ LLVM.GetValue array index, IsFirstClass a,+ LLVM.ValueType array index ~ a,+ TypeNum.NaturalT index, TypeNum.NaturalT dim,+ (index :<: dim) ~ TypeBool.True) =>+ index -> process (Value (LLVM.Array dim a)) (Value a)+arrayElement i =+ map (\array -> LLVM.extractvalue array i)++{- |+Read the i-th element from an aggregate type.+-}+element ::+ (C process, IsFirstClass a, LLVM.GetValue agg index,+ LLVM.ValueType agg index ~ a) =>+ index -> process (Value agg) (Value a)+element i =+ map (\array -> LLVM.extractvalue array i)++ applyStorable :: (Storable a, MakeValueTuple a, ValueTuple a ~ valueA, Memory.C valueA, Storable b, MakeValueTuple b, ValueTuple b ~ valueB, Memory.C valueB) =>@@ -258,11 +454,11 @@ simpleFunction $ createNamedFunction ExternalLinkage "fillprocessblock" $ \ size alPtr blPtr -> do s <- start ioContext- (pos,_) <- Maybe.arrayLoop2 size alPtr blPtr s $+ (pos,_) <- MaybeCont.arrayLoop2 size alPtr blPtr s $ \ aPtri bPtri s0 -> do- a <- Maybe.lift $ Memory.load aPtri+ a <- MaybeCont.lift $ Memory.load aPtri (b,s1) <- next ioContext a s0- Maybe.lift $ Memory.store b bPtri+ MaybeCont.lift $ Memory.store b bPtri return s1 ret (pos :: Value Word32) fmap (fromIntegral :: Word32 -> Int) $@@ -271,12 +467,6 @@ (Memory.castStorablePtr bPtr) -foreign import ccall safe "dynamic" derefStartPtr ::- Exec.Importer (IO (Ptr stateStruct))--foreign import ccall safe "dynamic" derefStopPtr ::- Exec.Importer (Ptr stateStruct -> IO ())- foreign import ccall safe "dynamic" derefChunkPtr :: Exec.Importer (Ptr stateStruct -> Word32 -> Ptr aStruct -> Ptr bStruct -> IO Word32)@@ -286,9 +476,10 @@ (Memory.C aValue, Memory.Struct aValue ~ aStruct, Memory.C bValue, Memory.Struct bValue ~ bStruct, Memory.C state, Memory.Struct state ~ stateStruct) =>- (forall r.+ (forall r z.+ (Phi z) => aValue -> state ->- Maybe.T r (Value Bool, (Value (Ptr bStruct), state)) (bValue, state)) ->+ MaybeCont.T r z (bValue, state)) -> (forall r. CodeGenFunction r state) -> IO (FunPtr (IO (Ptr stateStruct)),@@ -307,13 +498,13 @@ (createNamedFunction ExternalLinkage "fillprocess" $ \ sptr loopLen aPtr bPtr -> do sInit <- Memory.load sptr- (pos,sExit) <- Maybe.arrayLoop2 loopLen aPtr bPtr sInit $+ (pos,sExit) <- MaybeCont.arrayLoop2 loopLen aPtr bPtr sInit $ \ aPtri bPtri s0 -> do- a <- Maybe.lift $ Memory.load aPtri+ a <- MaybeCont.lift $ Memory.load aPtri (b,s1) <- next a s0- Maybe.lift $ Memory.store b bPtri+ MaybeCont.lift $ Memory.store b bPtri return s1- Memory.store sExit sptr+ Memory.store (Maybe.fromJust sExit) sptr ret (pos :: Value Word32))
+ src/Synthesizer/LLVM/Causal/ProcessPrivate.hs view
@@ -0,0 +1,20 @@+module Synthesizer.LLVM.Causal.ProcessPrivate where++import Control.Arrow (Arrow, arr, (>>>), (&&&), )+++loopNext ::+ (Monad m) =>+ (context -> (a,c) -> state -> m ((b,c), state)) ->+ context -> a -> (c, state) -> m (b, (c, state))+loopNext next ctx a0 (c0,s0) = do+ ((b1,c1), s1) <- next ctx (a0,c0) s0+ return (b1,(c1,s1))++feedbackControlledAux ::+ Arrow arrow =>+ arrow ((ctrl,a),c) b ->+ arrow (ctrl,b) c ->+ arrow ((ctrl,a),c) (b,c)+feedbackControlledAux forth back =+ arr (fst.fst) &&& forth >>> arr snd &&& back
+ src/Synthesizer/LLVM/Causal/ProcessValue.hs view
@@ -0,0 +1,44 @@+{- |+This module provides functions similar to+"Synthesizer.LLVM.Causal.Process"+but expects functions that operate on 'Value.T'.+This way you can use common arithmetic operators+instead of LLVM assembly functions.+-}+module Synthesizer.LLVM.Causal.ProcessValue (+ map, zipWith, mapAccum,+ ) where++import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Simple.Value as Value++import qualified LLVM.Extra.Memory as Memory++import Foreign.Storable.Tuple ()++import Prelude ()+++map ::+ (Causal.C process) =>+ (Value.T a -> Value.T b) ->+ process a b+map f =+ Causal.map (Value.unlift1 f)++zipWith ::+ (Causal.C process) =>+ (Value.T a -> Value.T b -> Value.T c) ->+ process (a,b) c+zipWith f =+ Causal.zipWith (Value.unlift2 f)++mapAccum ::+ (Causal.C process, Memory.C s) =>+ (Value.T a -> Value.T s -> (Value.T b, Value.T s)) ->+ Value.T s ->+ process a b+mapAccum next start =+ Causal.mapAccum+ (Value.unlift2 next)+ (Value.unlift0 start)
src/Synthesizer/LLVM/CausalParameterized/Controlled.hs view
@@ -34,8 +34,7 @@ import LLVM.Extra.Class (MakeValueTuple, ValueTuple, ) import qualified LLVM.Core as LLVM-import LLVM.Core- (Value, IsFloating, IsConst, IsSized, )+import LLVM.Core (Value, IsFloating, IsConst, IsSized, ) import qualified Synthesizer.LLVM.Frame.Stereo as Stereo @@ -44,12 +43,7 @@ import Foreign.Storable (Storable, ) --- import qualified Algebra.Field as Field--- import qualified Algebra.Module as Module-import qualified Algebra.Ring as Ring-import qualified Algebra.Additive as Additive - {- | A filter parameter type uniquely selects a filter function. However it does not uniquely determine the input and output type,@@ -65,7 +59,7 @@ (C parameter a b, Memory.C parameter, Memory.FirstClass r, IsSized r, IsSized (Memory.Stored r),- Ring.C r, IsFloating r, Storable r, IsConst r,+ IsFloating r, Storable r, SoV.IntegerConstant r, MakeValueTuple r, ValueTuple r ~ (Value r), LLVM.CmpRet r, LLVM.CmpResult r ~ Bool) => Param.T p r ->@@ -82,20 +76,20 @@ -} instance- (A.PseudoModule a v, A.IntegerConstant a,+ (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a, Memory.C a, Memory.C v) => C (Filt1.Parameter a) v (Filt1.Result v) where type Input (Filt1.Parameter a) (Filt1.Result v) = v type Output (Filt1.Parameter a) v = Filt1.Result v- process = Filt1.causalP+ process = Filt1.causal instance- (A.PseudoModule a v, A.RationalConstant a,+ (a ~ A.Scalar v, A.PseudoModule v, A.RationalConstant a, Memory.C a, Memory.C v) => C (Filt2.Parameter a) v v where type Input (Filt2.Parameter a) v = v type Output (Filt2.Parameter a) v = v- process = Filt2.causalP+ process = Filt2.causal instance (Vector.Arithmetic a, SoV.RationalConstant a,@@ -106,10 +100,10 @@ (Value a) (Value a) where type Input (Filt2P.Parameter a) (Value a) = Value a type Output (Filt2P.Parameter a) (Value a) = Value a- process = Filt2P.causalP+ process = Filt2P.causal instance- (SoV.PseudoModule a v, SoV.IntegerConstant a,+ (a ~ SoV.Scalar v, SoV.PseudoModule v, SoV.IntegerConstant a, Memory.FirstClass a, IsSized a, IsSized (Memory.Stored a), Memory.FirstClass v, IsSized v, IsSized (Memory.Stored v), TypeNum.NaturalT n,@@ -118,67 +112,50 @@ (Value v) (Value v) where type Input (Cascade.ParameterValue n a) (Value v) = Value v type Output (Cascade.ParameterValue n a) (Value v) = Value v- process = Cascade.causalP+ process = Cascade.causal instance- (A.PseudoModule a v, A.RationalConstant a,+ (a ~ A.Scalar v, A.PseudoModule v, A.RationalConstant a, Memory.C a, Memory.C v) => C (Allpass.Parameter a) v v where type Input (Allpass.Parameter a) v = v type Output (Allpass.Parameter a) v = v- process = Allpass.causalP+ process = Allpass.causal instance- (A.PseudoModule a v, A.RationalConstant a,+ (a ~ A.Scalar v, A.PseudoModule v, A.RationalConstant a, Memory.C a, Memory.C v, TypeNum.NaturalT n) => C (Allpass.CascadeParameter n a) v v where type Input (Allpass.CascadeParameter n a) v = v type Output (Allpass.CascadeParameter n a) v = v- process = Allpass.cascadeP+ process = Allpass.cascade instance- (SoV.PseudoModule a v, SoV.IntegerConstant a,- Additive.C v, IsConst v,- Memory.FirstClass a, IsSized a, IsSized (Memory.Stored a),- Memory.FirstClass v, IsSized v, IsSized (Memory.Stored v),- MakeValueTuple a, ValueTuple a ~ (Value a),- MakeValueTuple v, ValueTuple v ~ (Value v),- Storable v,- TypeNum.NaturalT n) =>- C (Moog.Parameter n (Value a))- (Value v) (Value v) where- type Input (Moog.Parameter n (Value a)) (Value v) = Value v- type Output (Moog.Parameter n (Value a)) (Value v) = Value v- process = Moog.causalP--{--instance- (A.PseudoModule a v, A.RationalConstant a,- Memory.C a, Memory.C v,- TypeNum.NaturalT n) =>+ (A.PseudoModule v, A.Scalar v ~ a, A.IntegerConstant a,+ Memory.C v, TypeNum.NaturalT n) => C (Moog.Parameter n a) v v where type Input (Moog.Parameter n a) v = v type Output (Moog.Parameter n a) v = v- process = Moog.causalP--}+ process = Moog.causal + instance- (A.PseudoModule a v, A.RationalConstant a,+ (a ~ A.Scalar v, A.PseudoModule v, A.RationalConstant a, Memory.C a, Memory.C v) => C (UniFilter.Parameter a) v (UniFilter.Result v) where type Input (UniFilter.Parameter a) (UniFilter.Result v) = v type Output (UniFilter.Parameter a) v = UniFilter.Result v- process = UniFilter.causalP+ process = UniFilter.causal instance (A.PseudoRing a, A.RationalConstant a, Memory.C a) => C (ComplexFilt.Parameter a) (Stereo.T a) (Stereo.T a) where type Input (ComplexFilt.Parameter a) (Stereo.T a) = Stereo.T a type Output (ComplexFilt.Parameter a) (Stereo.T a) = Stereo.T a- process = ComplexFilt.causalP+ process = ComplexFilt.causal instance (Vector.Arithmetic a, IsConst a,@@ -192,4 +169,4 @@ (Stereo.T (Value a)) (Stereo.T (Value a)) where type Input (ComplexFiltPack.Parameter a) (Stereo.T (Value a)) = Stereo.T (Value a) type Output (ComplexFiltPack.Parameter a) (Stereo.T (Value a)) = Stereo.T (Value a)- process = ComplexFiltPack.causalP+ process = ComplexFiltPack.causal
src/Synthesizer/LLVM/CausalParameterized/ControlledPacked.hs view
@@ -33,8 +33,7 @@ import qualified LLVM.Core as LLVM import LLVM.Util.Loop (Phi, )-import LLVM.Core- (Value, IsFloating, IsConst, IsSized, )+import LLVM.Core (Value, IsFloating, IsSized, ) import qualified Types.Data.Num as TypeNum import Types.Data.Num.Ops ((:*:), )@@ -44,9 +43,6 @@ import Control.Arrow ((<<<), arr, first, ) import qualified Algebra.Field as Field--- import qualified Algebra.Module as Module--- import qualified Algebra.Ring as Ring-import qualified Algebra.Additive as Additive import NumericPrelude.Numeric import NumericPrelude.Base@@ -65,29 +61,22 @@ processCtrlRate :: (C parameter av bv, Serial.Read av, n ~ Serial.Size av, a ~ Serial.Element av,- Serial.C bv, n ~ Serial.Size bv, b ~ Serial.Element bv,+ Serial.C bv, n ~ Serial.Size bv, b ~ Serial.Element bv, Memory.C parameter,- Field.C r, Storable r, IsFloating r,- Memory.FirstClass r, Memory.Stored r ~ rm, IsSized r, IsSized rm, IsConst r,+ Field.C r, Storable r, IsFloating r, SoV.IntegerConstant r,+ Memory.FirstClass r, Memory.Stored r ~ rm, IsSized r, IsSized rm, MakeValueTuple r, ValueTuple r ~ (Value r), LLVM.CmpRet r, LLVM.CmpResult r ~ Bool) => Param.T p r -> (Param.T p r -> SigP.T p parameter) -> CausalP.T p av bv-processCtrlRate reduct ctrlGen = withSize $ \n ->+processCtrlRate reduct ctrlGen = Serial.withSize $ \n -> CausalP.applyFst process (SigP.interpolateConstant- (fmap (/ fromInteger (TypeNum.fromIntegerT n)) reduct)+ (fmap (/ fromIntegral n) reduct) (ctrlGen reduct)) -withSize ::- (Serial.Read av, n ~ Serial.Size av,- Serial.Read bv, n ~ Serial.Size bv) =>- (n -> CausalP.T p av bv) ->- CausalP.T p av bv-withSize f = f undefined - {- Instances for the particular filters shall be defined here in order to avoid orphan instances.@@ -100,7 +89,7 @@ C (Filt1.Parameter a) v (Filt1.Result v) where type Input (Filt1.Parameter a) (Filt1.Result v) = v type Output (Filt1.Parameter a) v = Filt1.Result v- process = Filt1.causalPackedP+ process = Filt1.causalPacked instance (Serial.C v, Serial.Element v ~ a,@@ -109,10 +98,10 @@ C (Filt2.Parameter a) v v where type Input (Filt2.Parameter a) v = v type Output (Filt2.Parameter a) v = v- process = Filt2.causalPackedP+ process = Filt2.causalPacked instance- (A.PseudoModule (LLVM.Value a) v,+ (LLVM.Value a ~ A.Scalar v, A.PseudoModule v, Serial.C v, Serial.Element v ~ LLVM.Value a, SoV.IntegerConstant a, A.PseudoRing v, A.IntegerConstant v, Memory.C v,@@ -124,7 +113,7 @@ C (Cascade.ParameterValue n a) v v where type Input (Cascade.ParameterValue n a) v = v type Output (Cascade.ParameterValue n a) v = v- process = Cascade.causalPackedP+ process = Cascade.causalPacked instance@@ -134,7 +123,7 @@ C (Allpass.Parameter a) v v where type Input (Allpass.Parameter a) v = v type Output (Allpass.Parameter a) v = v- process = Allpass.causalPackedP+ process = Allpass.causalPacked instance (TypeNum.NaturalT n,@@ -144,30 +133,27 @@ C (Allpass.CascadeParameter n a) v v where type Input (Allpass.CascadeParameter n a) v = v type Output (Allpass.CascadeParameter n a) v = v- process = Allpass.cascadePackedP+ process = Allpass.cascadePacked instance- (SoV.PseudoModule a a, SoV.IntegerConstant a, Additive.C a,- Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am,- MakeValueTuple a, ValueTuple a ~ (Value a), Storable a,- TypeNum.PositiveT d, LLVM.IsPrimitive a,+ (Serial.C v, Serial.Element v ~ b, Phi a, Class.Undefined a,+ a ~ A.Scalar b, A.PseudoModule b, A.IntegerConstant a, Memory.C b, TypeNum.NaturalT n) =>- C (Moog.Parameter n (Value a))- (Serial.Value d a) (Serial.Value d a) where- type Input (Moog.Parameter n (Value a)) (Serial.Value d a) = (Serial.Value d a)- type Output (Moog.Parameter n (Value a)) (Serial.Value d a) = (Serial.Value d a)+ C (Moog.Parameter n a) v v where+ type Input (Moog.Parameter n a) v = v+ type Output (Moog.Parameter n a) v = v process =- CausalPS.pack Moog.causalP <<<+ CausalPS.pack Moog.causal <<< first (arr Serial.constant) instance (Serial.C v, Serial.Element v ~ b, Phi a, Class.Undefined a,- A.PseudoModule a b, A.IntegerConstant a, Memory.C b) =>+ a ~ A.Scalar b, A.PseudoModule b, A.IntegerConstant a, Memory.C b) => C (UniFilter.Parameter a) v (UniFilter.Result v) where type Input (UniFilter.Parameter a) (UniFilter.Result v) = v type Output (UniFilter.Parameter a) v = UniFilter.Result v process =- CausalPS.pack UniFilter.causalP <<<+ CausalPS.pack UniFilter.causal <<< first (arr Serial.constant)
src/Synthesizer/LLVM/CausalParameterized/Functional.hs view
@@ -4,13 +4,15 @@ {-# LANGUAGE Rank2Types #-} module Synthesizer.LLVM.CausalParameterized.Functional ( T,- lift,+ lift, fromSignal, ($&), (&|&), compile,- withArgs, MakeArguments, Arguments, makeArgs,+ withArgs, compileSignal, MakeArguments, Arguments, makeArgs,+ AnyArg(..), ) where -import qualified Synthesizer.LLVM.CausalParameterized.Process as Causal+import qualified Synthesizer.LLVM.CausalParameterized.ProcessPrivate as CausalP+import qualified Synthesizer.LLVM.Parameterized.Signal as Signal import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified LLVM.Extra.MaybeContinuation as Maybe@@ -38,7 +40,6 @@ import qualified Control.Category as Cat import Control.Arrow (Arrow, (>>^), (&&&), arr, first, ) import Control.Category (Category, (.), )-import Control.Monad (liftM2, ) import Control.Applicative (Applicative, (<*>), pure, ) import Foreign.Storable (Storable, )@@ -53,28 +54,29 @@ newtype T p inp out = Cons (Code p inp out) --- | similar to @Causal.T p a b@+-- | similar to @CausalP.T p a b@ data Code p a b =- forall state ioContext startParamTuple nextParamTuple.- (Storable startParamTuple,- Storable nextParamTuple,- MakeValueTuple startParamTuple,- MakeValueTuple nextParamTuple,- Memory.C (ValueTuple startParamTuple),- Memory.C (ValueTuple nextParamTuple),+ forall context state ioContext parameters.+ (Storable parameters,+ MakeValueTuple parameters,+ Memory.C (ValueTuple parameters),+ Memory.C context, Memory.C state) => Code (forall r c. (Phi c) =>- ValueTuple nextParamTuple ->- a -> state ->+ context -> a -> state -> StateT Vault (Maybe.T r c) (b, state)) -- compute next value (forall r.- ValueTuple startParamTuple ->- CodeGenFunction r state)+ ValueTuple parameters ->+ CodeGenFunction r (context, state)) -- initial state- (p -> IO (ioContext, (nextParamTuple, startParamTuple)))+ (forall r.+ context -> state ->+ CodeGenFunction r ())+ -- cleanup+ (p -> IO (ioContext, parameters)) {- initialization from IO monad This will be run within Unsafe.performIO, so no observable In/Out actions please!@@ -86,37 +88,27 @@ instance Category (Code p) where id = arr id- Code nextB startB createIOContextB deleteIOContextB .- Code nextA startA createIOContextA deleteIOContextA = Code- (\(paramA, paramB) a (sa0,sb0) ->- do (b,sa1) <- nextA paramA a sa0- (c,sb1) <- nextB paramB b sb0- return (c, (sa1,sb1)))- (\(paramA, paramB) ->- liftM2 (,)- (startA paramA)- (startB paramB))- (\p -> do- (ca,(nextParamA,startParamA)) <- createIOContextA p- (cb,(nextParamB,startParamB)) <- createIOContextB p- return ((ca,cb),- ((nextParamA, nextParamB),- (startParamA, startParamB))))- (\(ca,cb) ->- deleteIOContextA ca >>- deleteIOContextB cb)+ Code nextB startB stopB createIOContextB deleteIOContextB .+ Code nextA startA stopA createIOContextA deleteIOContextA = Code+ (CausalP.composeNext+ (State.mapStateT . Maybe.onFail)+ stopA stopB nextA nextB)+ (CausalP.composeStart startA startB)+ (CausalP.composeStop stopA stopB)+ (CausalP.composeCreate createIOContextA createIOContextB)+ (CausalP.composeDelete deleteIOContextA deleteIOContextB) + instance Arrow (Code p) where arr f = Code- (\ _p a state -> return (f a, state))- (const $ return ())- (const $ return ((),((),())))+ (\ _p a () -> return (f a, ()))+ (\() -> return ((),()))+ (\() () -> return ())+ (const $ return ((),())) (const $ return ())- first (Code next start create delete) = Code- (\ioContext (b,d) sa0 ->- do (c,sa1) <- next ioContext b sa0- return ((c,d), sa1))- start create delete+ first (Code next start stop create delete) = Code+ (CausalP.firstNext next) start stop+ create delete {-@@ -143,13 +135,13 @@ lift0 :: (forall r. CodeGenFunction r out) -> T p inp out-lift0 f = lift (Causal.mapSimple (const f))+lift0 f = lift (CausalP.mapSimple (const f)) lift1 :: (forall r. a -> CodeGenFunction r out) -> T p inp a -> T p inp out-lift1 f x = Causal.mapSimple f $& x+lift1 f x = CausalP.mapSimple f $& x lift2 :: (forall r. a -> b -> CodeGenFunction r out) -> T p inp a -> T p inp b -> T p inp out-lift2 f x y = Causal.zipWithSimple f $& x&|&y+lift2 f x y = CausalP.zipWithSimple f $& x&|&y instance (A.PseudoRing b, A.Real b, A.IntegerConstant b) => Num (T p a b) where@@ -160,7 +152,11 @@ abs = lift1 A.abs signum = lift1 A.signum +instance (A.Field b, A.Real b, A.RationalConstant b) => Fractional (T p a b) where+ fromRational x = pure (A.fromRational' x)+ (/) = lift2 A.fdiv + instance (A.Additive b) => Additive.C (T p a b) where zero = pure A.zero (+) = lift2 A.add@@ -196,7 +192,7 @@ infixr 0 $& -($&) :: Causal.T p b c -> T p a b -> T p a c+($&) :: CausalP.T p b c -> T p a b -> T p a c f $& (Cons b) = tagUnique $ liftCode f . b @@ -208,17 +204,20 @@ tagUnique $ b &&& c -liftCode :: Causal.T p inp out -> Code p inp out-liftCode (Causal.Cons next start create delete) =+liftCode :: CausalP.T p inp out -> Code p inp out+liftCode (CausalP.Cons next start stop create delete) = Code (\p a state -> Trans.lift (next p a state))- start create delete+ start stop create delete -lift :: Causal.T p inp out -> T p inp out+lift :: CausalP.T p inp out -> T p inp out lift = tagUnique . liftCode +fromSignal :: Signal.T p out -> T p inp out+fromSignal = lift . CausalP.fromSignal+ tag :: Vault.Key out -> Code p inp out -> T p inp out-tag key (Code next start create delete) =+tag key (Code next start stop create delete) = Cons $ Code (\p a s0 -> do@@ -229,7 +228,7 @@ bs@(b,_) <- next p a s0 State.modify (Vault.insert key b) return bs)- start create delete+ start stop create delete -- dummy for debugging _tag :: Vault.Key out -> Code p inp out -> T p inp out@@ -240,16 +239,19 @@ Unsafe.performIO $ fmap (flip tag code) Vault.newKey -initialize :: Code p inp out -> Causal.T p inp out-initialize (Code next start create delete) =- Causal.Cons+initialize :: Code p inp out -> CausalP.T p inp out+initialize (Code next start stop create delete) =+ CausalP.Cons (\p a state -> State.evalStateT (next p a state) Vault.empty)- start create delete+ start stop create delete -compile :: T p inp out -> Causal.T p inp out+compile :: T p inp out -> CausalP.T p inp out compile (Cons code) = initialize code +compileSignal :: T p () out -> Signal.T p out+compileSignal f = CausalP.toSignal $ compile f + {- | Using 'withArgs' you can simplify @@ -264,12 +266,12 @@ -} withArgs :: (MakeArguments inp) =>- (Arguments (T p inp) inp -> T p inp out) -> Causal.T p inp out+ (Arguments (T p inp) inp -> T p inp out) -> CausalP.T p inp out withArgs = withArgsStart (lift Cat.id) withArgsStart :: (MakeArguments inp) =>- T p inp inp -> (Arguments (T p inp) inp -> T p inp out) -> Causal.T p inp out+ T p inp inp -> (Arguments (T p inp) inp -> T p inp out) -> CausalP.T p inp out withArgsStart fid f = compile (f (makeArgs fid)) @@ -296,6 +298,10 @@ instance MakeArguments (Stereo.T a) where makeArgs = id +type instance Arguments f () = f ()+instance MakeArguments () where+ makeArgs = id+ type instance Arguments f (a,b) = (Arguments f a, Arguments f b) instance (MakeArguments a, MakeArguments b) => MakeArguments (a,b) where@@ -305,3 +311,10 @@ instance (MakeArguments a, MakeArguments b, MakeArguments c) => MakeArguments (a,b,c) where makeArgs f = (makeArgs $ fmap fst3 f, makeArgs $ fmap snd3 f, makeArgs $ fmap thd3 f)+++newtype AnyArg a = AnyArg {getAnyArg :: a}++type instance Arguments f (AnyArg a) = f a+instance MakeArguments (AnyArg a) where+ makeArgs = fmap getAnyArg
src/Synthesizer/LLVM/CausalParameterized/FunctionalPlug.hs view
@@ -14,7 +14,7 @@ import qualified Synthesizer.LLVM.Plug.Input as PIn import qualified Synthesizer.LLVM.Plug.Output as POut -import qualified Synthesizer.LLVM.CausalParameterized.Process as Causal+import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Parameterized.Signal as Sig import qualified Synthesizer.CausalIO.Process as PIO@@ -43,9 +43,9 @@ import Data.Unique (Unique, newUnique, ) import Data.Maybe (fromMaybe, ) -import Control.Arrow (Arrow, (^<<), (<<^), arr, first, second, )-import Control.Category (Category, id, (.), )-import Control.Applicative (Applicative, (<*>), pure, liftA2, )+import Control.Arrow ((^<<), (<<^), arr, first, second, )+import Control.Category (id, (.), )+import Control.Applicative (Applicative, (<*>), pure, liftA2, liftA3, ) import qualified System.Unsafe as Unsafe @@ -62,7 +62,7 @@ whether we have already seen a certain object. If we encounter a known object then we use the Simple constructor-and fetch the stored Causal output+and fetch the stored CausalP output within the causal process enclosed in Simple. This and the causal process in the Plugged constructor are the second level.@@ -82,23 +82,23 @@ Plugged (pp -> inp -> x) (PIn.T x y)- (Causal.T pl (y, Vault) (out, Vault))+ (CausalP.T pl (y, Vault) (out, Vault)) | {-- The Simple constructor is needed for reusing shared Causal processes+ The Simple constructor is needed for reusing shared CausalP processes and for input without external representation. (a Plug.Input) -}- Simple (Causal.T pl Vault (out, Vault))+ Simple (CausalP.T pl Vault (out, Vault)) applyCore ::- Causal.T pl a b ->+ CausalP.T pl (a, Vault) (b, Vault) -> Core pp pl inp a -> Core pp pl inp b-applyCore f (Plugged prep plg process) =- Plugged prep plg (first f . process)-applyCore f (Simple process) =- Simple (first f . process)+applyCore f core =+ case core of+ Plugged prep plg process -> Plugged prep plg (f . process)+ Simple process -> Simple (f . process) combineCore :: Core pp pl inp a ->@@ -123,9 +123,9 @@ reuseCore :: Vault.Key out -> Core pp pl inp out reuseCore key =- Simple (arr (\vault ->+ Simple $ arr $ \vault -> (fromMaybe (error "key must have been lost") $ Vault.lookup key vault,- vault)))+ vault) tag ::@@ -138,31 +138,24 @@ then return $ reuseCore key else do MS.modify (Set.insert unique)- core <- stateCore- let store (a,v) = (a, Vault.insert key a v)- return $- case core of- Plugged prep plg process ->- Plugged prep plg (store ^<< process)- Simple process ->- Simple (store ^<< process)+ fmap (applyCore (arr $ \(a,v) -> (a, Vault.insert key a v))) stateCore tagUnique :: MS.State (Set.Set Unique) (Core pp pl inp out) -> T pp pl inp out tagUnique core = Unsafe.performIO $- fmap ($ core) $ liftA2 tag newUnique Vault.newKey+ liftA3 tag newUnique Vault.newKey (pure core) infixr 0 $& ($&) ::- Causal.T pl a b ->+ CausalP.T pl a b -> T pp pl inp a -> T pp pl inp b f $& Cons core =- tagUnique $ fmap (applyCore f) core+ tagUnique $ fmap (applyCore $ first f) core infixr 3 &|&@@ -184,7 +177,7 @@ f <*> x = fmap (uncurry ($)) $ combineCore f x lift0Core :: (forall r. CodeGenFunction r out) -> Core pp pl inp out-lift0Core f = Simple (Causal.mapSimple (\v -> fmap (flip (,) v) f))+lift0Core f = Simple (CausalP.mapSimple (\v -> fmap (flip (,) v) f)) instance Functor (T pp pl inp) where@@ -199,10 +192,10 @@ lift0 f = tagUnique $ pure $ lift0Core f lift1 :: (forall r. a -> CodeGenFunction r out) -> T pp pl inp a -> T pp pl inp out-lift1 f x = Causal.mapSimple f $& x+lift1 f x = CausalP.mapSimple f $& x lift2 :: (forall r. a -> b -> CodeGenFunction r out) -> T pp pl inp a -> T pp pl inp b -> T pp pl inp out-lift2 f x y = Causal.zipWithSimple f $& x&|&y+lift2 f x y = CausalP.zipWithSimple f $& x&|&y instance (A.PseudoRing b, A.Real b, A.IntegerConstant b) => Num (T pp pl a b) where@@ -213,7 +206,11 @@ abs = lift1 A.abs signum = lift1 A.signum +instance (A.Field b, A.Real b, A.RationalConstant b) => Fractional (T pp pl a b) where+ fromRational x = pure (A.fromRational' x)+ (/) = lift2 A.fdiv + instance (A.Additive b) => Additive.C (T pp pl a b) where zero = pure A.zero (+) = lift2 A.add@@ -252,7 +249,7 @@ Sig.T pl a -> T pp pl inp a fromSignal sig =- tagUnique $ pure $ Simple (Causal.feedFst sig)+ tagUnique $ pure $ Simple (CausalP.feedFst sig) @@ -280,14 +277,14 @@ case MS.evalState core Set.empty of Plugged prep pin process -> fmap (\f pp pl -> f pl <<^ prep pp) $- Causal.processIOCore+ CausalP.processIOCore pin (fst ^<< process <<^ flip (,) Vault.empty) pout Simple _ -> error "FunctionalPlug.runPlugOut: no substantial input available" -- Simple process ->- -- Causal.processIOCore pin process pout+ -- CausalP.processIOCore pin process pout run :: (POut.Default b) =>
+ src/Synthesizer/LLVM/CausalParameterized/Helix.hs view
@@ -0,0 +1,646 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE Rank2Types #-}+{- |+<http://arxiv.org/abs/0911.5171>+-}+module Synthesizer.LLVM.CausalParameterized.Helix (+ -- * time and phase control based on the helix model+ static,+ staticPacked,+ dynamic,+ dynamicLimited,++ -- * useful control curves+ zigZag,+ zigZagPacked,+ zigZagLong,+ zigZagLongPacked,+ ) where++import qualified Synthesizer.LLVM.CausalParameterized.ProcessValue as CausalPV+import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS+import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.CausalParameterized.Functional as Func+import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS+import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified Synthesizer.LLVM.RingBufferForward as RingBuffer+import qualified Synthesizer.LLVM.Frame.SerialVector as Serial+import qualified Synthesizer.LLVM.Simple.Value as Value+import qualified Synthesizer.LLVM.Interpolation as Ip+import qualified Synthesizer.LLVM.Parameter as Param+import Synthesizer.LLVM.CausalParameterized.Functional (($&), (&|&), )+import Synthesizer.LLVM.CausalParameterized.Process (($*), ($<), )+import Synthesizer.LLVM.Simple.Value ((%>), (%>=), (?), (??), )++import qualified Synthesizer.LLVM.Storable.Vector as SVU+import qualified Data.StorableVector as SV++import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Vector as Vector+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.MaybeContinuation as MaybeCont+import LLVM.Extra.Class (MakeValueTuple, ValueTuple, )++import qualified LLVM.Core as LLVM+import LLVM.Core (CodeGenFunction, Value, IsSized, IsFloating, )++import qualified Types.Data.Num as TypeNum+import Types.Data.Num (D1, )++import Data.Word (Word32, )++import Foreign.ForeignPtr (touchForeignPtr, )+import Foreign.Storable (Storable, )++import Control.Arrow (first, (<<<), (^<<), (<<^), )+import Control.Category (id, )+import Control.Applicative (liftA2, )+import Control.Functor.HT (unzip, )+import Data.Traversable (mapM, )+import Data.Tuple.HT (mapFst, )++import qualified Algebra.Field as Field+import qualified Algebra.Ring as Ring++import NumericPrelude.Numeric hiding (splitFraction, )+import NumericPrelude.Base hiding (unzip, zip, mapM, id, )++import Prelude ()+++{- |+Inputs are @(shape, phase)@.++The shape parameter is limited at the beginning and at the end+such that only available data is used for interpolation.+Actually, we allow almost one step less than possible,+since the right boundary of the interval of admissible @shape@ values is open.+-}+static ::+ (Storable vh, MakeValueTuple vh, ValueTuple vh ~ v, Memory.C v,+ Ip.C nodesStep, Ip.C nodesLeap,+ SoV.RationalConstant a, SoV.Fraction a,+ Storable a, MakeValueTuple a, ValueTuple a ~ Value a,+ Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,+ LLVM.NumberOfElements a ~ D1) =>+ (forall r. Ip.T r nodesLeap (Value a) v) ->+ (forall r. Ip.T r nodesStep (Value a) v) ->+ Param.T p Int ->+ Param.T p a ->+ Param.T p (SV.Vector vh) ->+ CausalP.T p (Value a, Value a) v+static ipLeap ipStep periodInt period vec =+ let period32 = Param.word32 periodInt+ cellMargin = combineMarginParams ipLeap ipStep periodInt+ in interpolateCell ipLeap ipStep+ <<<+ first (peekCell cellMargin period32 vec)+ <<<+ flattenShapePhaseProc period32 period+ <<<+ first+ (limitShape cellMargin period32+ (Param.word32 $ fmap SV.length vec))+++staticPacked ::+ (Storable vh, MakeValueTuple vh, ValueTuple vh ~ ve,+ Serial.Element v ~ ve, Memory.C ve,+ Ip.C nodesStep, Ip.C nodesLeap,+ Serial.Size (nodesLeap (nodesStep v)) ~ n,+ Serial.C (nodesLeap (nodesStep v)),+ Serial.Element (nodesLeap (nodesStep v)) ~+ nodesLeap (nodesStep (Serial.Element v)),+ TypeNum.PositiveT n,+ SoV.RationalConstant a, SoV.Fraction a, Vector.Real a,+ Storable a, MakeValueTuple a, ValueTuple a ~ Value a,+ Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,+ LLVM.IsPrimitive a, LLVM.IsPrimitive am) =>+ (forall r. Ip.T r nodesLeap (Serial.Value n a) v) ->+ (forall r. Ip.T r nodesStep (Serial.Value n a) v) ->+ Param.T p Int ->+ Param.T p a ->+ Param.T p (SV.Vector vh) ->+ CausalP.T p (Serial.Value n a, Serial.Value n a) v+staticPacked ipLeap ipStep periodInt period vec =+ let period32 = Param.word32 periodInt+ cellMargin = combineMarginParams ipLeap ipStep periodInt+ in interpolateCell ipLeap ipStep+ <<<+ first (CausalPS.pack+ (peekCell (fmap elementMargin cellMargin) period32 vec))+ <<<+ flattenShapePhaseProcPacked period32 period+ <<<+ first+ (limitShapePacked cellMargin period32+ (Param.word32 $ fmap SV.length vec))+++{- |+In contrast to 'dynamic' this one ends+when the end of the manipulated signal is reached.+-}+dynamicLimited ::+ (Ip.C nodesStep, Ip.C nodesLeap,+ A.Additive v, Memory.C v,+ SoV.RationalConstant a, SoV.Fraction a,+ LLVM.CmpRet a, LLVM.CmpResult a ~ Bool,+ Storable a, MakeValueTuple a, ValueTuple a ~ Value a,+ Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,+ LLVM.NumberOfElements a ~ D1) =>+ (forall r. Ip.T r nodesLeap (Value a) v) ->+ (forall r. Ip.T r nodesStep (Value a) v) ->+ Param.T p Int ->+ Param.T p a ->+ SigP.T p v ->+ CausalP.T p (Value a, Value a) v+dynamicLimited ipLeap ipStep periodInt period sig =+ dynamicGen+ (\cellMargin (skips, fracs) ->+ let windows =+ RingBuffer.trackSkip (fmap Ip.marginNumber cellMargin) sig $& skips+ in (windows,+ CausalP.delay1Zero $& skips,+ CausalP.delay1Zero $& fracs))+ ipLeap ipStep periodInt period++{- |+If the time control exceeds the end of the input signal,+then the last waveform is locked.+This is analogous to 'static'.+-}+dynamic ::+ (Ip.C nodesStep, Ip.C nodesLeap,+ A.Additive v, Memory.C v,+ SoV.RationalConstant a, SoV.Fraction a,+ LLVM.CmpRet a, LLVM.CmpResult a ~ Bool,+ Storable a, MakeValueTuple a, ValueTuple a ~ Value a,+ Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,+ LLVM.NumberOfElements a ~ D1) =>+ (forall r. Ip.T r nodesLeap (Value a) v) ->+ (forall r. Ip.T r nodesStep (Value a) v) ->+ Param.T p Int ->+ Param.T p a ->+ SigP.T p v ->+ CausalP.T p (Value a, Value a) v+dynamic ipLeap ipStep periodInt period sig =+ dynamicGen+ (\cellMargin (skips, fracs) ->+ let {-+ For conformance with 'static'+ we stop one step before the definite end.+ We achieve this by using a buffer+ that is one step longer than necessary.+ -}+ ((running, actualSkips), windows) =+ mapFst unzip $ unzip $+ RingBuffer.trackSkipHold+ (fmap (succ . Ip.marginNumber) cellMargin) sig $& skips+ holdFracs =+ CausalPV.zipWithSimple (\r fr -> r ? (fr, 1))+ $&+ running &|& (CausalP.delay1Zero $& fracs)+ in (windows, actualSkips, holdFracs))+ ipLeap ipStep periodInt period++dynamicGen ::+ (Ip.C nodesStep, Ip.C nodesLeap,+ A.Additive v, Memory.C v,+ SoV.RationalConstant a, SoV.Fraction a,+ LLVM.CmpRet a, LLVM.CmpResult a ~ Bool,+ Storable a, MakeValueTuple a, ValueTuple a ~ Value a,+ Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,+ LLVM.NumberOfElements a ~ D1) =>+ (Param.T p (Ip.Margin (nodesLeap (nodesStep v))) ->+ (Func.T p (Value a, Value a) (Value Word32),+ Func.T p (Value a, Value a) (Value a)) ->+ (Func.T p (Value a, Value a) (RingBuffer.T v),+ Func.T p (Value a, Value a) (Value Word32),+ Func.T p (Value a, Value a) (Value a))) ->+ (forall r. Ip.T r nodesLeap (Value a) v) ->+ (forall r. Ip.T r nodesStep (Value a) v) ->+ Param.T p Int ->+ Param.T p a ->+ CausalP.T p (Value a, Value a) v+dynamicGen limitMaxShape ipLeap ipStep periodInt period =+ let period32 = Param.word32 periodInt+ cellMargin = combineMarginParams ipLeap ipStep periodInt+ minShape =+ Param.word32 $ fmap fst $+ liftA2 shapeMargin cellMargin periodInt++ in Func.withArgs $ \(shape, phase) ->+ let (windows, skips, fracs) =+ limitMaxShape cellMargin $+ unzip (integrateFrac $& (limitMinShape minShape $& shape))+ (offsets, shapePhases) =+ unzip+ (flattenShapePhaseProc period32 period $&+ (constantFromWord32 minShape + fracs)+ &|&+ (CausalP.osciCoreSync $&+ phase+ &|&+ negate+ (CausalPV.map (flip (/)) period $&+ (CausalP.mapSimple LLVM.inttofp $& skips))))+ in interpolateCell ipLeap ipStep $&+ (CausalP.map (uncurry . cellFromBuffer) period32+ $&+ windows+ &|&+ offsets)+ &|&+ shapePhases++constantFromWord32 ::+ (IsFloating a, LLVM.NumberOfElements a ~ TypeNum.D1) =>+ Param.T p Word32 -> Func.T p inp (Value a)+constantFromWord32 x =+ Func.fromSignal+ (CausalP.mapSimple LLVM.inttofp $* SigP.constant x)++limitMinShape ::+ (Storable a, Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,+ LLVM.NumberOfElements a ~ TypeNum.D1,+ LLVM.IsFloating a, LLVM.CmpRet a, LLVM.CmpResult a ~ Bool) =>+ Param.T p Word32 ->+ CausalP.T p (Value a) (Value a)+limitMinShape xLim =+ CausalPV.mapAccum+ (\_ x lim -> (x%>=lim) ? ((x-lim,zero), (zero,lim-x)))+ (Value.lift1 LLVM.inttofp) (return ()) xLim++integrateFrac ::+ (IsFloating a,+ Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,+ LLVM.NumberOfElements a ~ TypeNum.D1) =>+ CausalP.T p (Value a) (Value Word32, Value a)+integrateFrac =+ CausalP.mapAccumSimple+ (\a (_n,frac) -> do+ s <- splitFraction =<< A.add a frac+ return (s, s))+ (return (A.zero, A.zero))+++interpolateCell ::+ (Ip.C nodesStep, Ip.C nodesLeap) =>+ (forall r. Ip.T r nodesLeap a v) ->+ (forall r. Ip.T r nodesStep a v) ->+ CausalP.T p (nodesLeap (nodesStep v), (a, a)) v+interpolateCell ipLeap ipStep =+ CausalP.mapSimple+ (\(nodes, (leap,step)) ->+ ipLeap leap =<< mapM (ipStep step) nodes)++cellFromBuffer ::+ (Memory.C a, Ip.C nodesLeap, Ip.C nodesStep) =>+ Value Word32 ->+ RingBuffer.T a ->+ Value Word32 ->+ CodeGenFunction r (nodesLeap (nodesStep a))+cellFromBuffer periodInt buffer offset =+ Ip.indexNodes+ (Ip.indexNodes (flip RingBuffer.index buffer) A.one)+ periodInt offset++elementMargin ::+ Ip.Margin (nodesLeap (nodesStep v)) ->+ Ip.Margin (nodesLeap (nodesStep (Serial.Element v)))+elementMargin (Ip.Margin x y) = Ip.Margin x y++peekCell ::+ (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value,+ Ip.C nodesLeap, Ip.C nodesStep) =>+ Param.T p (Ip.Margin (nodesLeap (nodesStep value))) ->+ Param.T p Word32 ->+ Param.T p (SV.Vector a) ->+ CausalP.T p (Value Word32) (nodesLeap (nodesStep value))+peekCell margin period32 vec =+ Param.with (Param.word32 $ fmap Ip.marginOffset margin) $ \getOffset valueOffset ->+ Param.with period32 $ \getPeriod valuePeriod -> CausalP.Cons+ (\(p,off,per) n () -> MaybeCont.lift $ do+ offset <- A.sub n (valueOffset off)+ nodes <-+ Ip.loadNodes (Ip.loadNodes Memory.load A.one) (valuePeriod per)+ =<< LLVM.getElementPtr p (offset, ())+ return (nodes, ()))+ (return . flip (,) ())+ (const $ const $ return ())+ (\p ->+ let (fp,ptr,_l) = SVU.unsafeToPointers $ Param.get vec p+ in return (fp, (ptr, getOffset p, getPeriod p)))+ touchForeignPtr+++flattenShapePhaseProc ::+ (IsFloating a, SoV.Fraction a, SoV.RationalConstant a,+ Storable ah, MakeValueTuple ah, ValueTuple ah ~ Value a,+ Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,+ LLVM.NumberOfElements a ~ D1) =>+ Param.T p Word32 ->+ Param.T p ah ->+ CausalP.T p+ (Value a, Value a)+ (Value Word32, (Value a, Value a))+flattenShapePhaseProc period32 period =+ CausalP.map+ (\(perInt, per) (shape, phase) ->+ flattenShapePhase perInt per shape phase)+ (liftA2 (,) period32 period)++flattenShapePhaseProcPacked ::+ (IsFloating a, Vector.Real a, SoV.RationalConstant a,+ Storable ah, MakeValueTuple ah, ValueTuple ah ~ Value a,+ Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,+ TypeNum.PositiveT n) =>+ Param.T p Word32 ->+ Param.T p ah ->+ CausalP.T p+ (Serial.Value n a, Serial.Value n a)+ (Serial.Value n Word32,+ (Serial.Value n a, Serial.Value n a))+flattenShapePhaseProcPacked period32 period =+ CausalP.map+ (\(perInt, per) (Serial.Cons shape, Serial.Cons phase) -> do+ perIntVec <- SoV.replicate perInt+ perVec <- SoV.replicate per+ (i, (leap, step)) <-+ flattenShapePhase perIntVec perVec shape phase+ return (Serial.Cons i, (Serial.Cons leap, Serial.Cons step)))+ (liftA2 (,) period32 period)++flattenShapePhase ::+ (IsFloating a, SoV.Fraction a, SoV.RationalConstant a,+ LLVM.NumberOfElements a ~ LLVM.NumberOfElements i,+ LLVM.IsInteger i) =>+ Value i ->+ Value a ->+ Value a -> Value a ->+ CodeGenFunction r (Value i, (Value a, Value a))+flattenShapePhase = Value.unlift4 $ \periodInt period shape phase ->+ let qLeap = Value.lift1 A.fraction $ shape/period - phase+ (n,qStep) =+ unzip $ Value.lift1 splitFraction $+ {-+ If 'shape' is correctly limited,+ the value is always non-negative algebraically,+ but maybe not numerically.+ -}+ Value.max zero $+ shape - qLeap * Value.lift1 LLVM.inttofp periodInt+ in (n,(qLeap,qStep))++{- |+You must make sure, that the argument is non-negative.+-}+splitFraction ::+ (IsFloating a, LLVM.IsInteger i,+ LLVM.NumberOfElements a ~ LLVM.NumberOfElements i) =>+ Value a -> CodeGenFunction r (Value i, Value a)+splitFraction x = do+ n <- LLVM.fptoint x+ frac <- A.sub x =<< LLVM.inttofp n+ return (n, frac)+++limitShape ::+ (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized tm,+ IsFloating t, SoV.Real t,+ LLVM.NumberOfElements t ~ LLVM.NumberOfElements i,+ MakeValueTuple i, ValueTuple i ~ Value i,+ Ring.C i, LLVM.IsInteger i, SoV.IntegerConstant i,+ Storable i, Memory.FirstClass i, Memory.Stored i ~ im, IsSized im,+ Ip.C nodesStep, Ip.C nodesLeap) =>+ Param.T p (Ip.Margin (nodesLeap (nodesStep value))) ->+ Param.T p i ->+ Param.T p i ->+ CausalP.T p (Value t) (Value t)+limitShape margin periodInt len =+ CausalPV.zipWithSimple (Value.limit . unzip)+ $<+ limitShapeSignal margin periodInt len++limitShapePacked ::+ (Memory.FirstClass t, Memory.Stored t ~ tm,+ IsSized tm, LLVM.IsPrimitive tm,+ LLVM.SizeOf tm ~ tmsize,+ IsFloating t, LLVM.IsPrimitive t, Vector.Real t,+ TypeNum.PositiveT n,+ Ip.C nodesStep, Ip.C nodesLeap) =>+ Param.T p (Ip.Margin (nodesLeap (nodesStep value))) ->+ Param.T p Word32 ->+ Param.T p Word32 ->+ CausalP.T p (Serial.Value n t) (Serial.Value n t)+limitShapePacked margin periodInt len =+ CausalPV.zipWithSimple+ (\minmax shape ->+ let (minShape,maxShape) = unzip minmax+ in Value.limit+ (Value.lift1 Serial.upsample minShape,+ Value.lift1 Serial.upsample maxShape)+ shape)+ $<+ limitShapeSignal margin periodInt len++limitShapeSignal ::+ (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized tm,+ IsFloating t,+ LLVM.NumberOfElements t ~ LLVM.NumberOfElements i,+ MakeValueTuple i, ValueTuple i ~ Value i,+ Ring.C i, LLVM.IsInteger i, SoV.IntegerConstant i,+ Storable i, Memory.FirstClass i, Memory.Stored i ~ im, IsSized im,+ Ip.C nodesStep, Ip.C nodesLeap) =>+ Param.T p (Ip.Margin (nodesLeap (nodesStep value))) ->+ Param.T p i ->+ Param.T p i ->+ SigP.T p (Value t, Value t)+limitShapeSignal margin periodInt len =+ SigP.Cons+ (\minMax () -> return (minMax, ()))+ (\(minShapeInt, maxShapeInt) -> do+ minShape <- LLVM.inttofp minShapeInt+ maxShape <- LLVM.inttofp maxShapeInt+ return ((minShape, maxShape), ()))+ (const $ const $ return ())+ (\p -> return ((),+ shapeLimits+ (Param.get margin p)+ (Param.get periodInt p)+ (Param.get len p)))+ (const $ return ())+++_limitShape ::+ (Ring.C th, Storable th, MakeValueTuple th, ValueTuple th ~ t,+ Memory.C t, A.Real t,+ Ip.C nodesStep, Ip.C nodesLeap) =>+ Ip.Margin (nodesLeap (nodesStep value)) ->+ Param.T p th ->+ Param.T p th ->+ CausalP.T p t t+_limitShape margin periodInt len =+ CausalP.Cons+ (\(minShape,maxShape) shape () -> MaybeCont.lift $ do+ limited <- A.min maxShape =<< A.max minShape shape+ return (limited, ()))+ (\minmax -> return (minmax, ()))+ (const $ const $ return ())+ (\p ->+ return+ ((),+ shapeLimits margin+ (Param.get periodInt p)+ (Param.get len p)))+ (const $ return ())++shapeLimits ::+ (Ip.C nodesLeap, Ip.C nodesStep, Ring.C t) =>+ Ip.Margin (nodesLeap (nodesStep value)) ->+ t ->+ t ->+ (t, t)+shapeLimits margin periodInt len =+ case shapeMargin margin periodInt of+ (leftMargin, rightMargin) ->+ (leftMargin, len - rightMargin)++_shapeLimits ::+ (Ip.C nodesLeap, Ip.C nodesStep,+ IsFloating t, LLVM.NumberOfElements t ~ D1) =>+ Ip.Margin (nodesLeap (nodesStep value)) ->+ Value.T (Value Word32) ->+ Value.T (Value t) ->+ (Value.T (Value t), Value.T (Value t))+_shapeLimits margin periodInt len =+ let (leftMargin, rightMargin) = shapeMargin margin periodInt+ in (Value.lift1 LLVM.inttofp leftMargin,+ len - Value.lift1 LLVM.inttofp rightMargin)++shapeMargin ::+ (Ip.C nodesLeap, Ip.C nodesStep, Ring.C i) =>+ Ip.Margin (nodesLeap (nodesStep value)) ->+ i -> (i, i)+shapeMargin margin periodInt =+ let leftMargin = fromIntegral (Ip.marginOffset margin) + periodInt+ rightMargin = fromIntegral (Ip.marginNumber margin) - leftMargin+ in (leftMargin, rightMargin)++combineMarginParams ::+ (Ip.C nodesStep, Ip.C nodesLeap) =>+ (forall r. Ip.T r nodesLeap a v) ->+ (forall r. Ip.T r nodesStep a v) ->+ Param.T p Int ->+ Param.T p (Ip.Margin (nodesLeap (nodesStep v)))+combineMarginParams ipLeap ipStep periodInt =+ fmap+ (combineMargins (Ip.toMargin ipLeap) (Ip.toMargin ipStep))+ periodInt++combineMargins ::+ Ip.Margin (nodesLeap value) ->+ Ip.Margin (nodesStep value) ->+ Int ->+ Ip.Margin (nodesLeap (nodesStep value))+combineMargins marginLeap marginStep periodInt =+ Ip.Margin {+ Ip.marginNumber =+ Ip.marginNumber marginStep ++ Ip.marginNumber marginLeap * periodInt,+ Ip.marginOffset =+ Ip.marginOffset marginStep ++ Ip.marginOffset marginLeap * periodInt+ }+++zigZagLong ::+ (Storable a, MakeValueTuple a, ValueTuple a ~ Value a,+ Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,+ SoV.Fraction a, IsFloating a, SoV.RationalConstant a, LLVM.CmpRet a,+ Field.C a) =>+ Param.T p a ->+ Param.T p a ->+ CausalP.T p (Value a) (Value a)+zigZagLong =+ zigZagLongGen (CausalP.fromSignal . SigP.constant) zigZag++zigZagLongPacked ::+ (Storable a, MakeValueTuple a, ValueTuple a ~ Value a,+ SoV.Fraction a, SoV.RationalConstant a, Vector.Real a,+ Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am,+ LLVM.IsPrimitive am,+ Field.C a,+ (n TypeNum.:*: LLVM.SizeOf am) ~ amsize,+ TypeNum.PositiveT amsize,+ TypeNum.PositiveT n) =>+ Param.T p a ->+ Param.T p a ->+ CausalP.T p (Serial.Value n a) (Serial.Value n a)+zigZagLongPacked =+ zigZagLongGen (CausalP.fromSignal . SigPS.constant) zigZagPacked++zigZagLongGen ::+ (A.RationalConstant al, A.Field al, Field.C a) =>+ (Param.T p a -> CausalP.T p al al) ->+ (Param.T p a -> CausalP.T p al al) ->+ Param.T p a ->+ Param.T p a ->+ CausalP.T p al al+zigZagLongGen constant zz prefix loop =+ zz (negate $ prefix/loop) * constant loop + constant prefix+ <<<+ id / constant loop++zigZag ::+ (Storable a, MakeValueTuple a, ValueTuple a ~ Value a,+ Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,+ SoV.Fraction a, IsFloating a, SoV.RationalConstant a,+ LLVM.CmpRet a) =>+ Param.T p a ->+ CausalP.T p (Value a) (Value a)+zigZag start =+ CausalPV.mapSimple (\x -> 1-abs (1-x))+ <<<+ CausalPV.mapAccum+ (\_ d t0 ->+ let t1 = t0+d+ in (t0, wrap (curry . (??)) t1))+ id (return ()) start++zigZagPacked ::+ (Storable a, MakeValueTuple a, ValueTuple a ~ Value a,+ Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,+ SoV.Fraction a, Vector.Real a, IsFloating a, SoV.RationalConstant a,+ LLVM.CmpRet a,+ TypeNum.PositiveT n) =>+ Param.T p a ->+ CausalP.T p (Serial.Value n a) (Serial.Value n a)+zigZagPacked start =+ Serial.Cons+ ^<<+ CausalPV.mapSimple (\x -> 1 - abs (1-x))+ <<<+ CausalPV.mapAccum+ (\_ d t0 ->+ let (t1, cum) = unzip $ Value.lift2 Vector.cumulate t0 d+ {-+ Vector.select can be replaced by (??)+ once vector select is implemented by LLVM.+ -}+ in (wrap (Value.lift3 Vector.select) cum, t1))+ id (return ()) start+ <<^+ (\(Serial.Cons v) -> v)++wrap ::+ (SoV.RationalConstant a, IsFloating a, SoV.Fraction a, LLVM.CmpRet a) =>+ (Value.T (Value (LLVM.CmpResult a)) ->+ Value.T (Value a) ->+ Value.T (Value a) ->+ Value.T (Value a)) ->+ Value.T (Value a) -> Value.T (Value a)+wrap select a = select (a%>0) (2 * Value.fraction (a/2)) a
src/Synthesizer/LLVM/CausalParameterized/Process.hs view
@@ -1,44 +1,108 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ForeignFunctionInterface #-} module Synthesizer.LLVM.CausalParameterized.Process ( T(Cons), simple, fromSignal, toSignal,- mapAccum, map, mapSimple, zipWithSimple,+ mapAccum, map, mapSimple, zipWith, zipWithSimple, apply, compose, first, feedFst, feedSnd,- loop, take, takeWhile, integrate,- module Synthesizer.LLVM.CausalParameterized.Process+ loop, loopZero, take, takeWhile, integrate,++ ($<), ($>), ($*), ($<#), ($>#), ($*#),+ applyFst, applySnd,++ mapAccumSimple,++ replicateControlled,+ replicateParallel,+ replicateControlledParam,+ feedbackControlled,+ Causal.feedbackControlledZero,+ Causal.fromModifier,+ stereoFromMono,+ stereoFromMonoControlled,+ stereoFromMonoParameterized,+ Causal.stereoFromVector,+ Causal.vectorize,+ Causal.replaceChannel,+ Causal.arrayElement,+ Causal.element,+ mix,+ raise,+ envelope,+ envelopeStereo,+ amplify,+ amplifyStereo,+ mapLinear,+ mapExponential,+ quantizeLift,+ osciSimple,+ osciCore,+ osciCoreSync,+ shapeModOsci,+ delay,+ delayZero,+ delay1,+ delay1Zero,+ delayControlled,+ delayControlledInterpolated,+ differentiate,+ comb,+ combStereo,+ reverb,+ reverbEfficient,+ pipeline,+ skip,+ frequencyModulation,+ frequencyModulationLinear,+ adjacentNodes02,+ adjacentNodes13,+ trigger,++ runStorable,+ applyStorable,+ runStorableChunky,+ runStorableChunkyCont,+ applyStorableChunky,++ processIO,+ processIOCore, ) where import Synthesizer.LLVM.CausalParameterized.ProcessPrivate+import Synthesizer.LLVM.Causal.ProcessPrivate (feedbackControlledAux, )+import Synthesizer.LLVM.Causal.Process (loopZero, )+import qualified Synthesizer.LLVM.Causal.Process as Causal import qualified Synthesizer.LLVM.Plug.Input as PIn import qualified Synthesizer.LLVM.Plug.Output as POut import qualified Synthesizer.LLVM.Parameter as Param import qualified Synthesizer.CausalIO.Process as PIO -import Synthesizer.LLVM.Parameterized.Signal (($#), )+import Synthesizer.LLVM.Parameterized.SignalPrivate+ (withStart, quantizeCreate, quantizeDelete,+ quantizeNext, quantizeStart, quantizeStop, )+import Synthesizer.LLVM.Parameter (($#), ) import qualified Synthesizer.LLVM.RingBuffer as RingBuffer import qualified Synthesizer.LLVM.Parameterized.Signal as Sig+import qualified Synthesizer.LLVM.Interpolation as Interpolation import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Frame as Frame import qualified Synthesizer.LLVM.Execution as Exec-import qualified Synthesizer.LLVM.Simple.Value as Value import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector as SV import qualified Data.StorableVector.Base as SVB import qualified Synthesizer.Generic.Cut as Cut-import qualified Synthesizer.Plain.Modifier as Modifier+import qualified Synthesizer.Causal.Class as CausalClass import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Vector as Vector-import qualified LLVM.Extra.MaybeContinuation as Maybe+import qualified LLVM.Extra.MaybeContinuation as MaybeCont+import qualified LLVM.Extra.Maybe as Maybe import qualified LLVM.Extra.ForeignPtr as ForeignPtr import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Control as C@@ -46,59 +110,63 @@ import qualified LLVM.Extra.Arithmetic as A import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, undefTuple, ) +import qualified LLVM.Core as LLVM import LLVM.Util.Loop (Phi, )-import LLVM.Core as LLVM-import Types.Data.Num (D2, )-import Types.Data.Ord ((:<:), )+import LLVM.Core+ (CodeGenFunction, ret, Value, valueOf,+ IsSized, IsConst, IsArithmetic, IsFloating,+ Linkage(ExternalLinkage), createNamedFunction, )+ import qualified Types.Data.Num as TypeNum-import qualified Types.Data.Bool as TypeBool+import Types.Data.Num (D1, ) import qualified Control.Monad.HT as M import qualified Control.Arrow as Arr import qualified Control.Category as Cat-import Control.Monad.Trans.State (runState, state, evalState, )-import Control.Arrow (arr, (<<<), (>>>), (&&&), )-import Control.Monad (liftM2, liftM3, when, )-import Control.Applicative (liftA2, )+import qualified Control.Monad.Trans.State as MS+import Control.Monad.Trans.State (evalState, )+import Control.Arrow (arr, second, (<<<), (<<^), (>>>), (&&&), )+import Control.Monad (liftM, liftM2, liftM3, when, )+import Control.Applicative (liftA2, liftA3, pure, (<*>), )+import Control.Functor.HT (void, unzip, ) +import qualified Data.List as List+import Data.Traversable (traverse, )+import Data.Foldable (sequence_, )+import Data.Tuple.HT (swap, mapSnd, uncurry3, snd3, )+import Data.Word (Word32, )+import Data.Int (Int8, )+ import System.Random (Random, RandomGen, randomR, ) import qualified Algebra.Transcendental as Trans-import qualified Algebra.Field as Field-import qualified Algebra.Ring as Ring-import qualified Algebra.Additive as Additive -import Data.Function.HT (nest, )-import Data.Tuple.HT (swap, )-import Data.Word (Word32, )-import Foreign.Storable.Tuple ()-import Foreign.Storable (Storable, poke, ) import qualified Synthesizer.LLVM.Alloc as Alloc+import qualified System.Unsafe as Unsafe import qualified Foreign.Marshal.Utils as AllocUtil-import Foreign.ForeignPtr (withForeignPtr, )-import Foreign.Ptr (FunPtr, )+import qualified Foreign.Concurrent as FC+import Foreign.Storable.Tuple ()+import Foreign.Storable (Storable, )+import Foreign.ForeignPtr (touchForeignPtr, withForeignPtr, )+import Foreign.Ptr (FunPtr, Ptr, ) import Control.Exception (bracket, )-import qualified System.Unsafe as Unsafe -import qualified Data.List as List- import qualified Synthesizer.LLVM.Debug.Storable as DebugSt import qualified Synthesizer.LLVM.Debug.Counter as DebugCnt import NumericPrelude.Numeric-import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, take, takeWhile, )+import NumericPrelude.Base hiding+ (and, iterate, map, unzip, zip, zipWith, take, takeWhile, sequence_, ) infixl 0 $<, $>, $*, $<#, $>#, $*# -- infixr 0 $:* -- can be used together with $ applyFst, ($<) :: T p (a,b) c -> Sig.T p a -> T p b c-applyFst proc sig =- proc <<< feedFst sig+applyFst = CausalClass.applyFst applySnd, ($>) :: T p (a,b) c -> Sig.T p b -> T p a c-applySnd proc sig =- proc <<< feedSnd sig+applySnd = CausalClass.applySnd {- These infix operators may become methods of a type class@@ -140,135 +208,154 @@ mapAccum (\() -> f) (\() -> s) (return ()) (return ()) --- cf. synthesizer-core:Causal.Process, can be defined for any arrow-{-# INLINE replicateControlled #-}-replicateControlled :: Int -> T p (c,x) x -> T p (c,x) x-replicateControlled n p =- nest n- (Arr.arr fst &&& p >>> )- (Arr.arr snd)+replicateParallel ::+ (Undefined b, Phi b) =>+ Param.T p Int -> Sig.T p b -> T p (b,b) b -> T p a b -> T p a b+replicateParallel n z cum p =+ replicateControlled n (first p >>> cum) $> z +{-+There are several problems:++ * We have to call f on every parameter in the list,+ but we have to assume that the generated code is always the same.++ * createIOContext may return different types for every element in the list.+ If types are different, the LLVM code cannot be the same, though.+-}+replicateControlledParam ::+ (Undefined x, Phi x) =>+ (forall q. Param.T q p -> Param.T q a -> T q (c,x) x) ->+ Param.T p [a] -> T p (c,x) x+replicateControlledParam f ps =+ case f (arr fst) (arr snd) of+ Cons next start stop createIOContext deleteIOContext -> Cons+ (replicateControlledNext next stop)+-- (_replicateControlledNext next)+ (replicateControlledStart start)+ (replicateControlledStop stop)+ (\p ->+ replicateControlledCreate $+ mapM+ (\a -> createIOContext (p,a))+ (Param.get ps p))+ (replicateControlledDelete deleteIOContext)++ -- cf. synthesizer-core:Causal.Process-{-# INLINE feedbackControlled #-} feedbackControlled ::- (Storable ch,- MakeValueTuple ch, ValueTuple ch ~ c,- Memory.C c) =>+ (Storable ch, MakeValueTuple ch, ValueTuple ch ~ c, Memory.C c) => Param.T p ch -> T p ((ctrl,a),c) b -> T p (ctrl,b) c -> T p (ctrl,a) b feedbackControlled initial forth back =- loop initial- (Arr.arr (fst.fst) &&& forth >>> Arr.arr snd &&& back)---fromModifier ::- (Value.Flatten ah, Value.Registers ah ~ al,- Value.Flatten bh, Value.Registers bh ~ bl,- Value.Flatten ch, Value.Registers ch ~ cl,- Value.Flatten sh, Value.Registers sh ~ sl,- Memory.C sl) =>- Modifier.Simple sh ch ah bh -> T p (cl,al) bl-fromModifier (Modifier.Simple initial step) =- mapAccumSimple- (\(c,a) s ->- Value.flatten $- runState- (step (Value.unfold c) (Value.unfold a))- (Value.unfold s))- (Value.flatten initial)+ loop initial (feedbackControlledAux forth back) {- | Run a causal process independently on each stereo channel. -} stereoFromMono ::+ (Phi a, Phi b, Undefined b) => T p a b -> T p (Stereo.T a) (Stereo.T b)-stereoFromMono =- Stereo.arrowFromMono+stereoFromMono (Cons next start stop createIOContext deleteIOContext) = Cons+ (stereoNext stop next)+ (stereoStart start)+ (stereoStop stop)+ (stereoCreate createIOContext createIOContext)+ (composeDelete deleteIOContext deleteIOContext) stereoFromMonoControlled ::+ (Phi a, Phi b, Phi c, Undefined b) => T p (c,a) b -> T p (c, Stereo.T a) (Stereo.T b)-stereoFromMonoControlled =- Stereo.arrowFromMonoControlled+stereoFromMonoControlled proc =+ stereoFromMono proc <<^ (\(c,sa) -> fmap ((,) c) sa) -stereoFromChannels ::- T p a b -> T p a b -> T p (Stereo.T a) (Stereo.T b)-stereoFromChannels =- Stereo.arrowFromChannels+stereoFromMonoParameterized ::+ (Phi a, Phi b, Undefined b) =>+ (forall q. Param.T q p -> Param.T q x -> T q a b) ->+ Param.T p (Stereo.T x) -> T p (Stereo.T a) (Stereo.T b)+stereoFromMonoParameterized f ps =+ case f (arr fst) (arr snd) of+ Cons next start stop createIOContext deleteIOContext -> Cons+ (stereoNext stop next)+ (stereoStart start)+ (stereoStop stop)+ (stereoCreate+ (\p -> createIOContext (p, Stereo.left $ Param.get ps p))+ (\p -> createIOContext (p, Stereo.right $ Param.get ps p)))+ (composeDelete deleteIOContext deleteIOContext) -{--In order to let this work we have to give the disable-mmx option somewhere,-but where?--}-stereoFromVector ::- (IsPrimitive a, IsPrimitive b) =>- T p (Value (Vector D2 a)) (Value (Vector D2 b)) ->- T p (Stereo.T (Value a)) (Stereo.T (Value b))-stereoFromVector proc =- mapSimple Frame.stereoFromVector <<<- proc <<<- mapSimple Frame.vectorFromStereo+stereoCreate ::+ Monad m =>+ (p -> m (ioContextA, context)) ->+ (p -> m (ioContextB, context)) ->+ p -> m ((ioContextA, ioContextB), Stereo.T context)+stereoCreate l r =+ liftM (mapSnd $ uncurry Stereo.cons) . composeCreate l r -vectorize ::- (Vector.C va, n ~ Vector.Size va, a ~ Vector.Element va,- Vector.C vb, n ~ Vector.Size vb, b ~ Vector.Element vb) =>- T p a b -> T p va vb-vectorize = vectorizeSize undefined+stereoNext ::+ (Phi a, Phi b, Phi c, Phi s, Phi context,+ Undefined b, Undefined s) =>+ (context -> s -> CodeGenFunction r ()) ->+ (forall z. (Phi z) => context -> a -> s -> MaybeCont.T r z (b, s)) ->+ Stereo.T context ->+ Stereo.T a ->+ Stereo.T s ->+ MaybeCont.T r c (Stereo.T b, Stereo.T s)+stereoNext stop next context a s0 = MaybeCont.fromMaybe $ do+ mbs1 <-+ twiceStereo+ (MaybeCont.toMaybe . uncurry3 next)+ (liftA3 (,,) context a s0) -{--insert and extract instructions will be in opposite order,-no matter whether we use foldr or foldl-and independent from the order of proc and channel in replaceChannel.-However, LLVM neglects the order anyway.--}-vectorizeSize ::- (Vector.C va, n ~ Vector.Size va, a ~ Vector.Element va,- Vector.C vb, n ~ Vector.Size vb, b ~ Vector.Element vb) =>- n -> T p a b -> T p va vb-vectorizeSize n proc =- foldl- (\acc i -> replaceChannel i proc acc)- (Arr.arr (const $ undefTuple)) $- List.take (TypeNum.fromIntegerT n) [0 ..]+ mbs2 <-+ if True+ then Maybe.lift2 Stereo.cons (Stereo.left mbs1) (Stereo.right mbs1)+ else MaybeCont.toMaybe $ traverse (MaybeCont.fromMaybe . return) mbs1 -{- |-Given a vector process, replace the i-th output by output-that is generated by a scalar process from the i-th input.--}-replaceChannel ::- (Vector.C va, n ~ Vector.Size va, a ~ Vector.Element va,- Vector.C vb, n ~ Vector.Size vb, b ~ Vector.Element vb) =>- Int -> T p a b -> T p va vb -> T p va vb-replaceChannel i channel proc =- let li = valueOf $ fromIntegral i- in zipWithSimple (Vector.insert li) <<<- (channel <<< mapSimple (Vector.extract li)) &&&- proc+ end <- Maybe.getIsNothing mbs2+ C.ifThen end () $+ sequence_ $+ liftA2+ (\mbsi c -> Maybe.for mbsi (stop c . snd))+ mbs1 context -{- |-Read the i-th element from each array.--}-arrayElement ::- (IsFirstClass a, LLVM.GetValue (LLVM.Array dim a) index,- LLVM.ValueType (LLVM.Array dim a) index ~ a,- TypeNum.NaturalT index, TypeNum.NaturalT dim,- (index :<: dim) ~ TypeBool.True) =>- index -> T p (Value (LLVM.Array dim a)) (Value a)-arrayElement i =- mapSimple (\array -> LLVM.extractvalue array i)+ return $ fmap unzip mbs2 -{- |-Read the i-th element from an aggregate type.--}-element ::- (IsFirstClass a, LLVM.GetValue agg index,- LLVM.ValueType agg index ~ a) =>- index -> T p (Value agg) (Value a)-element i =- mapSimple (\array -> LLVM.extractvalue array i)+stereoStart ::+ (Phi a, Phi b, Phi c, Undefined b, Undefined c) =>+ (a -> CodeGenFunction r (c, b)) ->+ Stereo.T a -> CodeGenFunction r (Stereo.T c, Stereo.T b)+stereoStart code a =+ fmap unzip $ twiceStereo code a +stereoStop ::+ (Phi context, Phi state) =>+ (context -> state -> CodeGenFunction r ()) ->+ Stereo.T context -> Stereo.T state -> CodeGenFunction r ()+stereoStop code c s = void $ twiceStereo (uncurry code) (liftA2 (,) c s) +twiceStereo ::+ (Phi a, Phi b, Undefined b) =>+ (a -> CodeGenFunction r b) ->+ Stereo.T a -> CodeGenFunction r (Stereo.T b)+twiceStereo code a =+ fmap (uncurry Stereo.cons) $+ twice code (Stereo.left a, Stereo.right a)++twice ::+ (Phi a, Phi b, Undefined b) =>+ (a -> CodeGenFunction r b) ->+ (a,a) -> CodeGenFunction r (b,b)+twice code a =+ fmap snd $+ C.fixedLengthLoop (valueOf (2::Int8)) (a, undefTuple) $+ \((a0,a1), (_,b1)) -> do+ b0 <- code a0+ return ((a1,a0), (b1,b0))++ {- | You may also use '(+)'. -}@@ -358,35 +445,21 @@ -} quantizeLift :: (Memory.C b,- Ring.C c,- IsFloating c, CmpRet c, CmpResult c ~ Bool,- Storable c, MakeValueTuple c, ValueTuple c ~ (Value c),- Memory.FirstClass c, Memory.Stored c ~ cm, IsSized c, IsSized cm,- IsConst c) =>+ Storable c, MakeValueTuple c, ValueTuple c ~ Value cl,+ SoV.IntegerConstant cl, IsFloating cl,+ LLVM.CmpRet cl, LLVM.CmpResult cl ~ Bool,+ Memory.FirstClass cl, Memory.Stored cl ~ cm, IsSized cm) => Param.T p c -> T p a b -> T p a b quantizeLift k- (Cons next start createIOContext deleteIOContext) = Cons- (\(kl,parameter) a0 bState0 -> do- ((b1,state1), ss1) <-- Maybe.fromBool $- C.whileLoop- (valueOf True, bState0)- (\(cont1, (_, ss0)) ->- and cont1 =<< A.fcmp FPOLE ss0 (value LLVM.zero))- (\(_,((_,state01), ss0)) ->- Maybe.toBool $ liftM2 (,)- (next parameter a0 state01)- (Maybe.lift $ A.add ss0 (Param.value k kl)))-- ss2 <- Maybe.lift $ A.sub ss1 (valueOf Ring.one)- return (b1, ((b1,state1),ss2)))- (fmap (\sa -> ((undefTuple, sa), value LLVM.zero)) . start)- (\p -> do- (ioContext, (nextParam, startParam)) <- createIOContext p- return (ioContext, ((Param.get k p, nextParam), startParam)))- deleteIOContext+ (Cons next start stop createIOContext deleteIOContext) =+ Param.with k $ \getK valueK -> Cons+ (\context a0 -> quantizeNext (flip next a0) valueK context)+ (quantizeStart start)+ (quantizeStop stop)+ (quantizeCreate createIOContext getK)+ (quantizeDelete deleteIOContext) {- |@@ -396,25 +469,35 @@ For FM synthesis we need also negative phase distortions, thus we use 'SoV.addToPhase' which supports that. -}-osciCore ::- (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized t, IsSized tm,- IsConst t, SoV.Fraction t, Additive.C t) =>+osciCore, _osciCore, osciCoreSync ::+ (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized tm,+ SoV.Fraction t) => T p (Value t, Value t) (Value t)-osciCore =+_osciCore = zipWithSimple SoV.addToPhase <<< Arr.second (mapAccumSimple (\a s -> do b <- SoV.incPhase a s return (s,b))- (return (valueOf Additive.zero)))--- this is in principle equivalent to mapAccumSimple,--- but needs more type constraints--- (loop Additive.zero (arr snd &&& zipWithSimple SoV.incPhase))+ (return A.zero)) +osciCoreSync =+ zipWithSimple SoV.addToPhase <<<+ Arr.second+ (mapAccumSimple+ (\a s -> do+ b <- SoV.incPhase a s+ return (b,b))+ (return A.zero))++osciCore =+ zipWithSimple SoV.addToPhase <<<+ Arr.second (loopZero (arr snd &&& zipWithSimple SoV.incPhase))+ osciSimple :: (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized t, IsSized tm,- IsConst t, SoV.Fraction t, Additive.C t) =>+ SoV.Fraction t) => (forall r. Value t -> CodeGenFunction r y) -> T p (Value t, Value t) y osciSimple wave =@@ -422,7 +505,7 @@ shapeModOsci :: (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized t, IsSized tm,- IsConst t, SoV.Fraction t, Additive.C t) =>+ SoV.Fraction t) => (forall r. c -> Value t -> CodeGenFunction r y) -> T p (c, (Value t, Value t)) y shapeModOsci wave =@@ -436,16 +519,22 @@ The initial value is needed in order to determine the ring buffer element type. -} delay ::- (Storable a,- MakeValueTuple a, ValueTuple a ~ al,- Memory.C al) =>+ (Storable a, MakeValueTuple a, ValueTuple a ~ al, Memory.C al) => Param.T p a -> Param.T p Int -> T p al al delay initial time = mapSimple RingBuffer.oldest <<< RingBuffer.track initial time +delayZero ::+ (Memory.C a, A.Additive a) =>+ Param.T p Int -> T p a a+delayZero time =+ mapSimple RingBuffer.oldest+ <<<+ RingBuffer.trackConst A.zero time + {- | Delay by one sample. For very small delay times (say up to 8)@@ -460,19 +549,58 @@ what you want. -} delay1 ::- (Storable a,- MakeValueTuple a, ValueTuple a ~ al,- Memory.C al) =>+ (Storable a, MakeValueTuple a, ValueTuple a ~ al, Memory.C al) => Param.T p a -> T p al al-delay1 initial =- loop initial (arr swap)+delay1 initial = loop initial (arr swap) +delay1Zero :: (Memory.C a, A.Additive a) => T p a a+delay1Zero = loopZero (arr swap) ++{- |+Delay by a variable amount of samples.+The momentum delay must be between @0@ and @maxTime@, inclusively.+-}+delayControlled ::+ (Storable a, MakeValueTuple a, ValueTuple a ~ al, Memory.C al) =>+ Param.T p a -> Param.T p Int -> T p (Value Word32, al) al+delayControlled initial maxTime =+ zipWithSimple RingBuffer.index+ <<<+ second (RingBuffer.track initial maxTime)++{- |+Delay by a variable fractional amount of samples.+Non-integer delays are achieved by linear interpolation.+The momentum delay must be between @0@ and @maxTime@, inclusively.+-}+delayControlledInterpolated ::+ (Interpolation.C nodes,+ Storable vh, MakeValueTuple vh, ValueTuple vh ~ v, Memory.C v,+ IsFloating a, LLVM.NumberOfElements a ~ TypeNum.D1) =>+ (forall r. Interpolation.T r nodes (Value a) v) ->+ Param.T p vh -> Param.T p Int -> T p (Value a, v) v+delayControlledInterpolated ip initial maxTime =+ let margin = Interpolation.toMargin ip+ in zipWithSimple+ (\del buf -> do+ let offset =+ A.fromInteger' $ fromIntegral $+ Interpolation.marginOffset margin+ n <- A.max offset =<< LLVM.fptoint del+ k <- A.sub del =<< LLVM.inttofp n+ m <- A.sub n offset+ ip k =<<+ Interpolation.indexNodes (flip RingBuffer.index buf) A.one m)+ <<<+ second+ (RingBuffer.track initial+ (fmap (Interpolation.marginNumber margin +) maxTime))++ differentiate :: (A.Additive al,- Storable a,- MakeValueTuple a, ValueTuple a ~ al,- Memory.C al) =>+ Storable a, MakeValueTuple a, ValueTuple a ~ al, Memory.C al) => Param.T p a -> T p al al differentiate initial = Cat.id - delay1 initial@@ -481,26 +609,22 @@ Delay time must be greater than zero! -} comb ::- (Ring.C a, Storable a,- IsArithmetic a, MakeValueTuple a, ValueTuple a ~ (Value a),- Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am) =>+ (A.PseudoRing al,+ Storable a, MakeValueTuple a, ValueTuple a ~ al, Memory.C al) => Param.T p a -> Param.T p Int ->- T p (Value a) (Value a)+ T p al al comb gain time =- let z = Additive.zero `asTypeOf` gain- in loop z (mix >>> (Cat.id &&&- (delay z (subtract 1 time) >>> amplify gain)))+ loopZero (mix >>> (Cat.id &&&+ (delayZero (subtract 1 time) >>> amplify gain))) combStereo ::- (Ring.C a, Storable a,- IsArithmetic a, MakeValueTuple a, ValueTuple a ~ (Value a),- Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am) =>+ (A.PseudoRing al,+ Storable a, MakeValueTuple a, ValueTuple a ~ al, Memory.C al) => Param.T p a -> Param.T p Int ->- T p (Stereo.T (Value a)) (Stereo.T (Value a))+ T p (Stereo.T al) (Stereo.T al) combStereo gain time =- let z = Additive.zero `asTypeOf` (liftA2 Stereo.cons gain gain)- in loop z (mix >>> (Cat.id &&&- (delay z (subtract 1 time) >>> amplifyStereo gain)))+ loopZero (mix >>> (Cat.id &&&+ (delayZero (subtract 1 time) >>> amplifyStereo gain))) {- | Example: apply a stereo reverb to a mono sound.@@ -510,24 +634,51 @@ > (Stereo.cons 42 23) -} reverb ::- (Field.C a, Random a, Storable a,- IsArithmetic a, MakeValueTuple a, ValueTuple a ~ (Value a),- Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am,+ (Random a,+ IsArithmetic a, SoV.RationalConstant a,+ MakeValueTuple a, ValueTuple a ~ (Value a),+ Storable a, Memory.FirstClass a, Memory.Stored a ~ am, IsSized am, RandomGen g) => g -> Int -> (a,a) -> (Int,Int) -> T p (Value a) (Value a) reverb rnd num gainRange timeRange =- amplify (return (recip (fromIntegral num) `asTypeOf` fst gainRange)) <<<+ mapSimple (A.mul (A.fromRational' $ recip $ fromIntegral num)) <<< (foldl (+) Cat.id $- List.take num $ List.map (\(g,t) -> comb $# g $# t) $- flip evalState rnd $- M.repeat $- liftM2 (,)- (state (randomR gainRange))- (state (randomR timeRange)))+ reverbParams rnd num gainRange timeRange) +reverbEfficient ::+ (Random a,+ SoV.PseudoModule a, SoV.Scalar a ~ s,+ IsFloating s, SoV.IntegerConstant s, LLVM.NumberOfElements s ~ D1,+ MakeValueTuple a, ValueTuple a ~ Value a,+ Storable a, Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,+ RandomGen g) =>+ Param.T p g -> Param.T p Int -> Param.T p (a,a) -> Param.T p (Int,Int) ->+ T p (Value a) (Value a)+reverbEfficient rnd num gainRange timeRange =+ map+ (\n x -> flip A.scale x =<< A.fdiv A.one =<< LLVM.inttofp n)+ (fmap (fromIntegral :: Int -> Word32) num)+ <<<+ replicateControlledParam+ (\_p p -> first (comb (fmap fst p) (fmap snd p)) >>> mix)+ (pure reverbParams <*> rnd <*> num <*> gainRange <*> timeRange)+ <<^+ (\a -> (a,a)) +reverbParams ::+ (RandomGen g, Random a) =>+ g -> Int -> (a, a) -> (Int, Int) -> [(a, Int)]+reverbParams rnd num gainRange timeRange =+ List.take num $+ flip evalState rnd $+ M.repeat $+ liftM2 (,)+ (MS.state (randomR gainRange))+ (MS.state (randomR timeRange))++ {- | This allows to compute a chain of equal processes efficiently, if all of these processes can be bundled in one vectorial process.@@ -557,28 +708,63 @@ (Vector.C v, a ~ Vector.Element v, Class.Zero v, Memory.C v) => T p v v -> T p a a-pipeline (Cons next start createIOContext deleteIOContext) = Cons- (\param a0 (v0,s0) -> do- (a1,v1) <- Maybe.lift $ Vector.shiftUp a0 v0- (v2,s2) <- next param v1 s0- return (a1, (v2,s2)))- (\p -> do- s <- start p- return (Class.zeroTuple, s))- createIOContext- deleteIOContext+pipeline = Causal.pipeline -linearInterpolation ::- (Ring.C a, IsArithmetic a, IsConst a) =>- Value a -> (Value a, Value a) -> CodeGenFunction r (Value a)-linearInterpolation r (a,b) = do- ra <- A.mul a =<< A.sub (valueOf one) r- rb <- A.mul b r- A.add ra rb+{- |+Feeds a signal into a causal process while holding or skipping signal elements+according to the process input.+The skip happens after a value is passed from the fed signal. +@skip x $* 0@ repeats the first signal value in the output.+@skip x $* 1@ feeds the signal to the output as is.+@skip x $* 2@ feeds the signal to the output with double speed.+-}+skip ::+ (Undefined v, Phi v, Memory.C v) =>+ Sig.T p v -> T p (Value Word32) v+skip (Sig.Cons next start stop createIOContext deleteIOContext) =+ Cons+ (\context n1 (yState0,n0) -> do+ (y,state1) <-+ MaybeCont.fromMaybe $ fmap snd $+ MaybeCont.fixedLengthLoop n0 yState0 $+ next context . snd+ return (y, ((y,state1),n1)))+ (withStart start $ \s -> return ((undefTuple, s), A.one))+ (\context ((_y,state),_k) -> stop context state)+ createIOContext+ deleteIOContext {- |+Like 'skip' but does not require @Memory@ constraint on the result type.+This way it can be used on a stream of ring buffer states.+The downside is that the result is recomputed (from the previous state)+at every step.++Warning:+This process is actually unsafe.+It fails on signal generators that use mutable variables,+like Signal.storableVectorLazy.+-}+_skipVolatile ::+ Sig.T p v -> T p (Value Word32) v+_skipVolatile (Sig.Cons next start stop createIOContext deleteIOContext) =+ Cons+ (\context n state0 -> do+ y <- fmap fst $ next context state0+ state1 <-+ MaybeCont.fromMaybe $ fmap snd $+ MaybeCont.fixedLengthLoop n state0 $+ fmap snd . next context+ return (y, state1))+ (withStart start return)+ stop+ createIOContext+ deleteIOContext+++{- | > frequencyModulationLinear signal is a causal process mapping from a shrinking factor@@ -589,40 +775,69 @@ The shrinking factor must be non-negative. -} frequencyModulationLinear ::- (-- Memory.C a,- Ring.C a,- IsFloating a, CmpRet a, CmpResult a ~ Bool,- Storable a, MakeValueTuple a, ValueTuple a ~ (Value a),- Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am,- IsConst a) =>+ (SoV.IntegerConstant a, IsFloating a, LLVM.CmpRet a, LLVM.CmpResult a ~ Bool,+ Memory.FirstClass a, Memory.Stored a ~ am, IsSized am) => Sig.T p (Value a) -> T p (Value a) (Value a)-frequencyModulationLinear- (Sig.Cons next start createIOContext deleteIOContext) =+frequencyModulationLinear xs =+ frequencyModulation Interpolation.linear (adjacentNodes02 xs)++frequencyModulation ::+ (SoV.IntegerConstant a, IsFloating a, LLVM.CmpRet a, LLVM.CmpResult a ~ Bool,+ Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,+ Undefined nodes, Phi nodes, Memory.C nodes) =>+ (forall r. Value a -> nodes -> CodeGenFunction r v) ->+ Sig.T p nodes -> T p (Value a) v+frequencyModulation ip+ (Sig.Cons next start stop createIOContext deleteIOContext) = Cons- (\parameter k yState0 -> do- (((y02,y12),state2), ss2) <-- Maybe.fromBool $+ (\context k yState0 -> do+ ((nodes2,state2), ss2) <-+ MaybeCont.fromBool $ C.whileLoop (valueOf True, yState0) (\(cont0, (_, ss0)) ->- and cont0 =<< A.fcmp FPOGE ss0 (valueOf Ring.one))- (\(_,(((_,y01),state0), ss0)) ->- Maybe.toBool $ liftM2 (,)- (do (y11,state1) <- next parameter state0- return ((y01,y11),state1))- (Maybe.lift $ A.sub ss0 (valueOf Ring.one)))+ LLVM.and cont0 =<< A.fcmp LLVM.FPOGE ss0 A.one)+ (\(_,((_,state0), ss0)) ->+ MaybeCont.toBool $ liftM2 (,)+ (next context state0)+ (MaybeCont.lift $ A.sub ss0 A.one)) - Maybe.lift $ do- y <- linearInterpolation ss2 (y02,y12)+ MaybeCont.lift $ do+ y <- ip ss2 nodes2 ss3 <- A.add ss2 k- return (y, (((y02,y12),state2),ss3)))- (\p -> do- sa <- start p- return (((value undef, value undef), sa), valueOf 2))+ return (y, ((nodes2, state2), ss3)))+ (withStart start $ \sa ->+ return ((undefTuple, sa), A.fromInteger' 1))+ (\context ((_y01,state),_ss) -> stop context state) createIOContext deleteIOContext +adjacentNodes02 ::+ (Memory.C a, Undefined a) =>+ Sig.T p a -> Sig.T p (Interpolation.Nodes02 a)+adjacentNodes02 xs =+ Sig.tail+ (mapAccumSimple+ (\new old -> return (Interpolation.Nodes02 old new, new))+ (return undefTuple)+ $*+ xs) +adjacentNodes13 ::+ (MakeValueTuple ah, Storable ah, ValueTuple ah ~ a,+ Memory.C a, Undefined a) =>+ Param.T p ah -> Sig.T p a -> Sig.T p (Interpolation.Nodes13 a)+adjacentNodes13 yp0 xs =+ Sig.tail $ Sig.tail+ (mapAccum+ (\() new (x0, x1, x2) ->+ return (Interpolation.Nodes13 x0 x1 x2 new, (x1, x2, new)))+ (\y0 -> return (undefTuple, undefTuple, Param.value yp0 y0))+ (pure ()) yp0+ $*+ xs)++ {- | @trigger fill signal@ send @signal@ to the output and restart it whenever the Boolean process input is 'True'.@@ -641,19 +856,24 @@ Param.T p a -> Sig.T p al -> T p (Value Bool) al-trigger fill (Sig.Cons next start createIOContext deleteIOContext) = Cons- (\(nextParam, startParam, f) b0 (active0, s0) -> Maybe.lift $ do- (active1,s1) <-- C.ifThen b0 (active0,s0)- (fmap ((,) (valueOf False)) $ start startParam)- (active2,(a2,s2)) <-- Maybe.toBool $ Maybe.guard active1 >> next nextParam s1- a3 <- C.select active2 a2 (Param.value fill f)- return (a3,(active2,s2)))- (\() -> return (valueOf False, undefTuple))+trigger fill (Sig.Cons next start stop createIOContext deleteIOContext) =+ Param.with fill $ \getFill valueFill -> Cons+ (\(param, f) b0 mcs0 -> MaybeCont.lift $ do+ mcs1 <-+ C.ifThen b0 mcs0 $+ Maybe.for mcs0 (uncurry stop)+ >>+ fmap Maybe.just (start param)+ mcas2 <-+ Maybe.run mcs1 (return Maybe.nothing) $ \(c1,s1) ->+ MaybeCont.toMaybe $ fmap ((,) c1) $ next c1 s1+ a3 <- Maybe.select (fmap (fst.snd) mcas2) (valueFill f)+ return (a3, fmap (mapSnd snd) mcas2))+ (\pf -> return (pf, Maybe.nothing))+ (\ _pf -> flip Maybe.for $ uncurry stop) (\p -> do- (context, (nextParam, startParam)) <- createIOContext p- return (context, ((nextParam, startParam, Param.get fill p), ())))+ (context, param) <- createIOContext p+ return (context, (param, getFill p))) deleteIOContext @@ -679,20 +899,21 @@ Storable b, MakeValueTuple b, ValueTuple b ~ valueB, Memory.C valueB) => T p valueA valueB -> IO (p -> SV.Vector a -> SV.Vector b)-runStorable (Cons next start createIOContext deleteIOContext) = do+runStorable (Cons next start stop createIOContext deleteIOContext) = do fill <- fmap derefFillPtr $ Exec.compileModule $ createNamedFunction ExternalLinkage "fillprocessblock" $ \paramPtr size alPtr blPtr -> do- (nextParam,startParam) <- Memory.load paramPtr- s <- start startParam- (pos,_) <- Maybe.arrayLoop2 size alPtr blPtr s $+ param <- Memory.load paramPtr+ (c,s) <- start param+ (pos,msExit) <- MaybeCont.arrayLoop2 size alPtr blPtr s $ \ aPtri bPtri s0 -> do- a <- Maybe.lift $ Memory.load aPtri- (b,s1) <- next nextParam a s0- Maybe.lift $ Memory.store b bPtri+ a <- MaybeCont.lift $ Memory.load aPtri+ (b,s1) <- next c a s0+ MaybeCont.lift $ Memory.store b bPtri return s1+ Maybe.for msExit $ stop c ret (pos :: Value Word32) return $ \p as ->@@ -718,61 +939,71 @@ foreign import ccall safe "dynamic" derefChunkPtr ::- Exec.Importer (Ptr nextParamStruct -> Ptr stateStruct -> Word32 ->+ Exec.Importer (Ptr contextStateStruct -> Word32 -> Ptr structA -> Ptr structB -> IO Word32) compileChunky :: (Memory.C valueA, Memory.Struct valueA ~ structA, Memory.C valueB, Memory.Struct valueB ~ structB,- Memory.C state, Memory.Struct state ~ stateStruct,- Memory.C startParamValue, Memory.Struct startParamValue ~ startParamStruct,- Memory.C nextParamValue, Memory.Struct nextParamValue ~ nextParamStruct) =>- (forall r.- nextParamValue ->+ Memory.C parameters, Memory.Struct parameters ~ paramStruct,+ Memory.C context, Memory.C state,+ Memory.Struct (context, Maybe.T state) ~ contextStateStruct) =>+ (forall r z.+ (Phi z) =>+ context -> valueA -> state ->- Maybe.T r (Value Bool, (Value (Ptr structB), state)) (valueB, state)) ->+ MaybeCont.T r z (valueB, state)) -> (forall r.- startParamValue ->- CodeGenFunction r state) ->- IO (FunPtr (Ptr startParamStruct -> IO (Ptr stateStruct)),- FunPtr (Ptr stateStruct -> IO ()),- FunPtr (Ptr nextParamStruct -> Ptr stateStruct -> Word32 ->+ parameters ->+ CodeGenFunction r (context, state)) ->+ (forall r.+ context -> state ->+ CodeGenFunction r ()) ->+ IO (FunPtr (Ptr paramStruct -> IO (Ptr contextStateStruct)),+ FunPtr (Ptr contextStateStruct -> IO ()),+ FunPtr (Ptr contextStateStruct -> Word32 -> Ptr structA -> Ptr structB -> IO Word32))-compileChunky next start =+compileChunky next start stop = Exec.compileModule $ liftM3 (,,) (createNamedFunction ExternalLinkage "startprocess" $ \paramPtr -> do pptr <- LLVM.malloc- flip Memory.store pptr =<< start =<< Memory.load paramPtr+ flip Memory.store pptr . mapSnd Maybe.just =<< start =<< Memory.load paramPtr ret pptr) (createNamedFunction ExternalLinkage "stopprocess" $- \ pptr -> LLVM.free pptr >> ret ())+ \ contextStatePtr -> do+ (c,ms) <- Memory.load contextStatePtr+ Maybe.for ms $ stop c+ LLVM.free contextStatePtr+ ret ()) (createNamedFunction ExternalLinkage "fillprocess" $- \ paramPtr sptr loopLen aPtr bPtr -> do- param <- Memory.load paramPtr- sInit <- Memory.load sptr- (pos,sExit) <- Maybe.arrayLoop2 loopLen aPtr bPtr sInit $- \ aPtri bPtri s0 -> do- a <- Maybe.lift $ Memory.load aPtri+ \ contextStatePtr loopLen aPtr bPtr -> do+ (param, msInit) <- Memory.load contextStatePtr+ (pos,msExit) <-+ Maybe.run msInit (return (A.zero, Maybe.nothing)) $ \sInit ->+ MaybeCont.arrayLoop2 loopLen aPtr bPtr sInit $+ \ aPtri bPtri s0 -> do+ a <- MaybeCont.lift $ Memory.load aPtri (b,s1) <- next param a s0- Maybe.lift $ Memory.store b bPtri+ MaybeCont.lift $ Memory.store b bPtri return s1- Memory.store sExit sptr+ sptr <- LLVM.getElementPtr0 contextStatePtr (TypeNum.d1, ())+ Memory.store msExit sptr ret (pos :: Value Word32)) foreign import ccall safe "dynamic" derefStartParamPtr ::- Exec.Importer (Ptr startParamStruct -> IO (Ptr stateStruct))+ Exec.Importer (Ptr paramStruct -> IO (Ptr contextStateStruct)) foreign import ccall safe "dynamic" derefStopPtr ::- Exec.Importer (Ptr stateStruct -> IO ())+ Exec.Importer (Ptr contextStateStruct -> IO ()) compilePlugged ::- (Memory.C state, Memory.Struct state ~ stateStruct,- Memory.C startParamValue, Memory.Struct startParamValue ~ startParamStruct,- Memory.C nextParamValue, Memory.Struct nextParamValue ~ nextParamStruct,+ (Memory.C parameters, Memory.Struct parameters ~ paramStruct,+ Memory.C context, Memory.C state,+ Memory.Struct (context, Maybe.T state) ~ contextStateStruct, Undefined stateIn, Phi stateIn, Undefined stateOut, Phi stateOut, Memory.C paramValueIn, Memory.Struct paramValueIn ~ paramStructIn,@@ -783,51 +1014,58 @@ (forall r. paramValueIn -> LLVM.CodeGenFunction r stateIn) ->- (forall r.- nextParamValue ->+ (forall r z.+ (Phi z) =>+ context -> valueA -> state ->- Maybe.T r- (Value Bool, (Value Word32, (stateIn, state, stateOut)))- (valueB, state)) ->+ MaybeCont.T r z (valueB, state)) -> (forall r.- startParamValue ->- CodeGenFunction r state) ->+ parameters ->+ CodeGenFunction r (context, state)) -> (forall r.+ context -> state ->+ CodeGenFunction r ()) ->+ (forall r. paramValueOut -> valueB -> stateOut -> LLVM.CodeGenFunction r stateOut) -> (forall r. paramValueOut -> LLVM.CodeGenFunction r stateOut) ->- IO (FunPtr (Ptr startParamStruct -> IO (Ptr stateStruct)),- FunPtr (Ptr stateStruct -> IO ()),- FunPtr (Ptr nextParamStruct -> Ptr stateStruct -> Word32 ->+ IO (FunPtr (Ptr paramStruct -> IO (Ptr contextStateStruct)),+ FunPtr (Ptr contextStateStruct -> IO ()),+ FunPtr (Ptr contextStateStruct -> Word32 -> Ptr paramStructIn -> Ptr paramStructOut -> IO Word32))-compilePlugged nextIn startIn next start nextOut startOut =+compilePlugged nextIn startIn next start stop nextOut startOut = Exec.compileModule $ liftM3 (,,) (createNamedFunction ExternalLinkage "startprocess" $ \paramPtr -> do pptr <- LLVM.malloc- flip Memory.store pptr =<< start =<< Memory.load paramPtr+ flip Memory.store pptr . mapSnd Maybe.just =<< start =<< Memory.load paramPtr ret pptr) (createNamedFunction ExternalLinkage "stopprocess" $- \ pptr -> LLVM.free pptr >> ret ())+ \ contextStatePtr -> do+ (c,ms) <- Memory.load contextStatePtr+ Maybe.for ms $ stop c+ LLVM.free contextStatePtr+ ret ()) (createNamedFunction ExternalLinkage "fillprocess" $- \ paramPtr sptr loopLen inPtr outPtr -> do- param <- Memory.load paramPtr- sInit <- Memory.load sptr+ \ contextStatePtr loopLen inPtr outPtr -> do+ (param, msInit) <- Memory.load contextStatePtr inParam <- Memory.load inPtr outParam <- Memory.load outPtr inInit <- startIn inParam outInit <- startOut outParam- (pos,(_,sExit,_)) <-- Maybe.fixedLengthLoop loopLen (inInit, sInit, outInit) $- \ (in0,s0,out0) -> do- (a,in1) <- Maybe.lift $ nextIn inParam in0+ (pos,msExit) <-+ Maybe.run msInit (return (A.zero, Maybe.nothing)) $ \sInit ->+ MaybeCont.fixedLengthLoop loopLen (inInit, sInit, outInit) $+ \ (in0,s0,out0) -> do+ (a,in1) <- MaybeCont.lift $ nextIn inParam in0 (b,s1) <- next param a s0- out1 <- Maybe.lift $ nextOut outParam b out0+ out1 <- MaybeCont.lift $ nextOut outParam b out0 return (in1, s1, out1)- Memory.store sExit sptr+ sptr <- LLVM.getElementPtr0 contextStatePtr (TypeNum.d1, ())+ Memory.store (fmap snd3 msExit) sptr ret (pos :: Value Word32)) @@ -852,20 +1090,20 @@ IO ((SVL.Vector a -> SVL.Vector b) -> p -> SVL.Vector a -> SVL.Vector b)-runStorableChunkyCont (Cons next start createIOContext deleteIOContext) = do- (startFunc, stopFunc, fill) <- compileChunky next start+runStorableChunkyCont (Cons next start stop createIOContext deleteIOContext) = do+ (startFunc, stopFunc, fill) <- compileChunky next start stop return $ \ procRest p sig -> SVL.fromChunks $ Unsafe.performIO $ do- (ioContext, (nextParam, startParam)) <- createIOContext p+ (ioContext, param) <- createIOContext p when False $ DebugCnt.with DebugSt.dumpCounter $ do- DebugSt.dump "next-param" nextParam- DebugSt.dump "start-param" startParam+ DebugSt.dump "param" param - statePtr <- ForeignPtr.newParam stopFunc startFunc startParam- nextParamPtr <-- ForeignPtr.new (deleteIOContext ioContext) nextParam+ statePtr <- ForeignPtr.newParam stopFunc startFunc param+ concStatePtr <-+ withForeignPtr statePtr $+ flip FC.newForeignPtr (deleteIOContext ioContext) let go xt = Unsafe.interleaveIO $@@ -873,14 +1111,14 @@ [] -> return [] x:xs -> SVB.withStartPtr x $ \aPtr size -> do v <-- ForeignPtr.with nextParamPtr $ \nptr -> withForeignPtr statePtr $ \sptr -> SVB.createAndTrim size $ fmap fromIntegral .- derefChunkPtr fill nptr sptr+ derefChunkPtr fill sptr (fromIntegral size) (Memory.castStorablePtr aPtr) . Memory.castStorablePtr+ touchForeignPtr concStatePtr (if SV.length v > 0 then fmap (v:) else id) $@@ -933,21 +1171,19 @@ IO (p -> PIO.T a d) processIOCore (PIn.Cons nextIn startIn createIn deleteIn)- (Cons next start createIOContext deleteIOContext)+ (Cons next start stop createIOContext deleteIOContext) (POut.Cons nextOut startOut createOut deleteOut) = do (startFunc, stopFunc, fill) <-- compilePlugged nextIn startIn next start nextOut startOut+ compilePlugged nextIn startIn next start stop nextOut startOut return $ \p -> PIO.Cons- (\a s@(_, (nextParamPtr,statePtr)) -> do+ (\a s@(_, paramPtr) -> do let maximumSize = Cut.length a- nptr = Memory.castStorablePtr nextParamPtr- sptr = statePtr (contextIn, paramIn) <- createIn a (contextOut,paramOut) <- createOut maximumSize actualSize <- AllocUtil.with paramIn $ \inptr -> AllocUtil.with paramOut $ \outptr ->- derefChunkPtr fill nptr sptr+ derefChunkPtr fill paramPtr (fromIntegral maximumSize) (Memory.castStorablePtr inptr) (Memory.castStorablePtr outptr)@@ -955,22 +1191,18 @@ b <- deleteOut (fromIntegral actualSize) contextOut return (b, s)) (do- (ioContext, (nextParam, startParam)) <- createIOContext p+ (ioContext, param) <- createIOContext p when False $ DebugCnt.with DebugSt.dumpCounter $ do- DebugSt.dump "next-param" nextParam- DebugSt.dump "start-param" startParam+ DebugSt.dump "param" param - nextParamPtr <- Alloc.malloc- poke nextParamPtr nextParam- statePtr <-- AllocUtil.with startParam+ contextStatePtr <-+ AllocUtil.with param (derefStartParamPtr startFunc . Memory.castStorablePtr) - return (ioContext, (nextParamPtr, statePtr)))- (\(ioContext, (nextParamPtr,statePtr)) -> do- derefStopPtr stopFunc statePtr- Alloc.free nextParamPtr+ return (ioContext, contextStatePtr))+ (\(ioContext, contextStatePtr) -> do+ derefStopPtr stopFunc contextStatePtr deleteIOContext ioContext) processIO ::
src/Synthesizer/LLVM/CausalParameterized/ProcessPacked.hs view
@@ -8,7 +8,8 @@ module Synthesizer.LLVM.CausalParameterized.ProcessPacked where import Synthesizer.LLVM.CausalParameterized.Process (T(Cons), )-import qualified Synthesizer.LLVM.CausalParameterized.Process as Causal+import Synthesizer.LLVM.Parameterized.SignalPrivate (withStart, )+import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Parameter as Param import qualified Synthesizer.LLVM.Frame as Frame import qualified Synthesizer.LLVM.Frame.SerialVector as Serial@@ -21,22 +22,23 @@ import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Control as C-import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, undefTuple, )+import LLVM.Extra.Class (MakeValueTuple, ValueTuple, undefTuple, ) -import LLVM.Core as LLVM+import qualified LLVM.Core as LLVM+import LLVM.Core+ (CodeGenFunction, Value, valueOf,+ IsSized, IsArithmetic,+ IsPrimitive, IsFirstClass, ) import qualified Types.Data.Bool as TypeBool import qualified Types.Data.Num as TypeNum-import Types.Data.Num.Ops ((:*:), ) import Types.Data.Ord ((:<:), ) import qualified Control.Monad.Trans.Class as MT import qualified Control.Monad.Trans.State as MS import qualified Control.Category as Cat import qualified Control.Arrow as Arr-import Control.Arrow ((^<<), (<<<), )--import qualified Algebra.Additive as Additive+import Control.Arrow ((<<<), ) import Data.Tuple.HT (swap, ) @@ -57,7 +59,7 @@ (Serial.Read va, n ~ Serial.Size va, a ~ Serial.Element va, Serial.C vb, n ~ Serial.Size vb, b ~ Serial.Element vb) => T p a b -> T p va vb-pack (Cons next start createIOContext deleteIOContext) = Cons+pack (Cons next start stop createIOContext deleteIOContext) = Cons (\param a s -> do r <- Maybe.lift $ Serial.readStart a ((_,w2),(_,s2)) <-@@ -65,10 +67,11 @@ C.whileLoop (valueOf True, let w = undefTuple- in ((r,w), (valueOf $ (fromIntegral $ Serial.sizeOfIterator w :: Word32), s)))+ in ((r,w),+ (valueOf (fromIntegral $ Serial.sizeOfIterator w :: Word32), s))) (\(cont,(_rw0,(i0,_s0))) -> A.and cont =<<- A.cmp CmpGT i0 (value LLVM.zero))+ A.cmp LLVM.CmpGT i0 A.zero) (\(_,((r0,w0),(i0,s0))) -> Maybe.toBool $ do (ai,r1) <- Maybe.lift $ Serial.readNext r0 (bi,s1) <- next param ai s0@@ -79,6 +82,7 @@ b <- Maybe.lift $ Serial.writeStop w2 return (b, s2)) start+ stop createIOContext deleteIOContext @@ -92,7 +96,7 @@ (Serial.Read va, n ~ Serial.Size va, a ~ Serial.Element va, Serial.C vb, n ~ Serial.Size vb, b ~ Serial.Element vb) => T p a b -> T p va vb-packSmall (Cons next start createIOContext deleteIOContext) = Cons+packSmall (Cons next start stop createIOContext deleteIOContext) = Cons (\param a -> MS.runStateT $ (MT.lift . Maybe.lift . Serial.assemble)@@ -101,6 +105,7 @@ =<< (MT.lift $ Maybe.lift $ Serial.extractAll a)) start+ stop createIOContext deleteIOContext @@ -118,9 +123,9 @@ Memory.C va, Memory.C vb) => T p va vb -> T p a b-unpack (Cons next start createIOContext deleteIOContext) = Cons+unpack (Cons next start stop createIOContext deleteIOContext) = Cons (\param ai ((w0,r0),(i0,s0)) -> do- endOfVector <- Maybe.lift $ A.cmp CmpEQ i0 (valueOf 0)+ endOfVector <- Maybe.lift $ A.cmp LLVM.CmpEQ i0 A.zero ((w2,r2),(i2,s2)) <- Maybe.fromBool $ C.ifThen endOfVector (valueOf True, ((w0,r0),(i0,s0))) $ do@@ -136,96 +141,83 @@ (bi,r3) <- Serial.readNext r2 i3 <- A.dec i2 return (bi, ((w3,r3),(i3,s2))))- (\p -> do- s <- start p+ (withStart start $ \s -> do w <- Serial.writeZero return ((w, Class.undefTuple), (valueOf (0::Word32), s)))+ (\context (_wr,(_i,state)) -> stop context state) createIOContext deleteIOContext raise ::- (Storable a, IsArithmetic a, IsConst a,+ (Storable a, IsArithmetic a, MakeValueTuple a, ValueTuple a ~ (Value a),- Memory.FirstClass a, Memory.Stored a ~ am,- IsPrimitive a, IsSized a, SizeOf a ~ as,- IsPrimitive am, IsSized am, SizeOf am ~ amsize,- TypeNum.PositiveT (n :*: as),- TypeNum.PositiveT (n :*: amsize),+ IsPrimitive a, Memory.FirstClass a,+ Memory.Stored a ~ am, IsSized am, TypeNum.PositiveT n) => Param.T p a -> T p (Serial.Value n a) (Serial.Value n a)-raise x =- Causal.map Frame.mix (Serial.replicate ^<< x)-+raise =+ CausalP.map+ (\x y -> Serial.upsample x >>= flip Frame.mix y) amplify ::- (Storable a, IsArithmetic a, IsConst a,+ (Storable a, IsArithmetic a, MakeValueTuple a, ValueTuple a ~ (Value a),- Memory.FirstClass a, Memory.Stored a ~ am,- IsPrimitive a, IsSized a, SizeOf a ~ as,- IsPrimitive am, IsSized am, SizeOf am ~ amsize,- TypeNum.PositiveT (n :*: as),- TypeNum.PositiveT (n :*: amsize),+ IsPrimitive a, Memory.FirstClass a,+ Memory.Stored a ~ am, IsSized am, TypeNum.PositiveT n) => Param.T p a -> T p (Serial.Value n a) (Serial.Value n a)-amplify p =- Causal.map Frame.amplifyMono (Serial.replicate ^<< p)+amplify =+ CausalP.map+ (\x y -> Serial.upsample x >>= flip Frame.amplifyMono y) amplifyStereo ::- (Storable a, IsArithmetic a, IsConst a,+ (Storable a, IsArithmetic a, MakeValueTuple a, ValueTuple a ~ (Value a),- Memory.FirstClass a, Memory.Stored a ~ am,- IsPrimitive a, IsSized a, SizeOf a ~ as,- IsPrimitive am, IsSized am, SizeOf am ~ amsize,- TypeNum.PositiveT (n :*: as),- TypeNum.PositiveT (n :*: amsize),+ IsPrimitive a, Memory.FirstClass a,+ Memory.Stored a ~ am, IsSized am, TypeNum.PositiveT n) => Param.T p a -> T p (Stereo.T (Serial.Value n a)) (Stereo.T (Serial.Value n a))-amplifyStereo p =- Causal.map Frame.amplifyStereo (Serial.replicate ^<< p)+amplifyStereo =+ CausalP.map+ (\x y -> Serial.upsample x >>= flip Frame.amplifyStereo y) osciCore :: (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized t, IsSized tm,- SoV.Fraction t, IsConst t,- Vector.Real t, IsPrimitive t,- TypeNum.PositiveT n,- Additive.C t) =>+ Vector.Real t, SoV.Fraction t, LLVM.IsFloating t,+ TypeNum.PositiveT n) => T p (Serial.Value n t, Serial.Value n t) (Serial.Value n t) osciCore =- Causal.zipWithSimple A.addToPhase <<<+ CausalP.zipWithSimple A.addToPhase <<< Arr.second- (Causal.mapAccumSimple+ (CausalP.mapAccumSimple (\a phase0 -> do (phase1,b1) <- Serial.cumulate phase0 a phase2 <- A.signedFraction phase1 return (b1,phase2))- (return (valueOf Additive.zero)))+ (return A.zero)) osciSimple :: (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized t, IsSized tm,- SoV.Fraction t, IsConst t,- Vector.Real t, IsPrimitive t,- TypeNum.PositiveT n,- Additive.C t) =>+ Vector.Real t, SoV.Fraction t, LLVM.IsFloating t,+ TypeNum.PositiveT n) => (forall r. Serial.Value n t -> CodeGenFunction r y) -> T p (Serial.Value n t, Serial.Value n t) y osciSimple wave =- Causal.mapSimple wave <<< osciCore+ CausalP.mapSimple wave <<< osciCore shapeModOsci :: (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized t, IsSized tm,- SoV.Fraction t, IsConst t,- Vector.Real t, IsPrimitive t,- TypeNum.PositiveT n,- Additive.C t) =>+ Vector.Real t, SoV.Fraction t, LLVM.IsFloating t,+ TypeNum.PositiveT n) => (forall r. c -> Serial.Value n t -> CodeGenFunction r y) -> T p (c, (Serial.Value n t, Serial.Value n t)) y shapeModOsci wave =- Causal.zipWithSimple wave <<< Arr.second osciCore+ CausalP.zipWithSimple wave <<< Arr.second osciCore delay1 ::@@ -235,8 +227,8 @@ Memory.C al) => Param.T p a -> T p va va delay1 initial =- Causal.loop initial $- Causal.mapSimple (fmap swap . uncurry Serial.shiftUp . swap)+ CausalP.loop initial $+ CausalP.mapSimple (fmap swap . uncurry Serial.shiftUp . swap) differentiate :: (Serial.C va, n ~ Serial.Size va, al ~ Serial.Element va,@@ -248,7 +240,21 @@ differentiate initial = Cat.id - delay1 initial +integrate ::+ (Storable a, MakeValueTuple a, ValueTuple a ~ Value a, Vector.Arithmetic a,+ Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,+ TypeNum.PositiveT n) =>+ Param.T p a ->+ T p (Serial.Value n a) (Serial.Value n a)+integrate =+ CausalP.mapAccum+ (\() a acc0 -> do+ (acc1,b) <- Serial.cumulate acc0 a+ return (b,acc1))+ return+ (return ()) + arrayElement :: (IsFirstClass a, LLVM.Value a ~ Serial.Element v, Serial.C v, LLVM.GetValue (LLVM.Array dim a) index,@@ -257,4 +263,4 @@ (index :<: dim) ~ TypeBool.True) => index -> T p (Value (LLVM.Array dim a)) v arrayElement i =- Causal.mapSimple Serial.upsample <<< Causal.arrayElement i+ CausalP.mapSimple Serial.upsample <<< CausalP.arrayElement i
src/Synthesizer/LLVM/CausalParameterized/ProcessPrivate.hs view
@@ -7,25 +7,38 @@ import qualified Synthesizer.LLVM.Parameterized.SignalPrivate as Sig import qualified Synthesizer.LLVM.Parameter as Param+import qualified Synthesizer.LLVM.Causal.Process as Causal+import Synthesizer.LLVM.Causal.ProcessPrivate (loopNext, ) +import qualified Synthesizer.Causal.Class as CausalClass++import qualified LLVM.Extra.Control as C import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.MaybeContinuation as Maybe+import qualified LLVM.Extra.MaybeContinuation as MaybeCont import qualified LLVM.Extra.Memory as Memory+import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, ) import qualified LLVM.Core as LLVM-import LLVM.Extra.Class (MakeValueTuple, ValueTuple, ) import LLVM.Util.Loop (Phi, )-import LLVM.Core (Value, valueOf, CodeGenFunction, )+import LLVM.Core (CodeGenFunction, Value, valueOf, ) +import Types.Data.Num (d1, )++import qualified Control.Monad.HT as M import qualified Control.Arrow as Arr import qualified Control.Category as Cat import Control.Arrow (arr, (^<<), (<<<), (&&&), )-import Control.Monad (liftM2, ) import Control.Applicative (Applicative, pure, (<*>), )+import Data.Tuple.HT (mapSnd, ) +import qualified Synthesizer.LLVM.Storable.Vector as SVU+import qualified Data.StorableVector as SV+ import Data.Word (Word32, ) import Foreign.Storable.Tuple () import Foreign.Storable (Storable, )+import Foreign.ForeignPtr (ForeignPtr, touchForeignPtr, )+import Foreign.Ptr (Ptr, ) import qualified Number.Ratio as Ratio import qualified Algebra.Field as Field@@ -33,31 +46,33 @@ import qualified Algebra.Additive as Additive import NumericPrelude.Numeric-import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, take, takeWhile, )+import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, take, takeWhile, init, ) import qualified Prelude as P data T p a b =- forall state ioContext startParamTuple nextParamTuple.- (Storable startParamTuple,- Storable nextParamTuple,- MakeValueTuple startParamTuple,- MakeValueTuple nextParamTuple,- Memory.C (ValueTuple startParamTuple),- Memory.C (ValueTuple nextParamTuple),+ forall context state ioContext parameters.+ (Storable parameters,+ MakeValueTuple parameters,+ Memory.C (ValueTuple parameters),+ Memory.C context, Memory.C state) => Cons (forall r c. (Phi c) =>- ValueTuple nextParamTuple ->- a -> state -> Maybe.T r c (b, state))+ context ->+ a -> state -> MaybeCont.T r c (b, state)) -- compute next value (forall r.- ValueTuple startParamTuple ->- CodeGenFunction r state)+ ValueTuple parameters ->+ CodeGenFunction r (context, state)) -- initial state- (p -> IO (ioContext, (nextParamTuple, startParamTuple)))+ (forall r.+ context -> state ->+ CodeGenFunction r ())+ -- cleanup+ (p -> IO (ioContext, parameters)) {- initialization from IO monad This will be run within Unsafe.performIO, so no observable In/Out actions please!@@ -65,41 +80,58 @@ (ioContext -> IO ()) -- finalization from IO monad, also run within Unsafe.performIO +instance CausalClass.C (T p) where+ type SignalOf (T p) = Sig.T p+ type ProcessOf (Sig.T p) = T p+ toSignal = toSignal+ fromSignal = fromSignal +instance Causal.C (T p) where+ simple next start =+ simple (\() -> next) (\() -> fmap ((,) ()) start) (pure ())++ loopConst init (Cons next start stop createIOContext deleteIOContext) =+ Cons+ (loopNext next)+ (fmap (mapSnd ((,) init)) . start)+ (loopStop stop)+ createIOContext+ deleteIOContext++ replicateControlled n = replicateControlled $ pure n++ simple ::- (Storable startParamTuple,- Storable nextParamTuple,- MakeValueTuple startParamTuple, ValueTuple startParamTuple ~ startParamValue,- MakeValueTuple nextParamTuple, ValueTuple nextParamTuple ~ nextParamValue,- Memory.C startParamValue,- Memory.C nextParamValue,+ (Storable parameters,+ MakeValueTuple parameters, ValueTuple parameters ~ paramValue,+ Memory.C paramValue,+ Memory.C context, Memory.C state) => (forall r c. (Phi c) =>- nextParamValue ->- a -> state -> Maybe.T r c (b, state)) ->+ context -> a -> state -> MaybeCont.T r c (b, state)) -> (forall r.- startParamValue ->- CodeGenFunction r state) ->- Param.T p nextParamTuple ->- Param.T p startParamTuple -> T p a b-simple f start selectParam initial = Cons- (f . Param.value selectParam)- (start . Param.value initial)- (return . (,) () . Param.get (selectParam &&& initial))- (const $ return ())+ paramValue ->+ CodeGenFunction r (context, state)) ->+ Param.T p parameters -> T p a b+simple f start param =+ Param.with param $ \get value -> Cons f+ (start . value)+ (const $ const $ return ())+ (return . (,) () . get)+ (const $ return ()) toSignal :: T p () a -> Sig.T p a-toSignal (Cons next start createIOContext deleteIOContext) = Sig.Cons- (\ioContext -> next ioContext ())- start+toSignal (Cons next start stop createIOContext deleteIOContext) = Sig.Cons+ (\p -> next p ())+ start stop createIOContext deleteIOContext fromSignal :: Sig.T p b -> T p a b-fromSignal (Sig.Cons next start createIOContext deleteIOContext) = Cons- (\ioContext _ -> next ioContext)- start+fromSignal (Sig.Cons next start stop createIOContext deleteIOContext) = Cons+ (\p _ -> next p)+ start stop createIOContext deleteIOContext @@ -114,9 +146,9 @@ T p a b mapAccum next start selectParamN selectParamS = simple- (\p a s -> Maybe.lift $ next p a s)- start- selectParamN selectParamS+ (\p a s -> MaybeCont.lift $ next p a s)+ (\(n,s) -> fmap ((,) n) $ start s)+ (selectParamN &&& selectParamS) map ::@@ -137,6 +169,14 @@ mapSimple f = map (const f) (return ()) +zipWith ::+ (Storable ph, MakeValueTuple ph, ValueTuple ph ~ pl, Memory.C pl) =>+ (forall r. pl -> a -> b -> CodeGenFunction r c) ->+ Param.T p ph ->+ T p (a,b) c+zipWith f =+ map (uncurry . f)+ zipWithSimple :: (forall r. a -> b -> CodeGenFunction r c) -> T p (a,b) c@@ -145,16 +185,13 @@ apply :: T p a b -> Sig.T p a -> Sig.T p b-apply proc sig =- toSignal (proc <<< fromSignal sig)+apply = CausalClass.apply feedFst :: Sig.T p a -> T p b (a,b)-feedFst sig =- fromSignal sig &&& Cat.id+feedFst = CausalClass.feedFst feedSnd :: Sig.T p a -> T p b (b,a)-feedSnd sig =- Cat.id &&& fromSignal sig+feedSnd = CausalClass.feedSnd {-@@ -164,37 +201,203 @@ -} compose :: T p a b -> T p b c -> T p a c compose- (Cons nextA startA createIOContextA deleteIOContextA)- (Cons nextB startB createIOContextB deleteIOContextB) =+ (Cons nextA startA stopA createIOContextA deleteIOContextA)+ (Cons nextB startB stopB createIOContextB deleteIOContextB) = Cons- (\(paramA, paramB) a (sa0,sb0) ->- do (b,sa1) <- nextA paramA a sa0- (c,sb1) <- nextB paramB b sb0- return (c, (sa1,sb1)))- (\(paramA, paramB) ->- liftM2 (,)- (startA paramA)- (startB paramB))- (\p -> do- (ca,(nextParamA,startParamA)) <- createIOContextA p- (cb,(nextParamB,startParamB)) <- createIOContextB p- return ((ca,cb),- ((nextParamA, nextParamB),- (startParamA, startParamB))))- (\(ca,cb) ->- deleteIOContextA ca >>- deleteIOContextB cb)+ (composeNext MaybeCont.onFail stopA stopB nextA nextB)+ (composeStart startA startB)+ (composeStop stopA stopB)+ (composeCreate createIOContextA createIOContextB)+ (composeDelete deleteIOContextA deleteIOContextB) +composeNext ::+ (Monad maybe) =>+ (forall x. code () -> maybe x -> maybe x) ->+ (contextA -> stateA -> code ()) ->+ (contextB -> stateB -> code ()) ->+ (contextA -> a -> stateA -> maybe (b, stateA)) ->+ (contextB -> b -> stateB -> maybe (c, stateB)) ->+ (contextA, contextB) ->+ a ->+ (stateA, stateB) ->+ maybe (c, (stateA, stateB))+composeNext onFail stopA stopB nextA nextB (paramA, paramB) a (sa0,sb0) = do+ (b,sa1) <-+ onFail (stopB paramB sb0) $+ nextA paramA a sa0+ (c,sb1) <-+ onFail (stopA paramA sa1) $+ nextB paramB b sb0+ return (c, (sa1,sb1)) +composeStart ::+ Monad m =>+ (paramA -> m (contextA, stateA)) ->+ (paramB -> m (contextB, stateB)) ->+ (paramA, paramB) -> m ((contextA, contextB), (stateA, stateB))+composeStart = Sig.combineStart++composeStop ::+ Monad m =>+ (contextA -> stateA -> m ()) ->+ (contextB -> stateB -> m ()) ->+ (contextA, contextB) -> (stateA, stateB) -> m ()+composeStop = Sig.combineStop++composeCreate ::+ Monad m =>+ (p -> m (ioContextA, contextA)) ->+ (p -> m (ioContextB, contextB)) ->+ p -> m ((ioContextA, ioContextB), (contextA, contextB))+composeCreate = Sig.combineCreate++composeDelete ::+ (Monad m) =>+ (ca -> m ()) -> (cb -> m ()) -> (ca, cb) -> m ()+composeDelete = Sig.combineDelete++ first :: T p b c -> T p (b, d) (c, d)-first (Cons next start createIOContext deleteIOContext) = Cons- (\ioContext (b,d) sa0 ->- do (c,sa1) <- next ioContext b sa0- return ((c,d), sa1))- start+first (Cons next start stop createIOContext deleteIOContext) = Cons+ (firstNext next) start stop createIOContext deleteIOContext +firstNext ::+ Monad m =>+ (context -> a -> s -> m (b, s)) ->+ context -> (a, c) -> s -> m ((b, c), s)+firstNext next context (b,d) sa0 = do+ (c,sa1) <- next context b sa0+ return ((c,d), sa1) ++{- |+serial replication++But you may also use it for a parallel replication, see 'replicateParallel'.+-}+replicateControlled ::+ (Undefined x, Phi x) =>+ Param.T p Int -> T p (c,x) x -> T p (c,x) x+replicateControlled n (Cons next start stop createIOContext deleteIOContext) =+ case Param.word32 n of+ n32 -> Cons+ (\(len, cs) ->+ replicateControlledNext next stop (Param.value n32 len, cs))+ (\(len, param) ->+ replicateControlledStart start (Param.value n32 len, param))+ (\(len, cs) ->+ replicateControlledStop stop (Param.value n32 len, cs))+ (\p ->+ replicateControlledCreate $+ M.replicate (Param.get n p) (createIOContext p))+ (replicateControlledDelete deleteIOContext)++replicateControlledNext ::+ (Memory.C context, Memory.C state,+ contextState ~+ LLVM.Struct (Memory.Struct context, (Memory.Struct state, ())),+ Phi z, Phi a, Undefined a) =>+ (forall z0. (Phi z0) =>+ context -> (ctrl, a) -> state ->+ MaybeCont.T r z0 (a, state)) ->+ (context -> state -> CodeGenFunction r ()) ->+ (Value Word32, Value (Ptr contextState)) ->+ (ctrl, a) ->+ () ->+ MaybeCont.T r z (a, ())+replicateControlledNext next stop (len, contextStates) (c,a) () =+ MaybeCont.fromMaybe $ fmap (\(_,ms) -> fmap (flip (,) ()) ms) $+ MaybeCont.arrayLoop len contextStates a $+ \contextStatePtr a0 -> do+ (context, s0) <- MaybeCont.lift $ Memory.load contextStatePtr+ (a1,s1) <-+ MaybeCont.onFail+ (replicateControlledStopExcept+ stop len contextStates contextStatePtr) $+ next context (c,a0) s0+ MaybeCont.lift $+ Memory.store s1 =<< LLVM.getElementPtr0 contextStatePtr (d1, ())+ return a1++replicateControlledStopExcept ::+ (Memory.C a, Memory.C b,+ ab ~ LLVM.Struct (Memory.Struct a, (Memory.Struct b, ()))) =>+ (a -> b -> CodeGenFunction r ()) ->+ Value Word32 ->+ Value (Ptr ab) ->+ Value (Ptr ab) ->+ CodeGenFunction r ()+replicateControlledStopExcept stop len contextStates contextStatePtr =+ C.arrayLoop len contextStates () $ \ptr () -> do+ b <- A.cmp LLVM.CmpNE ptr contextStatePtr+ C.ifThen b () $ uncurry stop =<< Memory.load ptr++_replicateControlledNext ::+ (Memory.C context, Memory.C state,+ contextState ~+ LLVM.Struct (Memory.Struct context, (Memory.Struct state, ())),+ Phi z, Phi a, Undefined a) =>+ (forall z0. (Phi z0) =>+ context -> (ctrl, a) -> state ->+ MaybeCont.T r z0 (a, state)) ->+ (Value Word32, Value (Ptr contextState)) ->+ (ctrl, a) ->+ () ->+ MaybeCont.T r z (a, ())+_replicateControlledNext next (len, contextStates) (c,a) () =+ fmap (flip (,) ()) $ MaybeCont.fromBool $ fmap snd $+ C.arrayLoopWithExit len contextStates (valueOf True, a) $+ \contextStatePtr (_,a0) -> do+ (context, s0) <- Memory.load contextStatePtr+ (cont, (a1,s1)) <- MaybeCont.toBool $ next context (c,a0) s0+ Memory.store s1 =<< LLVM.getElementPtr0 contextStatePtr (d1, ())+ return (cont, (cont,a1))++replicateControlledStart ::+ (Memory.C a, Memory.C b) =>+ (a -> CodeGenFunction r b) ->+ (Value Word32, Value (Ptr (Memory.Struct a))) ->+ CodeGenFunction r ((Value Word32, Value (Ptr (Memory.Struct b))), ())+replicateControlledStart start (len, params) = do+ contextStates <- LLVM.arrayMalloc len+ C.arrayLoop2 len params contextStates () $ \paramPtr statePtr () ->+ flip Memory.store statePtr =<< start =<< Memory.load paramPtr+ return ((len, contextStates), ())++replicateControlledStop ::+ (Memory.C a, Memory.C b,+ ab ~ LLVM.Struct (Memory.Struct a, (Memory.Struct b, ()))) =>+ (a -> b -> CodeGenFunction r ()) ->+ (Value Word32, Value (Ptr ab)) ->+ () ->+ CodeGenFunction r ()+replicateControlledStop stop (len, contextStates) () = do+ C.arrayLoop len contextStates () $ \contextStatePtr () ->+ uncurry stop =<< Memory.load contextStatePtr+ LLVM.free contextStates+++replicateControlledCreate ::+ (Monad m, MakeValueTuple b, Storable b, ValueTuple b ~ bl, Memory.C bl) =>+ m [(a, b)] ->+ m (([a], ForeignPtr b),+ (Word32, Ptr (Memory.Struct bl)))+replicateControlledCreate createIOContexts = do+ (ioContexts, params) <- M.lift unzip createIOContexts+ let (fptr, ptr, len) = SVU.unsafeToPointers $ SV.pack params+ return+ ((ioContexts, fptr),+ (fromIntegral len, ptr))++replicateControlledDelete ::+ (a -> IO ()) ->+ ([a], ForeignPtr b) -> IO ()+replicateControlledDelete deleteIOContext (ioContexts, fptr) = do+ mapM_ deleteIOContext ioContexts+ touchForeignPtr fptr++ instance Cat.Category (T p) where id = mapSimple return (.) = flip compose@@ -253,23 +456,22 @@ in a way that allows to access a result before creating the input. -} loop ::- (Storable ch,- MakeValueTuple ch, ValueTuple ch ~ c,- Memory.C c) =>- Param.T p ch -> T p (a,c) (b,c) -> T p a b-loop initial (Cons next start createIOContext deleteIOContext) =- Cons- (\p a0 (c0,s0) -> do- ((b1,c1), s1) <- next p (a0,c0) s0- return (b1,(c1,s1)))- (\(i,p) -> fmap ((,) (Param.value initial i)) $ start p)+ (Storable c, MakeValueTuple c, ValueTuple c ~ cl, Memory.C cl) =>+ Param.T p c -> T p (a,cl) (b,cl) -> T p a b+loop initial (Cons next start stop createIOContext deleteIOContext) =+ Param.with initial $ \getInitial valueInitial -> Cons+ (loopNext next)+ (\(i,p) -> fmap (mapSnd ((,) (valueInitial i))) $ start p)+ (loopStop stop) (\p -> do- (ctx,(nextParam,startParam)) <- createIOContext p- return (ctx,- (nextParam, (Param.get initial p, startParam))))+ (ctx, param) <- createIOContext p+ return (ctx, (getInitial p, param))) deleteIOContext +loopStop :: (context -> state -> m) -> context -> (c, state) -> m+loopStop stop ctx (_c,s) = stop ctx s + takeWhile :: (Storable ph, MakeValueTuple ph, ValueTuple ph ~ pl, Memory.C pl) => (forall r. pl -> a -> CodeGenFunction r (Value Bool)) ->@@ -277,11 +479,10 @@ T p a a takeWhile check selectParam = simple (\p a () -> do- Maybe.guard =<< Maybe.lift (check p a)+ MaybeCont.guard =<< MaybeCont.lift (check p a) return (a, ()))- return+ (\p -> return (p, ())) selectParam- (return ()) take ::@@ -289,7 +490,7 @@ T p a a take len = snd ^<<- takeWhile (const $ A.cmp LLVM.CmpLT (valueOf 0) . fst) (return ()) <<<+ takeWhile (const $ A.cmp LLVM.CmpLT A.zero . fst) (return ()) <<< feedFst (Sig.iterate (const A.dec) (return ()) ((fromIntegral :: Int -> Word32) . max 0 ^<< len))@@ -297,7 +498,7 @@ {- | The first output value is the initial value.-Thus 'integrate' delays by one sample compared with 'integrate0'.+Thus 'integrate' delays by one sample compared with 'integrateSync'. -} integrate :: (Storable a, A.Additive al,@@ -307,10 +508,10 @@ integrate = flip loop (arr snd &&& zipWithSimple A.add) -integrate0 ::+integrateSync :: (Storable a, A.Additive al, MakeValueTuple a, ValueTuple a ~ al, Memory.C al) => Param.T p a -> T p al al-integrate0 =+integrateSync = flip loop ((\a -> (a,a)) ^<< zipWithSimple A.add)
src/Synthesizer/LLVM/CausalParameterized/ProcessValue.hs view
@@ -8,22 +8,25 @@ -} module Synthesizer.LLVM.CausalParameterized.ProcessValue ( -- simple,- mapAccum, map, mapSimple,+ mapAccum, map, mapSimple, zipWith, zipWithSimple,+ takeWhile, ) where import Synthesizer.LLVM.CausalParameterized.ProcessPrivate (T, )-import qualified Synthesizer.LLVM.CausalParameterized.ProcessPrivate as Causal-import qualified Synthesizer.LLVM.Parameter as Param-+import qualified Synthesizer.LLVM.CausalParameterized.ProcessPrivate as CausalP+import qualified Synthesizer.LLVM.Causal.ProcessValue as CausalV import qualified Synthesizer.LLVM.Simple.Value as Value+import qualified Synthesizer.LLVM.Parameter as Param import qualified LLVM.Extra.Memory as Memory import LLVM.Extra.Class (MakeValueTuple, ValueTuple, ) +import qualified LLVM.Core as LLVM+ import Foreign.Storable.Tuple () import Foreign.Storable (Storable, ) -import Prelude hiding (map, )+import Prelude hiding (map, zipWith, takeWhile, ) {-@@ -41,7 +44,7 @@ Param.T p nextParamTuple -> Param.T p startParamTuple -> T p a b simple f start =- Causal.simple+ CausalP.simple (\p a s -> Value.flattenMaybe $ next@@ -56,14 +59,25 @@ (Value.T pl -> Value.T a -> Value.T b) -> Param.T p ph -> T p a b-map f = Causal.map (Value.unlift2 f)+map f = CausalP.map (Value.unlift2 f) mapSimple :: (Value.T a -> Value.T b) -> T p a b-mapSimple f =- Causal.mapSimple (Value.unlift1 f)+mapSimple = CausalV.map +zipWith ::+ (Storable ph, MakeValueTuple ph, ValueTuple ph ~ pl, Memory.C pl) =>+ (Value.T pl -> Value.T a -> Value.T b -> Value.T c) ->+ Param.T p ph -> T p (a,b) c+zipWith f =+ CausalP.zipWith (Value.unlift3 f)++zipWithSimple ::+ (Value.T a -> Value.T b -> Value.T c) ->+ T p (a,b) c+zipWithSimple = CausalV.zipWith+ mapAccum :: (Storable pnh, MakeValueTuple pnh, ValueTuple pnh ~ pnl, Memory.C pnl, Storable psh, MakeValueTuple psh, ValueTuple psh ~ psl, Memory.C psl,@@ -74,11 +88,14 @@ Param.T p psh -> T p a b mapAccum next start =- Causal.mapAccum- (\p a s ->- Value.flatten $- next- (Value.constantValue p)- (Value.constantValue a)- (Value.constantValue s))+ CausalP.mapAccum+ (Value.unlift3 next) (Value.unlift1 start)++takeWhile ::+ (Storable ph, MakeValueTuple ph, ValueTuple ph ~ pl, Memory.C pl) =>+ (Value.T pl -> Value.T a -> Value.T (LLVM.Value Bool)) ->+ Param.T p ph ->+ T p a a+takeWhile check =+ CausalP.takeWhile (Value.unlift2 check)
src/Synthesizer/LLVM/ConstantPiece.hs view
@@ -33,12 +33,10 @@ import Data.Word (Word32, ) import Foreign.Storable.Tuple () import Foreign.Storable (Storable, )-import Foreign.Ptr (Ptr, )-import qualified Synthesizer.LLVM.Alloc as Alloc import Control.Applicative (liftA2, ) -import NumericPrelude.Numeric+import NumericPrelude.Numeric () import NumericPrelude.Base @@ -82,21 +80,20 @@ (Memory.C value) => SigP.T p (T value) -> SigP.T p value-flatten (SigP.Cons next start createIOContext deleteIOContext) =+flatten (SigP.Cons next start stop createIOContext deleteIOContext) = SigP.Cons- (\nextParam state0 -> do+ (\context state0 -> do (Cons length1 y1, s1) <- Maybe.fromBool $ whileLoop (valueOf True, state0) (\(cont, (Cons len _y, _s)) ->- LLVM.and cont =<< A.cmp LLVM.CmpEQ len (valueOf 0))+ LLVM.and cont =<< A.cmp LLVM.CmpEQ len A.zero) (\(_cont, (Cons _len _y, s)) ->- Maybe.toBool $ next nextParam s)+ Maybe.toBool $ next context s) length2 <- Maybe.lift (A.dec length1) return (y1, (Cons length2 y1, s1)))- (\startParam ->- fmap ((,) (Cons (valueOf 0) undefTuple)) $- start startParam)+ (SigP.withStart start (return . ((,) (Cons A.zero undefTuple))))+ (\context (_, state) -> stop context state) createIOContext deleteIOContext @@ -105,29 +102,21 @@ Param.T p (EventList.T NonNeg.Int a) -> SigP.T p (T value) piecewiseConstant evs = SigP.Cons- (\(stable, yPtr) () -> do+ (\stable () -> do+ yPtr <- Maybe.lift $ LLVM.alloca len <- Maybe.lift $ do nextFn <- LLVM.staticFunction EventIt.nextCallBack LLVM.call nextFn stable yPtr Maybe.guard =<<- Maybe.lift (A.cmp LLVM.CmpNE len (valueOf 0))+ Maybe.lift (A.cmp LLVM.CmpNE len A.zero) y <- Maybe.lift $ Memory.load yPtr return (Cons len y, ())) return+ (const $ const $ return ()) (\p -> do stable <- EventIt.new (Param.get evs p)- yPtr <- Alloc.malloc- return ((stable, asTypeOfEventListElement yPtr evs),- ((stable, Memory.castStorablePtr yPtr), ())))- (\(stable,yPtr) -> do- EventIt.dispose stable- Alloc.free yPtr)--asTypeOfEventListElement ::- Ptr a ->- Param.T p (EventList.T NonNeg.Int a) ->- Ptr a-asTypeOfEventListElement ptr _ = ptr+ return (stable, (stable, ())))+ EventIt.dispose lazySize ::@@ -139,9 +128,10 @@ nextFn <- LLVM.staticFunction SizeIt.nextCallBack LLVM.call nextFn stable Maybe.guard =<<- Maybe.lift (A.cmp LLVM.CmpNE len (valueOf 0))+ Maybe.lift (A.cmp LLVM.CmpNE len A.zero) return (Cons len (), ())) return+ (const $ const $ return ()) (\p -> do stable <- SizeIt.new (Param.get size p) return (stable, (stable, ())))
src/Synthesizer/LLVM/EventIterator.hs view
@@ -1,10 +1,14 @@ {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ForeignFunctionInterface #-} module Synthesizer.LLVM.EventIterator where import qualified Data.EventList.Relative.BodyTime as EventList import qualified Numeric.NonNegative.Wrapper as NonNeg +import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Class as Class+ import Data.Word (Word32, ) import Foreign.Storable (Storable, poke, ) import Foreign.Ptr (Ptr, castPtr, )@@ -18,24 +22,27 @@ import qualified Synthesizer.LLVM.Debug.StablePtr as DebugStable -data T =- forall a. Storable a =>- Cons (IORef (EventList.T NonNeg.Int a))- {--For problems about Storable constraint, see ChunkIterator.+For problems on constraints, see ChunkIterator. -}+data T a =+ (Storable a, Class.MakeValueTuple a, Memory.C (Class.ValueTuple a)) =>+ Cons (IORef (EventList.T NonNeg.Int a))++type MemoryPtr a = Ptr (Memory.Struct (Class.ValueTuple a))++ foreign import ccall "&nextConstant" nextCallBack :: FunPtr (- StablePtr T ->- Ptr a -> IO Word32+ StablePtr (T a) ->+ MemoryPtr a -> IO Word32 ) foreign export ccall "nextConstant" next ::- StablePtr T ->- Ptr a -> IO Word32+ StablePtr (T a) ->+ MemoryPtr a -> IO Word32 {- |@@ -44,8 +51,8 @@ say below 100). -} new ::- Storable a =>- EventList.T NonNeg.Int a -> IO (StablePtr T)+ (Storable a, Class.MakeValueTuple a, Memory.C (Class.ValueTuple a)) =>+ EventList.T NonNeg.Int a -> IO (StablePtr (T a)) new evs = DebugStable.trace "new" =<< newStablePtr . Cons@@ -55,12 +62,12 @@ EventList.toPairList evs) dispose ::- StablePtr T -> IO ()+ StablePtr (T a) -> IO () dispose = freeStablePtr <=< DebugStable.trace "dispose" next ::- StablePtr T ->- Ptr a -> IO Word32+ StablePtr (T a) ->+ MemoryPtr a -> IO Word32 next stable eventPtr = DebugStable.trace "next" stable >>= deRefStablePtr >>= \state ->
src/Synthesizer/LLVM/Filter/Allpass.hs view
@@ -3,10 +3,16 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveTraversable #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Synthesizer.LLVM.Filter.Allpass ( Parameter, parameter, CascadeParameter, flangerParameter, flangerParameterPlain,+ causal, cascade, phaser,+ cascadePipeline, phaserPipeline,+ causalPacked, cascadePacked, phaserPacked,+ causalP, cascadeP, phaserP, cascadePipelineP, phaserPipelineP, causalPackedP, cascadePackedP, phaserPackedP,@@ -21,6 +27,8 @@ import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.CausalParameterized.Functional as F+import qualified Synthesizer.LLVM.Causal.ProcessValue as CausalV+import qualified Synthesizer.LLVM.Causal.Process as Causal import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import qualified Synthesizer.LLVM.Simple.Value as Value @@ -28,6 +36,7 @@ import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Util.Loop as Loop import qualified LLVM.Core as LLVM import LLVM.Extra.Class (Undefined, undefTuple, ) import LLVM.Core (CodeGenFunction, )@@ -85,8 +94,8 @@ instance (Value.Flatten a) => Value.Flatten (Parameter a) where type Registers (Parameter a) = Parameter (Value.Registers a)- flatten = Value.flattenTraversable- unfold = Value.unfoldFunctor+ flattenCode = Value.flattenCodeTraversable+ unfoldCode = Value.unfoldCodeTraversable instance (Vector.Simple v) => Vector.Simple (Parameter v) where@@ -102,18 +111,20 @@ parameter :: (A.Transcendental a, A.RationalConstant a) => a -> a -> CodeGenFunction r (Parameter a)-parameter phase freq =- Value.flatten $- Allpass.parameter- (Value.constantValue phase) (Value.constantValue freq)+parameter = Value.unlift2 Allpass.parameter newtype CascadeParameter n a = CascadeParameter (Allpass.Parameter a) deriving- (Phi, Undefined, Class.Zero, Storable,+ (Undefined, Class.Zero, Storable, Functor, App.Applicative, Fold.Foldable, Trav.Traversable) +instance (Phi a) => Phi (CascadeParameter n a) where+ phis bb (CascadeParameter v) = fmap CascadeParameter $ Loop.phis bb v+ addPhis bb (CascadeParameter x) (CascadeParameter y) = Loop.addPhis bb x y++ instance (Memory.C a) => Memory.C (CascadeParameter n a) where type Struct (CascadeParameter n a) = Memory.Struct a load = Memory.loadNewtype CascadeParameter@@ -137,8 +148,8 @@ instance (Value.Flatten a) => Value.Flatten (CascadeParameter n a) where type Registers (CascadeParameter n a) = CascadeParameter n (Value.Registers a)- flatten = Value.flattenTraversable- unfold = Value.unfoldFunctor+ flattenCode = Value.flattenCodeTraversable+ unfoldCode = Value.unfoldCodeTraversable instance (Vector.Simple v) => Vector.Simple (CascadeParameter n v) where@@ -159,11 +170,8 @@ (A.Transcendental a, A.RationalConstant a, TypeNum.NaturalT n) => n -> a -> CodeGenFunction r (CascadeParameter n a)-flangerParameter order freq =- Value.flatten $- CascadeParameter $- Allpass.flangerParameter (TypeNum.fromIntegerT order) $- Value.constantValue freq+flangerParameter order =+ Value.unlift1 (flangerParameterPlain order) flangerParameterPlain :: (Trans.C a, TypeNum.NaturalT n) =>@@ -174,7 +182,7 @@ modifier ::- (A.PseudoModule a v, A.IntegerConstant a) =>+ (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a) => Modifier.Simple -- (Allpass.State (Value.T v)) (Value.T v, Value.T v)@@ -184,50 +192,50 @@ Allpass.firstOrderModifier {--For Allpass cascade you may use the 'CausalP.pipeline' function.+For Allpass cascade you may use the 'Causal.pipeline' function. -}-causalP ::- (A.RationalConstant a, A.PseudoModule a v, Memory.C v) =>- CausalP.T p (Parameter a, v) v-causalP =- CausalP.fromModifier modifier+causal ::+ (Causal.C process,+ A.RationalConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v) =>+ process (Parameter a, v) v+causal =+ Causal.fromModifier modifier replicateStage ::- (TypeNum.NaturalT n) =>+ (Causal.C process,+ TypeNum.NaturalT n, Phi b, Undefined b) => n ->- CausalP.T p (Parameter a, b) b ->- CausalP.T p (CascadeParameter n a, b) b+ process (Parameter a, b) b ->+ process (CascadeParameter n a, b) b replicateStage order stg =- CausalP.replicateControlled+ Causal.replicateControlled (TypeNum.fromIntegerT order) (stg <<< first (arr (\(CascadeParameter p) -> p))) -cascadeP ::- (A.RationalConstant a, A.PseudoModule a v, Memory.C v,+cascade ::+ (Causal.C process,+ A.RationalConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v, TypeNum.NaturalT n) =>- CausalP.T p (CascadeParameter n a, v) v-cascadeP =- replicateStage undefined causalP+ process (CascadeParameter n a, v) v+cascade =+ replicateStage undefined causal half ::- (A.RationalConstant a, A.PseudoModule a v) =>- CausalP.T p (param a, v) v-half =- let scale :: A.PseudoModule a v => param a -> a -> v -> CodeGenFunction r v- scale _ = A.scale- in CausalP.mapSimple- (\(p,x) -> scale p (A.fromRational' 0.5) x)+ (Causal.C process, A.RationalConstant a, a ~ A.Scalar v, A.PseudoModule v) =>+ process v v+half = CausalV.map (Value.fromRational' 0.5 *>) -phaserP ::- (A.RationalConstant a, A.RationalConstant v,- A.PseudoModule a v, Memory.C v,+phaser ::+ (Causal.C process,+ A.RationalConstant a, A.RationalConstant v,+ a ~ A.Scalar v, A.PseudoModule v, Memory.C v, TypeNum.NaturalT n) =>- CausalP.T p (CascadeParameter n a, v) v-phaserP =- CausalP.mix <<<- cascadeP &&& arr snd <<<- (arr fst &&& half)+ process (CascadeParameter n a, v) v+phaser =+ Causal.mix <<<+ cascade &&& arr snd <<<+ second half {-@@ -235,21 +243,22 @@ but LLVM-2.6 does not yet do it. -} stage ::- (Vector.Canonical n a, Vector.Construct n a ~ v,- A.PseudoModule a a, A.IntegerConstant a, Memory.C a) =>+ (Causal.C process,+ Vector.Canonical n a, Vector.Construct n a ~ v,+ a ~ A.Scalar a, A.PseudoModule a, A.IntegerConstant a, Memory.C a) => n ->- CausalP.T p+ process (CascadeParameter n v, v) (CascadeParameter n v, v) stage _ =- CausalP.vectorize+ Causal.vectorize (arr fst &&&- (CausalP.fromModifier modifier <<<+ (Causal.fromModifier modifier <<< first (arr (\(CascadeParameter p) -> p)))) withSize ::- (n -> CausalP.T p (CascadeParameter n a, b) c) ->- CausalP.T p (CascadeParameter n a, b) c+ (n -> process (CascadeParameter n a, b) c) ->+ process (CascadeParameter n a, b) c withSize f = f undefined {- |@@ -258,47 +267,51 @@ primitive element types and we get a delay by the number of pipeline stages. -}-cascadePipelineP ::- (Vector.Canonical n a, Vector.Construct n a ~ v,- A.PseudoModule a a, A.IntegerConstant a, Memory.C a,- Class.Zero v, Memory.C v) =>- CausalP.T p (CascadeParameter n a, a) a-cascadePipelineP = withSize $ \order ->- snd ^<< CausalP.pipeline (stage order)+cascadePipeline ::+ (Causal.C process,+ Vector.Canonical n a, Vector.Construct n a ~ v,+ a ~ A.Scalar a, A.PseudoModule a, A.IntegerConstant a, Memory.C a,+ A.Additive v, Memory.C v) =>+ process (CascadeParameter n a, a) a+cascadePipeline = withSize $ \order ->+ snd ^<< Causal.pipeline (stage order) vectorId ::- (Vector.Canonical n a) =>- n -> CausalP.T p (Vector.Construct n a) (Vector.Construct n a)+ (Causal.C process, Vector.Canonical n a) =>+ n -> process (Vector.Construct n a) (Vector.Construct n a) vectorId _ = Cat.id -phaserPipelineP ::- (Vector.Canonical n a, Vector.Construct n a ~ v,- A.PseudoModule a a, A.RationalConstant a, Memory.C a,- Class.Zero v, Memory.C v) =>- CausalP.T p (CascadeParameter n a, a) a-phaserPipelineP = withSize $ \order ->- CausalP.mix <<<- cascadePipelineP &&&- (CausalP.pipeline (vectorId order) <<^ snd) <<<--- (CausalP.delay (const zero) (const $ TypeNum.fromIntegerT order) <<^ snd) <<<- (arr fst &&& half)+phaserPipeline ::+ (Causal.C process,+ Vector.Canonical n a, Vector.Construct n a ~ v,+ a ~ A.Scalar a, A.PseudoModule a, A.RationalConstant a, Memory.C a,+ A.Additive v, Memory.C v) =>+ process (CascadeParameter n a, a) a+phaserPipeline = withSize $ \order ->+ Causal.mix <<<+ cascadePipeline &&&+ (Causal.pipeline (vectorId order) <<^ snd) <<<+-- (Causal.delay (const zero) (const $ TypeNum.fromIntegerT order) <<^ snd) <<<+ second half -causalPackedP,- causalNonRecursivePackedP ::- (Serial.C v, Serial.Element v ~ a,+causalPacked,+ causalNonRecursivePacked ::+ (Causal.C process,+ Serial.C v, Serial.Element v ~ a, Memory.C a, A.IntegerConstant a, A.PseudoRing v, A.PseudoRing a) =>- CausalP.T p (Parameter a, v) v-causalPackedP =- Filt1L.causalRecursivePackedP <<<- (CausalP.mapSimple+ process (Parameter a, v) v++causalPacked =+ Filt1L.causalRecursivePacked <<<+ (Causal.map (\(Parameter k, _) -> fmap Filt1.Parameter $ A.neg k) &&&- causalNonRecursivePackedP)+ causalNonRecursivePacked) -causalNonRecursivePackedP =- CausalP.mapAccumSimple+causalNonRecursivePacked =+ Causal.mapAccum (\(Parameter k, v0) x1 -> do (_,v1) <- Serial.shiftUp x1 v0 y <- A.add v1 =<< A.mul v0 =<< Serial.upsample k@@ -307,16 +320,80 @@ return (y, u0)) (return A.zero) +cascadePacked, phaserPacked ::+ (Causal.C process,+ TypeNum.NaturalT n,+ Serial.C v, Serial.Element v ~ a,+ A.PseudoRing a, A.IntegerConstant a, Memory.C a,+ A.PseudoRing v, A.RationalConstant v) =>+ process (CascadeParameter n a, v) v+cascadePacked =+ replicateStage undefined causalPacked++phaserPacked =+ Causal.mix <<<+ cascadePacked &&& arr snd <<<+ second (Causal.map (A.mul (A.fromRational' 0.5)))++++++causalP ::+ (A.RationalConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v) =>+ CausalP.T p (Parameter a, v) v+causalP = causal++cascadeP ::+ (A.RationalConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v,+ TypeNum.NaturalT n) =>+ CausalP.T p (CascadeParameter n a, v) v+cascadeP = cascade++phaserP ::+ (A.RationalConstant a, A.RationalConstant v,+ a ~ A.Scalar v, A.PseudoModule v, Memory.C v,+ TypeNum.NaturalT n) =>+ CausalP.T p (CascadeParameter n a, v) v+phaserP = phaser+++cascadePipelineP ::+ (Vector.Canonical n a, Vector.Construct n a ~ v,+ a ~ A.Scalar a, A.PseudoModule a, A.IntegerConstant a, Memory.C a,+ A.Additive v, Memory.C v) =>+ CausalP.T p (CascadeParameter n a, a) a+cascadePipelineP = cascadePipeline++phaserPipelineP ::+ (Vector.Canonical n a, Vector.Construct n a ~ v,+ a ~ A.Scalar a, A.PseudoModule a, A.RationalConstant a, Memory.C a,+ A.Additive v, Memory.C v) =>+ CausalP.T p (CascadeParameter n a, a) a+phaserPipelineP = phaserPipeline+++causalPackedP ::+ (Serial.C v, Serial.Element v ~ a,+ Memory.C a, A.IntegerConstant a,+ A.PseudoRing v, A.PseudoRing a) =>+ CausalP.T p (Parameter a, v) v+causalPackedP = causalPacked+ cascadePackedP, phaserPackedP :: (TypeNum.NaturalT n, Serial.C v, Serial.Element v ~ a, A.PseudoRing a, A.IntegerConstant a, Memory.C a, A.PseudoRing v, A.RationalConstant v) => CausalP.T p (CascadeParameter n a, v) v-cascadePackedP =- replicateStage undefined causalPackedP+cascadePackedP = cascadePacked+phaserPackedP = phaserPacked -phaserPackedP =- CausalP.mix <<<- cascadePackedP &&& arr snd <<<- second (CausalP.mapSimple (A.mul (A.fromRational' 0.5)))+{-# DEPRECATED causalP "use 'causal' instead" #-}+{-# DEPRECATED cascadeP "use 'cascade' instead" #-}+{-# DEPRECATED phaserP "use 'phaser' instead" #-}+{-# DEPRECATED cascadePipelineP "use 'cascadePipeline' instead" #-}+{-# DEPRECATED phaserPipelineP "use 'phaserPipeline' instead" #-}+{-# DEPRECATED causalPackedP "use 'causalPacked' instead" #-}+{-# DEPRECATED cascadePackedP "use 'cascadePacked' instead" #-}+{-# DEPRECATED phaserPackedP "use 'phaserPacked' instead" #-}
src/Synthesizer/LLVM/Filter/Butterworth.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} module Synthesizer.LLVM.Filter.Butterworth ( parameter, Cascade.ParameterValue,+ Cascade.causal, Cascade.causalPacked, Cascade.causalP, Cascade.causalPackedP, Cascade.fixSize, ) where@@ -12,7 +13,6 @@ import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2 import qualified Synthesizer.Plain.Filter.Recursive.Butterworth as Butterworth-import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2Core import Synthesizer.Plain.Filter.Recursive (Passband, ) import qualified Synthesizer.LLVM.Simple.Value as Value@@ -24,7 +24,7 @@ import qualified LLVM.Core as LLVM import LLVM.Core (Value, valueOf, constOf,- IsConst, IsFloating, IsSized, SizeOf,+ IsFloating, IsSized, SizeOf, CodeGenFunction, ) import Data.Word (Word32, ) @@ -51,8 +51,7 @@ parameterMalloc n kind ratio freq = do let order = 2 * TypeNum.fromIntegerT n- partialRatio <-- Value.decons (Butterworth.partialRatio order (Value.constantValue ratio))+ partialRatio <- Value.unlift1 (Butterworth.partialRatio order) ratio let sines = (flip const :: n -> LLVM.Value (LLVM.Array n a) -> LLVM.Value (LLVM.Array n a)) n $@@ -69,13 +68,7 @@ sinw <- LLVM.load si flip LLVM.store ptri =<< Filt2.composeParameter =<<- Value.flatten- (Filt2Core.adjustPassband kind- (flip- (Butterworth.partialParameter- (Value.constantValue partialRatio))- (Value.constantValue sinw))- (Value.constantValue freq))+ Value.unlift3 (Butterworth.partialParameter kind) partialRatio sinw freq A.advanceArrayElementPtr si pv <- LLVM.load ps LLVM.free psine@@ -84,8 +77,7 @@ _parameterAlloca n kind ratio freq = do let order = 2 * TypeNum.fromIntegerT n- partialRatio <-- Value.decons (Butterworth.partialRatio order (Value.constantValue ratio))+ partialRatio <- Value.unlift1 (Butterworth.partialRatio order) ratio let sines = (flip const :: n -> LLVM.Value (LLVM.Array n a) -> LLVM.Value (LLVM.Array n a)) n $@@ -102,12 +94,6 @@ sinw <- LLVM.load si flip LLVM.store ptri =<< Filt2.composeParameter =<<- Value.flatten- (Filt2Core.adjustPassband kind- (flip- (Butterworth.partialParameter- (Value.constantValue partialRatio))- (Value.constantValue sinw))- (Value.constantValue freq))+ Value.unlift3 (Butterworth.partialParameter kind) partialRatio sinw freq A.advanceArrayElementPtr si fmap Cascade.ParameterValue $ LLVM.load ps
src/Synthesizer/LLVM/Filter/Chebyshev.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} module Synthesizer.LLVM.Filter.Chebyshev ( parameterA, parameterB, Cascade.ParameterValue,+ Cascade.causal, Cascade.causalPacked, Cascade.causalP, Cascade.causalPackedP, Cascade.fixSize, ) where@@ -26,7 +27,6 @@ (Value, valueOf, IsSized, SizeOf, IsFloating, CodeGenFunction, ) import Data.Word (Word32, ) -import qualified Types.Data.Bool as TypeBool import qualified Types.Data.Num as TypeNum import Types.Data.Num.Ops ((:*:), ) @@ -35,9 +35,6 @@ import qualified Number.Complex as Complex import qualified Algebra.Transcendental as Trans--- import qualified Algebra.Field as Field--- import qualified Algebra.Module as Module--- import qualified Algebra.Ring as Ring import NumericPrelude.Numeric import NumericPrelude.Base@@ -49,7 +46,7 @@ -} parameterA, parameterB :: (Trans.C a, SoV.TranscendentalConstant a, IsFloating a, IsSized a,- TypeNum.PositiveT n, TypeNum.IsNatural n ~ TypeBool.True,+ TypeNum.PositiveT n, TypeNum.NaturalT n, TypeNum.PositiveT (n :*: SizeOf a), IsSized (Cascade.ParameterStruct n a), SizeOf (Cascade.ParameterStruct n a) ~ paramSize, (n :*: LLVM.UnknownSize) ~ paramSize, TypeNum.PositiveT paramSize) =>@@ -75,12 +72,12 @@ parameter :: (Trans.C a, SoV.RationalConstant a, IsFloating a, IsSized a,- TypeNum.PositiveT n, TypeNum.IsNatural n ~ TypeBool.True,+ Value.T (Value a) ~ av,+ TypeNum.PositiveT n, TypeNum.NaturalT n, TypeNum.PositiveT (n :*: SizeOf a), IsSized (Cascade.ParameterStruct n a), SizeOf (Cascade.ParameterStruct n a) ~ paramSize, (n :*: LLVM.UnknownSize) ~ paramSize, TypeNum.PositiveT paramSize) =>- (Int -> Value.T (Value a) -> Value.T (Value a) ->- Complex.T (Value.T (Value a)) -> Filt2Core.Parameter (Value.T (Value a))) ->+ (Passband -> Int -> av -> Complex.T av -> av -> Filt2Core.Parameter av) -> n -> Passband -> Value a -> Value a -> CodeGenFunction r (Value (Cascade.ParameterStruct n a)) parameter partialParameter n kind ratio freq = do@@ -103,11 +100,9 @@ flip LLVM.store ptri =<< Filt2.composeParameter =<< Value.flatten- (Filt2Core.adjustPassband kind- (flip- (partialParameter order- (Value.constantValue ratio))- (ComplexL.unfold c))+ (partialParameter kind order+ (Value.constantValue ratio)+ (ComplexL.unfold c) (Value.constantValue freq)) A.advanceArrayElementPtr si
src/Synthesizer/LLVM/Filter/ComplexFirstOrder.hs view
@@ -89,8 +89,8 @@ instance (Value.Flatten a) => Value.Flatten (Parameter a) where type Registers (Parameter a) = Parameter (Value.Registers a)- flatten = Value.flattenTraversable- unfold = Value.unfoldFunctor+ flattenCode = Value.flattenCodeTraversable+ unfoldCode = Value.unfoldCodeTraversable parameter, _parameter ::@@ -152,13 +152,14 @@ return (A.zero Complex.+: A.zero) causal ::- (A.PseudoRing a, A.IntegerConstant a, Memory.C a) =>- Causal.T+ (Causal.C process, A.PseudoRing a, A.IntegerConstant a, Memory.C a) =>+ process (Parameter a, Stereo.T a) (Stereo.T a) causal = Causal.mapAccum next start +{-# DEPRECATED causalP "use causal instead" #-} causalP :: (A.PseudoRing a, A.IntegerConstant a, Memory.C a) => CausalP.T p
src/Synthesizer/LLVM/Filter/ComplexFirstOrderPacked.hs view
@@ -22,8 +22,8 @@ import qualified LLVM.Core as LLVM import LLVM.Core- (Value, valueOf, value, Struct,- IsPrimitive, IsConst, IsFloating, IsSized,+ (Value, valueOf, Struct,+ IsPrimitive, IsFloating, IsSized, Vector, insertelement, CodeGenFunction, ) import LLVM.Util.Loop (Phi, phis, addPhis, )@@ -102,8 +102,8 @@ ki <- A.mul k =<< A.sin w kin <- A.neg ki- kvr <- Vector.assemble [kr,kin,amp, value LLVM.zero]- kvi <- Vector.assemble [ki,kr, amp, value LLVM.zero]+ kvr <- Vector.assemble [kr,kin,amp, A.zero]+ kvi <- Vector.assemble [ki,kr, amp, A.zero] return (Parameter kvr kvi) @@ -119,9 +119,9 @@ This would even require a vector of size 3. -} next ::- (Vector.Arithmetic a, IsConst a) =>+ (Vector.Arithmetic a) => (Parameter a, Stereo.T (Value a)) ->- (Value (State a)) ->+ Value (State a) -> CodeGenFunction r (Stereo.T (Value a), (Value (State a))) next (Parameter kr ki, x) s = do sr <- insertelement s (Stereo.left x) (valueOf 2)@@ -134,39 +134,21 @@ return (Stereo.cons yr yi, sv) start ::- (IsPrimitive a, IsConst a) =>+ (Vector.Arithmetic a) => CodeGenFunction r (Value (State a))-start =- return (value LLVM.zero)+start = return A.zero causal ::- (IsConst a, Vector.Arithmetic a,- Memory.C (Value (State a))) =>-{-- (IsConst a, Vector.Arithmetic a,- Memory.FirstClass a am,- IsPrimitive am,- IsSized am s, Add s s s2, Add s2 s s3, Add s3 s s4, Sets.Pos s4,- IsSized (State a) vasize,- IsSized (State am) vamsize) =>--}- Causal.T+ (Causal.C process, Vector.Arithmetic a, Memory.C (Value (State a))) =>+ process (Parameter a, Stereo.T (Value a)) (Stereo.T (Value a)) causal = Causal.mapAccum next start +{-# DEPRECATED causalP "use causal instead" #-} causalP ::- (IsConst a, Vector.Arithmetic a,- Memory.C (Value (State a))) =>-{-- (IsConst a, Vector.Arithmetic a,- Memory.FirstClass a am,- IsPrimitive am,- IsSized am s, Add s s s2, Add s2 s s3, Add s3 s s4, Sets.Pos s4,- IsSized (State a) vasize,- IsSized (State am) vamsize) =>--}+ (Vector.Arithmetic a, Memory.C (Value (State a))) => CausalP.T p (Parameter a, Stereo.T (Value a)) (Stereo.T (Value a))
src/Synthesizer/LLVM/Filter/FirstOrder.hs view
@@ -3,6 +3,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Synthesizer.LLVM.Filter.FirstOrder ( Result(Result,lowpass_,highpass_), Parameter, parameter,+ causal, lowpassCausal, highpassCausal,+ causalPacked, lowpassCausalPacked, highpassCausalPacked,+ causalRecursivePacked, -- for Allpass+ causalP, lowpassCausalP, highpassCausalP, causalPackedP, lowpassCausalPackedP, highpassCausalPackedP, causalRecursivePackedP, -- for Allpass@@ -15,6 +19,7 @@ import qualified Synthesizer.Plain.Modifier as Modifier import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Causal.Process as Causal import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import qualified Synthesizer.LLVM.Simple.Value as Value @@ -49,9 +54,14 @@ instance (Value.Flatten a) => Value.Flatten (Parameter a) where type Registers (Parameter a) = Parameter (Value.Registers a)- flatten = Value.flattenTraversable- unfold = Value.unfoldFunctor+ flattenCode = Value.flattenCodeTraversable+ unfoldCode = Value.unfoldCodeTraversable +instance (Value.Flatten a) => Value.Flatten (Result a) where+ type Registers (Result a) = Result (Value.Registers a)+ flattenCode = Value.flattenCodeTraversable+ unfoldCode = Value.unfoldCodeTraversable+ {- instance LLVM.ValueTuple a => LLVM.ValueTuple (Parameter a) where buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)@@ -68,14 +78,19 @@ parameter :: (A.Transcendental a, A.RationalConstant a) => a -> LLVM.CodeGenFunction r (Parameter a)-parameter reson =- Value.flatten $- FirstOrder.parameter- (Value.constantValue reson)+parameter = Value.unlift1 FirstOrder.parameter +modifier ::+ (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a) =>+ Modifier.Simple+ (Value.T v)+ (Parameter (Value.T a))+ (Value.T v) (Result (Value.T v))+modifier = FirstOrder.modifier+ lowpassModifier, highpassModifier ::- (A.PseudoModule a v, A.IntegerConstant a) =>+ (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a) => Modifier.Simple -- (FirstOrder.State (Value.T v)) (Value.T v)@@ -84,37 +99,31 @@ lowpassModifier = FirstOrder.lowpassModifier highpassModifier = FirstOrder.highpassModifier -causalP ::- (A.IntegerConstant a, A.PseudoModule a v, Memory.C v) =>- CausalP.T p (Parameter a, v) (Result v)-{--in contrast to CausalP.fromModifier this allows for sharing-between lowpass and highpass channel--}-causalP =- CausalP.mapSimple (\(l,x) -> do- h <- A.sub x l- return (Result{FirstOrder.lowpass_ = l,- FirstOrder.highpass_ = h}))- <<< (lowpassCausalP &&& arr snd)+causal ::+ (Causal.C process,+ A.IntegerConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v) =>+ process (Parameter a, v) (Result v)+causal = Causal.fromModifier modifier -lowpassCausalP, highpassCausalP ::- (A.IntegerConstant a, A.PseudoModule a v, Memory.C v) =>- CausalP.T p (Parameter a, v) v-lowpassCausalP = CausalP.fromModifier lowpassModifier-highpassCausalP = CausalP.fromModifier highpassModifier+lowpassCausal, highpassCausal ::+ (Causal.C process,+ A.IntegerConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v) =>+ process (Parameter a, v) v+lowpassCausal = CausalP.fromModifier lowpassModifier+highpassCausal = CausalP.fromModifier highpassModifier -lowpassCausalPackedP, highpassCausalPackedP, causalRecursivePackedP ::- (Serial.C v, Serial.Element v ~ a,+lowpassCausalPacked, highpassCausalPacked, causalRecursivePacked ::+ (Causal.C process,+ Serial.C v, Serial.Element v ~ a, Memory.C a, A.IntegerConstant a, A.PseudoRing v, A.PseudoRing a) =>- CausalP.T p (Parameter a, v) v-highpassCausalPackedP =- arr snd - lowpassCausalPackedP-lowpassCausalPackedP =- causalRecursivePackedP <<<+ process (Parameter a, v) v+highpassCausalPacked =+ Causal.zipWith A.sub <<< arr snd &&& lowpassCausalPacked+lowpassCausalPacked =+ causalRecursivePacked <<< (arr fst &&&- CausalP.mapSimple+ Causal.map (\(FirstOrder.Parameter k, x) -> A.mul x =<< Serial.upsample =<< A.sub (A.fromInteger' 1) k)) @@ -132,11 +141,11 @@ f1x = f0x + k * f0x->1 f2x = f1x + k^2 * f1x->2 -}-causalRecursivePackedP =- CausalP.mapAccumSimple+causalRecursivePacked =+ Causal.mapAccum (\(FirstOrder.Parameter k, xk0) y1 -> do y1k <- A.mul k y1- xk1 <- Serial.modify (LLVM.valueOf 0) (A.add y1k) xk0+ xk1 <- Serial.modify A.zero (A.add y1k) xk0 let size = Serial.size xk0 kv <- Serial.upsample k xk2 <-@@ -208,14 +217,63 @@ -causalPackedP ::- (Serial.C v, Serial.Element v ~ a,+causalPacked ::+ (Causal.C process,+ Serial.C v, Serial.Element v ~ a, Memory.C a, A.IntegerConstant a, A.PseudoRing v, A.PseudoRing a) =>+ process (Parameter a, v) (Result v)+causalPacked =+ Causal.map (\(l,x) -> do+ h <- A.sub x l+ return (Result{FirstOrder.lowpass_ = l,+ FirstOrder.highpass_ = h}))+ <<< (lowpassCausalPacked &&& arr snd)++++causalP ::+ (A.IntegerConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v) => CausalP.T p (Parameter a, v) (Result v)-causalPackedP =- CausalP.mapSimple (\(l,x) -> do+{-+Before we added sharing to Simple.Value,+only this implementation allowed sharing+and using CausalP.fromModifier did not.+-}+causalP =+ Causal.map (\(l,x) -> do h <- A.sub x l return (Result{FirstOrder.lowpass_ = l, FirstOrder.highpass_ = h}))- <<< (lowpassCausalPackedP &&& arr snd)+ <<< (lowpassCausalP &&& arr snd)++lowpassCausalP, highpassCausalP ::+ (A.IntegerConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v) =>+ CausalP.T p (Parameter a, v) v+lowpassCausalP = lowpassCausal+highpassCausalP = highpassCausal++lowpassCausalPackedP, highpassCausalPackedP, causalRecursivePackedP ::+ (Serial.C v, Serial.Element v ~ a,+ Memory.C a, A.IntegerConstant a,+ A.PseudoRing v, A.PseudoRing a) =>+ CausalP.T p (Parameter a, v) v+highpassCausalPackedP = highpassCausalPacked+lowpassCausalPackedP = lowpassCausalPacked+causalRecursivePackedP = causalRecursivePacked++causalPackedP ::+ (Serial.C v, Serial.Element v ~ a,+ Memory.C a, A.IntegerConstant a,+ A.PseudoRing v, A.PseudoRing a) =>+ CausalP.T p (Parameter a, v) (Result v)+causalPackedP = causalPacked+++{-# DEPRECATED causalP "use 'causal' instead" #-}+{-# DEPRECATED lowpassCausalP "use 'lowpassCausal' instead" #-}+{-# DEPRECATED highpassCausalP "use 'highpassCausal' instead" #-}+{-# DEPRECATED causalPackedP "use 'causalPacked' instead" #-}+{-# DEPRECATED lowpassCausalPackedP "use 'lowpassCausalPacked' instead" #-}+{-# DEPRECATED highpassCausalPackedP "use 'highpassCausalPacked' instead" #-}+{-# DEPRECATED causalRecursivePackedP "use 'causalRecursivePacked' instead" #-}
src/Synthesizer/LLVM/Filter/Moog.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveTraversable #-} module Synthesizer.LLVM.Filter.Moog (Parameter, parameter,- causalP,- causalInitP,+ causal, causalInit,+ causalP, causalInitP, ) where import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1@@ -15,20 +15,20 @@ import Synthesizer.Plain.Filter.Recursive (Pole(..)) import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Causal.Process as Causal import qualified Synthesizer.LLVM.Simple.Value as Value import qualified Synthesizer.LLVM.Parameter as Param import Foreign.Storable (Storable, ) -import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Vector as Vector import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Class as Class-import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, undefTuple, )+import LLVM.Extra.Class (Undefined, undefTuple, ) import qualified LLVM.Core as LLVM-import LLVM.Core (Value, IsConst, IsSized, CodeGenFunction, )+import LLVM.Core (CodeGenFunction, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) import qualified Types.Data.Num as TypeNum@@ -38,11 +38,9 @@ import qualified Control.Applicative as App import qualified Data.Foldable as Fold import qualified Data.Traversable as Trav-import Control.Arrow ((>>>), (&&&), )+import Control.Arrow (arr, (>>>), (&&&), ) import Control.Applicative (liftA2, ) -import qualified Algebra.Additive as Additive- import NumericPrelude.Numeric import NumericPrelude.Base @@ -87,8 +85,8 @@ instance (Value.Flatten a, TypeNum.NaturalT n) => Value.Flatten (Parameter n a) where type Registers (Parameter n a) = Parameter n (Value.Registers a)- flatten = Value.flattenTraversable- unfold = Value.unfoldFunctor+ flattenCode = Value.flattenCodeTraversable+ unfoldCode = Value.unfoldCodeTraversable instance (Vector.Simple v, TypeNum.NaturalT n) => Vector.Simple (Parameter n v) where@@ -105,29 +103,13 @@ (A.Transcendental a, A.RationalConstant a, TypeNum.NaturalT n) => n -> a -> a -> CodeGenFunction r (Parameter n a)-parameter order reson freq =- Value.flatten $- Parameter $ Moog.parameter (TypeNum.fromIntegerT order)- (Pole (Value.constantValue reson) (Value.constantValue freq))+parameter order =+ Value.unlift2 $ \reson freq ->+ Parameter $ Moog.parameter (TypeNum.fromIntegerT order) (Pole reson freq) -{--infixr 1 ^>>, >>^ -(>>^) ::- (Value.Flatten b bl, Value.Flatten c cl) =>- CausalP.T p al bl -> (b -> c) -> CausalP.T p al cl-(>>^) a f =- a >>> CausalP.mapSimple (Value.flatten . f . Value.unfold)--(^>>) ::- (Value.Flatten a al, Value.Flatten b bl) =>- (a -> b) -> CausalP.T p bl cl -> CausalP.T p al cl-(^>>) f b =- CausalP.mapSimple (Value.flatten . f . Value.unfold) >>> b--}- merge ::- (A.PseudoModule a v, A.IntegerConstant a) =>+ (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a) => (Parameter n a, v) -> v -> CodeGenFunction r (FirstOrder.Parameter a, v) merge (Parameter (Moog.Parameter f k), x) y0 =@@ -136,57 +118,64 @@ in Value.flatten (fmap c k, c x - c f *> c y0) amplify ::- (A.PseudoModule a v, A.IntegerConstant a) =>+ (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a) => Parameter n a -> v -> CodeGenFunction r v-amplify (Parameter (Moog.Parameter f _k)) y1 =- Value.decons $- (1 + Value.constantValue f) *> Value.constantValue y1+amplify =+ Value.unlift2 $ \p y1 ->+ case fmap (Moog.feedback . getParam) p of+ f -> (1 + f) *> y1 +causal ::+ (Causal.C process,+ Memory.C v, A.PseudoModule v, A.Scalar v ~ a, A.IntegerConstant a,+ TypeNum.NaturalT n) =>+ process (Parameter n a, v) v+causal =+ causalSize+ (flip Causal.feedbackControlledZero (arr snd))+ undefined+ causalP ::- (SoV.PseudoModule a v, SoV.IntegerConstant a,- IsConst v, Additive.C v,- Storable v,- MakeValueTuple v, ValueTuple v ~ (Value v),- MakeValueTuple a, ValueTuple a ~ (Value a),- Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am,- Memory.FirstClass v, Memory.Stored v ~ vm, IsSized v, IsSized vm,+ (Memory.C v, A.PseudoModule v, A.Scalar v ~ a, A.IntegerConstant a, TypeNum.NaturalT n) =>- CausalP.T p (Parameter n (Value a), Value v) (Value v)-causalP =- let withZero ::- (Additive.C v) =>- (Param.T p v ->- CausalP.T p (Parameter n (Value a), Value v) (Value v)) ->- CausalP.T p (Parameter n (Value a), Value v) (Value v)- withZero proc = proc zero- in withZero causalInitP+ CausalP.T p (Parameter n a, v) v+causalP = causal -causalInitP ::- (A.PseudoModule a v, A.IntegerConstant a,- Storable vh, Class.MakeValueTuple vh, v ~ Class.ValueTuple vh,- Memory.C v,+causalInit, causalInitP ::+ (Storable vh, Class.MakeValueTuple vh,+ Class.ValueTuple vh ~ v, Memory.C v,+ A.PseudoModule v, A.Scalar v ~ a, A.IntegerConstant a, TypeNum.NaturalT n) => Param.T p vh -> CausalP.T p (Parameter n a, v) v-causalInitP =- causalInitPSize undefined+causalInit = causalInitP+causalInitP initial =+ let selectOutput :: Param.T p vh -> (b, Class.ValueTuple vh) -> Class.ValueTuple vh+ selectOutput _ = snd+ in causalSize+ (flip+ (CausalP.feedbackControlled initial)+ (arr $ selectOutput initial))+ undefined -causalInitPSize ::- (A.PseudoModule a v, A.IntegerConstant a,- Storable vh, Class.MakeValueTuple vh, v ~ Class.ValueTuple vh,- Memory.C v,++causalSize ::+ (Causal.C process,+ Memory.C v, A.PseudoModule v, A.Scalar v ~ a, A.IntegerConstant a, TypeNum.NaturalT n) =>- n -> Param.T p vh -> CausalP.T p (Parameter n a, v) v-causalInitPSize n initial =+ (process ((Parameter n a, v), v) v ->+ process (Parameter n a, v) v) ->+ n ->+ process (Parameter n a, v) v+causalSize feedback n = let order = TypeNum.fromIntegerT n- selectOutput :: Param.T p vh -> (b, Class.ValueTuple vh) -> Class.ValueTuple vh- selectOutput _ = snd in Arrow.arr fst &&&- CausalP.feedbackControlled- initial- (CausalP.zipWithSimple merge >>>- CausalP.replicateControlled order Filt1.lowpassCausalP)- (Arrow.arr (selectOutput initial))- >>> CausalP.zipWithSimple amplify+ feedback+ (Causal.zipWith merge >>>+ Causal.replicateControlled order Filt1.lowpassCausal)+ >>> Causal.zipWith amplify++{-# DEPRECATED causalP "use 'causal' instead" #-}+{-# DEPRECATED causalInitP "use 'causalInit' instead" #-}
+ src/Synthesizer/LLVM/Filter/NonRecursive.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+module Synthesizer.LLVM.Filter.NonRecursive (+ convolve,+ convolvePacked,+ ) where++import qualified Synthesizer.LLVM.CausalParameterized.ProcessPrivate as CausalP+import qualified Synthesizer.LLVM.Parameter as Param++import qualified Synthesizer.LLVM.RingBuffer as RingBuffer+import qualified Synthesizer.LLVM.Frame.SerialVector as Serial++import qualified Synthesizer.LLVM.Storable.Vector as SVU+import qualified Data.StorableVector as SV++import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Control as C+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Class as Class+import LLVM.Extra.Class (undefTuple, )++import qualified LLVM.Core as LLVM+import LLVM.Core (Value, valueOf, CodeGenFunction, IsSized, SizeOf, )++import qualified Types.Data.Num as TypeNum+import Types.Data.Num.Ops ((:*:), )++import Foreign.ForeignPtr (touchForeignPtr, )+import Foreign.Storable (Storable, )+import Foreign.Ptr (Ptr, )+import Data.Word (Word32, )++import Control.Arrow ((<<<), (&&&), )+import Control.Monad (liftM2, )++import qualified Algebra.IntegralDomain as Integral++import NumericPrelude.Numeric+import NumericPrelude.Base++++{-+This is a brute-force implementation.+No Karatsuba, No Toom-Cook, No Fourier.+-}+convolve ::+ (Storable a,+ Class.MakeValueTuple a, Class.ValueTuple a ~ al,+ Memory.C al, A.PseudoRing al) =>+ Param.T p (SV.Vector a) -> CausalP.T p al al+convolve mask =+ let len = fmap SV.length mask+ in CausalP.zipWith scalarProduct (fmap (fromIntegral :: Int -> Word32) len)+ <<<+ RingBuffer.trackConst A.zero len &&& provideMask mask++convolvePacked ::+ (LLVM.IsPrimitive a, Memory.FirstClass a, Memory.Stored a ~ am,+ LLVM.IsPrimitive am, IsSized am, SizeOf am ~ amsize,+ TypeNum.PositiveT n, TypeNum.PositiveT (n :*: amsize),+ Class.MakeValueTuple a, Class.ValueTuple a ~ al, Memory.Struct al ~ am,+ Storable a, Memory.C al,+ LLVM.IsArithmetic a) =>+ Param.T p (SV.Vector a) ->+ CausalP.T p (Serial.Value n a) (Serial.Value n a)+convolvePacked mask =+ Serial.withSize $ \vectorSize ->+ let len = fmap SV.length mask+ in CausalP.zipWith scalarProductPacked+ (fmap (fromIntegral :: Int -> Word32) len)+ <<<+ RingBuffer.trackConst A.zero+ (fmap (flip Integral.divUp vectorSize) len)+ &&&+ provideMask mask++provideMask ::+ (Storable a,+ Class.MakeValueTuple a, Class.ValueTuple a ~ al,+ Memory.C al, Memory.Struct al ~ am) =>+ Param.T p (SV.Vector a) -> CausalP.T p x (Value (Ptr am))+provideMask mask =+ CausalP.Cons+ (\p _x () -> return (p,()))+ return+ (const $ const $ return ())+ (\p ->+ let (fp,ptr,_l) = SVU.unsafeToPointers $ Param.get mask p+ in return (fp, (ptr, ())))+ -- keep the foreign ptr alive+ touchForeignPtr+++scalarProduct ::+ (Memory.C a, Memory.Struct a ~ am,+ A.PseudoRing a) =>+ Value Word32 ->+ RingBuffer.T a -> Value (Ptr am) ->+ CodeGenFunction r a+scalarProduct n rb mask =+ fmap snd $+ C.arrayLoop n mask (A.zero, A.zero) $ \ptr (k, s) -> do+ a <- RingBuffer.index k rb+ b <- Memory.load ptr+ liftM2 (,) (A.inc k) (A.add s =<< A.mul a b)++_scalarProduct ::+ (Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,+ LLVM.IsArithmetic a) =>+ Value Word32 ->+ RingBuffer.T (Value a) -> Value (Ptr am) ->+ CodeGenFunction r (Value a)+_scalarProduct = scalarProduct+++scalarProductPacked ::+ (LLVM.IsPrimitive a, Memory.FirstClass a, Memory.Stored a ~ am,+ LLVM.IsPrimitive am, IsSized am, SizeOf am ~ amsize,+ TypeNum.PositiveT n, TypeNum.PositiveT (n :*: amsize),+ LLVM.IsArithmetic a) =>+ Value Word32 ->+ RingBuffer.T (Serial.Value n a) -> Value (Ptr am) ->+ CodeGenFunction r (Serial.Value n a)+scalarProductPacked n0 rb mask0 = do+ (ax, rx) <- readSerialStart rb+ bx <- Memory.load mask0+ sx <- A.scale bx ax+ n1 <- A.dec n0+ mask1 <- A.advanceArrayElementPtr mask0+ fmap snd $ C.arrayLoop n1 mask1 (rx, sx) $+ \ptr (r1, s1) -> do+ (a,r2) <- readSerialNext rb r1+ b <- Memory.load ptr+ fmap ((,) r2) (A.add s1 =<< A.scale b a)+++type+ Iterator n a =+ ((Serial.Value n a,+ {-+ I would like to use Serial.Iterator,+ but we need to read in reversed order,+ that is, from high to low indices.+ -}+ Serial.Value n a,+ Value Word32),+ Value Word32)++readSerialStart ::+ (LLVM.IsPrimitive a, Memory.FirstClass a, Memory.Stored a ~ am,+ LLVM.IsPrimitive am, IsSized am, SizeOf am ~ amsize,+ TypeNum.PositiveT n, TypeNum.PositiveT (n :*: amsize)) =>+ RingBuffer.T (Serial.Value n a) ->+ CodeGenFunction r (Serial.Value n a, Iterator n a)+readSerialStart rb = do+ a <- RingBuffer.index A.zero rb+ return (a, ((a, undefTuple, A.zero), A.zero))++readSerialNext ::+ (LLVM.IsPrimitive a, Memory.FirstClass a, Memory.Stored a ~ am,+ LLVM.IsPrimitive am, IsSized am, SizeOf am ~ amsize,+ TypeNum.PositiveT n, TypeNum.PositiveT (n :*: amsize)) =>+ RingBuffer.T (Serial.Value n a) ->+ Iterator n a ->+ CodeGenFunction r (Serial.Value n a, Iterator n a)+readSerialNext rb ((a0,r0,j0), k0) = do+ vectorEnd <- A.cmp LLVM.CmpEQ j0 A.zero+ ((r1,j1), k1) <-+ C.ifThen vectorEnd ((r0,j0), k0) $ do+ k <- A.inc k0+ r <- RingBuffer.index k rb+ return ((r, valueOf (fromIntegral $ Serial.size r :: Word32)), k)+ j2 <- A.dec j1+ (ai,r2) <- Serial.shiftUp undefTuple r1+ (_, a1) <- Serial.shiftUp ai a0+ return (a1, ((a1,r2,j2), k1))
src/Synthesizer/LLVM/Filter/SecondOrder.hs view
@@ -8,6 +8,7 @@ Filt2.c0, Filt2.c1, Filt2.c2, Filt2.d1, Filt2.d2, bandpassParameter, ParameterStruct, composeParameter, decomposeParameter, -- for cascade+ causal, causalPacked, causalP, causalPackedP, ) where @@ -17,6 +18,7 @@ import qualified Synthesizer.Plain.Modifier as Modifier import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Causal.Process as Causal import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import qualified Synthesizer.LLVM.Simple.Value as Value @@ -108,8 +110,8 @@ instance (Value.Flatten a) => Value.Flatten (Parameter a) where type Registers (Parameter a) = Parameter (Value.Registers a)- flatten = Value.flattenTraversable- unfold = Value.unfoldFunctor+ flattenCode = Value.flattenCodeTraversable+ unfoldCode = Value.unfoldCodeTraversable @@ -143,8 +145,8 @@ instance (Value.Flatten a) => Value.Flatten (Filt2.State a) where type Registers (Filt2.State a) = Filt2.State (Value.Registers a)- flatten = Value.flattenTraversable- unfold = Value.unfoldFunctor+ flattenCode = Value.flattenCodeTraversable+ unfoldCode = Value.unfoldCodeTraversable {-# DEPRECATED bandpassParameter "only for testing, use Universal or Moog filter for production code" #-}@@ -166,7 +168,7 @@ kcos k2 modifier ::- (A.PseudoModule a v, A.IntegerConstant a) =>+ (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a) => Modifier.Simple (Filt2.State (Value.T v)) (Parameter (Value.T a))@@ -174,34 +176,52 @@ modifier = Filt2.modifier +causal ::+ (Causal.C process,+ a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a, Memory.C v) =>+ process (Parameter a, v) v+causal =+ Causal.fromModifier modifier++{-# DEPRECATED causalP "use causal instead" #-} causalP ::- (A.PseudoModule a v, A.IntegerConstant a, Memory.C v) =>+ (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a, Memory.C v) => CausalP.T p (Parameter a, v) v causalP = CausalP.fromModifier modifier +{-# DEPRECATED causalPackedP "use causalPacked instead" #-}+causalPackedP ::+ (Serial.C v, Serial.Element v ~ a,+ Memory.C v, Memory.C a, A.IntegerConstant v, A.IntegerConstant a,+ A.PseudoRing v, A.PseudoRing a) =>+ CausalP.T p (Parameter a, v) v+causalPackedP = causalPacked+ {- | Vector size must be at least D2. -}-causalPackedP,- causalRecursivePackedP ::- (Serial.C v, Serial.Element v ~ a,+causalPacked,+ causalRecursivePacked ::+ (Causal.C process,+ Serial.C v, Serial.Element v ~ a, Memory.C v, Memory.C a, A.IntegerConstant v, A.IntegerConstant a, A.PseudoRing v, A.PseudoRing a) =>- CausalP.T p (Parameter a, v) v-causalPackedP =- causalRecursivePackedP <<<- (arr fst &&& causalNonRecursivePackedP)+ process (Parameter a, v) v+causalPacked =+ causalRecursivePacked <<<+ (arr fst &&& causalNonRecursivePacked) -_causalRecursivePackedPAlt,- causalNonRecursivePackedP ::- (Serial.C v, Serial.Element v ~ a,+_causalRecursivePackedAlt,+ causalNonRecursivePacked ::+ (Causal.C process,+ Serial.C v, Serial.Element v ~ a, Memory.C a, A.IntegerConstant v, A.IntegerConstant a, A.PseudoRing v, A.PseudoRing a) =>- CausalP.T p (Parameter a, v) v-causalNonRecursivePackedP =- CausalP.mapAccumSimple+ process (Parameter a, v) v+causalNonRecursivePacked =+ Causal.mapAccum (\(p, v0) (x1,x2) -> do (u1n,v1) <- Serial.shiftUp x1 v0 (u2n,v2) <- Serial.shiftUp x2 v1@@ -243,8 +263,8 @@ f1x = f0x + a * f0x->1 + b * f0x->2 f2x = f1x + (a^2-2*b) * f1x->2 + b^2 * f1x->4 -}-causalRecursivePackedP =- CausalP.mapAccumSimple+causalRecursivePacked =+ Causal.mapAccum (\(p, x0) y1v -> do let size = Serial.size x0 @@ -287,8 +307,8 @@ return (xk2, xk2)) (return A.zero) -_causalRecursivePackedPAlt =- CausalP.mapAccumSimple+_causalRecursivePackedAlt =+ Causal.mapAccum (\(p, x0) (x1,x2) -> do let size = Serial.size x0 -- let xk1 = x0
src/Synthesizer/LLVM/Filter/SecondOrderCascade.hs view
@@ -3,12 +3,21 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-}-module Synthesizer.LLVM.Filter.SecondOrderCascade where+module Synthesizer.LLVM.Filter.SecondOrderCascade (+ causal, causalPacked,+ causalP, causalPackedP,+ ParameterValue(..),+ ParameterStruct,+ fixSize,+ ) where import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2 import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2Core +import qualified Synthesizer.LLVM.CausalParameterized.Functional as Func import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Causal.Process as Causal+import Synthesizer.LLVM.CausalParameterized.Functional (($&), (&|&), ) import qualified Synthesizer.LLVM.Frame.SerialVector as Serial @@ -20,19 +29,17 @@ import qualified LLVM.Core as LLVM import LLVM.Util.Loop (Phi, phis, addPhis, )-import LLVM.Core- (Value, valueOf,- IsArithmetic, IsSized,- CodeGenFunction, )+import LLVM.Core (Value, IsArithmetic, IsSized, CodeGenFunction, ) -import qualified Types.Data.Bool as TypeBool import qualified Types.Data.Num as TypeNum import Types.Data.Num.Ops ((:*:), ) import Data.Word (Word32, )+import Data.Tuple.HT (mapSnd, ) import qualified Control.Arrow as Arrow-import Control.Arrow ((>>>), (<<<), (&&&), arr, )+import Control.Arrow ((>>>), (<<<), (^<<), (<<^), (&&&), arr, )+import Control.Applicative (liftA2, ) -- import qualified Algebra.Transcendental as Trans -- import qualified Algebra.Field as Field@@ -73,7 +80,7 @@ Class.Zero (ParameterValue n a) where zeroTuple = ParameterValue Class.zeroTuple -instance (TypeNum.IntegerT n, TypeNum.IsNatural n ~ TypeBool.True,+instance (TypeNum.IntegerT n, TypeNum.NaturalT n, Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am, TypeNum.PositiveT (n :*: LLVM.UnknownSize)) => Memory.C (ParameterValue n a) where@@ -83,38 +90,33 @@ decompose = Memory.decomposeNewtype ParameterValue compose = Memory.composeNewtype (\(ParameterValue k) -> k) +type instance Func.Arguments f (ParameterValue n a) = f (ParameterValue n a)+instance Func.MakeArguments (ParameterValue n a) where+ makeArgs = id withSize ::- (n -> CausalP.T p (ParameterValue n a, x) y) ->- CausalP.T p (ParameterValue n a, x) y+ (n -> process (ParameterValue n a, x) y) ->+ process (ParameterValue n a, x) y withSize f = f undefined fixSize :: n ->- CausalP.T p (ParameterValue n a, x) y ->- CausalP.T p (ParameterValue n a, x) y+ process (ParameterValue n a, x) y ->+ process (ParameterValue n a, x) y fixSize _n = id causalP ::- (A.PseudoModule (LLVM.Value a) v,+ (LLVM.Value a ~ A.Scalar v, A.PseudoModule v, Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am, Memory.C v, IsArithmetic a, SoV.IntegerConstant a, TypeNum.NaturalT n, TypeNum.PositiveT (n :*: LLVM.UnknownSize)) => CausalP.T p (ParameterValue n a, v) v-causalP =- withSize $ \n ->- foldl (\x y -> (arr fst &&& x) >>> y) (arr snd) $- map- (\k ->- Filt2.causalP <<<- Arrow.first (CausalP.mapSimple- (\ps -> getStageParameter ps k)))- (take (TypeNum.fromIntegerT n) [0..])+causalP = causal causalPackedP ::- (A.PseudoModule (LLVM.Value a) v,+ (LLVM.Value a ~ A.Scalar v, A.PseudoModule v, Serial.C v, Serial.Element v ~ LLVM.Value a, SoV.IntegerConstant a, A.PseudoRing v, A.IntegerConstant v, Memory.C v,@@ -124,18 +126,96 @@ TypeNum.PositiveT (n :*: LLVM.UnknownSize), TypeNum.NaturalT n) => CausalP.T p (ParameterValue n a, v) v-causalPackedP =+causalPackedP = causalPacked+++causal ::+ (Causal.C process,+ LLVM.Value a ~ A.Scalar v, A.PseudoModule v,+ Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am,+ Memory.C v,+ IsArithmetic a, SoV.IntegerConstant a, TypeNum.NaturalT n,+ TypeNum.PositiveT (n :*: LLVM.UnknownSize)) =>+ process (ParameterValue n a, v) v+causal = causalGen Filt2.causal++causalPacked ::+ (Causal.C process,+ LLVM.Value a ~ A.Scalar v, A.PseudoModule v,+ Serial.C v, Serial.Element v ~ LLVM.Value a,+ SoV.IntegerConstant a,+ A.PseudoRing v, A.IntegerConstant v, Memory.C v,+ Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am,+ LLVM.IsPrimitive a,+ LLVM.IsPrimitive am,+ TypeNum.PositiveT (n :*: LLVM.UnknownSize),+ TypeNum.NaturalT n) =>+ process (ParameterValue n a, v) v+causalPacked = causalGen Filt2.causalPacked++causalGen ::+ (Causal.C process, IsSized a, Phi v, Undefined v,+ TypeNum.NaturalT n, TypeNum.PositiveT (n :*: LLVM.UnknownSize)) =>+ process (Filt2Core.Parameter (Value a), v) v ->+ process (ParameterValue n a, v) v+causalGen stage = withSize $ \n ->+ snd+ ^<<+ Causal.replicateControlled+ (TypeNum.fromIntegerT n)+ (paramStage stage)+ <<^+ (\(p,v) -> (p, (A.zero, v)))++paramStage ::+ (Causal.C process, IsSized a,+ TypeNum.NaturalT n, TypeNum.PositiveT (n :*: LLVM.UnknownSize)) =>+ process (Filt2Core.Parameter (Value a), v) v ->+ process (ParameterValue n a, (Value Word32, v)) (Value Word32, v)+paramStage stage =+ let p = arr fst+ i = arr (fst.snd)+ v = arr (snd.snd)+ in (Causal.map A.inc <<< i)+ &&&+ (stage <<<+ (Causal.zipWith getStageParameterAlloca <<< p &&& i)+ &&&+ v)++_paramStage ::+ (IsSized a,+ TypeNum.NaturalT n, TypeNum.PositiveT (n :*: LLVM.UnknownSize)) =>+ CausalP.T p (Filt2Core.Parameter (Value a), v) v ->+ CausalP.T p (ParameterValue n a, (Value Word32, v)) (Value Word32, v)+_paramStage stage =+ (Func.withArgs $ \(p,(i,v)) ->+ liftA2 (,) (i+1)+ (stage $&+ (Causal.zipWith getStageParameterAlloca $& p &|& i)+ &|&+ v))+ <<^+ mapSnd (mapSnd Func.AnyArg)++_causalGenP ::+ (Causal.C process, IsSized a,+ TypeNum.NaturalT n, TypeNum.PositiveT (n :*: LLVM.UnknownSize)) =>+ process (Filt2Core.Parameter (Value a), v) v ->+ process (ParameterValue n a, v) v+_causalGenP stage =+ withSize $ \n -> foldl (\x y -> (arr fst &&& x) >>> y) (arr snd) $ map (\k ->- Filt2.causalPackedP <<<- Arrow.first (CausalP.mapSimple- (\ps -> getStageParameter ps k)))+ stage <<<+ Arrow.first (Causal.map (flip getStageParameter k))) (take (TypeNum.fromIntegerT n) [0..]) -getStageParameter, getStageParameterMalloc, getStageParameterAlloca ::- (LLVM.IsFirstClass a, IsSized a, SoV.IntegerConstant a,++getStageParameter ::+ (IsSized a, TypeNum.NaturalT n, TypeNum.PositiveT (n :*: LLVM.UnknownSize)) => ParameterValue n a -> Word32 ->@@ -148,17 +228,23 @@ Memory.compose ps -} +_getStageParameterMalloc, getStageParameterAlloca ::+ (IsSized a,+ TypeNum.NaturalT n, TypeNum.PositiveT (n :*: LLVM.UnknownSize)) =>+ ParameterValue n a ->+ Value Word32 ->+ CodeGenFunction r (Filt2Core.Parameter (Value a)) {- Expensive because we need a heap allocation for every sample. However, we could allocate the memory once in the Causal initialization routine. -}-getStageParameterMalloc ps k = do+_getStageParameterMalloc ps k = do ptr <- LLVM.malloc LLVM.store (parameterValue ps) ptr p <- Filt2.decomposeParameter =<< LLVM.load- =<< LLVM.getElementPtr0 ptr (valueOf k, ())+ =<< LLVM.getElementPtr0 ptr (k, ()) LLVM.free ptr return p @@ -172,4 +258,7 @@ LLVM.store (parameterValue ps) ptr Filt2.decomposeParameter =<< LLVM.load- =<< LLVM.getElementPtr0 ptr (valueOf k, ())+ =<< LLVM.getElementPtr0 ptr (k, ())++{-# DEPRECATED causalP "use 'causal' instead" #-}+{-# DEPRECATED causalPackedP "use 'causalPacked' instead" #-}
src/Synthesizer/LLVM/Filter/SecondOrderPacked.hs view
@@ -4,13 +4,14 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} module Synthesizer.LLVM.Filter.SecondOrderPacked (- Parameter, bandpassParameter, State, causalP,+ Parameter, bandpassParameter, State, causal, causalP, ) where import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2L import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2 import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Causal.Process as Causal import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Vector as Vector import qualified LLVM.Extra.Memory as Memory@@ -115,20 +116,14 @@ yv <- Vector.assemble [x0, y0, x1new, y1new] return (y0, yv) +causal ::+ (Causal.C process, Vector.Arithmetic a, Memory.C (Value (State a))) =>+ process (Parameter a, Value a) (Value a)+causal =+ Causal.mapAccum next (return A.zero)++{-# DEPRECATED causalP "use causal instead" #-} causalP ::- (Vector.Arithmetic a,- Memory.C (Value (State a))) =>-{-- (Vector.Arithmetic a, IsPrimitive am,- Memory.FirstClass a am,- IsSized am ams,- Add ams ams ams2,- Add ams ams2 ams3,- Add ams ams3 ams4,- Sets.Pos ams4) =>--}- CausalP.T p- (Parameter a, Value a) (Value a)-causalP =- CausalP.mapAccumSimple next- (return (LLVM.value LLVM.zero))+ (Vector.Arithmetic a, Memory.C (Value (State a))) =>+ CausalP.T p (Parameter a, Value a) (Value a)+causalP = causal
src/Synthesizer/LLVM/Filter/Universal.hs view
@@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Synthesizer.LLVM.Filter.Universal ( Result(Result, lowpass, highpass, bandpass, bandlimit),- Parameter, parameter, causalP,+ Parameter, parameter, causal, causalP, ) where import qualified Synthesizer.Plain.Filter.Recursive.Universal as Universal@@ -13,6 +13,7 @@ import qualified Synthesizer.Plain.Modifier as Modifier import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Causal.Process as Causal import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import qualified Synthesizer.LLVM.Simple.Value as Value @@ -75,8 +76,8 @@ instance (Value.Flatten a) => Value.Flatten (Result a) where type Registers (Result a) = Result (Value.Registers a)- flatten = Value.flattenTraversable- unfold = Value.unfoldFunctor+ flattenCode = Value.flattenCodeTraversable+ unfoldCode = Value.unfoldCodeTraversable {-@@ -93,8 +94,8 @@ instance (Value.Flatten a) => Value.Flatten (Parameter a) where type Registers (Parameter a) = Parameter (Value.Registers a)- flatten = Value.flattenTraversable- unfold = Value.unfoldFunctor+ flattenCode = Value.flattenCodeTraversable+ unfoldCode = Value.unfoldCodeTraversable instance (Vector.Simple v) => Vector.Simple (Parameter v) where@@ -144,15 +145,13 @@ parameter :: (A.Transcendental a, A.RationalConstant a) => a -> a -> CodeGenFunction r (Parameter a)-parameter reson freq =- Value.flatten $- Universal.parameter- (Pole (Value.constantValue reson) (Value.constantValue freq))--- (Pole (Value.unfold reson) (Value.unfold freq))+parameter =+ Value.unlift2 $ \reson freq ->+ Universal.parameter (Pole reson freq) modifier ::- (A.PseudoModule a v, A.IntegerConstant a) =>+ (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a) => Modifier.Simple (Universal.State (Value.T v)) (Parameter (Value.T a))@@ -160,11 +159,17 @@ modifier = Universal.modifier +causal ::+ (Causal.C process,+ a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a, Memory.C v) =>+ process (Parameter a, v) (Result v)+causal = Causal.fromModifier modifier++{-# DEPRECATED causalP "use causal instead" #-} causalP ::- (A.PseudoModule a v, A.IntegerConstant a, Memory.C v) =>+ (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a, Memory.C v) => CausalP.T p (Parameter a, v) (Result v)-causalP =- CausalP.fromModifier modifier+causalP = causal {- The state variable filter could be vectorised
src/Synthesizer/LLVM/Frame/SerialVector.hs view
@@ -1,9 +1,8 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-} {- | A special vector type that represents a time-sequence of samples. This way we can distinguish safely between LLVM vectors@@ -23,11 +22,12 @@ Zero, writeZero, Iterator(Iterator), ReadIterator, WriteIterator, ReadMode, WriteMode, - Sized, Size, size, sizeOfIterator,+ Sized, Size, size, sizeOfIterator, withSize, insertTraversable, extractTraversable, readStartTraversable, readNextTraversable, writeStartTraversable, writeNextTraversable, writeStopTraversable,+ writeZeroTraversable, extractAll, assemble, modify, upsample, subsample,@@ -44,9 +44,9 @@ import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Util.Loop as Loop import qualified LLVM.Core as LLVM-import LLVM.Extra.Class- (MakeValueTuple, valueTupleOf, )+import LLVM.Extra.Class (MakeValueTuple, valueTupleOf, ) import LLVM.Util.Loop (Phi, ) import qualified Types.Data.Num as TypeNum@@ -85,15 +85,60 @@ newtype T v = Cons v deriving ( Eq, St.Storable,- Class.Zero, Class.Undefined, Phi,- A.Additive, A.PseudoRing, A.Field, A.Real, A.Fraction,- A.Algebraic, A.Transcendental,+ Class.Zero, Class.Undefined, A.IntegerConstant, A.RationalConstant, Num) -- SoV.IntegerConstant, SoV.RationalConstant, SoV.TranscendentalConstant) -instance (A.PseudoModule a v) => A.PseudoModule a (T v) where+instance (Phi v) => Phi (T v) where+ phis bb (Cons v) = fmap Cons $ Loop.phis bb v+ addPhis bb (Cons x) (Cons y) = Loop.addPhis bb x y++instance (A.Additive v) => A.Additive (T v) where+ add = lift2 A.add+ sub = lift2 A.sub+ neg = lift1 A.neg+ zero = Cons A.zero++instance (A.PseudoRing v) => A.PseudoRing (T v) where+ mul = lift2 A.mul++instance (A.Real v) => A.Real (T v) where+ min = lift2 A.min+ max = lift2 A.max+ abs = lift1 A.abs+ signum = lift1 A.signum++instance (A.Fraction v) => A.Fraction (T v) where+ truncate = lift1 A.truncate+ fraction = lift1 A.fraction++instance (A.Field v) => A.Field (T v) where+ fdiv = lift2 A.fdiv++instance (A.Algebraic v) => A.Algebraic (T v) where+ sqrt = lift1 A.sqrt++instance (A.Transcendental v) => A.Transcendental (T v) where+ pi = fmap Cons A.pi+ sin = lift1 A.sin+ log = lift1 A.log+ exp = lift1 A.exp+ cos = lift1 A.cos+ pow = lift2 A.pow+++lift1 :: Functor f => (a -> f b) -> T a -> f (T b)+lift1 f (Cons x) = fmap Cons $ f x++lift2 :: Functor f => (a -> b -> f c) -> T a -> T b -> f (T c)+lift2 f (Cons x) (Cons y) = fmap Cons $ f x y+++type instance A.Scalar (T v) = A.Scalar v+instance (A.PseudoModule v) => A.PseudoModule (T v) where scale a (Cons v) = fmap Cons $ A.scale a v + type instance F.Arguments f (T v) = f (T v) instance F.MakeArguments (T v) where makeArgs = id@@ -124,8 +169,13 @@ newtype Iterator mode it v = Iterator {unIterator :: it}- deriving (Class.Undefined, Phi)+ deriving (Class.Undefined) +instance Phi it => Phi (Iterator mode it v) where+ phis bb (Iterator x) = fmap Iterator $ Loop.phis bb x+ addPhis bb (Iterator x) (Iterator y) = Loop.addPhis bb x y++ type ReadIterator = Iterator ReadMode type WriteIterator = Iterator WriteMode @@ -379,8 +429,7 @@ instance (Zero v) => Zero (Stereo.T v) where - writeZero =- fmap combineItFunctor $ Trav.sequence $ App.pure writeZero+ writeZero = writeZeroTraversable modify ::@@ -396,7 +445,7 @@ (Read v) => v -> LLVM.CodeGenFunction r (Element v) subsample v =- extract (LLVM.value LLVM.zero :: LLVM.Value Word32) v+ extract (A.zero :: LLVM.Value Word32) v -- this will be translated to an efficient pshufd upsample ::@@ -495,6 +544,9 @@ writeStopTraversable :: (Trav.Traversable f, App.Applicative f, C v) => WriteIterator (f (WriteIt v)) (f v) -> LLVM.CodeGenFunction r (f v)+writeZeroTraversable ::+ (Trav.Traversable f, App.Applicative f, Zero v) =>+ LLVM.CodeGenFunction r (WriteIterator (f (WriteIt v)) (f v)) writeStartTraversable = fmap combineItFunctor $ Trav.sequence $ App.pure writeStart@@ -505,7 +557,10 @@ writeStopTraversable = Trav.mapM writeStop . sequenceItFunctor +writeZeroTraversable =+ fmap combineItFunctor $ Trav.sequence $ App.pure writeZero + instance (MakeValueTuple v) => MakeValueTuple (T v) where type ValueTuple (T v) = T (Class.ValueTuple v) valueTupleOf (Cons v) = Cons (Class.valueTupleOf v)@@ -551,7 +606,7 @@ sizeOfIterator :: Sized v => Iterator mode it v -> Int sizeOfIterator = let sz :: Sized v => v -> Iterator mode it v -> Int- sz v _ = fromIntegral $ size v+ sz v _ = size v in sz undefined
src/Synthesizer/LLVM/Frame/Stereo.hs view
@@ -9,12 +9,13 @@ -} module Synthesizer.LLVM.Frame.Stereo ( Stereo.T, Stereo.cons, Stereo.left, Stereo.right,+ Stereo.Channel(Left, Right), Stereo.select, Stereo.arrowFromMono, Stereo.arrowFromMonoControlled, Stereo.arrowFromChannels,- interleave,- sequence,- liftApplicative,+ Stereo.interleave,+ Stereo.sequence,+ Stereo.liftApplicative, ) where import qualified Synthesizer.Frame.Stereo as Stereo@@ -33,28 +34,10 @@ import Types.Data.Num (d0, d1, ) import Control.Monad (liftM2, )-import Control.Applicative (Applicative, liftA2, )+import Control.Applicative (liftA2, ) import qualified Data.Traversable as Trav -import Prelude hiding (sequence, )----- if it turns out to be useful, we may move it to sample-frame package-interleave :: (Stereo.T a, Stereo.T b) -> Stereo.T (a,b)-interleave = uncurry (liftA2 (,))---- if it turns out to be useful, we may move it to sample-frame package-sequence :: (Functor f) => f (Stereo.T a) -> Stereo.T (f a)-sequence x =- Stereo.cons- (fmap Stereo.left x)- (fmap Stereo.right x)--liftApplicative ::- (Applicative f) =>- (f a -> f b) -> f (Stereo.T a) -> f (Stereo.T b)-liftApplicative proc =- Trav.sequenceA . fmap proc . sequence+import Prelude hiding (Either(Left, Right), sequence, ) instance (Class.Zero a) => Class.Zero (Stereo.T a) where
src/Synthesizer/LLVM/Frame/StereoInterleaved.hs view
@@ -26,12 +26,16 @@ Value(Value), interleave, deinterleave,+ fromMono, assemble, extractAll,+ zero, amplify,+ envelope, ) where import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Frame.SerialVector as Serial+import qualified Synthesizer.LLVM.CausalParameterized.Functional as F import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Control as C@@ -55,16 +59,23 @@ import qualified Data.Foldable as Fold import Control.Monad (liftM2, )-import Control.Applicative (liftA2, )+import Control.Applicative (liftA2, pure, ) import Data.Tuple.HT (mapPair, ) +import qualified Algebra.Additive as Additive + data T n a = Cons (Vector n a) (Vector n a) data Value n a = Value (LLVM.Value (Vector n a)) (LLVM.Value (Vector n a)) +type instance F.Arguments f (Value n a) = f (Value n a)+instance F.MakeArguments (Value n a) where+ makeArgs = id++ withSize :: (TypeNum.IntegerT n) => (Int -> m (Value n a)) -> m (Value n a) withSize = let sz :: (TypeNum.IntegerT n) => n -> (Int -> m (Value n a)) -> m (Value n a)@@ -86,6 +97,13 @@ deinterleave v = Serial.assemble =<< extractAll v +fromMono ::+ (LLVM.IsPrimitive a, TypeNum.PositiveT n) =>+ Serial.Value n a ->+ LLVM.CodeGenFunction r (Value n a)+fromMono x =+ assemble . map pure =<< Serial.extractAll x+ assemble :: (LLVM.IsPrimitive a, TypeNum.IntegerT n, TypeNum.PositiveT n) => [Stereo.T (LLVM.Value a)] -> LLVM.CodeGenFunction r (Value n a)@@ -126,7 +144,7 @@ St.pokeElemOff p 1 v1 instance (TypeNum.PositiveT n, LLVM.IsPrimitive a) => Class.Zero (Value n a) where- zeroTuple = Value (LLVM.value LLVM.zero) (LLVM.value LLVM.zero)+ zeroTuple = Value Class.zeroTuple Class.zeroTuple instance (TypeNum.PositiveT n, LLVM.IsPrimitive a) => Undefined (Value n a) where undefTuple = Value (LLVM.value LLVM.undef) (LLVM.value LLVM.undef)@@ -260,6 +278,10 @@ neg = mapV A.neg +zero :: (TypeNum.PositiveT n, Additive.C a) => (T n a)+zero = Cons (LLVM.vector [Additive.zero]) (LLVM.vector [Additive.zero])++ scale :: (TypeNum.PositiveT n, LLVM.IsPrimitive a, LLVM.IsArithmetic a) => LLVM.Value a -> Value n a -> LLVM.CodeGenFunction r (Value n a)@@ -271,6 +293,12 @@ (TypeNum.PositiveT n, LLVM.IsPrimitive a, LLVM.IsArithmetic a, LLVM.IsConst a) => a -> Value n a -> LLVM.CodeGenFunction r (Value n a) amplify a = scale (LLVM.valueOf a)++envelope ::+ (TypeNum.PositiveT n, LLVM.IsPrimitive a, LLVM.IsArithmetic a, LLVM.IsConst a) =>+ Serial.Value n a -> Value n a -> LLVM.CodeGenFunction r (Value n a)+envelope e a =+ zipV Value (flip A.mul) a =<< fromMono e mapV :: (Monad m) =>
src/Synthesizer/LLVM/Generator/Exponential2.hs view
@@ -118,8 +118,8 @@ instance (Value.Flatten a) => Value.Flatten (Parameter a) where type Registers (Parameter a) = Parameter (Value.Registers a)- flatten = Value.flattenTraversable- unfold = Value.unfoldFunctor+ flattenCode = Value.flattenCodeTraversable+ unfoldCode = Value.unfoldCodeTraversable instance (Vector.Simple v) => Vector.Simple (Parameter v) where@@ -136,9 +136,7 @@ (Trans.C a, SoV.TranscendentalConstant a, IsFloating a) => Value a -> CodeGenFunction r (Parameter (Value a))-parameter halfLife =- Value.flatten $ parameterPlain $- Value.constantValue halfLife+parameter = Value.unlift1 parameterPlain parameterPlain :: (Trans.C a) =>@@ -252,8 +250,8 @@ instance (Value.Flatten a) => Value.Flatten (ParameterPacked a) where type Registers (ParameterPacked a) = ParameterPacked (Value.Registers a)- flatten = Value.flattenTraversable- unfold = Value.unfoldFunctor+ flattenCode = Value.flattenCodeTraversable+ unfoldCode = Value.unfoldCodeTraversable type instance F.Arguments f (ParameterPacked a) = f (ParameterPacked a) instance F.MakeArguments (ParameterPacked a) where@@ -284,8 +282,7 @@ Serial.iterate (A.mul k) (A.fromInteger' 1) return $ ParameterPacked feedback current {-- Value.flatten $ parameterPackedPlain $- Value.constantValue halfLife+ Value.unlift1 parameterPackedPlain -} withSizePlain ::
+ src/Synthesizer/LLVM/Interpolation.hs view
@@ -0,0 +1,269 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeFamilies #-}+module Synthesizer.LLVM.Interpolation (+ C(margin),+ loadNodes,+ indexNodes,++ Margin(..),+ toMargin,++ T,++ Nodes02(..),+ linear,+ linearVector,++ Nodes13(..),+ cubic,+ cubicVector,+ ) where++import qualified Synthesizer.LLVM.Simple.Value as Value++import qualified Synthesizer.LLVM.Frame.SerialVector as Serial+import qualified Synthesizer.Interpolation.Core as Interpolation++import qualified LLVM.Extra.Scalar as Scalar+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Util.Loop as Loop+import qualified LLVM.Core as LLVM++import LLVM.Core (CodeGenFunction, Value, )++import Foreign.Ptr (Ptr, )+import Data.Word (Word32, )++import qualified Types.Data.Num as TypeNum++import qualified Control.Monad.Trans.State as MS+import Control.Applicative (Applicative, liftA2, pure, (<*>), )+import Data.Traversable (Traversable, traverse, sequenceA, foldMapDefault, )+import Data.Foldable (Foldable, foldMap, )+++class (Applicative nodes, Traversable nodes) => C nodes where+ margin :: Margin (nodes a)++data Margin nodes =+ Margin { marginNumber, marginOffset :: Int }+ deriving (Show, Eq)+++type T r nodes a v = a -> nodes v -> CodeGenFunction r v+++toMargin ::+ (C nodes) =>+ (forall r. T r nodes a v) ->+ Margin (nodes v)+toMargin _ = margin+++{- |+Zero nodes before index 0 and two nodes starting from index 0.+-}+data Nodes02 a = Nodes02 {nodes02_0, nodes02_1 :: a}++instance C Nodes02 where+ margin = Margin { marginNumber = 2, marginOffset = 0 }+++instance Functor Nodes02 where+ fmap f (Nodes02 x0 x1) = Nodes02 (f x0) (f x1)++instance Applicative Nodes02 where+ pure x = Nodes02 x x+ (Nodes02 f0 f1) <*> (Nodes02 x0 x1) = Nodes02 (f0 x0) (f1 x1)++instance Foldable Nodes02 where+ foldMap = foldMapDefault++instance Traversable Nodes02 where+ traverse f (Nodes02 x0 x1) = liftA2 Nodes02 (f x0) (f x1)+++instance (Serial.Sized value) => Serial.Sized (Nodes02 value) where+ type Size (Nodes02 value) = Serial.Size value++instance (Serial.Read v) => Serial.Read (Nodes02 v) where+ type Element (Nodes02 v) = Nodes02 (Serial.Element v)+ type ReadIt (Nodes02 v) = Nodes02 (Serial.ReadIt v)++ extract = Serial.extractTraversable++ readStart = Serial.readStartTraversable+ readNext = Serial.readNextTraversable++instance (Serial.C v) => Serial.C (Nodes02 v) where+ type WriteIt (Nodes02 v) = Nodes02 (Serial.WriteIt v)++ insert = Serial.insertTraversable++ writeStart = Serial.writeStartTraversable+ writeNext = Serial.writeNextTraversable+ writeStop = Serial.writeStopTraversable+++instance (Class.Undefined a) => Class.Undefined (Nodes02 a) where+ undefTuple = Class.undefTuplePointed++instance (Loop.Phi a) => Loop.Phi (Nodes02 a) where+ phis = Class.phisTraversable+ addPhis = Class.addPhisFoldable+++type Struct02 a = LLVM.Struct (a, (a, ()))++memory02 ::+ (Memory.C l) =>+ Memory.Record r (Struct02 (Memory.Struct l)) (Nodes02 l)+memory02 =+ liftA2 Nodes02+ (Memory.element nodes02_0 TypeNum.d0)+ (Memory.element nodes02_1 TypeNum.d1)++instance (Memory.C l) => Memory.C (Nodes02 l) where+ type Struct (Nodes02 l) = Struct02 (Memory.Struct l)+ load = Memory.loadRecord memory02+ store = Memory.storeRecord memory02+ decompose = Memory.decomposeRecord memory02+ compose = Memory.composeRecord memory02+++linear ::+ (A.PseudoRing a, A.IntegerConstant a) =>+ T r Nodes02 a a+linear r (Nodes02 a b) =+ Scalar.unliftM3 (Value.unlift3 Interpolation.linear) a b r++linearVector ::+ (A.PseudoModule v, A.Scalar v ~ a, A.IntegerConstant a) =>+ T r Nodes02 a v+linearVector r (Nodes02 a b) =+ Value.unlift3 Interpolation.linear a b r+++++{- |+One node before index 0 and three nodes starting from index 0.+-}+data Nodes13 a = Nodes13 {nodes13_0, nodes13_1, nodes13_2, nodes13_3 :: a}++instance C Nodes13 where+ margin = Margin { marginNumber = 4, marginOffset = 1 }++instance Functor Nodes13 where+ fmap f (Nodes13 x0 x1 x2 x3) = Nodes13 (f x0) (f x1) (f x2) (f x3)++instance Applicative Nodes13 where+ pure x = Nodes13 x x x x+ (Nodes13 f0 f1 f2 f3) <*> (Nodes13 x0 x1 x2 x3) =+ Nodes13 (f0 x0) (f1 x1) (f2 x2) (f3 x3)++instance Foldable Nodes13 where+ foldMap = foldMapDefault++instance Traversable Nodes13 where+ traverse f (Nodes13 x0 x1 x2 x3) =+ pure Nodes13 <*> f x0 <*> f x1 <*> f x2 <*> f x3+++instance (Serial.Sized value) => Serial.Sized (Nodes13 value) where+ type Size (Nodes13 value) = Serial.Size value++instance (Serial.Read v) => Serial.Read (Nodes13 v) where+ type Element (Nodes13 v) = Nodes13 (Serial.Element v)+ type ReadIt (Nodes13 v) = Nodes13 (Serial.ReadIt v)++ extract = Serial.extractTraversable++ readStart = Serial.readStartTraversable+ readNext = Serial.readNextTraversable++instance (Serial.C v) => Serial.C (Nodes13 v) where+ type WriteIt (Nodes13 v) = Nodes13 (Serial.WriteIt v)++ insert = Serial.insertTraversable++ writeStart = Serial.writeStartTraversable+ writeNext = Serial.writeNextTraversable+ writeStop = Serial.writeStopTraversable+++instance (Class.Undefined a) => Class.Undefined (Nodes13 a) where+ undefTuple = Class.undefTuplePointed++instance (Loop.Phi a) => Loop.Phi (Nodes13 a) where+ phis = Class.phisTraversable+ addPhis = Class.addPhisFoldable+++type Struct13 a = LLVM.Struct (a, (a, (a, (a, ()))))++memory13 ::+ (Memory.C l) =>+ Memory.Record r (Struct13 (Memory.Struct l)) (Nodes13 l)+memory13 =+ pure Nodes13+ <*> Memory.element nodes13_0 TypeNum.d0+ <*> Memory.element nodes13_1 TypeNum.d1+ <*> Memory.element nodes13_2 TypeNum.d2+ <*> Memory.element nodes13_3 TypeNum.d3++instance (Memory.C l) => Memory.C (Nodes13 l) where+ type Struct (Nodes13 l) = Struct13 (Memory.Struct l)+ load = Memory.loadRecord memory13+ store = Memory.storeRecord memory13+ decompose = Memory.decomposeRecord memory13+ compose = Memory.composeRecord memory13+++cubic ::+ (A.Field a, A.RationalConstant a) =>+ T r Nodes13 a a+cubic r (Nodes13 a b c d) =+ Scalar.unliftM5 (Value.unlift5 Interpolation.cubic) a b c d r++cubicVector ::+ (A.PseudoModule v, A.Scalar v ~ a, A.Field a, A.RationalConstant a) =>+ T r Nodes13 a v+cubicVector r (Nodes13 a b c d) =+ Value.unlift5 Interpolation.cubic a b c d r+++loadNodes ::+ (C nodes) =>+ (Value (Ptr am) -> CodeGenFunction r a) ->+ Value Word32 ->+ Value (Ptr am) -> CodeGenFunction r (nodes a)+loadNodes loadNode step =+ MS.evalStateT $ sequenceA $ pure $ loadNext loadNode step++loadNext ::+ (Value (Ptr am) -> CodeGenFunction r a) ->+ Value Word32 ->+ MS.StateT (Value (Ptr am)) (CodeGenFunction r) a+loadNext loadNode step =+ MS.StateT $ \ptr ->+ liftA2 (,) (loadNode ptr) (LLVM.getElementPtr ptr (step, ()))++++indexNodes ::+ (C nodes) =>+ (Value Word32 -> CodeGenFunction r v) ->+ Value Word32 ->+ Value Word32 -> CodeGenFunction r (nodes v)+indexNodes indexNode step =+ MS.evalStateT $ sequenceA $ pure $ indexNext indexNode step++indexNext ::+ (Value Word32 -> CodeGenFunction r v) ->+ Value Word32 ->+ MS.StateT (Value Word32) (CodeGenFunction r) v+indexNext indexNode step =+ MS.StateT $ \i -> liftA2 (,) (indexNode i) (A.add i step)
src/Synthesizer/LLVM/MIDI.hs view
@@ -2,11 +2,13 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-} {- | Convert MIDI events of a MIDI controller to a control signal. -} module Synthesizer.LLVM.MIDI (- module Synthesizer.LLVM.MIDI,+ frequencyFromBendModulation,+ frequencyFromBendModulationPacked, Gen.applyModulation, ) where @@ -15,8 +17,9 @@ import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import Synthesizer.LLVM.CausalParameterized.Process (($>), )-import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS+import qualified Synthesizer.LLVM.CausalParameterized.Functional as Func 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 Wave@@ -29,7 +32,6 @@ import qualified LLVM.Core as LLVM import LLVM.Core (IsSized, SizeOf, ) -import qualified Types.Data.Bool as TypeBool import qualified Types.Data.Num as TypeNum import Types.Data.Num.Ops ((:*:), ) @@ -40,10 +42,11 @@ import Control.Arrow (second, (<<<), (<<^), ) import Control.Monad ({- liftM, -} liftM2, )+import Data.Tuple.HT (mapPair, ) -- import NumericPrelude.Base import NumericPrelude.Numeric-import Prelude ()+import Prelude (($), ) {-@@ -132,7 +135,7 @@ press <- channelPressure chan pressDepth 0 return $ SigP.envelope bend $- SigP.mapSimple (A.add (LLVM.valueOf 1)) $+ SigP.mapSimple (A.add A.one) $ SigP.envelope (SigP.mix fm press) (SigP.osciSimple Wave.approxSine2 zero $# speed)@@ -145,11 +148,7 @@ Param.T p y -> CausalP.T p (BM.T yl) yl frequencyFromBendModulation speed =- CausalP.envelope- <<<- second- (CausalP.mapSimple (A.add (A.fromInteger' 1)) <<< CausalP.envelope- $> SigP.osciSimple Wave.approxSine2 zero speed)+ frequencyFromPair SigP.osciSimple speed <<^ (\(BM.Cons b m) -> (b,m)) @@ -160,18 +159,31 @@ LLVM.IsPrimitive am, Storable a, Class.MakeValueTuple a, Class.ValueTuple a ~ (LLVM.Value a), Vector.Real a, SoV.IntegerConstant a,- TypeNum.PositiveT n, TypeNum.IsPositive n ~ TypeBool.True,+ TypeNum.PositiveT n, TypeNum.PositiveT (n :*: SizeOf a), TypeNum.PositiveT (n :*: SizeOf am)) => Param.T p a -> CausalP.T p (BM.T (LLVM.Value a)) (Serial.Value n a) frequencyFromBendModulationPacked speed =- CausalP.envelope- <<<- second- (CausalP.mapSimple (A.add (A.fromInteger' 1)) <<< CausalP.envelope- $> SigPS.osciSimple Wave.approxSine2 zero speed)+ frequencyFromPair SigPS.osciSimple speed <<< CausalP.mapSimple (\(BM.Cons b m) -> liftM2 (,) (Serial.upsample b) (Serial.upsample m))++frequencyFromPair, _frequencyFromPair ::+ (Additive.C y, A.PseudoRing yl, A.IntegerConstant yl, A.Fraction yl) =>+ ((forall r. yl -> LLVM.CodeGenFunction r yl) ->+ Param.T p y -> Param.T p y -> SigP.T p yl) ->+ Param.T p y ->+ CausalP.T p (yl,yl) yl+frequencyFromPair osci speed =+ (Func.withArgs $ \(b, m) ->+ b * (1 + m * Func.fromSignal (osci Wave.approxSine2 zero speed)))+ <<^+ mapPair (Func.AnyArg, Func.AnyArg)++_frequencyFromPair osci speed =+ CausalP.envelope+ <<<+ second (1 + (CausalP.envelope $> osci Wave.approxSine2 zero speed))
src/Synthesizer/LLVM/Parameter.hs view
@@ -1,8 +1,13 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleContexts #-} module Synthesizer.LLVM.Parameter where import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.Memory as Memory+import Foreign.Storable.Tuple ()+import Foreign.Storable (Storable, ) import qualified Algebra.Transcendental as Trans import qualified Algebra.Algebraic as Algebraic@@ -16,9 +21,10 @@ import Control.Applicative (pure, liftA2, ) import Data.Tuple.HT (mapFst, )+import Data.Word (Word32, ) import NumericPrelude.Numeric-import Prelude (fmap, error, (.), const, id, Functor, Monad, )+import Prelude (Functor, Monad, fmap, error, (.), const, id, ) import qualified Prelude as P @@ -73,6 +79,37 @@ T p tuple -> value -> value value (Constant a) _ = Class.valueTupleOf a value (Variable _) v = v+++{- |+This function provides specialised variants of 'get' and 'value',+that use the unit type for constants+and thus save space in parameter structures.+-}+with ::+ (Storable tuple, Class.MakeValueTuple tuple,+ Class.ValueTuple tuple ~ value, Memory.C value) =>+ T p tuple ->+ (forall parameters.+ (Storable parameters,+ Class.MakeValueTuple parameters,+ Memory.C (Class.ValueTuple parameters)) =>+ (p -> parameters) ->+ (Class.ValueTuple parameters -> value) ->+ a) ->+ a+with (Constant a) f = f (const ()) (\() -> Class.valueTupleOf a)+with (Variable v) f = f v id+++word32 :: T p Int -> T p Word32+word32 = fmap fromIntegral+++infixl 0 $#++($#) :: (T p a -> b) -> (a -> b)+($#) f a = f (pure a) {- |
src/Synthesizer/LLVM/Parameterized/Signal.hs view
@@ -10,21 +10,19 @@ ) where import Synthesizer.LLVM.Parameterized.SignalPrivate-import qualified Synthesizer.LLVM.CausalParameterized.ProcessPrivate as Causal+import qualified Synthesizer.LLVM.CausalParameterized.ProcessPrivate as CausalP import qualified Synthesizer.LLVM.Parameter as Param import qualified Synthesizer.LLVM.ConstantPiece as Const +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo+import qualified Synthesizer.LLVM.Frame as Frame import qualified Synthesizer.LLVM.Random as Rnd import qualified Synthesizer.LLVM.Wave as Wave-import qualified Synthesizer.LLVM.Frame as Frame import qualified Synthesizer.LLVM.Execution as Exec--import qualified LLVM.Extra.MaybeContinuation as Maybe-import qualified LLVM.Extra.ForeignPtr as ForeignPtr-import qualified LLVM.Extra.Memory as Memory-import LLVM.Extra.Control (whileLoop, ifThen, )+import qualified Synthesizer.LLVM.Alloc as Alloc import qualified Synthesizer.LLVM.Storable.ChunkIterator as ChunkIt+import qualified Synthesizer.LLVM.Storable.Vector as SVU import qualified Data.StorableVector.Lazy.Pattern as SVP import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector as SV@@ -34,15 +32,25 @@ import qualified Numeric.NonNegative.Chunky as Chunky import qualified Numeric.NonNegative.Wrapper as NonNeg -import qualified Synthesizer.LLVM.Frame.Stereo as Stereo- import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.MaybeContinuation as MaybeCont+import qualified LLVM.Extra.Either as Either+import qualified LLVM.Extra.Maybe as Maybe+import qualified LLVM.Extra.ForeignPtr as ForeignPtr+import qualified LLVM.Extra.Memory as Memory+import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, ) import LLVM.Extra.Arithmetic (advanceArrayElementPtr, )-import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, undefTuple, )+import LLVM.Extra.Control (whileLoop, ifThen, ) -import LLVM.Core as LLVM import qualified LLVM.Util.Loop as Loop+import qualified LLVM.Core as LLVM+import LLVM.Core+ (CodeGenFunction, ret, Value, value, valueOf,+ IsSized, IsConst, IsArithmetic, IsFloating,+ CodeGenModule, Linkage(ExternalLinkage),+ Function, createNamedFunction, )+ import qualified Types.Data.Num as TypeNum import Control.Monad.HT ((<=<), )@@ -55,61 +63,29 @@ import qualified Algebra.RealField as RealField import qualified Algebra.Algebraic as Algebraic import qualified Algebra.Field as Field-import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive +import Data.Tuple.HT (mapSnd, ) import Data.Word (Word8, Word32, ) import Data.Int (Int32, ) import Foreign.Storable.Tuple () import Foreign.Storable (Storable, )-import Foreign.Marshal.Array (advancePtr, )-import qualified Synthesizer.LLVM.Alloc as Alloc import Foreign.ForeignPtr (touchForeignPtr, withForeignPtr, )-import Foreign.Ptr (FunPtr, nullPtr, )+import Foreign.Ptr (FunPtr, Ptr, nullPtr, ) import Control.Exception (bracket, ) import qualified System.Unsafe as Unsafe+import qualified Foreign.Concurrent as FC import qualified Synthesizer.LLVM.Debug.Storable as DebugSt import qualified Synthesizer.LLVM.Debug.Counter as Counter import NumericPrelude.Numeric-import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, )+import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, cycle, ) -- for debugMain import qualified Control.Monad.Trans.Reader as R -infixl 0 $#--($#) :: (Param.T p a -> b) -> (a -> b)-($#) f a = f (return a)---mapAccum ::- (Storable pnh, MakeValueTuple pnh, ValueTuple pnh ~ pnl, Memory.C pnl,- Storable psh, MakeValueTuple psh, ValueTuple psh ~ psl, Memory.C psl,- Memory.C s) =>- (forall r. pnl -> a -> s -> CodeGenFunction r (b,s)) ->- (forall r. psl -> CodeGenFunction r s) ->- Param.T p pnh ->- Param.T p psh ->- T p a -> T p b-mapAccum f startS selectParamF selectParamS- (Cons next start createIOContext deleteIOContext) =- Cons- (\(parameterF, parameter) (sa0,ss0) -> do- (a,sa1) <- next parameter sa0- (b,ss1) <- Maybe.lift $ f (Param.value selectParamF parameterF) a ss0- return (b, (sa1,ss1)))- (\(parameterF, parameter) ->- liftM2 (,) (start parameter) (startS (Param.value selectParamS parameterF)))- (\p -> do- (ioContext, (nextParam, startParam)) <- createIOContext p- return (ioContext, ((Param.get selectParamF p, nextParam),- (Param.get selectParamS p, startParam))))- deleteIOContext-- zip :: T p a -> T p b -> T p (a,b) zip = liftA2 (,) @@ -121,43 +97,42 @@ -} tail :: T p a -> T p a-tail (Cons next start createIOContext deleteIOContext) = Cons+tail (Cons next start stop createIOContext deleteIOContext) = Cons next- (\(nextParameter, startParameter) -> do- s0 <- start startParameter- Maybe.resolve (next nextParameter s0)- (return s0)- (\(_a,s1) -> return s1))- (\p -> do- (ioContext, (nextParam, startParam)) <- createIOContext p- return (ioContext, (nextParam, (nextParam, startParam))))+ (\parameter -> do+ (c,s0) <- start parameter+ MaybeCont.resolve (next c s0)+ (return (c,s0))+ (\(_a,s1) -> return (c,s1)))+ stop+ createIOContext deleteIOContext drop :: Param.T p Int -> T p a -> T p a-drop n (Cons next start createIOContext deleteIOContext) =- let n32 = fmap (fromIntegral :: Int -> Word32) n in Cons+drop n (Cons next start stop createIOContext deleteIOContext) =+ Param.with (Param.word32 n) $ \getN valueN -> Cons next- (\(nextParameter, i0, startParameter) -> do- s0 <- start startParameter+ (\(parameter, i0) -> do+ (c,s0) <- start parameter (_, _, s3) <-- whileLoop (valueOf True, Param.value n32 i0, s0)+ whileLoop (valueOf True, valueN i0, s0) (\(cont,i1,_s1) -> A.and cont =<<- A.cmp CmpGT i1 (value LLVM.zero))+ A.cmp LLVM.CmpGT i1 A.zero) (\(_cont,i1,s1) -> do (cont, s2) <-- Maybe.resolve (next nextParameter s1)+ MaybeCont.resolve (next c s1) (return (valueOf False, s1)) (\(_a,s) -> return (valueOf True, s)) i2 <- A.dec i1 return (cont, i2, s2))- return s3)+ return (c, s3))+ stop (\p -> do- (ioContext, (nextParam, startParam)) <- createIOContext p- return (ioContext, (nextParam,- (nextParam, Param.get n32 p, startParam))))+ (ioContext, param) <- createIOContext p+ return (ioContext, (param, getN p))) deleteIOContext {- |@@ -170,40 +145,64 @@ {- We might save a little space by using a union for the states of the first and the second signal generator.+If the concatenated generators allocate memory,+we could also save some memory by calling @startB@+only after the first generator finished.+However, for correct deallocation+we would need to track which of the @start@ blocks+have been executed so far.+This in turn might be difficult in connection with the garbage collector. -} append :: (Loop.Phi a, Undefined a) => T p a -> T p a -> T p a append- (Cons nextA startA createIOContextA deleteIOContextA)- (Cons nextB startB createIOContextB deleteIOContextB) =+ (Cons nextA startA stopA createIOContextA deleteIOContextA)+ (Cons nextB startB stopB createIOContextB deleteIOContextB) = Cons- (\(parameterA, parameterB) (firstPart,(sa0,sb0)) ->- Maybe.fromBool $ do- (contA, (a,sa1)) <-- ifThen firstPart (valueOf False, (undefTuple,sa0))- (Maybe.toBool $ nextA parameterA sa0)- secondPart <- inv contA- (contB, (b,sb1)) <-- ifThen secondPart (valueOf True, (a,sb0))- (Maybe.toBool $ nextB parameterB sb0)- return (contB, (b, (contA, (sa1,sb1)))))- (\(parameterA, parameterB) ->- fmap ((,) (valueOf True)) $- liftM2 (,)- (startA parameterA)- (startB parameterB))- (\p -> do- (ca,(nextParamA,startParamA)) <- createIOContextA p- (cb,(nextParamB,startParamB)) <- createIOContextB p- return ((ca,cb),- ((nextParamA, nextParamB),- (startParamA, startParamB))))- (\(ca,cb) ->- deleteIOContextA ca >>- deleteIOContextB cb)+ (\parameterB ecs0 -> MaybeCont.fromMaybe $ do+ ecs1 <-+ Either.run ecs0+ (\(ca, sa0) ->+ MaybeCont.resolve+ (nextA ca sa0)+ (fmap Either.right $ startB parameterB)+ (\(a1,sa1) -> return (Either.left (a1, (ca, sa1)))))+ (return . Either.right) + Either.run ecs1+ (\(a1,cs1) ->+ return (Maybe.just (a1, Either.left cs1)))+ (\(cb,sb0) ->+ MaybeCont.toMaybe $+ fmap (\(b,sb1) -> (b, Either.right (cb,sb1))) $+ nextB cb sb0))+ (\(parameterA, parameterB) -> do+ cs <- startA parameterA+ return (parameterB, Either.left cs))+ (\ _parameterB s -> Either.run s (uncurry stopA) (uncurry stopB))+ (combineCreate createIOContextA createIOContextB)+ (combineDelete deleteIOContextA deleteIOContextB) +cycle ::+ (Loop.Phi a, Undefined a) =>+ T p a -> T p a+cycle (Cons next start stop createIOContext deleteIOContext) =+ Cons+ (\parameter (c0,s0) ->+ MaybeCont.alternative+ (fmap (mapSnd ((,) c0)) $ next c0 s0)+ (do (c1,s1) <- MaybeCont.lift $ start parameter+ (b0,s2) <- next c1 s1+ return (b0,(c1,s2))))+ (\parameter -> do+ contextState <- start parameter+ return (parameter, contextState))+ (\_parameter contextState -> uncurry stop contextState)+ createIOContext+ deleteIOContext++ -- * signal modifiers {- |@@ -217,39 +216,18 @@ -} interpolateConstant :: (Memory.C a,- Ring.C b,- IsFloating b, CmpRet b, CmpResult b ~ Bool,- Storable b, MakeValueTuple b, ValueTuple b ~ (Value b), IsConst b,+ IsFloating b, SoV.IntegerConstant b, LLVM.CmpRet b, LLVM.CmpResult b ~ Bool,+ Storable b, MakeValueTuple b, ValueTuple b ~ (Value b), Memory.FirstClass b, IsSized b, IsSized (Memory.Stored b)) => Param.T p b -> T p a -> T p a interpolateConstant k- (Cons next start createIOContext deleteIOContext) =- Cons- (\(kl,parameter) yState0 -> do- ((y1,state1), ss1) <-- Maybe.fromBool $- whileLoop- (valueOf True, yState0)- (\(cont1, (_, ss1)) ->- and cont1 =<< A.fcmp FPOLE ss1 (value LLVM.zero))- (\(_,((_,state01), ss1)) ->- Maybe.toBool $ liftM2 (,)- (next parameter state01)- (Maybe.lift $ A.add ss1 (Param.value k kl)))-- ss2 <- Maybe.lift $ A.sub ss1 (valueOf Ring.one)- return (y1, ((y1,state1),ss2)))--{- using this initialization code we would not need undefined values- (do sa <- start- (a,_) <- next sa- return (sa, a, valueOf 0))--}- (fmap (\sa -> ((undefTuple, sa), value LLVM.zero)) . start)- (\p -> do- (ioContext, (nextParam, startParam)) <- createIOContext p- return (ioContext, ((Param.get k p, nextParam), startParam)))- deleteIOContext+ (Cons next start stop createIOContext deleteIOContext) =+ Param.with k $ \getK valueK -> Cons+ (quantizeNext next valueK)+ (quantizeStart start)+ (quantizeStop stop)+ (quantizeCreate createIOContext getK)+ (quantizeDelete deleteIOContext) @@ -296,9 +274,8 @@ constant x = simple (\pl () -> return (pl, ()))- return+ (return . flip (,) ()) x- (return ()) exponentialCore ::@@ -390,7 +367,7 @@ Memory.C al, A.Additive al, A.IntegerConstant al) => Param.T p a -> Param.T p a -> Param.T p a -> T p al parabolaCore d2 d1 start =- Causal.apply (Causal.integrate start) $+ CausalP.apply (CausalP.integrate start) $ rampCore d2 d1 @@ -437,25 +414,25 @@ Param.T p a -> T p al ramp dur =- Causal.apply (Causal.take (fmap round dur)) $+ CausalP.apply (CausalP.take (fmap round dur)) $ rampInf dur parabolaFadeIn dur =- Causal.apply (Causal.take (fmap round dur)) $+ CausalP.apply (CausalP.take (fmap round dur)) $ parabolaFadeInInf dur parabolaFadeOut dur =- Causal.apply (Causal.take (fmap round dur)) $+ CausalP.apply (CausalP.take (fmap round dur)) $ parabolaFadeOutInf dur parabolaFadeInMap dur = -- t*(2-t)- Causal.apply (Causal.mapSimple (\t -> A.mul t =<< A.sub (A.fromInteger' 2) t)) $+ CausalP.apply (CausalP.mapSimple (\t -> A.mul t =<< A.sub (A.fromInteger' 2) t)) $ ramp dur parabolaFadeOutMap dur = -- 1-t^2- Causal.apply (Causal.mapSimple (\t -> A.sub (A.fromInteger' 1) =<< A.mul t t)) $+ CausalP.apply (CausalP.mapSimple (\t -> A.sub (A.fromInteger' 1) =<< A.mul t t)) $ ramp dur @@ -478,7 +455,7 @@ -} noise :: (Algebraic.C a, IsFloating a, IsConst a,- NumberOfElements a ~ TypeNum.D1,+ LLVM.NumberOfElements a ~ TypeNum.D1, Memory.C (Value a), IsSized a, MakeValueTuple a, ValueTuple a ~ (Value a), Storable a) => Param.T p Word32 ->@@ -526,19 +503,17 @@ fromStorableVector selectVec = Cons (\() (p0,l0) -> do- cont <- Maybe.lift $ A.cmp CmpGT l0 (valueOf 0)- Maybe.withBool cont $ do+ cont <- MaybeCont.lift $ A.cmp LLVM.CmpGT l0 A.zero+ MaybeCont.withBool cont $ do y1 <- Memory.load p0 p1 <- advanceArrayElementPtr p0 l1 <- A.dec l0 return (y1,(p1,l1)))- return+ (return . (,) ())+ (\() _ -> return ()) (\p ->- let (fp,s,l) = SVB.toForeignPtr $ Param.get selectVec p- in return (fp,- ((),- (Memory.castStorablePtr $ Unsafe.foreignPtrToPtr fp `advancePtr` s,- fromIntegral l :: Word32))))+ let (fp,ptr,l) = SVU.unsafeToPointers $ Param.get selectVec p+ in return (fp, (ptr, fromIntegral l :: Word32))) -- keep the foreign ptr alive touchForeignPtr @@ -553,27 +528,27 @@ T p value fromStorableVectorLazy sig = Cons- (\(stable, lenPtr) (buffer0,length0) -> do- (buffer1,length1) <- Maybe.lift $ do- nextChunkFn <- staticFunction ChunkIt.nextCallBack- needNext <- A.cmp CmpEQ length0 (valueOf 0)+ (\stable (buffer0,length0) -> do+ (buffer1,length1) <- MaybeCont.lift $ do+ nextChunkFn <- LLVM.staticFunction ChunkIt.nextCallBack+ needNext <- A.cmp LLVM.CmpEQ length0 A.zero ifThen needNext (buffer0,length0)- (liftM2 (,)- (call nextChunkFn stable lenPtr)- (load lenPtr))- valid <- Maybe.lift $ A.cmp CmpNE buffer1 (valueOf nullPtr)- Maybe.withBool valid $ do+ (do lenPtr <- LLVM.alloca+ liftM2 (,)+ (LLVM.call nextChunkFn stable lenPtr)+ (LLVM.load lenPtr))+ valid <- MaybeCont.lift $ A.cmp LLVM.CmpNE buffer1 (valueOf nullPtr)+ MaybeCont.withBool valid $ do x <- Memory.load buffer1 buffer2 <- advanceArrayElementPtr buffer1 length2 <- A.dec length1 return (x, (buffer2,length2)))- (\() -> return (valueOf nullPtr, valueOf 0))+ (\s -> return (s, (valueOf nullPtr, A.zero)))+ (\ _s _ -> return ()) (\p -> do- s <- liftM2 (,) (ChunkIt.new (Param.get sig p)) Alloc.malloc- return (s, (s,())))- (\(stable,lenPtr) -> do- ChunkIt.dispose stable- Alloc.free lenPtr)+ s <- ChunkIt.new (Param.get sig p)+ return (s, s))+ ChunkIt.dispose @@ -605,19 +580,20 @@ (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) => T p value -> IO (Int -> p -> SV.Vector a)-run (Cons next start createIOContext deleteIOContext) =+run (Cons next start stop createIOContext deleteIOContext) = do -- this compiles once and is much faster than simpleFunction fill <- fmap derefFillPtr . Exec.compileModule . createNamedFunction ExternalLinkage "fillsignalblock" $ \paramPtr size bPtr -> do- (nextParam,startParam) <- Memory.load paramPtr- s <- start startParam- (pos,_) <- Maybe.arrayLoop size bPtr s $ \ ptri s0 -> do- (y,s1) <- next nextParam s0- Maybe.lift $ Memory.store y ptri+ param <- Memory.load paramPtr+ (c,s) <- start param+ (pos,se) <- MaybeCont.arrayLoop size bPtr s $ \ ptri s0 -> do+ (y,s1) <- next c s0+ MaybeCont.lift $ Memory.store y ptri return s1+ Maybe.for se $ stop c ret (pos :: Value Word32) return $ \len p ->@@ -640,80 +616,85 @@ foreign import ccall safe "dynamic" derefChunkPtr ::- Exec.Importer (Ptr nextParamStruct -> Ptr stateStruct -> Word32 -> Ptr struct -> IO Word32)+ Exec.Importer (Ptr contextStateStruct -> Word32 -> Ptr struct -> IO Word32) moduleChunky :: (Memory.C value, Memory.Struct value ~ struct,- Memory.C state, Memory.Struct state ~ stateStruct,- Memory.C startParamValue, Memory.Struct startParamValue ~ startParamStruct,- Memory.C nextParamValue, Memory.Struct nextParamValue ~ nextParamStruct) =>+ Memory.C parameters, Memory.Struct parameters ~ paramStruct,+ Memory.C context, Memory.C state,+ Memory.Struct (context, Maybe.T state) ~ contextStateStruct) =>+ (forall r z.+ (Loop.Phi z) =>+ context -> state -> MaybeCont.T r z (value, state)) -> (forall r.- nextParamValue ->- state -> Maybe.T r (Value Bool, state) (value, state)) ->+ parameters -> CodeGenFunction r (context, state)) -> (forall r.- startParamValue ->- CodeGenFunction r state) ->+ context -> state -> CodeGenFunction r ()) -> CodeGenModule- (Function (Ptr startParamStruct -> IO (Ptr stateStruct)),- Function (Ptr stateStruct -> IO ()),- Function (Ptr nextParamStruct -> Ptr stateStruct -> Word32 -> Ptr struct -> IO Word32))-moduleChunky next start = liftM3 (,,)+ (Function (Ptr paramStruct -> IO (Ptr contextStateStruct)),+ Function (Ptr contextStateStruct -> IO ()),+ Function (Ptr contextStateStruct ->+ Word32 -> Ptr struct -> IO Word32))+moduleChunky next start stop = liftM3 (,,) (createNamedFunction ExternalLinkage "startsignal" $ \paramPtr -> do pptr <- LLVM.malloc- flip Memory.store pptr =<< start =<< Memory.load paramPtr+ flip Memory.store pptr . mapSnd Maybe.just =<< start =<< Memory.load paramPtr ret pptr) (createNamedFunction ExternalLinkage "stopsignal" $- \ pptr -> LLVM.free pptr >> ret ())+ \ contextStatePtr -> do+ (c,ms) <- Memory.load contextStatePtr+ Maybe.for ms $ stop c+ LLVM.free contextStatePtr+ ret ()) (createNamedFunction ExternalLinkage "fillsignal" $- \ paramPtr sptr loopLen ptr -> do- param <- Memory.load paramPtr- sInit <- Memory.load sptr- (pos,sExit) <- Maybe.arrayLoop loopLen ptr sInit $ \ ptri s0 -> do- (y,s1) <- next param s0- Maybe.lift $ Memory.store y ptri+ \ contextStatePtr loopLen ptr -> do+ (context, msInit) <- Memory.load contextStatePtr+ (pos,msExit) <-+ Maybe.run msInit (return (A.zero, Maybe.nothing)) $ \sInit ->+ MaybeCont.arrayLoop loopLen ptr sInit $ \ ptri s0 -> do+ (y,s1) <- next context s0+ MaybeCont.lift $ Memory.store y ptri return s1- Memory.store sExit sptr+ sptr <- LLVM.getElementPtr0 contextStatePtr (TypeNum.d1, ())+ Memory.store msExit sptr ret (pos :: Value Word32)) compileChunky :: (Memory.C value, Memory.Struct value ~ struct,- Memory.C state, Memory.Struct state ~ stateStruct,- Memory.C startParamValue, Memory.Struct startParamValue ~ startParamStruct,- Memory.C nextParamValue, Memory.Struct nextParamValue ~ nextParamStruct) =>+ Memory.C parameters, Memory.Struct parameters ~ paramStruct,+ Memory.C context, Memory.C state,+ Memory.Struct (context, Maybe.T state) ~ contextStateStruct) =>+ (forall r z.+ (Loop.Phi z) =>+ context -> state -> MaybeCont.T r z (value, state)) -> (forall r.- nextParamValue ->- state -> Maybe.T r (Value Bool, state) (value, state)) ->+ parameters -> CodeGenFunction r (context, state)) -> (forall r.- startParamValue ->- CodeGenFunction r state) ->- IO (FunPtr (Ptr startParamStruct -> IO (Ptr stateStruct)),- FunPtr (Ptr stateStruct -> IO ()),- FunPtr (Ptr nextParamStruct -> Ptr stateStruct -> Word32 -> Ptr struct -> IO Word32))-compileChunky next start =- Exec.compileModule $ moduleChunky next start+ context -> state -> CodeGenFunction r ()) ->+ IO (FunPtr (Ptr paramStruct -> IO (Ptr contextStateStruct)),+ FunPtr (Ptr contextStateStruct -> IO ()),+ FunPtr (Ptr contextStateStruct ->+ Word32 -> Ptr struct -> IO Word32))+compileChunky next start stop =+ Exec.compileModule $ moduleChunky next start stop debugMain ::- forall- struct stateStruct- startParamValue startParamStruct- nextParamValue nextParamStruct.- (Storable startParamValue,- Storable nextParamValue,+ forall parameters struct paramStruct contextStateStruct.+ (Storable parameters, LLVM.IsType struct,- LLVM.IsType stateStruct,- LLVM.IsType startParamStruct,- LLVM.IsType nextParamStruct,- IsSized startParamStruct,- IsSized nextParamStruct) =>+ LLVM.IsType contextStateStruct,+ LLVM.IsType paramStruct,+ IsSized paramStruct) => CodeGenModule- (Function (Ptr startParamStruct -> IO (Ptr stateStruct)),- Function (Ptr stateStruct -> IO ()),- Function (Ptr nextParamStruct -> Ptr stateStruct -> Word32 -> Ptr struct -> IO Word32)) ->- (nextParamValue, startParamValue) ->+ (Function (Ptr paramStruct -> IO (Ptr contextStateStruct)),+ Function (Ptr contextStateStruct -> IO ()),+ Function (Ptr contextStateStruct ->+ Word32 -> Ptr struct -> IO Word32)) ->+ parameters -> IO (Function (Word32 -> Ptr (Ptr Word8) -> IO Word32))-debugMain sigModule (nextParam, startParam) = do+debugMain sigModule params = do {- This does not work, since we cannot add (Mul n D32 s) constraint to the function argument in reifyIntegral.@@ -723,39 +704,33 @@ LLVM.store (value arr) ptr LLVM.bitcast ptr) -}- nextArray <-- DebugSt.withConstArray nextParam (\arr -> do- ptr <- LLVM.alloca- LLVM.store (value arr) =<< LLVM.bitcast ptr- return ptr)- startArray <-- DebugSt.withConstArray startParam (\arr -> do+ paramArray <-+ DebugSt.withConstArray params (\arr -> do ptr <- LLVM.alloca LLVM.store (value arr) =<< LLVM.bitcast ptr return ptr) m <- LLVM.newModule - mainFunc <- defineModule m (do+ mainFunc <- LLVM.defineModule m (do mallocBytes <- LLVM.newNamedFunction ExternalLinkage "malloc" :: LLVM.TFunction (Ptr Word8 -> IO (Ptr struct)) (start, stop, fill) <- sigModule createNamedFunction ExternalLinkage "main" $ \ _argc _argv -> do- state <- LLVM.call start =<< startArray+ contextState <- LLVM.call start =<< paramArray let chunkSize = LLVM.valueOf 100000 basePtr = LLVM.valueOf nullPtr buffer <- LLVM.call mallocBytes =<< LLVM.bitcast =<< LLVM.getElementPtr basePtr (chunkSize, ())- nextPtr <- nextArray _done <-- LLVM.call fill nextPtr state chunkSize (asTypeOf buffer basePtr)- _ <- LLVM.call stop state- ret (LLVM.value LLVM.zero :: LLVM.Value Word32))+ LLVM.call fill contextState chunkSize (asTypeOf buffer basePtr)+ _ <- LLVM.call stop contextState+ ret (A.zero :: LLVM.Value Word32)) Counter.with Exec.counter $ R.ReaderT $ \cnt -> do- writeBitcodeToFile ("main" ++ Counter.format 3 cnt ++ ".bc") m+ LLVM.writeBitcodeToFile ("main" ++ Counter.format 3 cnt ++ ".bc") m return mainFunc @@ -770,25 +745,26 @@ (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) => T p value -> IO (SVP.LazySize -> p -> SVL.Vector a)-runChunkyPattern (Cons next start createIOContext deleteIOContext) = do- (startFunc, stopFunc, fill) <- compileChunky next start+runChunkyPattern (Cons next start stop createIOContext deleteIOContext) = do+ (startFunc, stopFunc, fill) <- compileChunky next start stop return $ \ lazysize p -> SVL.fromChunks $ Unsafe.performIO $ do- (ioContext, (nextParam, startParam)) <- createIOContext p+ (ioContext, param) <- createIOContext p {- putStr "nextParam: " DebugSt.format nextParam >>= putStrLn -} when False $ Counter.with DebugSt.dumpCounter $ do- DebugSt.dump "next-param" nextParam- DebugSt.dump "start-param" startParam+ DebugSt.dump "param" param when False $ void $- debugMain (moduleChunky next start) (nextParam, startParam)+ debugMain (moduleChunky next start stop) param - statePtr <- ForeignPtr.newParam stopFunc startFunc startParam- nextParamPtr <- ForeignPtr.new (deleteIOContext ioContext) nextParam+ statePtr <- ForeignPtr.newParam stopFunc startFunc param+ concStatePtr <-+ withForeignPtr statePtr $+ flip FC.newForeignPtr (deleteIOContext ioContext) let go cs = Unsafe.interleaveIO $@@ -797,11 +773,11 @@ SVL.ChunkSize size : rest -> do v <- withForeignPtr statePtr $ \sptr ->- ForeignPtr.with nextParamPtr $ \nptr -> SVB.createAndTrim size $ fmap fromIntegral .- derefChunkPtr fill nptr sptr (fromIntegral size) .+ derefChunkPtr fill sptr (fromIntegral size) . Memory.castStorablePtr+ touchForeignPtr concStatePtr (if SV.length v > 0 then fmap (v:) else id) $
src/Synthesizer/LLVM/Parameterized/SignalPacked.hs view
@@ -24,6 +24,7 @@ module Synthesizer.LLVM.Parameterized.SignalPacked where import Synthesizer.LLVM.Parameterized.Signal (T(Cons), )+import Synthesizer.LLVM.Parameterized.SignalPrivate (withStart, ) import qualified Synthesizer.LLVM.Parameterized.Signal as Sig import qualified Synthesizer.LLVM.Parameter as Param import qualified Synthesizer.LLVM.Frame.SerialVector as Serial@@ -35,13 +36,16 @@ import qualified LLVM.Extra.MaybeContinuation as Maybe import qualified LLVM.Extra.Control as U import qualified LLVM.Extra.Arithmetic as A-import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, undefTuple, )+import LLVM.Extra.Class (MakeValueTuple, ValueTuple, undefTuple, ) -import qualified Types.Data.Bool as TypeBool import qualified Types.Data.Num as TypeNum import Types.Data.Num ((:*:), ) -import LLVM.Core as LLVM+import qualified LLVM.Core as LLVM+import LLVM.Core+ (CodeGenFunction, Value, valueOf,+ IsSized, IsConst, IsArithmetic, IsFloating,+ IsPrimitive, Vector, SizeOf, ) import qualified Control.Monad.Trans.Class as MT import qualified Control.Monad.Trans.State as MS@@ -77,7 +81,7 @@ T p a -> T p v pack = packRotate -packRotate (Cons next start createIOContext deleteIOContext) = Cons+packRotate (Cons next start stop createIOContext deleteIOContext) = Cons (\param s -> do wInit <- Maybe.lift $ Serial.writeStart (w2,_,s2) <-@@ -89,7 +93,7 @@ s)) (\(cont,(_w0,i0,_s0)) -> A.and cont =<<- A.cmp CmpGT i0 (value LLVM.zero))+ A.cmp LLVM.CmpGT i0 A.zero) (\(_,(w0,i0,s0)) -> Maybe.toBool $ do (a,s1) <- next param s0 Maybe.lift $ do@@ -99,6 +103,7 @@ v <- Maybe.lift $ Serial.writeStop w2 return (v, s2)) start+ stop createIOContext deleteIOContext @@ -116,10 +121,10 @@ (v2,_,s2) <- Maybe.fromBool $ U.whileLoop- (valueOf True, (undefTuple, value LLVM.zero, s))+ (valueOf True, (undefTuple, A.zero, s)) (\(cont,(v0,i0,_s0)) -> A.and cont =<<- A.cmp CmpLT i0+ A.cmp LLVM.CmpLT i0 (valueOf $ fromIntegral $ Serial.size v0)) (\(_,(v0,i0,s0)) -> Maybe.toBool $ do (a,s1) <- next param s0@@ -143,7 +148,7 @@ packSmall :: (Serial.C v, a ~ Serial.Element v) => T p a -> T p v-packSmall (Cons next start createIOContext deleteIOContext) = Cons+packSmall (Cons next start stop createIOContext deleteIOContext) = Cons (\param -> MS.runStateT $ case undefined of@@ -153,6 +158,7 @@ =<< replicateM (Serial.size vundef) (MS.StateT $ next param)) start+ stop createIOContext deleteIOContext @@ -162,23 +168,22 @@ T p v -> T p a unpack = unpackRotate -unpackRotate (Cons next start createIOContext deleteIOContext) = Cons- (\param (i0,r0,s0) -> do+unpackRotate (Cons next start stop createIOContext deleteIOContext) = Cons+ (\context (i0,r0,s0) -> do endOfVector <-- Maybe.lift $ A.cmp CmpEQ i0 (valueOf (0::Word32))+ Maybe.lift $ A.cmp LLVM.CmpEQ i0 (valueOf (0::Word32)) (i2,r2,s2) <- Maybe.fromBool $ U.ifThen endOfVector (valueOf True, (i0,r0,s0)) $ do- (cont1, (v1,s1)) <- Maybe.toBool $ next param s0+ (cont1, (v1,s1)) <- Maybe.toBool $ next context s0 r1 <- Serial.readStart v1 return (cont1, (valueOf $ fromIntegral $ Serial.size v1, r1, s1)) Maybe.lift $ do (a,r3) <- Serial.readNext r2 i3 <- A.dec i2 return (a, (i3,r3,s2)))- (\p -> do- s <- start p- return (valueOf 0, undefTuple, s))+ (withStart start $ \s -> return (A.zero, undefTuple, s))+ (\context (_,_,state) -> stop context state) createIOContext deleteIOContext @@ -195,13 +200,13 @@ unpackIndex (Cons next start createIOContext deleteIOContext) = Cons (\param (i0,v0,s0) -> do endOfVector <-- Maybe.lift $ A.cmp CmpGE i0+ Maybe.lift $ A.cmp LLVM.CmpGE i0 (valueOf $ fromIntegral $ Serial.size v0) (i2,v2,s2) <- Maybe.fromBool $ U.ifThen endOfVector (valueOf True, (i0,v0,s0)) $ do (cont1, (v1,s1)) <- Maybe.toBool $ next param s0- return (cont1, (value LLVM.zero, v1, s1))+ return (cont1, (A.zero, v1, s1)) Maybe.lift $ do a <- Vector.extract i2 v2 i3 <- A.inc i2@@ -221,7 +226,7 @@ withSize f = f undefined withSizeRing ::- (Ring.C b, TypeNum.IntegerT n, TypeNum.IsPositive n ~ TypeBool.True) =>+ (Ring.C b, TypeNum.IntegerT n, TypeNum.PositiveT n) => (b -> T p (Serial.Value n a)) -> T p (Serial.Value n a) withSizeRing f =@@ -229,14 +234,13 @@ constant ::- (Storable a, MakeValueTuple a, ValueTuple a ~ (Value a),+ (Storable a, MakeValueTuple a, ValueTuple a ~ (Value a), IsConst a, Memory.FirstClass a, Memory.Stored a ~ am,- IsPrimitive a, IsSized a, SizeOf a ~ as,+ IsPrimitive a, IsPrimitive am, IsSized am, SizeOf am ~ amsize,- TypeNum.PositiveT (n :*: as), TypeNum.PositiveT (n :*: amsize),- TypeNum.IntegerT n, TypeNum.IsPositive n ~ TypeBool.True) =>+ TypeNum.PositiveT n) => Param.T p a -> T p (Serial.Value n a) constant x = Sig.constant (Serial.replicate ^<< x)@@ -250,7 +254,7 @@ IsPrimitive am, IsSized am, SizeOf am ~ amsize, TypeNum.PositiveT (n :*: as), TypeNum.PositiveT (n :*: amsize),- TypeNum.IntegerT n, TypeNum.IsPositive n ~ TypeBool.True) =>+ TypeNum.IntegerT n, TypeNum.PositiveT n) => Param.T p a -> Param.T p a -> T p (Serial.Value n a) exponential2 halfLife start = withSizeRing $ \n -> Sig.exponentialCore@@ -267,7 +271,7 @@ IsPrimitive am, IsSized am, SizeOf am ~ amsize, TypeNum.PositiveT (n :*: as), TypeNum.PositiveT (n :*: amsize),- TypeNum.IntegerT n, TypeNum.IsPositive n ~ TypeBool.True) =>+ TypeNum.IntegerT n, TypeNum.PositiveT n) => Param.T p a -> Param.T p a -> Param.T p a -> T p (Serial.Value n a) exponentialBounded2 bound halfLife start = withSizeRing $ \n ->@@ -287,7 +291,7 @@ TypeNum.PositiveT (n :*: tsize), TypeNum.PositiveT (n :*: tmsize), Vector.Real t, IsFloating t, RealField.C t, IsConst t,- TypeNum.IntegerT n, TypeNum.IsPositive n ~ TypeBool.True) =>+ TypeNum.IntegerT n, TypeNum.PositiveT n) => Param.T p t -> Param.T p t -> T p (Serial.Value n t) osciCore phase freq = withSizeRing $ \n -> Sig.osciCore@@ -308,7 +312,7 @@ TypeNum.PositiveT (n :*: tmsize), Memory.C cl, Vector.Real t, IsFloating t, RealField.C t, IsConst t,- TypeNum.IntegerT n, TypeNum.IsPositive n ~ TypeBool.True) =>+ TypeNum.IntegerT n, TypeNum.PositiveT n) => (forall r. cl -> Serial.Value n t -> CodeGenFunction r y) -> Param.T p c -> Param.T p t -> Param.T p t -> T p y@@ -324,7 +328,7 @@ TypeNum.PositiveT (n :*: tsize), TypeNum.PositiveT (n :*: tmsize), Vector.Real t, IsFloating t, RealField.C t, IsConst t,- TypeNum.IntegerT n, TypeNum.IsPositive n ~ TypeBool.True) =>+ TypeNum.IntegerT n, TypeNum.PositiveT n) => (forall r. Serial.Value n t -> CodeGenFunction r y) -> Param.T p t -> Param.T p t -> T p y osciSimple wave =@@ -340,7 +344,7 @@ TypeNum.PositiveT (n :*: as), TypeNum.PositiveT (n :*: amsize), IsArithmetic a, SoV.IntegerConstant a,- TypeNum.IntegerT n, TypeNum.IsPositive n ~ TypeBool.True) =>+ TypeNum.IntegerT n, TypeNum.PositiveT n) => Param.T p a -> T p (Serial.Value n a) rampSlope slope = withSizeRing $ \n -> Sig.rampCore@@ -386,7 +390,7 @@ -} noise :: (Algebraic.C a, IsFloating a, SoV.IntegerConstant a,- TypeNum.IntegerT n, TypeNum.IsPositive n ~ TypeBool.True,+ TypeNum.IntegerT n, TypeNum.PositiveT n, TypeNum.PositiveT (n :*: TypeNum.D32), Memory.FirstClass a, Memory.Stored a ~ am, IsPrimitive a, IsSized a, SizeOf a ~ as,@@ -424,7 +428,7 @@ CodeGenFunction r (Value (Vector n Int32))) noiseCore, noiseCoreAlt ::- (TypeNum.IntegerT n, TypeNum.IsPositive n ~ TypeBool.True,+ (TypeNum.IntegerT n, TypeNum.PositiveT n, TypeNum.PositiveT (n :*: TypeNum.D32)) => Param.T p Word32 -> T p (Serial.Value n Word32)
src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs view
@@ -8,7 +8,11 @@ import qualified Synthesizer.LLVM.Parameter as Param import qualified LLVM.Extra.MaybeContinuation as Maybe import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Control as C+import qualified LLVM.Core as LLVM import LLVM.Extra.Class (MakeValueTuple, ValueTuple, ) import LLVM.Core (CodeGenFunction, )@@ -18,6 +22,8 @@ import Control.Monad (liftM2, ) import Control.Applicative (Applicative, pure, (<*>), ) +import Data.Tuple.HT (mapFst)+ import Foreign.Storable.Tuple () import Foreign.Storable (Storable, ) @@ -59,25 +65,30 @@ Consider a signal algorithm, where the LFO frequency is a parameter. -} data T p a =- forall state ioContext startParamTuple nextParamTuple.- (Storable startParamTuple,- Storable nextParamTuple,- MakeValueTuple startParamTuple,- MakeValueTuple nextParamTuple,- Memory.C (ValueTuple startParamTuple),- Memory.C (ValueTuple nextParamTuple),+ forall context state ioContext parameters.+ (Storable parameters,+ MakeValueTuple parameters,+ Memory.C (ValueTuple parameters),+ Memory.C context, Memory.C state) => Cons (forall r c. (Phi c) =>- ValueTuple nextParamTuple ->- state -> Maybe.T r c (a, state))+ context -> state -> Maybe.T r c (a, state)) -- compute next value (forall r.- ValueTuple startParamTuple ->- CodeGenFunction r state)- -- initial state- (p -> IO (ioContext, (nextParamTuple, startParamTuple)))+ ValueTuple parameters ->+ CodeGenFunction r (context, state))+ -- allocate initial state+ (forall r.+ context -> state ->+ CodeGenFunction r ())+ {- cleanup+ You must make sure to call this+ whenever you allocated context and state with the 'start' function.+ You must call it with the latest state returned from the 'next' function.+ -}+ (p -> IO (ioContext, parameters)) {- initialization from IO monad This will be run within Unsafe.performIO, so no observable In/Out actions please!@@ -85,30 +96,72 @@ (ioContext -> IO ()) -- finalization from IO monad, also run within Unsafe.performIO ++withStart ::+ (startParam -> CodeGenFunction r (context, state0)) ->+ (state0 -> CodeGenFunction r state1) ->+ startParam -> CodeGenFunction r (context, state1)+withStart start act p = do+ (c,s) <- start p+ fmap ((,) c) $ act s++combineStart ::+ Monad m =>+ (paramA -> m (contextA, stateA)) ->+ (paramB -> m (contextB, stateB)) ->+ (paramA, paramB) -> m ((contextA, contextB), (stateA, stateB))+combineStart startA startB (paramA, paramB) =+ liftM2+ (\(ca,sa) (cb,sb) -> ((ca,cb), (sa,sb)))+ (startA paramA)+ (startB paramB)++combineStop ::+ Monad m =>+ (contextA -> stateA -> m ()) ->+ (contextB -> stateB -> m ()) ->+ (contextA, contextB) -> (stateA, stateB) -> m ()+combineStop stopA stopB (ca, cb) (sa, sb) =+ stopA ca sa >> stopB cb sb++combineCreate ::+ Monad m =>+ (p -> m (ioContextA, contextA)) ->+ (p -> m (ioContextB, contextB)) ->+ p -> m ((ioContextA, ioContextB), (contextA, contextB))+combineCreate createIOContextA createIOContextB p = do+ (ca,paramA) <- createIOContextA p+ (cb,paramB) <- createIOContextB p+ return ((ca,cb), (paramA,paramB))++combineDelete ::+ (Monad m) =>+ (ca -> m ()) -> (cb -> m ()) -> (ca, cb) -> m ()+combineDelete deleteIOContextA deleteIOContextB (ca,cb) =+ deleteIOContextA ca >>+ deleteIOContextB cb+++ simple ::- (Storable startParamTuple,- Storable nextParamTuple,- MakeValueTuple startParamTuple,- MakeValueTuple nextParamTuple,- ValueTuple startParamTuple ~ startParamValue,- ValueTuple nextParamTuple ~ nextParamValue,- Memory.C startParamValue,- Memory.C nextParamValue,+ (Storable parameters,+ MakeValueTuple parameters,+ Memory.C (ValueTuple parameters),+ Memory.C context, Memory.C state) => (forall r c. (Phi c) =>- nextParamValue ->- state -> Maybe.T r c (al, state)) ->+ context -> state -> Maybe.T r c (al, state)) -> (forall r.- startParamValue ->- CodeGenFunction r state) ->- Param.T p nextParamTuple ->- Param.T p startParamTuple -> T p al-simple f start selectParam initial = Cons- (f . Param.value selectParam)- (start . Param.value initial)- (return . (,) () . Param.get (selectParam &&& initial))- (const $ return ())+ ValueTuple parameters ->+ CodeGenFunction r (context, state)) ->+ Param.T p parameters -> T p al+simple f start param =+ Param.with param $ \getParam valueParam -> Cons f+ (start . valueParam)+ (const $ const $ return ())+ (return . (,) () . getParam)+ (const $ return ()) map ::@@ -117,16 +170,18 @@ Param.T p ph -> T p a -> T p b map f selectParamF- (Cons next start createIOContext deleteIOContext) =- Cons+ (Cons next start stop createIOContext deleteIOContext) =+ Param.with selectParamF $ \getParamF valueF -> Cons (\(parameterF, parameter) sa0 -> do (a,sa1) <- next parameter sa0- b <- Maybe.lift $ f (Param.value selectParamF parameterF) a+ b <- Maybe.lift $ f (valueF parameterF) a return (b, sa1))- start+ (\(parameterF, parameter) ->+ fmap (mapFst ((,) parameterF)) $ start parameter)+ (stop . snd) (\p -> do- (ioContext, (nextParam, startParam)) <- createIOContext p- return (ioContext, ((Param.get selectParamF p, nextParam), startParam)))+ (ioContext, param) <- createIOContext p+ return (ioContext, (getParamF p, param))) deleteIOContext mapSimple ::@@ -141,27 +196,26 @@ Param.T p ph -> T p a -> T p b -> T p c zipWith f selectParamF- (Cons nextA startA createIOContextA deleteIOContextA)- (Cons nextB startB createIOContextB deleteIOContextB) =- Cons+ (Cons nextA startA stopA createIOContextA deleteIOContextA)+ (Cons nextB startB stopB createIOContextB deleteIOContextB) =+ Param.with selectParamF $ \getParamF valueParamF -> Cons (\(parameterF, (parameterA, parameterB)) (sa0,sb0) -> do- (a,sa1) <- nextA parameterA sa0- (b,sb1) <- nextB parameterB sb0- c <- Maybe.lift $ f (Param.value selectParamF parameterF) a b+ (a,sa1) <-+ Maybe.onFail (stopB parameterB sb0) $+ nextA parameterA sa0+ (b,sb1) <-+ Maybe.onFail (stopA parameterA sa1) $+ nextB parameterB sb0+ c <- Maybe.lift $ f (valueParamF parameterF) a b return (c, (sa1,sb1)))- (\(parameterA, parameterB) ->- liftM2 (,)- (startA parameterA)- (startB parameterB))+ (\(parameterF, parameter) ->+ fmap (mapFst ((,) parameterF)) $+ combineStart startA startB parameter)+ (combineStop stopA stopB . snd) (\p -> do- (ca,(nextParamA,startParamA)) <- createIOContextA p- (cb,(nextParamB,startParamB)) <- createIOContextB p- return ((ca,cb),- ((Param.get selectParamF p, (nextParamA, nextParamB)),- (startParamA, startParamB))))- (\(ca,cb) ->- deleteIOContextA ca >>- deleteIOContextB cb)+ (c,param) <- combineCreate createIOContextA createIOContextB p+ return (c, (getParamF p, param)))+ (combineDelete deleteIOContextA deleteIOContextB) zipWithSimple :: (forall r. a -> b -> CodeGenFunction r c) ->@@ -180,8 +234,7 @@ pure x = simple (\() () -> return (x, ()))- return- (return ())+ (\() -> return ((),())) (return ()) (<*>) = zipWithSimple (\f a -> return (f a)) @@ -222,9 +275,64 @@ (forall r. pl -> al -> CodeGenFunction r al) -> Param.T p ph -> Param.T p a -> T p al-iterate f selectParam initial = simple+iterate f param initial = simple (\pl al0 -> Maybe.lift $ fmap (\al1 -> (al0,al1)) (f pl al0)) return- selectParam- initial+ (param &&& initial)+++quantizeNext ::+ (LLVM.IsFloating a, LLVM.CmpRet a, LLVM.CmpResult a ~ Bool,+ SoV.IntegerConstant a, Phi z,+ Class.Undefined y, Phi y,+ Class.Undefined state, Phi state) =>+ (forall zn. Phi zn => context -> state -> Maybe.T r zn (y, state)) ->+ (valueA -> LLVM.Value a) ->+ (valueA, context) ->+ ((y, state), LLVM.Value a) ->+ Maybe.T r z (y, ((y, state), LLVM.Value a))+quantizeNext next valueK (kl,context) yState0 = do+ ((y1,state1), frac1) <-+ Maybe.fromBool $+ C.whileLoop+ (LLVM.valueOf True, yState0)+ (\(cont1, (_, frac0)) ->+ LLVM.and cont1 =<< A.fcmp LLVM.FPOLE frac0 A.zero)+ (\(_,((_,state01), frac0)) ->+ Maybe.toBool $ liftM2 (,)+ (next context state01)+ (Maybe.lift $ A.add frac0 (valueK kl)))++ frac2 <- Maybe.lift $ A.sub frac1 A.one+ return (y1, ((y1,state1),frac2))++quantizeStart ::+ (Monad m, Class.Undefined y, A.Additive al) =>+ (param -> m (context, state)) ->+ (ap, param) -> m ((ap, context), ((y, state), al))+{- using this initialization code we would not need undefined values+ (do sa <- start+ (a,_) <- next sa+ return (sa, a, A.zero))+-}+quantizeStart start (kl,p) = do+ (c,s) <- start p+ return ((kl,c), ((Class.undefTuple, s), A.zero))++quantizeStop ::+ (context -> state -> m ()) ->+ (ap, context) -> ((y, state), al) -> m ()+quantizeStop stop (_kl,c) ((_, s), _) = stop c s++quantizeCreate ::+ Monad m =>+ (p -> m (ioContext, param)) ->+ (p -> ah) -> p -> m (ioContext, (ah, param))+quantizeCreate createIOContext getK p = do+ (ioContext, param) <- createIOContext p+ return (ioContext, (getK p, param))++quantizeDelete :: (ioContext -> m ()) -> (ioContext -> m ())+quantizeDelete deleteIOContext =+ deleteIOContext
src/Synthesizer/LLVM/Plug/Input.hs view
@@ -34,16 +34,14 @@ import qualified Numeric.NonNegative.Wrapper as NonNegW +import qualified Synthesizer.LLVM.Storable.Vector as SVU import qualified Data.StorableVector as SV-import qualified Data.StorableVector.Base as SVB import qualified Foreign.Marshal.Array as Array import qualified Foreign.Marshal.Alloc as Alloc import qualified Foreign.ForeignPtr as FPtr import Foreign.Storable (Storable, pokeElemOff, ) -import qualified System.Unsafe as Unsafe- import Data.Word (Word32, ) @@ -168,10 +166,8 @@ (A.advanceArrayElementPtr p)) return (\vec ->- let (fp,s,_l) = SVB.toForeignPtr vec- in return (fp,- Memory.castStorablePtr $- Unsafe.foreignPtrToPtr fp `Array.advancePtr` s))+ let (fp,ptr,_l) = SVU.unsafeToPointers vec+ in return (fp,ptr)) -- keep the foreign ptr alive FPtr.touchForeignPtr
src/Synthesizer/LLVM/Plug/Output.hs view
@@ -16,16 +16,14 @@ import Control.Monad (liftM2, ) +import qualified Synthesizer.LLVM.Storable.Vector as SVU import qualified Data.StorableVector as SV import qualified Data.StorableVector.Base as SVB -import qualified Foreign.Marshal.Array as Array import qualified Foreign.ForeignPtr as FPtr import Foreign.Storable.Tuple () import Foreign.Storable (Storable, ) -import qualified System.Unsafe as Unsafe- import NumericPrelude.Numeric import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, take, takeWhile, ) @@ -107,11 +105,9 @@ return (\len -> do vec <- SVB.create len (const $ return ())- -- s should be always zero, but we must not rely on that- let (fp,s,_l) = SVB.toForeignPtr vec- return (vec,- Memory.castStorablePtr $- Unsafe.foreignPtrToPtr fp `Array.advancePtr` s))+ -- offset should be always zero, but we must not rely on that+ let (_fp,ptr,_l) = SVU.unsafeToPointers vec+ return (vec, ptr)) (\len vec -> do let (fp,_s,_l) = SVB.toForeignPtr vec -- keep the foreign ptr alive
src/Synthesizer/LLVM/Random.hs view
@@ -19,7 +19,6 @@ zext, trunc, lshr, value, valueOf, vector, undef, constOf, constVector, bitcast, ) import qualified LLVM.Core as LLVM-import qualified Types.Data.Bool as TypeBool import qualified Types.Data.Num as TypeNum import Data.Function.HT (nest, )@@ -63,8 +62,8 @@ nextCG32 :: Value Word32 -> CodeGenFunction r (Value Word32) nextCG32 s = do- sHigh <- A.mul (valueOf splitRem) =<< LLVM.idiv s split- sLow <- A.mul (valueOf factor) =<< LLVM.irem s split+ sHigh <- A.mul (valueOf splitRem) =<< LLVM.idiv s (valueOf split)+ sLow <- A.mul (valueOf factor) =<< LLVM.irem s (valueOf split) flip A.irem (valueOf modulus) =<< A.add sHigh sLow nextCG64 :: Value Word32 -> CodeGenFunction r (Value Word32)@@ -121,7 +120,7 @@ fromIntegral $ nest n next 1 vectorSeed ::- (TypeNum.IntegerT n, TypeNum.IsPositive n ~ TypeBool.True) =>+ (TypeNum.IntegerT n, TypeNum.PositiveT n) => Word32 -> Vector n Word32 vectorSeed seed = let n = Vector.size $ valueOf v@@ -369,7 +368,7 @@ Value (Vector n Int32) -> CodeGenFunction r (Value (Vector n Int32)) selectNonNegativeGeneric x y = do- b <- A.cmp LLVM.CmpGE x (value LLVM.zero)+ b <- A.cmp LLVM.CmpGE x A.zero Vector.select b x y
src/Synthesizer/LLVM/RingBuffer.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} module Synthesizer.LLVM.RingBuffer (- T, track,+ T, track, trackConst, index, oldest, ) where @@ -20,15 +20,22 @@ import Data.Word (Word32, ) import Foreign.Storable.Tuple () import Foreign.Storable (Storable, )-import qualified Synthesizer.LLVM.Alloc as Alloc import Foreign.Ptr (Ptr, ) import Prelude hiding (length, ) -data T ap =+{-+I have chosen this type parameter+in order make sure that you can only retrieve from the buffer+what you have put into it.+E.g. if you store a SerialVector in it,+you can only load a SerialVector from it, but not a Vector,+although both of them use the same type for storage.+-}+data T a = Cons {- buffer :: Value (Ptr ap),+ buffer :: Value (Ptr (Memory.Struct a)), length :: Value Word32, current :: Value Word32, oldest_ :: Value Word32@@ -38,10 +45,12 @@ This function does not check for range violations. If the ring buffer was generated by @track initial time@, then the minimum index is zero and the maximum index is @time@.+Index zero refers to the current sample+and index @time@ refers to the oldest one. -} index :: (Memory.C a) =>- Value Word32 -> T (Memory.Struct a) -> CodeGenFunction r a+ Value Word32 -> T a -> CodeGenFunction r a index i rb = do k <- flip A.irem (length rb) =<< A.add (current rb) i Memory.load =<< LLVM.getElementPtr (buffer rb) (k, ())@@ -53,7 +62,7 @@ -} oldest :: (Memory.C a) =>- T (Memory.Struct a) -> CodeGenFunction r a+ T a -> CodeGenFunction r a oldest rb = Memory.load =<< LLVM.getElementPtr (buffer rb) (oldest_ rb, ()) @@ -70,40 +79,90 @@ The initial value is also needed for determining the ring buffer element type. -} track ::- (Storable a,- Class.MakeValueTuple a, Class.ValueTuple a ~ al,- Memory.C al) =>- Param.T p a -> Param.T p Int -> CausalP.T p al (T (Memory.Struct al))+ (Storable a, Class.MakeValueTuple a,+ Class.ValueTuple a ~ al, Memory.C al) =>+ Param.T p a -> Param.T p Int -> CausalP.T p al (T al) track initial time =- let time32 = fmap (fromIntegral :: Int -> Word32) time in- CausalP.Cons- (\(size,ptr) a remain0 -> Maybe.lift $ do- Memory.store a =<< LLVM.getElementPtr ptr (remain0, ())- cont <- A.cmp LLVM.CmpGT remain0 (LLVM.value LLVM.zero)- remain1 <-- C.ifThenSelect cont (Param.value time32 size)- (A.dec remain0)- size1 <- A.inc (Param.value time32 size)- return (Cons ptr size1 remain0 remain1, remain1))- (\(x, (size,ptr)) -> do- size1 <- A.inc (Param.value time32 size)- -- cf. LLVM.Storable.Signal.fill- C.arrayLoop size1 ptr () $ \ ptri () ->- Memory.store (Param.value initial x) ptri >> return ()- return size)- (\p -> do- let size = Param.get time p- x = Param.get initial p- {-- We allocate one element more than necessary- in order to simplify handling of delay time zero- -}- ptr <- Alloc.mallocArray (size+1)- let param =- (fromIntegral size :: Word32,- Memory.castStorablePtr (ptrAsTypeOf ptr x))- return ((size,ptr), (param, (x, param))))- (\(size,ptr) -> Alloc.freeArray (size + 1) ptr)+ Param.with initial $ \getInitial valueInitial ->+ Param.with (Param.word32 time) $ \getTime valueTime ->+ CausalP.Cons+ (trackNext valueTime)+ (\(x, size) -> trackStart valueTime (valueInitial x, size))+ trackStop+ (trackCreate getInitial getTime)+ trackDelete -ptrAsTypeOf :: Ptr a -> a -> Ptr a-ptrAsTypeOf p _ = p+{- |+Initialize with zero without the need of a Haskell zero value.++We cannot get rid of the type 'a' so easily,+because we need its Storable instance+for allocating the buffer on the Haskell side.+-}+trackConst ::+ (Memory.C al) =>+ al -> Param.T p Int -> CausalP.T p al (T al)+trackConst initial time =+ Param.with (Param.word32 time) $ \getTime valueTime ->+ CausalP.Cons+ (trackNext valueTime)+ (\size -> trackStart valueTime (initial, size))+ trackStop+ (trackConstCreate getTime)+ trackDelete++trackConstCreate ::+ (p -> t) ->+ p ->+ IO ((), t)+trackConstCreate getTime p =+ return ((), getTime p)+++trackNext ::+ (Memory.C al, Memory.Struct al ~ am) =>+ (tl -> Value Word32) ->+ (tl, Value (Ptr am)) ->+ al -> Value Word32 ->+ Maybe.T r z (T al, Value Word32)+trackNext valueTime (size,ptr) a remain0 = Maybe.lift $ do+ Memory.store a =<< LLVM.getElementPtr ptr (remain0, ())+ cont <- A.cmp LLVM.CmpGT remain0 A.zero+ let size0 = valueTime size+ remain1 <- C.ifThenSelect cont size0 (A.dec remain0)+ size1 <- A.inc size0+ return (Cons ptr size1 remain0 remain1, remain1)++trackStart ::+ (Memory.C al, Memory.Struct al ~ am) =>+ (tl -> Value Word32) ->+ (al, tl) ->+ CodeGenFunction r ((tl, Value (Ptr am)), Value Word32)+trackStart valueTime (initial, size) = do+ let size0 = valueTime size+ size1 <- A.inc size0+ ptr <- LLVM.arrayMalloc size1+ -- cf. LLVM.Storable.Signal.fill+ C.arrayLoop size1 ptr () $ \ ptri () ->+ Memory.store initial ptri+ return ((size,ptr), size0)++trackStop ::+ (LLVM.IsType am) =>+ (tl, Value (Ptr am)) ->+ Value Word32 ->+ CodeGenFunction r ()+trackStop (_size,ptr) _remain = LLVM.free ptr++trackCreate ::+ (Class.MakeValueTuple a, Class.ValueTuple a ~ al,+ Memory.C al, Memory.Struct al ~ am) =>+ (p -> a) ->+ (p -> t) ->+ p ->+ IO ((), (a, t))+trackCreate getInitial getTime p =+ return ((), (getInitial p, getTime p))++trackDelete :: () -> IO ()+trackDelete () = return ()
+ src/Synthesizer/LLVM/RingBufferForward.hs view
@@ -0,0 +1,293 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Rank2Types #-}+module Synthesizer.LLVM.RingBufferForward (+ T, track, trackSkip, trackSkipHold,+ index,+ ) where++import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified Synthesizer.LLVM.Parameter as Param+import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*), )++import qualified LLVM.Extra.MaybeContinuation as MaybeCont+import qualified LLVM.Extra.Maybe as Maybe+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Control as C+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Class as Class++import qualified LLVM.Core as LLVM+import LLVM.Util.Loop (Phi, )+import LLVM.Core (CodeGenFunction, Value, )++import Control.Arrow ((<<<), )+import Control.Applicative (pure, )+import Data.Tuple.HT (mapSnd, )++import Data.Word (Word32, )+import Foreign.Storable.Tuple ()+import Foreign.Ptr (Ptr, )++import Prelude hiding (length, )+++{- |+This type is very similar to 'Synthesizer.LLVM.RingBuffer.T'+but differs in several details:++* It stores values in time order,+ whereas 'Synthesizer.LLVM.RingBuffer.T' stores in opposite order.++* Since it stores future values it is not causal+ and can only track signal generators.++* There is no need for an initial value.++* It stores one value less than 'Synthesizer.LLVM.RingBuffer.T'+ since it is meant to provide infixes of the signal+ rather than providing the basis for a delay line.++Those differences in detail would not justify a new type,+you could achieve the same by a combination of+'Synthesizer.LLVM.RingBuffer.track'+and+'Synthesizer.LLVM.CausalParameterized.Process.skip'.+The fundamental problem of this combination is+that it requires to keep the ring buffer alive+longer than the providing signal exists.+This is not possible with the current design.+That's why we provide the combination of @track@ and @skip@+in a way that does not suffer from that problem.+This functionality is critical for+'Synthesizer.LLVM.CausalParameterized.Helix.dynamic'.+-}+data T a =+ Cons {+ buffer :: Value (Ptr (Memory.Struct a)),+ length :: Value Word32,+ current :: Value Word32+ }++{- |+This function does not check for range violations.+If the ring buffer was generated by @track time@,+then the minimum index is zero and the maximum index is @time-1@.+Index zero refers to the current sample+and index @time-1@ refers to the one that is farthermost in the future.+-}+index ::+ (Memory.C a) =>+ Value Word32 -> T a -> CodeGenFunction r a+index i rb = do+ k <- flip A.irem (length rb) =<< A.add (current rb) i+ Memory.load =<< LLVM.getElementPtr (buffer rb) (k, ())+++{- |+@track time signal@ bundles @time@ successive values of @signal@.+The values can be accessed using 'index' with indices+ranging from 0 to @time-1@.++The @time@ parameter must be non-negative.+-}+track ::+ (Memory.C a) =>+ Param.T p Int -> SigP.T p a -> SigP.T p (T a)+track time input = trackSkip time input $* 1++{- |+@trackSkip time input $* skips@+is like+@Process.skip (track time input) $* skips@+but this composition would require a @Memory@ constraint for 'T'+which we cannot provide.+-}+trackSkip ::+ (Memory.C a) =>+ Param.T p Int -> SigP.T p a -> CausalP.T p (Value Word32) (T a)+trackSkip time (SigP.Cons next start stop create delete) =+ Param.with (Param.word32 time) $ \getTime valueTime ->+ CausalP.Cons+ (trackNext next valueTime)+ (trackStart start valueTime)+ (trackStop stop)+ (trackCreate create getTime)+ (trackDelete delete)++{- |+Like @trackSkip@ but repeats the last buffer content+when the end of the input signal is reached.+The returned 'Bool' flag is 'True' if a skip could be performed completely+and it is 'False' if the skip exceeds the end of the input.+That is, once a 'False' is returned all following values are tagged with 'False'.+The returned 'Word32' value is the number of actually skipped values.+This lags one step behind the input of skip values.+The number of an actual number of skips+is at most the number of requested skips.+If the flag is 'False', then the number of actual skips is zero.+The converse does not apply.++If the input signal is too short, the output is undefined.+(Before the available data the buffer will be filled with arbitrary values.)+We could fill the buffer with zeros,+but this would require an Arithmetic constraint+and the generated signal would not be very meaningful.+We could also return an empty signal if the input is too short.+However this would require a permanent check.+-}+trackSkipHold, trackSkipHold_ ::+ (Memory.C a) =>+ Param.T p Int -> SigP.T p a ->+ CausalP.T p (Value Word32) ((Value Bool, Value Word32), T a)+trackSkipHold time xs =+ (CausalP.zipWithSimple+ (\b ((c,x), buf) -> do+ y <- C.select b x A.zero+ return ((c, y), buf))+ $< (CausalP.delay1 (pure False) $* SigP.constant (pure True)))+{-+ (CausalPV.zipWithSimple (\b ((c,x), buf) -> ((c, b ?? (x,0)), buf))+ $< (CausalP.delay1 (pure False) $* SigP.constant (pure True)))+-}+ <<<+ trackSkipHold_ time xs++trackSkipHold_ time (SigP.Cons next start stop create delete) =+ (Param.with (Param.word32 time) $ \getTime valueTime ->+ CausalP.Cons+ (trackNextHold next valueTime)+ (trackStartHold start valueTime)+ (trackStopHold stop)+ (trackCreate create getTime)+ (trackDelete delete))+++trackNext ::+ (Memory.C al, Memory.Struct al ~ am, Phi z,+ Phi state, Class.Undefined state) =>+ (forall z0. (Phi z0) => context -> state -> MaybeCont.T r z0 (al, state)) ->+ (tl -> Value Word32) ->+ (context, (tl, Value (Ptr am))) ->+ Value Word32 ->+ (Value Word32, (state, Value Word32)) ->+ MaybeCont.T r z (T al, (Value Word32, (state, Value Word32)))+trackNext next valueTime (context, (size,ptr)) n1 (n0, statePos) = do+ let size0 = valueTime size+ (state3, pos3) <-+ MaybeCont.fromMaybe $ fmap snd $+ MaybeCont.fixedLengthLoop n0 statePos $ \(state0, pos0) -> do+ (a, state1) <- next context state0+ MaybeCont.lift $+ fmap ((,) state1) $ storeNext (size0,ptr) a pos0+ return (Cons ptr size0 pos3, (n1, (state3, pos3)))++trackStart ::+ (LLVM.IsSized am,+ Phi state, Class.Undefined state) =>+ (param -> CodeGenFunction r (context, state)) ->+ (tl -> Value Word32) ->+ (param, tl) ->+ CodeGenFunction r+ ((context, (tl, Value (Ptr am))),+ (Value Word32, (state, Value Word32)))+trackStart start valueTime (param, size) = do+ (context, state) <- start param+ let size0 = valueTime size+ ptr <- LLVM.arrayMalloc size0+ return ((context, (size,ptr)), (size0, (state, A.zero)))++trackStop ::+ (LLVM.IsType am) =>+ (context -> state -> CodeGenFunction r ()) ->+ (context, (tl, Value (Ptr am))) ->+ (Value Word32, (state, Value Word32)) ->+ CodeGenFunction r ()+trackStop stop (context, (_size,ptr)) (_n, (state, _remain)) = do+ LLVM.free ptr+ stop context state+++trackNextHold ::+ (Memory.C al, Memory.Struct al ~ am, Phi z,+ Phi state, Class.Undefined state) =>+ (forall z0. (Phi z0) => context -> state -> MaybeCont.T r z0 (al, state)) ->+ (tl -> Value Word32) ->+ (context, (tl, Value (Ptr am))) ->+ Value Word32 ->+ (Value Word32, (Maybe.T state, Value Word32)) ->+ MaybeCont.T r z+ (((Value Bool, Value Word32), T al),+ (Value Word32, (Maybe.T state, Value Word32)))+trackNextHold next valueTime (context, (size,ptr)) nNext (n0, (mstate0, pos0)) =+ MaybeCont.lift $ do+ let size0 = valueTime size+ (n3, (pos3, state3)) <-+ Maybe.run mstate0+ (return (n0, (pos0, mstate0)))+ (\state0 ->+ Maybe.loopWithExit (n0, (state0, pos0))+ (\(n1, (state1, pos1)) -> do+ cont <- A.cmp LLVM.CmpGT n1 A.zero+ fmap (mapSnd ((,) n1 . (,) pos1)) $+ C.ifThen cont+ (Maybe.nothing, Maybe.just state1)+ (do aState <- MaybeCont.toMaybe $ next context state1+ return (aState, fmap snd aState)))+ (\((a,state), (n1, (pos1, _mstate))) -> do+ pos2 <- storeNext (size0,ptr) a pos1+ n2 <- A.dec n1+ return (n2, (state, pos2))))+ skipped <- A.sub n0 n3+ return (((Maybe.isJust state3, skipped), Cons ptr size0 pos3),+ (nNext, (state3, pos3)))++storeNext ::+ (Memory.C al, Memory.Struct al ~ am) =>+ (Value Word32, Value (Ptr am)) ->+ al -> Value Word32 -> CodeGenFunction r (Value Word32)+storeNext (size0,ptr) a pos0 = do+ Memory.store a =<< LLVM.getElementPtr ptr (pos0, ())+ pos1 <- A.inc pos0+ cont <- A.cmp LLVM.CmpLT pos1 size0+ C.select cont pos1 A.zero+++trackStartHold ::+ (LLVM.IsSized am,+ Phi state, Class.Undefined state) =>+ (param -> CodeGenFunction r (context, state)) ->+ (tl -> Value Word32) ->+ (param, tl) ->+ CodeGenFunction r+ ((context, (tl, Value (Ptr am))),+ (Value Word32, (Maybe.T state, Value Word32)))+trackStartHold start valueTime (param, size) = do+ (context, state) <- start param+ let size0 = valueTime size+ ptr <- LLVM.arrayMalloc size0+ return ((context, (size,ptr)), (size0, (Maybe.just state, A.zero)))++trackStopHold ::+ (LLVM.IsType am) =>+ (context -> state -> CodeGenFunction r ()) ->+ (context, (tl, Value (Ptr am))) ->+ (Value Word32, (Maybe.T state, Value Word32)) ->+ CodeGenFunction r ()+trackStopHold stop (context, (_size,ptr)) (_n, (state, _remain)) = do+ LLVM.free ptr+ Maybe.for state $ stop context+++trackCreate ::+ (p -> IO (ioContext, param)) ->+ (p -> t) ->+ p ->+ IO (ioContext, (param, t))+trackCreate create getTime p = do+ (context, param) <- create p+ return (context, (param, getTime p))++trackDelete :: (ioContext -> IO ()) -> ioContext -> IO ()+trackDelete = id
src/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs view
@@ -6,11 +6,14 @@ import qualified Synthesizer.LLVM.Server.CausalPacked.Speech as Speech import qualified Synthesizer.LLVM.Server.CausalPacked.Instrument as Instr+import qualified Synthesizer.LLVM.Server.CausalPacked.InstrumentPlug as InstrPlug import qualified Synthesizer.LLVM.Server.SampledSound as Sample import Synthesizer.LLVM.Server.Common +import qualified Synthesizer.MIDI.PiecewiseConstant.ControllerSet as PCS import qualified Synthesizer.MIDI.CausalIO.ControllerSet as MCS import qualified Synthesizer.MIDI.CausalIO.Process as MIO+import qualified Synthesizer.MIDI.Value as MV import qualified Synthesizer.CausalIO.Process as PIO import qualified Synthesizer.PiecewiseConstant.Signal as PC @@ -18,6 +21,7 @@ import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS import qualified Synthesizer.LLVM.Storable.Process as CausalSt+import qualified Synthesizer.LLVM.Storable.Signal as SigStL import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt import qualified Synthesizer.LLVM.Frame.Stereo as Stereo@@ -29,16 +33,18 @@ import qualified Synthesizer.Zip as Zip -import qualified Synthesizer.MIDI.Dimensional.ValuePlain as MV+import qualified Synthesizer.MIDI.Dimensional.ValuePlain as DMV import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg import qualified Sound.MIDI.Message.Channel as ChannelMsg+import qualified Sound.MIDI.Message.Class.Construct as Construct import qualified Sound.MIDI.Message.Class.Check as Check -import Control.Arrow (Arrow, (<<<), (<<^), (^<<), arr, first, )+import Control.Arrow (Arrow, arr, first, (<<<), (^<<), ) import Control.Category (id, )-import Control.Monad (guard, )+import Control.Applicative ((<*>), ) import qualified Data.List.HT as ListHT+import Data.Maybe.HT (toMaybe, ) import qualified Data.Map as Map @@ -100,7 +106,7 @@ controllerExponentialDirect chan ctrl bnds initial = MIO.slice (Check.controller chan ctrl)- (MV.controllerExponential bnds)+ (DMV.controllerExponential bnds) initial shortTime ::@@ -168,10 +174,32 @@ controllerExponentialDim ctrl bnds initial = MCS.slice (MCS.Controller ctrl)- (MV.controllerExponential bnds)+ (DMV.controllerExponential bnds) initial +timeControlPercussive, timeControlString ::+ PIO.T+ (PCS.T MCS.Controller Int)+ (Zip.T+ (Instr.Control Instr.Time)+ (Instr.Control Instr.Time))++timeControlPercussive =+ controllerExponentialDim Ctrl.attackTime+ (DN.time 0.1, DN.time 2.5) (DN.time 0.8)+ &+&+ controllerExponentialDim Ctrl.releaseTime+ (DN.time 0.03, DN.time 0.3) (DN.time 0.1)++timeControlString =+ controllerExponentialDim Ctrl.attackTime+ (DN.time 0.005, DN.time 0.1) (DN.time 0.1)+ &+&+ controllerExponentialDim Ctrl.releaseTime+ (DN.time 0.03, DN.time 0.3) (DN.time 0.2)++ keyboardDetuneFMCore :: (Check.C msg, POut.Default b) => CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->@@ -179,13 +207,27 @@ IO (ChannelMsg.Channel -> VoiceMsg.Program -> SampleRate Real -> PIO.T (MIO.Events msg) b) keyboardDetuneFMCore emitStereo smpDir = do- arrange <- CausalSt.makeArranger+ arrange <- keyboardDetuneFMConstVolume smpDir amp <- CausalP.processIO (emitStereo <<< CausalP.envelopeStereo <<< first (CausalP.mapSimple Serial.upsample))+ return $ \chan initPgm rate ->+ amp ()+ <<<+ MIO.controllerExponential chan controllerVolume (0.001, 1) (0.2::Float)+ &+&+ arrange chan initPgm rate +keyboardDetuneFMConstVolume ::+ (Check.C msg) =>+ FilePath ->+ IO (ChannelMsg.Channel -> VoiceMsg.Program -> SampleRate Real ->+ PIO.T (MIO.Events msg) (SV.Vector (Stereo.T Vector)))+keyboardDetuneFMConstVolume smpDir = do+ arrange <- CausalSt.makeArranger+ tine <- Instr.tineStereoFM ping <- Instr.pingStereoReleaseFM filterSaw <- Instr.filterSawStereoFM@@ -195,6 +237,7 @@ windPhaser <- Instr.windPhaser string <- Instr.softStringShapeFM fmString <- Instr.fmStringStereoFM+ helixNoise <- InstrPlug.helixNoise arcs <- sequence $ Instr.cosineStringStereoFM : Instr.arcSawStringStereoFM :@@ -203,25 +246,18 @@ Instr.arcTriangleStringStereoFM : [] - tmt0 <- Instr.makeSampledSounds smpDir Sample.tomatensalat- hal0 <- Instr.makeSampledSounds smpDir Sample.hal- grp0 <- Instr.makeSampledSounds smpDir Sample.graphentheorie-- let timeControlPercussive =- controllerExponentialDim Ctrl.attackTime- (DN.time 0.1, DN.time 2.5) (DN.time 0.8)- &+&- controllerExponentialDim Ctrl.releaseTime- (DN.time 0.03, DN.time 0.3) (DN.time 0.1)+ helixSound <- Instr.helixSound+ sampledSound <- Instr.sampledSound - timeControlString =- controllerExponentialDim Ctrl.attackTime- (DN.time 0.005, DN.time 0.1) (DN.time 0.1)- &+&- controllerExponentialDim Ctrl.releaseTime- (DN.time 0.03, DN.time 0.3) (DN.time 0.2)+ syllables <-+ fmap concat $+ mapM (Sample.loadRanges smpDir) $+ Sample.tomatensalat :+ Sample.hal :+ Sample.graphentheorie :+ [] - frequencyControlPercussive =+ let frequencyControlPercussive = MCS.controllerLinear controllerDetune (0,0.005) 0.001 &+& MCS.bendWheelPressure 2 0.04 0.03@@ -337,6 +373,16 @@ &+& frequencyControlString)) + helixNoiseProc rate vel freq =+ helixNoise rate vel freq+ <<<+ Zip.arrowSecond+ (timeControlString+ &+&+ (MCS.controllerExponential controllerTimbre0 (1,0.01) 0.1+ &+&+ frequencyControlString))+ makeArc proc rate vel freq = proc rate vel freq <<<@@ -352,38 +398,65 @@ <<< Zip.arrowSecond frequencyControlPercussive + helixed smp rate vel freq =+ smp rate vel freq+ <<<+ Zip.arrowSecond+ (MCS.controllerExponential Ctrl.attackTime (0.25, 4) 1+ &+&+ frequencyControlPercussive)+ bank = Map.fromAscList $ zip [VoiceMsg.toProgram 0 ..] $ [tineProc, pingProc, filterSawProc, bellNoiseProc,- stringProc, fmStringProc] +++ stringProc, fmStringProc, helixNoiseProc] ++ map makeArc arcs ++ windProc : windPhaserProc :- map sampled (tmt0 ++ hal0 ++ grp0)+ ([helixed . helixSound, sampled . sampledSound] <*> syllables) return $ \chan initPgm rate ->- amp ()+ arrange <<<- (MCS.controllerExponential controllerVolume (0.001, 1) (0.2::Float)- <<^ Zip.second)- &+&- (arrange- <<<- arr shortTime- <<<- MIO.sequenceModulatedMultiProgram chan initPgm- (\pgm -> Map.findWithDefault pingProc pgm bank rate))+ arr shortTime <<<+ MIO.sequenceModulatedMultiProgram chan initPgm+ (\pgm -> Map.findWithDefault pingProc pgm bank rate)+ <<< id &+& MCS.fromChannel chan -data Phoneme = Phoneme Bool VoiceMsg.Pitch+keyboardMultiChannel ::+ (Check.C msg) =>+ FilePath ->+ IO (SampleRate Real ->+ PIO.T (MIO.Events msg) (SV.Vector (Stereo.T Real)))+keyboardMultiChannel smpDir = do+ proc <-+ keyboardDetuneFMCore+ (CausalP.mapSimple StereoInt.interleave)+ smpDir+ mix <- CausalP.processIO CausalP.mix + return $ \ sampleRate ->+ arr SigStL.unpackStereoStrict+ <<<+ foldl1+ (\x y -> mix () <<< Zip.arrowFanout x y)+ (map+ (\chan ->+ proc (ChannelMsg.toChannel chan) (VoiceMsg.toProgram 0)+ sampleRate)+ [0 .. 3])++++data Phoneme = Phoneme Bool VoiceMsg.Velocity VoiceMsg.Pitch+ instance Check.C Phoneme where- note _chan (Phoneme on p) =- Just (VoiceMsg.normalVelocity, p, on)+ note _chan (Phoneme on v p) = Just (v, p, on) voderSplit ::- (Check.C msg, Arrow arrow) =>+ (Check.C msg, Construct.C msg, Arrow arrow) => ChannelMsg.Channel -> arrow (MIO.Events msg)@@ -394,20 +467,30 @@ arr $ uncurry Zip.Cons . EventListTT.unzip .- fmap (ListHT.partitionMaybe $ \ev -> do- (_v,p,b) <- Check.note chan ev- guard $ p < VoiceMsg.toPitch 53- return $ Phoneme b p)+ fmap+ (ListHT.unzipEithers .+ fmap (\ev ->+ case Check.note chan ev of+ Nothing -> Right ev+ Just (v,p,b) ->+ if p >= VoiceMsg.toPitch 36+ then+ let p0 = VoiceMsg.increasePitch (-36) p+ in if p0 <= VoiceMsg.toPitch 29+ then Left $ Phoneme b v p0+ else Right $ Construct.note chan+ (v, VoiceMsg.increasePitch (-12) p, b)+ else Right ev)) voder ::- (Check.C msg, POut.Default b) =>+ (Check.C msg, Construct.C msg, POut.Default b) => CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->+ Speech.VowelSynth -> FilePath -> IO (ChannelMsg.Channel -> VoiceMsg.Program -> SampleRate Real -> PIO.T (MIO.Events msg) b)-voder emitStereo smpDir = do+voder emitStereo voice smpDir = do carrier <- keyboardDetuneFMCore id smpDir- voice <- Speech.phoneme arrange <- CausalSt.makeArranger interleave <- CausalP.processIO emitStereo @@ -425,3 +508,146 @@ Zip.arrowSecond (carrier chan initPgm sampleRate) <<< voderSplit chan++voderBand ::+ (Check.C msg, Construct.C msg, POut.Default b) =>+ CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->+ FilePath ->+ IO (ChannelMsg.Channel -> VoiceMsg.Program ->+ SampleRate Real -> PIO.T (MIO.Events msg) b)+voderBand emitStereo smpDir = do+ voice <- Speech.vowelBand+ voder emitStereo voice smpDir++voderMask ::+ (Check.C msg, Construct.C msg, POut.Default b) =>+ CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->+ FilePath ->+ IO (ChannelMsg.Channel -> VoiceMsg.Program ->+ SampleRate Real -> PIO.T (MIO.Events msg) b)+voderMask emitStereo smpDir = do+ voice <-+ Speech.vowelMask <*>+ fmap+ (Map.mapMaybe (\(typ,smp) ->+ toMaybe (typ==Speech.Filtered Speech.Continuous Speech.Voiced) smp))+ Speech.loadMasksKeyboard+ voder emitStereo voice smpDir+++voderEnv ::+ (Check.C msg, Construct.C msg, POut.Default b) =>+ CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->+ Speech.VowelSynthEnv ->+ FilePath ->+ IO (ChannelMsg.Channel -> VoiceMsg.Program ->+ SampleRate Real -> PIO.T (MIO.Events msg) b)+voderEnv emitStereo voice smpDir = do+ carrier <- keyboardDetuneFMConstVolume smpDir+ arrange <- CausalSt.makeArranger+ amp <-+ CausalP.processIO+ (emitStereo <<<+ CausalP.envelopeStereo <<<+ first (CausalP.mapSimple Serial.upsample))++ return $ \chan initPgm sampleRate ->+ amp ()+ <<<+ MIO.controllerExponential chan controllerVolume (0.001, 1) (0.2::Float)+ &+&+ (arrange+ <<<+ arr shortTime+ <<<+ MIO.sequenceModulatedMultiProgramVelocityPitch+ chan (VoiceMsg.toProgram 0)+ (\ _pgm vel -> voice sampleRate (MV.velocity vel))+ <<<+ Zip.arrowSecond+ (Zip.arrowFanout+ (timeControlString <<< MCS.fromChannel chan)+ (carrier chan initPgm sampleRate))+ <<<+ voderSplit chan)++voderMaskEnv ::+ (Check.C msg, Construct.C msg, POut.Default b) =>+ CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->+ FilePath ->+ IO (ChannelMsg.Channel -> VoiceMsg.Program ->+ SampleRate Real -> PIO.T (MIO.Events msg) b)+voderMaskEnv emitStereo smpDir = do+ voice <- Speech.phonemeMask <*> Speech.loadMasksKeyboard+ voderEnv emitStereo voice smpDir+++voderSeparated ::+ (Check.C msg, Construct.C msg, POut.Default b) =>+ CausalP.T (SampleRate Real) (Stereo.T VectorValue) (POut.Element b) ->+ Speech.VowelSynthEnv ->+ FilePath ->+ IO (ChannelMsg.Channel -> ChannelMsg.Channel -> VoiceMsg.Program ->+ SampleRate Real -> PIO.T (MIO.Events msg) b)+voderSeparated emitStereo voice smpDir = do+ carrier <- keyboardDetuneFMCore id smpDir+ arrange <- CausalSt.makeArranger+ amp <-+ CausalP.processIO+ (emitStereo <<<+ CausalP.envelopeStereo <<<+ first (CausalP.mapSimple Serial.upsample))++ return $ \carrierChan phonemeChan initPgm sampleRate ->+ amp sampleRate+ <<<+ MIO.controllerExponential phonemeChan controllerVolume (0.001, 1) (0.2::Float)+ &+&+ (arrange+ <<<+ arr shortTime+ <<<+ MIO.sequenceModulatedMultiProgramVelocityPitch+ phonemeChan (VoiceMsg.toProgram 0)+ (\ _pgm vel -> voice sampleRate (MV.velocity vel))+ <<<+ Zip.arrowFanout id+ (Zip.arrowFanout+ (timeControlString <<< MCS.fromChannel phonemeChan)+ (carrier carrierChan initPgm sampleRate)))++voderMaskSeparated ::+ (Check.C msg, Construct.C msg, POut.Default b) =>+ CausalP.T (SampleRate Real) (Stereo.T VectorValue) (POut.Element b) ->+ FilePath ->+ IO (ChannelMsg.Channel -> ChannelMsg.Channel -> VoiceMsg.Program ->+ SampleRate Real -> PIO.T (MIO.Events msg) b)+voderMaskSeparated emitStereo smpDir = do+ voice <- Speech.phonemeMask <*> Speech.loadMasksGrouped+ voderSeparated emitStereo voice smpDir++voderMaskMulti ::+ (Check.C msg, Construct.C msg) =>+ FilePath ->+ IO (SampleRate Real ->+ PIO.T (MIO.Events msg) (SV.Vector (Stereo.T Real)))+voderMaskMulti smpDir = do+ mix <- CausalP.processIO CausalP.mix+ proc <-+ voderMaskSeparated+ (CausalP.mapSimple StereoInt.interleave)+ smpDir++ return $ \ sampleRate ->+ arr SigStL.unpackStereoStrict+ <<<+ foldl1+ (\x y -> mix () <<< Zip.arrowFanout x y)+ (map+ (\chan ->+ proc+ (ChannelMsg.toChannel chan)+ (ChannelMsg.toChannel $ succ chan)+ (VoiceMsg.toProgram 4)+ sampleRate)+ [0, 2, 4, 6])
src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs view
@@ -22,6 +22,7 @@ import qualified Synthesizer.CausalIO.Gate as Gate import qualified Synthesizer.CausalIO.Process as PIO +import Synthesizer.LLVM.CausalParameterized.Process (($<), ) import Synthesizer.LLVM.CausalParameterized.Functional (($&), (&|&), ) import qualified Synthesizer.LLVM.Filter.Universal as UniFilter import qualified Synthesizer.LLVM.Filter.Allpass as Allpass@@ -30,14 +31,19 @@ import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Frame as Frame import qualified Synthesizer.LLVM.Frame.SerialVector as Serial+import qualified Synthesizer.LLVM.CausalParameterized.Helix as Helix 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.ProcessValue as CausalPV 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.Interpolation as Interpolation import qualified Synthesizer.LLVM.Wave as WaveL+import qualified Synthesizer.LLVM.Simple.Value as Value+import Synthesizer.LLVM.Simple.Value ((%>), (%<=), ) import qualified Synthesizer.LLVM.MIDI.BendModulation as BM import qualified Synthesizer.LLVM.MIDI as MIDIL@@ -50,9 +56,6 @@ import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector as SV -import System.FilePath ((</>), )--import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Monad as LM import qualified LLVM.Core as LLVM@@ -62,9 +65,10 @@ import qualified Data.Traversable as Trav import Control.Arrow (Arrow, arr, first, second, (&&&), (<<^), (^<<), ) import Control.Category (id, (.), )-import Control.Monad (liftM2, liftM3, (<=<), )+import Control.Monad (liftM2, liftM3, liftM4, (<=<), ) import Control.Applicative (pure, liftA2, liftA3, ) import Data.Monoid (mappend, )+import Data.Tuple.HT (fst3, snd3, thd3, ) import qualified Number.DimensionTerm as DN @@ -79,6 +83,8 @@ type Time = DN.Time Real type Frequency = DN.Frequency Real +type Chunk = SV.Vector Vector+type StereoChunk = SV.Vector (Stereo.T Vector) type BendModControl = Control (BM.T Real) type DetuneBendModControl = Zip.T (Control Real) (Control (BM.T Real)) @@ -122,18 +128,8 @@ Param.T p Real -> CausalP.T p VectorValue VectorValue takeThreshold =- CausalP.takeWhile- (\threshold y ->- A.cmp LLVM.CmpLE threshold =<< Serial.subsample y)---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)+ CausalPV.takeWhile+ (\threshold y -> threshold %<= Value.lift1 Serial.subsample y) type EnvelopeControl =@@ -157,7 +153,17 @@ (Zip.consChecked "ping gate times" gate times) ctrl -ping :: IO (Instrument Real (SV.Vector Vector))+zipEnvelope ::+ (Arrow arrow, CutG.Transform a, CutG.Transform b) =>+ arrow EnvelopeControl a ->+ arrow (WithEnvelopeControl b) (Zip.T a b)+zipEnvelope env =+ Zip.arrowFirstShorten env+ .+ reorderEnvelopeControl+++ping :: IO (Instrument Real Chunk) ping = fmap (\proc sampleRate vel freq -> proc (sampleRate, (vel,freq))@@ -175,7 +181,7 @@ pingReleaseEnvelope :: IO (Real -> Real -> SampleRate Real -> Real ->- PIO.T MIO.GateChunk (SV.Vector Vector))+ PIO.T MIO.GateChunk Chunk) pingReleaseEnvelope = liftM2 (\sustain release dec rel sr vel ->@@ -201,9 +207,7 @@ CausalP.fromSignal (SigPS.exponential2 release level)) -pingRelease ::- IO (Real -> Real ->- Instrument Real (SV.Vector Vector))+pingRelease :: IO (Real -> Real -> Instrument Real Chunk) pingRelease = liftM2 (\osci envelope dec rel sr vel freq ->@@ -221,9 +225,7 @@ pingControlledEnvelope :: Maybe Real -> IO (SampleRate Real -> Real ->- PIO.T- EnvelopeControl- (SV.Vector Vector))+ PIO.T EnvelopeControl Chunk) pingControlledEnvelope threshold = liftM2 (\sustain release sr vel ->@@ -258,7 +260,7 @@ (Zip.T (Zip.T (Control Real) (Control Time)) DetuneBendModControl)))- (SV.Vector (Stereo.T Vector)))+ StereoChunk) pingStereoReleaseFM = liftA2 (\osc env sr vel freq ->@@ -273,9 +275,7 @@ (Zip.arrowFirst $ Zip.arrowSecond $ arr $ halfLifeControl sr))) .- Zip.arrowFirstShorten (env sr vel)- .- reorderEnvelopeControl)+ zipEnvelope (env sr vel)) (CausalP.processIO (CausalP.envelopeStereo .@@ -306,7 +306,7 @@ (Zip.T (Zip.T (Control Frequency) (Control Time)) DetuneBendModControl))- (SV.Vector (Stereo.T Vector)))+ StereoChunk) filterSawStereoFM = liftA2 (\osc env sr vel freq ->@@ -320,9 +320,7 @@ (Zip.arrowSecond $ arr $ transposeModulation sr freq)) .- Zip.arrowFirstShorten (env sr vel)- .- reorderEnvelopeControl)+ zipEnvelope (env sr vel)) (CausalP.processIO (CausalP.envelopeStereo .@@ -349,7 +347,7 @@ expo) &|& (CausalP.stereoFromMono- (CausalPS.osciSimple WaveL.saw . CausalP.feedFst zero) $&+ (CausalPS.osciSimple WaveL.saw $< zero) $& freqs)))) (pingControlledEnvelope (Just 0.01)) @@ -360,7 +358,7 @@ (Zip.T (Zip.T (Control Real) (Control Real)) DetuneBendModControl))- (SV.Vector (Stereo.T Vector)))+ StereoChunk) tineStereoFM = liftA2 (\osc env sr vel freq ->@@ -370,9 +368,7 @@ Zip.arrowSecond $ arr $ transposeModulation sr freq) .- Zip.arrowFirstShorten (env sr vel)- .- reorderEnvelopeControl)+ zipEnvelope (env sr vel)) (CausalP.processIO (CausalP.envelopeStereo .@@ -385,7 +381,7 @@ index = CausalP.mapSimple Serial.upsample $& index0 depth = CausalP.mapSimple Serial.upsample $& depth0 expo =- F.lift $ CausalP.fromSignal $+ F.fromSignal $ SigPS.exponential2 (timeConst 1) (1 + vel) osci freq = CausalPS.osciSimple WaveL.approxSine2 $&@@ -405,7 +401,7 @@ (Zip.T (Zip.T (Control Real) (Control Real)) DetuneBendModControl))- (SV.Vector (Stereo.T Vector)))+ StereoChunk) bellNoiseStereoFM = liftA3 (\osc env envInf sr vel freq ->@@ -415,8 +411,8 @@ Zip.arrowSecond $ arr $ transposeModulation sr freq) .- Zip.arrowFirstShorten- (fanoutShorten+ zipEnvelope+ (Zip.arrowFanoutShorten (env sr (vel*0.5)) (let shortenTimes :: Real ->@@ -432,9 +428,7 @@ Zip.arrowSecond (shortenTimes 4)) (envInf sr (vel*4) .- Zip.arrowSecond (shortenTimes 7))))- .- reorderEnvelopeControl)+ Zip.arrowSecond (shortenTimes 7))))) (CausalP.processIO (F.withArgs $ \((env1,(env4,env7)),((noiseAmp0,noiseReson),fm)) -> let noiseAmp = CausalP.mapSimple Serial.upsample $& noiseAmp0@@ -443,9 +437,7 @@ (100 / fromIntegral vectorSize :: Param.T p Real) (CausalP.zipWithSimple (Moog.parameter TypeNum.d8)) noise =- F.lift- (CausalP.fromSignal- (SigPS.noise 12 (noiseReference 20000)))+ F.fromSignal (SigPS.noise 12 (noiseReference 20000)) freqs = stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) fm@@ -454,8 +446,7 @@ CausalP.envelopeStereo $& env &|& (CausalP.stereoFromMono- (CausalPS.osciSimple WaveL.approxSine4 .- CausalP.feedFst zero)+ (CausalPS.osciSimple WaveL.approxSine4 $< zero) $& CausalPS.amplifyStereo n $&@@ -481,7 +472,7 @@ stringControlledEnvelope :: IO (SampleRate Real -> Real ->- PIO.T EnvelopeControl (SV.Vector Vector))+ PIO.T EnvelopeControl Chunk) stringControlledEnvelope = liftM3 (\attack sustain release sr vel ->@@ -528,17 +519,16 @@ (MIDIL.frequencyFromBendModulationPacked (frequencyConst 0.2) $& fm)) in CausalP.stereoFromMonoControlled CtrlPS.process $&- (CausalP.zipWithSimple- (Moog.parameter TypeNum.d8) $&+ (CausalP.zipWithSimple (Moog.parameter TypeNum.d8) $& reson &|& modu) &|&- F.lift (CausalP.fromSignal stereoNoise)+ F.fromSignal stereoNoise wind :: IO (SampleRate Real -> Real -> Real -> PIO.T (WithEnvelopeControl DetuneBendModControl)- (SV.Vector (Stereo.T Vector)))+ StereoChunk) wind = liftA2 (\osc env sr vel freq ->@@ -547,9 +537,7 @@ (Zip.arrowSecond $ Zip.arrowSecond $ arr $ transposeModulation sr freq) .- Zip.arrowFirstShorten (env sr vel)- .- reorderEnvelopeControl)+ zipEnvelope (env sr vel)) (CausalP.processIO (F.withArgs $ \(env,(reson,fm)) -> CausalP.envelopeStereo $&@@ -564,7 +552,7 @@ (WithEnvelopeControl (Zip.T (Control Real) (Zip.T (Control Frequency) DetuneBendModControl)))- (SV.Vector (Stereo.T Vector)))+ StereoChunk) windPhaser = liftA2 (\osc env sr vel freq ->@@ -577,9 +565,7 @@ (Zip.arrowSecond $ arr $ transposeModulation sr freq)) .- Zip.arrowFirstShorten (env sr vel)- .- reorderEnvelopeControl)+ zipEnvelope (env sr vel)) (CausalP.processIO (F.withArgs $ \(env,(phaserMix0,(phaserFreq,(reson,fm)))) -> let phaserMix = CausalP.mapSimple Serial.upsample $& phaserMix0@@ -614,7 +600,7 @@ PIO.T (WithEnvelopeControl (Zip.T (Control Real) DetuneBendModControl))- (SV.Vector (Stereo.T Vector))+ StereoChunk softStringShapeCore :: (forall r.@@ -631,9 +617,7 @@ Zip.arrowSecond $ arr $ transposeModulation sr freq) .- Zip.arrowFirstShorten (env sr vel)- .- reorderEnvelopeControl)+ zipEnvelope (env sr vel)) (CausalP.processIO (CausalP.envelopeStereo .@@ -700,7 +684,7 @@ (Zip.T (Zip.T (Control Real) (Control Real)) DetuneBendModControl))- (SV.Vector (Stereo.T Vector)))+ StereoChunk) fmStringStereoFM = liftA2 (\osc env sr vel freq ->@@ -710,9 +694,7 @@ Zip.arrowSecond $ arr $ transposeModulation sr freq) .- Zip.arrowFirstShorten (env sr vel)- .- reorderEnvelopeControl)+ zipEnvelope (env sr vel)) (CausalP.processIO (F.withArgs $ \(env,((depth0,shape0),(det0,fm))) -> let det = CausalP.mapSimple Serial.upsample $& det0@@ -762,131 +744,186 @@ SampleRate Real -> Real -> Real -> PIO.T (Zip.T MIO.GateChunk DetuneBendModControl)- (SV.Vector (Stereo.T Vector)))+ StereoChunk) 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 = Sample.positions smp- amp = 2 * amplitudeFromVelocity vel- (attack, sustain, release) = Sample.parts smp- osci smpBody = osc (sr, (amp, smpBody))- in mappend- (osci- (attack `SigSt.append`- SVL.cycle (SigSt.take (Sample.loopLength pos) sustain))- .- Gate.shorten)- (osci release <<^ Zip.second)+ in assembleParts osc smp sr vel . Zip.arrowSecond- ((id :: PIOId (SV.Vector (Stereo.T Vector)))+ ((id :: PIOId StereoChunk) . freqMod (sr, ()) . (Zip.arrowSecond $ arr $- transposeModulation sr (freq * Sample.period 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 -})) -}))))+ transposeModulation sr (freq * Sample.period pos))))+ (CausalP.processIO (CausalP.stereoFromMono resamplingProc)) (CausalP.processIO (F.withArgs $ stereoFrequenciesFromDetuneBendModulation (frequencyConst 3))) -makeSampledSounds ::- FilePath ->- Sample.Info ->- IO [SampleRate Real -> Real -> Real ->- PIO.T- (Zip.T MIO.GateChunk DetuneBendModControl)- (SV.Vector (Stereo.T Vector))]-makeSampledSounds dir (file, positions, period) = do- liftA2- (\makeSmp smp ->- map (\pos -> makeSmp (Sample.Cons smp pos period))- positions)- sampledSound- (Sample.load (dir </> file)) - {- | mainly for testing purposes -} sampledSoundMono :: IO (Sample.T -> SampleRate Real -> Real -> Real ->- PIO.T- (Zip.T MIO.GateChunk BendModControl)- (SV.Vector Vector))+ PIO.T (Zip.T MIO.GateChunk BendModControl) Chunk) sampledSoundMono = 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 = Sample.positions smp- amp = 2 * amplitudeFromVelocity vel- (attack, sustain, release) = Sample.parts smp- osci smpBody = osc (sr, (amp, smpBody))- in mappend- (osci- (attack `SigSt.append`- SVL.cycle (SigSt.take (Sample.loopLength pos) sustain))- .- Gate.shorten)- (osci release <<^ Zip.second)+ in assembleParts osc smp sr vel . Zip.arrowSecond- ((id :: PIOId (SV.Vector Vector))+ ((id :: PIOId Chunk) . freqMod (sr, ()) .- (arr $ transposeModulation sr (freq * Sample.period smp))))- (CausalP.processIO- (let amp = number fst- smp = signal snd- in CausalPS.amplify amp- .- 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 -})) -})))+ (arr $ transposeModulation sr (freq * Sample.period pos))))+ (CausalP.processIO resamplingProc) (CausalP.processIO (MIDIL.frequencyFromBendModulationPacked (frequencyConst 3))) -makeSampledSoundsMono ::- FilePath ->- Sample.Info ->- IO [SampleRate Real -> Real -> Real ->+{-+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@.+-}+assembleParts ::+ (CutG.Transform a, CutG.Transform b) =>+ ((SampleRate Real, (Real, SVL.Vector Real)) -> PIO.T a b) ->+ Sample.T -> SampleRate Real -> Real ->+ PIO.T (Zip.T (Gate.Chunk gate) a) b+assembleParts osc smp sr vel =+ let pos = Sample.positions smp+ amp = 2 * amplitudeFromVelocity vel+ (attack, sustain, release) = Sample.parts smp+ osci smpBody = osc (sr, (amp, smpBody))+ in mappend+ (osci+ (attack `SigSt.append`+ SVL.cycle (SigSt.take (Sample.loopLength pos) sustain))+ .+ Gate.shorten)+ (osci release <<^ Zip.second)++resamplingProc ::+ CausalP.T+ (SampleRate Real, (Real, SigSt.T Real))+ VectorValue VectorValue+resamplingProc =+ let amp = number fst+ smp = signal snd+ in CausalPS.amplify amp+ .+ 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 -})) -})++helixSound ::+ IO (Sample.T ->+ SampleRate Real -> Real -> Real -> PIO.T- (Zip.T MIO.GateChunk BendModControl)- (SV.Vector Vector)]-makeSampledSoundsMono dir (file, positions, period) = do- liftA2- (\makeSmp smp ->- map (\pos -> makeSmp (Sample.Cons smp pos period))- positions)- sampledSoundMono- (Sample.load (dir </> file))+ (Zip.T MIO.GateChunk+ (Zip.T (Control Real) DetuneBendModControl))+ StereoChunk)+helixSound =+ liftM4+ (\helix zigZag integrate freqMod smp sr vel freq ->+ let pos = Sample.positions smp+ amp = 2 * amplitudeFromVelocity vel+ rateFactor =+ DN.divToScalar+ (Sample.sampleRate smp)+ (frequencyFromSampleRate sr)+ releaseStart =+ fromIntegral $+ Sample.loopStart pos + Sample.loopLength pos+ releaseStop =+ fromIntegral $+ Sample.start pos + Sample.length pos+ poss =+ (fromIntegral $ Sample.start pos,+ fromIntegral $ Sample.loopStart pos,+ fromIntegral $ Sample.loopLength pos)+ in helix (sr, ((amp, Sample.period pos), Sample.body smp))+ .+ Zip.arrowFirstShorten+ (mappend+ (zigZag (sr, poss) . Gate.shorten)+ (integrate (sr, (releaseStart, releaseStop))+ <<^ Zip.second))+ .+ Zip.arrowSecond+ (freqMod (sr, ())+ .+ (Zip.arrowSecond $ arr $ transposeModulation sr freq))+ .+ arr (\(Zip.Cons gate (Zip.Cons speed fm)) ->+ Zip.Cons (Zip.Cons gate (fmap (rateFactor*) speed)) fm))+ makeHelix+ makeZigZag+ makeIntegrate+ (CausalP.processIO+ (F.withArgs $ stereoFrequenciesFromDetuneBendModulation (frequencyConst 3)))++makeHelix ::+ IO ((SampleRate Real, ((Real, Real), SigSt.T Real)) ->+ PIO.T (Zip.T Chunk StereoChunk) StereoChunk)+makeHelix =+ CausalP.processIO+ (let amp = number (fst.fst)+ per = number (snd.fst)+ smp = signal snd+ in CausalPS.amplifyStereo amp+ .+ CausalP.stereoFromMono+ (Helix.staticPacked+ Interpolation.linear+ Interpolation.linear+ (fmap round per) per+ (fmap (SV.concat . SVL.chunks) smp)+ .+ second (CausalPS.osciCore $< 0))+ .+ arr (\(shape, freq) -> fmap ((,) shape) freq))++makeZigZag ::+ IO ((SampleRate Real, (Real, Real, Real)) ->+ PIO.T (Control Real) Chunk)+makeZigZag =+ CausalP.processIO+ (let start = number fst3+ loopStart = number snd3+ loopLength = number thd3++ in CausalPS.raise start+ .+ -- CausalPS.pack (Helix.zigZagLong (loopStart-start) loopLength)+ Helix.zigZagLongPacked (loopStart-start) loopLength+ .+ CausalP.mapSimple Serial.upsample)++makeIntegrate ::+ IO ((SampleRate Real, (Real, Real)) ->+ PIO.T (Control Real) Chunk)+makeIntegrate =+ CausalP.processIO+ (let start = number fst+ stop = number snd++ in CausalPV.takeWhile+ (\s v -> s %> Value.lift1 Serial.subsample v)+ stop+ .+ CausalPS.integrate start+ .+ CausalP.mapSimple Serial.upsample)
src/Synthesizer/LLVM/Server/CausalPacked/InstrumentPlug.hs view
@@ -10,11 +10,12 @@ import Synthesizer.LLVM.Server.CausalPacked.Instrument ( Control, DetuneBendModControl,- WithEnvelopeControl,+ WithEnvelopeControl, StereoChunk, pingControlledEnvelope,+ stringControlledEnvelope, reorderEnvelopeControl, ) import Synthesizer.LLVM.Server.CommonPacked (- Param, Vector, VectorValue, )+ Param, VectorValue, ) import Synthesizer.LLVM.Server.Common ( SampleRate, Real, frequencyConst, timeConst,@@ -25,18 +26,20 @@ import Synthesizer.LLVM.CausalParameterized.FunctionalPlug (($&), (&|&), ) import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Frame.SerialVector as Serial+import qualified Synthesizer.LLVM.CausalParameterized.Helix as Helix import qualified Synthesizer.LLVM.CausalParameterized.FunctionalPlug as FP 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.Interpolation as Interpolation import qualified Synthesizer.LLVM.Wave as WaveL import qualified Synthesizer.LLVM.MIDI.BendModulation as BM import qualified Synthesizer.LLVM.MIDI as MIDIL import qualified Synthesizer.Zip as Zip -import qualified Data.StorableVector as SV- import qualified LLVM.Core as LLVM import qualified Data.Traversable as Trav@@ -69,7 +72,7 @@ (Zip.T (Zip.T (Control Real) (Control Real)) DetuneBendModControl))- (SV.Vector (Stereo.T Vector)))+ StereoChunk) tineStereoFM = liftA2 (\osc env sr vel freq ->@@ -100,3 +103,41 @@ in CausalP.envelopeStereo $& FP.plug env &|& Stereo.liftApplicative osci freqs) (pingControlledEnvelope (Just 0.01))+++helixNoise ::+ IO (SampleRate Real -> Real -> Real ->+ PIO.T+ (WithEnvelopeControl+ (Zip.T (Control Real) DetuneBendModControl))+ StereoChunk)+helixNoise =+ liftA2+ (\osc env sr vel freq ->+ osc (sr, freq) (sr, vel)+ .+ Zip.arrowFirstShorten (env sr vel)+ .+ reorderEnvelopeControl)+ (FP.withArgs $ \(env, (speed0, (detune,fm))) ->+ let freqs =+ stereoFrequenciesFromDetuneBendModulation+ (frequencyConst 5)+ (FP.plug detune,+ FP.plug $ liftA2 (uncurry transposeModulation) FP.askParameter fm)+ speed = CausalP.mapSimple Serial.upsample $& FP.plug speed0+ in CausalP.envelopeStereo $&+ FP.plug env &|& Stereo.liftApplicative (helixOsci speed) freqs)+ stringControlledEnvelope++helixOsci ::+ FP.T pp pl inp VectorValue ->+ FP.T pp pl inp VectorValue ->+ FP.T pp pl inp VectorValue+helixOsci speed freq =+ CausalPS.pack+ (Helix.dynamicLimited Interpolation.cubic Interpolation.cubic+ 64 (64 :: Param.T p Real) (SigP.noise 66 0.2))+ $&+ speed &|&+ (CausalPS.osciCore $& 0 &|& freq)
src/Synthesizer/LLVM/Server/CausalPacked/Speech.hs view
@@ -2,21 +2,27 @@ module Synthesizer.LLVM.Server.CausalPacked.Speech where import Synthesizer.LLVM.Server.CausalPacked.Instrument- (Control, Frequency, frequencyControl, )-import Synthesizer.LLVM.Server.CommonPacked (Vector, VectorValue, )-import Synthesizer.LLVM.Server.Common (SampleRate, Real, frequency, )+ (StereoChunk, Control, Frequency, frequencyControl,+ WithEnvelopeControl, zipEnvelope,+ stringControlledEnvelope, pingControlledEnvelope, )+import Synthesizer.LLVM.Server.CommonPacked (VectorValue, )+import Synthesizer.LLVM.Server.Common+ (SampleRate(SampleRate), Real, parameter, noiseReference, frequency, )+import qualified Synthesizer.LLVM.Server.SampledSound as Sample import qualified Synthesizer.MIDI.CausalIO.Process as MIO import qualified Synthesizer.CausalIO.Gate as Gate import qualified Synthesizer.CausalIO.Process as PIO -import Synthesizer.LLVM.CausalParameterized.Process (($<), )+import Synthesizer.LLVM.CausalParameterized.Process (($<), ($>), ($*), ) import Synthesizer.LLVM.CausalParameterized.FunctionalPlug (($&), (&|&), ) import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Frame.SerialVector as Serial+import qualified Synthesizer.LLVM.Filter.NonRecursive as FiltNR import qualified Synthesizer.LLVM.CausalParameterized.FunctionalPlug as FP import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS 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.Zip as Zip@@ -24,19 +30,28 @@ import qualified Synthesizer.PiecewiseConstant.Signal as PC +import qualified Synthesizer.Generic.Control as CtrlG+import qualified Synthesizer.Generic.Signal as SigG+ import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter import Synthesizer.Plain.Filter.Recursive (Pole(Pole)) +import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector as SV+import qualified Data.Map as Map ; import Data.Map (Map) import qualified LLVM.Core as LLVM -import Control.Arrow (Arrow, arr, (^<<), )+import System.FilePath ((</>), (<.>), )++import Control.Arrow (arr, second, (^<<), (***), ) import Control.Category ((.), )-import Control.Applicative (liftA, liftA3, )+import Control.Applicative (pure, liftA, liftA3, (<*>), ) +import Data.Traversable (Traversable, traverse, forM, )+ import NumericPrelude.Numeric-import NumericPrelude.Base hiding (id, (.), )+import NumericPrelude.Base hiding ((.), ) {-@@ -63,17 +78,22 @@ sch - highpass cutoff 1500 Hz -} -phoneme ::- IO (SampleRate Real -> VoiceMsg.Pitch ->- PIO.T (Zip.T MIO.GateChunk (SV.Vector (Stereo.T Vector)))- (SV.Vector (Stereo.T Vector)))-phoneme =+type+ VowelSynth =+ SampleRate Real -> VoiceMsg.Pitch ->+ PIO.T (Zip.T MIO.GateChunk StereoChunk) StereoChunk++{- |+Synthesize vowels using bandpass filters.+-}+vowelBand :: IO VowelSynth+vowelBand = liftA- (\osc sr p ->+ (\filt sr p -> case formants p of Nothing -> arr $ const SV.empty Just fs ->- osc (sr, fs)+ filt (sr, fs) . Gate.shorten) (CausalP.processIO@@ -89,7 +109,7 @@ formants :: VoiceMsg.Pitch -> Maybe (Real, Real) formants p =- case VoiceMsg.fromPitch p - 36 of+ case VoiceMsg.fromPitch p of 00 -> Just ( 320, 800) -- u 02 -> Just ( 500, 1000) -- o 04 -> Just (1000, 1400) -- a@@ -101,6 +121,280 @@ _ -> Nothing +{- |+Synthesize vowels using sampled impulse responses.+-}+vowelMask ::+ IO (Map VoiceMsg.Pitch (SV.Vector Real) -> VowelSynth)+vowelMask =+ liftA+ (\filt dict sr p ->+ case Map.lookup p dict of+ Nothing -> arr $ const SV.empty+ Just mask ->+ filt (sr, mask)+ .+ Gate.shorten)+ (CausalP.processIO+ (CausalP.stereoFromMono (FiltNR.convolvePacked (parameter id))))+++type+ VowelSynthEnv =+ SampleRate Real -> Real {- Velocity -} -> VoiceMsg.Pitch ->+ PIO.T (WithEnvelopeControl StereoChunk) StereoChunk++data EnvelopeType = Continuous | Percussive+ deriving (Eq, Ord, Show)++data CarrierType = Voiced | Unvoiced | Rasp+ deriving (Eq, Ord, Show)++data PhonemeType = Filtered EnvelopeType CarrierType | Sampled+ deriving (Eq, Ord, Show)++{- |+Like 'vowelMask', but it does not simply open and close the gate abruptly.+Instead we use an envelope for fading the filtered sound in and out.+-}+phonemeMask ::+ IO (Map VoiceMsg.Pitch (PhonemeType, SV.Vector Real) -> VowelSynthEnv)+phonemeMask =+ pure+ (\filt filtRasp filtNoise smp contEnv percEnv dict sr vel p ->+ case Map.lookup p dict of+ Nothing -> arr $ const SV.empty+ Just (typ, mask) ->+ case typ of+ Filtered env carrier ->+ (case carrier of+ Voiced -> filt (sr, mask)+ Unvoiced -> filtNoise (sr, mask) . arr Zip.first+ Rasp ->+ filtRasp (sr, (mask,+ case sr of+ SampleRate r ->+ SVL.cycle $ SVL.take (round $ r/20) $+ CtrlG.exponential SigG.defaultLazySize+ (r/40) 1)))+ .+ zipEnvelope+ (case env of+ Continuous -> contEnv sr vel+ Percussive -> percEnv sr vel)+ Sampled ->+ smp (sr, SVL.fromChunks $ repeat mask)+ .+ arr Zip.first+ .+ zipEnvelope (contEnv sr vel))+ <*> CausalP.processIO+ (CausalP.envelopeStereo+ .+ second+ (CausalP.stereoFromMono (FiltNR.convolvePacked (parameter id))))+ <*> CausalP.processIO+ (CausalP.envelopeStereo+ .+ ((CausalP.envelope+ $< SigPS.pack (SigP.fromStorableVectorLazy (parameter snd)))+ ***+ CausalP.stereoFromMono (FiltNR.convolvePacked (parameter fst))))+ <*> CausalP.processIO+ (CausalP.envelopeStereo $>+ traverse+ (\seed ->+ FiltNR.convolvePacked (parameter id) $*+ (SigPS.noise seed $ noiseReference 1e7))+ (Stereo.cons 42 23))+ <*> CausalP.processIO+ (let smp = parameter id+ in pure ^<<+ (CausalP.envelope $>+ (SigPS.pack $ SigP.fromStorableVectorLazy smp)))+ <*> stringControlledEnvelope+ <*> pingControlledEnvelope (Just 0.01)+++phonemeRr,+ phonemeU,+ phonemeO,+ phonemeA,+ phonemeOe,+ phonemeOn,+ phonemeUe,+ phonemeAe,+ phonemeE,+ phonemeI,++ phonemeNg,+ phonemeL,+ phonemeM,+ phonemeN,+ phonemeR,+ phonemeJ,++ phonemeW,+ phonemeF,+ phonemeSch,+ phonemeH,+ phonemeTh,+ phonemeIch,+ phonemeAch,+ phonemeS,++ phonemeP,+ phonemeK,+ phonemeT,++ phonemeB,+ phonemeG,+ phonemeD+ :: (PhonemeType, FilePath)+phonemeU = (Filtered Continuous Voiced, "u")+phonemeO = (Filtered Continuous Voiced, "o")+phonemeA = (Filtered Continuous Voiced, "a")+phonemeOe = (Filtered Continuous Voiced, "oe")+phonemeOn = (Filtered Continuous Voiced, "on")+phonemeUe = (Filtered Continuous Voiced, "ue")+phonemeAe = (Filtered Continuous Voiced, "ae")+phonemeE = (Filtered Continuous Voiced, "e")+phonemeI = (Filtered Continuous Voiced, "i")++phonemeNg = (Filtered Continuous Voiced, "ng")+phonemeL = (Filtered Continuous Voiced, "l")+phonemeM = (Filtered Continuous Voiced, "m")+phonemeN = (Filtered Continuous Voiced, "n")+phonemeR = (Filtered Continuous Voiced, "r")+phonemeJ = (Filtered Continuous Voiced, "j")++phonemeW = (Filtered Continuous Unvoiced, "w")+phonemeF = (Filtered Continuous Unvoiced, "f")+phonemeSch = (Filtered Continuous Unvoiced, "sch")+phonemeH = (Filtered Continuous Unvoiced, "h")+phonemeTh = (Filtered Continuous Unvoiced, "th")+phonemeIch = (Filtered Continuous Unvoiced, "ich")+phonemeAch = (Filtered Continuous Unvoiced, "ach")+phonemeS = (Filtered Continuous Unvoiced, "s")++phonemeP = (Filtered Percussive Unvoiced, "p")+phonemeK = (Filtered Percussive Unvoiced, "k")+phonemeT = (Filtered Percussive Unvoiced, "t")++phonemeB = (Filtered Percussive Voiced, "b")+phonemeG = (Filtered Percussive Voiced, "g")+phonemeD = (Filtered Percussive Voiced, "d")++-- phonemeRr = (Sampled, "r")) :+phonemeRr = (Filtered Continuous Rasp, "ng")+++maskNamesKeyboard :: Map VoiceMsg.Pitch (PhonemeType, FilePath)+maskNamesKeyboard =+ Map.fromList $+ zip [VoiceMsg.toPitch 0 ..] $++ phonemeL : phonemeNg :+ phonemeM : phonemeJ :+ phonemeN :+ phonemeR :+ phonemeP :+ phonemeB : phonemeK :+ phonemeG : phonemeT :+ phonemeD :++ phonemeU : phonemeUe :+ phonemeO : phonemeOe :+ phonemeA :+ phonemeE : phonemeAe :+ phonemeI :+ phonemeRr :++ phonemeW : phonemeF :+ phonemeSch :+ phonemeH : phonemeTh :+ phonemeIch : phonemeAch :+ phonemeS :+ []++loadMasksKeyboard :: IO (Map VoiceMsg.Pitch (PhonemeType, SV.Vector Real))+loadMasksKeyboard =+ fmap (Map.insert (VoiceMsg.toPitch 29)+ (Filtered Continuous Voiced, SV.singleton 1)) $+ loadMasks maskNamesKeyboard+++maskNamesGrouped :: Map VoiceMsg.Pitch (PhonemeType, FilePath)+maskNamesGrouped =+ Map.fromList $++ (zip [VoiceMsg.toPitch 0 ..] $+ phonemeU :+ phonemeO :+ phonemeA :+ phonemeOe :+ phonemeUe :+ phonemeAe :+ phonemeE :+ phonemeI :+ phonemeOn :+ [])+ +++ (zip [VoiceMsg.toPitch 16 ..] $+ phonemeJ :+ phonemeL :+ phonemeM :+ phonemeN :+ phonemeNg :+ phonemeR :+ [])+ +++ (zip [VoiceMsg.toPitch 32 ..] $+ phonemeW :+ phonemeF :+ phonemeSch :+ phonemeH :+ phonemeTh :+ phonemeIch :+ phonemeAch :+ phonemeS :+ [])+ +++ (zip [VoiceMsg.toPitch 48 ..] $+ phonemeRr :+ [])+ +++ (zip [VoiceMsg.toPitch 64 ..] $+ phonemeP :+ phonemeK :+ phonemeT :+ [])+ +++ (zip [VoiceMsg.toPitch 80 ..] $+ phonemeB :+ phonemeG :+ phonemeD :+ [])++loadMasksGrouped :: IO (Map VoiceMsg.Pitch (PhonemeType, SV.Vector Real))+loadMasksGrouped =+ fmap (Map.insert (VoiceMsg.toPitch 127)+ (Filtered Continuous Voiced, SV.singleton 8)) $+ loadMasks maskNamesGrouped+++loadMasks ::+ (Traversable dict) =>+ dict (PhonemeType, FilePath) ->+ IO (dict (PhonemeType, SV.Vector Real))+loadMasks maskNames =+ forM maskNames $ \(typ, name) ->+ fmap ((,) typ . SV.concat . SVL.chunks) $+ Sample.load+ ((if typ==Sampled then "phoneme" else "mask") </> name <.> "wav")+++ type Input a = FP.Input (SampleRate Real) a plugUniFilterParameter ::@@ -124,7 +418,7 @@ singleFormant :: (Input inp (Control Real), (Input inp (Control Real), Input inp (Control Frequency))) ->- Input inp (SV.Vector (Stereo.T Vector)) ->+ Input inp StereoChunk -> FP.T (SampleRate Real) pl inp (Stereo.T VectorValue) singleFormant (amp, (reson, freq)) x = CausalP.envelopeStereo $&@@ -139,8 +433,8 @@ filterFormant :: IO (SampleRate Real -> PIO.T- (Zip.T FormantControl (SV.Vector (Stereo.T Vector)))- (SV.Vector (Stereo.T Vector)))+ (Zip.T FormantControl StereoChunk)+ StereoChunk) filterFormant = liftA (\filt sr -> filt sr (sr, ()))@@ -153,8 +447,8 @@ (Zip.T FormantControl (Zip.T FormantControl (Zip.T FormantControl FormantControl))))- (SV.Vector (Stereo.T Vector)))- (SV.Vector (Stereo.T Vector)))+ StereoChunk)+ StereoChunk) filterFormants = liftA (\filt sr -> filt sr (sr, ()))
+ src/Synthesizer/LLVM/Server/CausalPacked/SpeechExplore.hs view
@@ -0,0 +1,358 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Main where++import Synthesizer.LLVM.Server.Common (Real, )++import qualified Synthesizer.LLVM.Server.SampledSound as Sample+import qualified Sound.Sox.Write as SoxWrite++import qualified Graphics.Gnuplot.Advanced as Plot+import qualified Graphics.Gnuplot.Terminal.WXT as WXT+import qualified Graphics.Gnuplot.Plot.TwoDimensional as Plot2D+import qualified Graphics.Gnuplot.Graph.TwoDimensional as Graph2D++import Synthesizer.LLVM.CausalParameterized.Process (($*), ($<), ($<#), )+import qualified Synthesizer.LLVM.CausalParameterized.Controlled as CtrlP+import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1+import qualified Synthesizer.LLVM.Filter.NonRecursive as FiltNR++import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter+import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as FirstOrder+import Synthesizer.Plain.Filter.Recursive (Pole(Pole))++import qualified Synthesizer.Generic.Filter.NonRecursive as FiltNRG+import qualified Synthesizer.Generic.Fourier as Fourier+import qualified Synthesizer.Generic.Analysis as Analysis+import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.Piece as Piece+import qualified Synthesizer.Causal.Filter.NonRecursive as FiltNRC+import qualified Synthesizer.Causal.Process as Causal+import qualified Synthesizer.State.Signal as SigS+import Synthesizer.Piecewise ((#|-), (-|#), (#|), (|#), )++import qualified Data.StorableVector.Lazy.Pattern as SVP+import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV+import Foreign.Storable (Storable)++import Control.Arrow (arr, (<<<), (^<<), )+import Control.Category ((.), id, )++import Control.Functor.HT (void, )++import qualified Data.List.HT as ListHT+import qualified Data.List as List+import Data.Foldable (forM_, )+import Data.Maybe.HT (toMaybe, )+import Data.Maybe (catMaybes, )+import Data.Tuple.HT (mapSnd, )+import Data.Ord.HT (comparing, )+import Data.Monoid (mempty, mappend, )++import System.FilePath ((</>), (<.>), )++import qualified Number.Complex as Complex++import NumericPrelude.Numeric+import NumericPrelude.Base hiding (id, (.), )+++sampleRateInt :: Int+sampleRateInt = 44100++sampleRate :: Real+sampleRate = fromIntegral sampleRateInt++spectrum :: SVL.Vector Real -> SVL.Vector Real+spectrum xs =+ SVL.map Complex.magnitude $+ SVL.take (div (SVL.length xs) 2) $+ Fourier.transformBackward $+ SVL.map Complex.fromReal xs++timeDomain :: SVL.Vector Real -> SVL.Vector (Complex.T Real)+timeDomain xs =+ Fourier.transformForward $+ SVL.append+ (SVL.map Complex.fromReal xs)+ (SVL.replicate SVL.defaultChunkSize (SVL.length xs) 0)++chop :: Int -> SVL.Vector Real -> [SVL.Vector Real]+chop n =+ map (SVL.take n) .+ takeWhile (not . SVL.null) .+ iterate (SVL.drop n)++spectrumPlot :: SVL.Vector Real -> Plot2D.T Real Real+spectrumPlot xs =+ let k = sampleRate / fromIntegral (SVL.length xs)+ step = 16+ avg chunk = SVL.foldl (+) zero chunk / fromIntegral step+ in Plot2D.list Graph2D.lines $+ zip (iterate (fromIntegral step * k +) 0) $+ map avg $ chop step $+ spectrum xs++plotSpectrum :: SVL.Vector Real -> IO ()+plotSpectrum xs =+ void $+ Plot.plot WXT.cons $+ spectrumPlot xs++saveSound :: FilePath -> SVL.Vector Real -> IO ()+saveSound path xs =+ void $ SoxWrite.simple SVL.hPut mempty path sampleRateInt xs+++-- * modelling formants using bandpass filters++type Formant a = (UniFilter.Result a -> a, Pole Real, Real)++formants_a_noise :: [Formant a]+formants_a_noise =+ (UniFilter.bandpass, Pole 20 900, 1) :+ (UniFilter.bandpass, Pole 20 1200, 0.4) :+ (UniFilter.bandpass, Pole 10 2600, 0.07) :+ []++formants_f :: [Formant a]+formants_f =+ (UniFilter.lowpass, Pole 2 4000, 0.6) :+ (UniFilter.lowpass, Pole 2 11000, 0.3) :+ []++formants_sch :: [Formant a]+formants_sch =+ (UniFilter.bandpass, Pole 5 1500, 1.3) :+ (UniFilter.lowpass, Pole 2 3000, 0.6) :+ []++synthesis :: IO (SVL.ChunkSize -> () -> SVL.Vector Real)+synthesis =+ SigP.runChunky $+ (sum (map (\(typ, Pole q f, amp) ->+ CausalP.amplify (return amp)+ <<<+ typ+ ^<<+ CtrlP.process+ $<+ (SigP.constant $ return $+ UniFilter.parameter $ Pole q $ f / sampleRate))+ formants_sch)+ $* SigP.noise 174373 0.02)++compareSpec ::IO ()+compareSpec = do+ sampled <- Sample.load "phoneme/sch.wav"+ synthesized <- synthesis+ void $ Plot.plot WXT.cons $+ spectrumPlot sampled+ `mappend`+ spectrumPlot+ (SVL.take (SVL.length sampled) $+ synthesized (SVL.chunkSize 4096) ())++render ::IO ()+render = do+ synthesized <- synthesis+ saveSound "sch-synth.wav" $+ SVL.take sampleRateInt $+ synthesized (SVL.chunkSize 4096) ()+++-- * purification of sampled periods++-- ** using a comb filter++type Comb = (Real, Int) -> SVL.Vector Real -> SVL.Vector Real++makeComb :: IO Comb+makeComb =+ CausalP.runStorableChunky $ CausalP.comb (arr fst) (arr snd)++makeHighComb :: IO Comb+makeHighComb =+ CausalP.runStorableChunky $+ CausalP.comb (arr fst) (arr snd)+ .+ (Filt1.highpassCausal $<# FirstOrder.parameter (1000/sampleRate))++{- |+Take n values from the end of the vector in a lazy way.+-}+takeEnd :: (Storable a) => Int -> SVL.Vector a -> SVL.Vector a+takeEnd n xs =+ SVP.drop (SVP.length (SVL.drop n xs)) xs++scorePeriod :: Comb -> Real -> Int -> SVL.Vector Real -> (Real, SVL.Vector Real)+scorePeriod comb gain period sig =+ let end = takeEnd (3*period) $ comb (gain, period) sig+ in (Analysis.volumeEuclideanSqr end, end)++vowelNames :: [String]+vowelNames = ["a", "e", "i", "o", "on", "u", "oe", "ue", "ae"]++tonalNames :: [String]+tonalNames = vowelNames ++ ["l", "m", "n", "ng", "r", "j"]++sibilantNames :: [String]+sibilantNames = ["f", "h", "w", "s", "sch", "th", "ich", "ach"]++stopConsonantNames :: [String]+stopConsonantNames = ["p", "k", "t", "b", "g", "d"]++scanPeriods ::IO ()+scanPeriods = do+ comb <- makeComb+ forM_ tonalNames $ \name -> do+ let path = "phoneme" </> name <.> "wav"+ sampled <- Sample.load path+ putStrLn path+ let scores =+ flip map [350 .. 400] $ \period ->+ (period,+ flip map [0.9, 0.99, 0.999] $ \gain ->+ fst $ scorePeriod comb gain period sampled)+ -- mapM_ print scores+ putStrLn $+ "maximum: " +++ show (List.maximumBy (comparing snd) $ map (mapSnd maximum) scores)+++normalize :: SVL.Vector Real -> SVL.Vector Real+normalize =+ FiltNRG.normalize ((4*) . Analysis.volumeEuclidean)+++{-+We use the zero with the least derivative+in order to reduce jumps at the loop point.+In order to further reduce jumps, we cross-fade two adjacent periods.+It must be @length period3 = 3*len@.+@period3@ must contain a zero in the center chunk of size @len@.+-}+bestRotation :: Int -> SVL.Vector Real -> SVL.Vector Real+bestRotation len period3 =+ let start =+ fst $+ List.minimumBy (comparing snd) $ catMaybes $+ zipWith (fmap . (,)) [0..] $+ ListHT.mapAdjacent+ (\x y -> toMaybe (signum x /= signum y) (abs(x-y))) $+ SVL.unpack $ SVL.take len $ SVL.drop (len-1) period3+ in Causal.apply+ (Causal.applyFst+ (FiltNRC.crossfade len)+ (SVL.drop (start+len) period3))+ (SVL.drop start period3)++findPeriod :: Comb -> SVL.Vector Real -> SVL.Vector Real+findPeriod comb sampled =+ normalize $+ uncurry bestRotation $+ mapSnd snd $+ List.maximumBy (comparing (fst . snd)) $+ flip map [350 .. 400] $ \period ->+ (period, scorePeriod comb 0.99 period sampled)++extractPeriods ::IO ()+extractPeriods = do+ comb <- makeHighComb+ forM_ tonalNames $ \name -> do+ let readPath = "phoneme" </> name <.> "wav"+ sampled <- Sample.load readPath+ putStrLn readPath+ let writePath = "mask" </> name <.> "wav"+ saveSound writePath $ findPeriod comb sampled+++-- ** using the frequency spectrum++makeFilter :: IO (SV.Vector Real -> SVL.Vector Real -> SVL.Vector Real)+makeFilter =+ CausalP.runStorableChunky $ FiltNR.convolve id++normalizeMax :: SVL.Vector Real -> SVL.Vector Real+normalizeMax = FiltNRG.normalize Analysis.volumeMaximum++envelope :: Int -> SVL.Vector Real+envelope sizeInt =+ let size = fromIntegral sizeInt+ rampSize = size / 8+ in Piece.run SigG.defaultLazySize $+ 0 |# (rampSize, Piece.cosine) #|-+ 1 -|# (size-2*rampSize, Piece.step) #|-+ 1 -|# (rampSize, Piece.cosine) #| (0::Float)++data Transfer =+ Transfer {+ transferSpectrum,+ transferShrunkenSpectrum,+ transferEnvelope,+ transferWindow :: SVL.Vector Real+ }++transfer :: SVL.Vector Real -> Transfer+transfer sampled =+ let halfResponseSize = 256+ responseSize = 2*halfResponseSize+ halfShrink = div (SVL.length sampled) (2*responseSize)+ shrink = 2*halfShrink+ spec = spectrum $ SVL.take (shrink*responseSize) sampled+ shrunkenSpec =+ SigG.fromState SigG.defaultLazySize $+ SigS.init $ SigS.cons 0 $ SigS.map SigG.sum $+ SigG.sliceVertical shrink $ SVL.drop halfShrink spec+ env = envelope responseSize+ window =+ FiltNRG.envelope env $+ uncurry (flip SVL.append) $+ SVL.splitAt halfResponseSize $+ normalizeMax $ SVL.map Complex.real $+ timeDomain shrunkenSpec+ in Transfer {+ transferSpectrum = spec,+ transferShrunkenSpectrum = shrunkenSpec,+ transferEnvelope = env,+ transferWindow = window+ }++testTransfer ::IO ()+testTransfer = do+ sampled <- Sample.load "phoneme/o-noise.wav"+ filt <- makeFilter+ let trans = transfer sampled+ saveSound "/tmp/spectrum.wav" $+ normalizeMax $ transferSpectrum trans+ saveSound "/tmp/shrunkenspectrum.wav" $+ normalizeMax $ transferShrunkenSpectrum trans+ saveSound "/tmp/envelope.wav" $ transferEnvelope trans+ saveSound "/tmp/window.wav" $ transferWindow trans+ let window = SV.concat $ SVL.chunks $ transferWindow trans+ saveSound "/tmp/filtered.wav" $+ filt window $ SVL.concat $ replicate 100 $ SVL.cons 1 $+ SVL.replicate SVL.defaultChunkSize 380 0+ saveSound "/tmp/chirp.wav" $+ filt window $ SVL.concat $+ map (\n -> SVL.cons 1 $ SVL.replicate SVL.defaultChunkSize n 0) $+ [350..450]++transferMasks ::IO ()+transferMasks = do+-- forM_ (map (++"-noise") vowelNames) $ \name -> do+ forM_ (tonalNames++sibilantNames++stopConsonantNames) $ \name -> do+ let readPath = "phoneme" </> name <.> "wav"+ sampled <- Sample.load readPath+ putStrLn readPath+ let writePath = "mask" </> name <.> "wav"+ let trans = transfer sampled+ saveSound writePath $ normalize $ transferWindow trans+ let spectrumPath = "/tmp" </> "spec-" ++ name <.> "wav"+ saveSound spectrumPath $ normalizeMax $ transferShrunkenSpectrum trans+++main :: IO ()+main = transferMasks
src/Synthesizer/LLVM/Server/Common.hs view
@@ -1,9 +1,9 @@ {-# LANGUAGE TypeFamilies #-} module Synthesizer.LLVM.Server.Common (- Real,+ Real, Param, SampleRate(SampleRate), Instrument,- frequency, time, number, control, signal, parameter,+ frequency, time, noiseReference, number, control, signal, parameter, frequencyConst, timeConst, ($/), @@ -53,35 +53,41 @@ type Real = Float +type Param p = Param.T (SampleRate Real, p)+ type Instrument a sig = SampleRate a -> MidiSt.Instrument a sig -frequency :: (p -> Real) -> Param.T (SampleRate Real, p) Real+frequency :: (p -> Real) -> Param p Real frequency param = arr (\(SampleRate sampleRate, p) -> param p / sampleRate) -time :: (p -> Real) -> Param.T (SampleRate Real, p) Real+time :: (p -> Real) -> Param p Real time param = arr (\(SampleRate sampleRate, p) -> param p * sampleRate) -number :: (p -> Real) -> Param.T (SampleRate Real, p) Real+noiseReference :: Real -> Param p Real+noiseReference freq =+ arr (\(SampleRate sampleRate, _p) -> sampleRate/freq)++number :: (p -> Real) -> Param p Real number param = arr (param . snd) -control :: (p -> PC.T Real) -> Param.T (SampleRate Real, p) (PC.T Real)+control :: (p -> PC.T Real) -> Param p (PC.T Real) control param = arr (param . snd) -signal :: (p -> SigSt.T a) -> Param.T (SampleRate Real, p) (SigSt.T a)+signal :: (p -> SigSt.T a) -> Param p (SigSt.T a) signal param = arr (param . snd) -parameter :: (p -> a) -> Param.T (SampleRate Real, p) a+parameter :: (p -> a) -> Param p a parameter param = arr (param . snd) -frequencyConst :: Real -> Param.T (SampleRate Real, p) Real+frequencyConst :: Real -> Param p Real frequencyConst param = arr (\(SampleRate sampleRate, _p) -> param / sampleRate) -timeConst :: Real -> Param.T (SampleRate Real, p) Real+timeConst :: Real -> Param p Real timeConst param = arr (\(SampleRate sampleRate, _p) -> param * sampleRate)
src/Synthesizer/LLVM/Server/CommonPacked.hs view
@@ -1,4 +1,7 @@-module Synthesizer.LLVM.Server.CommonPacked where+module Synthesizer.LLVM.Server.CommonPacked (+ module Synthesizer.LLVM.Server.CommonPacked,+ Param,+ ) where import Synthesizer.LLVM.Server.Common @@ -7,9 +10,8 @@ import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.CausalParameterized.Functional as F import qualified Synthesizer.LLVM.Parameterized.Signal as SigP-import qualified Synthesizer.LLVM.Parameter as Param -import qualified Data.List.Match as Match+import qualified Data.NonEmpty as NonEmpty import qualified Algebra.Additive as Additive @@ -22,14 +24,8 @@ sumNested :: (Additive.C a) => [a] -> a-sumNested [] = Additive.zero-sumNested xs@(_:rs) =- let ys = xs ++ Match.take rs (sum2 ys)- in last ys--sum2 :: (Additive.C a) => [a] -> [a]-sum2 (x:y:rest) = (x+y) : sum2 rest-sum2 xs = xs+sumNested =+ maybe Additive.zero (NonEmpty.foldBalanced (+)) . NonEmpty.fetch -- maybe this can be merged into a PCS.controllerDiscrete@@ -40,7 +36,6 @@ in n + 0.01*r -type Param p = Param.T (SampleRate Real, p) type SigP p = SigP.T (SampleRate Real, p) type CausalP p = CausalP.T (SampleRate Real, p) type FuncP p = F.T (SampleRate Real, p)@@ -63,7 +58,3 @@ vectorTime param = arr (\(SampleRate sampleRate, p) -> param p * sampleRate / fromIntegral vectorSize)--noiseReference :: Real -> Param p Real-noiseReference freq =- arr (\(SampleRate sampleRate, _p) -> sampleRate/freq)
src/Synthesizer/LLVM/Server/Packed/Instrument.hs view
@@ -81,8 +81,6 @@ import qualified Synthesizer.MIDI.PiecewiseConstant as PC import qualified Synthesizer.MIDI.EventList as Ev -import System.FilePath ((</>), )- import Synthesizer.MIDI.Storable (chunkSizesFromLazyTime, ) import qualified Synthesizer.LLVM.Frame.Stereo as Stereo@@ -103,7 +101,7 @@ import qualified Synthesizer.LLVM.Wave as WaveL import Synthesizer.LLVM.CausalParameterized.Process (($<), ($>), ($*), ) import Synthesizer.LLVM.CausalParameterized.Functional (($&), (&|&), )-import Synthesizer.LLVM.Parameterized.Signal (($#), )+import Synthesizer.LLVM.Parameter (($#), ) import qualified LLVM.Extra.Monad as LM import qualified LLVM.Extra.Arithmetic as A@@ -1375,7 +1373,7 @@ let fmSig = freqMod (chunkSizesFromLazyTime (PC.duration fm))- (sr, (fm, freq * Sample.period smp)) :: SigSt.T Vector+ (sr, (fm, freq * Sample.period pos)) :: SigSt.T Vector pos = Sample.positions smp amp = 2 * amplitudeFromVelocity vel (attack, sustain, release) = Sample.parts smp@@ -1427,7 +1425,7 @@ SVP.splitAt (chunkSizesFromLazyTime dur) $ (freqMod (chunkSizesFromLazyTime (PC.duration fm))- (sr, (fm, freq * Sample.period smp)) :: SigSt.T Vector)+ (sr, (fm, freq * Sample.period pos)) :: SigSt.T Vector) pos = Sample.positions smp amp = 2 * amplitudeFromVelocity vel (attack, sustain, release) = Sample.parts smp@@ -1454,25 +1452,3 @@ (CausalPS.amplify 1.001))) (SigP.runChunkyPattern (frequencyFromBendModulation (frequencyConst 3) (modulation id)))----- ToDo: flag failure if files cannot be found, or just remain silent-makeSampledSounds ::- FilePath ->- Sample.Info ->- IO [-- PC.T Real ->- PC.T (BM.T Real) ->- Instrument Real (Stereo.T Vector)]-makeSampledSounds dir (file, positions, period) = do-{-- sound <-- (SoxRead.withHandle1 (SVL.hGetContentsSync chunkSize) =<<- SoxRead.open SoxOption.none "speech/tomatensalat2.wav")- play (44100::Real) (sound::SVL.Vector Real)--}- liftA2- (\makeSmp smp ->- map (\pos -> makeSmp (Sample.Cons smp pos period))- positions)- sampledSound- (Sample.load (dir </> file))
src/Synthesizer/LLVM/Server/SampledSound.hs view
@@ -5,12 +5,15 @@ import qualified Sound.Sox.Read as SoxRead import qualified Sound.Sox.Option.Format as SoxOption import Control.Exception (bracket, )+import System.FilePath ((</>), ) import qualified Synthesizer.Storable.Signal as SigSt import qualified Data.StorableVector.Lazy as SVL import Data.Tuple.HT (mapPair, ) +import qualified Number.DimensionTerm as DN+ import Prelude hiding (Real, length, ) @@ -18,14 +21,15 @@ data T = Cons { body :: SigSt.T Real,- positions :: Positions,- period :: Real+ sampleRate :: DN.Frequency Real,+ positions :: Positions } data Positions = Positions { start, length,- loopStart, loopLength :: Int+ loopStart, loopLength :: Int,+ period :: Real } @@ -34,10 +38,22 @@ bracket (SoxRead.open SoxOption.none path) SoxRead.close $ SoxRead.withHandle1 (SVL.hGetContentsSync SVL.defaultChunkSize) +loadRanges :: FilePath -> Info -> IO [T]+loadRanges dir (Info file sr poss) =+ fmap+ (\smp -> map (Cons smp (DN.frequency sr)) poss)+ (load (dir </> file)) -type Info = (FilePath, [Positions], Real) +data+ Info =+ Info {+ infoName :: FilePath,+ infoRate :: Real,+ infoPositions :: [Positions]+ } + parts :: T -> (SigSt.T Real, SigSt.T Real, SigSt.T Real) parts smp = let pos = positions smp@@ -59,42 +75,50 @@ tomatensalatPositions :: [Positions] tomatensalatPositions =- Positions 0 29499 12501 15073 :- Positions 29499 31672 38163 17312 :- Positions 67379 28610 81811 10667 :- Positions 95989 31253 106058 16111 :- Positions 127242 38596 136689 11514 :+ Positions 0 29499 12501 15073 321.4 :+ Positions 29499 31672 38163 17312 320.6 :+ Positions 67379 28610 81811 10667 323.2 :+ Positions 95989 31253 106058 16111 323.7 :+ {-+ vor dem 't' kommt noch das Ende vom 'a'+ wir bräuchten eine weitere Positionsangabe,+ um am Ende etwas überspringen zu können.+ Ein Smart-Konstruktor wie 'positions'+ könnte das bisherige Verhalten nachmachen.+ -}+ Positions 127242 38596 136689 11514 319.3 : [] + tomatensalat :: Info tomatensalat =- ("tomatensalat2.wav", tomatensalatPositions, 324.5)+ Info "tomatensalat2.wav" 44100 tomatensalatPositions halPositions :: [Positions] halPositions = -- Positions 2371 25957 7362 6321 :- Positions 2371 25957 (2371+25957) 1 :- Positions 40546 34460 63540 9546 :- Positions 79128 32348 94367 14016 :- Positions 112027 21227 125880 5500 :- Positions 146057 23235 168941 352 :+ Positions 2371 25957 (2371+25957) 1 320 :+ Positions 40546 34460 63540 9546 317.4 :+ Positions 79128 32348 94367 14016 317.8 :+ Positions 112027 21227 125880 5500 322.5 :+ Positions 146057 23235 168941 352 320 : [] hal :: Info hal =- ("haskell-in-leipzig2.wav", halPositions, 316)+ Info "haskell-in-leipzig2.wav" 44100 halPositions graphentheoriePositions :: [Positions] graphentheoriePositions =- Positions 0 29524 13267 14768 :- Positions 29524 35333 47624 9968 :- Positions 64857 31189 73818 16408 :- Positions 96046 31312 106206 18504 :- Positions 127358 32127 132469 16530 :+ Positions 0 29524 13267 14768 301.1 :+ Positions 29524 35333 47624 9968 301.6 :+ Positions 64857 31189 73818 16408 297.3 :+ Positions 96046 31312 106206 18504 302.9 :+ Positions 127358 32127 132469 16530 299.4 : [] graphentheorie :: Info graphentheorie =- ("graphentheorie0.wav", graphentheoriePositions, 301.15)+ Info "graphentheorie0.wav" 44100 graphentheoriePositions
+ src/Synthesizer/LLVM/Server/SampledSoundAnalysis.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Main where+-- module Synthesizer.LLVM.Server.SampledSoundAnalysis where++import qualified Synthesizer.LLVM.Server.SampledSound as Sample++import Synthesizer.LLVM.Server.Common (Real, )++import qualified Graphics.Gnuplot.Advanced as Plot+import qualified Graphics.Gnuplot.Plot.TwoDimensional as Plot2D+import qualified Graphics.Gnuplot.Graph.TwoDimensional as Graph2D++import qualified Synthesizer.Generic.Fourier as Fourier+import qualified Synthesizer.Generic.Signal as SigG++import qualified Synthesizer.State.Signal as SigS+import qualified Synthesizer.Storable.Signal as SigSt+import qualified Data.StorableVector.Lazy as SVL++import qualified Data.Foldable as Fold+import Control.Functor.HT (void, )+import Control.Monad (when, )+import Data.Tuple.HT (snd3, )+import Data.Monoid ((<>), )+import Data.Ord.HT (comparing, )++import qualified Number.Complex as Complex+import qualified Algebra.Field as Field+import qualified Algebra.Additive as Additive++import NumericPrelude.Numeric+import NumericPrelude.Base hiding (id, )+import Prelude ()++{-+I want to find the maximum of a peak with sub-sample precision.+Model: Lay parabola through maximum point and its left and right neighbors.++Parabola through three points: (-1,a), (0,b), (1,c):++Lagrange polynomial L_i:++f(t) = a*L_-1(t) + b*L_0(t) + c*L_1(t)+ = a*t*(t-1)/2 - b*(t+1)*(t-1) + c*t*(t+1)/2+ = a*(t^2-t)/2 + b*(1-t^2) + c*(t^2+t)/2++0 =!= f'(t)+ = a*L_-1'(t) + b*L_0'(t) + c*L_1'(t)+ = a*(2*t-1)/2 - b*2*t + c*(2*t+1)/2+0 = a*(2*t-1) - b*4*t + c*(2*t+1)+ = c-a + (2*a - 4*b + 2*c)*t+t = (a-c) / (2*a - 4*b + 2*c)+ = (c-a) / (2 * (2*b - a - c))++t is always between -0.5 and 0.5.+An SMT solver at least is convinced of it:++Prelude Data.SBV> prove $ \(a::SReal) (b::SReal) (c::SReal) -> a.<b &&& c.<b ==> abs ((a-c) / (a - 2*b + c)) .<= 1+Q.E.D.++Precondition: a>=0, b>=0, c>=0, a<b, c<b:++2*c < 2*b+c < 2*b - c+c-a < 2*b - a - c++=> t<0.5++p = b-a+q = b-c++t = (p-q)/(2*(p+q))++Parabola maximum is invariant with respect to vertical shifts.++For non-negative data like in the absolute spectrum+this would not be a good model.+In this case we could model a peak with a Gaussian.+Essentially this means to apply the parabola model+to the logarithms of the non-negative values.++However, autocorrelation data can contain negative values.+-}+{- |+The three numbers must not be equal,+and the center value must be the largest one.+-}+peakMaximum :: (Field.C a) => (a,a,a) -> a+peakMaximum (a,b,c) =+ (c-a) / (2 * (2*b - a - c))+++{-+weight autocorrelation coefficients+since the later ones are computed from less overlapped signal parts.++However, this emphasises later coefficients+and in one case the wrong maximum is chosen this way.+-}+weight :: Int -> SVL.Vector Real -> SVL.Vector Real+weight len =+ SigG.zipWithState (\w c -> c / fromIntegral w)+ (SigS.takeWhile (>0) $+ SigS.iterate (subtract 1) len)++autocorrelation :: SVL.Vector Real -> SVL.Vector Real+autocorrelation xs =+ SigSt.map Complex.real $+ Fourier.transformForward $+ SigSt.map (Complex.fromReal . Complex.magnitudeSqr) $+ Fourier.transformBackward $+ SigSt.map Complex.fromReal xs <> SigSt.map (const Additive.zero) xs++argMax :: (Ord a) => [a] -> Int+argMax =+ fst . Fold.maximumBy (comparing snd) .+ zip (iterate succ 0)++main :: IO ()+main =+ Fold.forM_ [Sample.tomatensalat, Sample.hal, Sample.graphentheorie] $+ \info -> do+ putStrLn $ Sample.infoName info+ ranges <- Sample.loadRanges "speech" info+ Fold.forM_ ranges $ \smp ->+ let ignoreBeginning = 30+ body = snd3 $ Sample.parts smp+ ac =+ SVL.take (SVL.length body `div` 2) $+ -- weight (SVL.length body) $+ autocorrelation body+ maxi =+ (ignoreBeginning+) $ argMax $ SigSt.toList $+ SigSt.drop ignoreBeginning ac+ a:b:c:_ = SigSt.toList $ SigSt.drop (maxi-1) ac+ in if SVL.length body < 1000+ then putStrLn "no loop"+ else do+ when False $ print $ SVL.length body+ when False $ print $ SVL.length ac+ when False $ void $ Plot.plotDefault $+ Plot2D.list Graph2D.listLines $ SigSt.toList ac+ print $ fromIntegral maxi + peakMaximum (a,b,c)
src/Synthesizer/LLVM/Simple/Signal.hs view
@@ -6,28 +6,33 @@ {-# LANGUAGE ForeignFunctionInterface #-} module Synthesizer.LLVM.Simple.Signal where -import qualified Synthesizer.LLVM.Wave as Wave+import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Frame as Frame+import qualified Synthesizer.LLVM.Wave as Wave import qualified Synthesizer.LLVM.Execution as Exec-import qualified LLVM.Extra.ForeignPtr as ForeignPtr-import qualified LLVM.Extra.Memory as Memory-import qualified LLVM.Extra.ScalarOrVector as SoV-import qualified LLVM.Extra.MaybeContinuation as Maybe import qualified Synthesizer.LLVM.Storable.ChunkIterator as ChunkIt+import qualified Synthesizer.LLVM.Storable.Vector as SVU import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector as SV import qualified Data.StorableVector.Base as SVB -import qualified Synthesizer.LLVM.Frame.Stereo as Stereo-+import qualified LLVM.Extra.ForeignPtr as ForeignPtr+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.MaybeContinuation as MaybeCont+import qualified LLVM.Extra.Maybe as Maybe import qualified LLVM.Extra.Arithmetic as A import LLVM.Extra.Arithmetic (advanceArrayElementPtr, ) import LLVM.Extra.Control (whileLoop, ifThen, )-import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, undefTuple, )+import LLVM.Extra.Class (MakeValueTuple, ValueTuple, undefTuple, ) -import LLVM.Core as LLVM+import qualified LLVM.Core as LLVM import LLVM.Util.Loop (Phi, )+import LLVM.Core+ (CodeGenFunction, ret, Value, valueOf,+ IsSized, IsConst, IsArithmetic, IsFloating,+ Linkage(ExternalLinkage), createNamedFunction) import Control.Monad (liftM2, liftM3, ) import Control.Applicative (Applicative, pure, (<*>), liftA2, )@@ -38,15 +43,13 @@ import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive -import Data.Word (Word32, )+import qualified System.Unsafe as Unsafe import Foreign.Storable.Tuple () import Foreign.Storable (Storable, )-import Foreign.Marshal.Array (advancePtr, )-import qualified Synthesizer.LLVM.Alloc as Alloc import Foreign.ForeignPtr (touchForeignPtr, withForeignPtr, )-import Foreign.Ptr (FunPtr, nullPtr, )+import Foreign.Ptr (FunPtr, Ptr, nullPtr, )+import Data.Word (Word32, ) import Control.Exception (bracket, )-import qualified System.Unsafe as Unsafe import NumericPrelude.Numeric import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, )@@ -70,7 +73,7 @@ Cons (forall r c. (Phi c) => ioContext ->- state -> Maybe.T r c (a, state))+ state -> MaybeCont.T r c (a, state)) -- compute next value (forall r. ioContext ->@@ -87,7 +90,7 @@ simple :: (Memory.C state) => (forall r c.- state -> Maybe.T r c (a, state)) ->+ state -> MaybeCont.T r c (a, state)) -> (forall r. CodeGenFunction r state) -> T a simple next start =@@ -104,7 +107,7 @@ Cons (\ioContext sa0 -> do (a,sa1) <- next ioContext sa0- b <- Maybe.lift $ f a+ b <- MaybeCont.lift $ f a return (b, sa1)) start createIOContext deleteIOContext@@ -119,7 +122,7 @@ Cons (\ioContext (sa0,ss0) -> do (a,sa1) <- next ioContext sa0- (b,ss1) <- Maybe.lift $ f a ss0+ (b,ss1) <- MaybeCont.lift $ f a ss0 return (b, (sa1,ss1))) (\ioContext -> liftM2 (,) (start ioContext) startS)@@ -135,7 +138,7 @@ (\(ioContextA, ioContextB) (sa0,sb0) -> do (a,sa1) <- nextA ioContextA sa0 (b,sb1) <- nextB ioContextB sb0- c <- Maybe.lift $ f a b+ c <- MaybeCont.lift $ f a b return (c, (sa1,sb1))) (\(ioContextA, ioContextB) -> liftM2 (,)@@ -198,33 +201,33 @@ interpolateConstant :: (Memory.C a, Memory.FirstClass b, Memory.Stored b ~ bm, IsSized b, IsSized bm,- Ring.C b,- IsFloating b, LLVM.CmpRet b, LLVM.CmpResult b ~ Bool, IsConst b) =>+ SoV.IntegerConstant b,+ IsFloating b, LLVM.CmpRet b, LLVM.CmpResult b ~ Bool) => b -> T a -> T a interpolateConstant k (Cons next start createIOContext deleteIOContext) = Cons (\ioContext ((y0,state0),ss0) -> do ((y1,state1), ss1) <-- Maybe.fromBool $+ MaybeCont.fromBool $ whileLoop (valueOf True, ((y0,state0), ss0)) (\(cont1, (_, ss1)) ->- and cont1 =<< A.fcmp FPOLE ss1 (valueOf 0))+ LLVM.and cont1 =<< A.fcmp LLVM.FPOLE ss1 A.zero) (\(_, ((_,state01), ss1)) ->- Maybe.toBool $ liftM2 (,)+ MaybeCont.toBool $ liftM2 (,) (next ioContext state01)- (Maybe.lift $ A.add ss1 (valueOf k)))+ (MaybeCont.lift $ A.add ss1 (valueOf k))) - ss2 <- Maybe.lift $ A.sub ss1 (valueOf Ring.one)+ ss2 <- MaybeCont.lift $ A.sub ss1 A.one return (y1, ((y1,state1),ss2))) {- using this initialization code we would not need undefined values (do sa <- start (a,_) <- next sa- return (sa, a, valueOf 0))+ return (sa, a, A.zero)) -}- (fmap (\sa -> ((undefTuple, sa), valueOf 0)) . start)+ (fmap (\sa -> ((undefTuple, sa), A.zero)) . start) createIOContext deleteIOContext @@ -264,7 +267,7 @@ Value a -> T (Value a) iterate f initial = simple- (\y -> Maybe.lift $ fmap (\y1 -> (y,y1)) (f y))+ (\y -> MaybeCont.lift $ fmap (\y1 -> (y,y1)) (f y)) (return initial) exponential2 ::@@ -307,17 +310,17 @@ SV.Vector a -> T value fromStorableVector xs =- let (fp,s,l) = SVB.toForeignPtr xs+ let (fp,ptr,l) = SVU.unsafeToPointers xs in Cons (\_ (p0,l0) -> do- cont <- Maybe.lift $ A.cmp CmpGT l0 (valueOf 0)- Maybe.withBool cont $ do+ cont <- MaybeCont.lift $ A.cmp LLVM.CmpGT l0 A.zero+ MaybeCont.withBool cont $ do y1 <- Memory.load p0 p1 <- advanceArrayElementPtr p0 l1 <- A.dec l0 return (y1,(p1,l1))) (const $ return- (valueOf (Memory.castStorablePtr $ Unsafe.foreignPtrToPtr fp `advancePtr` s),+ (valueOf ptr, valueOf (fromIntegral l :: Word32))) -- keep the foreign ptr alive (return fp)@@ -334,25 +337,24 @@ T value fromStorableVectorLazy sig = Cons- (\(stable, lenPtr) (buffer0,length0) -> do- (buffer1,length1) <- Maybe.lift $ do- nextChunkFn <- staticFunction ChunkIt.nextCallBack- needNext <- A.cmp CmpEQ length0 (valueOf 0)+ (\stable (buffer0,length0) -> do+ (buffer1,length1) <- MaybeCont.lift $ do+ nextChunkFn <- LLVM.staticFunction ChunkIt.nextCallBack+ needNext <- A.cmp LLVM.CmpEQ length0 A.zero ifThen needNext (buffer0,length0)- (liftM2 (,)- (call nextChunkFn (valueOf stable) (valueOf lenPtr))- (load (valueOf lenPtr)))- valid <- Maybe.lift $ A.cmp CmpNE buffer1 (valueOf nullPtr)- Maybe.withBool valid $ do+ (do lenPtr <- LLVM.alloca+ liftM2 (,)+ (LLVM.call nextChunkFn (valueOf stable) lenPtr)+ (LLVM.load lenPtr))+ valid <- MaybeCont.lift $ A.cmp LLVM.CmpNE buffer1 (valueOf nullPtr)+ MaybeCont.withBool valid $ do x <- Memory.load buffer1 buffer2 <- advanceArrayElementPtr buffer1 length2 <- A.dec length1 return (x, (buffer2,length2)))- (const $ return (valueOf nullPtr, valueOf 0))- (liftM2 (,) (ChunkIt.new sig) Alloc.malloc)- (\(stable,lenPtr) -> do- ChunkIt.dispose stable- Alloc.free lenPtr)+ (const $ return (valueOf nullPtr, A.zero))+ (ChunkIt.new sig)+ ChunkIt.dispose {-@@ -380,9 +382,9 @@ Exec.runFunction $ createNamedFunction ExternalLinkage "fillsignalblock" $ \ size bPtr -> do s <- start ioContext- (pos,_) <- Maybe.arrayLoop size bPtr s $ \ ptri s0 -> do+ (pos,_) <- MaybeCont.arrayLoop size bPtr s $ \ ptri s0 -> do (y,s1) <- next ioContext s0- Maybe.lift $ Memory.store y ptri+ MaybeCont.lift $ Memory.store y ptri return s1 ret (pos :: Value Word32) fmap (fromIntegral :: Word32 -> Int) $@@ -396,8 +398,9 @@ compileChunky :: (Memory.C value, Memory.Struct value ~ struct, Memory.C state, Memory.Struct state ~ stateStruct) =>- (forall r.- state -> Maybe.T r (Value Bool, state) (value, state)) ->+ (forall r z.+ (Phi z) =>+ state -> MaybeCont.T r z (value, state)) -> (forall r. CodeGenFunction r state) -> IO (FunPtr (IO (Ptr stateStruct)),@@ -424,12 +427,12 @@ (createNamedFunction ExternalLinkage "fillsignal" $ \ sptr loopLen ptr -> do sInit <- Memory.load sptr- (pos,sExit) <- Maybe.arrayLoop loopLen ptr sInit $+ (pos,sExit) <- MaybeCont.arrayLoop loopLen ptr sInit $ \ ptri s0 -> do (y,s1) <- next s0- Maybe.lift $ Memory.store y ptri+ MaybeCont.lift $ Memory.store y ptri return s1- Memory.store sExit sptr+ Memory.store (Maybe.fromJust sExit) sptr ret (pos :: Value Word32))
src/Synthesizer/LLVM/Simple/Value.hs view
@@ -7,18 +7,27 @@ module Synthesizer.LLVM.Simple.Value ( T, decons, twoPi, square, sqrt,- max, min, limit,- lift0, lift1, lift2,- unlift0, unlift1, unlift2,+ max, min, limit, fraction,++ (%==), (%/=), (%<), (%<=), (%>), (%>=),+ (%&&), (%||),+ (?), (??),++ lift0, lift1, lift2, lift3,+ unlift0, unlift1, unlift2, unlift3, unlift4, unlift5, constantValue, constant,+ fromInteger', fromRational', - Flatten(flatten, unfold), Registers,- flattenTraversable, unfoldFunctor,+ Flatten(flattenCode, unfoldCode), Registers,+ flatten, unfold,+ flattenCodeTraversable, unfoldCodeTraversable, flattenFunction, ) where +import qualified LLVM.Extra.Control as C import qualified LLVM.Extra.Arithmetic as A +import LLVM.Util.Loop (Phi, ) import LLVM.Core (CodeGenFunction, ) import qualified LLVM.Core as LLVM @@ -28,6 +37,8 @@ import qualified Control.Monad.Trans.Class as MT import qualified Control.Monad.Trans.State as MS import Control.Monad (liftM2, liftM3, )+import Control.Applicative (Applicative, pure, (<*>), )+import Control.Functor.HT (unzip, unzip3, ) import qualified Synthesizer.LLVM.Frame.Stereo as Stereo @@ -47,12 +58,13 @@ import qualified Number.Complex as Complex import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold import qualified System.Unsafe as Unsafe import qualified Prelude as P-import NumericPrelude.Numeric hiding (pi, sqrt, )-import NumericPrelude.Base hiding (min, max, )+import NumericPrelude.Numeric hiding (pi, sqrt, fromRational', fraction, )+import NumericPrelude.Base hiding (min, max, unzip, unzip3, ) {-@@ -75,7 +87,14 @@ decons value = MS.evalStateT (code value) Vault.empty +instance Functor T where+ fmap f x = consUnique (fmap f (code x)) +instance Applicative T where+ pure = constantValue+ f <*> x = consUnique (code f <*> code x)++ type Compute r a = MS.StateT Vault.Vault (LLVM.CodeGenFunction r) a @@ -107,16 +126,16 @@ instance (A.PseudoRing a, A.IntegerConstant a) => Ring.C (T a) where- one = constantValue (A.fromInteger' 1)+ one = constantValue A.one (*) = lift2 A.mul- fromInteger = constantValue . A.fromInteger'+ fromInteger = fromInteger' {- This instance is enough for Module here. The difference to Module instances on Haskell tuples is, that LLVM vectors cannot be nested. -}-instance (A.PseudoModule a v, A.IntegerConstant a) =>+instance (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a) => Module.C (T a) (T v) where (*>) = lift2 A.scale @@ -139,8 +158,7 @@ instance (A.Field a, A.RationalConstant a) => Field.C (T a) where (/) = lift2 A.fdiv- fromRational' =- constantValue . A.fromRational' . fromRational'+ fromRational' = fromRational' . Field.fromRational' {- instance (Cmp a b, Fractional a, IsConst a, IsFloating a) => RealFrac (T a) where@@ -150,7 +168,7 @@ instance (A.Transcendental a, A.RationalConstant a) => Algebraic.C (T a) where sqrt = lift1 A.sqrt root n x = lift2 A.pow x (1 / fromInteger n)- x^/r = lift2 A.pow x (fromRational' r)+ x^/r = lift2 A.pow x (Field.fromRational' r) instance (A.Transcendental a, A.RationalConstant a) => Trans.C (T a) where pi = lift0 A.pi@@ -168,7 +186,7 @@ instance (A.PseudoRing a, A.Real a, A.IntegerConstant a) => P.Num (T a) where- fromInteger = constantValue . A.fromInteger'+ fromInteger = fromInteger' (+) = lift2 A.add (-) = lift2 A.sub (*) = lift2 A.mul@@ -179,8 +197,7 @@ instance (A.Field a, A.Real a, A.RationalConstant a) => P.Fractional (T a) where- fromRational =- constantValue . A.fromRational' . P.fromRational+ fromRational = fromRational' (/) = lift2 A.fdiv instance@@ -231,7 +248,10 @@ limit :: (A.Real a) => (T a, T a) -> T a -> T a limit (l,u) = max l . min u +fraction :: (A.Fraction a) => T a -> T a+fraction = lift1 A.fraction + instance (A.Real a, A.PseudoRing a, A.IntegerConstant a) => Absolute.C (T a) where abs = lift1 A.abs@@ -241,11 +261,11 @@ For useful instances with different scalar and vector type, we would need a more flexible superclass. -}-instance (A.Real a, A.IntegerConstant a, A.PseudoModule a a) =>+instance (A.Real a, A.IntegerConstant a, a ~ A.Scalar a, A.PseudoModule a) => NormedSum.C (T a) (T a) where norm = lift1 A.abs -instance (A.Real a, A.IntegerConstant a, A.PseudoModule a a) =>+instance (A.Real a, A.IntegerConstant a, a ~ A.Scalar a, A.PseudoModule a) => NormedEuc.Sqr (T a) (T a) where normSqr = lift1 A.square @@ -262,6 +282,66 @@ -} +infix 4 %==, %/=, %<, %<=, %>=, %>++(%==), (%/=), (%<), (%<=), (%>), (%>=) ::+ (LLVM.CmpRet a) =>+ T (LLVM.Value a) -> T (LLVM.Value a) -> T (LLVM.Value (LLVM.CmpResult a))+(%==) = lift2 $ LLVM.cmp LLVM.CmpEQ+(%/=) = lift2 $ LLVM.cmp LLVM.CmpNE+(%>) = lift2 $ LLVM.cmp LLVM.CmpGT+(%>=) = lift2 $ LLVM.cmp LLVM.CmpGE+(%<) = lift2 $ LLVM.cmp LLVM.CmpLT+(%<=) = lift2 $ LLVM.cmp LLVM.CmpLE++infixr 3 %&&+infixr 2 %||++-- | Lazy AND+(%&&) :: T (LLVM.Value Bool) -> T (LLVM.Value Bool) -> T (LLVM.Value Bool)+a %&& b = a ? (b, constant False)++-- | Lazy OR+(%||) :: T (LLVM.Value Bool) -> T (LLVM.Value Bool) -> T (LLVM.Value Bool)+a %|| b = a ? (constant True, b)++infix 0 ?+{- |+@true ? (t,f)@ evaluates @t@,+@false ? (t,f)@ evaluates @f@.+@t@ and @f@ can reuse interim results,+but they cannot contribute shared results,+since only one of them will be run.+Cf. '(??)'+-}+(?) ::+ (Flatten value, Registers value ~ a, Phi a) =>+ T (LLVM.Value Bool) -> (value, value) -> value+c ? (t, f) =+ unfoldCode $ consUnique $ do+ b <- code c+ shared <- MS.get+ MT.lift $+ C.ifThenElse b+ (MS.evalStateT (flattenCode t) shared)+ (MS.evalStateT (flattenCode f) shared)++infix 0 ??+{- |+The expression @c ?? (t,f)@ evaluates both @t@ and @f@+and selects components from @t@ and @f@ according to @c@.+It is useful for vector values and+for sharing @t@ or @f@ with other branches of an expression.+-}+(??) ::+ (LLVM.IsFirstClass a, LLVM.CmpRet a) =>+ T (LLVM.Value (LLVM.CmpResult a)) ->+ (T (LLVM.Value a), T (LLVM.Value a)) ->+ T (LLVM.Value a)+c ?? (t, f) = lift3 LLVM.select c t f+++ lift0 :: (forall r. CodeGenFunction r a) -> T a@@ -283,25 +363,80 @@ yv <- code y MT.lift $ f xv yv +lift3 ::+ (forall r. a -> b -> c -> CodeGenFunction r d) ->+ T a -> T b -> T c -> T d+lift3 f x y z =+ consUnique $ do+ xv <- code x+ yv <- code y+ zv <- code z+ MT.lift $ f xv yv zv -unlift0 ::++_unlift0 :: T a -> (forall r. CodeGenFunction r a)-unlift0 = decons+_unlift0 = decons -unlift1 ::+unlift0 ::+ (Flatten value) =>+ value ->+ (forall r. CodeGenFunction r (Registers value))+unlift0 = flatten++_unlift1 :: (T a -> T b) -> (forall r. a -> CodeGenFunction r b)-unlift1 f x =- decons (f (constantValue x))+_unlift1 = unlift1 -unlift2 ::+{-+Better type inference than flattenFunction.+-}+unlift1 ::+ (Flatten value) =>+ (T a -> value) ->+ (forall r. a -> CodeGenFunction r (Registers value))+unlift1 f a =+ flatten (f (constantValue a))++_unlift2 :: (T a -> T b -> T c) -> (forall r. a -> b -> CodeGenFunction r c)-unlift2 f x y =- decons (f (constantValue x) (constantValue y))+_unlift2 = unlift2 +unlift2 ::+ (Flatten value) =>+ (T a -> T b -> value) ->+ (forall r. a -> b -> CodeGenFunction r (Registers value))+unlift2 f a b =+ flatten (f (constantValue a) (constantValue b)) +unlift3 ::+ (Flatten value) =>+ (T a -> T b -> T c -> value) ->+ (forall r. a -> b -> c -> CodeGenFunction r (Registers value))+unlift3 f a b c =+ flatten (f (constantValue a) (constantValue b) (constantValue c))++unlift4 ::+ (Flatten value) =>+ (T a -> T b -> T c -> T d -> value) ->+ (forall r. a -> b -> c -> d -> CodeGenFunction r (Registers value))+unlift4 f a b c d =+ flatten $+ f (constantValue a) (constantValue b) (constantValue c) (constantValue d)++unlift5 ::+ (Flatten value) =>+ (T a -> T b -> T c -> T d -> T e -> value) ->+ (forall r. a -> b -> c -> d -> e -> CodeGenFunction r (Registers value))+unlift5 f a b c d e =+ flatten $+ f (constantValue a) (constantValue b) (constantValue c)+ (constantValue d) (constantValue e)++ constantValue :: a -> T a constantValue x = consUnique (return x)@@ -309,25 +444,54 @@ constant :: (LLVM.IsConst a) => a -> T (LLVM.Value a) constant = constantValue . LLVM.valueOf +fromInteger' :: (A.IntegerConstant a) => Integer -> T a+fromInteger' = constantValue . A.fromInteger' +fromRational' :: (A.RationalConstant a) => P.Rational -> T a+fromRational' = constantValue . A.fromRational'++ class Flatten value where type Registers value :: *- flatten :: value -> CodeGenFunction r (Registers value)- unfold :: (Registers value) -> value+ flattenCode :: value -> Compute r (Registers value)+ unfoldCode :: T (Registers value) -> value -flattenTraversable ::+flatten ::+ (Flatten value) =>+ value -> CodeGenFunction r (Registers value)+flatten x = MS.evalStateT (flattenCode x) Vault.empty++unfold ::+ (Flatten value) =>+ (Registers value) -> value+unfold x = unfoldCode $ pure x++flattenCodeTraversable :: (Flatten value, Trav.Traversable f) =>- f value -> CodeGenFunction r (f (Registers value))-flattenTraversable =- Trav.mapM flatten+ f value -> Compute r (f (Registers value))+flattenCodeTraversable =+ Trav.mapM flattenCode -unfoldFunctor ::- (Flatten value, Functor f) =>- f (Registers value) -> f value-unfoldFunctor =- fmap unfold+unfoldCodeTraversable ::+ (Flatten value, Trav.Traversable f, Applicative f) =>+ T (f (Registers value)) -> f value+unfoldCodeTraversable =+ unfoldFromGetters getters +unfoldFromGetters ::+ (Functor f, Flatten b) =>+ f (a -> Registers b) -> T a -> f b+unfoldFromGetters g x =+ fmap (unfoldCode . flip fmap x) g +getters ::+ (Trav.Traversable f, Applicative f) =>+ f (f a -> a)+getters =+ fmap (\n x -> Fold.toList x !! n) $+ MS.evalState (Trav.sequenceA (pure (MS.state $ \n -> (n, succ n)))) 0++ flattenFunction :: (Flatten a, Flatten b) => (a -> b) -> (Registers a -> CodeGenFunction r (Registers b))@@ -353,46 +517,49 @@ instance (Flatten a, Flatten b) => Flatten (a,b) where type Registers (a,b) = (Registers a, Registers b)- flatten (a,b) =- liftM2 (,) (flatten a) (flatten b)- unfold (a,b) =- (unfold a, unfold b)+ flattenCode (a,b) =+ liftM2 (,) (flattenCode a) (flattenCode b)+ unfoldCode x =+ case unzip x of+ (a,b) -> (unfoldCode a, unfoldCode b) instance (Flatten a, Flatten b, Flatten c) => Flatten (a,b,c) where type Registers (a,b,c) = (Registers a, Registers b, Registers c)- flatten (a,b,c) =- liftM3 (,,) (flatten a) (flatten b) (flatten c)- unfold (a,b,c) =- (unfold a, unfold b, unfold c)+ flattenCode (a,b,c) =+ liftM3 (,,) (flattenCode a) (flattenCode b) (flattenCode c)+ unfoldCode x =+ case unzip3 x of+ (a,b,c) -> (unfoldCode a, unfoldCode b, unfoldCode c) instance Flatten a => Flatten (Stereo.T a) where type Registers (Stereo.T a) = Stereo.T (Registers a)- flatten = flattenTraversable- unfold = unfoldFunctor+ flattenCode = flattenCodeTraversable+ unfoldCode = unfoldCodeTraversable instance Flatten a => Flatten (Complex.T a) where type Registers (Complex.T a) = Complex.T (Registers a)- flatten s =+ flattenCode s = liftM2 (Complex.+:)- (flatten $ Complex.real s)- (flatten $ Complex.imag s)- unfold = unfoldFunctor+ (flattenCode $ Complex.real s)+ (flattenCode $ Complex.imag s)+ unfoldCode =+ unfoldFromGetters $ Complex.real Complex.+: Complex.imag instance (RealRing.C a, Flatten a) => Flatten (Phase.T a) where type Registers (Phase.T a) = Registers a- flatten s =- flatten $ Phase.toRepresentative s- unfold s =+ flattenCode s =+ flattenCode $ Phase.toRepresentative s+ unfoldCode s = -- could also be unsafeFromRepresentative- Phase.fromRepresentative $ unfold s+ Phase.fromRepresentative $ unfoldCode s instance Flatten (T a) where type Registers (T a) = a- flatten = decons- unfold = constantValue+ flattenCode = code+ unfoldCode = id instance Flatten () where type Registers () = ()- flatten = return- unfold = id+ flattenCode = return+ unfoldCode _ = ()
src/Synthesizer/LLVM/Simple/Vanilla.hs view
@@ -43,7 +43,7 @@ (\y -> Maybe.lift $ fmap (\y1 -> (Value.constantValue y, y1))- (Value.decons (f (Value.constantValue y))))+ (Value.unlift1 f y)) (Value.decons initial) iterate ::@@ -55,7 +55,7 @@ (\y -> Maybe.lift $ fmap (\y1 -> (Value.unfold y, y1))- (Value.flatten (f (Value.unfold y))))+ (Value.flattenFunction f y)) (Value.flatten initial) @@ -75,8 +75,7 @@ Value t -> Value t -> Sig.T (Value y) osciReg wave phase freq = Sig.map- (Value.decons . Wave.apply wave .- Phase.fromRepresentative . Value.constantValue) $+ (Value.unlift1 $ Wave.apply wave . Phase.fromRepresentative) $ Sig.iterate (SoV.incPhase freq) phase osciVal ::
src/Synthesizer/LLVM/Storable/ChunkIterator.hs view
@@ -1,13 +1,17 @@ {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ForeignFunctionInterface #-} module Synthesizer.LLVM.Storable.ChunkIterator where import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector.Base as SVB +import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Class as Class+ import Data.Word (Word32, ) import Foreign.Storable (Storable, poke, )-import Foreign.Ptr (FunPtr, Ptr, nullPtr, castPtr, )+import Foreign.Ptr (FunPtr, Ptr, nullPtr, ) import Control.Monad (liftM2, ) @@ -15,50 +19,46 @@ import Data.IORef (IORef, newIORef, readIORef, writeIORef, ) -data T =- forall a. Storable a =>- Cons (IORef [SVB.Vector a]) (IORef (SVB.Vector a))- {--I do not see a way,-how to bind the result type @Ptr a@-to the input type @SV.Vector a@.-We cannot make the element type of the storable vector-a type parameter of 'T'-since then we would also need to make Storable-a constraint of the FFI interface,-and this is forbidden.+FFI declarations must not have constraints.+Thus we put them in the iterator datatype. -}+data T a =+ (Storable a, Class.MakeValueTuple a, Memory.C (Class.ValueTuple a)) =>+ Cons (IORef [SVB.Vector a]) (IORef (SVB.Vector a))++type MemoryPtr a = Ptr (Memory.Struct (Class.ValueTuple a))++ foreign import ccall "&nextChunk" nextCallBack :: FunPtr (- StablePtr T ->- Ptr Word32 -> IO (Ptr a)+ StablePtr (T a) ->+ Ptr Word32 -> IO (MemoryPtr a) ) foreign export ccall "nextChunk" next ::- StablePtr T ->- Ptr Word32 -> IO (Ptr a)+ StablePtr (T a) ->+ Ptr Word32 -> IO (MemoryPtr a) new ::- Storable a =>- SVL.Vector a -> IO (StablePtr T)+ (Storable a, Class.MakeValueTuple a, Memory.C (Class.ValueTuple a)) =>+ SVL.Vector a -> IO (StablePtr (T a)) new sig = newStablePtr =<< liftM2 Cons (newIORef (SVL.chunks sig))- (newIORef- (error "first chunk must be fetched with nextChunk"))+ (newIORef (error "first chunk must be fetched with nextChunk")) dispose ::- StablePtr T -> IO ()+ StablePtr (T a) -> IO () dispose = freeStablePtr next ::- StablePtr T ->- Ptr Word32 -> IO (Ptr a)+ StablePtr (T a) ->+ Ptr Word32 -> IO (MemoryPtr a) next stable lenPtr = deRefStablePtr stable >>= \state -> case state of@@ -71,5 +71,7 @@ in order to protect it against garbage collection -} writeIORef chunkRef x >> writeIORef listRef xs >>- SVB.withStartPtr x (\p l ->- poke lenPtr (fromIntegral l) >> return (castPtr p))+ SVB.withStartPtr x+ (\p l ->+ poke lenPtr (fromIntegral l) >>+ return (Memory.castStorablePtr p))
src/Synthesizer/LLVM/Storable/Signal.hs view
@@ -20,9 +20,6 @@ import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS import qualified Synthesizer.LLVM.Execution as Exec-import qualified LLVM.Extra.Memory as Memory-import qualified LLVM.Extra.Arithmetic as A-import LLVM.Extra.Control (arrayLoop, ) import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import qualified Synthesizer.LLVM.Frame.Stereo as Stereo@@ -37,8 +34,10 @@ import qualified Data.EventList.Absolute.TimeBody as AbsEventList import qualified Number.NonNegative as NonNeg +import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Arithmetic as A import LLVM.Extra.Arithmetic (advanceArrayElementPtr, )-+import LLVM.Extra.Control (arrayLoop, ) import LLVM.Extra.Class (MakeValueTuple, ValueTuple, ) import LLVM.Core (Linkage(ExternalLinkage), createNamedFunction, ret,
+ src/Synthesizer/LLVM/Storable/Vector.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE TypeFamilies #-}+module Synthesizer.LLVM.Storable.Vector where++import qualified LLVM.Extra.Memory as Memory+import LLVM.Extra.Class (MakeValueTuple, ValueTuple, )++import qualified Data.StorableVector as SV+import qualified Data.StorableVector.Base as SVB++import Foreign.Storable (Storable, )+import Foreign.Marshal.Array (advancePtr, )+import Foreign.ForeignPtr (ForeignPtr, )+import Foreign.Ptr (Ptr, )+import qualified System.Unsafe as Unsafe+++unsafeToPointers ::+ (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>+ SV.Vector a ->+ (ForeignPtr a, Ptr (Memory.Struct value), Int)+unsafeToPointers v =+ let (fp,s,l) = SVB.toForeignPtr v+ in (fp,+ Memory.castStorablePtr $ Unsafe.foreignPtrToPtr fp `advancePtr` s,+ l)
src/Synthesizer/LLVM/Wave.hs view
@@ -32,6 +32,33 @@ A.truncate <=< A.mul (A.fromInteger' 2) +{- |+Discrete interpolation between triangle and square wave.+For exponent 1 we get a triangle wave.+The larger the exponent, the more we approach a square wave,+the.more computing is necessary.+-}+triangleSquarePower ::+ (A.PseudoRing a, A.RationalConstant a, A.Real a) =>+ Integer -> a -> CodeGenFunction r a+triangleSquarePower n = Value.unlift1 $ \x ->+ let y = 2-4*x+ z = abs (1-abs y)+ in (1-z^n)*signum y++{- |+Continuous interpolation between triangle and square wave.+For factor 0 we get a square wave,+for factor 1 we get a triangle wave.+-}+triangleSquareRatio ::+ (A.Field a, A.RationalConstant a, A.Real a) =>+ a -> a -> CodeGenFunction r a+triangleSquareRatio = Value.unlift2 $ \c x ->+ let y = 2-4*x+ z = abs (1-abs y)+ in (1-z)/(1+(c-1)*z)*signum y+ triangle :: (A.PseudoRing a, A.RationalConstant a, A.Fraction a) => a -> CodeGenFunction r a
synthesizer-llvm.cabal view
@@ -1,5 +1,5 @@ Name: synthesizer-llvm-Version: 0.5.0.2+Version: 0.6 License: GPL License-File: LICENSE Author: Henning Thielemann <haskell@henning-thielemann.de>@@ -58,7 +58,7 @@ default: True Source-Repository this- Tag: 0.5.0.2+ Tag: 0.6 Type: darcs Location: http://code.haskell.org/synthesizer/llvm/ @@ -69,30 +69,29 @@ Library Build-Depends:- llvm-extra >=0.4.1 && <0.5,+ llvm-extra >=0.5 && <0.6, -- llvm must be imported with restrictive version bounds, -- because we import implicitly and unqualified llvm-tf >=3.0 && <3.0.1, tfp >=0.7 && <0.9, vault >=0.1 && <0.3,- synthesizer-core >=0.6 && <0.7,+ synthesizer-core >=0.7 && <0.8, synthesizer-midi >=0.6 && <0.7, midi >=0.2.1 && <0.3, storable-record >=0.0.2 && <0.1, storable-tuple >=0.0.2 && <0.1, sox >=0.2 && <0.3,- sample-frame-np >=0.0.1 && <0.1,- sample-frame >=0.0.1 && <0.1, storablevector >=0.2.6 && <0.3, unsafe >=0.0 && <0.1, numeric-prelude >=0.3 && <0.5, non-negative >=0.1 && <0.2,+ non-empty >=0.2 && <0.3, event-list >=0.1 && <0.2, filepath >=1.1 && <1.4, random >=1.0 && <1.1, containers >=0.1 && <0.6, transformers >=0.2 && <0.4,- utility-ht >=0.0.8 && <0.1+ utility-ht >=0.0.10 && <0.1 Build-Depends: -- base-4 needed for Control.Category@@ -117,6 +116,7 @@ Synthesizer.LLVM.Storable.Signal Synthesizer.LLVM.Storable.Process Synthesizer.LLVM.Causal.Process+ Synthesizer.LLVM.Causal.ProcessValue Synthesizer.LLVM.CausalParameterized.Process Synthesizer.LLVM.CausalParameterized.ProcessValue Synthesizer.LLVM.CausalParameterized.ProcessPacked@@ -124,6 +124,7 @@ Synthesizer.LLVM.CausalParameterized.ControlledPacked Synthesizer.LLVM.CausalParameterized.Functional Synthesizer.LLVM.CausalParameterized.FunctionalPlug+ Synthesizer.LLVM.CausalParameterized.Helix Synthesizer.LLVM.Plug.Input Synthesizer.LLVM.Plug.Output Synthesizer.LLVM.Filter.Allpass@@ -137,8 +138,11 @@ Synthesizer.LLVM.Filter.SecondOrderCascade Synthesizer.LLVM.Filter.Moog Synthesizer.LLVM.Filter.Universal+ Synthesizer.LLVM.Filter.NonRecursive Synthesizer.LLVM.Generator.Exponential2 Synthesizer.LLVM.RingBuffer+ Synthesizer.LLVM.RingBufferForward+ Synthesizer.LLVM.Interpolation Synthesizer.LLVM.ConstantPiece Synthesizer.LLVM.Frame.SerialVector Synthesizer.LLVM.Frame@@ -161,8 +165,10 @@ Other-Modules: Synthesizer.LLVM.Random Synthesizer.LLVM.EventIterator+ Synthesizer.LLVM.Storable.Vector Synthesizer.LLVM.Storable.ChunkIterator Synthesizer.LLVM.Storable.LazySizeIterator+ Synthesizer.LLVM.Causal.ProcessPrivate Synthesizer.LLVM.Parameterized.SignalPrivate Synthesizer.LLVM.CausalParameterized.ProcessPrivate Synthesizer.LLVM.Debug.Counter@@ -178,17 +184,15 @@ Build-Depends: synthesizer-llvm, - llvm-extra >=0.4.1 && <0.5,+ llvm-extra, llvm-tf, tfp,- synthesizer-core >=0.6 && <0.7,+ synthesizer-core, synthesizer-midi >=0.6 && <0.7, midi >=0.2.1 && <0.3, storable-record >=0.0.2 && <0.1, storable-tuple >=0.0.2 && <0.1, sox >=0.2 && <0.3,- sample-frame-np >=0.0.1 && <0.1,- sample-frame >=0.0.1 && <0.1, storablevector >=0.2.6 && <0.3, numeric-prelude >=0.3 && <0.5, non-negative >=0.1 && <0.2,@@ -196,7 +200,9 @@ random >=1.0 && <1.1, containers >=0.1 && <0.6, transformers >=0.2 && <0.4,- utility-ht >=0.0.8 && <0.1,+ non-empty >=0.2 && <0.3,+ utility-ht,+ filepath, synthesizer-alsa >=0.5 && <0.6, alsa-pcm >=0.6 && <0.7,@@ -221,16 +227,14 @@ Build-Depends: synthesizer-llvm, - llvm-extra >=0.4.1 && <0.5,+ llvm-extra, llvm-tf, tfp,- synthesizer-core >=0.6 && <0.7,+ synthesizer-core, synthesizer-midi >=0.6 && <0.7, midi >=0.2.1 && <0.3, storable-record >=0.0.2 && <0.1, storable-tuple >=0.0.2 && <0.1,- sample-frame-np >=0.0.1 && <0.1,- sample-frame >=0.0.1 && <0.1, storablevector >=0.2.6 && <0.3, numeric-prelude >=0.3 && <0.5, non-negative >=0.1 && <0.2,@@ -238,7 +242,7 @@ filepath >=1.1 && <1.4, containers >=0.1 && <0.6, transformers >=0.2 && <0.4,- utility-ht >=0.0.8 && <0.1,+ utility-ht, synthesizer-alsa >=0.5 && <0.6, midi-alsa >=0.2.1 && <0.3,@@ -275,25 +279,24 @@ jack >=0.7 && <0.8, - llvm-extra >=0.4.1 && <0.5,+ llvm-extra, llvm-tf, tfp,- synthesizer-core >=0.6 && <0.7,+ synthesizer-core, synthesizer-midi >=0.6 && <0.7, midi >=0.2.1 && <0.3, storable-record >=0.0.2 && <0.1, storable-tuple >=0.0.2 && <0.1,- sample-frame-np >=0.0.1 && <0.1,- sample-frame >=0.0.1 && <0.1, storablevector >=0.2.6 && <0.3, numeric-prelude >=0.3 && <0.5, non-negative >=0.1 && <0.2,+ random >=1.0 && <1.1, explicit-exception >=0.1.7 && <0.2, event-list >=0.1 && <0.2, filepath >=1.1 && <1.4, containers >=0.1 && <0.6, transformers >=0.2 && <0.4,- utility-ht >=0.0.8 && <0.1,+ utility-ht, base >=4 && <5 @@ -318,17 +321,15 @@ Build-Depends: synthesizer-llvm, - llvm-extra >=0.4.1 && <0.5,+ llvm-extra, llvm-tf, tfp, sox >=0.2.1 && <0.3,- synthesizer-core >=0.6 && <0.7,+ synthesizer-core, synthesizer-midi >=0.6 && <0.7, midi >=0.2.1 && <0.3, storable-record >=0.0.2 && <0.1, storable-tuple >=0.0.2 && <0.1,- sample-frame-np >=0.0.1 && <0.1,- sample-frame >=0.0.1 && <0.1, storablevector >=0.2.6 && <0.3, numeric-prelude >=0.3 && <0.5, non-negative >=0.1 && <0.2,@@ -337,7 +338,7 @@ filepath >=1.1 && <1.4, containers >=0.1 && <0.6, transformers >=0.2 && <0.4,- utility-ht >=0.0.8 && <0.1,+ utility-ht, base >=4 && <5 @@ -357,19 +358,61 @@ Other-Modules: Synthesizer.LLVM.Server.Option +Executable synthi-llvm-sample+ If flag(buildExamples)+ Build-Depends:+ gnuplot >=0.5 && <0.6,+ synthesizer-llvm,+ synthesizer-core,+ numeric-prelude,+ storablevector,+ utility-ht,+ base >=4 && <5+ Else+ Buildable: False+ Default-Language: Haskell98+ GHC-Options: -Wall+ If impl(ghc>=7.0)+ GHC-Options: -fwarn-unused-do-bind -fcontext-stack=1000+ CPP-Options: -DNoImplicitPrelude=RebindableSyntax+ Default-Extensions: CPP+ Main-Is: src/Synthesizer/LLVM/Server/SampledSoundAnalysis.hs++Executable synthi-llvm-speech+ If flag(buildExamples)+ Build-Depends:+ gnuplot >=0.5 && <0.6,+ filepath,+ sox,+ synthesizer-llvm,+ synthesizer-core,+ numeric-prelude,+ storablevector,+ utility-ht,+ base >=4 && <5+ Else+ Buildable: False+ Default-Language: Haskell98+ GHC-Options: -Wall+ If impl(ghc>=7.0)+ GHC-Options: -fwarn-unused-do-bind -fcontext-stack=1000+ CPP-Options: -DNoImplicitPrelude=RebindableSyntax+ Default-Extensions: CPP+ Main-Is: src/Synthesizer/LLVM/Server/CausalPacked/SpeechExplore.hs+ Executable synthi-llvm-test If flag(buildTests) Build-Depends: synthesizer-llvm, - llvm-extra >=0.4.1 && <0.5,+ llvm-extra, llvm-tf, tfp,- synthesizer-core >=0.6 && <0.7,+ synthesizer-core, storablevector >=0.2.6 && <0.3, numeric-prelude >=0.3 && <0.5, random >=1.0 && <1.1,- utility-ht >=0.0.8 && <0.1,+ utility-ht, QuickCheck >=1 && <3, base >=4 && <5@@ -384,6 +427,8 @@ Hs-Source-Dirs: testsuite Main-Is: Test/Main.hs Other-Modules:+ Test.Synthesizer.LLVM.RingBufferForward+ Test.Synthesizer.LLVM.Helix Test.Synthesizer.LLVM.Filter Test.Synthesizer.LLVM.Packed Test.Synthesizer.LLVM.Utility
testsuite/Test/Main.hs view
@@ -1,5 +1,7 @@ module Main where +import qualified Test.Synthesizer.LLVM.RingBufferForward as RingBufferForward+import qualified Test.Synthesizer.LLVM.Helix as Helix import qualified Test.Synthesizer.LLVM.Filter as Filter import qualified Test.Synthesizer.LLVM.Packed as Packed @@ -17,6 +19,8 @@ LLVM.initializeNativeTarget mapM_ (\(name,test) -> putStr (name ++ ": ") >> test) $ concat $+ prefix "Helix" Helix.tests :+ prefix "RingBufferForward" RingBufferForward.tests : prefix "Filter" Filter.tests : prefix "Packed" Packed.tests : []
testsuite/Test/Synthesizer/LLVM/Filter.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Rank2Types #-} module Test.Synthesizer.LLVM.Filter (tests) where @@ -10,6 +11,7 @@ import qualified Synthesizer.LLVM.Filter.Moog as Moog import qualified Synthesizer.LLVM.Filter.ComplexFirstOrder as ComplexFilter import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked as ComplexFilterP+import qualified Synthesizer.LLVM.Filter.NonRecursive as FiltNR import qualified Synthesizer.Plain.Filter.Recursive.Allpass as AllpassCore import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as FirstOrderCore@@ -24,7 +26,7 @@ import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS import qualified Synthesizer.LLVM.Parameterized.Signal as SigP import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*), )-import Synthesizer.LLVM.Parameterized.Signal (($#), )+import Synthesizer.LLVM.Parameter (($#), ) import Synthesizer.Plain.Filter.Recursive (Pole(Pole)) -- import qualified Synthesizer.Storable.Signal as SigSt@@ -40,6 +42,7 @@ import qualified Synthesizer.Basic.Phase as Phase import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV import Data.StorableVector.Lazy (ChunkSize, ) import Test.Synthesizer.LLVM.Utility@@ -48,18 +51,23 @@ import qualified Control.Category as Cat import Control.Category ((<<<), )-import Control.Arrow ((&&&), (^<<), (<<^), )+import Control.Arrow (arr, (&&&), (***), (^<<), (<<^), ) +import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Memory as Memory import LLVM.Core (Value, ) import qualified LLVM.Core as LLVM+import qualified Types.Data.Bool as TypeBool import qualified Types.Data.Num as TypeNum import Types.Data.Num (D4, ) import qualified Number.Complex as Complex import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified System.Random as Rnd+import Data.Word (Word32, )+ import Test.QuickCheck (quickCheck, ) import NumericPrelude.Numeric@@ -108,13 +116,13 @@ SigP.T p (Value Float) allpassPhaserCausal reduct = CausalP.apply- (Allpass.phaserP+ (Allpass.phaser $< allpassControl TypeNum.d16 reduct) allpassPhaserPipeline reduct xs = let order = TypeNum.d16 in (SigP.drop $# TypeNum.fromIntegerT order) $- (Allpass.phaserPipelineP+ (Allpass.phaserPipeline $< allpassControl order reduct $* xs) @@ -152,7 +160,7 @@ SigP.T p VectorValue -> SigP.T p VectorValue allpassPhaserPacked reduct =- applyPacked Allpass.phaserPackedP+ applyPacked Allpass.phaserPacked (allpassControl TypeNum.d16 reduct) allpassPacked :: IO (ChunkSize -> ((Int,Int), Int) -> SimFloat)@@ -224,7 +232,7 @@ SigP.T p (Value Float) -> SigP.T p (Value Float) firstOrderConstant cutOff xs =- FirstOrder.lowpassCausalP+ FirstOrder.lowpassCausal $< SigP.constant (FirstOrderCore.parameter ^<< cutOff) $* xs @@ -242,7 +250,7 @@ SigP.T p (Value Float) -> SigP.T p (Value Float) firstOrderCausal reduct xs =- FirstOrder.lowpassCausalP+ FirstOrder.lowpassCausal $< lfoSine FirstOrder.parameter reduct $* xs @@ -275,7 +283,7 @@ SigP.T p VectorValue firstOrderCausalPacked reduct = applyPacked- (FirstOrder.lowpassCausalPackedP)+ FirstOrder.lowpassCausalPacked (lfoSine FirstOrder.parameter reduct) firstOrderPacked :: IO (ChunkSize -> ((Int,Int), Int) -> SimFloat)@@ -295,7 +303,7 @@ SigP.T p (Value Float) -> SigP.T p (Value Float) secondOrderCausal reduct xs =- SecondOrder.causalP+ SecondOrder.causal $< lfoSine (SecondOrder.bandpassParameter (LLVM.valueOf (10::Float))) reduct $* xs @@ -304,7 +312,7 @@ SigP.T p VectorValue -> SigP.T p VectorValue secondOrderCausalPacked reduct =- applyPacked SecondOrder.causalPackedP+ applyPacked SecondOrder.causalPacked (lfoSine (SecondOrder.bandpassParameter (LLVM.valueOf (10::Float))) reduct) secondOrderPacked :: IO (ChunkSize -> ((Int,Int), Int) -> SimFloat)@@ -323,7 +331,7 @@ SigP.T p (Value Float) -> SigP.T p (Value Float) secondOrderCausalPacked2 reduct xs =- SecondOrderP.causalP+ SecondOrderP.causal $< lfoSine (SecondOrderP.bandpassParameter (LLVM.valueOf (10::Float))) reduct $* xs @@ -350,7 +358,7 @@ SigP.T p (Value Float) -> SigP.T p (UniFilter.Result (Value Float)) universalCausal reduct xs =- UniFilter.causalP+ UniFilter.causal $< lfoSine (UniFilter.parameter (LLVM.valueOf (10::Float))) reduct $* xs @@ -387,13 +395,13 @@ moogCausal ::- (TypeNum.NaturalT n) =>+ (TypeNum.NaturalT n, TypeNum.IsNatural n ~ TypeBool.True) => n -> Param.T p Float -> SigP.T p (Value Float) -> SigP.T p (Value Float) moogCausal order reduct xs =- Moog.causalP+ Moog.causal $< lfoSine (Moog.parameter order (LLVM.valueOf (10::Float))) reduct $* xs @@ -429,9 +437,9 @@ SigP.T p (Stereo.T (Value Float)) complexCausal reduct = CausalP.apply $- (ComplexFilter.causalP+ (ComplexFilter.causal $< lfoSine (ComplexFilter.parameter (LLVM.valueOf (10::Float))) reduct)- <<^ (\x -> Stereo.cons x (LLVM.value LLVM.zero))+ <<^ (\x -> Stereo.cons x A.zero) complexCausalPacked :: Param.T p Float ->@@ -439,9 +447,9 @@ SigP.T p (Stereo.T (Value Float)) complexCausalPacked reduct = CausalP.apply $- (ComplexFilterP.causalP+ (ComplexFilterP.causal $< lfoSine (ComplexFilterP.parameter (LLVM.valueOf (10::Float))) reduct)- <<^ (\x -> Stereo.cons x (LLVM.value LLVM.zero))+ <<^ (\x -> Stereo.cons x A.zero) complexPacked :: IO (ChunkSize -> ((Int,Int), Int) -> SimFloat) complexPacked =@@ -488,6 +496,21 @@ -} +convolvePacked :: IO (ChunkSize -> ((Int,Int), Word32) -> SimFloat)+convolvePacked =+ let mask =+ (\(len, seed) ->+ fst $ SV.packN len $ Rnd.randomRs (-1,1::Float) seed)+ ^<< rangeFromInt (1,20) *** arr Rnd.mkStdGen <<^ fst+ noise = SigP.noise (arr snd) 1+ noiseP = SigPS.noise (arr snd) 1+ unpack :: SigP.T p VectorValue -> SigP.T p (Value Float)+ unpack = SigPS.unpack+ in checkSimilarity 1e-3 limitFloat+ (FiltNR.convolve mask $* noise)+ (unpack $ (FiltNR.convolvePacked mask $* noiseP))++ tests :: [(String, IO ())] tests = ("secondOrderPacked", quickCheck =<< secondOrderPacked) :@@ -502,4 +525,5 @@ ("moog", quickCheck =<< moog) : ("complexPacked", quickCheck =<< complexPacked) : ("complex", quickCheck =<< complex) :+ ("convolvePacked", quickCheck =<< convolvePacked) : []
+ testsuite/Test/Synthesizer/LLVM/Helix.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE Rank2Types #-}+module Test.Synthesizer.LLVM.Helix (tests) where++import qualified Synthesizer.LLVM.CausalParameterized.Helix as Helix+import qualified Synthesizer.LLVM.CausalParameterized.Functional as Func+import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified Synthesizer.LLVM.Parameter as Param+import qualified Synthesizer.LLVM.Interpolation as Interpolation+import Synthesizer.LLVM.CausalParameterized.Functional (($&), (&|&), )+import Synthesizer.LLVM.CausalParameterized.Process (($*), )+import Synthesizer.LLVM.Parameter (($#), )++import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV+import Data.StorableVector.Lazy (ChunkSize, )++import Test.Synthesizer.LLVM.Utility+ (CheckSimilarity, checkSimilarity, rangeFromInt, )++import Control.Category ((<<<), )+import Control.Arrow (arr, (***), (^<<), (<<^), )+import Control.Applicative (pure, )++import LLVM.Core (Value, )++import Foreign.Storable (Storable, )++import qualified System.Random as Rnd+import Data.Word (Word32, )++-- import qualified Graphics.Gnuplot.Simple as Gnuplot+import Test.QuickCheck (quickCheck, )++import NumericPrelude.Numeric+import NumericPrelude.Base+++type SimFloat = CheckSimilarity Float++signalLength :: Int+signalLength = 500+++limitFloat :: (Storable a) => SVL.Vector a -> SVL.Vector a+limitFloat = SVL.take signalLength+++randomSpeed :: Param.T p (Int, Int) -> SigP.T p (Value Float)+randomSpeed p =+ SigP.fromStorableVectorLazy+ ((\(len, seed) ->+ SVL.cycle $+ SVL.fromChunks+ [fst $ SV.packN len $ Rnd.randomRs (0,10::Float) seed])+ ^<< rangeFromInt (1,100) *** arr Rnd.mkStdGen <<< p)++randomPhase :: Param.T p (Int, Int) -> SigP.T p (Value Float)+randomPhase p =+ SigP.fromStorableVectorLazy+ ((\(len, seed) ->+ SVL.cycle $+ SVL.fromChunks+ [fst $ SV.packN len $ Rnd.randomRs (0,1::Float) seed])+ ^<< rangeFromInt (1,100) *** arr Rnd.mkStdGen <<< p)++staticDynamic ::+ IO (ChunkSize -> (((Int, Int), (Int, Int)), (Int, Word32)) -> SimFloat)+staticDynamic =+ let len = 1000+ speedParam = arr $ fst.fst+ phaseParam = arr $ snd.fst+ noiseParam = arr $ snd.snd+ period = rangeFromInt (1,32::Float) <<^ fst.snd+ noise seed = CausalP.take (pure len) $* SigP.noise seed 1++ static =+ Helix.static Interpolation.linear Interpolation.linear+ (fmap round period) period+ (fmap (\seed -> SigP.render (noise (arr id)) len seed :: SV.Vector Float) noiseParam)+ $&+ Func.fromSignal+ ((CausalP.integrate $# (0::Float)) $* randomSpeed speedParam)+ &|&+ Func.fromSignal (randomPhase phaseParam)++ dynamic =+ Helix.dynamic Interpolation.linear Interpolation.linear+ (fmap round period) period (noise noiseParam)+ $&+ Func.fromSignal (randomSpeed speedParam)+ &|&+ Func.fromSignal (randomPhase phaseParam)++ in checkSimilarity 5e-3 limitFloat+ (Func.compileSignal static)+ (Func.compileSignal dynamic)++{-+plot :: IO ()+plot = do+ render <- staticDynamic+ case render (SVL.chunkSize 1) (((111,0),(0,23)),(107,11)) of+ CheckSimilarity _tol xs ys ->+ Gnuplot.plotLists [] [SVL.unpack xs, SVL.unpack ys]+ >>+ Gnuplot.plotList [] (zipWith (-) (SVL.unpack xs) (SVL.unpack ys))+-}+++tests :: [(String, IO ())]+tests =+ ("staticDynamic", quickCheck =<< staticDynamic) :+ []
testsuite/Test/Synthesizer/LLVM/Packed.hs view
@@ -16,14 +16,13 @@ import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS import qualified Synthesizer.LLVM.Parameterized.Signal as SigP import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import Synthesizer.LLVM.Parameterized.Signal (($#), ) import Synthesizer.LLVM.CausalParameterized.Process (($*), ) import qualified Synthesizer.LLVM.Storable.Signal as SigStL import qualified Data.StorableVector.Lazy as SVL import Data.StorableVector.Lazy (ChunkSize, ) -import Control.Arrow ((^<<), (<<^), (<<<), )+import Control.Arrow (arr, (^<<), (<<^), (<<<), ) import Data.Word (Word32, ) @@ -168,23 +167,23 @@ limitPackedWord32 = SVL.take (div signalLength 4) -noise :: IO (ChunkSize -> () -> CheckEquality Word32)+noise :: IO (ChunkSize -> Word32 -> CheckEquality Word32) noise = checkEquality limitWord32- (SigP.noiseCore $# 0)- (SigP.noiseCoreAlt $# 0)+ (SigP.noiseCore (arr id))+ (SigP.noiseCoreAlt (arr id)) -noiseVector :: IO (ChunkSize -> () -> CheckEquality (Serial.Plain D4 Word32))+noiseVector :: IO (ChunkSize -> Word32 -> CheckEquality (Serial.Plain D4 Word32)) noiseVector = checkEquality limitPackedWord32- (SigPS.noiseCore $# 0)- (SigPS.noiseCoreAlt $# 0)+ (SigPS.noiseCore (arr id))+ (SigPS.noiseCoreAlt (arr id)) -noiseScalarVector :: IO (ChunkSize -> () -> CheckEquality (Serial.Plain D4 Word32))+noiseScalarVector :: IO (ChunkSize -> Word32 -> CheckEquality (Serial.Plain D4 Word32)) noiseScalarVector = checkEquality limitPackedWord32- (SigPS.noiseCore $# 0)- (SigPS.packSmall (SigP.noiseCore $# 0))+ (SigPS.noiseCore (arr id))+ (SigPS.packSmall (SigP.noiseCore (arr id))) tests :: [(String, IO ())]
+ testsuite/Test/Synthesizer/LLVM/RingBufferForward.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE Rank2Types #-}+module Test.Synthesizer.LLVM.RingBufferForward (tests) where++import qualified Synthesizer.LLVM.Parameter as Param+import qualified Synthesizer.LLVM.RingBufferForward as RingBuffer+import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import Synthesizer.LLVM.CausalParameterized.Process (($*), )++import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV+import Data.StorableVector.Lazy (ChunkSize, )++import Test.Synthesizer.LLVM.Utility+ (CheckEquality, checkEquality, rangeFromInt, )++import Control.Category ((<<<), )+import Control.Arrow (arr, (***), (^<<), (<<^), )+import Control.Applicative (pure, )+import Data.Tuple.HT (fst3, snd3, thd3, )++import qualified LLVM.Extra.Arithmetic as A++import qualified LLVM.Core as LLVM+import LLVM.Core (Value, )++import Foreign.Storable (Storable, )++import qualified System.Random as Rnd+import Data.Word (Word32, )++import Test.QuickCheck (quickCheck, )++import NumericPrelude.Numeric+import NumericPrelude.Base+++type EquFloat = CheckEquality Float++signalLength :: Int+signalLength = 10000+++limitFloat :: (Storable a) => SVL.Vector a -> SVL.Vector a+limitFloat = SVL.take signalLength+++trackId :: IO (ChunkSize -> (Int, Word32) -> EquFloat)+trackId =+ let bufferSize = rangeFromInt (1,1000) <<^ fst+ noise = SigP.noise (arr snd) 1+ in checkEquality limitFloat+ noise+ (CausalP.mapSimple (RingBuffer.index A.zero) $*+ RingBuffer.track bufferSize noise)++trackTail :: IO (ChunkSize -> (Int, Word32) -> EquFloat)+trackTail =+ let bufferSize = rangeFromInt (2,1000) <<^ fst+ noise = SigP.noise (arr snd) 1+ in checkEquality limitFloat+ (SigP.tail noise)+ (CausalP.mapSimple (RingBuffer.index A.one) $*+ RingBuffer.track bufferSize noise)++trackDrop :: IO (ChunkSize -> (Int, Word32) -> EquFloat)+trackDrop =+ let n = rangeFromInt (0,1000) <<^ fst+ noise = SigP.noise (arr snd) 1+ in checkEquality limitFloat+ (SigP.drop n noise)+ (CausalP.map RingBuffer.index (fmap (fromIntegral :: Int -> Word32) n) $*+ RingBuffer.track (fmap succ n) noise)++randomSkips :: Param.T p (Int, Int) -> SigP.T p (Value Word32)+randomSkips p =+ SigP.fromStorableVectorLazy+ ((\(len, seed) ->+ SVL.cycle $+ SVL.fromChunks+ [fst $ SV.packN len $ Rnd.randomRs (0,10::Word32) seed])+ ^<< rangeFromInt (1,100) *** arr Rnd.mkStdGen <<< p)++trackSkip :: IO (ChunkSize -> ((Int,Int), Word32) -> EquFloat)+trackSkip =+ let skips = randomSkips (arr fst)+ noise = SigP.noise (arr snd) 1+ in checkEquality limitFloat+ (CausalP.skip noise $* skips)+ (CausalP.mapSimple (RingBuffer.index A.one) $*+ (RingBuffer.trackSkip 1 noise $* skips))++trackSkip1 :: IO (ChunkSize -> (Int, Word32) -> EquFloat)+trackSkip1 =+ let bufferSize = 1000+ k = rangeFromInt (0, fromIntegral bufferSize-1 :: Word32) <<^ fst+ noise = SigP.noise (arr snd) 1+ in checkEquality limitFloat+ (CausalP.map RingBuffer.index k $*+ (RingBuffer.track (pure bufferSize) noise))+ (CausalP.map RingBuffer.index k $*+ (RingBuffer.trackSkip (pure bufferSize) noise $* 1))++trackSkipHold ::+ IO (ChunkSize -> ((Int,Int), Int, Word32) -> CheckEquality (Bool, Float))+trackSkipHold =+ let bufferSize = 1000+ skips = randomSkips (arr fst3)+ k = rangeFromInt (0, fromIntegral bufferSize-1 :: Word32) <<^ snd3+ noise = SigP.noise (arr thd3) 1+ in checkEquality limitFloat+ (fmap ((,) (LLVM.valueOf True)) $+ (CausalP.map RingBuffer.index k $*+ (RingBuffer.trackSkip (pure bufferSize) noise $* skips)))+ (CausalP.map+ (\ki ((b,_s),buf) -> fmap ((,) b) $ RingBuffer.index ki buf) k $*+ (RingBuffer.trackSkipHold (pure bufferSize) noise $* skips))++{-+To do:++test that trackSkipHold returns False forever after it has returned False once.+-}+++tests :: [(String, IO ())]+tests =+ ("trackId", quickCheck =<< trackId) :+ ("trackTail", quickCheck =<< trackTail) :+ ("trackDrop", quickCheck =<< trackDrop) :+ ("trackSkip", quickCheck =<< trackSkip) :+ ("trackSkip1", quickCheck =<< trackSkip1) :+ ("trackSkipHold", quickCheck =<< trackSkipHold) :+ []