module Synthesizer.LLVM.Server.Packed.Test where import qualified Synthesizer.LLVM.Server.Packed.Instrument as Instr import qualified Synthesizer.LLVM.Server.Default as Default import qualified Synthesizer.LLVM.Server.SampledSound as Sample import Synthesizer.LLVM.Server.ALSA (makeNote) import Synthesizer.LLVM.Server.CommonPacked (Vector, vectorSize) import Synthesizer.LLVM.Server.Common hiding (Instrument) import qualified Sound.ALSA.Sequencer.Event as Event import qualified Synthesizer.MIDI.PiecewiseConstant as PC import qualified Synthesizer.MIDI.Generic as Gen import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import qualified Synthesizer.ALSA.Storable.Play as Play import Synthesizer.MIDI.Storable (Instrument, chunkSizesFromLazyTime) import qualified Synthesizer.LLVM.MIDI.BendModulation as BM import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Parameterized.Signal as SigP import qualified Synthesizer.LLVM.Storable.Signal as SigStL import Synthesizer.LLVM.CausalParameterized.Process (($*)) import qualified Synthesizer.Storable.Cut as CutSt import qualified Synthesizer.Storable.Signal as SigSt import qualified Data.StorableVector.Lazy.Pattern as SVP import qualified Data.StorableVector.Lazy as SVL import qualified Data.EventList.Relative.TimeBody as EventList import qualified Data.EventList.Relative.BodyTime as EventListBT import Control.Arrow ((<<<), arr) import Control.Applicative (pure, liftA, liftA2) import Control.Monad.Trans.State (evalState) import qualified Numeric.NonNegative.Wrapper as NonNegW import qualified Numeric.NonNegative.Chunky as NonNegChunky import Algebra.IntegralDomain (divUp) import qualified Number.DimensionTerm as DN import Prelude hiding (Real, round, break) chunkSize :: SVL.ChunkSize chunkSize = Play.defaultChunkSize vectorChunkSize :: SVL.ChunkSize vectorChunkSize = case chunkSize of SVL.ChunkSize size -> SVL.ChunkSize (divUp size vectorSize) sampleRatePlain :: Num a => a sampleRatePlain = case Default.sampleRate of SampleRate r -> r sampleRate :: SampleRate Real sampleRate = Default.sampleRate emptyEvents :: time -> EventList.T time [Event.T] emptyEvents t = let evs = EventList.cons t [] evs in evs {- | try to reproduce a space leak -} sequencePlain :: IO () sequencePlain = SVL.writeFile "test.f32" $ -- print $ last $ SVL.chunks $ CutSt.arrange chunkSize $ evalState (Gen.sequence Default.channel (error "no sound" :: Instrument Real Real)) $ emptyEvents 10 sequenceLLVM :: IO () sequenceLLVM = do arrange <- SigStL.makeArranger SVL.writeFile "test.f32" $ -- print $ last $ SVL.chunks $ arrange vectorChunkSize $ evalState (Gen.sequence Default.channel (error "no sound" :: Instrument Real Vector)) $ emptyEvents 10 sequencePitchBendCycle :: IO () sequencePitchBendCycle = do arrange <- SigStL.makeArranger SVL.writeFile "test.f32" $ arrange vectorChunkSize $ evalState (let -- fm = error "undefined pitch bend" fm = EventListBT.cons 1 10 fm in Gen.sequenceModulated fm Default.channel (error "no sound" :: PC.T Real -> Instrument Real Vector)) $ emptyEvents 10 sequencePitchBendSimple :: IO () sequencePitchBendSimple = do arrange <- SigStL.makeArranger SVL.writeFile "test.f32" $ arrange vectorChunkSize $ evalState (let fm y = EventListBT.cons y 10 (fm (2-y)) in Gen.sequenceModulated (fm 1) Default.channel (error "no sound" :: PC.T Real -> Instrument Real Vector)) $ emptyEvents 10 sequencePitchBend :: IO () sequencePitchBend = do arrange <- SigStL.makeArranger SVL.writeFile "test.f32" $ arrange vectorChunkSize $ evalState (do fm <- PC.pitchBend Default.channel 2 0.01 Gen.sequenceModulated fm Default.channel (error "no sound" :: PC.T Real -> Instrument Real Vector)) $ emptyEvents 10 sequenceModulated :: IO () sequenceModulated = do arrange <- SigStL.makeArranger SVL.writeFile "test.f32" $ arrange vectorChunkSize $ evalState (do fm <- PC.bendWheelPressure Default.channel 2 0.04 0.03 Gen.sequenceModulated fm Default.channel (error "no sound" :: PC.T (BM.T Real) -> Instrument Real Vector)) $ emptyEvents 10 sequenceModulatedLong :: IO () sequenceModulatedLong = do arrange <- SigStL.makeArranger -- sound <- Instr.softStringReleaseEnvelope $/ sampleRate sound <- Instr.softString $/ sampleRate -- space leak -- sound <- Instr.pingReleaseEnvelope $/ 1 $/ sampleRate -- no space leak -- sound <- Instr.pingRelease $/ 1 $/ 1 $/ sampleRate -- no space leak SVL.writeFile "test.f32" $ arrange vectorChunkSize $ evalState (Gen.sequence Default.channel sound) $ let evs t = EventList.cons t [] (evs (20-t)) in EventList.cons 10 [makeNote Event.NoteOn 60] $ EventList.cons 10 [makeNote Event.NoteOn 64] $ evs 10 sequenceModulatedLongFM :: IO () sequenceModulatedLongFM = do arrange <- SigStL.makeArranger sound <- Instr.softStringFM SVL.writeFile "test.f32" $ arrange vectorChunkSize $ evalState (do fm <- PC.bendWheelPressure Default.channel 2 0.04 0.03 Gen.sequenceModulated fm Default.channel (\fmlocal -> sound fmlocal $ sampleRate)) $ let evs t = EventList.cons t [] (evs (20-t)) in EventList.cons 10 [makeNote Event.NoteOn 60] $ EventList.cons 10 [makeNote Event.NoteOn 64] $ evs 10 sequenceModulatedRepeat :: IO () sequenceModulatedRepeat = do arrange <- SigStL.makeArranger sound <- Instr.softStringFM SVL.writeFile "test.f32" $ arrange vectorChunkSize $ evalState (do fm <- PC.bendWheelPressure Default.channel 2 0.04 0.03 Gen.sequenceModulated fm Default.channel (\fmlocal -> sound fmlocal $ sampleRate)) $ let evs t = EventList.cons t [makeNote Event.NoteOn 60] $ EventList.cons t [makeNote Event.NoteOff 60] $ evs (20-t) in evs 10 sequencePress :: IO () sequencePress = do arrange <- SigStL.makeArranger -- sound <- Instr.softString $/ sampleRate -- sound <- Instr.softStringReleaseEnvelope $/ sampleRate sound <- Instr.pingReleaseEnvelope $/ 1 $/ 1 $/ vectorChunkSize $/ sampleRate SVL.writeFile "test.f32" $ arrange vectorChunkSize $ evalState (Gen.sequence Default.channel (\ _freq -> sound)) $ let evs t = EventList.cons t [makeNote Event.NoteOn 60] $ EventList.cons t [makeNote Event.NoteOff 60] $ evs (20-t) in evs 10 sampledSoundTest0 :: IO (Sample.T -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) sampledSoundTest0 = liftA (\osc smp _fm _vel _freq _dur -> osc chunkSize (Sample.body smp)) (SigP.runChunky (let smp = arr id in fmap (\x -> Stereo.cons x x) $ SigPS.pack $ SigP.fromStorableVectorLazy smp)) sampledSoundTest1 :: IO (Sample.T -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) sampledSoundTest1 = liftA (\osc smp _fm _vel _freq _dur -> osc chunkSize (Sample.body smp)) (SigP.runChunky (let smp = arr id in CausalP.stereoFromMono (CausalPS.pack (CausalP.frequencyModulationLinear (SigP.fromStorableVectorLazy smp))) $* liftA2 Stereo.cons (SigPS.constant 0.999) (SigPS.constant 1.001))) -- $* (SigPS.constant $# Stereo.cons 0.999 1.001))) sampledSoundTest2 :: IO (Sample.T -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) sampledSoundTest2 = liftA (\osc smp fm _vel freq dur -> let pos = Sample.positions smp body = SigSt.take (Sample.length pos) $ SigSt.drop (Sample.start pos) $ Sample.body smp in SVP.take (chunkSizesFromLazyTime dur) $ osc chunkSize (sampleRate, (body, (fm, freq * Sample.period pos)))) (SigP.runChunky (let smp = signal fst fm = Instr.modulation snd in (CausalP.stereoFromMono (CausalPS.pack (CausalP.frequencyModulationLinear (SigP.fromStorableVectorLazy smp))) <<< liftA2 Stereo.cons (CausalPS.amplify 0.999) (CausalPS.amplify 1.001)) $* Instr.frequencyFromBendModulation (frequencyConst 3) fm)) sampledSoundTest3SpaceLeak :: IO (Sample.T -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) sampledSoundTest3SpaceLeak = liftA (\osc smp _fm vel freq dur -> {- 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 (sustainFM, releaseFM) = SVP.splitAt (chunkSizesFromLazyTime dur) $ (SigSt.repeat chunkSize (Serial.replicate (freq*Sample.period pos/sampleRatePlain)) :: SigSt.T Vector) pos = Sample.positions smp amp = 2 * amplitudeFromVelocity vel (attack, sustain, release) = Sample.parts smp in osc (amp, attack `SigSt.append` SVL.cycle (SigSt.take (Sample.loopLength pos) sustain)) sustainFM `SigSt.append` osc (amp,release) releaseFM) (CausalP.runStorableChunky (let smp = arr snd amp = arr fst in CausalPS.amplifyStereo amp <<< CausalP.stereoFromMono (CausalPS.pack (CausalP.frequencyModulationLinear (SigP.fromStorableVectorLazy smp))) <<< liftA2 Stereo.cons (CausalPS.amplify 0.999) (CausalPS.amplify 1.001))) sampledSoundTest4NoSpaceLeak :: IO (Sample.T -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) sampledSoundTest4NoSpaceLeak = liftA (\freqMod smp fm _vel freq dur -> {- 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 (sustainFM, releaseFM) = SVP.splitAt (chunkSizesFromLazyTime dur) $ (freqMod (chunkSizesFromLazyTime (PC.duration fm)) (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)) (SigP.runChunkyPattern (Instr.frequencyFromBendModulation (frequencyConst 3) (Instr.modulation id))) sampledSoundTest5LargeSpaceLeak :: IO (Sample.T -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) sampledSoundTest5LargeSpaceLeak = liftA2 (\osc freqMod smp fm vel freq dur -> {- 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 (sustainFM, releaseFM) = SVP.splitAt (chunkSizesFromLazyTime dur) $ (freqMod (chunkSizesFromLazyTime (PC.duration fm)) (sampleRate, (fm, freq*Sample.period pos)) :: SigSt.T Vector) pos = Sample.positions smp amp = 2 * amplitudeFromVelocity vel (attack, sustain, release) = Sample.parts smp in osc (amp, attack `SigSt.append` SVL.cycle (SigSt.take (Sample.loopLength pos) sustain)) sustainFM `SigSt.append` osc (amp,release) releaseFM) (CausalP.runStorableChunky (arr (\x -> Stereo.cons x x))) (SigP.runChunkyPattern (Instr.frequencyFromBendModulation (frequencyConst 3) (Instr.modulation id))) sampledSoundSmallSpaceLeak4 :: IO (Sample.T -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) sampledSoundSmallSpaceLeak4 = liftA (\osc smp _fm _vel freq dur -> let (sustainFM, releaseFM) = SVP.splitAt (chunkSizesFromLazyTime dur) $ (SigSt.repeat chunkSize (Serial.replicate (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) (CausalP.runStorableChunky (arr (\x -> Stereo.cons x x))) sampledSoundSmallSpaceLeak4a :: IO (Sample.T -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) sampledSoundSmallSpaceLeak4a = liftA (\osc smp _fm _vel freq dur -> case SVP.splitAt (chunkSizesFromLazyTime dur) $ (SigSt.repeat chunkSize (Serial.replicate (freq*Sample.period (Sample.positions smp) / sampleRatePlain)) :: SigSt.T Vector) of (sustainFM, releaseFM) -> osc () sustainFM `SigSt.append` SigSt.map (\x -> Stereo.cons x x) releaseFM) (CausalP.runStorableChunky (arr (\x -> Stereo.cons x x))) sampledSoundNoSmallSpaceLeak3 :: IO (Sample.T -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) sampledSoundNoSmallSpaceLeak3 = pure (\smp _fm _vel freq dur -> let (sustainFM, releaseFM) = SVP.splitAt (chunkSizesFromLazyTime dur) $ (SigSt.repeat chunkSize (Serial.replicate (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) {-# NOINLINE amplifySVL #-} amplifySVL :: SVL.Vector Vector -> SVL.Vector Vector amplifySVL = SigSt.map (2*) sampledSoundNoSmallSpaceLeak2 :: IO (Sample.T -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) sampledSoundNoSmallSpaceLeak2 = liftA (\osc smp _fm _vel freq dur -> let (sustainFM, releaseFM) = SVP.splitAt (chunkSizesFromLazyTime dur) $ (SigSt.repeat chunkSize (Serial.replicate (freq*Sample.period pos/sampleRatePlain)) :: SigSt.T Vector) pos = Sample.positions smp in osc () (amplifySVL sustainFM `SigSt.append` amplifySVL releaseFM)) (CausalP.runStorableChunky (arr (\x -> Stereo.cons x x))) sampledSoundSmallSpaceLeak1 :: IO (Sample.T -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) sampledSoundSmallSpaceLeak1 = liftA (\osc smp _fm _vel freq dur -> let (sustainFM, releaseFM) = SVP.splitAt (chunkSizesFromLazyTime dur) $ (SigSt.repeat chunkSize (Serial.replicate (freq*Sample.period pos/sampleRatePlain)) :: SigSt.T Vector) pos = Sample.positions smp in osc () sustainFM `SigSt.append` osc () releaseFM) (CausalP.runStorableChunky (arr (\x -> Stereo.cons x x))) sampledSoundSmallSpaceLeak0 :: IO (Sample.T -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) sampledSoundSmallSpaceLeak0 = liftA (\osc smp _fm vel freq dur -> {- 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 (sustainFM, releaseFM) = SVP.splitAt (chunkSizesFromLazyTime dur) $ (SigSt.repeat chunkSize (Serial.replicate (freq*Sample.period pos/sampleRatePlain)) :: SigSt.T Vector) pos = Sample.positions smp amp = 2 * amplitudeFromVelocity vel (attack, sustain, release) = Sample.parts smp in osc (amp, attack `SigSt.append` SVL.cycle (SigSt.take (Sample.loopLength pos) sustain)) sustainFM `SigSt.append` osc (amp,release) releaseFM) (CausalP.runStorableChunky (arr (\x -> Stereo.cons x x))) makeSample :: Int -> Sample.T makeSample size = Sample.Cons (SigSt.replicate chunkSize size 0) (DN.frequency 44100) (Sample.Positions 0 100000 50000 50000 100) sequenceSample :: IO () sequenceSample = do arrange <- SigStL.makeArranger sampler <- sampledSoundTest2 let sound = sampler $ makeSample 100000 SVL.writeFile "test.f32" $ arrange vectorChunkSize $ evalState (do fm <- PC.bendWheelPressure Default.channel 2 0.04 0.03 Gen.sequenceModulated fm Default.channel sound) $ let evs t = EventList.cons t [] (evs (20-t)) in EventList.cons 10 [makeNote Event.NoteOn 60] $ evs 10 {- sequenceSample1 :: IO () sequenceSample1 = do sampler <- Instr.sampledSound let sound = sampler (SampledSound (SigSt.replicate chunkSize 100000 0) (SamplePositions 0 100000 50000 50000) 100) SVL.writeFile "test.f32" $ sound {- (let evs f = EventListBT.cons (BM.Cons 0.001 f) 10 (evs (0.02-f)) in evs 0.01) -} (let evs t = EventListBT.cons (BM.Cons 0.01 0.001) t (evs (20-t)) in evs 10) {- (PCS.Cons (Map.singleton (PC.Controller VoiceMsg.modulation) 1) (let evs t = EventList.cons t [] (evs (20-t)) in EventListMT.consTime 10 $ evs 10)) -} 0.01 1 -- (NonNegChunky.fromChunks $ repeat $ NonNegW.fromNumber 10) (NonNegChunky.fromChunks $ map NonNegW.fromNumber $ iterate (20-) 10) -} sequenceSample1 :: IO () sequenceSample1 = do sampler <- sampledSoundSmallSpaceLeak4a let sound = sampler $ makeSample 100000 SVL.writeFile "test.f32" $ sound (let evs = EventListBT.cons (BM.Cons 0.01 0.001) 1 evs in evs) 0.01 1 (NonNegChunky.fromChunks $ repeat $ NonNegW.fromNumber 10) {- sequenceSample1a :: IO () sequenceSample1a = do {- makeStereoLLVM <- CausalP.runStorableChunky2 -- NoSpaceLeak (arr (\x -> Stereo.cons x x)) let stereoLLVM = makeStereoLLVM () -} stereoLLVM <- CausalP.runStorableChunky3 let stereoPlain = SigSt.map (\x -> Stereo.cons x x) SVL.writeFile "test.f32" $ let dur = NonNegChunky.fromChunks $ repeat $ SVL.chunkSize 10 !(sustainFM, releaseFM) = SVP.splitAt dur $ (SigSt.repeat chunkSize (Serial.replicate 1) :: SigSt.T Vector) in case 3::Int of -- no leak 0 -> stereoLLVM $ sustainFM `SigSt.append` releaseFM -- no leak 1 -> stereoPlain $ sustainFM `SigSt.append` releaseFM -- no leak 2 -> stereoPlain sustainFM `SigSt.append` stereoPlain releaseFM -- leak 3 -> stereoLLVM sustainFM `SigSt.append` stereoPlain releaseFM -- no leak 4 -> stereoPlain sustainFM `SigSt.append` stereoLLVM releaseFM -- leak 5 -> stereoLLVM sustainFM `SigSt.append` stereoLLVM releaseFM -} sequenceSample2 :: IO () sequenceSample2 = do arrange <- SigStL.makeArranger sampler <- sampledSoundTest2 let sound = sampler $ makeSample 100000 SVL.writeFile "test.f32" $ arrange vectorChunkSize $ evalState (do bend <- PC.pitchBend Default.channel 2 0.01 let fm = fmap (\t -> BM.Cons t t) bend Gen.sequenceModulated fm Default.channel sound) $ let evs t = EventList.cons t [] (evs (20-t)) in EventList.cons 10 [makeNote Event.NoteOn 60] $ evs 10 {- Interestingly, when the program aborts because of heap exhaustion, then the generated file has size 137MB independent of the heap size (I tried sizes from 1MB to 64MB). -} sequenceSample3 :: IO () sequenceSample3 = do arrange <- SigStL.makeArranger sampler <- sampledSoundTest2 let sound = sampler $ makeSample 100000 SVL.writeFile "test.f32" $ arrange vectorChunkSize $ evalState (let evs = EventListBT.cons (BM.Cons 0.01 0.001) 10 evs in Gen.sequence Default.channel (sound evs)) $ let evs = EventList.cons 10 [] evs in EventList.cons 10 [makeNote Event.NoteOn 60] evs sequenceSample4 :: IO () sequenceSample4 = do arrange <- SigStL.makeArranger sampler <- Instr.sampledSound -- sampler <- sampledSoundTest2 let sound = sampler $ makeSample 100000 SVL.writeFile "test.f32" $ arrange vectorChunkSize $ evalState (let evs = EventListBT.cons (BM.Cons 0.01 0.001) 10 evs in Gen.sequenceCore Default.channel Gen.errorNoProgram (Gen.Modulator () return (return . Gen.renderInstrumentIgnoreProgram (sound evs sampleRate)))) $ let evs = EventList.cons 10 [] evs in EventList.cons 10 [makeNote Event.NoteOn 60] evs sequenceFM1 :: IO () sequenceFM1 = do arrange <- SigStL.makeArranger sound <- Instr.softStringFM $/ let evs = EventListBT.cons (BM.Cons 0.01 0.001) 10 evs in evs -- sound <- Instr.softStringReleaseEnvelope SVL.writeFile "test.f32" $ arrange vectorChunkSize $ evalState (Gen.sequenceCore Default.channel Gen.errorNoProgram (Gen.Modulator () return (return . Gen.renderInstrumentIgnoreProgram (sound sampleRate)))) $ let evs = EventList.cons 10 [] evs in EventList.cons 10 [makeNote Event.NoteOn 60] evs {- sound 0.01 1 (NonNegChunky.fromChunks $ map NonNegW.fromNumber $ iterate (20-) 10) -} adsr :: IO () adsr = do env <- Instr.adsr SVL.writeFile "adsr.f32" $ env 0.2 2 0.15 0.3 0.5 vectorChunkSize sampleRate (-0.5) 88200 constCtrl :: a -> PC.T a constCtrl x = let xs = EventListBT.cons x 10000 xs in xs bellNoiseStereoTest :: IO () bellNoiseStereoTest = do str <- Instr.bellNoiseStereoFM SVL.writeFile "bellnoise.f32" $ str 0.3 0.1 (constCtrl 0.3) (constCtrl 100) vectorChunkSize (constCtrl (BM.Cons 1 0.01)) sampleRate 0 440 100000