synthesizer-llvm-0.5: alsa/Synthesizer/LLVM/Server/CausalPacked/Test.hs
module Synthesizer.LLVM.Server.CausalPacked.Test where
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.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, )
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]
sampledSound :: IO ()
sampledSound = do
opt <- Option.get
amp <-
CausalP.processIO
(CausalP.mapSimple StereoInt.interleave)
tomatoSmps <-
Instr.makeSampledSounds (Option.sampleDirectory opt) Sample.tomatensalat
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
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
(_attack, _sustain, release) ->
SVL.writeFile "/tmp/release.f32" release
tomatoSmps <-
Instr.makeSampledSoundsMono (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 <-
Instr.makeSampledSounds (Option.sampleDirectory opt) Sample.tomatensalat
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 <-
case Sample.tomatensalat of
(name, _positions, _period) ->
Sample.load (Option.sampleDirectory opt ++ "/" ++ name)
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 <-
case Sample.tomatensalat of
(name, _positions, _period) ->
Sample.load (Option.sampleDirectory opt ++ "/" ++ name)
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 <-
case Sample.tomatensalat of
(name, _positions, _period) ->
Sample.load (Option.sampleDirectory opt ++ "/" ++ name)
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 <-
case Sample.tomatensalat of
(name, _positions, _period) ->
Sample.load (Option.sampleDirectory opt ++ "/" ++ name)
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.lift $ CausalP.fromSignal $
SigP.noise 12 (recip freq)
in (1-ratio) * noise +
ratio * (CausalP.delay (pure (0::Float)) 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.delay (pure (0::Float)) 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
-}
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))))
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)
(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))))