synthesizer-alsa 0.0.3 → 0.1
raw patch · 8 files changed
+2805/−576 lines, 8 filesdep +arraydep +mididep +synthesizer-dimensionaldep −synthesizerdep ~alsadep ~non-negativedep ~soxnew-component:exe:synthicate
Dependencies added: array, midi, synthesizer-dimensional
Dependencies removed: synthesizer
Dependency ranges changed: alsa, non-negative, sox, storablevector, synthesizer-core
Files
- src/RealTimeSynthesizer.hs +806/−99
- src/RealTimeSynthesizerDim.hs +426/−0
- src/Synthesizer/Dimensional/ALSA/MIDI.hs +444/−0
- src/Synthesizer/Dimensional/ALSA/Play.hs +100/−0
- src/Synthesizer/EventList/ALSA/MIDI.hs +637/−0
- src/Synthesizer/Storable/ALSA/MIDI.hs +239/−456
- src/Synthesizer/Storable/ALSA/Play.hs +121/−0
- synthesizer-alsa.cabal +32/−21
src/RealTimeSynthesizer.hs view
@@ -1,22 +1,62 @@ module Main where -import Synthesizer.Storable.ALSA.MIDI+import qualified Sound.Alsa as ALSA+import qualified Sound.Alsa.Sequencer as MIDI+import qualified Synthesizer.Storable.ALSA.Play as Play+import Synthesizer.Storable.ALSA.MIDI (+ Instrument, makeInstrumentSounds,+ getNoteSignal, getNoteSignalMultiProgram, getNoteSignalModulated,+ getNoteSignalMultiModulated, applyModulation,+ getFMSignalFromBendWheelPressure, getPitchBendSignal,+ getControllerSignal, getControllerSignalExp,+ chunkSizesFromLazyTime, insertBreaks, ) -import qualified Synthesizer.Storable.Cut as CutSt-import qualified Synthesizer.Storable.Oscillator as OsciSt+import Synthesizer.EventList.ALSA.MIDI (+ Channel, LazyTime, StrictTime, Note(..), NoteBoundary(..),+ withMIDIEventsNonblock,+ matchNoteEvents, partitionMaybe,+ getSlice, getControllerEvents, )+ import qualified Synthesizer.Basic.Wave as Wave+import qualified Synthesizer.Frame.Stereo as Stereo +-- import Foreign.Storable (Storable, )+-- import Data.Int (Int16, )++import qualified Synthesizer.Causal.Process as Causal+import qualified Synthesizer.Causal.Interpolation as Interpolation+import qualified Synthesizer.Causal.Oscillator as OsciC+import qualified Synthesizer.Causal.Filter.Recursive.Integration as IntegC+import Control.Arrow ((<<<), (^<<), (<<^), (***), )+import qualified Synthesizer.Interpolation.Module as Ip++import qualified Synthesizer.Storable.Filter.NonRecursive as FiltNRSt+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.Generic.Signal as SigG+-- import qualified Synthesizer.Generic.Cut as CutG+import qualified Synthesizer.Generic.Wave as WaveG+import qualified Synthesizer.Generic.Loop as LoopG import qualified Synthesizer.State.Signal as SigS import qualified Synthesizer.State.Control as CtrlS+import qualified Synthesizer.State.Noise as NoiseS import qualified Synthesizer.State.Oscillator as OsciS+import qualified Synthesizer.State.Displacement as DispS import qualified Synthesizer.State.Filter.NonRecursive as FiltNRS import qualified Synthesizer.Plain.Filter.Recursive as FiltR import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter+-- import qualified Synthesizer.Generic.Filter.NonRecursive as FiltG+-- import qualified Synthesizer.Basic.Phase as Phase +import qualified Sound.MIDI.Message.Channel as ChannelMsg+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg+ import qualified Data.EventList.Relative.TimeBody as EventList import qualified Data.EventList.Relative.TimeTime as EventListTT import qualified Data.EventList.Relative.MixedBody as EventListMB@@ -25,59 +65,116 @@ import qualified Data.EventList.Relative.MixedTime as EventListMT import Data.EventList.Relative.MixedBody ((/.), (./), ) -import Control.Monad.Trans.State (state, evalState, )+import qualified Sound.Sox.Read as SoxRead+import qualified Sound.Sox.Frame as SoxFrame+import qualified Sound.Sox.Option.Format as SoxOption +import Control.Monad.Trans.State (state, evalState, get, modify, )+import Control.Monad (mzero, )+ -- import qualified Numeric.NonNegative.Class as NonNeg import qualified Numeric.NonNegative.Wrapper as NonNegW import qualified Numeric.NonNegative.ChunkyPrivate as NonNegChunky import qualified Algebra.RealField as RealField+import qualified Algebra.Additive as Additive -import NumericPrelude (zero, round, )-import Prelude hiding (round, break, )+import Data.Tuple.HT (mapSnd, )+import Data.Maybe.HT (toMaybe, ) +import NumericPrelude (zero, round, (*>), (^?), )+import Prelude hiding (Real, round, break, ) +channel :: Channel+channel = ChannelMsg.toChannel 0++sampleRate :: Num a => a+-- sampleRate = 24000+sampleRate = 48000+-- sampleRate = 44100++latency :: Int+-- latency = 0+-- latency = 256+latency = 1000++chunkSize :: SVL.ChunkSize+chunkSize = Play.defaultChunkSize++lazySize :: SigG.LazySize+lazySize =+ let (SVL.ChunkSize size) = chunkSize+ in SigG.LazySize size+++type Real = Float+++{-# INLINE withMIDIEvents #-}+withMIDIEvents ::+ (Double -> a -> IO b) ->+ (EventList.T StrictTime (Maybe MIDI.Event) -> a) -> IO b+withMIDIEvents action proc =+ let rate = sampleRate+ in withMIDIEventsNonblock rate $+ action rate . proc+++{-# INLINE play #-}+play ::+ (RealField.C t, Additive.C y, ALSA.SampleFmt y) =>+ t -> SigSt.T y -> IO ()+play rate =+ Play.auto (round rate) .+ SigSt.append (SigSt.replicate chunkSize latency zero)+-- FiltG.delayPosLazySize chunkSize latency+-- FiltG.delayPos latency++-- ToDo: do not record the empty chunk that is inserted for latency+{-# INLINE playAndRecord #-}+playAndRecord ::+ (RealField.C t, Additive.C y, ALSA.SampleFmt y, SoxFrame.C y) =>+ FilePath -> t -> SigSt.T y -> IO ()+playAndRecord fileName rate =+ Play.autoAndRecord fileName (round rate) .+ SigSt.append (SigSt.replicate chunkSize latency zero)++ exampleVolume :: IO () exampleVolume = putStrLn "run 'aconnect' to connect to the MIDI controller" >>- (withMIDIEventsNonblock defaultSampleRate $- playMono defaultSampleRate .+ (withMIDIEvents play $ SigSt.zipWith (*)- (OsciSt.static defaultChunkSize Wave.sine zero (800/defaultSampleRate)) .- evalState (getControllerSignal 0 7 (0,1) 0))+ (OsciSt.static chunkSize Wave.sine zero (800/sampleRate)) .+ evalState (getControllerSignal channel VoiceMsg.mainVolume (0,1) (0::Real))) exampleFrequency :: IO () exampleFrequency =- withMIDIEventsNonblock defaultSampleRate $- playMono defaultSampleRate .- OsciSt.freqMod defaultChunkSize Wave.sine zero .- evalState (getControllerSignal 0 7- (400/defaultSampleRate, 1200/defaultSampleRate) (800/defaultSampleRate))+ withMIDIEvents play $+ OsciSt.freqMod chunkSize Wave.sine zero .+ evalState (getControllerSignal channel VoiceMsg.mainVolume+ (400/sampleRate, 1200/sampleRate) (800/sampleRate::Real)) testFrequency1 :: IO () testFrequency1 =- withMIDIEventsNonblock defaultSampleRate $+ withMIDIEvents play $ const- (playMono (defaultSampleRate::Double) $- OsciSt.static defaultChunkSize Wave.sine zero (800/defaultSampleRate))+ (OsciSt.static chunkSize Wave.sine zero (800/sampleRate::Real)) testFrequency2 :: IO () testFrequency2 =- withMIDIEventsNonblock defaultSampleRate $- print .- evalState (getControllerEvents 0 7)+ withMIDIEvents (const print) $+ evalState (getControllerEvents channel VoiceMsg.mainVolume) testFrequency3 :: IO () testFrequency3 =- withMIDIEventsNonblock defaultSampleRate $- print .+ withMIDIEvents (const print) $ evalState (getSlice Just) testFrequency4 :: IO () testFrequency4 =- withMIDIEventsNonblock defaultSampleRate $- print .+ withMIDIEvents (const print) $ evalState (fmap (EventListTT.catMaybesR . flip EventListTM.snocTime 0 .@@ -86,173 +183,783 @@ examplePitchBend :: IO () examplePitchBend =- withMIDIEventsNonblock defaultSampleRate $- playMono defaultSampleRate .- OsciSt.freqMod defaultChunkSize Wave.sine zero .- evalState (getPitchBendSignal 0 2 (880/defaultSampleRate))+ withMIDIEvents play $+ OsciSt.freqMod chunkSize Wave.sine zero .+ evalState (getPitchBendSignal channel 2 (880/sampleRate::Real)) exampleVolumeFrequency :: IO () exampleVolumeFrequency = putStrLn "run 'aconnect' to connect to the MIDI controller" >>- (withMIDIEventsNonblock defaultSampleRate $- playMono defaultSampleRate .+ (withMIDIEvents play $ evalState (do- vol <- getControllerSignal 0 7 (0,1) 0- freq <- getPitchBendSignal 0 2 (880/defaultSampleRate)+ vol <- getControllerSignal channel VoiceMsg.mainVolume (0,1) 0+ freq <- getPitchBendSignal channel 2 (880/sampleRate::Real) return $ SigSt.zipWith (*) vol- (OsciSt.freqMod defaultChunkSize Wave.sine zero freq)))+ (OsciSt.freqMod chunkSize Wave.sine zero freq))) ++{-# INLINE amplitudeFromVelocity #-}+amplitudeFromVelocity :: Real -> Real+amplitudeFromVelocity vel = 4**vel+ {-# INLINE ping #-}-ping :: Double -> Double -> SigSt.T Double+ping :: Real -> Real -> SigSt.T Real ping vel freq =- SigS.toStorableSignal defaultChunkSize $- FiltNRS.envelope (CtrlS.exponential2 (0.2*defaultSampleRate) (4**vel)) $- OsciS.static Wave.saw zero (freq/defaultSampleRate)+ SigS.toStorableSignal chunkSize $+ FiltNRS.envelope (CtrlS.exponential2 (0.2*sampleRate) (amplitudeFromVelocity vel)) $+ OsciS.static Wave.saw zero (freq/sampleRate) -pingDur :: Instrument-pingDur dur vel freq =+pingDur :: Instrument Real Real+pingDur vel freq dur = SigStV.take (chunkSizesFromLazyTime dur) $ ping vel freq -pingRelease :: Instrument-pingRelease dur vel freq =- let env =- SigSt.switchR SigSt.empty- (\body x ->- SigSt.append body $- SigS.toStorableSignal defaultChunkSize $- SigS.take (round (0.3*defaultSampleRate :: Double)) $- CtrlS.exponential2 (0.1*defaultSampleRate) x) $+pingReleaseEnvelope :: Real -> LazyTime -> SigSt.T Real+pingReleaseEnvelope vel dur =+ SigSt.switchR SigSt.empty+ (\body x ->+ SigSt.append body $+ SigS.toStorableSignal chunkSize $+ SigS.take (round (0.3*sampleRate :: Real)) $+ CtrlS.exponential2 (0.1*sampleRate) x) $+ SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $+ CtrlS.exponential2 (0.4*sampleRate) (amplitudeFromVelocity vel)++pingRelease :: Instrument Real Real+pingRelease vel freq dur =+ SigS.zipWithStorable (*)+ (OsciS.static Wave.saw zero (freq/sampleRate))+ (pingReleaseEnvelope vel dur)++pingStereoRelease :: Instrument Real (Stereo.T Real)+pingStereoRelease vel freq dur =+-- SigS.zipWithStorable (\y c -> fmap (c*) y)+ SigS.zipWithStorable (flip (*>))+ (SigS.zipWith Stereo.cons+ (OsciS.static Wave.saw zero (freq*0.999/sampleRate))+ (OsciS.static Wave.saw zero (freq*1.001/sampleRate)))+ (pingReleaseEnvelope vel dur)++tine :: Instrument Real Real+tine vel freq dur =+ SigS.zipWithStorable (*)+ (OsciS.phaseMod Wave.sine (freq/sampleRate)+ (FiltNRS.envelope+ (CtrlS.exponential (1*sampleRate) (vel+1))+ (OsciS.static Wave.sine zero (2*freq/sampleRate))))+ (pingReleaseEnvelope 0 dur)++tineStereo :: Instrument Real (Stereo.T Real)+tineStereo vel freq dur =+ let ctrl f =+ FiltNRS.envelope+ (CtrlS.exponential (1*sampleRate) (vel+1))+ (OsciS.static Wave.sine zero (2*f/sampleRate))+ in SigS.zipWithStorable (flip (*>))+ (SigS.zipWith Stereo.cons+ (OsciS.phaseMod Wave.sine (freq*0.995/sampleRate) (ctrl freq))+ (OsciS.phaseMod Wave.sine (freq*1.005/sampleRate) (ctrl freq)))+ (pingReleaseEnvelope 0 dur)+++softStringReleaseEnvelope ::+ Real -> LazyTime -> SigSt.T Real+softStringReleaseEnvelope vel dur =+ let attackTime = sampleRate+ amp = amplitudeFromVelocity vel+ cnst = CtrlS.constant amp+ {-+ release <- take attackTime beginning+ would yield a space leak, thus we first split 'beginning'+ and then concatenate it again+ -}+ {-+ We can not easily generate attack and sustain separately,+ because we want to use the chunk structure implied by 'dur'.+ -}+ (attack, sustain) =+ SigSt.splitAt attackTime $ SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $- CtrlS.exponential2 (0.4*defaultSampleRate) (4**vel)- in SigS.zipWithStorable (*)- (OsciS.static Wave.saw zero (freq/defaultSampleRate))- env+ flip SigS.append cnst $+ SigS.map ((amp*) . sin) $+ CtrlS.line attackTime (0, pi/2)+ release = SigSt.reverse attack+ in attack `SigSt.append` sustain `SigSt.append` release +-- it's better to avoid inlining here+softString :: Instrument Real (Stereo.T Real)+softString vel freq dur =+ let f = freq/sampleRate+ {-# INLINE osci #-}+ osci d =+ OsciS.static Wave.saw zero (d * f)+ in flip (SigS.zipWithStorable (flip (*>)))+ (softStringReleaseEnvelope vel dur)+ (SigS.map ((0.3::Real)*>) $+ SigS.zipWith Stereo.cons+ (DispS.mix+ (osci 1.005)+ (osci 0.998))+ (DispS.mix+ (osci 1.002)+ (osci 0.995))) ++softStringReleaseEnvelopeCausal ::+ Real -> LazyTime -> SigSt.T Real+softStringReleaseEnvelopeCausal vel dur =+ Causal.apply+ (softStringReleaseEnvelopeCausalProcess vel)+ (SigSt.append+ (SigStV.replicate (chunkSizesFromLazyTime dur) True)+ (SigSt.repeat chunkSize False))+++{-# INLINE softStringReleaseEnvelopeCausalProcess #-}+softStringReleaseEnvelopeCausalProcess ::+ Real -> Causal.T Bool Real+softStringReleaseEnvelopeCausalProcess vel =+ let vol = amplitudeFromVelocity vel+ attackTime = sampleRate+ {-# INLINE sine #-}+ sine x = sin (x*pi/(2*attackTime))+ in Causal.fromStateMaybe+ (\b ->+ get >>= \n ->+ if b+ then+ if n==attackTime+ then return vol+ else+ modify (1+) >>+ return (vol * sine n)+ else+ if n==0+ then mzero+ else+ modify (subtract 1) >>+ return (vol * sine n))+ zero++{-# INLINE softStringCausalProcess #-}+softStringCausalProcess :: Real -> Causal.T Real (Stereo.T Real)+softStringCausalProcess freq =+ let f = freq/sampleRate+ {-# INLINE osci #-}+ osci d =+ OsciS.static Wave.saw zero (d * f)+ in Causal.applySnd+ (Causal.map (uncurry (*>)))+ (SigS.map ((0.3::Real)*>) $+ SigS.zipWith Stereo.cons+ (DispS.mix+ (osci 1.005)+ (osci 0.998))+ (DispS.mix+ (osci 1.002)+ (osci 0.995)))++softStringCausal :: Instrument Real (Stereo.T Real)+softStringCausal vel freq dur =+ Causal.apply+ (softStringCausalProcess freq <<<+ softStringReleaseEnvelopeCausalProcess vel)+ (SigSt.append+ (SigStV.replicate (chunkSizesFromLazyTime dur) True)+ (SigSt.repeat chunkSize False))++ exampleKeyboard :: IO () exampleKeyboard =- withMIDIEventsNonblock defaultSampleRate $- playMono defaultSampleRate .+ withMIDIEvents play $+-- playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate::Real) . SigSt.map (0.2*) .- evalState (getNoteSignal 0 pingRelease)+ evalState (getNoteSignalMultiProgram chunkSize channel+ (VoiceMsg.toProgram 2)+ [pingDur, pingRelease, tine]) +exampleKeyboardStereo :: IO ()+exampleKeyboardStereo =+ withMIDIEvents play $+-- playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate::Real) .+ SigSt.map ((0.2::Real)*>) .+ evalState (getNoteSignalMultiProgram chunkSize channel+ (VoiceMsg.toProgram 1)+ [pingStereoRelease, tineStereo, softString, softStringCausal])++stringStereoFM :: SigSt.T Real -> Instrument Real (Stereo.T Real)+stringStereoFM fmSt vel freq dur =+ let fm = SigS.fromStorableSignal fmSt+ in SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $+ FiltNRS.amplifyVector (amplitudeFromVelocity vel) $+ SigS.zipWith Stereo.cons+ (OsciS.freqMod Wave.saw zero $+ FiltNRS.amplify (freq*0.999/sampleRate) fm)+ (OsciS.freqMod Wave.saw zero $+ FiltNRS.amplify (freq*1.001/sampleRate) fm)++exampleKeyboardPitchbend :: IO ()+exampleKeyboardPitchbend =+ withMIDIEvents play $+ SigSt.map ((0.2::Real)*>) .+ evalState+ (do bend <- getPitchBendSignal channel (2^?(2/12)) 1+ getNoteSignalModulated chunkSize bend channel stringStereoFM)++exampleKeyboardFM :: IO ()+exampleKeyboardFM =+ withMIDIEvents play $+ SigSt.map ((0.2::Real)*>) .+ evalState+ (do fm <- getFMSignalFromBendWheelPressure channel+ 2 (10/sampleRate) 0.04 0.03+ getNoteSignalModulated chunkSize fm channel stringStereoFM)++stringStereoDetuneFM ::+ SigSt.T Real -> SigSt.T Real -> Instrument Real (Stereo.T Real)+stringStereoDetuneFM detuneSt fmSt vel freq dur =+ let fm = SigS.fromStorableSignal fmSt+ detune = SigS.fromStorableSignal detuneSt+ {-# INLINE osci #-}+ osci =+ OsciS.freqMod Wave.saw zero .+ FiltNRS.amplify (freq/sampleRate) .+ FiltNRS.envelope fm+ in SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $+ FiltNRS.amplifyVector (amplitudeFromVelocity vel) $+ SigS.zipWith Stereo.cons+ (osci $ SigS.map (1-) detune)+ (osci $ SigS.map (1+) detune)++exampleKeyboardDetuneFM :: IO ()+exampleKeyboardDetuneFM =+ withMIDIEvents play $+ SigSt.map ((0.2::Real)*>) .+ evalState+ (do fm <- getFMSignalFromBendWheelPressure channel+ 2 (10/sampleRate) 0.04 0.03+ detune <- getControllerSignal channel+ VoiceMsg.vectorX (0,0.005) 0+ getNoteSignalMultiModulated+ chunkSize channel stringStereoDetuneFM+ (applyModulation fm .+ applyModulation detune))++ exampleKeyboardFilter :: IO () exampleKeyboardFilter =- withMIDIEventsNonblock defaultSampleRate $- playMono defaultSampleRate .+ withMIDIEvents play $ SigSt.map (0.2*) . evalState- (do music <- getNoteSignal 0 pingRelease- freq <- getControllerSignal 0 21- (100/defaultSampleRate, 5000/defaultSampleRate)- (700/defaultSampleRate)+ (do music <- getNoteSignal chunkSize channel pingRelease+ freq <- getControllerSignal channel+ VoiceMsg.vectorY+ -- (VoiceMsg.toController 21)+ (100/sampleRate, 5000/sampleRate)+ (700/sampleRate) return $- SigS.toStorableSignal defaultChunkSize $+ SigS.toStorableSignal chunkSize $ SigS.map UniFilter.lowpass $ SigS.modifyModulated UniFilter.modifier (SigS.map UniFilter.parameter $ SigS.zipWith FiltR.Pole- (SigS.repeat 5)+ (SigS.repeat (5 :: Real)) (SigS.fromStorableSignal freq)) $ SigS.fromStorableSignal music) +{-# INLINE sampledSoundGenerator #-}+sampledSoundGenerator :: (Real, SigSt.T Real) -> Real -> SigS.T Real+sampledSoundGenerator (period, sample) freq =+ Causal.apply+ (Interpolation.relativeZeroPad zero Ip.linear zero+ (SigS.fromStorableSignal sample)) $+ SigS.repeat (freq/sampleRate*period)++sampledSound :: (Real, SigSt.T Real) -> Instrument Real Real+sampledSound sound vel freq dur =+ SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $+ SigS.map ((amplitudeFromVelocity vel) *) $+ sampledSoundGenerator sound freq++sampledSoundDetuneStereo ::+ Real -> (Real, SigSt.T Real) -> Instrument Real (Stereo.T Real)+sampledSoundDetuneStereo detune sound vel freq dur =+ SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $+ SigS.map ((amplitudeFromVelocity vel) *>) $+ SigS.zipWith Stereo.cons+ (sampledSoundGenerator sound (freq*(1-detune)))+ (sampledSoundGenerator sound (freq*(1+detune)))++sampleReleaseEnvelope :: Real -> Real -> LazyTime -> SigSt.T Real+sampleReleaseEnvelope halfLife vel dur =+ let amp = amplitudeFromVelocity vel+ in SigSt.append+ (SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $+ CtrlS.constant amp)+ (SigS.toStorableSignal chunkSize $+ SigS.take (round (5*halfLife*sampleRate :: Real)) $+ CtrlS.exponential2 (halfLife*sampleRate) amp)++sampledSoundDetuneStereoRelease ::+ Real -> Real -> (Real, SigSt.T Real) -> Instrument Real (Stereo.T Real)+sampledSoundDetuneStereoRelease release detune sound vel freq dur =+ flip (SigS.zipWithStorable (flip (*>)))+ (sampleReleaseEnvelope release vel dur) $+ SigS.zipWith Stereo.cons+ (sampledSoundGenerator sound (freq*(1-detune)))+ (sampledSoundGenerator sound (freq*(1+detune)))+++readPianoSample :: IO (Real, SigSt.T Real)+readPianoSample =+ fmap ((,) 96) $+ SoxRead.withHandle1 (SVL.hGetContentsSync chunkSize) =<<+ SoxRead.open SoxOption.none "a-piano3"++readStringSample :: IO (Real, SigSt.T Real)+readStringSample =+ fmap ((,) 64) $+ SoxRead.withHandle1 (SVL.hGetContentsSync chunkSize) =<<+ SoxRead.open SoxOption.none "strings7.s8"+++{- |+Resample a sampled sound with a smooth loop+using our time manipulation algorithm.+Time is first controlled linearly,+then switches to a sine or triangular control.+Loop start must be large enough in order provide enough spare data+for interpolation at the beginning+and loop start plus length must preserve according space at the end.+One period is enough space for linear interpolation.+The infinite sound we generate is not just a cycle,+that uses bounded space.+Instead we need to compute all the time.+In order to avoid duplicate interpolation,+we have merged resampling and time looping.+-}+{-# INLINE sampledSoundTimeLoop #-}+sampledSoundTimeLoop ::+ (Real -> Real -> Real -> Real -> SigS.T Real) ->+ (Real, SigSt.T Real) -> Real -> Real -> Instrument Real Real+sampledSoundTimeLoop loopTimeMod+ (period, sample) loopLen loopStart vel freq dur =+ let wave = WaveG.sampledTone Ip.linear Ip.linear period sample+ in SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $+ (((0.2 * amplitudeFromVelocity vel) *) ^<<+ OsciC.shapeMod wave zero (freq/sampleRate))+ `Causal.apply`+ loopTimeMod period (loopLen/2) (loopStart + loopLen/2) freq++{-+Graphics.Gnuplot.Simple.plotList [] (SigS.toList $ SigS.take 20000 $ loopTimeMod 64 1000 2000 440)+-}+loopTimeModSine :: Real -> Real -> Real -> Real -> SigS.T Real+loopTimeModSine period loopDepth loopCenter freq =+ let rate = freq*period/sampleRate+ in SigS.append+ (SigS.takeWhile (loopCenter>=) $+ SigS.iterate (rate+) zero)+ (SigS.map (\t -> loopCenter + loopDepth * sin t) $+ SigS.iterate ((rate/loopDepth)+) zero)++loopTimeModZigZag :: Real -> Real -> Real -> Real -> SigS.T Real+loopTimeModZigZag period loopDepth loopCenter freq =+ let rate = freq*period/sampleRate+ in SigS.append+ (SigS.takeWhile (loopCenter>=) $+ SigS.iterate (rate+) zero)+ (SigS.map (\t -> loopCenter + loopDepth * t) $+ OsciS.static Wave.triangle zero (rate/(4*loopDepth)))++++exampleKeyboardSample :: IO ()+exampleKeyboardSample =+ do piano <- readPianoSample+ string <- readStringSample+ let loopedString = mapSnd (LoopG.simple 8750 500) string+ fadedString = mapSnd (LoopG.fade (undefined::Real) 8750 500) string+ timeSineString = LoopG.timeReverse lazySize Ip.linear Ip.linear LoopG.timeControlSine 8750 500 string+ timeZigZagString = LoopG.timeReverse lazySize Ip.linear Ip.linear LoopG.timeControlZigZag 8750 500 string+ withMIDIEvents play $+ SigSt.map (0.2*) .+ evalState (getNoteSignalMultiProgram chunkSize channel+ (VoiceMsg.toProgram 5) $+ sampledSound piano :+ sampledSound string :+ sampledSound loopedString :+ sampledSound fadedString :+ sampledSound timeSineString :+ sampledSound timeZigZagString :+ sampledSoundTimeLoop loopTimeModSine string 8750 500 :+ sampledSoundTimeLoop loopTimeModZigZag string 8750 500 :+ [])+++exampleKeyboardVariousStereo :: IO ()+exampleKeyboardVariousStereo =+ do piano <- readPianoSample+ string <- readStringSample+ let loopedString =+ LoopG.timeReverse lazySize Ip.linear Ip.linear+ LoopG.timeControlZigZag 8750 500 string+ withMIDIEvents (playAndRecord "session.wav") $+ SigSt.map ((0.2::Real)*>) .+ evalState (getNoteSignalMultiProgram chunkSize channel+ (VoiceMsg.toProgram 0) $+ pingStereoRelease :+ tineStereo :+ softString :+ sampledSoundDetuneStereo 0.001 piano :+ sampledSoundDetuneStereo 0.002 loopedString :+ sampledSoundDetuneStereoRelease 0.1 0.001 piano :+ sampledSoundDetuneStereoRelease 0.3 0.002 loopedString :+ [])+++timeModulatedSample :: (Real, SigSt.T Real) ->+ SigSt.T Real -> SigSt.T Real -> SigSt.T Real -> Instrument Real Real+timeModulatedSample (period, sample) offsetMod speedMod freqMod vel freq dur =+ let wave = WaveG.sampledTone Ip.linear Ip.linear period sample+ in SigStV.take (chunkSizesFromLazyTime dur) $+{-+ (((0.2 * amplitudeFromVelocity vel) *) ^<<+ OsciC.freqMod Wave.saw zero <<<+ Causal.map ((freq/sampleRate) *))+ `Causal.apply` freqMod+-}+ (((0.2 * amplitudeFromVelocity vel) *) ^<<+ OsciC.shapeFreqMod wave zero <<<+ (uncurry (+) ^<< Causal.feedFst offsetMod <<< IntegC.run) ***+ Causal.map ((freq/sampleRate) *))+ `Causal.applyFst` speedMod+ `Causal.apply` freqMod++exampleKeyboardSampleTFM :: IO ()+exampleKeyboardSampleTFM =+ do instr <- readPianoSample+ withMIDIEvents play $+ evalState+ (do fm <- getFMSignalFromBendWheelPressure channel+ 2 (10/sampleRate) 0.04 0.03+ speed <- getControllerSignal channel+ (VoiceMsg.toController 22)+ (0,2) 1+ offset <- getControllerSignal channel+ (VoiceMsg.toController 21)+ (0, fromIntegral (SVL.length (snd instr))) 0+ getNoteSignalMultiModulated+ chunkSize channel (timeModulatedSample instr)+ (applyModulation fm .+ applyModulation speed .+ applyModulation offset))++++colourNoise ::+ SigSt.T Real -> SigSt.T Real ->+ Instrument Real Real+colourNoise resonanceMod freqMod vel freq dur =+ SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $+ ((((sqrt sampleRate/2000 * amplitudeFromVelocity vel) *) . UniFilter.lowpass) ^<<+ UniFilter.causal)+ `Causal.applyFst`+ SigS.zipWith+ (\r f -> UniFilter.parameter $ FiltR.Pole r (f*freq/sampleRate))+ (SigS.fromStorableSignal resonanceMod)+ (SigS.fromStorableSignal freqMod)+ `Causal.apply` NoiseS.white++exampleKeyboardNoisePipe :: IO ()+exampleKeyboardNoisePipe =+ withMIDIEvents play $+ evalState+ (do fm <- getFMSignalFromBendWheelPressure channel+ 2 (10/sampleRate) 0.04 0.03+ resonance <-+ getControllerSignalExp channel+ (VoiceMsg.toController 23)+ (1, 100) 10+ getNoteSignalMultiModulated+ chunkSize channel colourNoise+ (applyModulation fm .+ applyModulation resonance))+++toneFromNoise ::+ SigSt.T Real -> SigSt.T Real ->+ Instrument Real Real+toneFromNoise speedMod freqMod vel freq dur =+ SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $+ (((0.1 * amplitudeFromVelocity vel) *) ^<<+ OsciC.shapeFreqModFromSampledTone+ Ip.linear Ip.linear+ 100 (SigS.toStorableSignal chunkSize NoiseS.white)+ zero zero <<<+ Causal.second (Causal.map ((freq/sampleRate)*)))+ `Causal.applyFst`+ SigS.fromStorableSignal speedMod+ `Causal.apply`+ SigS.fromStorableSignal freqMod++exampleKeyboardNoisyTone :: IO ()+exampleKeyboardNoisyTone =+ withMIDIEvents play $+ evalState+ (do fm <- getFMSignalFromBendWheelPressure channel+ 2 (10/sampleRate) 0.04 0.03+ speed <- getControllerSignal channel+ (VoiceMsg.toController 21)+ (0,0.5) 0.1+ getNoteSignalMultiModulated+ chunkSize channel toneFromNoise+ (applyModulation fm .+ applyModulation speed))++{-+I like to control the filter parameters+before phase and time modulation.+Unfortunately this means,+that we have to translate those control signals back+using the speed profile, which is tricky.+We need an inverse frequency modulation, that is:++freqMod ctrl (invFreqMod ctrl signal) = signal++The problem is, that the chunk boundaries will not match.+invFreqMod must be a StorableSignal function and it is not causal+in any of its inputs.+-}+toneFromFilteredNoise ::+ SigSt.T Real -> SigSt.T Real ->+ SigSt.T Real -> SigSt.T Real ->+ Instrument Real Real+toneFromFilteredNoise resonanceMod cutoffMod speedMod freqMod vel freq dur =+ let period = 100+ filtNoise =+ ((((amplitudeFromVelocity vel) *) . UniFilter.lowpass) ^<<+ UniFilter.causal <<< Causal.feedSnd NoiseS.white+ <<^ (\(r,f) -> UniFilter.parameter $+ FiltR.Pole r (f/period)))+ `Causal.applyFst`+ FiltNRSt.inverseFrequencyModulationFloor chunkSize speedMod resonanceMod+ `Causal.apply`+ FiltNRSt.inverseFrequencyModulationFloor chunkSize speedMod cutoffMod+ in SigStV.take (chunkSizesFromLazyTime dur) $+ (((0.1 * amplitudeFromVelocity vel) *) ^<<+ OsciC.shapeFreqModFromSampledTone+ Ip.linear Ip.linear+ period filtNoise+ zero zero <<<+ Causal.second (Causal.map ((freq/sampleRate)*)))+ `Causal.applyFst` speedMod+ `Causal.apply` freqMod+++exampleKeyboardFilteredNoisyTone :: IO ()+exampleKeyboardFilteredNoisyTone =+ withMIDIEvents play $+ evalState+ (do fm <- getFMSignalFromBendWheelPressure channel+ 2 (10/sampleRate) 0.04 0.03+ {-+ speed must never be zero,+ since this requires to fetch unlimited data from future.+ -}+ speed <- getControllerSignal channel+ (VoiceMsg.toController 21)+ (0.05,0.5) 0.1+ cutoff <- getControllerSignalExp channel+ (VoiceMsg.toController 22)+ (1, 30) 10+ resonance <- getControllerSignalExp channel+ (VoiceMsg.toController 23)+ (1, 20) 5+ getNoteSignalMultiModulated+ chunkSize channel toneFromFilteredNoise+ (applyModulation fm .+ applyModulation speed .+ applyModulation cutoff .+ applyModulation resonance))++ testKeyboard1 :: IO () testKeyboard1 =- withMIDIEventsNonblock defaultSampleRate $- const (playMono defaultSampleRate $ ping 0 440)+ withMIDIEvents play $+ const (ping 0 440) -testKeyboard2 :: SigSt.T Double+testKeyboard2 :: SigSt.T Real testKeyboard2 =- let music :: Double -> EventList.T StrictTime (SigSt.T Double)- music x = 5 /. SigSt.replicate defaultChunkSize 6 x ./ music (x+1)- in CutSt.arrange defaultChunkSize $+ 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 -testKeyboard3 :: SigSt.T Double+testKeyboard3 :: SigSt.T Real testKeyboard3 =- let time :: Double -> Int- time t = round (t * defaultSampleRate)- music :: Double -> EventList.T StrictTime (SigSt.T Double)+ 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) (ping 0 x) ./ music (x*1.01)- in CutSt.arrange defaultChunkSize $+ in CutSt.arrange chunkSize $ EventList.mapTime fromIntegral $ music 110 -makeLazyTime :: Double -> LazyTime+makeLazyTime :: Real -> LazyTime makeLazyTime t = NonNegChunky.fromNumber $ NonNegW.fromNumberMsg "keyboard time" $- round (t * defaultSampleRate)+ round (t * sampleRate) -testKeyboard4 :: SigSt.T Double+normalVelocity :: VoiceMsg.Velocity+normalVelocity =+ VoiceMsg.toVelocity VoiceMsg.normalVelocity++pitch :: Int -> VoiceMsg.Pitch+pitch = VoiceMsg.toPitch++defaultProgram :: VoiceMsg.Program+defaultProgram = VoiceMsg.toProgram 0++embedDefaultProgram ::+ EventListTT.T LazyTime (NoteBoundary Bool) ->+ EventListTT.T LazyTime (NoteBoundary (Maybe VoiceMsg.Program))+embedDefaultProgram =+ EventListTT.mapBody (\(NoteBoundary p v b) ->+ NoteBoundary p v (toMaybe b defaultProgram))++testKeyboard4 :: SigSt.T Real testKeyboard4 = let {-- idInstr :: Double -> Double -> SigSt.T Double- idInstr _vel freq = SigSt.repeat defaultChunkSize freq+ idInstr :: Real -> Real -> SigSt.T Real+ idInstr _vel freq = SigSt.repeat chunkSize freq -} -- inf = time 0.4 + inf- music :: Int -> EventListTT.T LazyTime (Int,Int,LazyTime)+ music :: Int -> EventListTT.T LazyTime Note music p = makeLazyTime 0.2 EventListMT./.--- (p, 64, inf) EventListMT../- (p, 64, makeLazyTime 0.4) EventListMT../+-- (pitch p, normalVelocity, inf) EventListMT../+ Note defaultProgram (pitch p) normalVelocity (makeLazyTime 0.4) EventListMT../ music (p+1)- in CutSt.arrange defaultChunkSize $+ in CutSt.arrange chunkSize $ EventListTM.switchTimeR const $ EventListTT.mapTime fromIntegral $ insertBreaks $ makeInstrumentSounds pingDur $ music 0 -exampleNotes0 :: Int -> EventListTT.T LazyTime (Int,Int,Bool)+exampleNotes0 :: Int -> EventListTT.T LazyTime (NoteBoundary Bool) exampleNotes0 p = makeLazyTime 0.2 EventListMT./.- (let (oct,pc) = divMod p 12 in (50 + pc, 64, even oct)) EventListMT../+ (let (oct,pc) = divMod p 12+ in (NoteBoundary (pitch (50 + pc)) normalVelocity (even oct)))+ EventListMT../ exampleNotes0 (p+1) -exampleNotes1 :: EventListTT.T LazyTime (Int,Int,Bool)+exampleNotes1 :: EventListTT.T LazyTime (NoteBoundary Bool) exampleNotes1 = makeLazyTime 0.2 EventListMT./.- (50, 64, True) EventListMT../+ (NoteBoundary (pitch 50) normalVelocity True) EventListMT../ makeLazyTime 0.2 EventListMT./.- (52, 64, True) EventListMT../+ (NoteBoundary (pitch 52) normalVelocity True) EventListMT../ makeLazyTime 0.2 EventListMT./.- (54, 64, True) EventListMT../+ (NoteBoundary (pitch 54) normalVelocity True) EventListMT../ makeLazyTime 0.2 EventListMT./.--- (50, 64, False) EventListMT../+-- (NoteBoundary (pitch 50) normalVelocity False) EventListMT../ undefined -testKeyboard5 :: SigSt.T Double+testKeyboard5 :: SigSt.T Real testKeyboard5 =- CutSt.arrange defaultChunkSize $+ CutSt.arrange chunkSize $ EventListTM.switchTimeR const $ EventListTT.mapTime fromIntegral $ insertBreaks $ makeInstrumentSounds pingDur $ matchNoteEvents $+ embedDefaultProgram $ exampleNotes0 0 -testKeyboard6 :: EventListTT.T LazyTime (Int,Int,LazyTime)+testKeyboard6 :: EventListTT.T LazyTime Note testKeyboard6 =- matchNoteEvents exampleNotes1+ matchNoteEvents $+ embedDefaultProgram $+ exampleNotes1 -testKeyboard7 :: EventListTT.T LazyTime (Int,Int)+testKeyboard7 :: EventListTT.T LazyTime (VoiceMsg.Pitch, VoiceMsg.Velocity) testKeyboard7 =- EventListTT.mapBody (\ ~(p,v,_b) -> (p,v)) $+ EventListTT.mapBody (\ ~(Note _ p v _d) -> (p,v)) $ testKeyboard6 +testSpeed :: IO ()+testSpeed =+ let _sig =+ Causal.apply+ (softStringCausalProcess 440 <<<+ softStringReleaseEnvelopeCausalProcess 0)+ (SigS.repeat True)+ sig =+ Causal.apply+ (softStringCausalProcess 440)+ (SigS.repeat 1)+ in SV.writeFile "speed.f32" $+ SigS.runViewL sig+ (\next s -> fst $ SV.unfoldrN 1000000 next s)++testSpeedChunky :: IO ()+testSpeedChunky =+ let sig =+ Causal.apply+ (softStringCausalProcess 440 <<<+ 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))+-}++testSpeedArrange :: IO ()+testSpeedArrange =+ let sig =+ Causal.apply+ (softStringCausalProcess 440 <<<+ 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)]++{-+This program has still a very slowly growing memory leak.+-} main :: IO () main =+-- Play.auto 44100 $ OsciSt.static chunkSize Wave.sine zero (800/sampleRate::Real) -- print testKeyboard3--- playMono defaultSampleRate testKeyboard3+-- playMono sampleRate testKeyboard3 -- examplePitchBend -- exampleKeyboard- exampleKeyboardFilter+-- exampleKeyboardStereo+-- exampleKeyboardPitchbend+-- exampleKeyboardFM+-- exampleKeyboardDetuneFM+-- exampleKeyboardFilter+-- exampleKeyboardSample+ exampleKeyboardVariousStereo+-- exampleKeyboardSampleTFM+-- exampleKeyboardNoisyTone+-- exampleKeyboardFilteredNoisyTone+-- testSpeed {-
+ src/RealTimeSynthesizerDim.hs view
@@ -0,0 +1,426 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE Rank2Types #-}+module Main where++import qualified Synthesizer.Dimensional.ALSA.Play as Play+import qualified Synthesizer.Dimensional.ALSA.MIDI as MIDI++import qualified Sound.Alsa as ALSA+import qualified Sound.Alsa.Sequencer as AlsaMidi++import qualified Synthesizer.EventList.ALSA.MIDI as MIDIEv++import qualified Synthesizer.Storable.ALSA.Play as PlaySt++import qualified Synthesizer.Dimensional.Causal.Process as Causal+import qualified Synthesizer.Dimensional.Causal.Oscillator as Osci+import qualified Synthesizer.Dimensional.Causal.Filter as Filt+import qualified Synthesizer.Dimensional.Causal.ControlledProcess as CProc++import qualified Synthesizer.Dimensional.Rate as Rate+import qualified Synthesizer.Dimensional.Rate.Cut as CutR+import qualified Synthesizer.Dimensional.Rate.Control as CtrlR+import qualified Synthesizer.Dimensional.Rate.Oscillator as OsciR+import qualified Synthesizer.Dimensional.Rate.Filter as FiltR+import qualified Synthesizer.Dimensional.Amplitude as Amp+import qualified Synthesizer.Dimensional.Amplitude.Cut as CutA+import qualified Synthesizer.Dimensional.Amplitude.Control as CtrlA+import qualified Synthesizer.Dimensional.Amplitude.Displacement as DispA+import qualified Synthesizer.Dimensional.Amplitude.Flat as Flat+import qualified Synthesizer.Dimensional.Amplitude.Analysis as AnaA+import qualified Synthesizer.Dimensional.Amplitude.Filter as FiltA+import qualified Synthesizer.Dimensional.RateAmplitude.Control as CtrlD+import qualified Synthesizer.Dimensional.ChunkySize.Signal as SigC+import qualified Synthesizer.Dimensional.Signal.Private as SigA+import qualified Synthesizer.Dimensional.Process as Proc+import qualified Synthesizer.Dimensional.Wave as WaveD++import Synthesizer.Dimensional.Causal.Process ((<<<), )+import Synthesizer.Dimensional.Wave ((&*~), )+import Synthesizer.Dimensional.Process (($:), (.:), )+import Synthesizer.Dimensional.Signal ((&*^), )+import Control.Applicative (liftA2, liftA3, )++import qualified Synthesizer.Basic.Wave as Wave+import qualified Synthesizer.Frame.Stereo as Stereo++-- import Foreign.Storable (Storable, )+-- import Data.Int (Int16, )++import qualified Synthesizer.Storable.Signal as SigSt+-- import qualified Synthesizer.State.Signal as SigS++import qualified Sound.MIDI.Message.Channel as ChannelMsg+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg++import qualified Data.EventList.Relative.TimeBody as EventList++-- import qualified Numeric.NonNegative.Class as NonNeg+-- import qualified Numeric.NonNegative.Wrapper as NonNegW+-- import qualified Numeric.NonNegative.ChunkyPrivate as NonNegChunky++import qualified Algebra.Module as Module+import qualified Algebra.RealField as RealField+import qualified Algebra.Field as Field+import qualified Algebra.Ring as Ring++import qualified Algebra.DimensionTerm as Dim+import qualified Number.DimensionTerm as DN++import NumericPrelude+import PreludeBase hiding (break, )+++channel :: ChannelMsg.Channel+channel = ChannelMsg.toChannel 0++sampleRate :: Ring.C a => DN.Frequency a+sampleRate = DN.frequency 48000+-- sampleRate = 44100++latency :: Field.C a => DN.Time a+latency = DN.time 0.01++{-+chunkSize :: SVL.ChunkSize+chunkSize = Play.defaultChunkSize+-}+++type Real = Float+++{-# INLINE withMIDIEvents #-}+withMIDIEvents ::+ Ring.C t =>+ (DN.Frequency t -> a -> IO b) ->+ (EventList.T MIDIEv.StrictTime (Maybe AlsaMidi.Event) -> a) -> IO b+withMIDIEvents action proc =+ MIDIEv.withMIDIEventsNonblock+ (DN.toNumberWithDimension Dim.frequency sampleRate :: Double) $+ action sampleRate . proc++{-# INLINE play #-}+play ::+ (Module.C y yv, ALSA.SampleFmt yv, RealField.C t) =>+ DN.Frequency t ->+ (forall s. Proc.T s Dim.Time t+ (Play.StorableSignal s Dim.Voltage y yv)) ->+ IO ()+play rate sig =+ Play.renderTimeVoltageStorable rate+ (FiltR.delay latency $: sig)+++channelVolume :: VoiceMsg.Controller+channelVolume = VoiceMsg.modulation++exampleVolume :: IO ()+exampleVolume =+ putStrLn "run 'aconnect' to connect to the MIDI controller" >>+ (withMIDIEvents play $+ \evs ->+ liftA3+ (\env osci vol ->+ Causal.apply+ (Causal.applySnd env osci) $ vol)+ Filt.envelopeScalarDimension+ (OsciR.static (DN.voltage 1 &*~ Wave.sine) zero (DN.frequency (880::Real)))+ (MIDI.runFilter evs (MIDI.getControllerSignal channel channelVolume+ (DN.scalar 0, DN.scalar 1) (DN.scalar (1::Real)))))++examplePitchBend :: IO ()+examplePitchBend =+ withMIDIEvents play $+ \evs ->+ liftA2 Causal.apply+ (Osci.freqMod (DN.voltage (1::Real) &*~ Wave.sine) zero)+ (MIDI.runFilter evs (MIDI.getPitchBendSignal channel 2 (DN.frequency (880::Real))))++-- preserve chunk structure of channel volume+exampleVolumePitchBend0 :: IO ()+exampleVolumePitchBend0 =+ putStrLn "run 'aconnect' to connect to the MIDI controller" >>+ (withMIDIEvents play $+ \evs ->+ liftA3+ (\osci env (freq,vol) ->+ Causal.apply+ (Causal.applySnd env (osci $ SigA.restore freq)) $ vol)+ (OsciR.freqMod (DN.voltage 1 &*~ Wave.sine) zero)+ Filt.envelopeScalarDimension+ (MIDI.runFilter evs $ liftA2 (,)+ (MIDI.getPitchBendSignal channel 2 (DN.frequency (880::Real)))+ (MIDI.getControllerSignal channel channelVolume+ (DN.scalar 0, DN.scalar 1) (DN.scalar (1::Real)))))++-- preserve chunk structure of pitch bender+exampleVolumePitchBend1 :: IO ()+exampleVolumePitchBend1 =+ putStrLn "run 'aconnect' to connect to the MIDI controller" >>+ (withMIDIEvents play $+ \evs ->+ liftA3+ (\osci env (freq,vol) ->+ Causal.apply+ (Causal.applyFst env (SigA.restore vol) <<< osci)+ freq)+ (Osci.freqMod (DN.voltage 1 &*~ Wave.sine) zero)+ Filt.envelopeScalarDimension+ (MIDI.runFilter evs $ liftA2 (,)+ (MIDI.getPitchBendSignal channel 2 (DN.frequency (880::Real)))+ (MIDI.getControllerSignal channel channelVolume+ (DN.scalar 0, DN.scalar 1) (DN.scalar (1::Real)))))+++{-# INLINE ping #-}+ping :: MIDI.Instrument s Dim.Time Dim.Voltage Real Real+ping vel freq =+ fmap (flip SigC.store)+ (FiltR.envelope+ $: CtrlR.exponential2 (DN.time 0.2)+ $: OsciR.static (DN.voltage (4**vel) &*~ Wave.saw) zero freq)+++exampleKeyboard :: IO ()+exampleKeyboard =+ withMIDIEvents play $+ \evs ->+ MIDI.runFilter evs+ (MIDI.getNoteSignal PlaySt.defaultChunkSize (DN.voltage 1) channel ping)+++{-+Generating the envelope requires great care:+ - you must avoid an append function that determines the common volume automatically,+ because the volume of the second part is only known after the first part is complete+ - you must terminate the release phase,+ otherwise you get an infinite signal for every played note+-}+{-# INLINE pingReleaseEnvelope #-}+pingReleaseEnvelope ::+ Real ->+ Proc.T s Dim.Time Real+ (MIDI.LazyTime s ->+ SigA.T (Rate.Phantom s) (Amp.Dimensional Dim.Scalar Real) (SigSt.T Real))+pingReleaseEnvelope vel =+ Proc.withParam $ \dur ->+ do decay <-+ fmap (SigC.store dur) $+ CtrlR.exponential2 (DN.time 0.4)+ end <- fmap (AnaA.endPrimitive zero) $ fmap ($decay) SigA.embedSampleRate+ release <-+ SigA.store (DN.time 0.01) $:+ (CutR.take (DN.time 0.3) $:+ fmap Flat.canonicalize+ (DN.scalar end &*^ CtrlR.exponential2 (DN.time 0.1)))+ append <- CutR.append+ return $ (DispA.inflate (DN.fromNumber $ 4**vel) (append decay release))+-- return $ DispA.inflate (DN.fromNumber $ 4**vel) decay++{-+ Proc.withParam $ \dur ->+ liftA2+ (\embed env ->+ let x = SigC.store dur env+ y = AnaA.end $ embed x+ in )+ SigA.embedSampleRate+ (FiltR.envelope+ $: CtrlR.exponential2 (DN.time 0.2)+ $: OsciR.static (DN.voltage (4**vel) &*~ Wave.saw) zero freq)+-}++{-# INLINE pingRelease #-}+pingRelease :: MIDI.Instrument s Dim.Time Dim.Voltage Real Real+pingRelease vel freq =+ liftA3+ (\env ctrl osci dur ->+ Causal.apply+ (env <<< Causal.feedSnd osci)+ (ctrl dur))+ Filt.envelopeScalarDimension+ (pingReleaseEnvelope vel)+ (OsciR.static (DN.voltage 1 &*~ Wave.saw) zero freq)+++exampleKeyboardMulti :: IO ()+exampleKeyboardMulti =+ withMIDIEvents play $+ \evs ->+ MIDI.runFilter evs+ (MIDI.getNoteSignalMultiProgram PlaySt.defaultChunkSize (DN.voltage 1) channel+ (VoiceMsg.toProgram 0)+ [ping, pingRelease])+-- [string])+++{-# INLINE pingReleaseFM #-}+pingReleaseFM ::+ MIDI.ModulatedInstrument s Dim.Time Real+ (MIDI.Signal s Dim.Scalar Real Real ->+ MIDI.Signal s Dim.Voltage Real Real)+pingReleaseFM vel freq =+ liftA3+ (\env ctrl osci dur fm ->+ Causal.apply+ (env <<<+ Causal.feedSnd (osci (FiltA.amplifyScalarDimension freq $ SigA.restore fm)))+ (ctrl dur))+ Filt.envelopeScalarDimension+ (pingReleaseEnvelope vel)+ (OsciR.freqMod (DN.voltage 1 &*~ Wave.saw) zero)++exampleKeyboardFM :: IO ()+exampleKeyboardFM =+ withMIDIEvents play $+ \evs ->+ fmap (FiltA.amplify 0.3) $+ (MIDI.runFilter evs+ (MIDI.getNoteSignalModulated PlaySt.defaultChunkSize (DN.voltage 1) channel pingReleaseFM $:+ MIDI.getFMSignalFromBendWheelPressure channel 2 (DN.frequency 10) 0.04 0.03))+-- MIDI.getPitchBendSignal channel (2 ** recip 12) (DN.scalar one)))+++{-# INLINE pingStereoDetuneFM #-}+pingStereoDetuneFM ::+ MIDI.ModulatedInstrument s Dim.Time Real+ (MIDI.Signal s Dim.Scalar Real Real ->+ MIDI.Signal s Dim.Scalar Real Real ->+ MIDI.Signal s Dim.Voltage Real (Stereo.T Real))+pingStereoDetuneFM vel freq =+ liftA3+ (\env ctrl osci dur detuneSt fmSt ->+ let fm = SigA.restore fmSt+ detune = SigA.restore detuneSt+ osciChan d =+ osci (FiltA.amplifyScalarDimension freq+ (FiltA.envelope (DispA.raise 1 d) fm))+ in SigA.rewriteAmplitudeDimension Dim.identityLeft $+ Causal.apply+ (env <<<+ Causal.feedSnd (CutA.mergeStereo+ (osciChan detune)+ (osciChan $ FiltA.negate detune)))+ (ctrl dur))+ Filt.envelopeVectorDimension+ (pingReleaseEnvelope vel)+ (OsciR.freqMod (DN.voltage 1 &*~ Wave.saw) zero)++extraController :: VoiceMsg.Controller+extraController =+ VoiceMsg.vectorX+-- VoiceMsg.toController 21++extraController1 :: VoiceMsg.Controller+extraController1 =+ VoiceMsg.modulation+-- VoiceMsg.vectorY+-- VoiceMsg.toController 22+++exampleKeyboardDetuneFM :: IO ()+exampleKeyboardDetuneFM =+ withMIDIEvents play $+ \evs ->+ fmap (FiltA.amplify 0.3) $+ (MIDI.runFilter evs+ (MIDI.getNoteSignalMultiModulated PlaySt.defaultChunkSize (DN.voltage 1) channel pingStereoDetuneFM+ (fmap MIDI.applyModulation+ (MIDI.getFMSignalFromBendWheelPressure channel 2 (DN.frequency 10) 0.04 0.03) .:+ fmap MIDI.applyModulation+ (MIDI.getControllerSignal channel extraController (0, 0.005) 0))+ ))+++{- INLINE stringReleaseEnvelope -}+stringReleaseEnvelope ::+ Real ->+ Proc.T s Dim.Time Real+ (MIDI.LazyTime s ->+ SigA.T (Rate.Phantom s) (Amp.Dimensional Dim.Scalar Real) (SigSt.T Real))+stringReleaseEnvelope vel =+ Proc.withParam $ \dur ->+ do let attackTime = DN.time 1+ cnst <- CtrlR.constant+ {-+ release <- take attackTime beginning+ would yield a space leak, thus we first split 'beginning'+ and then concatenate it again+ -}+ {-+ We can not easily generate attack and sustain separately,+ because we want to use the chunk structure implied by 'dur'.+ -}+ (attack, sustain) <-+ CutR.splitAt attackTime $:+ (fmap (SigC.store dur .+ flip CutA.appendPrimitive cnst .+ DispA.map sin . Flat.canonicalize)+ (CtrlD.line attackTime (0, DN.scalar (pi/2))))+ let release = CutA.reverse attack+-- infixr 5 append+ append <- CutR.append+ return $+ DispA.inflate (DN.fromNumber $ 4**vel) $+ attack `append` sustain `append` release++{- INLINE string -}+string ::+ MIDI.ModulatedInstrument s Dim.Time Real+ (MIDI.Signal s Dim.Voltage Real (Stereo.T Real))+string vel freq =+ liftA3+ (\env ctrl osci dur ->+ SigA.rewriteAmplitudeDimension Dim.identityLeft $+ Causal.apply+ (env <<< Causal.feedSnd osci)+ (ctrl dur))+ Filt.envelopeVectorDimension+ (stringReleaseEnvelope vel)+ (Proc.pure CutA.mergeStereo+ $: (Proc.pure DispA.mix+ $: OsciR.static (DN.voltage 0.5 &*~ Wave.saw) zero (DN.scale 1.005 freq)+ $: OsciR.static (DN.voltage 0.5 &*~ Wave.saw) zero (DN.scale 0.998 freq))+ $: (Proc.pure DispA.mix+ $: OsciR.static (DN.voltage 0.5 &*~ Wave.saw) zero (DN.scale 1.002 freq)+ $: OsciR.static (DN.voltage 0.5 &*~ Wave.saw) zero (DN.scale 0.995 freq)))+++exampleKeyboardFilter :: IO ()+exampleKeyboardFilter =+ withMIDIEvents play $+ \evs ->+ liftA3+ (\osci filt (music,speed,depth) ->+ (Filt.lowpassFromUniversal <<<+ filt (CtrlA.constant 10)+ (DispA.mapExponential 4 (DN.frequency 1000) $+ FiltA.envelope (SigA.restore depth) $+ osci (SigA.restore speed)))+ `Causal.apply`+ FiltA.amplify 0.2 music)+ (OsciR.freqMod (WaveD.flat Wave.sine) zero)+ (CProc.runSynchronous2 Filt.universal)+-- FiltR.universal+ (MIDI.runFilter evs+ (liftA3 (,,)+ (MIDI.getNoteSignal PlaySt.defaultChunkSize (DN.voltage 1) channel string)+ (MIDI.getControllerSignalExp channel extraController+ (DN.frequency 0.1, DN.frequency 5) (DN.frequency 0.2))+ (MIDI.getControllerSignal channel extraController1+ (0, 1 :: DN.Scalar Real) 0.5)+ ))++++main :: IO ()+main =+-- exampleVolume+-- examplePitchBend+-- exampleVolumePitchBend1+-- exampleKeyboard+ exampleKeyboardMulti+-- exampleKeyboardFM+-- exampleKeyboardDetuneFM+-- exampleKeyboardFilter
+ src/Synthesizer/Dimensional/ALSA/MIDI.hs view
@@ -0,0 +1,444 @@+{- |+Convert MIDI events of a MIDI controller to a control signal.+-}+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Dimensional.ALSA.MIDI where++import Synthesizer.EventList.ALSA.MIDI (Channel, Controller, Note(Note), Program, )+import qualified Synthesizer.EventList.ALSA.MIDI as AlsaEL+import qualified Synthesizer.Storable.ALSA.MIDI as AlsaSt++import qualified Sound.Alsa.Sequencer as ALSA++import qualified Synthesizer.Dimensional.Causal.Process as Causal+import qualified Synthesizer.Dimensional.Causal.Filter as Filt++import qualified Synthesizer.Dimensional.Rate as Rate+import qualified Synthesizer.Dimensional.Rate.Oscillator as OsciR+import qualified Synthesizer.Dimensional.Signal.Private as SigA+import qualified Synthesizer.Dimensional.Process as Proc+import qualified Synthesizer.Dimensional.Amplitude as Amp+import qualified Synthesizer.Dimensional.Amplitude.Displacement as DispA+import qualified Synthesizer.Dimensional.Amplitude.Filter as FiltA+import qualified Synthesizer.Dimensional.Wave as WaveD+-- import qualified Synthesizer.Dimensional.RateAmplitude.Cut as CutA++import qualified Synthesizer.Basic.Wave as Wave++import Synthesizer.Dimensional.Causal.Process ((<<<), )+import Synthesizer.Dimensional.Process (($:), )++import qualified Synthesizer.ChunkySize as ChunkySize++import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Storable.Cut as CutSt+import qualified Synthesizer.Storable.Signal as SigSt+-- import qualified Data.StorableVector.Lazy.Pattern as SigStV+import qualified Data.StorableVector.Lazy as SVL++import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg++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.MixedTime as EventListMT+-- import qualified Data.EventList.Relative.BodyTime as EventListBT++import Foreign.Storable (Storable, )++-- import qualified Algebra.NonNegative as NonNeg+import qualified Number.NonNegative as NonNegW+import qualified Number.NonNegativeChunky as Chunky++-- import qualified Numeric.NonNegative.Class as NonNeg98+-- import qualified Numeric.NonNegative.Wrapper as NonNegW98+import qualified Numeric.NonNegative.Chunky as Chunky98++import qualified Algebra.DimensionTerm as Dim+import qualified Number.DimensionTerm as DN++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Module as Module+import qualified Algebra.RealField as RealField+import qualified Algebra.Field as Field+import qualified Algebra.Additive as Additive++import Control.Applicative (Applicative, pure, (<*>), liftA2, )+import Control.Monad.Trans.State (State, evalState, state, gets, )+import Control.Monad (liftM, )++import PreludeBase+import NumericPrelude+import Prelude (RealFrac, )+++type Signal s v y yv =+ AmpSignal s (Amp.Dimensional v y) yv++type AmpSignal s amp yv =+ SigA.T (Rate.Phantom s) amp (SigSt.T yv)++{- |+This type ensures that all signals generated from the event list+share the same sample rate.+-}+newtype Filter s u t a =+ Filter (AlsaEL.Filter (Proc.T s u t a))++{-# INLINE runFilter #-}+runFilter ::+ EventList.T AlsaEL.StrictTime (Maybe ALSA.Event) ->+ Filter s u t a -> Proc.T s u t a+runFilter evs (Filter f) =+ evalState f evs++instance Functor (Filter s u t) where+ fmap f (Filter flt) =+ Filter (fmap (fmap f) flt)++instance Applicative (Filter s u t) where+ pure x = Filter (pure (pure x))+ Filter f <*> Filter x =+ Filter (liftA2 (<*>) f x)+++{-# INLINE controllerValueToSample #-}+controllerValueToSample ::+ (Field.C y, Dim.C v) =>+ DN.T v y -> (DN.T v y, DN.T v y) -> Int -> y+controllerValueToSample amp (lower,upper) n =+ let k = fromIntegral n / 127+ in DN.divToScalar (DN.scale (1-k) lower + DN.scale k upper) amp++{-# INLINE getControllerSignal #-}+getControllerSignal ::+ (Storable y, Field.C y, Ord y, Dim.C u, Dim.C v) =>+ Channel -> Controller ->+ (DN.T v y, DN.T v y) -> DN.T v y ->+ Filter s u t (Signal s v y y)+getControllerSignal chan ctrl bnd initial =+ Filter $+ liftM+ (let amp = max initial (uncurry max bnd)+ in return . SigA.fromBody amp .+ AlsaSt.controllerValuesToSignal (DN.divToScalar initial amp) .+ EventListTT.mapBody (controllerValueToSample amp bnd)) $+ AlsaEL.getControllerEvents chan ctrl+++{-# INLINE controllerValueToSampleExp #-}+controllerValueToSampleExp ::+ (Trans.C y, Dim.C v) =>+ DN.T v y -> (DN.T v y, DN.T v y) -> Int -> y+controllerValueToSampleExp amp (lower,upper) n =+ let k = fromIntegral n / 127+ in DN.divToScalar lower amp ** (1-k) *+ DN.divToScalar upper amp ** k++{-# INLINE getControllerSignalExp #-}+getControllerSignalExp ::+ (Storable y, Trans.C y, Ord y, Dim.C u, Dim.C v) =>+ Channel -> Controller ->+ (DN.T v y, DN.T v y) -> DN.T v y ->+ Filter s u t (Signal s v y y)+getControllerSignalExp chan ctrl bnd initial =+ Filter $+ liftM+ (let amp = max initial (uncurry max bnd)+ in return . SigA.fromBody amp .+ AlsaSt.controllerValuesToSignal (DN.divToScalar initial amp) .+ EventListTT.mapBody (controllerValueToSampleExp amp bnd)) $+ AlsaEL.getControllerEvents chan ctrl+++{-# INLINE pitchBendValueToSample #-}+pitchBendValueToSample ::+ (Trans.C y, Dim.C v) =>+ DN.T v y -> y -> DN.T v y -> Int -> y+pitchBendValueToSample amp range center n =+ DN.divToScalar center amp * range ** (fromIntegral n / 8192)++{- |+@getPitchBendSignal channel range center@:+emits frequencies on an exponential scale from+@center/range@ to @center*range@.+-}+{-# INLINE getPitchBendSignal #-}+getPitchBendSignal ::+ (Storable y, Trans.C y, Ord y, Dim.C u, Dim.C v) =>+ Channel ->+ y -> DN.T v y ->+ Filter s u t (Signal s v y y)+getPitchBendSignal chan range center =+ Filter $+ liftM+ (let amp = DN.scale (max range (recip range)) center+ in return . SigA.fromBody amp .+ AlsaSt.controllerValuesToSignal (DN.divToScalar center amp) .+ EventListTT.mapBody (pitchBendValueToSample amp range center)) $+ AlsaEL.getSlice (AlsaEL.maybePitchBend chan)+-- AlsaEL.getPitchBendEvents chan+++{-# INLINE getChannelPressureSignal #-}+getChannelPressureSignal ::+ (Storable y, Trans.C y, Ord y, Dim.C u, Dim.C v) =>+ Channel ->+ DN.T v y -> DN.T v y ->+ Filter s u t (Signal s v y y)+getChannelPressureSignal chan maxVal initVal =+ Filter $+ liftM+ (return . SigA.fromBody maxVal .+ AlsaSt.controllerValuesToSignal (DN.divToScalar initVal maxVal) .+ EventListTT.mapBody (controllerValueToSample maxVal (zero,maxVal))) $+ AlsaEL.getSlice (AlsaEL.maybeChannelPressure chan)+-- AlsaEL.getPitchBendEvents chan+++{-# INLINE getFMSignalFromBendWheelPressure #-}+getFMSignalFromBendWheelPressure ::+ (Storable q, RealField.C q, Trans.C q, Module.C q q, Dim.C u) =>+ Channel ->+ Int -> DN.T (Dim.Recip u) q -> q -> q ->+ Filter s u q (Signal s Dim.Scalar q q)+getFMSignalFromBendWheelPressure chan+ pitchRange speed wheelDepth pressDepth =+ pure+ (\bend fm press osci env ->+ let modu =+ DispA.raise 1 $+ FiltA.envelope+ osci+ (DispA.mix+ (SigA.restore fm)+ (SigA.restore press))++ in Causal.apply+ (env <<< Causal.feedSnd modu <<< Causal.canonicalizeFlat)+ bend)++ $: getPitchBendSignal chan (2^?(fromIntegral pitchRange/12)) (DN.scalar 1)+ $: getControllerSignal chan VoiceMsg.modulation (zero, DN.scalar wheelDepth) zero+ $: getChannelPressureSignal chan (DN.scalar pressDepth) 0++ $: Filter (return $ OsciR.static (WaveD.flat Wave.sine) zero speed)+ $: Filter (return $ Filt.envelope)+++type LazyTime s = SigA.T (Rate.Phantom s) Amp.Abstract ChunkySize.T+-- type LazyTime s = SigA.T (Rate.Phantom s) Amp.Abstract SigStV.LazySize+-- type LazyTime s = SigA.T (Rate.Phantom s) Amp.Abstract AlsaEL.LazyTime++type Instrument s u v q y =+ ModulatedInstrument s u q (Signal s v q y)++type ModulatedInstrument s u q signal =+ q -> DN.T (Dim.Recip u) q ->+ Proc.T s u q (LazyTime s -> signal)++type Bank s u q signal =+ Program -> ModulatedInstrument s u q signal+++{-# INLINE chunkySizeFromLazyTime #-}+chunkySizeFromLazyTime :: AlsaEL.LazyTime -> ChunkySize.T+chunkySizeFromLazyTime =+ Chunky.fromChunks .+ map (SigG.LazySize . fromInteger . NonNegW.toNumber) .+ Chunky98.toChunks .+ Chunky98.normalize+++{-# INLINE renderInstrument #-}+renderInstrument ::+ (Trans.C q) =>+ Bank s Dim.Time q signal ->+ Note ->+ Proc.T s Dim.Time q signal+renderInstrument instrument (Note pgm pitch vel dur) =+ fmap ($ SigA.abstractFromBody $ chunkySizeFromLazyTime dur) $+ instrument pgm+ (fromIntegral (VoiceMsg.fromVelocity vel - 64)/63)+ {- This is the default tuning according to MIDI 1.0 Detailed Specification -}+ (DN.scale+ (2 ** (fromIntegral (VoiceMsg.fromPitch pitch + 3 - 6*12) / 12))+ (DN.frequency 440))++{- |+Instrument parameters are:+velocity from -1 to 1+(0 is the normal pressure, no pressure aka NoteOff is not supported),+frequency is given in Hertz+-}+{-# INLINE makeInstrumentSounds #-}+makeInstrumentSounds ::+ (Trans.C q) =>+ Bank s Dim.Time q signal ->+ EventListTT.T time Note ->+ Proc.T s Dim.Time q (EventListTT.T time signal)+makeInstrumentSounds bank =+ EventListTT.mapBodyM (renderInstrument bank)+++{-# INLINE getNoteSignal #-}+getNoteSignal ::+ (RealFrac q, Storable y, Module.C q y, Trans.C q, Dim.C v) =>+ SVL.ChunkSize ->+ DN.T v q ->+ Channel ->+ Instrument s Dim.Time v q y ->+ Filter s Dim.Time q (Signal s v q y)+getNoteSignal chunkSize amp chan instr =+ fmap (renderNoteSignal chunkSize amp) $+ prepareTones chan AlsaSt.errorNoProgram (const instr)++{-+{-# INLINE getNoteSignal #-}+getNoteSignal ::+ (RealFrac q, Storable y, Module.C q y, Trans.C q, Dim.C v) =>+ SVL.ChunkSize ->+ DN.T v q ->+ Channel ->+ Instrument s Dim.Time v q y ->+ Filter (Proc.T s Dim.Time q (Signal s v q y))+getNoteSignal chunkSize amp chan instr =+ fmap ((CutA.arrangeStorableVolume undefined {- chunkSize -} amp undefined $:) .+ fmap+ (EventListTM.switchTimeR const .+ EventListTT.mapTime fromIntegral .+ AlsaSt.insertBreaksGen (SigA.fromBody amp SigSt.empty)) .+ makeInstrumentSounds instr .+ AlsaEL.matchNoteEvents) $+ AlsaEL.getNoteEvents chan+-}+++{-# INLINE getNoteSignalModulated #-}+getNoteSignalModulated ::+ (RealFrac q, Storable y, Storable c,+ Module.C q y, Trans.C q, Dim.C v) =>+ SVL.ChunkSize ->+ DN.T v q ->+ Channel ->+ ModulatedInstrument s Dim.Time q+ (AmpSignal s amp c -> Signal s v q y) ->+ Filter s Dim.Time q+ (AmpSignal s amp c -> Signal s v q y)+getNoteSignalModulated chunkSize amp chan instr =+ fmap (flip $ \ctrl ->+ renderNoteSignal chunkSize amp .+ applyModulation ctrl) $+ prepareTones chan AlsaSt.errorNoProgram (const instr)++{-# INLINE getNoteSignalModulated2 #-}+getNoteSignalModulated2 ::+ (RealFrac q, Storable y, Storable c0, Storable c1,+ Module.C q y, Trans.C q, Dim.C v) =>+ SVL.ChunkSize ->+ DN.T v q ->+ Channel ->+ ModulatedInstrument s Dim.Time q+ (AmpSignal s amp0 c0 -> AmpSignal s amp1 c1 -> Signal s v q y) ->+ Filter s Dim.Time q+ (AmpSignal s amp0 c0 -> AmpSignal s amp1 c1 -> Signal s v q y)+getNoteSignalModulated2 chunkSize amp chan instr =+ fmap (\evs ctrl0 ctrl1 ->+ renderNoteSignal chunkSize amp .+ applyModulation ctrl1 .+ applyModulation ctrl0+ $ evs) $+ prepareTones chan AlsaSt.errorNoProgram (const instr)+++{-# INLINE getNoteSignalMultiModulated #-}+getNoteSignalMultiModulated ::+ (RealFrac q, Storable y,+ Module.C q y, Trans.C q, Dim.C v) =>+ SVL.ChunkSize ->+ DN.T v q ->+ Channel ->+ ModulatedInstrument s Dim.Time q instrument ->+ Filter s Dim.Time q+ (EventListTT.T AlsaEL.LazyTime instrument ->+ EventListTT.T AlsaEL.LazyTime (Signal s v q y)) ->+ Filter s Dim.Time q (Signal s v q y)+getNoteSignalMultiModulated chunkSize amp chan instr modu =+ fmap (renderNoteSignal chunkSize amp) $+ (modu $:+ prepareTones chan AlsaSt.errorNoProgram (const instr))++{-# INLINE prepareTones #-}+prepareTones ::+ (RealFrac q, Trans.C q) =>+ -- ToDo: use time value+ Channel ->+ Program ->+ Bank s Dim.Time q signal ->+ Filter s Dim.Time q (EventListTT.T AlsaEL.LazyTime signal)+prepareTones chan initPgm instr =+ Filter $+ fmap (makeInstrumentSounds instr .+ AlsaEL.matchNoteEvents .+ AlsaEL.embedPrograms initPgm) $+ AlsaEL.getNoteEvents chan++{-# INLINE applyModulation #-}+applyModulation ::+ (Storable y) =>+ AmpSignal s amp y ->+ EventListTT.T AlsaEL.LazyTime (AmpSignal s amp y -> body) ->+ EventListTT.T AlsaEL.LazyTime body+applyModulation ctrl =+ flip evalState ctrl .+ EventListTT.mapM advanceModulationChunky gets++{-# INLINE renderNoteSignal #-}+renderNoteSignal ::+ (Storable y, Module.C q y, Dim.C u, Field.C q) =>+ SVL.ChunkSize ->+ DN.T u q ->+ EventListTT.T AlsaEL.LazyTime (Signal s u q y) ->+ Signal s u q y+renderNoteSignal chunkSize amp =+ SigA.fromBody amp .+ CutSt.arrangeEquidist chunkSize .+ EventListTM.switchTimeR const .+ EventListTT.mapTime fromIntegral .+ AlsaSt.insertBreaks .+ EventListTT.mapBody (SigA.vectorSamples (flip DN.divToScalar amp))+++{-# INLINE advanceModulationChunky #-}+advanceModulationChunky ::+ (Storable y) =>+ AlsaEL.LazyTime -> State (AmpSignal s amp y) AlsaEL.LazyTime+advanceModulationChunky =+ liftM Chunky98.fromChunks .+ mapM advanceModulationChunk .+ Chunky98.toChunks++{-# INLINE advanceModulationChunk #-}+advanceModulationChunk ::+ (Storable y) =>+ NonNegW.Integer -> State (AmpSignal s amp y) NonNegW.Integer+advanceModulationChunk t = state $ \xs ->+ let ys = SigA.processBody (SigSt.drop (fromIntegral t)) xs+ in (AlsaSt.evaluateVectorHead (SigA.body ys) t, ys)+++{-# INLINE getNoteSignalMultiProgram #-}+getNoteSignalMultiProgram ::+ (RealFrac q, Storable y, Module.C q y, Trans.C q, Dim.C v) =>+ SVL.ChunkSize ->+ DN.T v q ->+ Channel ->+ Program ->+-- Bank s Dim.Time q (Signal s v q y) ->+ [Instrument s Dim.Time v q y] ->+ Filter s Dim.Time q (Signal s v q y)+getNoteSignalMultiProgram chunkSize amp chan initPgm instrs =+ let bank = AlsaEL.makeInstrumentArray instrs+ in fmap (renderNoteSignal chunkSize amp) $+ prepareTones chan initPgm $+ AlsaEL.getInstrumentFromArray bank initPgm
+ src/Synthesizer/Dimensional/ALSA/Play.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE Rank2Types #-}+module Synthesizer.Dimensional.ALSA.Play where++import qualified Synthesizer.Storable.ALSA.Play as Play++import qualified Synthesizer.Dimensional.Rate as Rate+import qualified Synthesizer.Dimensional.Amplitude as Amp++import qualified Synthesizer.Dimensional.Process as Proc+import qualified Synthesizer.Dimensional.Signal.Private as SigA++import qualified Synthesizer.Frame.Stereo as Stereo++import qualified Synthesizer.Storable.Signal as SigSt++import qualified Sound.Alsa as ALSA++import qualified Algebra.DimensionTerm as Dim+import qualified Number.DimensionTerm as DN++-- import qualified Algebra.ToInteger as ToInteger+import qualified Algebra.Module as Module+import qualified Algebra.RealField as RealField+-- import qualified Algebra.Field as Field+-- import qualified Algebra.Ring as Ring++import Foreign.Storable (Storable, )++-- import NumericPrelude+import PreludeBase+++type RenderedStorableSignal u t v y yv =+ SigA.T (Rate.Dimensional u t) (Amp.Dimensional v y) (SigSt.T yv)++type StorableSignal s v y yv =+ SigA.T (Rate.Phantom s) (Amp.Dimensional v y) (SigSt.T yv)+++{-# INLINE timeVoltageStorable #-}+timeVoltageStorable ::+ (Module.C y yv, ALSA.SampleFmt yv, RealField.C t) =>+ RenderedStorableSignal Dim.Time t Dim.Voltage y yv ->+ IO ()+timeVoltageStorable sig =+ let rate = DN.toNumberWithDimension Dim.frequency (SigA.actualSampleRate sig)+ in Play.auto (RealField.round rate)+ (SigA.vectorSamples (DN.toNumberWithDimension Dim.voltage) sig)++{-# INLINE timeVoltageMonoStorableToInt16 #-}+timeVoltageMonoStorableToInt16 ::+ (Storable y, RealField.C y, RealField.C t) =>+ RenderedStorableSignal Dim.Time t Dim.Voltage y y ->+ IO ()+timeVoltageMonoStorableToInt16 sig =+ let rate = DN.toNumberWithDimension Dim.frequency (SigA.actualSampleRate sig)+ in Play.monoToInt16 (RealField.round rate)+ (SigA.scalarSamples (DN.toNumberWithDimension Dim.voltage) sig)++{-# INLINE timeVoltageStereoStorableToInt16 #-}+timeVoltageStereoStorableToInt16 ::+ (Storable y, Module.C y y, RealField.C y, RealField.C t) =>+ RenderedStorableSignal Dim.Time t Dim.Voltage y (Stereo.T y) ->+ IO ()+timeVoltageStereoStorableToInt16 sig =+ let rate = DN.toNumberWithDimension Dim.frequency (SigA.actualSampleRate sig)+ in Play.stereoToInt16 (RealField.round rate)+ (SigA.vectorSamples (DN.toNumberWithDimension Dim.voltage) sig)+++{-# INLINE renderTimeVoltageStorable #-}+renderTimeVoltageStorable ::+ (Module.C y yv, ALSA.SampleFmt yv, RealField.C t) =>+ DN.T Dim.Frequency t ->+ (forall s. Proc.T s Dim.Time t+ (StorableSignal s Dim.Voltage y yv)) ->+ IO ()+renderTimeVoltageStorable rate sig =+ timeVoltageStorable (SigA.render rate sig)++{-# INLINE renderTimeVoltageMonoStorableToInt16 #-}+renderTimeVoltageMonoStorableToInt16 ::+ (Storable y, RealField.C y, RealField.C t) =>+ DN.T Dim.Frequency t ->+ (forall s. Proc.T s Dim.Time t+ (StorableSignal s Dim.Voltage y y)) ->+ IO ()+renderTimeVoltageMonoStorableToInt16 rate sig =+ timeVoltageMonoStorableToInt16 (SigA.render rate sig)++{-# INLINE renderTimeVoltageStereoStorableToInt16 #-}+renderTimeVoltageStereoStorableToInt16 ::+ (Storable y, Module.C y y, RealField.C y, RealField.C t) =>+ DN.T Dim.Frequency t ->+ (forall s. Proc.T s Dim.Time t+ (StorableSignal s Dim.Voltage y (Stereo.T y))) ->+ IO ()+renderTimeVoltageStereoStorableToInt16 rate sig =+ timeVoltageStereoStorableToInt16 (SigA.render rate sig)
+ src/Synthesizer/EventList/ALSA/MIDI.hs view
@@ -0,0 +1,637 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.EventList.ALSA.MIDI where++import qualified Sound.Alsa.Sequencer as ALSA++import qualified Data.EventList.Relative.TimeBody as EventList+import qualified Data.EventList.Relative.TimeTime as EventListTT+import qualified Data.EventList.Relative.MixedBody as EventListMB+-- import qualified Data.EventList.Relative.BodyMixed as EventListBM+import qualified Data.EventList.Relative.TimeMixed as EventListTM+import qualified Data.EventList.Relative.MixedTime as EventListMT+import qualified Data.EventList.Relative.BodyTime as EventListBT+import qualified Data.EventList.Absolute.TimeBody as AbsEventList++import qualified Sound.MIDI.Message.Channel as ChannelMsg++import System.IO.Unsafe (unsafeInterleaveIO, )+import Control.Concurrent (threadDelay)+import System.Time (ClockTime(TOD), getClockTime, )+import Control.Exception (bracket, )++import Control.Monad.Trans.State (State, state, evalState, modify, get, gets, put, )++-- import qualified Numeric.NonNegative.Class as NonNeg+import qualified Numeric.NonNegative.Wrapper as NonNegW+import qualified Numeric.NonNegative.ChunkyPrivate as NonNegChunky+import Data.Monoid (Monoid, mappend, mempty, )++import qualified Algebra.RealField as RealField+import qualified Algebra.Field as Field+-- import qualified Algebra.Additive as Additive++import Data.Array (Array, listArray, (!), bounds, inRange, )++import Data.Tuple.HT (mapPair, mapSnd, )+import Data.Maybe.HT (toMaybe, )+import Data.Maybe (isNothing, )+import Control.Monad (liftM, liftM2, guard, )++import NumericPrelude+import PreludeBase hiding (break, )++-- import Debug.Trace (trace, )+++{- |+The @time@ type needs high precision,+so you will certainly have to instantiate it with 'Double'.+'Float' has definitely not enough bits.+-}+getTimeSeconds :: Field.C time => IO time+getTimeSeconds =+ fmap clockTimeToSeconds getClockTime++clockTimeToSeconds :: Field.C time => ClockTime -> time+clockTimeToSeconds (TOD secs picos) =+ fromInteger secs + fromInteger picos * 1e-12++wait :: RealField.C time => time -> IO ()+wait t1 =+ do t0 <- getTimeSeconds+ threadDelay $ floor $ 1e6*(t1-t0)+++{-+We cannot easily turn this into a custom type,+since we need Maybe ALSA.Event sometimes.+-}+type StampedEvent time = (time, ALSA.Event)+++{- |+only use it for non-blocking sequencers++We ignore ALSA time stamps and use the time of fetching the event,+because I don't know whether the ALSA time stamps are in sync with getClockTime.+-}+getStampedEvent :: Field.C time =>+ ALSA.SndSeq -> IO (StampedEvent time)+getStampedEvent h =+ liftM2 (,)+ getTimeSeconds+ (ALSA.event_input h)++{- | only use it for non-blocking sequencers -}+getWaitingStampedEvents :: Field.C time =>+ ALSA.SndSeq -> IO [StampedEvent time]+getWaitingStampedEvents h =+ let loop =+ ALSA.alsa_catch+ (liftM2 (:) (getStampedEvent h) loop)+ (const $ return [])+ in loop+++getWaitingEvents :: ALSA.SndSeq -> IO [ALSA.Event]+getWaitingEvents h =+ let loop =+ ALSA.alsa_catch+ (liftM2 (:) (ALSA.event_input h) loop)+ (const $ return [])+ in loop++++{-+This should be a parameter for the functions, that use it.+It is essential for controlling the maximum chunk size.+-}+beat :: Field.C time => time+beat = 0.01+++type StrictTime = NonNegW.Integer++{-+ghc -i:src -e 'withMIDIEventsNonblock 44100 print' src/Synthesizer/Storable/ALSA/MIDI.hs+-}+{-+as a quick hack, we neglect the ALSA time stamp and use getTime or so++Maybe it is better to not use type variable for sample rate,+because ALSA supports only integers,+and if ALSA sample rate and sample rate do not match due to rounding errors,+then play and event fetching get out of sync over the time.+-}+withMIDIEventsNonblock :: (RealField.C time) =>+ time -> (EventList.T StrictTime (Maybe ALSA.Event) -> IO a) -> IO a+withMIDIEventsNonblock =+ withMIDIEventsNonblockWaitGrouped+++withMIDIEventsNonblockWaitGrouped :: (RealField.C time) =>+ time -> (EventList.T StrictTime (Maybe ALSA.Event) -> IO a) -> IO a+withMIDIEventsNonblockWaitGrouped rate proc =+ withInPort ALSA.Nonblock $ \ h _p ->+ do start <- getTimeSeconds+ l <- lazySequence $+ flip map (iterate (beat+) start) $ \t ->+ wait t >>+ liftM+ (\evs -> (t, Nothing : map Just evs))+ (getWaitingEvents h)+{-+ liftM2 (,)+ getTimeSeconds+ (liftM (\evs -> Nothing : map Just evs) $+ getWaitingEvents h)+-}+ proc $+ EventList.flatten $+ discretizeTime rate $+ AbsEventList.fromPairList l++{-+With this function latency becomes longer and longer if xruns occur,+but the latency is not just adapted,+but ones xruns occur, this implies more and more xruns.+-}+withMIDIEventsNonblockWaitDefer :: (RealField.C time) =>+ time -> (EventList.T StrictTime (Maybe ALSA.Event) -> IO a) -> IO a+withMIDIEventsNonblockWaitDefer rate proc =+ withInPort ALSA.Nonblock $ \ h _p ->+ do start <- getTimeSeconds+ l <- lazySequence $+ flip map (iterate (beat+) start) $ \t ->+ wait t >>+ liftM+ (\ es -> (t, Nothing) : map (mapSnd Just) es)+ (getWaitingStampedEvents h)+ proc $+ discretizeTime rate $+ {-+ delay events that are in wrong order+ disadvantage: we cannot guarantee a beat with a minimal period+ -}+ flip evalState start $+ AbsEventList.mapTimeM (\t -> modify (max t) >> get) $+ AbsEventList.fromPairList $ concat l++{-+We risk and endless skipping when the beat is too short.+(Or debug output slows down processing.)+-}+withMIDIEventsNonblockWaitSkip :: (RealField.C time) =>+ time -> (EventList.T StrictTime (Maybe ALSA.Event) -> IO a) -> IO a+withMIDIEventsNonblockWaitSkip rate proc =+ withInPort ALSA.Nonblock $ \ h _p ->+ do start <- getTimeSeconds+ l <- lazySequence $+ flip map (iterate (beat+) start) $ \t ->+ do wait t+ t0 <- getTimeSeconds+ -- print (t-start,t0-start)+ es <-+ if t0>=t+beat+ then return []+ else getWaitingStampedEvents h+ return $+ (t0, Nothing) :+ map (mapSnd Just) es+ proc $+ discretizeTime rate $+ AbsEventList.fromPairList $ concat l++withMIDIEventsNonblockWaitMin :: (RealField.C time) =>+ time -> (EventList.T StrictTime (Maybe ALSA.Event) -> IO a) -> IO a+withMIDIEventsNonblockWaitMin rate proc =+ withInPort ALSA.Nonblock $ \ h _p ->+ do start <- getTimeSeconds+ l <- lazySequence $+ flip map (iterate (beat+) start) $ \t ->+ wait t >>+ liftM+ (\ es ->+ (minimum $ t : map fst es, Nothing) :+ map (mapSnd Just) es)+ (getWaitingStampedEvents h)+{-+ mapM_ print $ EventList.toPairList $+ discretizeTime rate $+ AbsEventList.fromPairList $ concat l+ proc undefined+-}+ proc $+ discretizeTime rate $+ AbsEventList.fromPairList $ concat l++withMIDIEventsNonblockConstantPause :: (RealField.C time) =>+ time -> (EventList.T StrictTime (Maybe ALSA.Event) -> IO a) -> IO a+withMIDIEventsNonblockConstantPause rate proc =+ withInPort ALSA.Nonblock $ \ h _p ->+ do l <- ioToLazyList $ threadDelay (round $ flip asTypeOf rate $ beat*1e6) >>+ liftM2 (:)+ (liftM (\t->(t,Nothing)) getTimeSeconds)+ (liftM (map (mapSnd Just)) (getWaitingStampedEvents h))+ proc $+ discretizeTime rate $+ AbsEventList.fromPairList $ concat l++withMIDIEventsNonblockSimple :: (RealField.C time) =>+ time -> (EventList.T StrictTime ALSA.Event -> IO a) -> IO a+withMIDIEventsNonblockSimple rate proc =+ withInPort ALSA.Nonblock $ \ h _p ->+ do l <- ioToLazyList $+ threadDelay (round $ flip asTypeOf rate $ beat*1e6) >>+ getWaitingStampedEvents h+ proc $+ discretizeTime rate $+ AbsEventList.fromPairList $ concat l++withMIDIEventsBlock :: (RealField.C time) =>+ time -> (EventList.T StrictTime ALSA.Event -> IO a) -> IO a+withMIDIEventsBlock rate proc =+ withInPort ALSA.Block $ \ h _p ->+ do l <- ioToLazyList $ getStampedEvent h+ proc $+ discretizeTime rate $+ AbsEventList.fromPairList l++withInPort ::+ ALSA.BlockMode -> (ALSA.SndSeq -> ALSA.Port -> IO t) -> IO t+withInPort blockMode act =+ bracket+ (ALSA.open ALSA.default_seq_name ALSA.open_input blockMode)+ (ALSA.close) $+ \h ->+ ALSA.set_client_name h "Haskell-Synthesizer" >>+ (bracket+ (ALSA.create_simple_port h "listener"+ (ALSA.caps [ALSA.cap_write, ALSA.cap_subs_write])+ ALSA.type_midi_generic)+ (ALSA.delete_port h) $+ \p ->+ act h p)++{- |+We first discretize the absolute time values,+then we compute differences,+in order to avoid rounding errors in further computations.+-}+discretizeTime :: (RealField.C time) =>+ time -> AbsEventList.T time a -> EventList.T StrictTime a+discretizeTime sampleRate =+ EventListMB.mapTimeHead (const $ NonNegW.fromNumber zero) . -- clear first time since it is an absolute system time stamp+ EventList.fromAbsoluteEventList .+ AbsEventList.mapTime+ (NonNegW.fromNumberMsg "time conversion" . round . (sampleRate*))+++-- * event filters++type Filter = State (EventList.T StrictTime (Maybe ALSA.Event))+++{-+Maybe we could use StorableVector.Pattern.LazySize+or we could use synthesizer-core/ChunkySize.+What package should we rely on?+Which one is more portable?+-}+type LazyTime = NonNegChunky.T NonNegW.Integer++{- |+We turn the strict time values into lazy ones+according to the breaks by our beat.+However for the laziness breaks we ignore the events that are filtered out.+That is we loose laziness granularity+but hopefully gain efficiency by larger blocks.+-}+getSlice ::+ (ALSA.Event -> Maybe a) ->+ Filter (EventListTT.T LazyTime a)+getSlice f =+ fmap+ (EventListTT.catMaybesR .+ flip EventListTM.snocTime NonNegChunky.zero .+ EventList.mapTime NonNegChunky.fromNumber) $+ state (partitionMaybeBeat f)+-- state (partitionMaybe (maybe (Just Nothing) (fmap Just . f)))++{- |+Move all elements that are mapped to @Just@ into another list.+-}+partitionMaybe ::+ (a -> Maybe b) -> EventList.T StrictTime a ->+ (EventList.T StrictTime b, EventList.T StrictTime a)+partitionMaybe f =+ mapPair (EventList.catMaybes, EventList.catMaybes) .+ EventList.foldrPair (\t a ->+ let (x,y) =+ case f a of+ Just b -> (Just b, Nothing)+ Nothing -> (Nothing, Just a)+ in mapPair (EventList.cons t x, EventList.cons t y))+ (EventList.empty, EventList.empty)++{- |+Move all elements that are mapped to @Just@ into another list.+@Nothing@ elements in the source list+are maintained in both result lists as laziness breaks.+-}+partitionMaybeBeat ::+ (a -> Maybe b) -> EventList.T StrictTime (Maybe a) ->+ (EventList.T StrictTime (Maybe b), EventList.T StrictTime (Maybe a))+partitionMaybeBeat f =+ mapPair (EventList.catMaybes, EventList.catMaybes) .+ EventList.foldrPair (\t a0 ->+ let (x,y) =+ case a0 of+ Nothing -> (Just Nothing, Just Nothing)+ Just a1 ->+ case f a1 of+ Just b -> (Just $ Just b, Nothing)+ Nothing -> (Nothing, Just $ Just a1)+ in mapPair (EventList.cons t x, EventList.cons t y))+ (EventList.empty, EventList.empty)+++type Channel = ChannelMsg.Channel+type Controller = ChannelMsg.Controller+type Pitch = ChannelMsg.Pitch+type Velocity = ChannelMsg.Velocity+type Program = ChannelMsg.Program+++maybeController :: Channel -> Controller -> ALSA.Event -> Maybe (Int, Int)+maybeController chan ctrl e =+ let ALSA.TickTime n = ALSA.ev_timestamp e+ in case ALSA.ev_data e of+ ALSA.CtrlEv ALSA.Controller c ->+ toMaybe+ (fromIntegral (ALSA.ctrl_channel c) == ChannelMsg.fromChannel chan &&+ fromIntegral (ALSA.ctrl_param c) == ChannelMsg.fromController ctrl)+ (fromIntegral n, fromIntegral $ ALSA.ctrl_value c)+ _ -> Nothing+++getControllerEvents ::+ Channel -> Controller ->+ Filter (EventListTT.T LazyTime Int)+getControllerEvents chan ctrl =+ getSlice (fmap snd . maybeController chan ctrl)+++maybePitchBend :: Channel -> ALSA.Event -> Maybe Int+maybePitchBend chan e =+ case ALSA.ev_data e of+ ALSA.CtrlEv ALSA.PitchBend c ->+ toMaybe+ (fromIntegral (ALSA.ctrl_channel c) == ChannelMsg.fromChannel chan)+ (fromIntegral $ ALSA.ctrl_value c)+ _ -> Nothing++maybeChannelPressure :: Channel -> ALSA.Event -> Maybe Int+maybeChannelPressure chan e =+ case ALSA.ev_data e of+ ALSA.CtrlEv ALSA.ChanPress c ->+ toMaybe+ (fromIntegral (ALSA.ctrl_channel c) == ChannelMsg.fromChannel chan)+ (fromIntegral $ ALSA.ctrl_value c)+ _ -> Nothing+++data NoteBoundary a =+ NoteBoundary Pitch Velocity a+ deriving (Eq, Show)++data Note = Note Program Pitch Velocity LazyTime+ deriving (Eq, Show)+++{-+We could also provide a function which filters for specific programs/presets.+-}+getNoteEvents ::+ Channel ->+ Filter (EventListTT.T LazyTime (Either Program (NoteBoundary Bool)))+getNoteEvents chan =+ getSlice $ \e ->+ case ALSA.ev_data e of+ ALSA.NoteEv notePart note ->+ do guard (fromIntegral (ALSA.note_channel note) ==+ ChannelMsg.fromChannel chan)+ (vel,press) <-+ case notePart of+ ALSA.NoteOn ->+ return $+ let v = ALSA.note_velocity note+ in if v==0+ then (64, False)+ else (fromIntegral v, True)+ ALSA.NoteOff ->+ return+ (fromIntegral $ ALSA.note_velocity note, False)+ _ -> Nothing+ return $ Right $ NoteBoundary+ (ChannelMsg.toPitch $ fromIntegral $ ALSA.note_note note)+ (ChannelMsg.toVelocity vel)+ press+ ALSA.CtrlEv ALSA.PgmChange ctrl ->+ do guard (fromIntegral (ALSA.ctrl_channel ctrl) ==+ ChannelMsg.fromChannel chan)+ return $ Left $ ChannelMsg.toProgram $+ fromIntegral $ ALSA.ctrl_value ctrl+ _ -> Nothing++embedPrograms ::+ Program ->+ EventListTT.T LazyTime (Either Program (NoteBoundary Bool)) ->+ EventListTT.T LazyTime (NoteBoundary (Maybe Program))+embedPrograms initPgm =+ EventListTT.catMaybesR .+ flip evalState initPgm .+ EventListTT.mapBodyM+ (either+ (\pgm -> put pgm >> return Nothing)+ (\(NoteBoundary p v press) ->+ gets (Just . NoteBoundary p v . toMaybe press)))+++matchNoteEventsAlt ::+ EventListTT.T LazyTime (NoteBoundary (Maybe Program)) ->+ EventListTT.T LazyTime Note+matchNoteEventsAlt =+ EventListTT.catMaybesR .+ matchNoteEventsMaybe .+ EventListTT.mapBody Just++matchNoteEventsMaybe ::+ EventListTT.T LazyTime (Maybe (NoteBoundary (Maybe Program))) ->+ EventListTT.T LazyTime (Maybe Note)+matchNoteEventsMaybe =+ EventListMT.mapTimeTail $ \r0 ->+ flip (EventListMT.switchBodyL EventListBT.empty) r0 $+ \ev r1 ->+ case ev of+ Nothing ->+ EventListMT.consBody Nothing $+ matchNoteEventsMaybe r1+ Just (NoteBoundary pitchOn velOn pressOn) ->+ let (obj,r2) =+ case pressOn of+ Nothing -> (Nothing, r1) -- isolated NoteOff event+ Just pgm ->+ let (prefix,_noteOff,suffix) =+ break (maybe False+ (\(NoteBoundary pitchOff _velOff pressOff) ->+ pitchOn == pitchOff && isNothing pressOff)) r1+ in (Just (Note pgm pitchOn velOn (lazyDuration prefix)),+ EventListTM.prependBodyEnd+ (EventListTM.snocBody prefix Nothing) suffix)+ in EventListMT.consBody obj $+ matchNoteEventsMaybe r2++{-+We need a version of 'append' that is specialised to the lazy time type.+Otherwise @append (2 /. 'a' ./ 4 /. 'b' ./ 3 /. undefined) undefined@+does not return the @'b'@.+This makes 'testKeyboard7' omitting the last defined note.+In realtime performance this leads to the effect,+that notes are only played after the key is released.+-}+matchNoteEvents ::+ EventListTT.T LazyTime (NoteBoundary (Maybe Program)) ->+ EventListTT.T LazyTime Note+matchNoteEvents =+ EventListTT.catMaybesR .+ matchNoteEventsCore++matchNoteEventsCore ::+ EventListTT.T LazyTime (NoteBoundary (Maybe Program)) ->+ EventListTT.T LazyTime (Maybe Note)+matchNoteEventsCore =+ EventListMT.mapTimeTail $ \r0 ->+ flip (EventListMT.switchBodyL EventListBT.empty) r0 $+ \(NoteBoundary pitchOn velOn pressOn) r1 ->+ let (obj,r2) =+ case pressOn of+ Nothing -> (Nothing, r1) -- isolated NoteOff event+ Just pgm ->+ let (prefix,_noteOff,suffix) =+ break (\(NoteBoundary pitchOff _velOff pressOff) ->+ pitchOn == pitchOff && isNothing pressOff) r1+ in (Just $ Note pgm pitchOn velOn (lazyDuration prefix),+ appendTTLazy prefix suffix)+ in EventListMT.consBody obj $+ matchNoteEventsCore r2++{- |+This is like 'EventListTT.append' but more lazy,+because it uses the structure of the time value.+-}+appendTTLazy ::+ (Monoid lazyTime) =>+ EventListTT.T lazyTime body ->+ EventListTT.T lazyTime body ->+ EventListTT.T lazyTime body+appendTTLazy xs ys =+ EventListTT.foldr+ (\t zs ->+ let (d,ws) = either EventListMT.viewTimeL ((,) mempty) zs+ in EventListMT.consTime (mappend t d) ws)+ (\b zs -> Right $ EventListMT.consBody b zs)+ (Left ys) xs++lazyDuration ::+ (Monoid lazyTime) =>+ EventListTT.T lazyTime body -> lazyTime+lazyDuration =+ foldr mappend mempty . EventListTT.getTimes+++{- |+Find the first matching body element.+Event list must be infinite or it must contain a matching body element,+otherwise 'body' and the end of the returned list will be undefined.+-}+break ::+ (body -> Bool) -> EventListTT.T LazyTime body ->+ (EventListTT.T LazyTime body, body, EventListTT.T LazyTime body)+break p =+ EventListMT.switchTimeL $ \t xs ->+ let (prefix,suffix) = EventListBT.span (not . p) xs+ (b,r) =+ EventListMT.switchBodyL+ (error "no matching body element found",+ error "list ended before matching element found")+ (,)+ suffix+ in (EventListMT.consTime t prefix, b, r)++{- |+Remove the first matching body element.+Event list must be infinite or it must contain a matching body element,+otherwise 'body' and the end of the returned list will be undefined.+-}+remove ::+ (body -> Bool) -> EventListTT.T LazyTime body ->+ (body, EventListTT.T LazyTime body)+remove p =+ EventListMT.switchTimeL $ \t xs ->+ let (prefix,suffix) = EventListBT.span p xs+ (b,r) =+ EventListMT.switchBodyL+ (error "no matching body element found",+ error "list ended before matching element found")+ (,)+ suffix+ in (b, EventListTT.append (EventListMT.consTime t prefix) r)++++makeInstrumentArray :: [instr] -> Array Program instr+makeInstrumentArray instrs =+ listArray+ (ChannelMsg.toProgram 0, ChannelMsg.toProgram (length instrs - 1))+ instrs++getInstrumentFromArray :: Array Program instr -> Program -> Program -> instr+getInstrumentFromArray bank defltPgm pgm =+ bank !+ if inRange (bounds bank) pgm+ then pgm else defltPgm++++ioToLazyList :: IO a -> IO [a]+ioToLazyList m =+ let go = unsafeInterleaveIO $ liftM2 (:) m go+ in go++lazySequence :: [IO a] -> IO [a]+lazySequence [] = return []+lazySequence (m:ms) =+ unsafeInterleaveIO $ liftM2 (:) m $ lazySequence ms+++dump :: IO ()+dump =+ do putStrLn "Starting."+ h <- ALSA.open ALSA.default_seq_name ALSA.open_input ALSA.Block+ ALSA.set_client_name h "Haskell-Synthesizer"+ putStrLn "Created sequencer."+ p <- ALSA.create_simple_port h "one"+ (ALSA.caps [ALSA.cap_write, ALSA.cap_subs_write]) ALSA.type_midi_generic+ let loop = do putStrLn "waiting for an event:"+ e <- ALSA.event_input h+ print e+ loop+ loop+ ALSA.delete_port h p+ putStrLn "Deleted ports."+ ALSA.close h+ putStrLn "Closed sequencer."++
src/Synthesizer/Storable/ALSA/MIDI.hs view
@@ -1,57 +1,49 @@ {- | Convert MIDI events of a MIDI controller to a control signal. -}+{-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.Storable.ALSA.MIDI where -import qualified Sound.Alsa as ALSASig-import qualified Sound.Alsa.Sequencer as ALSA--import qualified Sound.Sox.Play as Play-import qualified Sound.Sox.Option.Format as SoxOpt-import qualified Synthesizer.Basic.Binary as BinSmp--- import Data.Int (Int16)+import Synthesizer.EventList.ALSA.MIDI import qualified Synthesizer.Storable.Cut as CutSt- import qualified Synthesizer.Storable.Signal as SigSt import qualified Data.StorableVector.Lazy.Pattern as SigStV import qualified Data.StorableVector.Lazy as SVL-import qualified Data.StorableVector.Base as SV -import qualified Data.EventList.Relative.TimeBody as EventList+import qualified Synthesizer.State.Signal as SigS+import qualified Synthesizer.State.Oscillator as OsciS+import qualified Synthesizer.State.Displacement as DispS+import qualified Synthesizer.State.Filter.NonRecursive as FiltNRS+import qualified Synthesizer.Basic.Wave as Wave++import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg+ import qualified Data.EventList.Relative.TimeTime as EventListTT-import qualified Data.EventList.Relative.MixedBody as EventListMB--- import qualified Data.EventList.Relative.BodyMixed as EventListBM import qualified Data.EventList.Relative.TimeMixed as EventListTM import qualified Data.EventList.Relative.MixedTime as EventListMT import qualified Data.EventList.Relative.BodyTime as EventListBT-import qualified Data.EventList.Absolute.TimeBody as AbsEventList -import qualified Foreign-import Foreign.Storable (Storable)--import System.IO.Unsafe (unsafeInterleaveIO, )-import Control.Concurrent (threadDelay)-import System.Time (ClockTime(TOD), getClockTime, )-import Control.Exception (bracket, )--import Control.Monad.Trans.State (State, state, )+import Foreign.Storable (Storable, ) -- import qualified Numeric.NonNegative.Class as NonNeg import qualified Numeric.NonNegative.Wrapper as NonNegW-import qualified Numeric.NonNegative.ChunkyPrivate as NonNegChunky+import qualified Numeric.NonNegative.Chunky as NonNegChunky -import qualified Algebra.RealField as RealField+import qualified Algebra.Transcendental as Trans+import qualified Algebra.RealField as RealField+import qualified Algebra.Field as Field+import qualified Algebra.Additive as Additive -import Data.Tuple.HT (mapPair, mapSnd, )-import Data.Maybe.HT (toMaybe, )--- import Data.Maybe (mapMaybe, )-import Control.Monad (liftM, liftM2, guard, )+import Control.Monad.Trans.State (State, evalState, state, modify, gets, )+import Control.Monad (liftM, ) -import NumericPrelude (round, )-import Prelude hiding (round, break, )+import PreludeBase+import NumericPrelude+import Prelude () + {- readMIDIController :: Storable a =>@@ -66,230 +58,68 @@ return SigSt.empty -} --getTimeSeconds :: Fractional time => IO time-getTimeSeconds =- fmap clockTimeToSeconds getClockTime--clockTimeToSeconds :: Fractional time => ClockTime -> time-clockTimeToSeconds (TOD secs picos) =- fromInteger secs + fromInteger picos * 1e-12---type ALSAEvent = (Double, ALSA.Event)--{- | only use it for non-blocking sequencers -}-getStampedEvent :: ALSA.SndSeq -> IO ALSAEvent-getStampedEvent h =- liftM2 (,)- getTimeSeconds- (ALSA.event_input h)--{- | only use it for non-blocking sequencers -}-getWaitingEvents :: ALSA.SndSeq -> IO [ALSAEvent]-getWaitingEvents h =- let loop =- ALSA.alsa_catch- (liftM2 (:) (getStampedEvent h) loop)- (const $ return [])- in loop---type StrictTime = NonNegW.Integer--{--ghc -i:src -e 'withMIDIEventsNonblock 44100 print' src/Synthesizer/Storable/ALSA/MIDI.hs--}--- as a quick hack, we neglect the ALSA time stamp and use getTime or so-withMIDIEventsNonblock ::- Double -> (EventList.T StrictTime (Maybe ALSA.Event) -> IO a) -> IO a-withMIDIEventsNonblock rate proc =- withInPort ALSA.Nonblock $ \ h _p ->- do l <- ioToLazyList $ threadDelay 10000 >>- liftM2 (:)- (liftM (\t->(t,Nothing)) getTimeSeconds)- (liftM (map (mapSnd Just)) (getWaitingEvents h))- proc $- discretizeTime rate $- AbsEventList.fromPairList $ concat l--withMIDIEventsNonblockSimple ::- Double -> (EventList.T StrictTime ALSA.Event -> IO a) -> IO a-withMIDIEventsNonblockSimple rate proc =- withInPort ALSA.Nonblock $ \ h _p ->- do l <- ioToLazyList $ threadDelay 10000 >> getWaitingEvents h- proc $- discretizeTime rate $- AbsEventList.fromPairList $ concat l--withMIDIEventsBlock ::- Double -> (EventList.T StrictTime ALSA.Event -> IO a) -> IO a-withMIDIEventsBlock rate proc =- withInPort ALSA.Block $ \ h _p ->- do l <- ioToLazyList $ getStampedEvent h- proc $- discretizeTime rate $- AbsEventList.fromPairList l--withInPort ::- ALSA.BlockMode -> (ALSA.SndSeq -> ALSA.Port -> IO t) -> IO t-withInPort blockMode act =- bracket- (ALSA.open ALSA.default_seq_name ALSA.open_input blockMode)- (ALSA.close) $- \h ->- ALSA.set_client_name h "Haskell-Synthesizer" >>- (bracket- (ALSA.create_simple_port h "listener"- (ALSA.caps [ALSA.cap_write, ALSA.cap_subs_write])- ALSA.type_midi_generic)- (ALSA.delete_port h) $- \p ->- act h p)--{- |-We first discretize the absolute time values,-then we compute differences,-in order to avoid rounding errors in further computations.--}-discretizeTime :: Double -> AbsEventList.T Double a -> EventList.T StrictTime a-discretizeTime sampleRate =- EventListMB.mapTimeHead (const 0) . -- clear first time since it is an absolute system time stamp- EventList.fromAbsoluteEventList .- AbsEventList.mapTime- (NonNegW.fromNumberMsg "time conversion" . round . (sampleRate*))+chunkSizesFromLazyTime :: LazyTime -> NonNegChunky.T SigSt.ChunkSize+chunkSizesFromLazyTime =+ NonNegChunky.fromChunks .+ map (SVL.ChunkSize . fromInteger . NonNegW.toNumber) .+ NonNegChunky.toChunks .+ NonNegChunky.normalize -type LazyTime = NonNegChunky.T NonNegW.Integer--{- |-We turn the strict time values into lazy ones-according to the breaks by our beat.-However for the laziness breaks we ignore the events that are filtered out.-That is we loose laziness granularity-but hopefully gain efficiency by larger blocks.--}-getSlice ::- (ALSA.Event -> Maybe a) ->- State (EventList.T StrictTime (Maybe ALSA.Event)) (EventListTT.T LazyTime a)-getSlice f =- fmap- (EventListTT.catMaybesR .- flip EventListTM.snocTime 0 .- EventList.mapTime NonNegChunky.fromNumber) $- state (partitionMaybeBeat f)--- state (partitionMaybe (maybe (Just Nothing) (fmap Just . f)))--{- |-Move all elements that are mapped to @Just@ into another list.--}-partitionMaybe ::- (a -> Maybe b) -> EventList.T StrictTime a ->- (EventList.T StrictTime b, EventList.T StrictTime a)-partitionMaybe f =- mapPair (EventList.catMaybes, EventList.catMaybes) .- EventList.foldrPair (\t a ->- let (x,y) =- case f a of- Just b -> (Just b, Nothing)- Nothing -> (Nothing, Just a)- in mapPair (EventList.cons t x, EventList.cons t y))- (EventList.empty, EventList.empty)--{- |-Move all elements that are mapped to @Just@ into another list.-@Nothing@ elements in the source list-are maintained in both result lists as laziness breaks.--}-partitionMaybeBeat ::- (a -> Maybe b) -> EventList.T StrictTime (Maybe a) ->- (EventList.T StrictTime (Maybe b), EventList.T StrictTime (Maybe a))-partitionMaybeBeat f =- mapPair (EventList.catMaybes, EventList.catMaybes) .- EventList.foldrPair (\t a0 ->- let (x,y) =- case a0 of- Nothing -> (Just Nothing, Just Nothing)- Just a1 ->- case f a1 of- Just b -> (Just $ Just b, Nothing)- Nothing -> (Nothing, Just $ Just a1)- in mapPair (EventList.cons t x, EventList.cons t y))- (EventList.empty, EventList.empty)--maybeController :: Int -> Int -> ALSA.Event -> Maybe (Int, Int)-maybeController chan ctrl e =- let ALSA.TickTime n = ALSA.ev_timestamp e- in case ALSA.ev_data e of- ALSA.CtrlEv ALSA.Controller c ->- toMaybe (fromIntegral (ALSA.ctrl_channel c) == chan &&- fromIntegral (ALSA.ctrl_param c) == ctrl)- (fromIntegral n, fromIntegral $ ALSA.ctrl_value c)- _ -> Nothing--getControllerEvents ::- Int -> Int ->- State (EventList.T StrictTime (Maybe ALSA.Event)) (EventListTT.T LazyTime Int)-getControllerEvents chan ctrl =- getSlice (fmap snd . maybeController chan ctrl)-+{-# INLINE controllerValuesToSignal #-} controllerValuesToSignal ::- Double -> EventListTT.T LazyTime Double -> SigSt.T Double+ (Storable y) =>+ y -> EventListTT.T LazyTime y -> SigSt.T y controllerValuesToSignal initial = EventListBT.foldrPair (\y t -> SigSt.append (SigStV.replicate (chunkSizesFromLazyTime t) y)) SigSt.empty . EventListMT.consBody initial -chunkSizesFromLazyTime :: LazyTime -> NonNegChunky.T SigSt.ChunkSize-chunkSizesFromLazyTime =- NonNegChunky.fromChunks .- map (SVL.ChunkSize . fromInteger . NonNegW.toNumber) .- NonNegChunky.toChunks .- NonNegChunky.normalize -+{-# INLINE controllerValueToSample #-} controllerValueToSample ::- (Double,Double) -> Int -> Double+ (Field.C y) =>+ (y,y) -> Int -> y controllerValueToSample (lower,upper) n = let k = fromIntegral n / 127 in (1-k) * lower + k * upper +{-# INLINE getControllerSignal #-} getControllerSignal ::- Int -> Int ->- (Double,Double) -> Double ->- State (EventList.T StrictTime (Maybe ALSA.Event)) (SigSt.T Double)+ (Storable y, Field.C y) =>+ Channel -> Controller ->+ (y,y) -> y ->+ Filter (SigSt.T y) getControllerSignal chan ctrl bnd initial = liftM (controllerValuesToSignal initial . EventListTT.mapBody (controllerValueToSample bnd)) $ getControllerEvents chan ctrl +{-# INLINE controllerValueToSampleExp #-} controllerValueToSampleExp ::- (Double,Double) -> Int -> Double+ (Trans.C y) =>+ (y,y) -> Int -> y controllerValueToSampleExp (lower,upper) n = let k = fromIntegral n / 127 in lower**(1-k) * upper**k +{-# INLINE getControllerSignalExp #-} getControllerSignalExp ::- Int -> Int ->- (Double,Double) -> Double ->- State (EventList.T StrictTime (Maybe ALSA.Event)) (SigSt.T Double)+ (Storable y, Trans.C y) =>+ Channel -> Controller ->+ (y,y) -> y ->+ Filter (SigSt.T y) getControllerSignalExp chan ctrl bnd initial = liftM (controllerValuesToSignal initial . EventListTT.mapBody (controllerValueToSampleExp bnd)) $ getControllerEvents chan ctrl -maybePitchBend :: Int -> ALSA.Event -> Maybe Int-maybePitchBend chan e =- case ALSA.ev_data e of- ALSA.CtrlEv ALSA.PitchBend c ->- toMaybe (fromIntegral (ALSA.ctrl_channel c) == chan)- (fromIntegral $ ALSA.ctrl_value c)- _ -> Nothing-+{-# INLINE pitchBendValueToSample #-} pitchBendValueToSample ::- Double -> Double -> Int -> Double+ (Trans.C y) =>+ y -> y -> Int -> y pitchBendValueToSample range center n = center * range ** (fromIntegral n / 8192) @@ -298,162 +128,73 @@ emits frequencies on an exponential scale from @center/range@ to @center*range@. -}+{-# INLINE getPitchBendSignal #-} getPitchBendSignal ::- Int ->- Double -> Double ->- State (EventList.T StrictTime (Maybe ALSA.Event)) (SigSt.T Double)+ (Storable y, Trans.C y) =>+ Channel ->+ y -> y ->+ Filter (SigSt.T y) getPitchBendSignal chan range center = liftM (controllerValuesToSignal center . EventListTT.mapBody (pitchBendValueToSample range center)) $ getSlice (maybePitchBend chan) -- getPitchBendEvents chan -{--We could also provide a function which filters for specific programs/presets.--}-getNoteEvents ::- Int ->- State- (EventList.T StrictTime (Maybe ALSA.Event))- (EventListTT.T LazyTime (Int,Int,Bool))-getNoteEvents chan =- getSlice $ \e ->- case ALSA.ev_data e of- ALSA.NoteEv notePart note ->- do guard (fromIntegral (ALSA.note_channel note) == chan)- (vel,press) <-- case notePart of- ALSA.NoteOn ->- return $- let v = ALSA.note_velocity note- in if v==0- then (64, False)- else (fromIntegral v, True)- ALSA.NoteOff ->- return- (fromIntegral $ ALSA.note_velocity note, False)- _ -> Nothing- return (fromIntegral $ ALSA.note_note note, vel, press)- _ -> Nothing+{-# INLINE getChannelPressureSignal #-}+getChannelPressureSignal ::+ (Storable y, Trans.C y) =>+ Channel ->+ y -> y ->+ Filter (SigSt.T y)+getChannelPressureSignal chan maxVal initVal =+ liftM (controllerValuesToSignal initVal .+ EventListTT.mapBody (controllerValueToSample (0,maxVal))) $+ getSlice (maybeChannelPressure chan) -matchNoteEventsAlt ::- EventListTT.T LazyTime (Int,Int,Bool) ->- EventListTT.T LazyTime (Int,Int,LazyTime)-matchNoteEventsAlt =- EventListTT.catMaybesR .- matchNoteEventsMaybe .- EventListTT.mapBody Just -matchNoteEventsMaybe ::- EventListTT.T LazyTime (Maybe (Int,Int,Bool)) ->- EventListTT.T LazyTime (Maybe (Int,Int,LazyTime))-matchNoteEventsMaybe =- EventListMT.mapTimeTail $ \r0 ->- flip (EventListMT.switchBodyL EventListBT.empty) r0 $- \ev r1 ->- case ev of- Nothing ->- EventListMT.consBody Nothing $ matchNoteEventsMaybe r1- Just (pitchOn,velOn,pressOn) ->- let (dur,r2) =- if not pressOn- then (0, r1) -- isolated NoteOff event- else- let (prefix,_noteOff,suffix) =- break (maybe False- (\(pitchOff,_velOff,pressOff) ->- pitchOn == pitchOff && not pressOff)) r1- in (lazyDuration prefix,- EventListTM.prependBodyEnd- (EventListTM.snocBody prefix Nothing) suffix)- in EventListMT.consBody (Just (pitchOn,velOn,dur)) $ matchNoteEventsMaybe r2--{--We need a version of 'append' which is specialised to the lazy time type.-Otherwise @append (2 /. 'a' ./ 4 /. 'b' ./ 3 /. undefined) undefined@-does not return the @'b'@.-This makes 'testKeyboard7' omitting the last defined note.-In realtime performance this leads to the effect,-that notes are only played after the key is released.--}-matchNoteEvents ::- EventListTT.T LazyTime (Int,Int,Bool) ->- EventListTT.T LazyTime (Int,Int,LazyTime)-matchNoteEvents =- EventListMT.mapTimeTail $ \r0 ->- flip (EventListMT.switchBodyL EventListBT.empty) r0 $- \(pitchOn,velOn,pressOn) r1 ->- let (dur,r2) =- if not pressOn- then (0, r1) -- isolated NoteOff event- else- let (prefix,_noteOff,suffix) =- break (\(pitchOff,_velOff,pressOff) ->- pitchOn == pitchOff && not pressOff) r1- in (lazyDuration prefix,- appendTTLazy prefix suffix)- in EventListMT.consBody (pitchOn,velOn,dur) $ matchNoteEvents r2--{- |-This is like 'EventListTT.append' but more lazy,-because it uses the structure of the time value.--}-appendTTLazy ::- EventListTT.T LazyTime body ->- EventListTT.T LazyTime body ->- EventListTT.T LazyTime body-appendTTLazy xs ys =- EventListTT.foldr- (\t zs ->- let (d,ws) = either EventListMT.viewTimeL ((,) NonNegChunky.zero) zs- in EventListMT.consTime (t + d) ws)- (\b zs -> Right $ EventListMT.consBody b zs)- (Left ys) xs--lazyDuration :: EventListTT.T LazyTime body -> LazyTime-lazyDuration = foldr (+) 0 . EventListTT.getTimes+{-# INLINE getFMSignalFromBendWheelPressure #-}+getFMSignalFromBendWheelPressure ::+ (Storable y, RealField.C y, Trans.C y) =>+ Channel ->+ Int -> y -> y -> y ->+ Filter (SigSt.T y)+getFMSignalFromBendWheelPressure chan+ pitchRange speed wheelDepth pressDepth =+ do bend <- getPitchBendSignal chan (2^?(fromIntegral pitchRange/12)) 1+ fm <- getControllerSignal chan VoiceMsg.modulation (0,wheelDepth) 0+ press <- getChannelPressureSignal chan pressDepth 0+ return $+ flip (SigS.zipWithStorable (*)) bend $+ SigS.map (1+) $+ FiltNRS.envelope+ (DispS.mix+ (SigS.fromStorableSignal fm)+ (SigS.fromStorableSignal press))+ (OsciS.static Wave.sine zero speed) -{- |-Find the first matching body element.-Event list must be infinite or it must contain a matching body element,-otherwise 'body' and the end of the returned list will be undefined.--}-break ::- (body -> Bool) -> EventListTT.T LazyTime body ->- (EventListTT.T LazyTime body, body, EventListTT.T LazyTime body)-break p =- EventListMT.switchTimeL $ \t xs ->- let (prefix,suffix) = EventListBT.span (not . p) xs- (b,r) =- EventListMT.switchBodyL- (error "no matching body element found",- error "list ended before matching element found")- (,)- suffix- in (EventListMT.consTime t prefix, b, r)--{- |-Remove the first matching body element.-Event list must be infinite or it must contain a matching body element,-otherwise 'body' and the end of the returned list will be undefined.--}-remove ::- (body -> Bool) -> EventListTT.T LazyTime body ->- (body, EventListTT.T LazyTime body)-remove p =- EventListMT.switchTimeL $ \t xs ->- let (prefix,suffix) = EventListBT.span p xs- (b,r) =- EventListMT.switchBodyL- (error "no matching body element found",- error "list ended before matching element found")- (,)- suffix- in (b, EventListTT.append (EventListMT.consTime t prefix) r)+type Instrument y yv = y -> y -> LazyTime -> SigSt.T yv+type Bank y yv = Program -> Instrument y yv +renderInstrument ::+ (Trans.C y) =>+ Bank y yv ->+ Note ->+ SigSt.T yv+renderInstrument instrument (Note pgm pitch vel dur) =+ instrument pgm+ (fromIntegral (VoiceMsg.fromVelocity vel - 64)/63)+ {- This is the default tuning according to MIDI 1.0 Detailed Specification -}+ (440 * 2 ^? (fromIntegral (VoiceMsg.fromPitch pitch + 3 - 6*12) / 12))+ dur -type Instrument = LazyTime -> Double -> Double -> SigSt.T Double+renderInstrumentIgnoreProgram ::+ (Trans.C y) =>+ Instrument y yv ->+ Note ->+ SigSt.T yv+renderInstrumentIgnoreProgram instrument =+ renderInstrument (const instrument) {- | Instrument parameters are:@@ -461,17 +202,12 @@ frequency is given in Hertz -} makeInstrumentSounds ::- Instrument ->- EventListTT.T time (Int,Int,LazyTime) ->- EventListTT.T time (SigSt.T Double)+ (Trans.C y) =>+ Instrument y yv ->+ EventListTT.T time Note ->+ EventListTT.T time (SigSt.T yv) makeInstrumentSounds instrument =- EventListTT.mapBody- (\(pitch, vel, dur) ->- instrument- dur- (fromIntegral (vel-64)/63)--- (880 * 2 ** (fromIntegral (pitch + 3 - 6*12) / 12)))- (440 * 2 ** (fromIntegral (pitch + 3 - 6*12) / 12)))+ EventListTT.mapBody (renderInstrument (const instrument)) {- |@@ -480,114 +216,161 @@ This is much like the version we started on. We could avoid this function with a more sophisticated version of 'arrange'. -}-insertBreaks ::- EventListTT.T LazyTime (SigSt.T Double) ->- EventListTT.T StrictTime (SigSt.T Double)-insertBreaks =+insertBreaksGen ::+ signal ->+ EventListTT.T LazyTime signal ->+ EventListTT.T StrictTime signal+insertBreaksGen empty = EventListTT.foldr (\lt r ->- case NonNegChunky.toChunksUnsafe (NonNegChunky.normalize lt) of- [] -> EventListMT.consTime 0 r+ {- uncurry matches lazy, thus the constructor represented by consTime+ can be generated before the particular time is known -}+ uncurry EventListMT.consTime $+ case NonNegChunky.toChunks (NonNegChunky.normalize lt) of+ [] -> (0, r) (t:ts) ->- EventListMT.consTime t $+ (,) t $ foldr (\dt ->- EventListMT.consBody SigSt.empty .+ EventListMT.consBody empty . EventListMT.consTime dt) r ts) EventListMT.consBody EventListBT.empty -getNoteSignal ::- Int ->- Instrument ->- State- (EventList.T StrictTime (Maybe ALSA.Event))- (SigSt.T Double)-getNoteSignal chan instr =- fmap (CutSt.arrangeEquidist defaultChunkSize .+insertBreaks ::+ (Storable y) =>+ EventListTT.T LazyTime (SigSt.T y) ->+ EventListTT.T StrictTime (SigSt.T y)+insertBreaks =+ insertBreaksGen SigSt.empty++{-# INLINE getNoteSignalCore #-}+getNoteSignalCore ::+ (Storable yv, Additive.C yv) =>+ SVL.ChunkSize ->+ Channel ->+ Program ->+ (EventListTT.T LazyTime Note ->+ EventListTT.T LazyTime (SigSt.T yv)) ->+ Filter (SigSt.T yv)+getNoteSignalCore chunkSize chan initPgm modulator =+ fmap (CutSt.arrangeEquidist chunkSize . EventListTM.switchTimeR const . EventListTT.mapTime fromIntegral . insertBreaks .- makeInstrumentSounds instr .- matchNoteEvents) $+ modulator .+ matchNoteEvents .+ embedPrograms initPgm) $ getNoteEvents chan --ioToLazyList :: IO a -> IO [a]-ioToLazyList m =- unsafeInterleaveIO $- liftM2 (:) m (ioToLazyList m)-+errorNoProgram :: Program+errorNoProgram =+ error "MIDI program not initialized" -dump :: IO ()-dump =- do putStrLn "Starting."- h <- ALSA.open ALSA.default_seq_name ALSA.open_input ALSA.Block- ALSA.set_client_name h "Haskell-Synthesizer"- putStrLn "Created sequencer."- p <- ALSA.create_simple_port h "one"- (ALSA.caps [ALSA.cap_write, ALSA.cap_subs_write]) ALSA.type_midi_generic- let loop = do putStrLn "waiting for an event:"- e <- ALSA.event_input h- print e- loop- loop- ALSA.delete_port h p- putStrLn "Deleted ports."- ALSA.close h- putStrLn "Closed sequencer."+{-# INLINE getNoteSignal #-}+getNoteSignal ::+ (Storable yv, Additive.C yv, Trans.C y) =>+ SVL.ChunkSize ->+ Channel ->+ Instrument y yv ->+ Filter (SigSt.T yv)+getNoteSignal chunkSize chan instr =+ getNoteSignalCore chunkSize chan errorNoProgram (makeInstrumentSounds instr) -{- |-Latency is high using Sox --Can we achieve better results using ALSA's sound output?--}-playMonoSox ::- (Storable a, RealField.C a) =>- a -> SigSt.T a -> IO ()-playMonoSox rate =- fmap (const ()) .- Play.simple SigSt.hPut SoxOpt.none (round rate) .- SigSt.map BinSmp.int16FromCanonical+{-# INLINE getNoteSignalModulated #-}+getNoteSignalModulated ::+ (Storable c, Storable yv, Additive.C yv, Trans.C y) =>+ SVL.ChunkSize ->+ SigSt.T c ->+ Channel ->+ (SigSt.T c -> Instrument y yv) ->+ Filter (SigSt.T yv)+getNoteSignalModulated chunkSize ctrl chan instr =+ getNoteSignalCore chunkSize chan errorNoProgram+ (flip evalState ctrl .+ EventListTT.mapM+ advanceModulationChunky+ (\note -> gets $ \c -> renderInstrumentIgnoreProgram (instr c) note)) -defaultSampleRate :: Num a => a-defaultSampleRate = 48000--- defaultSampleRate = 44100--bufferSize :: Int-bufferSize = 256+{-# INLINE getNoteSignalMultiModulated #-}+getNoteSignalMultiModulated ::+ (Storable yv, Additive.C yv, Trans.C y) =>+ SVL.ChunkSize ->+ Channel ->+ instrument ->+ (EventListTT.T LazyTime (instrument, Note) ->+ EventListTT.T LazyTime (Instrument y yv, Note)) ->+ Filter (SigSt.T yv)+getNoteSignalMultiModulated chunkSize chan instr modulator =+ getNoteSignalCore chunkSize chan errorNoProgram+ (EventListTT.mapBody (uncurry renderInstrumentIgnoreProgram) .+ modulator .+ EventListTT.mapBody ((,) instr)) -defaultChunkSize :: SigSt.ChunkSize-defaultChunkSize = SigSt.chunkSize bufferSize+applyModulation ::+ (Storable c) =>+ SigSt.T c ->+ EventListTT.T LazyTime (SigSt.T c -> instr, note) ->+ EventListTT.T LazyTime (instr, note)+applyModulation ctrl =+ flip evalState ctrl .+ EventListTT.mapM+ advanceModulationChunky+ (\(instr,note) -> gets $ \c -> (instr c, note)) -latency :: Int-latency = 1000+evaluateVectorHead ::+ (Storable a) =>+ SigSt.T a -> t -> t+evaluateVectorHead xs t =+ if SigSt.null xs then t else t +advanceModulationLazy, advanceModulationStrict, advanceModulationChunky ::+ (Storable a) =>+ LazyTime -> State (SigSt.T a) LazyTime {--alsaOpen: only few buffer overruns with- let buffer_time = 200000 -- 0.20s- period_time = 40000 -- 0.04s+This one drops lazily,+such that the control signal will be cached until it is used.+That is, if for a long time no new note is played,+more and more memory will be allocated.+-}+advanceModulationLazy t =+ modify (SigStV.drop (chunkSizesFromLazyTime t)) >> return t -However the delay is still perceivable.+{-+This one is too strict,+because the complete drop is forced+also if only the first chunk of the lazy time is requested. -}-playMono ::- (Storable a, RealField.C a) =>- a -> SigSt.T a -> IO ()-playMono rate xs =- let sink = ALSASig.alsaSoundSink "plughw:0,0" soundFormat- ys = SigSt.map BinSmp.int16FromCanonical xs+advanceModulationStrict t = state $ \xs ->+ let ys = SigStV.drop (chunkSizesFromLazyTime t) xs+ in (evaluateVectorHead ys t, ys) - soundFormat :: ALSASig.SoundFmt- soundFormat =- ALSASig.SoundFmt {- ALSASig.sampleFmt = ALSASig.SampleFmtLinear16BitSignedLE,- ALSASig.sampleFreq = round rate,- ALSASig.numChannels = 1- }+advanceModulationChunky =+ liftM NonNegChunky.fromChunks .+ mapM advanceModulationChunk .+ NonNegChunky.toChunks - in ALSASig.withSoundSink sink $ \to ->- flip mapM_ (SVL.chunks (SigSt.append (SigSt.replicate defaultChunkSize latency 0) ys)) $ \c ->- SV.withStartPtr c $ \ptr size ->- ALSASig.soundSinkWrite sink to (Foreign.castPtr ptr) size+advanceModulationChunk ::+ (Storable a) =>+ NonNegW.Integer -> State (SigSt.T a) NonNegW.Integer+advanceModulationChunk t = state $ \xs ->+ let ys = SigSt.drop (fromIntegral t) xs+ in (evaluateVectorHead ys t, ys)+++{-# INLINE getNoteSignalMultiProgram #-}+getNoteSignalMultiProgram ::+ (Storable yv, Additive.C yv, Trans.C y) =>+ SVL.ChunkSize ->+ Channel ->+ Program ->+ [Instrument y yv] ->+ Filter (SigSt.T yv)+getNoteSignalMultiProgram chunkSize chan initPgm instrs =+ let bank = makeInstrumentArray instrs+ in getNoteSignalCore chunkSize chan initPgm+ (EventListTT.mapBody (renderInstrument+ (getInstrumentFromArray bank initPgm)))
+ src/Synthesizer/Storable/ALSA/Play.hs view
@@ -0,0 +1,121 @@+{- |+Convert MIDI events of a MIDI controller to a control signal.+-}+module Synthesizer.Storable.ALSA.Play (+ auto,+ autoAndRecord,+ monoToInt16,+ stereoToInt16,+ defaultChunkSize,+ ) where++import qualified Sound.Alsa as ALSA++import qualified Synthesizer.Frame.Stereo as Stereo+import qualified Synthesizer.Basic.Binary as BinSmp++import qualified Sound.Sox.Frame as SoxFrame+import qualified Sound.Sox.Write as SoxWrite+import qualified Sound.Sox.Option.Format as SoxOption++import Foreign.Storable (Storable, )+import Foreign.Marshal.Array (advancePtr, )+import Foreign.Ptr (Ptr, minusPtr, )+import qualified System.IO as IO++-- import qualified Synthesizer.State.Signal as SigS++import qualified Synthesizer.Storable.Signal as SigSt+import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector.Base as SVB++import qualified Algebra.RealField as RealField++-- import NumericPrelude (round, )+import Prelude hiding (round, break, )+++defaultChunkSize :: SigSt.ChunkSize+defaultChunkSize = SigSt.chunkSize 256+++{-+alsaOpen: only few buffer underruns with+ let buffer_time = 200000 -- 0.20s+ period_time = 40000 -- 0.04s++However the delay is still perceivable.++Latency for keyboard playback might be better with:+ let buffer_time = 50000 -- 0.05s+ period_time = 10000 -- 0.01s+but we get too much underruns,+without actually achieving the required latency.+-}+{-# INLINE auto #-}+auto ::+ (ALSA.SampleFmt a) =>+ Int -> SigSt.T a -> IO ()+auto rate ys =+ let sink =+ ALSA.alsaSoundSinkTime "plughw:0,0" soundFormat $+ ALSA.SoundBufferTime 50000 10000++ {-# INLINE soundFormat #-}+ soundFormat :: ALSA.SoundFmt y+ soundFormat =+ ALSA.SoundFmt {+ ALSA.sampleFreq = rate+ }++ in ALSA.withSoundSink sink $ \to ->+ flip mapM_ (SVL.chunks ys) $ \c ->+ SVB.withStartPtr c $ \ptr size ->+ ALSA.soundSinkWrite sink to ptr size++-- cf. Alsa.hs+{-# INLINE arraySize #-}+arraySize :: Storable y => Ptr y -> Int -> Int+arraySize p n = advancePtr p n `minusPtr` p++{-# INLINE autoAndRecord #-}+autoAndRecord ::+ (ALSA.SampleFmt a, SoxFrame.C a) =>+ FilePath -> Int -> SigSt.T a -> IO ()+autoAndRecord fileName rate =+ let sink =+ ALSA.alsaSoundSinkTime "plughw:0,0" soundFormat $+ ALSA.SoundBufferTime 50000 10000++ {-# INLINE soundFormat #-}+ soundFormat :: ALSA.SoundFmt y+ soundFormat =+ ALSA.SoundFmt {+ ALSA.sampleFreq = rate+ }++ in (\act ->+ fmap (const ()) .+ SoxWrite.simple act SoxOption.none fileName rate) $ \h ys ->+ ALSA.withSoundSink sink $ \to ->+ flip mapM_ (SVL.chunks ys) $ \c ->+ SVB.withStartPtr c $ \ptr size ->+ ALSA.soundSinkWrite sink to ptr size >>+ IO.hPutBuf h ptr (arraySize ptr size)+++{-# INLINE monoToInt16 #-}+monoToInt16 ::+ (Storable y, RealField.C y) =>+ Int -> SigSt.T y -> IO ()+monoToInt16 rate xs =+ auto rate+ (SigSt.map BinSmp.int16FromCanonical xs)++{-# INLINE stereoToInt16 #-}+stereoToInt16 ::+ (Storable y, RealField.C y) =>+ Int -> SigSt.T (Stereo.T y) -> IO ()+stereoToInt16 rate xs =+ auto rate+ (SigSt.map (fmap BinSmp.int16FromCanonical) xs)
synthesizer-alsa.cabal view
@@ -1,11 +1,11 @@ Name: synthesizer-alsa-Version: 0.0.3+Version: 0.1 License: GPL License-File: LICENSE Author: Henning Thielemann <haskell@henning-thielemann.de> Maintainer: Henning Thielemann <haskell@henning-thielemann.de> Homepage: http://www.haskell.org/haskellwiki/Synthesizer-Package-URL: http://darcs.haskell.org/synthesizer-alsa/+Package-URL: http://code.haskell.org/synthesizer/alsa/ Category: Sound, Music Synopsis: Control synthesizer effects via ALSA/MIDI Description:@@ -13,40 +13,35 @@ and to convert them to control signals that can be used for audio effects. As demonstration there is a keyboard controlled music synthesizer.- However, latency increases over time such that the synthesizer becomes unusable.- I currently do not know how to solve this problem. Stability: Experimental-Tested-With: GHC==6.4.1, GHC==6.8.2+Tested-With: GHC==6.4.1, GHC==6.8.2, GHC==6.10.4 Cabal-Version: >=1.2 Build-Type: Simple Flag splitBase description: Choose the new smaller, split-up base package. -Flag splitSynthesizer- description: Use synthesizer-core instead of monolithic synthesizer+Flag optimizeAdvanced+ description: Enable advanced optimizations. They slow down compilation considerably.+ default: False Flag buildExamples description: Build example executables default: False Library- If flag(splitSynthesizer)- Build-Depends:- synthesizer-core >= 0.2 && < 0.3- Else- Build-Depends:- synthesizer >= 0.2 && < 0.3- Build-Depends:- sox >=0.0.1 && <0.1,- alsa >= 0.2 && <0.3,- -- midi >=0.1.1 && <0.1,- storablevector >=0.2.4 && <0.3,+ synthesizer-dimensional >=0.4 && < 0.5,+ synthesizer-core >=0.3 && < 0.4,+ sox >=0.1 && <0.2,+ alsa >=0.3 && <0.4,+ midi >=0.1.1 && <0.2,+ storablevector >=0.2.5 && <0.3, numeric-prelude >=0.0.3 && <0.2,- non-negative >=0.0.3 && <0.1,+ non-negative >=0.0.5 && <0.1, event-list >=0.0.8 && <0.1, -- data-accessor >=0.1 && <0.2,+ array >=0.1 && <0.3, transformers >=0.1.1 && <0.2, utility-ht >=0.0.1 && <0.1 @@ -62,12 +57,28 @@ GHC-Options: -Wall Hs-source-dirs: src Exposed-modules:+ Synthesizer.EventList.ALSA.MIDI Synthesizer.Storable.ALSA.MIDI+ Synthesizer.Storable.ALSA.Play+ Synthesizer.Dimensional.ALSA.MIDI+ Synthesizer.Dimensional.ALSA.Play Executable realtimesynth If !flag(buildExamples) Buildable: False- GHC-Options: -Wall -O2 -fexcess-precision -fvia-C -optc-O2 -threaded--- -ddump-simpl-stats+ If flag(optimizeAdvanced)+ GHC-Options: -O2 -fvia-C -optc-O2 -optc-msse3 -optc-ffast-math+ GHC-Options: -Wall -fexcess-precision -threaded+-- -ddump-simpl-stats -ddump-asm Hs-Source-Dirs: src Main-Is: RealTimeSynthesizer.hs++Executable synthicate+ If !flag(buildExamples)+ Buildable: False+ If flag(optimizeAdvanced)+ GHC-Options: -O2 -fvia-C -optc-O2 -optc-ffast-math+ GHC-Options: -Wall -fexcess-precision -threaded+-- -ddump-simpl-stats+ Hs-Source-Dirs: src+ Main-Is: RealTimeSynthesizerDim.hs