synthesizer-llvm-0.3: src/Synthesizer/LLVM/Server/CausalPacked/Test.hs
module Synthesizer.LLVM.Server.CausalPacked.Test where
import qualified Synthesizer.LLVM.Server.CausalPacked.Instrument as Instr
import qualified Synthesizer.LLVM.Server.CausalPacked.Run as Run
import qualified Synthesizer.LLVM.Server.Packed.Instrument as InstrP
import qualified Synthesizer.LLVM.Server.Option as Option
import Synthesizer.LLVM.Server.Packed.Instrument
(vectorSize, )
import Synthesizer.LLVM.Server.Packed.Run
(controllerVolume, controllerDetune,
controllerTimbre0, controllerTimbre1, )
import Synthesizer.LLVM.Server.CausalPacked.Run ((&+&), )
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.Generic.ALSA.MIDI as Gen
import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt
import qualified Sound.MIDI.Controller as Ctrl
import qualified Synthesizer.CausalIO.Gate as Gate
import qualified Synthesizer.Zip as Zip
import qualified Synthesizer.Storable.ALSA.Play as Play
import Synthesizer.Storable.ALSA.MIDI (Instrument, )
import qualified Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet as PCS
import qualified Synthesizer.CausalIO.ALSA.MIDIControllerSet as MCS
import qualified Synthesizer.CausalIO.ALSA.Process as PAlsa
import qualified Synthesizer.CausalIO.Process as PIO
import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP
import qualified Synthesizer.LLVM.Storable.Process as CausalSt
import qualified Synthesizer.LLVM.Storable.Signal as SigStL
import qualified LLVM.Extra.ScalarOrVector as SoV
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 Control.Arrow ((<<<), (<<^), arr, first, )
import Control.Category (id, )
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 Algebra.IntegralDomain (divUp, )
{-
import qualified Algebra.RealRing as RealRing
import qualified Algebra.Additive as Additive
-}
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, )
vectorChunkSize :: SVL.ChunkSize
vectorChunkSize =
case Play.defaultChunkSize of
SVL.ChunkSize size ->
SVL.ChunkSize (divUp size vectorSize)
sampleRatePlain :: Num a => a
sampleRatePlain = Option.defaultSampleRate
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 [] evs
in evs
chopEvents ::
(NonNeg.C time, Num time) =>
time ->
EventListTT.T time body ->
[EventListTT.T time body]
chopEvents chunkSize =
let go evs =
let (chunk,rest) = EventListTT.splitAtTime chunkSize evs
in if EventListTT.duration chunk == 0
then []
else chunk : go rest
in go
-- see playFromEvents
writeTest ::
(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
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 (EventListTT.mapTime
(NonNegW.fromNumberUnsafe . fromInteger . NonNegW.toNumber))
<<<
PAlsa.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 chan pitch 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 chan cc 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 SoV.replicate))
ping <- Instr.pingStereoReleaseFM
let timeControlPercussive =
Run.controllerExponentialDim Ctrl.attackTime
(DN.time 0.1, DN.time 2.5) (DN.time 0.8)
&+&
Run.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 (Option.sampleRate opt) vel freq
<<<
Zip.arrowSecond
(timeControlPercussive
&+&
((MCS.controllerExponential controllerTimbre0 (0.3,10) 0.05
&+&
Run.controllerExponentialDim controllerTimbre1
(DN.time 0.01, DN.time 10) (DN.time 5))
&+&
((MCS.controllerLinear Ctrl.soundController5 (0,10) 2
&+&
Run.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 (EventListTT.mapTime
(NonNegW.fromNumberUnsafe . fromInteger . NonNegW.toNumber))
<<<
PAlsa.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) InstrP.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) $
replicate 20 $
Zip.consChecked "Test.sampledSound"
(Gate.chunk 512 Nothing)
(PCS.Cons Map.empty (EventListTT.pause 512))