synthesizer-alsa-0.3: src/Synthesizer/Storable/ALSA/Server/Test.hs
module Synthesizer.Storable.ALSA.Server.Test where
import qualified Synthesizer.Storable.ALSA.Server.Instrument as Instr
import Synthesizer.Storable.ALSA.Server.Common
(Real, withMIDIEvents, play,
sampleRate, chunkSize, channel, )
import qualified Sound.ALSA.Sequencer.Address as Addr
import qualified Sound.ALSA.Sequencer.Client as Client
import qualified Sound.ALSA.Sequencer.Port as Port
import qualified Sound.ALSA.Sequencer.Queue as Queue
import qualified Sound.ALSA.Sequencer.RealTime as RealTime
import qualified Sound.ALSA.Sequencer.Event as Event
import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC
import qualified Synthesizer.Generic.ALSA.MIDI as Gen
import qualified Synthesizer.Storable.ALSA.MIDI as AlsaSt
import Synthesizer.Storable.ALSA.MIDI (
Instrument, chunkSizesFromLazyTime, )
import qualified Synthesizer.EventList.ALSA.MIDI as MIDIEv
import Synthesizer.EventList.ALSA.MIDI (
LazyTime, StrictTime, Note(..), NoteBoundary(..),
matchNoteEvents, getSlice, getControllerEvents, )
import qualified Synthesizer.Basic.Wave as Wave
import qualified Synthesizer.Causal.Process as Causal
import Control.Arrow ((<<<), )
import qualified Synthesizer.Storable.Cut as CutSt
import qualified Synthesizer.Storable.Oscillator as OsciSt
import qualified Synthesizer.Storable.Signal as SigSt
-- import qualified Data.StorableVector.Lazy.Builder as Bld
import qualified Data.StorableVector.Lazy.Pattern as SigStV
import qualified Data.StorableVector.Lazy as SVL
import qualified Data.StorableVector as SV
import qualified Synthesizer.State.Signal as SigS
import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
import qualified Data.EventList.Relative.TimeBody as EventList
import qualified Data.EventList.Relative.MixedBody as EventListMB
import qualified Data.EventList.Relative.BodyTime as EventListBT
import Data.EventList.Relative.MixedBody ((/.), (./), )
import qualified Control.Monad.Trans.State.Strict as MS
import Control.Monad.Trans.State (evalState, gets, )
import Control.Category ((.), )
import Data.Traversable (traverse, )
-- import qualified Numeric.NonNegative.Class as NonNeg
import qualified Numeric.NonNegative.Wrapper as NonNegW
import qualified Numeric.NonNegative.Chunky as NonNegChunky
import qualified Algebra.RealRing as RealRing
import qualified Algebra.Additive as Additive
import Data.Maybe.HT (toMaybe, )
import NumericPrelude.Numeric (zero, round, (^?), )
import Prelude hiding (Real, round, break, id, (.), )
import Data.Word (Word8, )
frequency1 :: IO ()
frequency1 =
withMIDIEvents play $
const
(OsciSt.static chunkSize Wave.sine zero (800/sampleRate::Real))
frequency2 :: IO ()
frequency2 =
withMIDIEvents (const $ const print) $
evalState (getControllerEvents channel VoiceMsg.mainVolume)
frequency3 :: IO ()
frequency3 =
withMIDIEvents (const $ const print) $
evalState (getSlice Just)
keyboard1 :: IO ()
keyboard1 =
withMIDIEvents play $
const (Instr.ping 0 440)
keyboard2 :: SigSt.T Real
keyboard2 =
let music :: Real -> EventList.T StrictTime (SigSt.T Real)
music x = 5 /. SigSt.replicate chunkSize 6 x ./ music (x+1)
in CutSt.arrange chunkSize $
EventList.mapTime fromIntegral $ music 42
keyboard3 :: SigSt.T Real
keyboard3 =
let time :: Real -> Int
time t = round (t * sampleRate)
music :: Real -> EventList.T StrictTime (SigSt.T Real)
music x =
fromIntegral (time 0.2) /.
SigSt.take (time 0.4) (Instr.ping 0 x) ./
music (x*1.01)
in CutSt.arrange chunkSize $
EventList.mapTime fromIntegral $ music 110
makeLazyTime :: Real -> LazyTime
makeLazyTime t =
NonNegChunky.fromNumber $
NonNegW.fromNumberMsg "keyboard time" $
round (t * sampleRate)
makeStrictTime :: Real -> StrictTime
makeStrictTime t =
NonNegW.fromNumberMsg "keyboard time" $
round (t * sampleRate)
normalVelocity :: VoiceMsg.Velocity
normalVelocity =
VoiceMsg.toVelocity VoiceMsg.normalVelocity
pitch :: Int -> VoiceMsg.Pitch
pitch = VoiceMsg.toPitch
defaultProgram :: VoiceMsg.Program
defaultProgram = VoiceMsg.toProgram 0
embedDefaultProgram ::
EventList.T StrictTime [NoteBoundary Bool] ->
EventList.T StrictTime [NoteBoundary (Maybe VoiceMsg.Program)]
embedDefaultProgram =
fmap (fmap (\(NoteBoundary p v b) ->
NoteBoundary p v (toMaybe b defaultProgram)))
keyboard4 :: SigSt.T Real
keyboard4 =
let {-
idInstr :: Real -> Real -> SigSt.T Real
idInstr _vel freq = SigSt.repeat chunkSize freq
-}
-- inf = time 0.4 + inf
music :: Int -> EventList.T StrictTime Note
music p =
makeStrictTime 0.2 /.
-- (pitch p, normalVelocity, inf) ./
Note defaultProgram (pitch p) normalVelocity (makeLazyTime 0.4) ./
music (p+1)
in CutSt.arrange chunkSize $
EventList.mapTime fromIntegral $
fmap (Gen.renderInstrumentIgnoreProgram Instr.pingDur) $
music 0
notes0 :: Int -> EventList.T StrictTime (NoteBoundary Bool)
notes0 p =
makeStrictTime 0.2 /.
(let (oct,pc) = divMod p 12
in (NoteBoundary (pitch (50 + pc)) normalVelocity (even oct)))
./
notes0 (p+1)
notes1 :: EventList.T StrictTime (NoteBoundary Bool)
notes1 =
makeStrictTime 0.2 /.
(NoteBoundary (pitch 50) normalVelocity True) ./
makeStrictTime 0.2 /.
(NoteBoundary (pitch 52) normalVelocity True) ./
makeStrictTime 0.2 /.
(NoteBoundary (pitch 54) normalVelocity True) ./
makeStrictTime 0.2 /.
-- (NoteBoundary (pitch 50) normalVelocity False) ./
undefined
notes2 :: EventList.T StrictTime [NoteBoundary Bool]
notes2 =
makeStrictTime 0.2 /.
[] ./
makeStrictTime 0.2 /.
[] ./
makeStrictTime 0.2 /.
[NoteBoundary (pitch 50) normalVelocity True] ./
makeStrictTime 0.2 /.
[NoteBoundary (pitch 52) normalVelocity True] ./
makeStrictTime 0.2 /.
[NoteBoundary (pitch 54) normalVelocity True] ./
makeStrictTime 0.2 /.
[NoteBoundary (pitch 50) normalVelocity False] ./
undefined
notes3 :: EventList.T StrictTime [NoteBoundary (Maybe VoiceMsg.Program)]
notes3 =
embedDefaultProgram $
notes2
keyboard5 :: SigSt.T Real
keyboard5 =
CutSt.arrange chunkSize $
EventList.mapTime fromIntegral $
Gen.flatten $
fmap (map (Gen.renderInstrumentIgnoreProgram Instr.pingDur)) $
matchNoteEvents $
notes3
keyboard6 :: EventList.T StrictTime [Note]
keyboard6 =
matchNoteEvents $
embedDefaultProgram $
fmap (:[]) $
notes1
keyboard7 :: EventList.T StrictTime [(VoiceMsg.Pitch, VoiceMsg.Velocity)]
keyboard7 =
fmap (map (\ ~(Note _ p v _d) -> (p,v))) $
keyboard6
arrangeSpaceLeak0 :: IO ()
arrangeSpaceLeak0 =
SVL.writeFile "test.f32" $
evalState (Gen.sequence (CutSt.arrange chunkSize) channel
(error "no sound" :: Instrument Real Real)) $
let evs = EventList.cons 10 [] evs
in evs
arrangeSpaceLeak1 :: IO ()
arrangeSpaceLeak1 =
SVL.writeFile "test.f32" $
evalState
(Gen.sequenceModulated (CutSt.arrange chunkSize)
(SigSt.iterate chunkSize (1+) 0) channel
(error "no sound" :: SigSt.T Real -> Instrument Real Real)) $
let evs = EventList.cons 10 [] evs
in evs
makeNote :: Event.NoteEv -> Word8 -> Event.T
makeNote typ pit =
Event.Cons
{ Event.highPriority = False
, Event.tag = 0
, Event.queue = Queue.direct
, Event.timestamp =
Event.RealTime $ RealTime.fromInteger 0
, Event.source = Addr.Cons {
Addr.client = Client.subscribers,
Addr.port = Port.unknown
}
, Event.dest = Addr.Cons {
Addr.client = Client.subscribers,
Addr.port = Port.unknown
}
, Event.body =
Event.NoteEv typ
(Event.simpleNote 0 pit 64)
}
{-
a space leak can only be observed for more than one note,
maybe our 'break' improvement fixed the case for one played note
-}
arrangeSpaceLeak3 :: IO ()
arrangeSpaceLeak3 =
SVL.writeFile "test.f32" $
evalState
(Gen.sequenceModulated (CutSt.arrange chunkSize)
(SigSt.iterate chunkSize (1e-7 +) 1) channel
Instr.stringStereoFM) $
-- (const Instr.pingDur :: SigSt.T Real -> Instrument Real Real)) $
let evs t = EventList.cons t [] (evs (20-t))
in -- EventList.cons 10 [makeNote MIDI.NoteOn 60] $
-- EventList.cons 10 [makeNote MIDI.NoteOn 64] $
evs 10
arrangeSpaceLeak4 :: IO ()
arrangeSpaceLeak4 =
SVL.writeFile "test.f32" $
evalState
(do bend <- AlsaSt.pitchBend channel (2^?(2/12)) 1
AlsaSt.sequenceModulated chunkSize bend channel Instr.stringStereoFM) $
let evs t = EventList.cons t [] (evs (20-t))
in evs 10
chordSpaceLeak1 :: IO ()
chordSpaceLeak1 =
SVL.writeFile "test.f32" $
evalState
(Gen.sequence (CutSt.arrange chunkSize)
channel Instr.pingDur) $
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
sequencePitchBend :: IO ()
sequencePitchBend =
SVL.writeFile "test.f32" $
evalState
(let fm y = (EventListBT.cons $! y) 10 (fm (2-y))
in Gen.sequenceModulated (CutSt.arrange chunkSize) (fm 1) channel
(error "no sound" ::
PC.T Real -> Instrument Real Real)) $
let evs = EventList.cons 10 [] evs
in evs
sequencePitchBend1 :: IO ()
sequencePitchBend1 =
SVL.writeFile "test.f32" $
evalState
(let fm y = EventListBT.cons y 10 (fm (2-y))
instr :: PC.T Real -> Instrument Real Real
instr = error "no sound"
in Gen.sequenceCore
(CutSt.arrange chunkSize) channel Gen.errorNoProgram
(Gen.Modulator (fm 1) Gen.advanceModulationChunk
(\note -> gets $ \c ->
Gen.renderInstrumentIgnoreProgram (instr c) note))) $
let evs = EventList.cons 10 [] evs
in evs
sequencePitchBend2 :: IO ()
sequencePitchBend2 =
SVL.writeFile "test.f32" $
let fm y = EventListBT.cons y 10 (fm (2-y))
-- fm = EventListBT.cons 1 10 fm
instr :: PC.T Real -> Instrument Real Real
instr = error "no sound"
evs = EventList.cons 10 [] evs
md =
Gen.Modulator
(fm 1)
Gen.advanceModulationChunkPC
-- Gen.advanceModulationChunk
(\note -> gets $ \c ->
Gen.renderInstrumentIgnoreProgram (instr c) note)
in CutSt.arrange chunkSize .
EventList.mapTime fromIntegral .
Gen.flatten .
Gen.applyModulator md $
evs
sequencePitchBend3 :: IO ()
sequencePitchBend3 =
SVL.writeFile "test.f32" $
let fm y = EventListBT.cons y 10 (fm (2-y))
-- fm = EventListBT.cons 1 10 fm
instr :: PC.T Real -> Instrument Real Real
instr = error "no sound"
evs = EventList.cons 10 [] evs
modEvent note =
gets $ \c ->
Gen.renderInstrumentIgnoreProgram (instr c) note
in CutSt.arrange chunkSize .
EventList.mapTime fromIntegral .
Gen.flatten .
flip evalState (fm 1) .
EventList.traverse
Gen.advanceModulationChunk
(traverse modEvent) $
evs
sequencePitchBend4 :: IO ()
sequencePitchBend4 =
SVL.writeFile "test.f32" $
let fm y = y : fm (2-y)
-- fm = repeat 1
instr :: [Real] -> Instrument Real Real
instr = error "no sound"
evs = EventList.cons 10 [] evs
modEvent note =
gets $ \c ->
Gen.renderInstrumentIgnoreProgram (instr c) note
in CutSt.arrange chunkSize .
EventList.mapTime fromIntegral .
Gen.flatten .
flip evalState (fm 1) .
EventList.traverse
Gen.advanceModulationChunk
(traverse modEvent) $
evs
sequencePitchBend4a :: IO ()
sequencePitchBend4a =
SVL.writeFile "test.f32" $
let fm y = y : fm (2-y)
-- fm = repeat 1
instr :: [Real] -> Instrument Real Real
instr = error "no sound"
evs = EventList.cons 10 [] evs
modEvent note =
MS.gets $ \c ->
Gen.renderInstrumentIgnoreProgram (instr c) note
in CutSt.arrange chunkSize .
EventList.mapTime fromIntegral .
Gen.flatten .
flip MS.evalState (fm 1) .
EventList.traverse
Gen.advanceModulationChunkStrict
(traverse modEvent) $
evs
sequencePitchBend4b :: IO ()
sequencePitchBend4b =
SVL.writeFile "test.f32" $
let fm y = y : fm (2-y)
-- fm = repeat 1
instr :: [Real] -> Instrument Real Real
instr = error "no sound"
evs = EventList.cons 10 [] evs
in CutSt.arrange chunkSize .
Gen.flatten $
EventList.foldrPair
(\t bs0 go s0 ->
let s1 = tail s0
bs1 =
map (Gen.renderInstrumentIgnoreProgram (instr s1)) bs0
in EventList.cons
(if null s1 then t else t) bs1 $
go s1)
(const EventList.empty) evs (fm 1)
sequencePitchBend4c :: IO ()
sequencePitchBend4c =
SVL.writeFile "test.f32" $
let fm y = y : fm (2-y)
-- fm = repeat 1
instr :: [Real] -> Instrument Real Real
instr = error "no sound"
in CutSt.arrange chunkSize .
Gen.flatten .
EventList.fromPairList $
foldr
(\(t,bs0) go s0 ->
let s1 = tail s0
bs1 =
map (Gen.renderInstrumentIgnoreProgram (instr s1)) bs0
in (if null s1 then t else t, bs1) :
go s1)
(const [])
(repeat (10,[]))
(fm 1)
sequencePitchBend4d :: IO ()
sequencePitchBend4d =
SVL.writeFile "test.f32" $
let fm y = y : fm (2-y)
-- fm = repeat 1
in CutSt.arrange chunkSize .
EventList.fromPairList $
foldr
(\(t,b) go s0 ->
let s1 = tail s0
in (if null s1 then t else t,
if null s1 then b else b) :
go s1)
(const [])
(repeat (10, SigSt.empty :: SigSt.T Real))
(fm 1 :: [Real])
sequencePitchBend4e :: IO ()
sequencePitchBend4e =
writeFile "test.txt" $
foldr
(\c go s0 ->
let s1 = tail s0
in (if null s1 then c else c) :
go s1)
(const [])
(repeat 'a')
(iterate not False)
-- (repeat True)
sequencePitchBend5 :: IO ()
sequencePitchBend5 =
SVL.writeFile "test.f32" $
let fm y = SigSt.iterate (SVL.ChunkSize 1) (y+) 0
instr :: SigSt.T Real -> Instrument Real Real
instr = error "no sound"
evs = EventList.cons 10 [] evs
modEvent note =
gets $ \c ->
Gen.renderInstrumentIgnoreProgram (instr c) note
in CutSt.arrange chunkSize .
EventList.mapTime fromIntegral .
Gen.flatten .
flip evalState (fm 1e-6) .
EventList.traverse
Gen.advanceModulationChunk
(traverse modEvent) $
evs
dummySound :: Instrument Real Real
dummySound =
\vel freq dur ->
SigStV.take (chunkSizesFromLazyTime dur) $
SigSt.repeat chunkSize (vel + 1e-3*freq)
sequenceStaccato :: IO ()
sequenceStaccato =
SVL.writeFile "test.f32" $
let evs t =
EventList.cons t [Right $ NoteBoundary (pitch 60) normalVelocity True] $
EventList.cons t [Right $ NoteBoundary (pitch 60) normalVelocity False] $
evs (20-t)
in CutSt.arrange chunkSize .
EventList.mapTime fromIntegral .
Gen.flatten .
EventList.mapBody
(map (Gen.renderInstrumentIgnoreProgram dummySound)) .
MIDIEv.matchNoteEvents .
MIDIEv.embedPrograms defaultProgram $
evs 10
sequenceStaccato3 :: IO ()
sequenceStaccato3 =
SVL.writeFile "test.f32" $
let evs t =
EventList.cons t [NoteBoundary (pitch 60) normalVelocity (Just defaultProgram)] $
EventList.cons t [NoteBoundary (pitch 60) normalVelocity Nothing] $
evs (20-t)
in CutSt.arrange chunkSize .
EventList.mapTime fromIntegral .
Gen.flatten .
EventList.mapBody
(map (Gen.renderInstrumentIgnoreProgram dummySound)) .
MIDIEv.matchNoteEvents $
evs 10
sequenceStaccato2 :: IO ()
sequenceStaccato2 =
SVL.writeFile "test.f32" $
let evs t =
EventList.cons t [makeNote Event.NoteOn 60] $
EventList.cons t [makeNote Event.NoteOff 60] $
evs (20-t)
in CutSt.arrange chunkSize .
EventList.mapTime fromIntegral .
Gen.flatten .
EventList.mapBody
(map (Gen.renderInstrumentIgnoreProgram dummySound)) .
MIDIEv.matchNoteEvents .
MIDIEv.embedPrograms defaultProgram .
evalState (MIDIEv.getNoteEvents channel) $
evs 10
sequenceStaccato1 :: IO ()
sequenceStaccato1 =
SVL.writeFile "test.f32" $
evalState
(do Gen.sequence (CutSt.arrange chunkSize) channel dummySound) $
let evs t =
EventList.cons t [makeNote Event.NoteOn 60] $
EventList.cons t [makeNote Event.NoteOff 60] $
evs (20-t)
in evs 10
speed :: IO ()
speed =
let _sig =
Causal.apply
(Instr.softStringCausalProcess 440 <<<
Instr.softStringReleaseEnvelopeCausalProcess 0)
(SigS.repeat True)
sig =
Causal.apply
(Instr.softStringCausalProcess 440)
(SigS.repeat 1)
in SV.writeFile "speed.f32" $
SigS.runViewL sig
(\next s -> fst $ SV.unfoldrN 1000000 next s)
speedChunky :: IO ()
speedChunky =
let sig =
Causal.apply
(Instr.softStringCausalProcess 440 <<<
Instr.softStringReleaseEnvelopeCausalProcess 0)
(SigS.repeat True)
in SVL.writeFile "speed.f32" $
SigSt.take 1000000 $
SigS.toStorableSignal (SVL.chunkSize 100) sig
{-
SigS.runViewL sig
(\next s -> SVL.take 1000000 (SVL.unfoldr (SVL.chunkSize 100) next s))
-}
speedArrange :: IO ()
speedArrange =
let sig =
Causal.apply
(Instr.softStringCausalProcess 440 <<<
Instr.softStringReleaseEnvelopeCausalProcess 0)
(SigS.repeat True)
sigSt =
SigS.toStorableSignal (SVL.chunkSize 100) sig
in SVL.writeFile "speed.f32" $
SigSt.take 1000000 $
CutSt.arrangeEquidist (SVL.chunkSize 100) $
EventList.fromPairList [(10000,sigSt)]