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 import qualified Synthesizer.LLVM.Server.Option as Option import Synthesizer.LLVM.Server.CausalPacked.Arrange ((&+&), shortTime, controllerExponentialDim, ) import Synthesizer.LLVM.Server.CommonPacked (Vector, ) import Synthesizer.LLVM.Server.Common hiding (Instrument, ) import qualified Sound.ALSA.Sequencer.Event as Event -- import qualified Sound.ALSA.Sequencer.Connect as Connect import qualified Sound.ALSA.Sequencer.Address as Addr import qualified Synthesizer.MIDI.Generic as Gen 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 Sound.MIDI.Controller as Ctrl import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg import qualified Synthesizer.CausalIO.Gate as Gate import qualified Synthesizer.Zip as Zip import qualified Synthesizer.ALSA.CausalIO.Process as PAlsa import Synthesizer.MIDI.Storable (Instrument, ) 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 import qualified Synthesizer.LLVM.CausalParameterized.Functional as F import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Parameterized.Signal as SigP import qualified Synthesizer.LLVM.Storable.Process as CausalSt import qualified Synthesizer.LLVM.Storable.Signal as SigStL import qualified Synthesizer.LLVM.MIDI.BendModulation as BM import qualified Synthesizer.LLVM.Wave as Wave import Synthesizer.LLVM.CausalParameterized.Process (($*), ($<), ) import qualified Synthesizer.Generic.Cut as CutG import qualified Synthesizer.Storable.Cut as CutSt 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.TimeTime as EventListTT import qualified Data.EventList.Relative.TimeMixed as EventListTM import qualified Data.EventList.Relative.BodyTime as EventListBT import Control.Arrow ((<<<), (<<^), (^<<), arr, first, ) import Control.Category (id, ) import Control.Applicative (pure, liftA2, ) import Control.Monad (when, ) import Control.Monad.Trans.State (evalState, ) import qualified Data.Map as Map -- import qualified Numeric.NonNegative.Class as NonNeg import qualified Numeric.NonNegative.Wrapper as NonNegW -- import qualified Numeric.NonNegative.Chunky as NonNegChunky import qualified Number.DimensionTerm as DN import Data.Word (Word8, Word32, ) import Data.Int (Int32, ) import Foreign.Storable (Storable, ) import qualified System.IO as IO import Control.Exception (bracket, ) -- import NumericPrelude.Numeric (zero, round, (^?), ) import Prelude hiding (Real, round, break, id, ) sampleRate :: Option.SampleRate Real sampleRate = Option.SampleRate Option.defaultSampleRate {- | try to reproduce a space leak -} sequencePlain :: IO () sequencePlain = SVL.writeFile "/tmp/test.f32" $ -- print $ last $ SVL.chunks $ CutSt.arrange Option.defaultChunkSize $ evalState (Gen.sequence Option.defaultChannel (error "no sound" :: Instrument Real Real)) $ let evs = EventList.cons 10 ([]::[Event.T]) evs in evs -- see playFromEvents writeTest :: (CutG.Read t, Storable a) => PIO.T t (SV.Vector a) -> [t] -> IO () writeTest (PIO.Cons next create delete) evsChunky = IO.withFile "/tmp/test.f32" IO.WriteMode $ \h -> bracket create delete $ let loop evs s0 = case evs of [] -> return () chunk : rest -> do (pcm, s1) <- next chunk s0 SV.hPut h pcm when (CutG.length pcm >= CutG.length chunk) (loop rest s1) in loop evsChunky render :: IO () render = do ping <- Instr.pingRelease $/ 1 $/ 0.1 -- leaky -- ping <- Instr.ping -- not leaky writeTest (ping sampleRate 10 440) $ replicate 10000 $ Gate.chunk 512 Nothing sequenceEvents :: [PAlsa.Events] -> IO () sequenceEvents evs = do arrange <- CausalSt.makeArranger ping <- Instr.pingRelease $/ 1 $/ 0.1 -- leaky -- ping <- Instr.ping -- not leaky let proc = arrange <<< arr shortTime <<< MIO.sequenceCore Option.defaultChannel (\ _pgm -> ping sampleRate) writeTest proc evs sequenceNothing :: IO () sequenceNothing = sequenceEvents $ let evs = EventList.cons 10 [] evs in chopEvents 512 $ EventListTM.takeTime (10^(7::Int)) evs noteEvent :: Event.NoteEv -> Word8 -> Word8 -> Word8 -> Event.T noteEvent mode chan pitch velocity = -- Event.simple (Connect.toSubscribers Addr.subscribers) $ Event.simple Addr.subscribers $ Event.NoteEv mode $ Event.simpleNote (Event.Channel $ fromIntegral chan) (Event.Pitch $ fromIntegral pitch) (Event.Velocity $ fromIntegral velocity) ctrlEvent :: Word8 -> Word32 -> Int32 -> Event.T ctrlEvent chan cc cval = -- Event.simple (Connect.toSubscribers Addr.subscribers) $ Event.simple Addr.subscribers $ Event.CtrlEv Event.Controller $ Event.Ctrl (Event.Channel $ fromIntegral chan) (Event.Parameter $ fromIntegral cc) (Event.Value $ fromIntegral cval) sequenceSingleLong :: IO () sequenceSingleLong = do sequenceEvents $ let evs = EventList.cons 10 [] evs in chopEvents 512 $ EventListTM.takeTime (10^(7::Int)) $ EventList.cons 0 [noteEvent Event.NoteOn 0 60 64] evs sequenceSingleShort :: IO () sequenceSingleShort = do sequenceEvents $ let evs = EventList.cons 10 [] evs in chopEvents 512 $ EventListTM.takeTime (10^(7::Int)) $ EventList.cons 0 [noteEvent Event.NoteOn 0 60 64] $ EventList.cons 10 [noteEvent Event.NoteOff 0 60 64] evs {- Although it consumes constant memory, the memory usage is quite high, e.g. 40MB for chunk size 100000 and peiod 1100. This might be caused by the large overlapping in the release phases. You need only 6MB heap for the same chunksize and period 11000. -} sequenceLoop :: IO () sequenceLoop = do sequenceEvents $ let evs = EventList.cons 11001 [noteEvent Event.NoteOff 0 60 50, noteEvent Event.NoteOn 0 60 50] evs in chopEvents 100000 $ EventListTM.takeTime (10^(7::Int)) $ EventList.cons 0 [noteEvent Event.NoteOn 0 60 50] evs sequenceStaccato :: IO () sequenceStaccato = do sequenceEvents $ let evs = EventList.cons 551 [noteEvent Event.NoteOff 0 60 50] $ EventList.cons 550 [noteEvent Event.NoteOn 0 60 50] evs in chopEvents 100000 $ EventListTM.takeTime (10^(7::Int)) $ EventList.cons 0 [noteEvent Event.NoteOn 0 60 50] evs sequenceControlledEvents :: [PAlsa.Events] -> IO () sequenceControlledEvents chunkedEvents = do opt <- Option.get arrange <- CausalSt.makeArranger amp <- CausalP.processIO (CausalP.mapSimple StereoInt.interleave <<< CausalP.envelopeStereo <<< first (CausalP.mapSimple Serial.upsample)) ping <- Instr.pingStereoReleaseFM 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) frequencyControlPercussive = MCS.controllerLinear controllerDetune (0,0.005) 0.001 &+& MCS.bendWheelPressure 2 0.04 0.03 pingProc vel freq = ping sampleRate vel freq <<< Zip.arrowSecond (timeControlPercussive &+& ((MCS.controllerExponential controllerTimbre0 (0.3,10) 0.05 &+& controllerExponentialDim controllerTimbre1 (DN.time 0.01, DN.time 10) (DN.time 5)) &+& ((MCS.controllerLinear Ctrl.soundController5 (0,10) 2 &+& controllerExponentialDim Ctrl.soundController7 (DN.time 0.03, DN.time 1) (DN.time 0.5)) &+& frequencyControlPercussive))) let proc = arr SigStL.unpackStereoStrict <<< amp () <<< (MCS.controllerExponential controllerVolume (0.001, 1) (0.2::Float) <<^ Zip.second) &+& (arrange <<< arr shortTime <<< MIO.sequenceModulated (Option.channel opt) (\ _pgm -> pingProc)) <<< id &+& MCS.fromChannel (Option.channel opt) writeTest proc chunkedEvents sequenceControlled :: IO () sequenceControlled = sequenceControlledEvents $ let evs = EventList.cons 10 [] evs in chopEvents 512 $ EventListTM.takeTime (10^(7::Int)) $ EventList.cons 0 [noteEvent Event.NoteOn 0 60 64] evs sequenceControlledModulated :: IO () sequenceControlledModulated = sequenceControlledEvents $ chopEvents 512 $ EventListTM.takeTime (10^(7::Int)) $ EventList.cons 0 [noteEvent Event.NoteOn 0 60 64] $ EventList.fromPairList $ map (\ev -> (10,[ev])) $ cycle $ 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 amp <- CausalP.processIO (CausalP.mapSimple StereoInt.interleave) tomatoSmps <- makeSampledSounds opt let tomato smp vel freq = smp sampleRate vel freq <<< Zip.arrowSecond (MCS.controllerLinear controllerDetune (0,0.005) 0.001 &+& MCS.bendWheelPressure 2 0.04 0.03) writeTest (arr SigStL.unpackStereoStrict <<< amp () <<< tomato (last tomatoSmps) 0 440) $ map (\m -> Zip.consChecked "Test.sampledSound" (Gate.chunk 512 m) (PCS.Cons Map.empty (EventListTT.pause 512))) $ replicate 10 Nothing ++ 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 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 <- liftA2 map Instr.sampledSoundMono $ Sample.loadRanges (Option.sampleDirectory opt) Sample.tomatensalat let tomato smp vel freq = smp sampleRate vel freq <<< Zip.arrowSecond (MCS.bendWheelPressure 2 0.04 0.03) writeTest (tomato (last tomatoSmps) 0 220) $ map (\m -> Zip.consChecked "Test.sampledSound" (Gate.chunk 512 m) (PCS.Cons Map.empty (EventListTT.pause 512))) $ replicate 10 Nothing ++ Just (256, VoiceMsg.normalVelocity) : replicate 10 Nothing {- This one crashes sometimes in LLVM-3.0 when optimizations are enabled. -} sampledSoundCrash :: IO () sampledSoundCrash = do opt <- Option.get amp <- CausalP.processIO (CausalP.mapSimple StereoInt.interleave) tomatoSmps <- makeSampledSounds opt let tomato smp vel freq = smp sampleRate vel freq <<< Zip.arrowSecond (MCS.controllerLinear controllerDetune (0,0.005) 0.001 &+& MCS.bendWheelPressure 2 0.04 0.03) writeTest (arr SigStL.unpackStereoStrict <<< amp () <<< tomato (head tomatoSmps) 0 440) $ map (\m -> Zip.consChecked "Test.sampledSound" (Gate.chunk 512 m) (PCS.Cons Map.empty (EventListTT.pause 512))) $ replicate 10 Nothing ++ Just (100, VoiceMsg.normalVelocity) : replicate 10 Nothing lfo :: SVL.Vector Real lfo = SigP.renderChunky (SVL.chunkSize 512) (1 + 0.1 * SigP.osciSimple Wave.approxSine2 (pure (0::Float)) 0.0001) () asMono :: vector Real -> vector Real asMono = id frequencyModulation :: IO () frequencyModulation = do opt <- Option.get smp <- loadTomato opt SVL.writeFile "/tmp/test.f32" . asMono . (\f -> f smp lfo) =<< CausalP.runStorableChunky (CausalP.frequencyModulationLinear $ SigP.fromStorableVectorLazy id) frequencyModulationIO :: IO () frequencyModulationIO = do opt <- Option.get smp <- loadTomato opt proc <- CausalP.processIO (CausalP.frequencyModulationLinear $ SigP.fromStorableVectorLazy id) writeTest (proc smp :: PIO.T (SV.Vector Real) (SV.Vector Real)) $ SVL.chunks lfo frequencyModulationStrictIO :: IO () frequencyModulationStrictIO = do opt <- Option.get smp <- loadTomato opt proc <- CausalP.processIO (CausalP.frequencyModulationLinear $ SigP.fromStorableVector id) writeTest (proc (SV.concat $ SVL.chunks smp) :: PIO.T (SV.Vector Real) (SV.Vector Real)) $ SVL.chunks lfo frequencyModulationSawIO :: IO () frequencyModulationSawIO = do proc <- CausalP.processIO (CausalP.frequencyModulationLinear (CausalP.take 50000 $* SigP.osciSaw 0 id)) writeTest (proc (0.01::Real) :: PIO.T (SV.Vector Real) (SV.Vector Real)) $ SVL.chunks lfo envelopeIO :: IO () envelopeIO = do opt <- Option.get smp <- loadTomato opt proc <- CausalP.processIO (CausalP.envelope $< SigP.fromStorableVectorLazy id) writeTest (proc smp :: PIO.T (SV.Vector Real) (SV.Vector Real)) $ SVL.chunks lfo functional :: IO () functional = do phaser <- CausalP.processIO $ F.withArgs $ \ratio -> let freq = frequency id noise = F.fromSignal $ SigP.noise 12 (recip freq) in (1-ratio) * noise + ratio * (CausalP.delayZero 100 F.$& noise) writeTest (phaser (sampleRate, 200000) :: PIO.T (EventListBT.T NonNegW.Int Float) (SV.Vector Float)) $ map (\y -> EventListBT.singleton y 10000) [0, 0.25, 0.5, 0.75, 1.00] functionalPlug :: IO () functionalPlug = do phaser <- FP.withArgs $ \ratio0 -> let freq = frequency id ratio = FP.plug ratio0 noise = FP.fromSignal $ SigP.noise 12 (recip freq) in (1-ratio) * noise + ratio * (CausalP.delayZero 100 FP.$& noise) writeTest (phaser () (sampleRate, 200000) :: PIO.T (EventListBT.T NonNegW.Int Float) (SV.Vector Float)) $ map (\y -> EventListBT.singleton y 10000) [0, 0.25, 0.5, 0.75, 1.00] makeUnpackStereoStrict :: IO (PIO.T (SV.Vector (Stereo.T Vector)) (SV.Vector (Stereo.T Real))) makeUnpackStereoStrict = fmap (\proc -> SigStL.unpackStereoStrict ^<< proc ()) $ CausalP.processIO (CausalP.mapSimple StereoInt.interleave) {- makeUnpackStereoStrict :: IO (SV.Vector (Stereo.T Vector) -> SV.Vector (Stereo.T Real)) makeUnpackStereoStrict = 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 writeTest (unpack <<< ping sampleRate 0 440) $ replicate 100 functionalTineControl functionalPlugTine :: IO () functionalPlugTine = do ping <- InstrFP.tineStereoFM unpack <- makeUnpackStereoStrict writeTest (unpack <<< ping sampleRate 0 440) $ 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 (EventListBT.singleton (DN.time 0.5) cs) (EventListBT.singleton (DN.time 1) cs)) (Zip.Cons (EventListBT.singleton 10 cs) (Zip.Cons (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