synthesizer-alsa 0.4 → 0.5
raw patch · 40 files changed
+2449/−6547 lines, 40 filesdep +synthesizer-mididep −arraydep −containersdep −data-accessordep ~alsa-pcmdep ~alsa-seqdep ~midi
Dependencies added: synthesizer-midi
Dependencies removed: array, containers, data-accessor, data-accessor-transformers, deepseq, storable-record
Dependency ranges changed: alsa-pcm, alsa-seq, midi, midi-alsa, numeric-prelude, old-time, synthesizer-core, synthesizer-dimensional, transformers
Files
- src/Synthesizer/ALSA/CausalIO/Process.hs +96/−0
- src/Synthesizer/ALSA/Dimensional/Play.hs +123/−0
- src/Synthesizer/ALSA/Dimensional/Server.hs +18/−0
- src/Synthesizer/ALSA/Dimensional/Server/Common.hs +101/−0
- src/Synthesizer/ALSA/Dimensional/Server/Run.hs +185/−0
- src/Synthesizer/ALSA/Dimensional/Server/Test.hs +58/−0
- src/Synthesizer/ALSA/EventList.hs +503/−0
- src/Synthesizer/ALSA/Storable/Play.hs +212/−0
- src/Synthesizer/ALSA/Storable/Server.hs +113/−0
- src/Synthesizer/ALSA/Storable/Server/Common.hs +101/−0
- src/Synthesizer/ALSA/Storable/Server/Run.hs +331/−0
- src/Synthesizer/ALSA/Storable/Server/Test.hs +582/−0
- src/Synthesizer/CausalIO/ALSA/MIDIControllerSelection.hs +0/−112
- src/Synthesizer/CausalIO/ALSA/MIDIControllerSet.hs +0/−156
- src/Synthesizer/CausalIO/ALSA/Process.hs +0/−728
- src/Synthesizer/Dimensional/ALSA/MIDI.hs +0/−451
- src/Synthesizer/Dimensional/ALSA/Play.hs +0/−123
- src/Synthesizer/Dimensional/ALSA/Server.hs +0/−18
- src/Synthesizer/Dimensional/ALSA/Server/Common.hs +0/−101
- src/Synthesizer/Dimensional/ALSA/Server/Instrument.hs +0/−204
- src/Synthesizer/Dimensional/ALSA/Server/Run.hs +0/−185
- src/Synthesizer/Dimensional/ALSA/Server/Test.hs +0/−56
- src/Synthesizer/Dimensional/MIDIValue.hs +0/−45
- src/Synthesizer/Dimensional/MIDIValuePlain.hs +0/−64
- src/Synthesizer/EventList/ALSA/MIDI.hs +0/−769
- src/Synthesizer/Generic/ALSA/MIDI.hs +0/−347
- src/Synthesizer/MIDIValue.hs +0/−56
- src/Synthesizer/MIDIValue/BendModulation.hs +0/−101
- src/Synthesizer/MIDIValue/BendWheelPressure.hs +0/−39
- src/Synthesizer/PiecewiseConstant/ALSA/MIDI.hs +0/−188
- src/Synthesizer/PiecewiseConstant/ALSA/MIDIControllerSet.hs +0/−379
- src/Synthesizer/Storable/ALSA/MIDI.hs +0/−319
- src/Synthesizer/Storable/ALSA/Play.hs +0/−210
- src/Synthesizer/Storable/ALSA/Server.hs +0/−113
- src/Synthesizer/Storable/ALSA/Server/Common.hs +0/−98
- src/Synthesizer/Storable/ALSA/Server/Instrument.hs +0/−486
- src/Synthesizer/Storable/ALSA/Server/Run.hs +0/−330
- src/Synthesizer/Storable/ALSA/Server/Test.hs +0/−602
- src/Test.hs +0/−203
- synthesizer-alsa.cabal +26/−64
+ src/Synthesizer/ALSA/CausalIO/Process.hs view
@@ -0,0 +1,96 @@+module Synthesizer.ALSA.CausalIO.Process (+ Events,+ playFromEvents,+ Output,+ playFromEventsWithParams,+ ) where++import qualified Synthesizer.ALSA.EventList as MIDIEv++import qualified Synthesizer.ALSA.Storable.Play as Play+import Synthesizer.MIDI.EventList (StrictTime, )++import qualified Synthesizer.CausalIO.Process as PIO++import qualified Sound.ALSA.PCM as PCM+import qualified Sound.ALSA.Sequencer.Event as Event++import qualified Data.EventList.Relative.TimeTime as EventListTT++import qualified Algebra.RealField as RealField+import qualified Algebra.Additive as Additive++import qualified Data.StorableVector as SV++import Control.Exception (bracket, )++import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude ()+++type Events = EventListTT.T StrictTime [Event.T]++playFromEvents ::+ (RealField.C time, PCM.SampleFmt a, Additive.C a) =>+ Play.Device -> MIDIEv.ClientName -> time -> time -> PCM.SampleFreq ->+ PIO.T Events (SV.Vector a) ->+ IO ()+playFromEvents device name latency beat rate+ (PIO.Cons next create delete) =+ let sink = Play.makeSink device beat rate+ rateFloat = fromIntegral rate+ in MIDIEv.withMIDIEventsChunked name beat rateFloat $ \getEventsList ->+ PCM.withSoundSink sink $ \to ->+{-+ Play.writeLazy sink to+ (SVL.replicate+ (SVL.chunkSize $ round (beat * rateFloat))+ (round (latency * rateFloat))+ (zero::Float))+-}+ Play.write sink to+ (SV.replicate (round (latency * rateFloat)) zero) >>+ (bracket create delete $ \state ->+ let loop getEvs0 s0 =+ case getEvs0 of+ [] -> return ()+ getEvents : getEvs1 -> do+ evs <- getEvents+ (pcm, s1) <- next evs s0+ Play.write sink to pcm+ loop getEvs1 s1+ in loop getEventsList state)+++type Output handle signal a =+ (IO ((PCM.Size, PCM.SampleFreq), handle),+ handle -> IO (),+ handle -> signal -> IO a)++playFromEventsWithParams ::+ Output handle signal () ->+ MIDIEv.ClientName ->+ ((PCM.Size, PCM.SampleFreq) -> PIO.T Events signal) ->+ IO ()+playFromEventsWithParams (open, close, write) name process =+ bracket open (close . snd) $ \(p@(period,rate),h) ->+ let rateFloat = fromIntegral rate :: Double+ beat = fromIntegral period / rateFloat+ in MIDIEv.withMIDIEventsChunked name beat rateFloat $ \getEventsList ->+ case process p of+ PIO.Cons next create delete -> do+{-+ write+ (SV.replicate (round (latency * rateFloat)) zero)+-}+ bracket create delete $ \state ->+ let loop getEvs0 s0 =+ case getEvs0 of+ [] -> return ()+ getEvents : getEvs1 -> do+ evs <- getEvents+ (chunk, s1) <- next evs s0+ write h chunk+ loop getEvs1 s1+ in loop getEventsList state
+ src/Synthesizer/ALSA/Dimensional/Play.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE Rank2Types #-}+module Synthesizer.ALSA.Dimensional.Play where++import qualified Synthesizer.ALSA.Storable.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.PCM 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.RealRing as RealRing+-- import qualified Algebra.Field as Field+-- import qualified Algebra.Ring as Ring++import Foreign.Storable (Storable, )++-- import NumericPrelude.Numeric+import NumericPrelude.Base+++type Device = String++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)+++makeSink ::+ (ALSA.SampleFmt y, RealRing.C t) =>+ Device {- ^ ALSA output device -} ->+ DN.Time t {- ^ period (buffer) size expressed in seconds -} ->+ DN.Frequency t {- ^ sample rate -} ->+ ALSA.SoundSink ALSA.Pcm y+makeSink device periodTime rate =+ Play.makeSink device+ (DN.toNumberWithDimension Dim.time periodTime)+ (RealRing.round (DN.toNumberWithDimension Dim.frequency rate))+++{-# INLINE timeVoltageStorable #-}+timeVoltageStorable ::+ (Module.C y yv, ALSA.SampleFmt yv, RealRing.C t) =>+ Device ->+ DN.Time t->+ RenderedStorableSignal Dim.Time t Dim.Voltage y yv ->+ IO ()+timeVoltageStorable device period sig =+ Play.auto (makeSink device period (SigA.actualSampleRate sig))+ (SigA.vectorSamples (DN.toNumberWithDimension Dim.voltage) sig)++{-# INLINE timeVoltageMonoStorableToInt16 #-}+timeVoltageMonoStorableToInt16 ::+ (Storable y, RealRing.C y, RealRing.C t) =>+ Device ->+ DN.Time t->+ RenderedStorableSignal Dim.Time t Dim.Voltage y y ->+ IO ()+timeVoltageMonoStorableToInt16 device period sig =+ Play.monoToInt16 (makeSink device period (SigA.actualSampleRate sig))+ (SigA.scalarSamples (DN.toNumberWithDimension Dim.voltage) sig)++{-# INLINE timeVoltageStereoStorableToInt16 #-}+timeVoltageStereoStorableToInt16 ::+ (Storable y, Module.C y y, RealRing.C y, RealRing.C t) =>+ Device ->+ DN.Time t->+ RenderedStorableSignal Dim.Time t Dim.Voltage y (Stereo.T y) ->+ IO ()+timeVoltageStereoStorableToInt16 device period sig =+ Play.stereoToInt16 (makeSink device period (SigA.actualSampleRate sig))+ (SigA.vectorSamples (DN.toNumberWithDimension Dim.voltage) sig)+++{-# INLINE renderTimeVoltageStorable #-}+renderTimeVoltageStorable ::+ (Module.C y yv, ALSA.SampleFmt yv, RealRing.C t) =>+ Device ->+ DN.Time t->+ DN.T Dim.Frequency t ->+ (forall s. Proc.T s Dim.Time t+ (StorableSignal s Dim.Voltage y yv)) ->+ IO ()+renderTimeVoltageStorable device period rate sig =+ timeVoltageStorable device period (SigA.render rate sig)++{-# INLINE renderTimeVoltageMonoStorableToInt16 #-}+renderTimeVoltageMonoStorableToInt16 ::+ (Storable y, RealRing.C y, RealRing.C t) =>+ Device ->+ DN.Time t->+ DN.T Dim.Frequency t ->+ (forall s. Proc.T s Dim.Time t+ (StorableSignal s Dim.Voltage y y)) ->+ IO ()+renderTimeVoltageMonoStorableToInt16 device period rate sig =+ timeVoltageMonoStorableToInt16 device period (SigA.render rate sig)++{-# INLINE renderTimeVoltageStereoStorableToInt16 #-}+renderTimeVoltageStereoStorableToInt16 ::+ (Storable y, Module.C y y, RealRing.C y, RealRing.C t) =>+ Device ->+ DN.Time t->+ DN.T Dim.Frequency t ->+ (forall s. Proc.T s Dim.Time t+ (StorableSignal s Dim.Voltage y (Stereo.T y))) ->+ IO ()+renderTimeVoltageStereoStorableToInt16 device period rate sig =+ timeVoltageStereoStorableToInt16 device period (SigA.render rate sig)
+ src/Synthesizer/ALSA/Dimensional/Server.hs view
@@ -0,0 +1,18 @@+module Main where++import qualified Synthesizer.ALSA.Dimensional.Server.Run as Run+import qualified Synthesizer.ALSA.Dimensional.Server.Test as Test++main :: IO ()+main =+ case 106::Int of+ 001 -> Test.sequence1+ 100 -> Run.volume+ 101 -> Run.pitchBend+ 102 -> Run.volumePitchBend1+ 103 -> Run.keyboard+ 104 -> Run.keyboardMulti+ 105 -> Run.keyboardFM+ 106 -> Run.keyboardDetuneFM+ 107 -> Run.keyboardFilter+ _ -> error "not implemented"
+ src/Synthesizer/ALSA/Dimensional/Server/Common.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RankNTypes #-}+module Synthesizer.ALSA.Dimensional.Server.Common where++import qualified Synthesizer.ALSA.Dimensional.Play as Play++import qualified Sound.ALSA.PCM as ALSA+import qualified Sound.ALSA.Sequencer.Event as Event++import qualified Synthesizer.ALSA.EventList as MIDIEv++import qualified Synthesizer.ALSA.Storable.Play as PlaySt++import qualified Synthesizer.Dimensional.Rate.Filter as FiltR+import qualified Synthesizer.Dimensional.Process as Proc++import Synthesizer.Dimensional.Process (($:), )++import qualified Data.StorableVector.Lazy as SVL++import qualified Sound.MIDI.Message.Channel as ChannelMsg++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.Numeric+import NumericPrelude.Base hiding (break, )++++channel :: ChannelMsg.Channel+channel = ChannelMsg.toChannel 0+++sampleRate :: Ring.C a => DN.Frequency a+-- sampleRate = DN.frequency 48000+sampleRate = DN.frequency 44100++latency :: Field.C a => DN.Time a+latency = DN.time 0+-- latency = DN.time 0.01++{-+chunkSize :: SVL.ChunkSize+chunkSize = Play.defaultChunkSize+-}++periodTime :: Field.C a => DN.Time a+periodTime =+ let (SVL.ChunkSize size) = PlaySt.defaultChunkSize+ in DN.scale (fromIntegral size) $ DN.unrecip sampleRate++device :: Play.Device+device = PlaySt.defaultDevice++clientName :: MIDIEv.ClientName+clientName = MIDIEv.ClientName "Haskell-Synthesizer"+++type Real = Double+++{-# INLINE withMIDIEvents #-}+withMIDIEvents ::+ Field.C t =>+ (DN.Time t -> DN.Frequency t ->+ (forall s. Proc.T s Dim.Time t+ (Play.StorableSignal s Dim.Voltage y yv)) ->+ IO b) ->+ (EventList.T MIDIEv.StrictTime [Event.T] ->+ forall s. Proc.T s Dim.Time t+ (Play.StorableSignal s Dim.Voltage y yv)) ->+ IO b+withMIDIEvents action proc =+ MIDIEv.withMIDIEvents clientName+ (DN.toNumberWithDimension Dim.time periodTime :: Double)+ (DN.toNumberWithDimension Dim.frequency sampleRate :: Double) $+ \ sig -> action periodTime sampleRate (proc sig)++{-# INLINE play #-}+play ::+ (Module.C y yv, ALSA.SampleFmt yv, RealField.C t) =>+ DN.Time t ->+ DN.Frequency t ->+ (forall s. Proc.T s Dim.Time t+ (Play.StorableSignal s Dim.Voltage y yv)) ->+ IO ()+play period rate sig =+ Play.renderTimeVoltageStorable device period rate+ (FiltR.delay latency $: sig)
+ src/Synthesizer/ALSA/Dimensional/Server/Run.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.ALSA.Dimensional.Server.Run where++import Synthesizer.ALSA.Dimensional.Server.Common+import qualified Synthesizer.MIDI.Dimensional.Example.Instrument as Instr++import qualified Synthesizer.MIDI.Dimensional as MIDI++import qualified Synthesizer.ALSA.Storable.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.FilterParameter as FiltP+import qualified Synthesizer.Dimensional.Causal.ControlledProcess as CProc++import qualified Synthesizer.Dimensional.Rate.Oscillator as OsciR+import qualified Synthesizer.Dimensional.Amplitude.Control as CtrlA+import qualified Synthesizer.Dimensional.Amplitude.Displacement as DispA+import qualified Synthesizer.Dimensional.Amplitude.Filter as FiltA+import qualified Synthesizer.Dimensional.Signal.Private as SigA+import qualified Synthesizer.Dimensional.Wave as WaveD++import Synthesizer.Dimensional.Causal.Process ((<<<), )+import Synthesizer.Dimensional.Wave ((&*~), )+import Synthesizer.Dimensional.Process (($:), (.:), )+import Control.Applicative (liftA2, liftA3, )++import qualified Synthesizer.Basic.Wave as Wave++import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg++import qualified Number.DimensionTerm as DN++import NumericPrelude.Numeric+import NumericPrelude.Base hiding (break, )++++channelVolume :: VoiceMsg.Controller+channelVolume = VoiceMsg.modulation+++volume :: IO ()+volume =+ putStrLn "run 'aconnect' to connect to the MIDI controller" >>+ (withMIDIEvents play $+ \evs ->+ liftA3+ (\env osci vol ->+ Causal.apply+ (Causal.applySnd env osci) $+ MIDI.piecewiseConstant $ vol)+ Filt.envelopeScalarDimension+ (OsciR.static (DN.voltage 1 &*~ Wave.sine) zero (DN.frequency (880::Real)))+ (MIDI.runFilter evs (MIDI.controllerLinear channel channelVolume+ (DN.scalar 0, DN.scalar 1) (DN.scalar (1::Real)))))++pitchBend :: IO ()+pitchBend =+ withMIDIEvents play $+ \evs ->+ liftA2 Causal.apply+ (Osci.freqMod (DN.voltage (1::Real) &*~ Wave.sine) zero)+ (fmap MIDI.piecewiseConstant $+ MIDI.runFilter evs+ (MIDI.pitchBend channel 2 (DN.frequency (880::Real))))++-- preserve chunk structure of channel volume+volumePitchBend0 :: IO ()+volumePitchBend0 =+ 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)) $+ MIDI.piecewiseConstant vol)+ (OsciR.freqMod (DN.voltage 1 &*~ Wave.sine) zero)+ Filt.envelopeScalarDimension+ (MIDI.runFilter evs $ liftA2 (,)+ (MIDI.pitchBend channel 2 (DN.frequency (880::Real)))+ (MIDI.controllerLinear channel channelVolume+ (DN.scalar 0, DN.scalar 1) (DN.scalar (1::Real)))))++-- preserve chunk structure of pitch bender+volumePitchBend1 :: IO ()+volumePitchBend1 =+ 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) $+ MIDI.piecewiseConstant freq)+ (Osci.freqMod (DN.voltage 1 &*~ Wave.sine) zero)+ Filt.envelopeScalarDimension+ (MIDI.runFilter evs $ liftA2 (,)+ (MIDI.pitchBend channel 2 (DN.frequency (880::Real)))+ (MIDI.controllerLinear channel channelVolume+ (DN.scalar 0, DN.scalar 1) (DN.scalar (1::Real)))))+++keyboard :: IO ()+keyboard =+ withMIDIEvents play $+ \evs ->+ MIDI.runFilter evs+ (MIDI.sequence PlaySt.defaultChunkSize (DN.voltage 1) channel Instr.ping)+++keyboardMulti :: IO ()+keyboardMulti =+ withMIDIEvents play $+ \evs ->+ MIDI.runFilter evs+ (MIDI.sequenceMultiProgram PlaySt.defaultChunkSize (DN.voltage 1) channel+ (VoiceMsg.toProgram 0)+ [Instr.ping, Instr.pingRelease])+-- [Instr.string])+++keyboardFM :: IO ()+keyboardFM =+ withMIDIEvents play $+ \evs ->+ fmap (FiltA.amplify 0.3) $+ (MIDI.runFilter evs+ (MIDI.sequenceModulated PlaySt.defaultChunkSize (DN.voltage 1) channel Instr.pingReleaseFM $:+ MIDI.bendWheelPressure channel 2 (DN.frequency 10) 0.04 0.03))+-- MIDI.pitchBend channel (2 ** recip 12) (DN.scalar one)))+++extraController :: VoiceMsg.Controller+extraController =+ VoiceMsg.vectorX+-- VoiceMsg.toController 21++extraController1 :: VoiceMsg.Controller+extraController1 =+ VoiceMsg.modulation+-- VoiceMsg.vectorY+-- VoiceMsg.toController 22+++keyboardDetuneFM :: IO ()+keyboardDetuneFM =+ withMIDIEvents play $+ \evs ->+ fmap (FiltA.amplify 0.3) $+ (MIDI.runFilter evs+ (MIDI.sequenceMultiModulated PlaySt.defaultChunkSize (DN.voltage 1) channel Instr.pingStereoDetuneFM+ (fmap MIDI.applyModulation+ (MIDI.bendWheelPressure channel 2 (DN.frequency 10) 0.04 0.03) .:+ fmap MIDI.applyModulation+ (MIDI.controllerLinear channel extraController (0, 0.005) 0))+ ))+++keyboardFilter :: IO ()+keyboardFilter =+ withMIDIEvents play $+ \evs ->+ liftA3+ (\osci filt (music,speed,depth) ->+ (FiltP.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 FiltP.universal)+-- FiltR.universal+ (MIDI.runFilter evs+ (liftA3 (,,)+ (MIDI.sequence PlaySt.defaultChunkSize (DN.voltage 1) channel Instr.string)+ (MIDI.controllerExponential channel extraController+ (DN.frequency 0.1, DN.frequency 5) (DN.frequency 0.2))+ (MIDI.controllerLinear channel extraController1+ (0, 1 :: DN.Scalar Real) 0.5)+ ))
+ src/Synthesizer/ALSA/Dimensional/Server/Test.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE Rank2Types #-}+module Synthesizer.ALSA.Dimensional.Server.Test where++import Synthesizer.ALSA.Dimensional.Server.Common+import Synthesizer.MIDI.Dimensional.Example.Instrument (ping, )++import qualified Synthesizer.ALSA.Storable.Play as PlaySt++import qualified Synthesizer.MIDI.Dimensional as MIDI+import qualified Synthesizer.MIDI.EventList as MIDIEv+import qualified Synthesizer.MIDI.Generic as MidiG++import qualified Synthesizer.Dimensional.Signal.Private as SigA+import qualified Synthesizer.Dimensional.Process as Proc++import qualified Synthesizer.Storable.Signal as SigSt+import qualified Data.StorableVector.Lazy as SVL++import qualified Data.EventList.Relative.TimeBody as EventList++import qualified Sound.ALSA.Sequencer.Event as Event++import qualified Algebra.DimensionTerm as Dim+import qualified Number.DimensionTerm as DN++import NumericPrelude.Numeric+import NumericPrelude.Base hiding (break, )++++sequence1 :: IO ()+sequence1 =+-- print =<<+-- File.renderTimeVoltageMonoDoubleToInt16 sampleRate "test.wav"+ SVL.writeFile "test.f32"+ (SigA.scalarSamples (DN.toNumberWithDimension Dim.voltage)+ (SigA.render sampleRate+ (let evs t = EventList.cons t ([]::[Event.T]) (evs (20-t))+ {-+ evs0 =+ EventList.cons 10 [makeNote AlsaMidi.NoteOn 60] $+ EventList.cons 10 [makeNote AlsaMidi.NoteOn 64] $+ evs 10+ -}+ in MIDI.runFilter (evs 10)+ (MIDI.sequence PlaySt.defaultChunkSize+ (DN.voltage 1) channel ping))))++sequence2 ::+ EventList.T MIDIEv.StrictTime [SigSt.T Real]+sequence2 =+ fmap (map SigA.body) $+ flip Proc.process sampleRate+ (let evs t = EventList.cons t ([]::[Event.T]) (evs (20-t))+ in MIDI.runFilter (evs 10)+ (MIDI.prepareTones channel MidiG.errorNoProgram+ (const ping)))
+ src/Synthesizer/ALSA/EventList.hs view
@@ -0,0 +1,503 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.ALSA.EventList where++import qualified Sound.ALSA.Sequencer.Address as Addr+import qualified Sound.ALSA.Sequencer.Client as Client+import qualified Sound.ALSA.Sequencer.Port as Port+import qualified Sound.ALSA.Sequencer.Port.InfoMonad as PortInfo+import qualified Sound.ALSA.Sequencer.Event as Event+import qualified Sound.ALSA.Sequencer.Queue as Queue+import qualified Sound.ALSA.Sequencer.Time as Time+import qualified Sound.ALSA.Sequencer.RealTime as RealTime+import qualified Sound.ALSA.Sequencer as SndSeq+import qualified Sound.ALSA.Exception as AlsaExc++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.TimeMixed as EventListTM+import qualified Data.EventList.Absolute.TimeBody as AbsEventList++import Sound.MIDI.ALSA.Check ()++import System.IO.Unsafe (unsafeInterleaveIO, )+import Control.Concurrent (threadDelay)+import System.Time (ClockTime(TOD), getClockTime, )++import Control.Monad.Trans.State+ (evalState, modify, get, )++import qualified Numeric.NonNegative.Class as NonNeg+import qualified Numeric.NonNegative.Wrapper as NonNegW++import qualified Algebra.RealField as RealField+import qualified Algebra.Field as Field++import Data.Tuple.HT (mapPair, mapSnd, )+import Data.Ord.HT (limit, )+import Control.Monad (liftM, liftM2, )++import NumericPrelude.Numeric+import NumericPrelude.Base+++{- |+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 Event.T sometimes.+-}+type StampedEvent time = (time, Event.T)+++{- |+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, SndSeq.AllowInput mode) =>+ SndSeq.T mode -> IO (StampedEvent time)+getStampedEvent h =+ liftM2 (,)+ getTimeSeconds+ (Event.input h)++{- | only use it for non-blocking sequencers -}+getWaitingStampedEvents ::+ (Field.C time, SndSeq.AllowInput mode) =>+ SndSeq.T mode -> IO [StampedEvent time]+getWaitingStampedEvents h =+ let loop =+ AlsaExc.catch+ (liftM2 (:) (getStampedEvent h) loop)+ (const $ return [])+ in loop++{- |+RealTime.toFractional for NumericPrelude.+-}+realTimeToField :: (Field.C a) => RealTime.T -> a+realTimeToField (RealTime.Cons s n) =+ fromIntegral s + fromIntegral n / (10^9)++addStamp ::+ (RealField.C time) =>+ Event.T -> StampedEvent time+addStamp ev =+ (case Event.time ev of+ Time.Cons Time.Absolute (Time.Real t) -> realTimeToField t+ _ -> error "unsupported time stamp type",+ ev)++{- | only use it for blocking sequencers -}+getStampedEventsUntilTime ::+ (RealField.C time,+ SndSeq.AllowInput mode, SndSeq.AllowOutput mode) =>+ SndSeq.T mode ->+ Queue.T -> Port.T -> time ->+ IO [StampedEvent time]+getStampedEventsUntilTime h q p t =+ fmap (map addStamp) $ getEventsUntilTime h q p t+++{- |+The client id may differ from the receiving sequencer.+I do not know, whether there are circumstances, where this is useful.+-}+getEventsUntilEcho ::+ (SndSeq.AllowInput mode) =>+ Client.T -> SndSeq.T mode -> IO [Event.T]+getEventsUntilEcho c h =+ let loop = do+ ev <- Event.input h+ let abort =+ case Event.body ev of+ Event.CustomEv Event.Echo _ ->+ c == Addr.client (Event.source ev)+ _ -> False+ if abort+ then return []+ else liftM (ev:) loop+ in loop++{- |+Get events until a certain point in time.+It sends itself an Echo event in order to measure time.+-}+getEventsUntilTime ::+ (RealField.C time,+ SndSeq.AllowInput mode, SndSeq.AllowOutput mode) =>+ SndSeq.T mode ->+ Queue.T -> Port.T -> time ->+ IO [Event.T]+getEventsUntilTime h q p t = do+ c <- Client.getId h+ _ <- Event.output h $+ makeEcho c q p t (Event.Custom 0 0 0)+ _ <- Event.drainOutput h+ getEventsUntilEcho c h+++getWaitingEvents ::+ (SndSeq.AllowInput mode) =>+ SndSeq.T mode -> IO [Event.T]+getWaitingEvents h =+ let loop =+ AlsaExc.catch+ (liftM2 (:) (Event.input h) loop)+ (const $ return [])+ in loop++++type StrictTime = NonNegW.Integer+newtype ClientName = ClientName String+ deriving (Show)++{-+ghc -i:src -e 'withMIDIEvents 44100 print' src/Synthesizer/Storable/ALSA/MIDI.hs+-}+{-+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.+-}+withMIDIEvents :: (RealField.C time) =>+ ClientName -> time -> time ->+ (EventList.T StrictTime [Event.T] -> IO a) -> IO a+withMIDIEvents =+ withMIDIEventsBlockEcho+++{-+as a quick hack, we neglect the ALSA time stamp and use getTime or so+-}+withMIDIEventsNonblockWaitGrouped :: (RealField.C time) =>+ ClientName -> time -> time ->+ (EventList.T StrictTime [Event.T] -> IO a) -> IO a+withMIDIEventsNonblockWaitGrouped name beat rate proc =+ withInPort name SndSeq.Nonblock $ \ h _p ->+ do start <- getTimeSeconds+ l <- lazySequence $+ flip map (iterate (beat+) start) $ \t ->+ wait t >>+ liftM+ (\evs -> (t, evs))+ (getWaitingEvents h)+{-+ liftM2 (,)+ getTimeSeconds+ (getWaitingEvents h)+-}+ proc $+ 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) =>+ ClientName -> time -> time ->+ (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a+withMIDIEventsNonblockWaitDefer name beat rate proc =+ withInPort name SndSeq.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) =>+ ClientName -> time -> time ->+ (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a+withMIDIEventsNonblockWaitSkip name beat rate proc =+ withInPort name SndSeq.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) =>+ ClientName -> time -> time ->+ (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a+withMIDIEventsNonblockWaitMin name beat rate proc =+ withInPort name SndSeq.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) =>+ ClientName -> time -> time ->+ (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a+withMIDIEventsNonblockConstantPause name beat rate proc =+ withInPort name SndSeq.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) =>+ ClientName -> time -> time ->+ (EventList.T StrictTime Event.T -> IO a) -> IO a+withMIDIEventsNonblockSimple name beat rate proc =+ withInPort name SndSeq.Nonblock $ \ h _p ->+ do l <- ioToLazyList $+ threadDelay (round $ flip asTypeOf rate $ beat*1e6) >>+ getWaitingStampedEvents h+ proc $+ discretizeTime rate $+ AbsEventList.fromPairList $ concat l+++setTimestamping ::+ SndSeq.T mode -> Port.T -> Queue.T -> IO ()+setTimestamping h p q =+ PortInfo.modify h p $ do+ PortInfo.setTimestamping True+ PortInfo.setTimestampReal True+ PortInfo.setTimestampQueue q++withMIDIEventsBlockEcho :: (RealField.C time) =>+ ClientName -> time -> time ->+ (EventList.T StrictTime [Event.T] -> IO a) -> IO a+withMIDIEventsBlockEcho name beat rate proc =+ withInPort name SndSeq.Block $ \ h p ->+ Queue.with h $ \ q ->+ do setTimestamping h p q+ Queue.control h q Event.QueueStart Nothing+ _ <- Event.drainOutput h++ proc .+ discretizeTime rate .+ AbsEventList.fromPairList .+ concat =<<+ (lazySequence $+ flip map (iterate (beat+) 0) $ \t ->+ let end = t+beat+ in -- (\act -> do evs <- act; print evs; return evs) $+ -- add a laziness break+ fmap ((t,[]) :) $+ fmap (map (mapPair (limit (t,end), (:[])))) $+ getStampedEventsUntilTime h q p end)++{- |+This is like withMIDIEventsBlockEcho+but collects all events at the beginning of the beats.+This way, further processing steps may collapse+all controller events within one beat to one event.+-}+withMIDIEventsBlockEchoQuantised :: (RealField.C time) =>+ ClientName -> time -> time ->+ (EventList.T StrictTime [Event.T] -> IO a) -> IO a+withMIDIEventsBlockEchoQuantised name beat rate proc =+ withInPort name SndSeq.Block $ \ h p ->+ Queue.with h $ \ q ->+ do Queue.control h q Event.QueueStart Nothing+ _ <- Event.drainOutput h++ proc .+ discretizeTime rate .+ AbsEventList.fromPairList =<<+ (lazySequence $+ flip map (iterate (beat+) 0) $ \t ->+ liftM+ (\evs -> (t, evs))+ (getEventsUntilTime h q p (t+beat)))++{- |+Make sure, that @beat@ is an integer multiple of @recip rate@.+Since we round time within each chunk,+we would otherwise accumulate rounding errors over time.+-}+withMIDIEventsChunked ::+ (RealField.C time) =>+ ClientName -> time -> time ->+ ([IO (EventListTT.T StrictTime [Event.T])] -> IO a) ->+ IO a+withMIDIEventsChunked name beat rate proc =+ withInPort name SndSeq.Block $ \ h p ->+ Queue.with h $ \ q ->+ do setTimestamping h p q+ Queue.control h q Event.QueueStart Nothing+ _ <- Event.drainOutput h++ proc $+ map+ (\t ->+ let end = t+beat+ in liftM+ (\evs ->+ EventListTM.switchBodyR+ (error "withMIDIEventsChunked: empty list, but there must be at least the end event")+ const $+ discretizeTime rate $+ AbsEventList.fromPairList $+ (t,[]) :+ {-+ FIXME: This is a quick hack in order to assert+ that all events are within one chunk+ and do not lie on the boundary.+ -}+ map (mapPair (limit (t , end - recip rate), (:[]))) evs +++ (end, []) :+ [])+ (getStampedEventsUntilTime h q p end))+ (iterate (beat+) 0)++withMIDIEventsChunkedQuantised ::+ (RealField.C time) =>+ ClientName -> time -> time ->+ ([IO (EventList.T StrictTime [Event.T])] -> IO a) ->+ IO a+withMIDIEventsChunkedQuantised name beat rate proc =+ withInPort name SndSeq.Block $ \ h p ->+ Queue.with h $ \ q ->+ do Queue.control h q Event.QueueStart Nothing+ _ <- Event.drainOutput h++ proc $+ map+ (\t ->+ liftM+ (\evs ->+ EventList.cons NonNeg.zero evs $+ EventList.singleton+ (NonNegW.fromNumberMsg "chunked time conversion" $+ round (beat*rate)) [])+ (getEventsUntilTime h q p (t+beat)))+ (iterate (beat+) 0)++makeEcho ::+ RealField.C time =>+ Client.T -> Queue.T -> Port.T ->+ time -> Event.Custom -> Event.T+makeEcho c q p t dat =+ (Event.simple+ (Addr.Cons {+ Addr.client = c,+ Addr.port = Port.unknown+ })+ (Event.CustomEv Event.Echo dat))+ { Event.queue = q+ , Event.time =+ Time.consAbs $ Time.Real $ RealTime.fromInteger $+ floor (10^9 * t)+ , Event.dest = Addr.Cons {+ Addr.client = c,+ Addr.port = p+ }+ }++withMIDIEventsBlock :: (RealField.C time) =>+ ClientName -> time ->+ (EventList.T StrictTime Event.T -> IO a) -> IO a+withMIDIEventsBlock name rate proc =+ withInPort name SndSeq.Block $ \ h _p ->+ do l <- ioToLazyList $ getStampedEvent h+ proc $+ discretizeTime rate $+ AbsEventList.fromPairList l++withInPort ::+ ClientName ->+ SndSeq.BlockMode ->+ (SndSeq.T SndSeq.DuplexMode -> Port.T -> IO t) -> IO t+withInPort (ClientName name) blockMode act =+ SndSeq.with SndSeq.defaultName blockMode $ \h ->+ Client.setName h name >>+ Port.withSimple h "input"+ (Port.caps [Port.capWrite, Port.capSubsWrite])+ Port.typeMidiGeneric+ (act h)++{- |+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*))++++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
+ src/Synthesizer/ALSA/Storable/Play.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Play audio signals via ALSA.+The module could also be called @Output@,+because with a @file@ sink, data can also be written to disk.+-}+module Synthesizer.ALSA.Storable.Play (+ -- * auxiliary functions+ Device,+ defaultDevice,+ defaultChunkSize,+ makeSink,+ write,+ writeLazy,+ -- * play functions+ auto,+ autoAndRecord,+ autoAndRecordMany,+ monoToInt16,+ stereoToInt16,+ ) where++import qualified Sound.ALSA.PCM 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 Data.Int (Int16, )+import qualified System.IO as IO+import qualified System.Exit as Exit++-- 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.RealRing as RealRing++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold++import NumericPrelude.Numeric+import NumericPrelude.Base+++{- |+A suggested default chunk size.+It is not used by the functions in this module.+-}+{-+Better move to Storable.Server.Common or Dimensional.Server.Common?+-}+defaultChunkSize :: SigSt.ChunkSize+defaultChunkSize = SigSt.chunkSize 512+{-+At some epochs this chunk size leads to buffer underruns.+I cannot reproduce this:+Some months it works this way on Suse but not on Ubuntu or vice versa.+Other months it works the other way round.+defaultChunkSize = SigSt.chunkSize 256+-}+++type Device = String++defaultDevice :: Device+defaultDevice = "default"+++{- |+Useful values for the output device are++* @\"default\"@ for mixing with the output of other applications.++* @\"plughw:0,0\"@ for accessing sound output in an exclusive way.++* @\"tee:default,'output.raw',raw\"@ for playing and simultaneously writing raw data to disk.++* @\"tee:default,'output.wav',wav\"@ for playing and writing to WAVE file format.+ Note that the length cannot be written,+ when the program is terminated,+ leaving the file in an invalid format.+-}+makeSink ::+ (ALSA.SampleFmt y, RealRing.C t) =>+ Device {- ^ ALSA output device -} ->+ t {- ^ period (buffer) size expressed in seconds -} ->+ ALSA.SampleFreq {- ^ sample rate -} ->+ ALSA.SoundSink ALSA.Pcm y+makeSink device periodTime rate =+ ALSA.alsaSoundSinkTime device+ (ALSA.SoundFmt {+ ALSA.sampleFreq = rate+ }) $+ ALSA.SoundBufferTime+ (round (5000000*periodTime))+ (round (1000000*periodTime))++{-+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 y) =>+ ALSA.SoundSink handle y ->+ SigSt.T y -> IO ()+auto sink ys =+ ALSA.withSoundSink sink $ \to ->+ writeLazy sink to ys++{-# INLINE writeLazy #-}+writeLazy ::+ (Storable y) =>+ ALSA.SoundSink handle y -> handle y ->+ SVL.Vector y -> IO ()+writeLazy sink to ys =+ mapM_ (write sink to) (SVL.chunks ys)++{-# INLINE write #-}+write ::+ (Storable y) =>+ ALSA.SoundSink handle y -> handle y ->+ SVB.Vector y -> IO ()+write sink to 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++{- |+Play a signal and write it to disk via SoX simultaneously.+Consider using 'auto' with @tee@ device.+-}+{-# INLINE autoAndRecord #-}+autoAndRecord ::+ (ALSA.SampleFmt y, SoxFrame.C y) =>+ FilePath ->+ ALSA.SoundFmt y ->+ ALSA.SoundSink handle y ->+ SigSt.T y -> IO Exit.ExitCode+autoAndRecord fileName fmt sink =+ let rate = ALSA.sampleFreq fmt+ in (\act ->+ 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)+++{- |+Play a signal and write it to multiple files.+The Functor @f@ may be @Maybe@ for no or one file to write,+or @[]@ for many files to write.+-}+{-# INLINE autoAndRecordMany #-}+autoAndRecordMany ::+ (ALSA.SampleFmt y, SoxFrame.C y,+ Trav.Traversable f) =>+ f FilePath ->+ ALSA.SoundFmt y ->+ ALSA.SoundSink handle y ->+ SigSt.T y -> IO (f Exit.ExitCode)+autoAndRecordMany fileNames fmt sink =+ let rate = ALSA.sampleFreq fmt+ in (\act ->+ SoxWrite.manyExtended act SoxOption.none SoxOption.none fileNames rate) $ \hs ys ->+ ALSA.withSoundSink sink $ \to ->+ flip mapM_ (SVL.chunks ys) $ \c ->+ SVB.withStartPtr c $ \ptr size ->+ ALSA.soundSinkWrite sink to ptr size >>+ Fold.traverse_ (\h -> IO.hPutBuf h ptr (arraySize ptr size)) hs+++{-# INLINE monoToInt16 #-}+monoToInt16 ::+ (Storable y, RealRing.C y) =>+ ALSA.SoundSink handle Int16 ->+ SigSt.T y -> IO ()+monoToInt16 sink xs =+ auto sink (SigSt.map BinSmp.int16FromCanonical xs)++{-# INLINE stereoToInt16 #-}+stereoToInt16 ::+ (Storable y, RealRing.C y) =>+ ALSA.SoundSink handle (Stereo.T Int16) ->+ SigSt.T (Stereo.T y) -> IO ()+stereoToInt16 sink xs =+ auto sink (SigSt.map (fmap BinSmp.int16FromCanonical) xs)
+ src/Synthesizer/ALSA/Storable/Server.hs view
@@ -0,0 +1,113 @@+module Main where++import qualified Synthesizer.ALSA.Storable.Server.Run as Run+import qualified Synthesizer.ALSA.Storable.Server.Test as Test+import Synthesizer.ALSA.Storable.Server.Common+ (Real, play, sampleRate, chunkSize, periodTime, )++import qualified Synthesizer.Basic.Wave as Wave++import qualified Synthesizer.ALSA.Storable.Play as Play+import qualified Synthesizer.Storable.Oscillator as OsciSt+import qualified Synthesizer.Storable.Signal as SigSt+import qualified Data.StorableVector.Lazy as SVL++import NumericPrelude.Numeric (zero, )+import Prelude hiding (Real, break, id, (.), )+++{-+This program has still a very slowly growing memory leak.+-}+main :: IO ()+main =+ case 208::Int of+ 001 -> print Test.keyboard3+ 002 -> play (periodTime::Real) sampleRate Test.keyboard3+ 003 -> Test.speed+ 004 -> Test.frequency1+ 005 -> Test.frequency2+ 006 -> Test.frequency3+{-+ 007 -> Test.frequency4+-}+ 008 -> Test.keyboard1+ 009 -> SigSt.writeFile "test.f32" Test.keyboard2+ 010 -> SigSt.writeFile "test.f32" Test.keyboard3+ 011 -> SigSt.writeFile "test.f32" Test.keyboard4+ 012 -> SigSt.writeFile "test.f32" Test.keyboard5+{-+ 013 -> Test.keyboard6+ 014 -> Test.keyboard7+-}+ 015 -> Test.arrangeSpaceLeak0+ 016 -> Test.arrangeSpaceLeak1+ 018 -> Test.arrangeSpaceLeak3+ 019 -> Test.arrangeSpaceLeak4+ 020 -> Test.chordSpaceLeak1+-- 021 -> Test.chordSpaceLeak2+-- 022 -> Test.chordSpaceLeak3+-- 023 -> Test.chordSpaceLeak4+ 023 -> Test.sequencePitchBend+ 024 -> Test.sequencePitchBend1+ 025 -> Test.sequencePitchBend2+ 026 -> Test.sequencePitchBend3+ 027 -> Test.sequencePitchBend4+ 028 -> Test.sequencePitchBend4a+ 029 -> Test.sequencePitchBend4b+ 030 -> Test.sequencePitchBend4c+ 031 -> Test.sequencePitchBend4d+ 032 -> Test.sequencePitchBend4e+ 033 -> Test.sequencePitchBend5+ 040 -> Test.sequenceStaccato+ 050 -> Test.speed+ 051 -> Test.speedChunky+ 052 -> Test.speedArrange+ 053 -> Play.auto+{-+ (ALSA.alsaSoundSinkTime Play.defaultDevice+ (ALSA.SoundFmt {+ ALSA.sampleFreq = sampleRate+ }) $+ ALSA.SoundBufferTime+ (round (5000000*periodTime::Real))+ (round (1000000*periodTime::Real))+ ) $+-}+{-+ (ALSA.fileSoundSink "test.f32"+ (ALSA.SoundFmt {+ ALSA.sampleFreq = sampleRate+ })) $+-}+ (Play.makeSink Play.defaultDevice (periodTime::Real) sampleRate) $+ SVL.cycle $+ SigSt.take 100000 $+ OsciSt.static chunkSize (fmap (0.9*) Wave.sine) zero (1/100::Real)+ 054 -> Play.auto+ (Play.makeSink Play.defaultDevice (periodTime::Real) sampleRate) $+ OsciSt.static chunkSize (fmap (0.9*) Wave.sine)+ zero (600/sampleRate::Real)+ 055 -> play (periodTime::Real) sampleRate $+ OsciSt.static chunkSize (fmap (0.9*) Wave.sine)+ zero (600/sampleRate::Real)+ 100 -> Run.volume+ 101 -> Run.frequency+ 102 -> Run.frequencyCausal+ 103 -> Run.pitchBend+ 104 -> Run.volumeFrequency+ 105 -> Run.volumeFrequencyCausal+ 200 -> Run.keyboard+ 201 -> Run.keyboardMulti+ 202 -> Run.keyboardStereo+ 203 -> Run.keyboardPitchbend+ 204 -> Run.keyboardFM+ 205 -> Run.keyboardDetuneFM+ 206 -> Run.keyboardFilter+ 207 -> Run.keyboardSample+ 208 -> Run.keyboardVariousStereo+ 209 -> Run.keyboardSampleTFM+ 210 -> Run.keyboardNoisyTone+ 211 -> Run.keyboardFilteredNoisyTone+ 300 -> Run.keyboardCausal+ _ -> error "not implemented server part"
+ src/Synthesizer/ALSA/Storable/Server/Common.hs view
@@ -0,0 +1,101 @@+module Synthesizer.ALSA.Storable.Server.Common where++import qualified Sound.ALSA.PCM as ALSA+import qualified Sound.ALSA.Sequencer.Event as Event++import qualified Synthesizer.ALSA.Storable.Play as Play+import qualified Synthesizer.ALSA.EventList as MIDIEv+import Synthesizer.ALSA.EventList (StrictTime, )++import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Storable.Signal as SigSt+import qualified Data.StorableVector.Lazy as SVL++import qualified Sound.MIDI.Message.Channel as ChannelMsg+import Sound.MIDI.Message.Channel (Channel, )++import qualified Data.EventList.Relative.TimeBody as EventList++import qualified Sound.Sox.Frame as SoxFrame+import qualified System.Exit as Exit++import Control.Category ((.), )++import qualified Algebra.RealField as RealField+import qualified Algebra.Field as Field+import qualified Algebra.Ring as Ring+import qualified Algebra.ToInteger as ToInteger+import qualified Algebra.Additive as Additive++import NumericPrelude.Numeric (zero, round, )+import Prelude hiding (Real, round, break, id, (.), )+++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++periodTime :: Field.C t => t+periodTime =+ let (SVL.ChunkSize size) = chunkSize+ in ToInteger.fromIntegral size Field./ Ring.fromInteger sampleRate++device :: Play.Device+device = Play.defaultDevice++clientName :: MIDIEv.ClientName+clientName = MIDIEv.ClientName "Haskell-Synthesizer"+++type Real = Float+++{-# INLINE withMIDIEvents #-}+withMIDIEvents ::+ (Double -> Double -> a -> IO b) ->+ (EventList.T StrictTime [Event.T] -> a) -> IO b+withMIDIEvents action proc =+ let rate = sampleRate+ per = periodTime+ in MIDIEv.withMIDIEvents clientName per rate $+ action per rate . proc+++{-# INLINE play #-}+play ::+ (RealField.C t, Additive.C y, ALSA.SampleFmt y) =>+ t -> t -> SigSt.T y -> IO ()+play period rate =+ Play.auto (Play.makeSink device period (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 -> t -> SigSt.T y -> IO Exit.ExitCode+playAndRecord fileName period rate =+ let intRate = round rate+ in Play.autoAndRecord fileName+ (ALSA.SoundFmt {ALSA.sampleFreq = intRate})+ (Play.makeSink device period intRate) .+ SigSt.append (SigSt.replicate chunkSize latency zero)
+ src/Synthesizer/ALSA/Storable/Server/Run.hs view
@@ -0,0 +1,331 @@+module Synthesizer.ALSA.Storable.Server.Run where++import qualified Synthesizer.MIDI.Example.Instrument as Instr+import Synthesizer.ALSA.Storable.Server.Common+ (Real, withMIDIEvents, play, device, clientName,+ sampleRate, lazySize, chunkSize, periodTime, channel, )++import qualified Synthesizer.MIDI.CausalIO.Process as MIO+import qualified Synthesizer.MIDI.Storable as MidiSt+import Synthesizer.MIDI.Storable (applyModulation, )++import qualified Synthesizer.ALSA.CausalIO.Process as PAlsa+import qualified Synthesizer.CausalIO.Process as PIO++import qualified Synthesizer.Causal.Oscillator as OsciC+import qualified Synthesizer.Causal.Process as Causal+import qualified Synthesizer.Causal.Filter.NonRecursive as FiltNRC++import qualified Synthesizer.Basic.Wave as Wave++import qualified Synthesizer.Interpolation.Module as Ip++import qualified Synthesizer.Storable.Oscillator as OsciSt+import qualified Synthesizer.Storable.Signal as SigSt+import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV+import Foreign.Storable (Storable, )++import qualified Synthesizer.Generic.Loop as LoopG+import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.State.Signal as SigS+import qualified Synthesizer.Plain.Filter.Recursive as FiltR+import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter++import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg++import Control.Monad.Trans.State (evalState, )+import Control.Category ((.), )+import Control.Arrow (arr, second, (&&&), )++import Data.Tuple.HT (mapSnd, )++import NumericPrelude.Numeric (zero, (*>), (^?), )+import Prelude hiding (Real, round, break, id, (.), )++++volume :: IO ()+volume =+ putStrLn "run 'aconnect' to connect to the MIDI controller" >>+ (withMIDIEvents play $+ SigSt.zipWith (*)+ (OsciSt.static chunkSize Wave.sine zero (800/sampleRate)) .+ evalState (MidiSt.controllerLinear channel VoiceMsg.mainVolume (0,1) (0.2::Real)))++frequency :: IO ()+frequency =+ withMIDIEvents play $+ OsciSt.freqMod chunkSize Wave.sine zero .+ evalState (MidiSt.controllerExponential channel VoiceMsg.modulation+ (400/sampleRate, 1600/sampleRate) (800/sampleRate::Real))+++{-# INLINE storableChunk #-}+storableChunk ::+ (SigG.Read sig a, Storable a) =>+ sig a -> SV.Vector a+storableChunk chunk =+ SigS.toStrictStorableSignal (SigG.length chunk) $+ SigG.toState chunk++frequencyCausal :: IO ()+frequencyCausal =+ PAlsa.playFromEvents device clientName 0.01 (periodTime::Double) sampleRate+ ((PIO.fromCausal $+ Causal.applyStorableChunk $+ OsciC.freqMod (fmap (0.99*) Wave.sine) zero)+ .+ arr storableChunk+ .+ (MIO.controllerExponential channel VoiceMsg.modulation+ (400/sampleRate, 1600/sampleRate) (800/sampleRate::Real)))+++pitchBend :: IO ()+pitchBend =+ withMIDIEvents play $+ OsciSt.freqMod chunkSize Wave.sine zero .+ evalState (MidiSt.pitchBend channel 2 (880/sampleRate::Real))++volumeFrequency :: IO ()+volumeFrequency =+ putStrLn "run 'aconnect' to connect to the MIDI controller" >>+ (withMIDIEvents play $+ evalState (do+ vol <- MidiSt.controllerLinear channel VoiceMsg.mainVolume (0,1) 0.5+ freq <- MidiSt.pitchBend channel 2 (880/sampleRate::Real)+ return $+ SigSt.zipWith (*) vol+ (OsciSt.freqMod chunkSize Wave.sine zero freq)))++volumeFrequencyCausal :: IO ()+volumeFrequencyCausal =+ PAlsa.playFromEvents device clientName 0.01 (periodTime::Double) sampleRate+ ((PIO.fromCausal $+ Causal.applyStorableChunk $+ FiltNRC.envelope+ .+ second (OsciC.freqMod Wave.sine zero))+ .+ arr (uncurry (SV.zipWith (,)))+ .+ (arr storableChunk+ .+ MIO.controllerLinear channel VoiceMsg.mainVolume (0,0.99) (0.5::Real)+ &&&+ arr storableChunk+ .+ MIO.pitchBend channel 2 (880/sampleRate::Real)))+++keyboard :: IO ()+keyboard =+ withMIDIEvents play $+-- playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate::Real) .+ SigSt.map (0.2*) .+ evalState (MidiSt.sequence chunkSize channel Instr.tine)++keyboardMulti :: IO ()+keyboardMulti =+ withMIDIEvents play $+-- playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate::Real) .+ SigSt.map (0.2*) .+ evalState (MidiSt.sequenceMultiProgram chunkSize channel+ (VoiceMsg.toProgram 2)+ [Instr.pingDur, Instr.pingRelease, Instr.tine])++keyboardStereo :: IO ()+keyboardStereo =+ withMIDIEvents play $+-- playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate::Real) .+ SigSt.map ((0.2::Real)*>) .+ evalState (MidiSt.sequenceMultiProgram chunkSize channel+ (VoiceMsg.toProgram 1)+ [Instr.pingStereoRelease, Instr.tineStereo,+ Instr.softString, Instr.softStringCausal])++keyboardPitchbend :: IO ()+keyboardPitchbend =+ withMIDIEvents play $+ SigSt.map ((0.2::Real)*>) .+ evalState+ (do bend <- MidiSt.pitchBend channel (2^?(2/12)) 1+ MidiSt.sequenceModulated chunkSize bend channel Instr.stringStereoFM)++keyboardFM :: IO ()+keyboardFM =+ withMIDIEvents play $+ SigSt.map ((0.2::Real)*>) .+ evalState+ (do fm <- MidiSt.bendWheelPressure channel+ 2 (10/sampleRate) 0.04 0.03+ MidiSt.sequenceModulated chunkSize fm channel Instr.stringStereoFM)++keyboardDetuneFM :: IO ()+keyboardDetuneFM =+ withMIDIEvents play $+ SigSt.map ((0.2::Real)*>) .+ evalState+ (do fm <- MidiSt.bendWheelPressure channel+ 2 (10/sampleRate) 0.04 0.03+ detune <- MidiSt.controllerLinear channel+ VoiceMsg.vectorX (0,0.005) 0+ MidiSt.sequenceMultiModulated+ chunkSize channel Instr.stringStereoDetuneFM+ (applyModulation fm .+ applyModulation detune))+++keyboardFilter :: IO ()+keyboardFilter =+ withMIDIEvents play $+ SigSt.map (0.2*) .+ evalState+ (do music <- MidiSt.sequence chunkSize channel Instr.pingRelease+ freq <- MidiSt.controllerLinear channel+ -- VoiceMsg.vectorY+ (VoiceMsg.toController 21)+ (100/sampleRate, 5000/sampleRate)+ (700/sampleRate)+ return $+ SigS.toStorableSignal chunkSize $+ SigS.map UniFilter.lowpass $+ SigS.modifyModulated+ UniFilter.modifier+ (SigS.map UniFilter.parameter $+ SigS.zipWith FiltR.Pole+ (SigS.repeat (5 :: Real))+ (SigS.fromStorableSignal freq)) $+ SigS.fromStorableSignal music)+++keyboardSample :: IO ()+keyboardSample =+ do piano <- Instr.readPianoSample+ string <- Instr.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 (MidiSt.sequenceMultiProgram chunkSize channel+ (VoiceMsg.toProgram 5) $+ Instr.sampledSound piano :+ Instr.sampledSound string :+ Instr.sampledSound loopedString :+ Instr.sampledSound fadedString :+ Instr.sampledSound timeSineString :+ Instr.sampledSound timeZigZagString :+ Instr.sampledSoundTimeLoop Instr.loopTimeModSine string 8750 500 :+ Instr.sampledSoundTimeLoop Instr.loopTimeModZigZag string 8750 500 :+ [])+++keyboardVariousStereo :: IO ()+keyboardVariousStereo =+ do piano <- Instr.readPianoSample+ string <- Instr.readStringSample+ let loopedString =+ LoopG.timeReverse lazySize Ip.linear Ip.linear+ LoopG.timeControlZigZag 8750 500 string+ withMIDIEvents play $+ SigSt.map ((0.2::Real)*>) .+ evalState (MidiSt.sequenceMultiProgram chunkSize channel+ (VoiceMsg.toProgram 0) $+ Instr.pingStereoRelease :+ Instr.tineStereo :+ Instr.softString :+ Instr.sampledSoundDetuneStereo 0.001 piano :+ Instr.sampledSoundDetuneStereo 0.002 loopedString :+ Instr.sampledSoundDetuneStereoRelease 0.1 0.001 piano :+ Instr.sampledSoundDetuneStereoRelease 0.3 0.002 loopedString :+ [])+++keyboardSampleTFM :: IO ()+keyboardSampleTFM =+ do instr <- Instr.readPianoSample+ withMIDIEvents play $+ evalState+ (do fm <- MidiSt.bendWheelPressure channel+ 2 (10/sampleRate) 0.04 0.03+ speed <- MidiSt.controllerLinear channel+ (VoiceMsg.toController 22)+ (0,2) 1+ offset <- MidiSt.controllerLinear channel+ (VoiceMsg.toController 21)+ (0, fromIntegral (SVL.length (snd instr))) 0+ MidiSt.sequenceMultiModulated+ chunkSize channel (Instr.timeModulatedSample instr)+ (applyModulation fm .+ applyModulation speed .+ applyModulation offset))+++keyboardNoisePipe :: IO ()+keyboardNoisePipe =+ withMIDIEvents play $+ evalState+ (do fm <- MidiSt.bendWheelPressure channel+ 2 (10/sampleRate) 0.04 0.03+ resonance <-+ MidiSt.controllerExponential channel+ (VoiceMsg.toController 23)+ (1, 100) 10+ MidiSt.sequenceMultiModulated+ chunkSize channel Instr.colourNoise+ (applyModulation fm .+ applyModulation resonance))+++keyboardNoisyTone :: IO ()+keyboardNoisyTone =+ withMIDIEvents play $+ evalState+ (do fm <- MidiSt.bendWheelPressure channel+ 2 (10/sampleRate) 0.04 0.03+ speed <- MidiSt.controllerLinear channel+ (VoiceMsg.toController 21)+ (0,0.5) 0.1+ MidiSt.sequenceMultiModulated+ chunkSize channel Instr.toneFromNoise+ (applyModulation fm .+ applyModulation speed))+++keyboardFilteredNoisyTone :: IO ()+keyboardFilteredNoisyTone =+ withMIDIEvents play $+ evalState+ (do fm <- MidiSt.bendWheelPressure channel+ 2 (10/sampleRate) 0.04 0.03+ {-+ speed must never be zero,+ since this requires to fetch unlimited data from future.+ -}+ speed <- MidiSt.controllerLinear channel+ (VoiceMsg.toController 21)+ (0.05,0.5) 0.1+ cutoff <- MidiSt.controllerExponential channel+ (VoiceMsg.toController 22)+ (1, 30) 10+ resonance <- MidiSt.controllerExponential channel+ (VoiceMsg.toController 23)+ (1, 20) 5+ MidiSt.sequenceMultiModulated+ chunkSize channel Instr.toneFromFilteredNoise+ (applyModulation fm .+ applyModulation speed .+ applyModulation cutoff .+ applyModulation resonance))++++keyboardCausal :: IO ()+keyboardCausal =+ PAlsa.playFromEvents device clientName 0.01 (periodTime::Double) sampleRate $+ arr (SV.map (0.2*))+ .+ MIO.sequenceStorable channel (\ _pgm -> Instr.pingReleaseCausal)
+ src/Synthesizer/ALSA/Storable/Server/Test.hs view
@@ -0,0 +1,582 @@+module Synthesizer.ALSA.Storable.Server.Test where++import qualified Synthesizer.MIDI.Example.Instrument as Instr+import Synthesizer.ALSA.Storable.Server.Common+ (Real, withMIDIEvents, play,+ sampleRate, chunkSize, channel, )++import qualified Sound.ALSA.Sequencer.Address as Addr+import qualified Sound.ALSA.Sequencer.Event as Event++import qualified Synthesizer.MIDI.PiecewiseConstant as PC+import qualified Synthesizer.MIDI.Generic as Gen+import qualified Synthesizer.MIDI.Storable as MidiSt+import Synthesizer.MIDI.Storable (+ Instrument, chunkSizesFromLazyTime, )++import qualified Synthesizer.MIDI.EventList as MIDIEv+import Synthesizer.MIDI.EventList (+ LazyTime, StrictTime, Note(..), NoteBoundary(..),+ matchNoteEvents, getSlice, getControllerEvents, )++import qualified Synthesizer.Basic.Wave as Wave++import qualified Synthesizer.Causal.Process as Causal+import Control.Arrow ((<<<), )++import qualified Synthesizer.Storable.Cut as CutSt+import qualified Synthesizer.Storable.Oscillator as OsciSt+import qualified Synthesizer.Storable.Signal as SigSt+-- import qualified Data.StorableVector.Lazy.Builder as Bld+import qualified Data.StorableVector.Lazy.Pattern as SigStV+import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV++import qualified Synthesizer.State.Signal as SigS++import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg+import Sound.MIDI.Message.Channel.Voice (normalVelocity, )++import qualified Data.EventList.Relative.TimeBody as EventList+import qualified Data.EventList.Relative.BodyTime as EventListBT+import Data.EventList.Relative.MixedBody ((/.), (./), )++import qualified Control.Monad.Trans.State.Strict as MS+import Control.Monad.Trans.State (evalState, gets, )+import Control.Category ((.), )++import Data.Traversable (traverse, )++-- import qualified Numeric.NonNegative.Class as NonNeg+import qualified Numeric.NonNegative.Wrapper as NonNegW+import qualified Numeric.NonNegative.Chunky as NonNegChunky++import Data.Maybe.HT (toMaybe, )++import NumericPrelude.Numeric (zero, round, (^?), )+import Prelude hiding (Real, round, break, id, (.), )++++frequency1 :: IO ()+frequency1 =+ withMIDIEvents play $+ const+ (OsciSt.static chunkSize Wave.sine zero (800/sampleRate::Real))++frequency2 :: IO ()+frequency2 =+ withMIDIEvents (const $ const print) $+ evalState (getControllerEvents channel VoiceMsg.mainVolume)++frequency3 :: IO ()+frequency3 =+ withMIDIEvents (const $ const print) $+ evalState (getSlice Just)+++keyboard1 :: IO ()+keyboard1 =+ withMIDIEvents play $+ const (Instr.ping 0 440)++keyboard2 :: SigSt.T Real+keyboard2 =+ let music :: Real -> EventList.T StrictTime (SigSt.T Real)+ music x = 5 /. SigSt.replicate chunkSize 6 x ./ music (x+1)+ in CutSt.arrange chunkSize $+ EventList.mapTime fromIntegral $ music 42++keyboard3 :: SigSt.T Real+keyboard3 =+ let time :: Real -> Int+ time t = round (t * sampleRate)+ music :: Real -> EventList.T StrictTime (SigSt.T Real)+ music x =+ fromIntegral (time 0.2) /.+ SigSt.take (time 0.4) (Instr.ping 0 x) ./+ music (x*1.01)+ in CutSt.arrange chunkSize $+ EventList.mapTime fromIntegral $ music 110++makeLazyTime :: Real -> LazyTime+makeLazyTime t =+ NonNegChunky.fromNumber $+ NonNegW.fromNumberMsg "keyboard time" $+ round (t * sampleRate)++makeStrictTime :: Real -> StrictTime+makeStrictTime t =+ NonNegW.fromNumberMsg "keyboard time" $+ round (t * sampleRate)++pitch :: Int -> VoiceMsg.Pitch+pitch = VoiceMsg.toPitch++defaultProgram :: VoiceMsg.Program+defaultProgram = VoiceMsg.toProgram 0++embedDefaultProgram ::+ EventList.T StrictTime [NoteBoundary Bool] ->+ EventList.T StrictTime [NoteBoundary (Maybe VoiceMsg.Program)]+embedDefaultProgram =+ fmap (fmap (\(NoteBoundary p v b) ->+ NoteBoundary p v (toMaybe b defaultProgram)))++keyboard4 :: SigSt.T Real+keyboard4 =+ let {-+ idInstr :: Real -> Real -> SigSt.T Real+ idInstr _vel freq = SigSt.repeat chunkSize freq+ -}+-- inf = time 0.4 + inf+ music :: Int -> EventList.T StrictTime Note+ music p =+ makeStrictTime 0.2 /.+-- (pitch p, normalVelocity, inf) ./+ Note defaultProgram (pitch p) normalVelocity (makeLazyTime 0.4) ./+ music (p+1)+ in CutSt.arrange chunkSize $+ EventList.mapTime fromIntegral $+ fmap (Gen.renderInstrumentIgnoreProgram Instr.pingDur) $+ music 0+++notes0 :: Int -> EventList.T StrictTime (NoteBoundary Bool)+notes0 p =+ makeStrictTime 0.2 /.+ (let (oct,pc) = divMod p 12+ in (NoteBoundary (pitch (50 + pc)) normalVelocity (even oct)))+ ./+ notes0 (p+1)++notes1 :: EventList.T StrictTime (NoteBoundary Bool)+notes1 =+ makeStrictTime 0.2 /.+ (NoteBoundary (pitch 50) normalVelocity True) ./+ makeStrictTime 0.2 /.+ (NoteBoundary (pitch 52) normalVelocity True) ./+ makeStrictTime 0.2 /.+ (NoteBoundary (pitch 54) normalVelocity True) ./+ makeStrictTime 0.2 /.+-- (NoteBoundary (pitch 50) normalVelocity False) ./+ undefined++notes2 :: EventList.T StrictTime [NoteBoundary Bool]+notes2 =+ makeStrictTime 0.2 /.+ [] ./+ makeStrictTime 0.2 /.+ [] ./+ makeStrictTime 0.2 /.+ [NoteBoundary (pitch 50) normalVelocity True] ./+ makeStrictTime 0.2 /.+ [NoteBoundary (pitch 52) normalVelocity True] ./+ makeStrictTime 0.2 /.+ [NoteBoundary (pitch 54) normalVelocity True] ./+ makeStrictTime 0.2 /.+ [NoteBoundary (pitch 50) normalVelocity False] ./+ undefined++notes3 :: EventList.T StrictTime [NoteBoundary (Maybe VoiceMsg.Program)]+notes3 =+ embedDefaultProgram $+ notes2++keyboard5 :: SigSt.T Real+keyboard5 =+ CutSt.arrange chunkSize $+ EventList.mapTime fromIntegral $+ Gen.flatten $+ fmap (map (Gen.renderInstrumentIgnoreProgram Instr.pingDur)) $+ matchNoteEvents $+ notes3++keyboard6 :: EventList.T StrictTime [Note]+keyboard6 =+ matchNoteEvents $+ embedDefaultProgram $+ fmap (:[]) $+ notes1++keyboard7 :: EventList.T StrictTime [(VoiceMsg.Pitch, VoiceMsg.Velocity)]+keyboard7 =+ fmap (map (\ ~(Note _ p v _d) -> (p,v))) $+ keyboard6+++emptyEvents :: StrictTime -> EventList.T StrictTime [Event.T]+emptyEvents time =+ let evs = EventList.cons time [] evs+ in evs+++arrangeSpaceLeak0 :: IO ()+arrangeSpaceLeak0 =+ SVL.writeFile "test.f32" $+ CutSt.arrange chunkSize $+ evalState (Gen.sequence channel+ (error "no sound" :: Instrument Real Real)) $+ emptyEvents 10++arrangeSpaceLeak1 :: IO ()+arrangeSpaceLeak1 =+ SVL.writeFile "test.f32" $+ CutSt.arrange chunkSize $+ evalState+ (Gen.sequenceModulated+ (SigSt.iterate chunkSize (1+) 0) channel+ (error "no sound" :: SigSt.T Real -> Instrument Real Real)) $+ emptyEvents 10++makeNote :: Event.NoteEv -> Event.Pitch -> Event.T+makeNote typ pit =+ Event.simple Addr.subscribers $ Event.NoteEv typ $+ Event.simpleNote (Event.Channel 0) pit Event.normalVelocity++{-+a space leak can only be observed for more than one note,+maybe our 'break' improvement fixed the case for one played note+-}+arrangeSpaceLeak3 :: IO ()+arrangeSpaceLeak3 =+ SVL.writeFile "test.f32" $+ CutSt.arrange chunkSize $+ evalState+ (Gen.sequenceModulated+ (SigSt.iterate chunkSize (1e-7 +) 1) channel+ Instr.stringStereoFM) $+-- (const Instr.pingDur :: SigSt.T Real -> Instrument Real Real)) $+ let evs t = EventList.cons t ([]::[Event.T]) (evs (20-t))+ in -- EventList.cons 10 [makeNote MIDI.NoteOn 60] $+ -- EventList.cons 10 [makeNote MIDI.NoteOn 64] $+ evs 10++arrangeSpaceLeak4 :: IO ()+arrangeSpaceLeak4 =+ SVL.writeFile "test.f32" $+ evalState+ (do bend <- MidiSt.pitchBend channel (2^?(2/12)) 1+ MidiSt.sequenceModulated chunkSize bend channel Instr.stringStereoFM) $+ let evs t = EventList.cons t ([]::[Event.T]) (evs (20-t))+ in evs 10++chordSpaceLeak1 :: IO ()+chordSpaceLeak1 =+ SVL.writeFile "test.f32" $+ CutSt.arrange chunkSize $+ evalState (Gen.sequence channel Instr.pingDur) $+ let evs t = EventList.cons t [] (evs (20-t))+ in EventList.cons 10 [makeNote Event.NoteOn $ Event.Pitch 60] $+ EventList.cons 10 [makeNote Event.NoteOn $ Event.Pitch 64] $+ evs 10+++sequencePitchBend :: IO ()+sequencePitchBend =+ SVL.writeFile "test.f32" $+ CutSt.arrange chunkSize $+ evalState+ (let fm y = (EventListBT.cons $! y) 10 (fm (2-y))+ in Gen.sequenceModulated (fm 1) channel+ (error "no sound" ::+ PC.T Real -> Instrument Real Real)) $+ emptyEvents 10++sequencePitchBend1 :: IO ()+sequencePitchBend1 =+ SVL.writeFile "test.f32" $+ CutSt.arrange chunkSize $+ evalState+ (let fm y = EventListBT.cons y 10 (fm (2-y))+ instr :: PC.T Real -> Instrument Real Real+ instr = error "no sound"+ in Gen.sequenceCore+ channel Gen.errorNoProgram+ (Gen.Modulator (fm 1) Gen.advanceModulationChunk+ (\note -> gets $ \c ->+ Gen.renderInstrumentIgnoreProgram (instr c) note))) $+ emptyEvents 10++sequencePitchBend2 :: IO ()+sequencePitchBend2 =+ SVL.writeFile "test.f32" $+ let fm y = EventListBT.cons y 10 (fm (2-y))+ -- fm = EventListBT.cons 1 10 fm+ instr :: PC.T Real -> Instrument Real Real+ instr = error "no sound"+ evs = EventList.cons 10 [] evs+ md =+ Gen.Modulator+ (fm 1)+ Gen.advanceModulationChunkPC+ -- Gen.advanceModulationChunk+ (\note -> gets $ \c ->+ Gen.renderInstrumentIgnoreProgram (instr c) note)+ in CutSt.arrange chunkSize .+ EventList.mapTime fromIntegral .+ Gen.flatten .+ Gen.applyModulator md $+ evs++sequencePitchBend3 :: IO ()+sequencePitchBend3 =+ SVL.writeFile "test.f32" $+ let fm y = EventListBT.cons y 10 (fm (2-y))+ -- fm = EventListBT.cons 1 10 fm+ instr :: PC.T Real -> Instrument Real Real+ instr = error "no sound"+ evs = EventList.cons 10 [] evs+ modEvent note =+ gets $ \c ->+ Gen.renderInstrumentIgnoreProgram (instr c) note+ in CutSt.arrange chunkSize .+ EventList.mapTime fromIntegral .+ Gen.flatten .+ flip evalState (fm 1) .+ EventList.traverse+ Gen.advanceModulationChunk+ (traverse modEvent) $+ evs++sequencePitchBend4 :: IO ()+sequencePitchBend4 =+ SVL.writeFile "test.f32" $+ let fm y = y : fm (2-y)+ -- fm = repeat 1+ instr :: [Real] -> Instrument Real Real+ instr = error "no sound"+ evs = EventList.cons 10 [] evs+ modEvent note =+ gets $ \c ->+ Gen.renderInstrumentIgnoreProgram (instr c) note+ in CutSt.arrange chunkSize .+ EventList.mapTime fromIntegral .+ Gen.flatten .+ flip evalState (fm 1) .+ EventList.traverse+ Gen.advanceModulationChunk+ (traverse modEvent) $+ evs++sequencePitchBend4a :: IO ()+sequencePitchBend4a =+ SVL.writeFile "test.f32" $+ let fm y = y : fm (2-y)+ -- fm = repeat 1+ instr :: [Real] -> Instrument Real Real+ instr = error "no sound"+ evs = EventList.cons 10 [] evs+ modEvent note =+ MS.gets $ \c ->+ Gen.renderInstrumentIgnoreProgram (instr c) note+ in CutSt.arrange chunkSize .+ EventList.mapTime fromIntegral .+ Gen.flatten .+ flip MS.evalState (fm 1) .+ EventList.traverse+ Gen.advanceModulationChunkStrict+ (traverse modEvent) $+ evs++sequencePitchBend4b :: IO ()+sequencePitchBend4b =+ SVL.writeFile "test.f32" $+ let fm y = y : fm (2-y)+ -- fm = repeat 1+ instr :: [Real] -> Instrument Real Real+ instr = error "no sound"+ evs = EventList.cons 10 [] evs+ in CutSt.arrange chunkSize .+ Gen.flatten $+ EventList.foldrPair+ (\t bs0 go s0 ->+ let s1 = tail s0+ bs1 =+ map (Gen.renderInstrumentIgnoreProgram (instr s1)) bs0+ in EventList.cons+ (if null s1 then t else t) bs1 $+ go s1)+ (const EventList.empty) evs (fm 1)++sequencePitchBend4c :: IO ()+sequencePitchBend4c =+ SVL.writeFile "test.f32" $+ let fm y = y : fm (2-y)+ -- fm = repeat 1+ instr :: [Real] -> Instrument Real Real+ instr = error "no sound"+ in CutSt.arrange chunkSize .+ Gen.flatten .+ EventList.fromPairList $+ foldr+ (\(t,bs0) go s0 ->+ let s1 = tail s0+ bs1 =+ map (Gen.renderInstrumentIgnoreProgram (instr s1)) bs0+ in (if null s1 then t else t, bs1) :+ go s1)+ (const [])+ (repeat (10,[]))+ (fm 1)++sequencePitchBend4d :: IO ()+sequencePitchBend4d =+ SVL.writeFile "test.f32" $+ let fm y = y : fm (2-y)+ -- fm = repeat 1+ in CutSt.arrange chunkSize .+ EventList.fromPairList $+ foldr+ (\(t,b) go s0 ->+ let s1 = tail s0+ in (if null s1 then t else t,+ if null s1 then b else b) :+ go s1)+ (const [])+ (repeat (10, SigSt.empty :: SigSt.T Real))+ (fm 1 :: [Real])++sequencePitchBend4e :: IO ()+sequencePitchBend4e =+ writeFile "test.txt" $+ foldr+ (\c go s0 ->+ let s1 = tail s0+ in (if null s1 then c else c) :+ go s1)+ (const [])+ (repeat 'a')+ (iterate not False)+ -- (repeat True)++sequencePitchBend5 :: IO ()+sequencePitchBend5 =+ SVL.writeFile "test.f32" $+ let fm y = SigSt.iterate (SVL.ChunkSize 1) (y+) 0+ instr :: SigSt.T Real -> Instrument Real Real+ instr = error "no sound"+ evs = EventList.cons 10 [] evs+ modEvent note =+ gets $ \c ->+ Gen.renderInstrumentIgnoreProgram (instr c) note+ in CutSt.arrange chunkSize .+ EventList.mapTime fromIntegral .+ Gen.flatten .+ flip evalState (fm 1e-6) .+ EventList.traverse+ Gen.advanceModulationChunk+ (traverse modEvent) $+ evs++dummySound :: Instrument Real Real+dummySound =+ \vel freq dur ->+ SigStV.take (chunkSizesFromLazyTime dur) $+ SigSt.repeat chunkSize (vel + 1e-3*freq)++sequenceStaccato :: IO ()+sequenceStaccato =+ SVL.writeFile "test.f32" $+ let evs t =+ EventList.cons t [Right $ NoteBoundary (pitch 60) normalVelocity True] $+ EventList.cons t [Right $ NoteBoundary (pitch 60) normalVelocity False] $+ evs (20-t)+ in CutSt.arrange chunkSize .+ EventList.mapTime fromIntegral .+ Gen.flatten .+ EventList.mapBody+ (map (Gen.renderInstrumentIgnoreProgram dummySound)) .+ MIDIEv.matchNoteEvents .+ MIDIEv.embedPrograms defaultProgram $+ evs 10++sequenceStaccato3 :: IO ()+sequenceStaccato3 =+ SVL.writeFile "test.f32" $+ let evs t =+ EventList.cons t [NoteBoundary (pitch 60) normalVelocity (Just defaultProgram)] $+ EventList.cons t [NoteBoundary (pitch 60) normalVelocity Nothing] $+ evs (20-t)+ in CutSt.arrange chunkSize .+ EventList.mapTime fromIntegral .+ Gen.flatten .+ EventList.mapBody+ (map (Gen.renderInstrumentIgnoreProgram dummySound)) .+ MIDIEv.matchNoteEvents $+ evs 10++sequenceStaccato2 :: IO ()+sequenceStaccato2 =+ SVL.writeFile "test.f32" $+ let p = Event.Pitch 60+ evs t =+ EventList.cons t [makeNote Event.NoteOn p] $+ EventList.cons t [makeNote Event.NoteOff p] $+ evs (20-t)+ in CutSt.arrange chunkSize .+ EventList.mapTime fromIntegral .+ Gen.flatten .+ EventList.mapBody+ (map (Gen.renderInstrumentIgnoreProgram dummySound)) .+ MIDIEv.matchNoteEvents .+ MIDIEv.embedPrograms defaultProgram .+ evalState (MIDIEv.getNoteEvents channel) $+ evs 10++sequenceStaccato1 :: IO ()+sequenceStaccato1 =+ SVL.writeFile "test.f32" $+ CutSt.arrange chunkSize $+ evalState (Gen.sequence channel dummySound) $+ let p = Event.Pitch 60+ evs t =+ EventList.cons t [makeNote Event.NoteOn p] $+ EventList.cons t [makeNote Event.NoteOff p] $+ evs (20-t)+ in evs 10+++speed :: IO ()+speed =+ let _sig =+ Causal.apply+ (Instr.softStringCausalProcess 440 <<<+ Instr.softStringReleaseEnvelopeCausalProcess 0)+ (SigS.repeat True)+ sig =+ Causal.apply+ (Instr.softStringCausalProcess 440)+ (SigS.repeat 1)+ in SV.writeFile "speed.f32" $+ SigS.runViewL sig+ (\next s -> fst $ SV.unfoldrN 1000000 next s)++speedChunky :: IO ()+speedChunky =+ let sig =+ Causal.apply+ (Instr.softStringCausalProcess 440 <<<+ Instr.softStringReleaseEnvelopeCausalProcess 0)+ (SigS.repeat True)+ in SVL.writeFile "speed.f32" $+ SigSt.take 1000000 $+ SigS.toStorableSignal (SVL.chunkSize 100) sig+{-+ SigS.runViewL sig+ (\next s -> SVL.take 1000000 (SVL.unfoldr (SVL.chunkSize 100) next s))+-}++speedArrange :: IO ()+speedArrange =+ let sig =+ Causal.apply+ (Instr.softStringCausalProcess 440 <<<+ Instr.softStringReleaseEnvelopeCausalProcess 0)+ (SigS.repeat True)+ sigSt =+ SigS.toStorableSignal (SVL.chunkSize 100) sig+ in SVL.writeFile "speed.f32" $+ SigSt.take 1000000 $+ CutSt.arrangeEquidist (SVL.chunkSize 100) $+ EventList.fromPairList [(10000,sigSt)]
− src/Synthesizer/CausalIO/ALSA/MIDIControllerSelection.hs
@@ -1,112 +0,0 @@-module Synthesizer.CausalIO.ALSA.MIDIControllerSelection (- fromChannel,- filter,- T(Cons),-- controllerLinear,- controllerExponential,- pitchBend,- channelPressure,- ) where--import qualified Synthesizer.CausalIO.Process as PIO-import qualified Synthesizer.CausalIO.ALSA.Process as PAlsa--import qualified Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet as PCS-import qualified Synthesizer.EventList.ALSA.MIDI as MIDIEv-import qualified Synthesizer.MIDIValue as MV--import qualified Sound.ALSA.Sequencer.Event as Event---- import qualified Data.EventList.Relative.TimeBody as EventList-import qualified Data.EventList.Relative.TimeTime as EventListTT--import qualified Algebra.Transcendental as Trans-import qualified Algebra.Field as Field--import qualified Data.Map as Map-import qualified Data.Maybe as Maybe-import Data.Tuple.HT (mapSnd, )--import Control.Arrow (Arrow, )--import NumericPrelude.Numeric-import NumericPrelude.Base hiding ((.), filter, )-import Prelude ()----fromChannel ::- (Arrow arrow) =>- MIDIEv.Channel ->- arrow- (EventListTT.T MIDIEv.StrictTime [Event.T])- (EventListTT.T MIDIEv.StrictTime [(PCS.Controller, Int)])-fromChannel chan =- PAlsa.mapMaybe $ PCS.maybeController chan----- see PCS.mapInsertMany-mapInsertMany ::- (Ord key) =>- [(key,a)] -> Map.Map key a -> Map.Map key a-mapInsertMany assignments inits =- foldl (flip (uncurry Map.insert)) inits assignments----data T a =- Cons PCS.Controller (Int -> a) a--filter ::- [T a] ->- PIO.T- (EventListTT.T MIDIEv.StrictTime [(PCS.Controller, Int)])- (PCS.T Int a)-filter mapping =- let dict =- Map.fromList $- zipWith (\n (Cons cc f _init) -> (cc, (n, f)))- [0 ..] mapping- in PIO.mapAccum- (\evs curMap ->- let ctrlEvs =- fmap (Maybe.mapMaybe (\(cc, val) ->- fmap (mapSnd ($val)) $ Map.lookup cc dict)) evs- in (PCS.Cons curMap ctrlEvs,- mapInsertMany- (concat $ EventListTT.getBodies ctrlEvs)- curMap))- (Map.fromList $ zip [0..] $- map (\(Cons _cc _f initVal) -> initVal) mapping)---controllerLinear ::- (Field.C y) =>- MIDIEv.Controller ->- (y,y) -> y ->- T y-controllerLinear ctrl bnd initial =- Cons (PCS.Controller ctrl) (MV.controllerLinear bnd) initial--controllerExponential ::- (Trans.C y) =>- MIDIEv.Controller ->- (y,y) -> y ->- T y-controllerExponential ctrl bnd initial =- Cons (PCS.Controller ctrl) (MV.controllerExponential bnd) initial--pitchBend ::- (Trans.C y) =>- y -> y ->- T y-pitchBend range center =- Cons PCS.PitchBend (MV.pitchBend range center) center--channelPressure ::- (Trans.C y) =>- y -> y ->- T y-channelPressure maxVal initial =- Cons PCS.Pressure (MV.controllerLinear (zero,maxVal)) initial
− src/Synthesizer/CausalIO/ALSA/MIDIControllerSet.hs
@@ -1,156 +0,0 @@-module Synthesizer.CausalIO.ALSA.MIDIControllerSet (- T,- fromChannel,- slice, PCS.Controller(..),-- controllerLinear,- controllerExponential,- pitchBend,- channelPressure,- bendWheelPressure,- ) where--import qualified Synthesizer.CausalIO.Process as PIO-import qualified Synthesizer.CausalIO.ALSA.Process as PAlsa--import qualified Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet as PCS-import qualified Synthesizer.PiecewiseConstant.Signal as PC-import qualified Synthesizer.EventList.ALSA.MIDI as MIDIEv-import qualified Synthesizer.MIDIValue.BendModulation as BM-import qualified Synthesizer.MIDIValue.BendWheelPressure as BWP-import qualified Synthesizer.MIDIValue as MV--import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg-import qualified Sound.ALSA.Sequencer.Event as Event---- import qualified Data.EventList.Relative.TimeBody as EventList-import qualified Data.EventList.Relative.TimeTime as EventListTT-import qualified Data.EventList.Relative.BodyTime as EventListBT-import qualified Data.EventList.Relative.MixedTime as EventListMT--import qualified Algebra.Transcendental as Trans-import qualified Algebra.Field as Field-import qualified Algebra.RealRing as RealRing--import qualified Control.Monad.Trans.State as MS--import qualified Data.Accessor.Basic as Acc--import qualified Data.Map as Map--import Data.Traversable (Traversable, traverse, )-import Data.Foldable (traverse_, )--import Control.Arrow (Arrow, arr, )-import Control.Category ((.), )--import qualified Data.Maybe as Maybe-import Data.Maybe.HT (toMaybe, )--import NumericPrelude.Numeric-import NumericPrelude.Base hiding ((.), )-import Prelude ()------ see PCS.mapInsertMany-mapInsertMany ::- (Ord key) =>- [(key,a)] -> Map.Map key a -> Map.Map key a-mapInsertMany assignments inits =- foldl (flip (uncurry Map.insert)) inits assignments---fromChannel ::- MIDIEv.Channel ->- PIO.T- (EventListTT.T MIDIEv.StrictTime [Event.T])- (PCS.T PCS.Controller Int)-fromChannel chan =- (PIO.traverse Map.empty $ \evs0 -> do- initial <- MS.get- fmap (PCS.Cons initial) $- traverse (\ys -> MS.modify (mapInsertMany ys) >> return ys) evs0)- .- PAlsa.mapMaybe (PCS.maybeController chan)---type T arrow y =- arrow- (PCS.T PCS.Controller Int)- (EventListBT.T PC.ShortStrictTime y)---slice ::- (Arrow arrow) =>- PCS.Controller ->- (Int -> y) {- ^ This might be a function from "Synthesizer.MIDIValue"- or "Synthesizer.Dimensional.MIDIValue" -} ->- y ->- T arrow y-slice c f deflt =- arr $ \(PCS.Cons initial stream) ->- let yin = maybe deflt f $ Map.lookup c initial- in PC.subdivideLongStrict $- EventListMT.consBody yin $- flip MS.evalState yin $- traverse- (\ys -> traverse_ (MS.put . f) ys >> MS.get) $- fmap- (Maybe.mapMaybe- (\(ci,a) -> toMaybe (c==ci) a))- stream---controllerLinear ::- (Field.C y, Arrow arrow) =>- MIDIEv.Controller ->- (y,y) -> y ->- T arrow y-controllerLinear ctrl bnd initial =- slice (PCS.Controller ctrl) (MV.controllerLinear bnd) initial--controllerExponential ::- (Trans.C y, Arrow arrow) =>- MIDIEv.Controller ->- (y,y) -> y ->- T arrow y-controllerExponential ctrl bnd initial =- slice (PCS.Controller ctrl) (MV.controllerExponential bnd) initial--pitchBend ::- (Trans.C y, Arrow arrow) =>- y -> y ->- T arrow y-pitchBend range center =- slice PCS.PitchBend (MV.pitchBend range center) center--channelPressure ::- (Trans.C y, Arrow arrow) =>- y -> y ->- T arrow y-channelPressure maxVal initial =- slice PCS.Pressure (MV.controllerLinear (zero,maxVal)) initial--bendWheelPressure ::- (RealRing.C y, Trans.C y, Arrow arrow) =>- Int -> y -> y ->- T arrow (BM.T y)-bendWheelPressure pitchRange wheelDepth pressDepth =- arr $ \(PCS.Cons initial stream) ->- let set key field =- maybe id (Acc.set field) $- Map.lookup key initial- yin =- set PCS.PitchBend BWP.bend $- set (PCS.Controller VoiceMsg.modulation) BWP.wheel $- set PCS.Pressure BWP.pressure $- BWP.deflt- in PC.subdivideLongStrict $- fmap (BM.fromBendWheelPressure pitchRange wheelDepth pressDepth) $- EventListMT.consBody yin $- flip MS.evalState yin $- traverse (\ys0 -> traverse_ MS.put ys0 >> MS.get) $- fmap Maybe.catMaybes $- flip MS.evalState BWP.deflt $- traverse (traverse PCS.checkBendWheelPressure) stream
− src/Synthesizer/CausalIO/ALSA/Process.hs
@@ -1,728 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-module Synthesizer.CausalIO.ALSA.Process (- Events,- playFromEvents,-- slice,- controllerLinear,- controllerExponential,- pitchBend,- channelPressure,- bendWheelPressure,- constant,-- Instrument,- Bank,- GateChunk,- noteEvents,- embedPrograms,- applyInstrument,- applyModulatedInstrument,- flattenControlSchedule,- applyModulation,- arrangeStorable,- sequenceCore,- sequenceModulated,- sequenceModulatedMultiProgram,- sequenceStorable,-- -- auxiliary function- initWith,- mapMaybe,- ) where--import qualified Synthesizer.CausalIO.Gate as Gate-import qualified Synthesizer.CausalIO.Process as PIO--import qualified Synthesizer.PiecewiseConstant.Signal as PC-import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as AlsaPC-import qualified Synthesizer.EventList.ALSA.MIDI as MIDIEv-import qualified Synthesizer.Storable.ALSA.Play as Play-import qualified Synthesizer.Storable.Cut as CutSt-import qualified Synthesizer.Generic.Cut as CutG-import qualified Synthesizer.Zip as Zip-import Synthesizer.EventList.ALSA.MIDI (StrictTime, )--import qualified Synthesizer.MIDIValue.BendModulation as BM-import qualified Synthesizer.MIDIValue.BendWheelPressure as BWP-import qualified Synthesizer.MIDIValue as MV--import qualified Sound.ALSA.PCM as PCM-import qualified Sound.ALSA.Sequencer.Event as Event--import qualified Sound.MIDI.ALSA.Check as Check-import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg--import Control.DeepSeq (NFData, rnf, )--import qualified Data.EventList.Relative.TimeBody as EventList-import qualified Data.EventList.Relative.BodyTime as EventListBT-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.Absolute.TimeBody as AbsEventList--import qualified Numeric.NonNegative.Wrapper as NonNegW-import qualified Numeric.NonNegative.Class as NonNeg--import qualified Algebra.Transcendental as Trans-import qualified Algebra.RealField as RealField-import qualified Algebra.RealRing as RealRing-import qualified Algebra.Field as Field-import qualified Algebra.Additive as Additive-import qualified Algebra.ToInteger as ToInteger--import qualified Data.StorableVector as SV-import qualified Data.StorableVector.ST.Strict as SVST-import Foreign.Storable (Storable, )--import Control.Exception (bracket, )--import qualified Control.Monad.Trans.Writer as MW-import qualified Control.Monad.Trans.State as MS-import qualified Control.Monad.Trans.Class as MT-import Control.Monad.IO.Class (liftIO, )--import qualified Data.Traversable as Trav-import Data.Traversable (Traversable, )-import Data.Foldable (traverse_, )--import Control.Arrow (Arrow, arr, (^<<), (<<^), )-import Control.Category ((.), )--import qualified Data.Map as Map--import qualified Data.List.HT as ListHT-import qualified Data.Maybe as Maybe-import Data.Monoid (Monoid, mempty, mappend, )-import Data.Maybe (maybeToList, )-import Data.Tuple.HT (mapFst, mapPair, )--import NumericPrelude.Numeric-import NumericPrelude.Base hiding ((.), sequence, )-import Prelude ()---type Events = EventListTT.T StrictTime [Event.T]--playFromEvents ::- (RealField.C time, PCM.SampleFmt a, Additive.C a) =>- Play.Device -> MIDIEv.ClientName -> time -> time -> PCM.SampleFreq ->- PIO.T Events (SV.Vector a) ->- IO ()-playFromEvents device name latency beat rate- (PIO.Cons next create delete) =- let sink = Play.makeSink device beat rate- rateFloat = fromIntegral rate- in MIDIEv.withMIDIEventsChunked name beat rateFloat $ \getEventsList ->- PCM.withSoundSink sink $ \to ->-{-- Play.writeLazy sink to- (SVL.replicate- (SVL.chunkSize $ round (beat * rateFloat))- (round (latency * rateFloat))- (zero::Float))--}- Play.write sink to- (SV.replicate (round (latency * rateFloat)) zero) >>- (bracket create delete $ \state ->- let loop getEvs0 s0 =- case getEvs0 of- [] -> return ()- getEvents : getEvs1 -> do- evs <- getEvents- (pcm, s1) <- next evs s0- Play.write sink to pcm- loop getEvs1 s1- in loop getEventsList state)---initWith ::- (y -> c) ->- c ->- PIO.T- (EventListTT.T StrictTime [y])- (EventListBT.T PC.ShortStrictTime c)-initWith f initial =- PIO.traverse initial $- \evs0 -> do- y0 <- MS.get- fmap (PC.subdivideLongStrict . EventListMT.consBody y0) $- Trav.traverse (\ys -> traverse_ (MS.put . f) ys >> MS.get) evs0--slice ::- (Event.T -> Maybe Int) ->- (Int -> y) -> y ->- PIO.T- Events- (EventListBT.T PC.ShortStrictTime y)-slice select f initial =- initWith f initial . mapMaybe select----mapMaybe ::- (Arrow arrow, Functor f) =>- (a -> Maybe b) ->- arrow (f [a]) (f [b])-mapMaybe f =- arr $ fmap $ Maybe.mapMaybe f--catMaybes ::- (Arrow arrow, Functor f) =>- arrow (f [Maybe a]) (f [a])-catMaybes =- arr $ fmap Maybe.catMaybes--traverse ::- (Traversable f) =>- s -> (a -> MS.State s b) ->- PIO.T (f [a]) (f [b])-traverse initial f =- PIO.traverse initial (Trav.traverse (Trav.traverse f))---controllerLinear ::- (Field.C y) =>- MIDIEv.Channel ->- MIDIEv.Controller ->- (y,y) -> y ->- PIO.T- Events- (EventListBT.T PC.ShortStrictTime y)-controllerLinear chan ctrl bnd initial =- slice (Check.controller chan ctrl)- (MV.controllerLinear bnd) initial--controllerExponential ::- (Trans.C y) =>- MIDIEv.Channel ->- MIDIEv.Controller ->- (y,y) -> y ->- PIO.T- Events- (EventListBT.T PC.ShortStrictTime y)-controllerExponential chan ctrl bnd initial =- slice (Check.controller chan ctrl)- (MV.controllerExponential bnd) initial--pitchBend ::- (Trans.C y) =>- MIDIEv.Channel ->- y -> y ->- PIO.T- Events- (EventListBT.T PC.ShortStrictTime y)-pitchBend chan range center =- slice (Check.pitchBend chan)- (MV.pitchBend range center) center--channelPressure ::- (Trans.C y) =>- MIDIEv.Channel ->- y -> y ->- PIO.T- Events- (EventListBT.T PC.ShortStrictTime y)-channelPressure chan maxVal initial =- slice (Check.channelPressure chan)- (MV.controllerLinear (zero,maxVal)) initial--bendWheelPressure ::- (RealRing.C y, Trans.C y) =>- MIDIEv.Channel ->- Int -> y -> y ->- PIO.T- Events- (EventListBT.T PC.ShortStrictTime (BM.T y))-bendWheelPressure chan- pitchRange wheelDepth pressDepth =- let toBM = BM.fromBendWheelPressure pitchRange wheelDepth pressDepth- in initWith toBM (toBM BWP.deflt)- .- catMaybes- .- traverse BWP.deflt (AlsaPC.checkBendWheelPressure chan)----- might be moved to synthesizer-core-constant ::- (Arrow arrow) =>- y -> arrow Events (EventListBT.T PC.ShortStrictTime y)-constant y = arr $- EventListBT.singleton y .- NonNegW.fromNumberMsg "CausalIO.ALSA.constant" .- fromIntegral .- EventListTT.duration--_constant ::- (Arrow arrow, CutG.Read input) =>- y -> arrow input (EventListBT.T PC.ShortStrictTime y)-_constant y = arr $- EventListBT.singleton y .- NonNegW.fromNumberMsg "CausalIO.ALSA.constant" .- CutG.length----noteEvents ::- (Arrow arrow) =>- MIDIEv.Channel ->- arrow- (EventListTT.T StrictTime [Event.T])- (EventListTT.T StrictTime- [Either MIDIEv.Program (MIDIEv.NoteBoundary Bool)])-noteEvents chan =- mapMaybe $ MIDIEv.checkNoteEvent chan---embedPrograms ::- MIDIEv.Program ->- PIO.T- (EventListTT.T StrictTime- [Either MIDIEv.Program (MIDIEv.NoteBoundary Bool)])- (EventListTT.T StrictTime- [MIDIEv.NoteBoundary (Maybe MIDIEv.Program)])-embedPrograms initPgm =- catMaybes .- traverse initPgm MIDIEv.embedProgramState---type GateChunk = Gate.Chunk MIDIEv.Velocity-type Instrument y chunk = y -> y -> PIO.T GateChunk chunk-type Bank y chunk = MIDIEv.Program -> Instrument y chunk----{--for distinction of notes with the same pitch--We must use Integer instead of Int, in order to avoid an overflow-that would invalidate the check for unmatched NoteOffs-that is based on comparison of the NoteIds.-We cannot re-use NoteIds easily,-since the events at one time point are handled out of order.--}-newtype NoteId = NoteId Integer- deriving (Show, Eq, Ord)--succNoteId :: NoteId -> NoteId-succNoteId (NoteId n) = NoteId (n+1)--flattenNoteIdRange :: (NoteId,NoteId) -> [NoteId]-flattenNoteIdRange (start,afterEnd) =- takeWhile (<afterEnd) $ iterate succNoteId start---newtype NoteOffList =- NoteOffList {- unwrapNoteOffList :: EventListTT.T StrictTime [NoteBoundary NoteId]- }---instance CutG.Read NoteOffList where- null (NoteOffList evs) =- EventListTT.isPause evs && EventListTT.duration evs == 0- length = fromIntegral . EventListTT.duration . unwrapNoteOffList--instance CutG.NormalForm NoteOffList where- evaluateHead =- EventListMT.switchTimeL (\t _ -> rnf (NonNegW.toNumber t)) .- unwrapNoteOffList--instance Monoid NoteOffList where- mempty = NoteOffList (EventListTT.pause mempty)- mappend (NoteOffList xs) (NoteOffList ys) =- NoteOffList (mappend xs ys)--{- |-The function defined here are based on the interpretation-of event lists as piecewise constant signals.-They do not fit to the interpretation of atomic events.-Because e.g. it makes no sense to split an atomic event into two instances by splitAt,-and it is also not clear, whether dropping the first chunk-shall leave a chunk of length zero-or remove that chunk completely.--}-instance CutG.Transform NoteOffList where- take n (NoteOffList xs) =- NoteOffList $- EventListTT.takeTime- (NonNegW.fromNumberMsg "NoteOffList.take" $ fromIntegral n) xs- drop n (NoteOffList xs) =- NoteOffList $- EventListTT.dropTime- (NonNegW.fromNumberMsg "NoteOffList.drop" $ fromIntegral n) xs- splitAt n (NoteOffList xs) =- mapPair (NoteOffList, NoteOffList) $- EventListTT.splitAtTime- (NonNegW.fromNumberMsg "NoteOffList.splitAtTime" $ fromIntegral n) xs-- -- cf. ChunkySize.dropMarginRem- dropMarginRem =- CutG.dropMarginRemChunky- (fmap fromIntegral . EventListTT.getTimes . unwrapNoteOffList)-- reverse (NoteOffList xs) =- NoteOffList . EventListTT.reverse $ xs---findEvent ::- (a -> Bool) ->- EventListTT.T StrictTime [a] ->- (EventListTT.T StrictTime [a], Maybe a)-findEvent p =- EventListTT.foldr- (\t -> mapFst (EventListMT.consTime t))- (\evs rest ->- case ListHT.break p evs of- (prefix, suffix) ->- mapFst (EventListMT.consBody prefix) $- case suffix of- [] -> rest- ev:_ -> (EventListTT.pause mempty, Just ev))- (EventListBT.empty, Nothing)--gateFromNoteOffs ::- (MIDIEv.Pitch, NoteId) ->- NoteOffList ->- GateChunk-gateFromNoteOffs pitchNoteId (NoteOffList noteOffs) =- let dur = EventListTT.duration noteOffs- (sustain, mEnd) =- findEvent- (\bnd ->- case bnd of- -- AllNotesOff -> True- NoteBoundary endPitch _ noteId ->- pitchNoteId == (endPitch, noteId))- noteOffs- in Gate.chunk dur $- flip fmap mEnd $ \end ->- (EventListTT.duration sustain,- case end of- NoteBoundary _ endVel _ -> endVel- {-- AllNotesOff ->- VoiceMsg.toVelocity VoiceMsg.normalVelocity -} )---data NoteBoundary a =- NoteBoundary VoiceMsg.Pitch VoiceMsg.Velocity a--- | AllSoundOff- deriving (Eq, Show)--{- |-We count NoteIds per pitch,-such that the pair (pitch,noteId) identifies a note.-We treat nested notes in a first-in-first-out order (FIFO).-E.g.--> On, On, On, Off, Off, Off--is interpreted as--> On 0, On 1, On 2, Off 0, Off 1, Off 2--NoteOffs without previous NoteOns are thrown away.--}-assignNoteIds ::- (Traversable f) =>- PIO.T- (f [MIDIEv.NoteBoundary (Maybe MIDIEv.Program)])- (f [NoteBoundary (NoteId, Maybe MIDIEv.Program)])-assignNoteIds =- fmap concat- ^<<- traverse Map.empty (\bnd ->- case bnd of- MIDIEv.AllNotesOff -> do- notes <- MS.get- MS.put Map.empty- return $- concatMap (\(pitch, range) ->- map- (\noteId ->- NoteBoundary pitch- (VoiceMsg.toVelocity VoiceMsg.normalVelocity)- (noteId, Nothing))- (flattenNoteIdRange range)) $- Map.toList notes- MIDIEv.NoteBoundary pitch vel mpgm ->- fmap (fmap (\noteId ->- NoteBoundary pitch vel (noteId,mpgm))) $- case mpgm of- Nothing -> do- mNoteId <- MS.gets (Map.lookup pitch)- case mNoteId of- Nothing -> return []- Just (nextNoteOffId, nextNoteOnId) ->- if nextNoteOffId >= nextNoteOnId- then return []- else do- MS.modify (Map.insert pitch (succNoteId nextNoteOffId, nextNoteOnId))- return [nextNoteOffId]- Just _ -> do- mNoteId <- MS.gets (Map.lookup pitch)- let (nextNoteOffId, nextNoteOnId) =- case mNoteId of- Nothing -> (NoteId 0, NoteId 0)- Just ids -> ids-- MS.modify (Map.insert pitch (nextNoteOffId, succNoteId nextNoteOnId))- return [nextNoteOnId])--applyInstrumentCore ::- (Arrow arrow, Trans.C y) =>- ((MIDIEv.Pitch, NoteId) -> noteOffListCtrl -> gateCtrl) ->- (MIDIEv.Program -> y -> y -> PIO.T gateCtrl chunk) ->- arrow- (EventListTT.T StrictTime- [NoteBoundary (NoteId, Maybe MIDIEv.Program)])- (Zip.T- NoteOffList- (EventListTT.T StrictTime [PIO.T noteOffListCtrl chunk]))-applyInstrumentCore makeGate bank = arr $- uncurry Zip.Cons .- mapFst NoteOffList .- EventListTT.unzip .- fmap (ListHT.unzipEithers . fmap (\ev ->- case ev of--- MIDIEv.AllNotesOff -> Left MIDIEv.AllNotesOff- NoteBoundary pitch vel (noteId, mpgm) ->- case mpgm of- Nothing -> Left $ NoteBoundary pitch vel noteId- Just pgm ->- Right $- bank pgm (MV.velocity vel)- (MV.frequencyFromPitch pitch)- <<^- makeGate (pitch, noteId)))--applyInstrument ::- (Arrow arrow, Trans.C y) =>- Bank y chunk ->- arrow- (EventListTT.T StrictTime- [NoteBoundary (NoteId, Maybe MIDIEv.Program)])- (Zip.T- NoteOffList- (EventListTT.T StrictTime [PIO.T NoteOffList chunk]))-applyInstrument = applyInstrumentCore gateFromNoteOffs---type ModulatedBank y ctrl chunk =- MIDIEv.Program -> y -> y ->- PIO.T (Zip.T GateChunk ctrl) chunk--applyModulatedInstrument ::- (Arrow arrow, Trans.C y, CutG.Read ctrl) =>- ModulatedBank y ctrl chunk ->- arrow- (Zip.T- (EventListTT.T StrictTime- [NoteBoundary (NoteId, Maybe MIDIEv.Program)])- ctrl)- (Zip.T- (Zip.T NoteOffList ctrl)- (EventListTT.T StrictTime- [PIO.T (Zip.T NoteOffList ctrl) chunk]))-applyModulatedInstrument bank =- (\(Zip.Cons (Zip.Cons noteOffs events) ctrl) ->- Zip.Cons (Zip.Cons noteOffs ctrl) events)- ^<<- Zip.arrowFirst- (applyInstrumentCore- (Zip.arrowFirst . gateFromNoteOffs) bank)---{- |-Turn an event list with bundles of elements-into an event list with single events.-ToDo: Move to event-list package?--}-flatten ::- (NonNeg.C time) =>- a ->- EventListTT.T time [a] ->- EventListTT.T time a-flatten empty =- EventListTT.foldr- EventListMT.consTime- (\bt xs ->- uncurry EventListMT.consBody $- case bt of- [] -> (empty, xs)- b:bs -> (b, foldr (\c rest -> EventListTT.cons NonNeg.zero c rest) xs bs))- EventListBT.empty---flattenControlSchedule ::- (Monoid chunk, Arrow arrow) =>- arrow- (Zip.T ctrl- (EventListTT.T StrictTime [PIO.T ctrl chunk]))- (Zip.T ctrl- (EventListTT.T StrictTime (PIO.T ctrl chunk)))-flattenControlSchedule = arr $- \(Zip.Cons ctrl evs) ->- -- Zip.consChecked "flattenControlSchedule" ctrl $- Zip.Cons ctrl $- flatten (arr (const mempty)) evs----data CausalState a b =- forall state.- CausalState- (a -> state -> IO (b, state))- (state -> IO ())- state--_applyChunkSimple :: CausalState a b -> a -> IO (b, CausalState a b)-_applyChunkSimple (CausalState next delete state0) input = do- (output, state1) <- next input state0- return (output, CausalState next delete state1)--applyChunk ::- (CutG.Read a, CutG.Read b) =>- CausalState a b -> a -> IO (b, Maybe (CausalState a b))-applyChunk (CausalState next delete state0) input = do- (output, state1) <- next input state0- cs <-- if CutG.length output < CutG.length input- then do- delete state1- return Nothing- else return $ Just $ CausalState next delete state1- return (output, cs)---- could be moved to synthesizer-core-applyModulation ::- (CutG.Transform ctrl, CutG.NormalForm ctrl,- CutG.Read chunk,- Monoid time, ToInteger.C time) =>- PIO.T- (Zip.T ctrl (EventListTT.T time (PIO.T ctrl chunk)))- (EventListTT.T time chunk)-applyModulation = PIO.Cons- (\(Zip.Cons ctrl evs) acc0 -> do- acc1 <- mapM (flip applyChunk ctrl) acc0- let (accChunks, acc2) = unzip acc1-- (newChunks, newAcc) <-- MW.runWriterT $- flip MS.evalStateT ctrl $- EventListTT.mapM- (\time -> do- ctrl_ <- MS.gets (CutG.drop (fromIntegral time))- MS.put ctrl_- return (case CutG.evaluateHead ctrl_ of () -> time))- (\(PIO.Cons next create delete) -> do- state0 <- liftIO create- (chunk, state1) <-- liftIO . applyChunk (CausalState next delete state0)- =<< MS.get- MT.lift $ MW.tell $ maybeToList state1- return chunk)- evs-- return- (EventListTM.prependBodyEnd- (EventList.fromPairList $- map ((,) mempty) accChunks)- newChunks,- Maybe.catMaybes acc2 ++ newAcc))-- (return [])- (mapM_ (\(CausalState _ close state) -> close state))--arrangeStorable ::- (Arrow arrow, Storable a, Additive.C a) =>- arrow- (EventListTT.T StrictTime (SV.Vector a))- (SV.Vector a)-arrangeStorable =- arr $ \evs ->- SVST.runSTVector (do- v <- SVST.new (fromIntegral $ EventListTT.duration evs) zero- mapM_ (uncurry $ CutSt.addChunkToBuffer v) $- AbsEventList.toPairList $- AbsEventList.mapTime fromIntegral $- EventList.toAbsoluteEventList 0 $- EventListTM.switchTimeR const evs- return v)----sequenceCore ::- (Monoid chunk, CutG.Read chunk, Trans.C y) =>- MIDIEv.Channel ->- Bank y chunk ->- PIO.T Events (EventListTT.T StrictTime chunk)-sequenceCore channel bank =- applyModulation- .- flattenControlSchedule- .- applyInstrument bank- .- assignNoteIds- .- embedPrograms (VoiceMsg.toProgram 0)- .- noteEvents channel---sequenceModulated ::- (Monoid chunk, CutG.Read chunk,- CutG.Transform ctrl, CutG.NormalForm ctrl, Trans.C y) =>- MIDIEv.Channel ->- ModulatedBank y ctrl chunk ->- PIO.T (Zip.T Events ctrl) (EventListTT.T StrictTime chunk)-sequenceModulated channel bank =- applyModulation- .- flattenControlSchedule- .- applyModulatedInstrument bank- .- Zip.arrowFirst- (assignNoteIds- .- embedPrograms (VoiceMsg.toProgram 0)- .- noteEvents channel)---sequenceModulatedMultiProgram ::- (Monoid chunk, CutG.Read chunk,- CutG.Transform ctrl, CutG.NormalForm ctrl, Trans.C y) =>- MIDIEv.Channel ->- MIDIEv.Program ->- ModulatedBank y ctrl chunk ->- PIO.T (Zip.T Events ctrl) (EventListTT.T StrictTime chunk)-sequenceModulatedMultiProgram channel initPgm bank =- applyModulation- .- flattenControlSchedule- .- applyModulatedInstrument bank- .- Zip.arrowFirst- (assignNoteIds- .- embedPrograms initPgm- .- noteEvents channel)---sequenceStorable ::- (Storable a, Additive.C a, Trans.C y) =>- MIDIEv.Channel ->- Bank y (SV.Vector a) ->- PIO.T Events (SV.Vector a)-sequenceStorable channel bank =- arrangeStorable- .- sequenceCore channel bank
− src/Synthesizer/Dimensional/ALSA/MIDI.hs
@@ -1,451 +0,0 @@-{- |-Convert MIDI events of a MIDI controller to a control signal.--}-{-# LANGUAGE NoImplicitPrelude #-}-module Synthesizer.Dimensional.ALSA.MIDI where--import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as AlsaPC-import qualified Synthesizer.EventList.ALSA.MIDI as AlsaEL-import qualified Synthesizer.Generic.ALSA.MIDI as AlsaG-import Synthesizer.EventList.ALSA.MIDI- (Channel, Controller, Note(Note), Program, )-import Synthesizer.Generic.ALSA.MIDI (errorNoProgram, )--import qualified Sound.ALSA.Sequencer.Event as Event--import qualified Synthesizer.Dimensional.MIDIValue as DMV-import qualified Synthesizer.MIDIValue as MV-import qualified Sound.MIDI.ALSA.Check as Check--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.PiecewiseConstant.Signal as PC-import qualified Synthesizer.ChunkySize as ChunkySize--import qualified Synthesizer.Generic.Cut as CutG-import qualified Synthesizer.Generic.Signal2 as SigG2-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.Category (Category, (.), )-import Control.Applicative (Applicative, pure, (<*>), liftA2, )-import Control.Monad.Trans.State (State, evalState, state, gets, )-import Control.Monad (liftM, )--import NumericPrelude.Base hiding (id, (.), )-import NumericPrelude.Numeric-import Prelude (RealFrac, )---type Signal s v y signal =- AmpSignal s (Amp.Dimensional v y) signal--type AmpSignal s amp signal =- SigA.T (Rate.Phantom s) amp signal--{- |-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 [Event.T] ->- 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 piecewiseConstant #-}-piecewiseConstant ::- (SigG.Write sig y) =>- SigA.T rate amp (AlsaPC.T y) ->- SigA.T rate amp (sig y)-piecewiseConstant =- SigA.processBody AlsaG.piecewiseConstant--{-# INLINE controllerLinear #-}-controllerLinear ::- (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 (AlsaPC.T y))-controllerLinear chan ctrl bnd initial =- Filter $- liftM- (let amp = max initial (uncurry max bnd)- in return . SigA.fromBody amp .- AlsaPC.initWith- (DMV.controllerLinear amp bnd) (DN.divToScalar initial amp)) $- AlsaEL.getControllerEvents chan ctrl---{-# INLINE controllerExponential #-}-controllerExponential ::- (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 (AlsaPC.T y))-controllerExponential chan ctrl bnd initial =- Filter $- liftM- (let amp = max initial (uncurry max bnd)- in return . SigA.fromBody amp .- AlsaPC.initWith- (DMV.controllerExponential amp bnd) (DN.divToScalar initial amp)) $- AlsaEL.getControllerEvents chan ctrl---{- |-@pitchBend channel range center@:-emits frequencies on an exponential scale from-@center/range@ to @center*range@.--}-{-# INLINE pitchBend #-}-pitchBend ::- (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 (AlsaPC.T y))-pitchBend chan range center =- Filter $- liftM- (let amp = DN.scale (max range (recip range)) center- in return . SigA.fromBody amp .- AlsaPC.initWith- (DMV.pitchBend amp range center) (DN.divToScalar center amp)) $- AlsaEL.getSlice (Check.pitchBend chan)--- AlsaEL.getPitchBendEvents chan---{-# INLINE channelPressure #-}-channelPressure ::- (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 (AlsaPC.T y))-channelPressure chan maxVal initVal =- Filter $- liftM- (return . SigA.fromBody maxVal .- AlsaPC.initWith- (DMV.controllerLinear maxVal (zero,maxVal))- (DN.divToScalar initVal maxVal)) $- AlsaEL.getSlice (Check.channelPressure chan)--- AlsaEL.getPitchBendEvents chan---{-# INLINE bendWheelPressure #-}-bendWheelPressure ::- (SigG.Write sig q, SigG2.Transform sig q 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 (sig q))-bendWheelPressure 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)- (piecewiseConstant bend))-- $: pitchBend chan (2^?(fromIntegral pitchRange/12)) (DN.scalar 1)- $: controllerLinear chan VoiceMsg.modulation (zero, DN.scalar wheelDepth) zero- $: channelPressure 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 signal =- ModulatedInstrument s u q (Signal s v q signal)--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 . NonNegW.toNumber) .- concatMap PC.chopLongTime .- 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- (MV.velocity vel)- (DMV.frequencyFromPitch pitch)--{- |-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 ->- EventList.T time [Note] ->- Proc.T s Dim.Time q (EventList.T time [signal])-makeInstrumentSounds bank =- EventList.mapBodyM (mapM (renderInstrument bank))---{-# INLINE sequence #-}-sequence ::- (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 (SigSt.T y) ->- Filter s Dim.Time q (Signal s v q (SigSt.T y))-sequence chunkSize amp chan instr =- fmap (renderSequence chunkSize amp) $- prepareTones chan errorNoProgram (const instr)--{--{-# INLINE sequence #-}-sequence ::- (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 (SigSt.T y)))-sequence 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 sequenceModulated #-}-sequenceModulated ::- (CutG.Transform ctrl, CutG.NormalForm ctrl,- 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- (AmpSignal s amp ctrl -> Signal s v q (SigSt.T y)) ->- Filter s Dim.Time q- (AmpSignal s amp ctrl -> Signal s v q (SigSt.T y))-sequenceModulated chunkSize amp chan instr =- fmap (flip $ \ctrl ->- renderSequence chunkSize amp .- applyModulator (applyModulation ctrl)) $- prepareTones chan errorNoProgram (const instr)--{-# INLINE sequenceModulated2 #-}-sequenceModulated2 ::- (CutG.Transform ctrl0, CutG.NormalForm ctrl0,- CutG.Transform ctrl1, CutG.NormalForm ctrl1,- 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- (AmpSignal s amp0 ctrl0 -> AmpSignal s amp1 ctrl1 -> Signal s v q (SigSt.T y)) ->- Filter s Dim.Time q- (AmpSignal s amp0 ctrl0 -> AmpSignal s amp1 ctrl1 -> Signal s v q (SigSt.T y))-sequenceModulated2 chunkSize amp chan instr =- fmap (\evs ctrl0 ctrl1 ->- renderSequence chunkSize amp .- applyModulator- (applyModulation ctrl1 .- applyModulation ctrl0)- $ evs) $- prepareTones chan errorNoProgram (const instr)---{-# INLINE sequenceMultiModulated #-}-sequenceMultiModulated ::- (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- (AlsaG.Modulator instrument (Signal s v q (SigSt.T y))) ->- Filter s Dim.Time q (Signal s v q (SigSt.T y))-sequenceMultiModulated chunkSize amp chan instr modu =- fmap (renderSequence chunkSize amp) $- (fmap applyModulator modu $:- prepareTones chan 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 (EventList.T AlsaEL.StrictTime [signal])-prepareTones chan initPgm instr =- Filter $- fmap (makeInstrumentSounds instr .- AlsaEL.matchNoteEvents .- AlsaEL.embedPrograms initPgm) $- AlsaEL.getNoteEvents chan--{-# INLINE applyModulation #-}-applyModulation ::- (CutG.Transform signal, CutG.NormalForm signal) =>- AmpSignal s amp signal ->- AlsaG.Modulator (AmpSignal s amp signal -> body) body-applyModulation ctrl =- AlsaG.Modulator ctrl advanceModulationChunk gets--{-# INLINE applyModulator #-}-applyModulator ::- AlsaG.Modulator a b ->- EventList.T AlsaEL.StrictTime [a] ->- EventList.T AlsaEL.StrictTime [b]-applyModulator =- AlsaG.applyModulator--{-# INLINE renderSequence #-}-renderSequence ::- (Storable y, Module.C q y, Dim.C u, Field.C q) =>- SVL.ChunkSize ->- DN.T u q ->- EventList.T AlsaEL.StrictTime [Signal s u q (SigSt.T y)] ->- Signal s u q (SigSt.T y)-renderSequence chunkSize amp =- SigA.fromBody amp .- CutSt.arrangeEquidist chunkSize .- {- This concatenates times across empty events,- and thus is too strict.- EventList.flatten .- -}- AlsaG.flatten .- EventList.mapTime fromIntegral .- EventList.mapBody (map (SigA.vectorSamples (flip DN.divToScalar amp)))---{-# INLINE advanceModulationChunky #-}-advanceModulationChunky ::- (CutG.Transform signal, CutG.NormalForm signal) =>- AlsaEL.LazyTime -> State (AmpSignal s amp signal) AlsaEL.LazyTime-advanceModulationChunky =- liftM Chunky98.fromChunks .- mapM advanceModulationChunk .- Chunky98.toChunks--{-# INLINE advanceModulationChunk #-}-advanceModulationChunk ::- (CutG.Transform signal, CutG.NormalForm signal) =>- AlsaEL.StrictTime -> State (AmpSignal s amp signal) AlsaEL.StrictTime-advanceModulationChunk t = state $ \xs ->- let ys = SigA.processBody (CutG.drop (fromIntegral t)) xs- in (AlsaG.evaluateVectorHead (SigA.body ys) t, ys)---{-# INLINE sequenceMultiProgram #-}-sequenceMultiProgram ::- (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 (SigSt.T y)) ->- [Instrument s Dim.Time v q (SigSt.T y)] ->- Filter s Dim.Time q (Signal s v q (SigSt.T y))-sequenceMultiProgram chunkSize amp chan initPgm instrs =- let bank = AlsaEL.makeInstrumentArray instrs- in fmap (renderSequence chunkSize amp) $- prepareTones chan initPgm $- AlsaEL.getInstrumentFromArray bank initPgm
− src/Synthesizer/Dimensional/ALSA/Play.hs
@@ -1,123 +0,0 @@-{-# 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.PCM 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.RealRing as RealRing--- import qualified Algebra.Field as Field--- import qualified Algebra.Ring as Ring--import Foreign.Storable (Storable, )---- import NumericPrelude.Numeric-import NumericPrelude.Base---type Device = String--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)---makeSink ::- (ALSA.SampleFmt y, RealRing.C t) =>- Device {- ^ ALSA output device -} ->- DN.Time t {- ^ period (buffer) size expressed in seconds -} ->- DN.Frequency t {- ^ sample rate -} ->- ALSA.SoundSink y ALSA.Pcm-makeSink device periodTime rate =- Play.makeSink device- (DN.toNumberWithDimension Dim.time periodTime)- (RealRing.round (DN.toNumberWithDimension Dim.frequency rate))---{-# INLINE timeVoltageStorable #-}-timeVoltageStorable ::- (Module.C y yv, ALSA.SampleFmt yv, RealRing.C t) =>- Device ->- DN.Time t->- RenderedStorableSignal Dim.Time t Dim.Voltage y yv ->- IO ()-timeVoltageStorable device period sig =- Play.auto (makeSink device period (SigA.actualSampleRate sig))- (SigA.vectorSamples (DN.toNumberWithDimension Dim.voltage) sig)--{-# INLINE timeVoltageMonoStorableToInt16 #-}-timeVoltageMonoStorableToInt16 ::- (Storable y, RealRing.C y, RealRing.C t) =>- Device ->- DN.Time t->- RenderedStorableSignal Dim.Time t Dim.Voltage y y ->- IO ()-timeVoltageMonoStorableToInt16 device period sig =- Play.monoToInt16 (makeSink device period (SigA.actualSampleRate sig))- (SigA.scalarSamples (DN.toNumberWithDimension Dim.voltage) sig)--{-# INLINE timeVoltageStereoStorableToInt16 #-}-timeVoltageStereoStorableToInt16 ::- (Storable y, Module.C y y, RealRing.C y, RealRing.C t) =>- Device ->- DN.Time t->- RenderedStorableSignal Dim.Time t Dim.Voltage y (Stereo.T y) ->- IO ()-timeVoltageStereoStorableToInt16 device period sig =- Play.stereoToInt16 (makeSink device period (SigA.actualSampleRate sig))- (SigA.vectorSamples (DN.toNumberWithDimension Dim.voltage) sig)---{-# INLINE renderTimeVoltageStorable #-}-renderTimeVoltageStorable ::- (Module.C y yv, ALSA.SampleFmt yv, RealRing.C t) =>- Device ->- DN.Time t->- DN.T Dim.Frequency t ->- (forall s. Proc.T s Dim.Time t- (StorableSignal s Dim.Voltage y yv)) ->- IO ()-renderTimeVoltageStorable device period rate sig =- timeVoltageStorable device period (SigA.render rate sig)--{-# INLINE renderTimeVoltageMonoStorableToInt16 #-}-renderTimeVoltageMonoStorableToInt16 ::- (Storable y, RealRing.C y, RealRing.C t) =>- Device ->- DN.Time t->- DN.T Dim.Frequency t ->- (forall s. Proc.T s Dim.Time t- (StorableSignal s Dim.Voltage y y)) ->- IO ()-renderTimeVoltageMonoStorableToInt16 device period rate sig =- timeVoltageMonoStorableToInt16 device period (SigA.render rate sig)--{-# INLINE renderTimeVoltageStereoStorableToInt16 #-}-renderTimeVoltageStereoStorableToInt16 ::- (Storable y, Module.C y y, RealRing.C y, RealRing.C t) =>- Device ->- DN.Time t->- DN.T Dim.Frequency t ->- (forall s. Proc.T s Dim.Time t- (StorableSignal s Dim.Voltage y (Stereo.T y))) ->- IO ()-renderTimeVoltageStereoStorableToInt16 device period rate sig =- timeVoltageStereoStorableToInt16 device period (SigA.render rate sig)
− src/Synthesizer/Dimensional/ALSA/Server.hs
@@ -1,18 +0,0 @@-module Main where--import qualified Synthesizer.Dimensional.ALSA.Server.Run as Run-import qualified Synthesizer.Dimensional.ALSA.Server.Test as Test--main :: IO ()-main =- case 106::Int of- 001 -> Test.sequence1- 100 -> Run.volume- 101 -> Run.pitchBend- 102 -> Run.volumePitchBend1- 103 -> Run.keyboard- 104 -> Run.keyboardMulti- 105 -> Run.keyboardFM- 106 -> Run.keyboardDetuneFM- 107 -> Run.keyboardFilter- _ -> error "not implemented"
− src/Synthesizer/Dimensional/ALSA/Server/Common.hs
@@ -1,101 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE RankNTypes #-}-module Synthesizer.Dimensional.ALSA.Server.Common where--import qualified Synthesizer.Dimensional.ALSA.Play as Play--import qualified Sound.ALSA.PCM as ALSA-import qualified Sound.ALSA.Sequencer.Event as Event--import qualified Synthesizer.EventList.ALSA.MIDI as MIDIEv--import qualified Synthesizer.Storable.ALSA.Play as PlaySt--import qualified Synthesizer.Dimensional.Rate.Filter as FiltR-import qualified Synthesizer.Dimensional.Process as Proc--import Synthesizer.Dimensional.Process (($:), )--import qualified Data.StorableVector.Lazy as SVL--import qualified Sound.MIDI.Message.Channel as ChannelMsg--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.Numeric-import NumericPrelude.Base hiding (break, )----channel :: ChannelMsg.Channel-channel = ChannelMsg.toChannel 0---sampleRate :: Ring.C a => DN.Frequency a--- sampleRate = DN.frequency 48000-sampleRate = DN.frequency 44100--latency :: Field.C a => DN.Time a-latency = DN.time 0--- latency = DN.time 0.01--{--chunkSize :: SVL.ChunkSize-chunkSize = Play.defaultChunkSize--}--periodTime :: Field.C a => DN.Time a-periodTime =- let (SVL.ChunkSize size) = PlaySt.defaultChunkSize- in DN.scale (fromIntegral size) $ DN.unrecip sampleRate--device :: Play.Device-device = PlaySt.defaultDevice--clientName :: MIDIEv.ClientName-clientName = MIDIEv.ClientName "Haskell-Synthesizer"---type Real = Double---{-# INLINE withMIDIEvents #-}-withMIDIEvents ::- Field.C t =>- (DN.Time t -> DN.Frequency t ->- (forall s. Proc.T s Dim.Time t- (Play.StorableSignal s Dim.Voltage y yv)) ->- IO b) ->- (EventList.T MIDIEv.StrictTime [Event.T] ->- forall s. Proc.T s Dim.Time t- (Play.StorableSignal s Dim.Voltage y yv)) ->- IO b-withMIDIEvents action proc =- MIDIEv.withMIDIEvents clientName- (DN.toNumberWithDimension Dim.time periodTime :: Double)- (DN.toNumberWithDimension Dim.frequency sampleRate :: Double) $- \ sig -> action periodTime sampleRate (proc sig)--{-# INLINE play #-}-play ::- (Module.C y yv, ALSA.SampleFmt yv, RealField.C t) =>- DN.Time t ->- DN.Frequency t ->- (forall s. Proc.T s Dim.Time t- (Play.StorableSignal s Dim.Voltage y yv)) ->- IO ()-play period rate sig =- Play.renderTimeVoltageStorable device period rate- (FiltR.delay latency $: sig)
− src/Synthesizer/Dimensional/ALSA/Server/Instrument.hs
@@ -1,204 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE Rank2Types #-}-module Synthesizer.Dimensional.ALSA.Server.Instrument where--import Synthesizer.Dimensional.ALSA.Server.Common-import qualified Synthesizer.Dimensional.ALSA.MIDI as MIDI--import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC--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.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.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 Synthesizer.Dimensional.Causal.Process ((<<<), )-import Synthesizer.Dimensional.Wave ((&*~), )-import Synthesizer.Dimensional.Process (($:), )-import Synthesizer.Dimensional.Signal ((&*^), )-import Control.Applicative (liftA3, )--import qualified Synthesizer.Basic.Wave as Wave-import qualified Synthesizer.Frame.Stereo as Stereo--import qualified Synthesizer.Storable.Signal as SigSt--import qualified Algebra.DimensionTerm as Dim-import qualified Number.DimensionTerm as DN--import NumericPrelude.Numeric-import NumericPrelude.Base hiding (break, )---{-# INLINE ping #-}-ping :: MIDI.Instrument s Dim.Time Dim.Voltage Real (SigSt.T 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)---{--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 (SigSt.T 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)---{-# INLINE pingReleaseFM #-}-pingReleaseFM ::- MIDI.ModulatedInstrument s Dim.Time Real- (MIDI.Signal s Dim.Scalar Real (SigSt.T Real) ->- MIDI.Signal s Dim.Voltage Real (SigSt.T 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)---{-# INLINE pingStereoDetuneFM #-}-pingStereoDetuneFM ::- MIDI.ModulatedInstrument s Dim.Time Real- (MIDI.Signal s Dim.Scalar Real (PC.T Real) ->- MIDI.Signal s Dim.Scalar Real (SigSt.T Real) ->- MIDI.Signal s Dim.Voltage Real (SigSt.T (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)---{- 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 (SigSt.T (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)))
− src/Synthesizer/Dimensional/ALSA/Server/Run.hs
@@ -1,185 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Synthesizer.Dimensional.ALSA.Server.Run where--import Synthesizer.Dimensional.ALSA.Server.Common-import qualified Synthesizer.Dimensional.ALSA.Server.Instrument as Instr--import qualified Synthesizer.Dimensional.ALSA.MIDI as MIDI--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.FilterParameter as FiltP-import qualified Synthesizer.Dimensional.Causal.ControlledProcess as CProc--import qualified Synthesizer.Dimensional.Rate.Oscillator as OsciR-import qualified Synthesizer.Dimensional.Amplitude.Control as CtrlA-import qualified Synthesizer.Dimensional.Amplitude.Displacement as DispA-import qualified Synthesizer.Dimensional.Amplitude.Filter as FiltA-import qualified Synthesizer.Dimensional.Signal.Private as SigA-import qualified Synthesizer.Dimensional.Wave as WaveD--import Synthesizer.Dimensional.Causal.Process ((<<<), )-import Synthesizer.Dimensional.Wave ((&*~), )-import Synthesizer.Dimensional.Process (($:), (.:), )-import Control.Applicative (liftA2, liftA3, )--import qualified Synthesizer.Basic.Wave as Wave--import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg--import qualified Number.DimensionTerm as DN--import NumericPrelude.Numeric-import NumericPrelude.Base hiding (break, )----channelVolume :: VoiceMsg.Controller-channelVolume = VoiceMsg.modulation---volume :: IO ()-volume =- putStrLn "run 'aconnect' to connect to the MIDI controller" >>- (withMIDIEvents play $- \evs ->- liftA3- (\env osci vol ->- Causal.apply- (Causal.applySnd env osci) $- MIDI.piecewiseConstant $ vol)- Filt.envelopeScalarDimension- (OsciR.static (DN.voltage 1 &*~ Wave.sine) zero (DN.frequency (880::Real)))- (MIDI.runFilter evs (MIDI.controllerLinear channel channelVolume- (DN.scalar 0, DN.scalar 1) (DN.scalar (1::Real)))))--pitchBend :: IO ()-pitchBend =- withMIDIEvents play $- \evs ->- liftA2 Causal.apply- (Osci.freqMod (DN.voltage (1::Real) &*~ Wave.sine) zero)- (fmap MIDI.piecewiseConstant $- MIDI.runFilter evs- (MIDI.pitchBend channel 2 (DN.frequency (880::Real))))---- preserve chunk structure of channel volume-volumePitchBend0 :: IO ()-volumePitchBend0 =- 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)) $- MIDI.piecewiseConstant vol)- (OsciR.freqMod (DN.voltage 1 &*~ Wave.sine) zero)- Filt.envelopeScalarDimension- (MIDI.runFilter evs $ liftA2 (,)- (MIDI.pitchBend channel 2 (DN.frequency (880::Real)))- (MIDI.controllerLinear channel channelVolume- (DN.scalar 0, DN.scalar 1) (DN.scalar (1::Real)))))---- preserve chunk structure of pitch bender-volumePitchBend1 :: IO ()-volumePitchBend1 =- 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) $- MIDI.piecewiseConstant freq)- (Osci.freqMod (DN.voltage 1 &*~ Wave.sine) zero)- Filt.envelopeScalarDimension- (MIDI.runFilter evs $ liftA2 (,)- (MIDI.pitchBend channel 2 (DN.frequency (880::Real)))- (MIDI.controllerLinear channel channelVolume- (DN.scalar 0, DN.scalar 1) (DN.scalar (1::Real)))))---keyboard :: IO ()-keyboard =- withMIDIEvents play $- \evs ->- MIDI.runFilter evs- (MIDI.sequence PlaySt.defaultChunkSize (DN.voltage 1) channel Instr.ping)---keyboardMulti :: IO ()-keyboardMulti =- withMIDIEvents play $- \evs ->- MIDI.runFilter evs- (MIDI.sequenceMultiProgram PlaySt.defaultChunkSize (DN.voltage 1) channel- (VoiceMsg.toProgram 0)- [Instr.ping, Instr.pingRelease])--- [Instr.string])---keyboardFM :: IO ()-keyboardFM =- withMIDIEvents play $- \evs ->- fmap (FiltA.amplify 0.3) $- (MIDI.runFilter evs- (MIDI.sequenceModulated PlaySt.defaultChunkSize (DN.voltage 1) channel Instr.pingReleaseFM $:- MIDI.bendWheelPressure channel 2 (DN.frequency 10) 0.04 0.03))--- MIDI.pitchBend channel (2 ** recip 12) (DN.scalar one)))---extraController :: VoiceMsg.Controller-extraController =- VoiceMsg.vectorX--- VoiceMsg.toController 21--extraController1 :: VoiceMsg.Controller-extraController1 =- VoiceMsg.modulation--- VoiceMsg.vectorY--- VoiceMsg.toController 22---keyboardDetuneFM :: IO ()-keyboardDetuneFM =- withMIDIEvents play $- \evs ->- fmap (FiltA.amplify 0.3) $- (MIDI.runFilter evs- (MIDI.sequenceMultiModulated PlaySt.defaultChunkSize (DN.voltage 1) channel Instr.pingStereoDetuneFM- (fmap MIDI.applyModulation- (MIDI.bendWheelPressure channel 2 (DN.frequency 10) 0.04 0.03) .:- fmap MIDI.applyModulation- (MIDI.controllerLinear channel extraController (0, 0.005) 0))- ))---keyboardFilter :: IO ()-keyboardFilter =- withMIDIEvents play $- \evs ->- liftA3- (\osci filt (music,speed,depth) ->- (FiltP.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 FiltP.universal)--- FiltR.universal- (MIDI.runFilter evs- (liftA3 (,,)- (MIDI.sequence PlaySt.defaultChunkSize (DN.voltage 1) channel Instr.string)- (MIDI.controllerExponential channel extraController- (DN.frequency 0.1, DN.frequency 5) (DN.frequency 0.2))- (MIDI.controllerLinear channel extraController1- (0, 1 :: DN.Scalar Real) 0.5)- ))
− src/Synthesizer/Dimensional/ALSA/Server/Test.hs
@@ -1,56 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE Rank2Types #-}-module Synthesizer.Dimensional.ALSA.Server.Test where--import Synthesizer.Dimensional.ALSA.Server.Instrument (ping, )-import Synthesizer.Dimensional.ALSA.Server.Common-import qualified Synthesizer.Dimensional.ALSA.MIDI as MIDI--import qualified Synthesizer.EventList.ALSA.MIDI as MIDIEv--import qualified Synthesizer.Storable.ALSA.Play as PlaySt-import qualified Synthesizer.Generic.ALSA.MIDI as AlsaG--import qualified Synthesizer.Dimensional.Signal.Private as SigA-import qualified Synthesizer.Dimensional.Process as Proc--import qualified Synthesizer.Storable.Signal as SigSt-import qualified Data.StorableVector.Lazy as SVL--import qualified Data.EventList.Relative.TimeBody as EventList--import qualified Algebra.DimensionTerm as Dim-import qualified Number.DimensionTerm as DN--import NumericPrelude.Numeric-import NumericPrelude.Base hiding (break, )----sequence1 :: IO ()-sequence1 =--- print =<<--- File.renderTimeVoltageMonoDoubleToInt16 sampleRate "test.wav"- SVL.writeFile "test.f32"- (SigA.scalarSamples (DN.toNumberWithDimension Dim.voltage)- (SigA.render sampleRate- (let evs t = EventList.cons t [] (evs (20-t))- {-- evs0 =- EventList.cons 10 [makeNote AlsaMidi.NoteOn 60] $- EventList.cons 10 [makeNote AlsaMidi.NoteOn 64] $- evs 10- -}- in MIDI.runFilter (evs 10)- (MIDI.sequence PlaySt.defaultChunkSize- (DN.voltage 1) channel ping))))--sequence2 ::- EventList.T MIDIEv.StrictTime [SigSt.T Real]-sequence2 =- fmap (map SigA.body) $- flip Proc.process sampleRate- (let evs t = EventList.cons t [] (evs (20-t))- in MIDI.runFilter (evs 10)- (MIDI.prepareTones channel AlsaG.errorNoProgram- (const ping)))
− src/Synthesizer/Dimensional/MIDIValue.hs
@@ -1,45 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{- |-Functions for converting MIDI controller and key values-to something meaningful for signal processing.--}-module Synthesizer.Dimensional.MIDIValue (- controllerLinear,- controllerExponential,- pitchBend,- MV.frequencyFromPitch,- ) where--import qualified Synthesizer.Dimensional.MIDIValuePlain as MV--import qualified Algebra.DimensionTerm as Dim-import qualified Number.DimensionTerm as DN--import qualified Algebra.Transcendental as Trans-import qualified Algebra.Field as Field--- import qualified Algebra.Additive as Additive--import NumericPrelude.Numeric--- import NumericPrelude.Base---{-# INLINE controllerLinear #-}-controllerLinear ::- (Field.C y, Dim.C v) =>- DN.T v y -> (DN.T v y, DN.T v y) -> Int -> y-controllerLinear amp bnd n =- DN.divToScalar (MV.controllerLinear bnd n) amp--{-# INLINE controllerExponential #-}-controllerExponential ::- (Trans.C y, Dim.C v) =>- DN.T v y -> (DN.T v y, DN.T v y) -> Int -> y-controllerExponential amp bnd n =- DN.divToScalar (MV.controllerExponential bnd n) amp--{-# INLINE pitchBend #-}-pitchBend ::- (Trans.C y, Dim.C v) =>- DN.T v y -> y -> DN.T v y -> Int -> y-pitchBend amp range center n =- DN.divToScalar (MV.pitchBend range center n) amp
− src/Synthesizer/Dimensional/MIDIValuePlain.hs
@@ -1,64 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{- |-Functions for converting MIDI controller and key values-to something meaningful for signal processing.--}-module Synthesizer.Dimensional.MIDIValuePlain (- controllerLinear,- controllerExponential,- pitchBend,- frequencyFromPitch,- ) where--import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg--import qualified Algebra.DimensionTerm as Dim-import qualified Number.DimensionTerm as DN--import qualified Algebra.Transcendental as Trans-import qualified Algebra.Field as Field--- import qualified Algebra.Additive as Additive--import NumericPrelude.Numeric-import NumericPrelude.Base---{-# INLINE controllerLinear #-}-controllerLinear ::- (Field.C y, Dim.C v) =>- (DN.T v y, DN.T v y) -> Int -> DN.T v y-controllerLinear (lower,upper) n =- let k = fromIntegral n / 127- in DN.scale (1-k) lower + DN.scale k upper--{-# INLINE controllerExponential #-}-controllerExponential ::- (Trans.C y, Dim.C v) =>- (DN.T v y, DN.T v y) -> Int -> DN.T v y-controllerExponential (lower,upper) n =- let k = fromIntegral n / 127- in case error "MIDIValue.controllerExponential dimension" of- d ->- DN.fromNumberWithDimension d $- DN.toNumberWithDimension d lower ** (1-k) *- DN.toNumberWithDimension d upper ** k--{-# INLINE pitchBend #-}-pitchBend ::- (Trans.C y, Dim.C v) =>- y -> DN.T v y -> Int -> DN.T v y-pitchBend range center n =- DN.scale (range ** (fromIntegral n / 8192)) center--{- |-Convert pitch to frequency according to the default tuning-in MIDI 1.0 Detailed Specification.--}-{-# INLINE frequencyFromPitch #-}-frequencyFromPitch ::- (Trans.C y) =>- VoiceMsg.Pitch -> DN.Frequency y-frequencyFromPitch pitch =- DN.scale- (2 ^? (fromIntegral (VoiceMsg.fromPitch pitch + 3 - 6*12) / 12))- (DN.frequency 440)
− src/Synthesizer/EventList/ALSA/MIDI.hs
@@ -1,769 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Synthesizer.EventList.ALSA.MIDI where--import qualified Sound.ALSA.Sequencer.Address as Addr-import qualified Sound.ALSA.Sequencer.Client as Client-import qualified Sound.ALSA.Sequencer.Port as Port-import qualified Sound.ALSA.Sequencer.Port.Info as PortInfo-import qualified Sound.ALSA.Sequencer.Event as Event-import qualified Sound.ALSA.Sequencer.Queue as Queue-import qualified Sound.ALSA.Sequencer.RealTime as RealTime-import qualified Sound.ALSA.Sequencer as SndSeq-import qualified Sound.ALSA.Exception as AlsaExc--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.Relative.BodyBody as EventListBB-import qualified Data.EventList.Absolute.TimeBody as AbsEventList--import qualified Sound.MIDI.Message.Channel as ChannelMsg-import qualified Sound.MIDI.Message.Channel.Mode as Mode-import qualified Sound.MIDI.ALSA.Check as Check-import qualified Sound.MIDI.ALSA as MALSA--import Data.Accessor.Basic ((^.), )--import System.IO.Unsafe (unsafeInterleaveIO, )-import Control.Concurrent (threadDelay)-import System.Time (ClockTime(TOD), getClockTime, )--import Control.Monad.Trans.State- (State, state, evalState, modify, get, gets, put, )-import Data.Traversable (traverse, )--import qualified Numeric.NonNegative.Class as NonNeg-import qualified Numeric.NonNegative.Wrapper as NonNegW-import qualified Numeric.NonNegative.Chunky as NonNegChunky--- import Data.Monoid (Monoid, mconcat, mappend, )--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 qualified Data.List.HT as ListHT-import Data.Tuple.HT (mapPair, mapFst, mapSnd, )-import Data.Ord.HT (limit, )-import Data.Maybe.HT (toMaybe, )-import Data.Maybe (catMaybes, isNothing, )-import Control.Monad.HT ((<=<), )-import Control.Monad (liftM, liftM2, guard, mzero, )--import NumericPrelude.Numeric-import NumericPrelude.Base--- import qualified Prelude as P---- 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 Event.T sometimes.--}-type StampedEvent time = (time, Event.T)---{- |-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, SndSeq.AllowInput mode) =>- SndSeq.T mode -> IO (StampedEvent time)-getStampedEvent h =- liftM2 (,)- getTimeSeconds- (Event.input h)--{- | only use it for non-blocking sequencers -}-getWaitingStampedEvents ::- (Field.C time, SndSeq.AllowInput mode) =>- SndSeq.T mode -> IO [StampedEvent time]-getWaitingStampedEvents h =- let loop =- AlsaExc.catch- (liftM2 (:) (getStampedEvent h) loop)- (const $ return [])- in loop--{- |-RealTime.toFractional for NumericPrelude.--}-realTimeToField :: (Field.C a) => RealTime.T -> a-realTimeToField (RealTime.Cons s n) =- fromIntegral s + fromIntegral n / (10^9)--addStamp ::- (RealField.C time) =>- Event.T -> StampedEvent time-addStamp ev =- (case Event.timestamp ev of- Event.RealTime t -> realTimeToField t- _ -> error "unsupported time stamp type",- ev)--{- | only use it for blocking sequencers -}-getStampedEventsUntilTime ::- (RealField.C time,- SndSeq.AllowInput mode, SndSeq.AllowOutput mode) =>- SndSeq.T mode ->- Queue.T -> Port.T -> time ->- IO [StampedEvent time]-getStampedEventsUntilTime h q p t =- fmap (map addStamp) $ getEventsUntilTime h q p t---{- |-The client id may differ from the receiving sequencer.-I do not know, whether there are circumstances, where this is useful.--}-getEventsUntilEcho ::- (SndSeq.AllowInput mode) =>- Client.T -> SndSeq.T mode -> IO [Event.T]-getEventsUntilEcho c h =- let loop = do- ev <- Event.input h- let abort =- case Event.body ev of- Event.CustomEv Event.Echo _ ->- c == Addr.client (Event.source ev)- _ -> False- if abort- then return []- else liftM (ev:) loop- in loop--{- |-Get events until a certain point in time.-It sends itself an Echo event in order to measure time.--}-getEventsUntilTime ::- (RealField.C time,- SndSeq.AllowInput mode, SndSeq.AllowOutput mode) =>- SndSeq.T mode ->- Queue.T -> Port.T -> time ->- IO [Event.T]-getEventsUntilTime h q p t = do- c <- Client.getId h- _ <- Event.output h $- makeEcho c q p t (Event.Custom 0 0 0)- _ <- Event.drainOutput h- getEventsUntilEcho c h---getWaitingEvents ::- (SndSeq.AllowInput mode) =>- SndSeq.T mode -> IO [Event.T]-getWaitingEvents h =- let loop =- AlsaExc.catch- (liftM2 (:) (Event.input h) loop)- (const $ return [])- in loop----type StrictTime = NonNegW.Integer-newtype ClientName = ClientName String- deriving (Show)--{--ghc -i:src -e 'withMIDIEvents 44100 print' src/Synthesizer/Storable/ALSA/MIDI.hs--}-{--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.--}-withMIDIEvents :: (RealField.C time) =>- ClientName -> time -> time ->- (EventList.T StrictTime [Event.T] -> IO a) -> IO a-withMIDIEvents =- withMIDIEventsBlockEcho---{--as a quick hack, we neglect the ALSA time stamp and use getTime or so--}-withMIDIEventsNonblockWaitGrouped :: (RealField.C time) =>- ClientName -> time -> time ->- (EventList.T StrictTime [Event.T] -> IO a) -> IO a-withMIDIEventsNonblockWaitGrouped name beat rate proc =- withInPort name SndSeq.Nonblock $ \ h _p ->- do start <- getTimeSeconds- l <- lazySequence $- flip map (iterate (beat+) start) $ \t ->- wait t >>- liftM- (\evs -> (t, evs))- (getWaitingEvents h)-{-- liftM2 (,)- getTimeSeconds- (getWaitingEvents h)--}- proc $- 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) =>- ClientName -> time -> time ->- (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a-withMIDIEventsNonblockWaitDefer name beat rate proc =- withInPort name SndSeq.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) =>- ClientName -> time -> time ->- (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a-withMIDIEventsNonblockWaitSkip name beat rate proc =- withInPort name SndSeq.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) =>- ClientName -> time -> time ->- (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a-withMIDIEventsNonblockWaitMin name beat rate proc =- withInPort name SndSeq.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) =>- ClientName -> time -> time ->- (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a-withMIDIEventsNonblockConstantPause name beat rate proc =- withInPort name SndSeq.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) =>- ClientName -> time -> time ->- (EventList.T StrictTime Event.T -> IO a) -> IO a-withMIDIEventsNonblockSimple name beat rate proc =- withInPort name SndSeq.Nonblock $ \ h _p ->- do l <- ioToLazyList $- threadDelay (round $ flip asTypeOf rate $ beat*1e6) >>- getWaitingStampedEvents h- proc $- discretizeTime rate $- AbsEventList.fromPairList $ concat l---setTimestamping ::- SndSeq.T mode -> Port.T -> Queue.T -> IO ()-setTimestamping h p q = do- info <- PortInfo.get h p- PortInfo.setTimestamping info True- PortInfo.setTimestampReal info True- PortInfo.setTimestampQueue info q- PortInfo.set h p info--withMIDIEventsBlockEcho :: (RealField.C time) =>- ClientName -> time -> time ->- (EventList.T StrictTime [Event.T] -> IO a) -> IO a-withMIDIEventsBlockEcho name beat rate proc =- withInPort name SndSeq.Block $ \ h p ->- Queue.with h $ \ q ->- do setTimestamping h p q- Queue.control h q Event.QueueStart 0 Nothing- _ <- Event.drainOutput h-- proc .- discretizeTime rate .- AbsEventList.fromPairList .- concat =<<- (lazySequence $- flip map (iterate (beat+) 0) $ \t ->- let end = t+beat- in -- (\act -> do evs <- act; print evs; return evs) $- -- add a laziness break- fmap ((t,[]) :) $- fmap (map (mapPair (limit (t,end), (:[])))) $- getStampedEventsUntilTime h q p end)--{- |-This is like withMIDIEventsBlockEcho-but collects all events at the beginning of the beats.-This way, further processing steps may collapse-all controller events within one beat to one event.--}-withMIDIEventsBlockEchoQuantised :: (RealField.C time) =>- ClientName -> time -> time ->- (EventList.T StrictTime [Event.T] -> IO a) -> IO a-withMIDIEventsBlockEchoQuantised name beat rate proc =- withInPort name SndSeq.Block $ \ h p ->- Queue.with h $ \ q ->- do Queue.control h q Event.QueueStart 0 Nothing- _ <- Event.drainOutput h-- proc .- discretizeTime rate .- AbsEventList.fromPairList =<<- (lazySequence $- flip map (iterate (beat+) 0) $ \t ->- liftM- (\evs -> (t, evs))- (getEventsUntilTime h q p (t+beat)))--{- |-Make sure, that @beat@ is an integer multiple of @recip rate@.-Since we round time within each chunk,-we would otherwise accumulate rounding errors over time.--}-withMIDIEventsChunked ::- (RealField.C time) =>- ClientName -> time -> time ->- ([IO (EventListTT.T StrictTime [Event.T])] -> IO a) ->- IO a-withMIDIEventsChunked name beat rate proc =- withInPort name SndSeq.Block $ \ h p ->- Queue.with h $ \ q ->- do setTimestamping h p q- Queue.control h q Event.QueueStart 0 Nothing- _ <- Event.drainOutput h-- proc $- map- (\t ->- let end = t+beat- in liftM- (\evs ->- EventListTM.switchBodyR- (error "withMIDIEventsChunked: empty list, but there must be at least the end event")- const $- discretizeTime rate $- AbsEventList.fromPairList $- (t,[]) :- {-- FIXME: This is a quick hack in order to assert- that all events are within one chunk- and do not lie on the boundary.- -}- map (mapPair (limit (t , end - recip rate), (:[]))) evs ++- (end, []) :- [])- (getStampedEventsUntilTime h q p end))- (iterate (beat+) 0)--withMIDIEventsChunkedQuantised ::- (RealField.C time) =>- ClientName -> time -> time ->- ([IO (EventList.T StrictTime [Event.T])] -> IO a) ->- IO a-withMIDIEventsChunkedQuantised name beat rate proc =- withInPort name SndSeq.Block $ \ h p ->- Queue.with h $ \ q ->- do Queue.control h q Event.QueueStart 0 Nothing- _ <- Event.drainOutput h-- proc $- map- (\t ->- liftM- (\evs ->- EventList.cons NonNeg.zero evs $- EventList.singleton- (NonNegW.fromNumberMsg "chunked time conversion" $- round (beat*rate)) [])- (getEventsUntilTime h q p (t+beat)))- (iterate (beat+) 0)--makeEcho ::- RealField.C time =>- Client.T -> Queue.T -> Port.T ->- time -> Event.Custom -> Event.T-makeEcho c q p t dat =- Event.Cons- { Event.highPriority = False- , Event.tag = 0- , Event.queue = q- , Event.timestamp =- Event.RealTime $ RealTime.fromInteger $- floor (10^9 * t)- , Event.source = Addr.Cons {- Addr.client = c,- Addr.port = Port.unknown- }- , Event.dest = Addr.Cons {- Addr.client = c,- Addr.port = p- }- , Event.body = Event.CustomEv Event.Echo dat- }--withMIDIEventsBlock :: (RealField.C time) =>- ClientName -> time ->- (EventList.T StrictTime Event.T -> IO a) -> IO a-withMIDIEventsBlock name rate proc =- withInPort name SndSeq.Block $ \ h _p ->- do l <- ioToLazyList $ getStampedEvent h- proc $- discretizeTime rate $- AbsEventList.fromPairList l--withInPort ::- ClientName ->- SndSeq.BlockMode ->- (SndSeq.T SndSeq.DuplexMode -> Port.T -> IO t) -> IO t-withInPort (ClientName name) blockMode act =- SndSeq.with SndSeq.defaultName blockMode $ \h ->- Client.setName h name >>- Port.withSimple h "input"- (Port.caps [Port.capWrite, Port.capSubsWrite])- Port.typeMidiGeneric- (act h)--{- |-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 [Event.T])---{--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?--We do not use this type for timing in event lists anymore.-It worked in principle but left us with a couple of memory leaks,-that I could never identify and eliminate completely.--}-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 ::- (Event.T -> Maybe a) ->- Filter (EventList.T StrictTime [a])-getSlice f =- state $- EventList.unzip .- fmap (ListHT.partitionMaybe f)---type Channel = ChannelMsg.Channel-type Controller = ChannelMsg.Controller-type Pitch = ChannelMsg.Pitch-type Velocity = ChannelMsg.Velocity-type Program = ChannelMsg.Program---getControllerEvents ::- Channel -> Controller ->- Filter (EventList.T StrictTime [Int])-getControllerEvents chan ctrl =- getSlice (Check.controller chan ctrl)--{--getControllerEvents ::- Channel -> Controller ->- Filter (EventList.T StrictTime (Maybe Int))-getControllerEvents chan ctrl =- fmap (fmap (fmap snd . ListHT.viewR)) $- getSlice (Check.controller chan ctrl)--}--data NoteBoundary a =- NoteBoundary Pitch Velocity a- | AllNotesOff- 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 (EventList.T StrictTime [Either Program (NoteBoundary Bool)])-getNoteEvents chan =- getSlice $ checkNoteEvent chan--checkNoteEvent ::- Channel -> Event.T ->- Maybe (Either Program (NoteBoundary Bool))-checkNoteEvent chan e =- case Event.body e of- Event.NoteEv notePart note ->- do guard (note ^. MALSA.noteChannel == chan)- let (part,vel) =- MALSA.normalNoteFromEvent notePart note- press <-- case part of- Event.NoteOn -> return True- Event.NoteOff -> return False- _ -> mzero- return $ Right $ NoteBoundary- (note ^. MALSA.notePitch) vel press- Event.CtrlEv Event.PgmChange ctrl ->- do guard (ctrl ^. MALSA.ctrlChannel == chan)- return $ Left $ ctrl ^. MALSA.ctrlProgram- {-- We do not handle AllSoundOff here,- since this would also mean to clear reverb buffers- and this cannot be handled here.- -}- Event.CtrlEv Event.Controller ctrl ->- do guard (ctrl ^. MALSA.ctrlControllerMode ==- MALSA.Mode Mode.AllNotesOff)- return $ Right AllNotesOff- _ -> mzero--embedPrograms ::- Program ->- EventList.T StrictTime [Either Program (NoteBoundary Bool)] ->- EventList.T StrictTime [NoteBoundary (Maybe Program)]-embedPrograms initPgm =- fmap catMaybes .- flip evalState initPgm .- traverse (traverse embedProgramState)--embedProgramState ::- Either Program (NoteBoundary Bool) ->- State Program (Maybe (NoteBoundary (Maybe Program)))-embedProgramState =- -- evaluate program for every event in order to prevent a space leak- (\n -> state (\s -> (seq s n, s)))- <=<- either- (\pgm -> put pgm >> return Nothing)- (\bnd ->- gets (Just .- case bnd of- AllNotesOff -> const AllNotesOff- NoteBoundary p v press ->- NoteBoundary p v . toMaybe press))---matchNoteEvents ::- EventList.T StrictTime [NoteBoundary (Maybe Program)] ->- EventList.T StrictTime [Note]-matchNoteEvents =- matchNoteEventsCore $ \bndOn -> case bndOn of- AllNotesOff -> Nothing- NoteBoundary pitchOn velOn pressOn ->- flip fmap pressOn $ \pgm ->- (\bndOff ->- case bndOff of- AllNotesOff -> True- NoteBoundary pitchOff _velOff pressOff ->- pitchOn == pitchOff && isNothing pressOff,- Note pgm pitchOn velOn)--matchNoteEventsCore ::- (noteBnd ->- Maybe (noteBnd -> Bool, LazyTime -> Note)) ->- EventList.T StrictTime [noteBnd] ->- EventList.T StrictTime [Note]-matchNoteEventsCore methods =- let recourseEvents =- EventListMB.switchBodyL $ \evs0 xs0 -> case evs0 of- [] -> ([], xs0)- ev:evs ->- case methods ev of- Nothing ->- recourseEvents (EventListMB.consBody evs xs0)- Just (check, cons) ->- case durationRemove check (EventListMB.consBody evs xs0) of- (dur, xs1) ->- mapFst- (cons dur :)- (recourseEvents xs1)- recourse =- EventList.switchL EventList.empty $ \(t,evs0) xs0 ->- let (evs1,xs1) = recourseEvents (EventListMB.consBody evs0 xs0)- in EventList.cons t evs1 $ recourse xs1- in recourse---{--durationRemove Char.isUpper ("a" ./ 3 /. "bf" ./ 5 /. "aCcd" ./ empty :: Data.EventList.Relative.BodyBody.T StrictTime [Char])--}-{- |-Search for specific event,-return its time stamp and remove it.--}-durationRemove ::- (NonNeg.C time) =>- (body -> Bool) ->- EventListBB.T time [body] ->- (NonNegChunky.T time, EventListBB.T time [body])-durationRemove p =- let errorEndOfList =- (error "no matching body element found",- error "list ended before matching element found")- recourse =- EventListMB.switchBodyL $ \evs xs0 ->- let (prefix, suffix0) = break p evs- (suffix1, rest) =- case suffix0 of- [] -> ([],- flip (EventListMB.switchTimeL errorEndOfList) xs0 $ \t xs1 ->- mapPair- (NonNegChunky.fromChunks . (t:) .- NonNegChunky.toChunks,- EventListMB.consTime t) $- recourse xs1)- _:ys -> (ys, (NonNeg.zero, xs0))- in mapSnd- (EventListMB.consBody (prefix++suffix1))- rest- in recourse--durationRemoveTB ::- (NonNeg.C time) =>- (body -> Bool) ->- EventList.T time [body] ->- (NonNegChunky.T time, EventList.T time [body])-durationRemoveTB p =- let errorEndOfList =- (error "no matching body element found",- error "list ended before matching element found")- recourse =- EventList.switchL errorEndOfList $ \(t,evs) xs ->- let (prefix, suffix0) = break p evs- (suffix1, rest) =- case suffix0 of- [] -> ([], recourse xs)- _:ys -> (ys, (NonNeg.zero, xs))- in mapPair- (NonNegChunky.fromChunks . (t:) .- NonNegChunky.toChunks,- EventList.cons t (prefix++suffix1))- rest- in recourse---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
− src/Synthesizer/Generic/ALSA/MIDI.hs
@@ -1,347 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{- |-Convert MIDI events of a MIDI controller to a control signal.--}-{-# LANGUAGE NoImplicitPrelude #-}-module Synthesizer.Generic.ALSA.MIDI where--import Synthesizer.EventList.ALSA.MIDI- (LazyTime, StrictTime, Filter, Channel,- Program, embedPrograms, makeInstrumentArray, getInstrumentFromArray,- Note(Note), matchNoteEvents, getNoteEvents, )--import qualified Sound.MIDI.Message.Channel as ChannelMsg--import qualified Synthesizer.PiecewiseConstant.Signal as PC-import qualified Synthesizer.Generic.Cut as CutG-import qualified Synthesizer.Generic.Signal as SigG--import qualified Synthesizer.MIDIValue as MV---- 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.MixedBody as EventListMB-import qualified Data.EventList.Relative.BodyTime as EventListBT-import qualified Data.EventList.Relative.TimeBody as EventList--import Data.Monoid (Monoid, mempty, )--import qualified Numeric.NonNegative.Class as NonNeg-import qualified Numeric.NonNegative.Wrapper as NonNegW-import qualified Numeric.NonNegative.Chunky as NonNegChunky--import qualified Algebra.Transcendental as Trans--- import qualified Algebra.Field as Field--- import qualified Algebra.Additive as Additive--import Control.Arrow (Arrow, arr, first, )-import Control.Category (Category, id, (.), )-import qualified Control.Monad.Trans.State.Strict as MS-import Control.Monad.Trans.State- (State, evalState, runState, state, gets, put, get, )-import Control.Monad (liftM, )-import Data.Traversable (traverse, )-import Data.Foldable (traverse_, )--import Control.DeepSeq (NFData, )--import NumericPrelude.Base hiding (id, (.), )-import NumericPrelude.Numeric-import Prelude ()----replicateLong ::- (SigG.Write sig y) =>- StrictTime -> y -> sig y-replicateLong tl y =- CutG.concat $- map (\t ->- SigG.replicate--- (SigG.LazySize $ fromIntegral $ maxBound::Int)- SigG.defaultLazySize- (NonNegW.toNumber t) y) $- PC.chopLongTime tl--{--ToDo: move to Generic.Signal--}-{-# INLINE piecewiseConstant #-}-piecewiseConstant ::- (SigG.Write sig y) =>- EventListBT.T StrictTime y -> sig y-piecewiseConstant =- EventListBT.foldrPair- (\y t -> SigG.append (replicateLong t y))- SigG.empty--{-# INLINE piecewiseConstantInit #-}-piecewiseConstantInit ::- (SigG.Write sig y) =>- y -> EventList.T StrictTime y -> sig y-piecewiseConstantInit initial =- (\ ~(t,rest) ->- SigG.append (replicateLong t initial) rest)- .- EventList.foldr- (,)- (\y ~(t,rest) ->- SigG.append (replicateLong t y) rest)- (0, SigG.empty)--{-# INLINE piecewiseConstantInitWith #-}-piecewiseConstantInitWith ::- (SigG.Write sig c) =>- (y -> c) ->- c -> EventList.T StrictTime [y] -> sig c-piecewiseConstantInitWith f initial =- piecewiseConstantInit initial .- flip evalState initial .- traverse (\evs -> traverse_ (put . f) evs >> get)----type Instrument y signal = y -> y -> LazyTime -> signal-type Bank y signal = Program -> Instrument y signal--{- |-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--}-renderInstrument ::- (Trans.C y) =>- Bank y signal ->- Note ->- signal-renderInstrument instrument (Note pgm pitch vel dur) =- instrument pgm- (MV.velocity vel)- (MV.frequencyFromPitch pitch)- dur--renderInstrumentIgnoreProgram ::- (Trans.C y) =>- Instrument y signal ->- Note ->- signal-renderInstrumentIgnoreProgram instrument =- renderInstrument (const instrument)---{- |-Turn an event list with bundles of elements-into an event list with single events.--}-flatten ::- (Monoid signal, NonNeg.C time) =>- EventList.T time [signal] ->- EventList.T time signal-flatten =- EventList.foldr- EventListMB.consTime- (\bt xs ->- uncurry EventListMB.consBody $- case bt of- [] -> (mempty, xs)- b:bs -> (b, foldr (EventList.cons NonNeg.zero) xs bs))- EventList.empty---applyModulation ::- (CutG.Transform signal, CutG.NormalForm signal) =>- signal ->- Modulator (signal -> instr, note) (instr, note)-applyModulation ctrl =- first $- Modulator ctrl advanceModulationChunk gets--{- |-We have to evaluate the head value at each 'drop'-in order to avoid growing thunks that lead to a space leak.--}-evaluateVectorHead ::- (CutG.NormalForm signal) =>- signal -> t -> t-evaluateVectorHead xs t =- case CutG.evaluateHead xs of () -> t--- if CutG.null xs then t else t--advanceModulation ::- (CutG.Transform signal, CutG.NormalForm signal) =>- LazyTime -> State signal LazyTime-advanceModulation =- liftM NonNegChunky.fromChunks .- mapM advanceModulationChunk .- NonNegChunky.toChunks--advanceModulationChunk ::- (CutG.Transform signal, CutG.NormalForm signal) =>- StrictTime -> State signal StrictTime-advanceModulationChunk t = state $ \xs ->- let ys = CutG.drop (fromIntegral t) xs- in (evaluateVectorHead ys t, ys)--advanceModulationChunkStrict ::- (CutG.Transform signal, CutG.NormalForm signal) =>- StrictTime -> MS.State signal StrictTime-advanceModulationChunkStrict t = MS.state $ \xs ->- let ys = CutG.drop (fromIntegral t) xs- in (evaluateVectorHead ys t, ys)--advanceModulationChunkPC ::- (NFData body) =>- StrictTime ->- State (EventListBT.T StrictTime body) StrictTime-advanceModulationChunkPC t = state $ \xs ->- let ys =- EventListBT.fromPairList $ tail $- EventListBT.toPairList xs- in (evaluateVectorHead ys t, ys)--type FilterSequence signal =- Filter (EventList.T PC.ShortStrictTime signal)--{- |-The state action for the time-should just return the argument time.-However we need this time (or alternatively another result type)-for triggering the 'drop' in 'advanceModulationChunk'.-Without this strict evaluation,-the drop will be delayed until the control curve is actually needed.--}-data Modulator note signal =- forall state.- Modulator- state- (StrictTime -> State state StrictTime)- (note -> State state signal)--instance Category Modulator where- id = Modulator () return return- (Modulator yInit yTime yBody) . (Modulator xInit xTime xBody) =- let compose ym xm r0 =- state $ \(xState0,yState0) ->- let (r1, xState1) = runState (xm r0) xState0- (r2, yState1) = runState (ym r1) yState0- in (r2, (xState1,yState1))- in Modulator- (xInit,yInit)- (compose yTime xTime)- (compose yBody xBody)--instance Arrow Modulator where- arr f = Modulator () return (return . f)- first (Modulator xInit xTime xBody) =- Modulator xInit xTime- (\(a0,c) -> fmap (\a1 -> (a1,c)) $ xBody a0)---applyModulator ::- Modulator a b ->- EventList.T StrictTime [a] ->- EventList.T StrictTime [b]-applyModulator- (Modulator modulatorInit modulatorTime modulatorBody) =- flip evalState modulatorInit .- EventList.traverse modulatorTime (traverse modulatorBody)---{-# INLINE sequenceCore #-}-sequenceCore ::- (Monoid signal) =>- Channel ->- Program ->- Modulator Note signal ->- FilterSequence signal-sequenceCore chan initPgm md =- fmap (EventList.mapTime fromIntegral .- flatten .- applyModulator md .- matchNoteEvents .- embedPrograms initPgm) $- getNoteEvents chan---errorNoProgram :: Program-errorNoProgram =- ChannelMsg.toProgram 0-{--Since we compute the current program strictly in embedPrograms,-initializing with undefined does no longer work.- error "MIDI program not initialized"--}---{-# INLINE sequence #-}-sequence ::- (Monoid signal, Trans.C y) =>- Channel ->- Instrument y signal ->- FilterSequence signal-sequence chan instr =- sequenceCore chan errorNoProgram- (Modulator () return- (return . renderInstrumentIgnoreProgram instr))---{-# INLINE sequenceModulated #-}-sequenceModulated ::- (CutG.Transform ctrl, CutG.NormalForm ctrl,- Monoid signal, Trans.C y) =>- ctrl ->- Channel ->- (ctrl -> Instrument y signal) ->- FilterSequence signal-sequenceModulated ctrl chan instr =- sequenceCore chan errorNoProgram- (Modulator ctrl advanceModulationChunk- (\note -> gets $ \c -> renderInstrumentIgnoreProgram (instr c) note))---{-# INLINE sequenceMultiModulated #-}-sequenceMultiModulated ::- (Monoid signal, Trans.C y) =>- Channel ->- instrument ->- Modulator (instrument, Note) (Instrument y signal, Note) ->- FilterSequence signal-sequenceMultiModulated chan instr- (Modulator modulatorInit modulatorTime modulatorBody) =- sequenceCore chan errorNoProgram- (Modulator modulatorInit modulatorTime- (fmap (uncurry renderInstrumentIgnoreProgram) .- modulatorBody .- (,) instr))--{-# INLINE sequenceMultiProgram #-}-sequenceMultiProgram ::- (Monoid signal, Trans.C y) =>- Channel ->- Program ->- [Instrument y signal] ->- FilterSequence signal-sequenceMultiProgram chan initPgm instrs =- let bank = makeInstrumentArray instrs- in sequenceCore chan initPgm- (Modulator () return- (return . renderInstrument- (getInstrumentFromArray bank initPgm)))--{-# INLINE sequenceModulatedMultiProgram #-}-sequenceModulatedMultiProgram ::- (CutG.Transform ctrl, CutG.NormalForm ctrl,- Monoid signal, Trans.C y) =>- ctrl ->- Channel ->- Program ->- [ctrl -> Instrument y signal] ->- FilterSequence signal-sequenceModulatedMultiProgram ctrl chan initPgm instrs =- let bank = makeInstrumentArray instrs- in sequenceCore chan initPgm- (Modulator- ctrl advanceModulationChunk- (\note -> gets $ \c -> renderInstrument- (\pgm -> getInstrumentFromArray bank initPgm pgm c) note))
− src/Synthesizer/MIDIValue.hs
@@ -1,56 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{- |-Functions for converting MIDI controller and key values-to something meaningful for signal processing.--}-module Synthesizer.MIDIValue where--import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg--import qualified Algebra.Transcendental as Trans-import qualified Algebra.Field as Field--import NumericPrelude.Numeric--- import NumericPrelude.Base---{-# INLINE controllerLinear #-}-controllerLinear ::- (Field.C y) =>- (y,y) -> Int -> y-controllerLinear (lower,upper) n =- let k = fromIntegral n / 127- in (1-k) * lower + k * upper--{-# INLINE controllerExponential #-}-controllerExponential ::- (Trans.C y) =>- (y,y) -> Int -> y-controllerExponential (lower,upper) n =- let k = fromIntegral n / 127- in lower**(1-k) * upper**k--{-# INLINE pitchBend #-}-pitchBend ::- (Trans.C y) =>- y -> y -> Int -> y-pitchBend range center n =- center * range ** (fromIntegral n / 8192)--{-# INLINE velocity #-}-velocity ::- (Field.C y) =>- VoiceMsg.Velocity -> y-velocity vel =- fromIntegral (VoiceMsg.fromVelocity vel - 64)/63--{- |-Convert pitch to frequency according to the default tuning-in MIDI 1.0 Detailed Specification.--}-{-# INLINE frequencyFromPitch #-}-frequencyFromPitch ::- (Trans.C y) =>- VoiceMsg.Pitch -> y-frequencyFromPitch pitch =- 440 * 2 ^? (fromIntegral (VoiceMsg.fromPitch pitch + 3 - 6*12) / 12)
− src/Synthesizer/MIDIValue/BendModulation.hs
@@ -1,101 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{- |-Combine pitchbend and modulation in one data type.--}-module Synthesizer.MIDIValue.BendModulation where--import qualified Synthesizer.MIDIValue.BendWheelPressure as BWP-import qualified Synthesizer.MIDIValue as MV--import qualified Algebra.Transcendental as Trans-import qualified Algebra.RealRing as RealRing-import qualified Algebra.Ring as Ring--import Foreign.Storable (Storable(sizeOf, alignment, peek, poke), )-import qualified Foreign.Storable.Traversable as Store--import qualified Data.Foldable as Fold-import qualified Data.Traversable as Trav--import Control.Applicative (Applicative, (<*>), pure, liftA2, )--import Control.DeepSeq (NFData, rnf, )--import NumericPrelude.Numeric-import NumericPrelude.Base---{- |-'bend' is a frequency factor-and 'depth' is a modulation depth to be interpreted by the instrument.--}-data T a = Cons {bend, depth :: a}- deriving (Show, Eq)--deflt :: (Ring.C a) => T a-deflt = Cons one zero---instance (NFData a) => NFData (T a) where- rnf bm =- case rnf (bend bm) of () -> rnf (depth bm)---instance Functor T where- {-# INLINE fmap #-}- fmap f (Cons b m) = Cons (f b) (f m)---- useful for defining 'peek' instance-instance Applicative T where- {-# INLINE pure #-}- pure a = Cons a a- {-# INLINE (<*>) #-}- (Cons fb fm) <*> (Cons b m) =- Cons (fb b) (fm m)--instance Fold.Foldable T where- {-# INLINE foldMap #-}- foldMap = Trav.foldMapDefault---- this allows for kinds of generic programming-instance Trav.Traversable T where- {-# INLINE sequenceA #-}- sequenceA (Cons b m) =- liftA2 Cons b m---force :: T a -> T a-force ~(Cons a b) = (Cons a b)--instance (Storable a) => Storable (T a) where- {-# INLINE sizeOf #-}- sizeOf = Store.sizeOf . force- {-# INLINE alignment #-}- alignment = Store.alignment . force- {-# INLINE peek #-}- peek = Store.peekApplicative- {-# INLINE poke #-}- poke = Store.poke----{- |-Multiply the pitch bend by a given factor.-This way you can e.g. shift the pitch bend from around 1-to the actual frequency.--}-shift ::- (Ring.C a) =>- a -> T a -> T a-shift k (Cons b d) = Cons (k*b) d--fromBendWheelPressure ::- (RealRing.C a, Trans.C a) =>- Int -> a -> a ->- BWP.T -> T a-fromBendWheelPressure- pitchRange wheelDepth pressDepth bwp =- Cons- (MV.pitchBend (2^?(fromIntegral pitchRange/12)) 1 (BWP.bend_ bwp))- (MV.controllerLinear (0,wheelDepth) (BWP.wheel_ bwp) +- MV.controllerLinear (0,pressDepth) (BWP.pressure_ bwp))
− src/Synthesizer/MIDIValue/BendWheelPressure.hs
@@ -1,39 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Synthesizer.MIDIValue.BendWheelPressure where--import qualified Data.Accessor.Basic as Accessor--import Control.DeepSeq (NFData, rnf, )--import NumericPrelude.Numeric-import NumericPrelude.Base---data T = Cons {bend_, wheel_, pressure_ :: Int}- deriving (Show, Eq)--deflt :: T-deflt = Cons 0 0 0---bend, wheel, pressure :: Accessor.T T Int-bend =- Accessor.fromSetGet- (\b (Cons _ w p) -> Cons b w p)- bend_--wheel =- Accessor.fromSetGet- (\w (Cons b _ p) -> Cons b w p)- wheel_--pressure =- Accessor.fromSetGet- (\p (Cons b w _) -> Cons b w p)- pressure_---instance NFData T where- rnf (Cons b w p) =- case (rnf b, rnf w, rnf p) of- ((), (), ()) -> ()
− src/Synthesizer/PiecewiseConstant/ALSA/MIDI.hs
@@ -1,188 +0,0 @@-{- |-Convert MIDI events of a MIDI controller to a control signal.--}-{-# LANGUAGE NoImplicitPrelude #-}-module Synthesizer.PiecewiseConstant.ALSA.MIDI (- T,- duration,- PC.zipWith,-- initWith,- controllerLinear,- controllerExponential,- pitchBend,- channelPressure,- bendWheelPressure,- checkBendWheelPressure,- bendWheelPressureZip,- ) where--import qualified Synthesizer.EventList.ALSA.MIDI as Ev-import Synthesizer.EventList.ALSA.MIDI (LazyTime, StrictTime, Filter, Channel, )--import qualified Sound.MIDI.ALSA.Check as Check-import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg-import qualified Sound.ALSA.Sequencer.Event as Event-import qualified Synthesizer.MIDIValue.BendModulation as BM-import qualified Synthesizer.MIDIValue.BendWheelPressure as BWP-import qualified Synthesizer.MIDIValue as MV--import qualified Synthesizer.PiecewiseConstant.Signal as PC---- 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 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.Chunky as NonNegChunky--import qualified Algebra.Transcendental as Trans-import qualified Algebra.RealRing as RealRing-import qualified Algebra.Field as Field--import qualified Data.Accessor.Monad.Trans.State as AccState-import Control.Monad.Trans.State (State, evalState, state, get, put, )-import Control.Monad (liftM, liftM2, msum, )-import Data.Traversable (traverse, sequence, )-import Data.Foldable (traverse_, )--import qualified Data.List.HT as ListHT-import qualified Data.List as List-import Data.Either (Either(Left, Right), )-import Data.Maybe (maybe, )-import Data.Function ((.), ($), flip, )--import NumericPrelude.Numeric-import Prelude as P (Maybe, fmap, (>>), )---type T = EventListBT.T StrictTime---duration :: T y -> LazyTime-duration =- NonNegChunky.fromChunks . EventListBT.getTimes---{-# INLINE initWith #-}-initWith ::- (y -> c) ->- c -> EventList.T StrictTime [y] -> T c-initWith f initial =-{-- EventListTM.switchBodyR EventListBT.empty- (\xs _ -> EventListMT.consBody initial xs) .--}- EventListMT.consBody initial .- flip EventListTM.snocTime NonNeg.zero .- flip evalState initial .- traverse- (\ys -> traverse_ (put . f) ys >> get)---{-# INLINE controllerLinear #-}-controllerLinear ::- (Field.C y) =>- Channel -> Ev.Controller ->- (y,y) -> y ->- Filter (T y)-controllerLinear chan ctrl bnd initial =- liftM (initWith (MV.controllerLinear bnd) initial) $- Ev.getControllerEvents chan ctrl---{-# INLINE controllerExponential #-}-controllerExponential ::- (Trans.C y) =>- Channel -> Ev.Controller ->- (y,y) -> y ->- Filter (T y)-controllerExponential chan ctrl bnd initial =- liftM (initWith (MV.controllerExponential bnd) initial) $- Ev.getControllerEvents chan ctrl---{- |-@pitchBend channel range center@:-emits frequencies on an exponential scale from-@center/range@ to @center*range@.--}-{-# INLINE pitchBend #-}-pitchBend ::- (Trans.C y) =>- Channel ->- y -> y ->- Filter (T y)-pitchBend chan range center =- liftM (initWith (MV.pitchBend range center) center) $- Ev.getSlice (Check.pitchBend chan)--- getPitchBendEvents chan--{-# INLINE channelPressure #-}-channelPressure ::- (Trans.C y) =>- Channel ->- y -> y ->- Filter (T y)-channelPressure chan maxVal initVal =- liftM (initWith (MV.controllerLinear (0,maxVal)) initVal) $- Ev.getSlice (Check.channelPressure chan)---{-# INLINE bendWheelPressure #-}-bendWheelPressure ::- (RealRing.C y, Trans.C y) =>- Channel ->- Int -> y -> y ->- Filter (T (BM.T y))-bendWheelPressure chan- pitchRange wheelDepth pressDepth =- let toBM = BM.fromBendWheelPressure pitchRange wheelDepth pressDepth- in liftM (initWith toBM (toBM BWP.deflt)) $- state $- EventList.unzip .- fmap ListHT.unzipEithers .- flip evalState BWP.deflt .- traverse (traverse (separateBWP chan))--separateBWP :: Channel -> Event.T -> State BWP.T (Either BWP.T Event.T)-separateBWP chan ev =- fmap (maybe (Right ev) Left) $- checkBendWheelPressure chan ev--{- |-I hesitate to move this to MIDIValue or BendWheelPressure module-because it depends on ALSA specific Event.--}-checkBendWheelPressure ::- Channel -> Event.T -> State BWP.T (Maybe BWP.T)-checkBendWheelPressure chan ev =- sequence $- (fmap (>> get)) $- msum $ List.map ($ev) $- (fmap (AccState.set BWP.bend) . Check.pitchBend chan) :- (fmap (AccState.set BWP.wheel) . Check.controller chan VoiceMsg.modulation) :- (fmap (AccState.set BWP.pressure) . Check.channelPressure chan) :- []--{- |-This one is certainly not as efficient as 'bendWheelPressure'-since it first slices the event list-and then zips the slices together.--}-{-# INLINE bendWheelPressureZip #-}-bendWheelPressureZip ::- (RealRing.C y, Trans.C y) =>- Channel ->- Int -> y -> y ->- Filter (T (BM.T y))-bendWheelPressureZip chan- pitchRange wheelDepth pressDepth =- liftM2 (PC.zipWith BM.Cons)- (pitchBend chan (2^?(fromIntegral pitchRange/12)) 1)- (liftM2 (PC.zipWith (+))- (controllerLinear chan VoiceMsg.modulation (0,wheelDepth) 0)- (channelPressure chan pressDepth 0))
− src/Synthesizer/PiecewiseConstant/ALSA/MIDIControllerSet.hs
@@ -1,379 +0,0 @@-{- |-Treat a stream of MIDI events as parallel streams of MIDI controller events.--}-{-# LANGUAGE NoImplicitPrelude #-}-module Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet (- T(Cons),- mapStream,-- Controller(Controller,PitchBend,Pressure),- fromChannel,- maybeController,- controllerLinear,- controllerExponential,- pitchBend,- channelPressure,- bendWheelPressure,- checkBendWheelPressure,- bendWheelPressureZip,-- -- * internal data needed in synthesizer-llvm- initial, stream,- ) where--import qualified Synthesizer.PiecewiseConstant.Signal as PC-import qualified Synthesizer.EventList.ALSA.MIDI as Ev-import Synthesizer.EventList.ALSA.MIDI (StrictTime, Channel, )--import qualified Sound.ALSA.Sequencer.Event as Event-import qualified Sound.MIDI.ALSA.Check as Check-import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg-import qualified Synthesizer.MIDIValue.BendModulation as BM-import qualified Synthesizer.MIDIValue.BendWheelPressure as BWP-import qualified Synthesizer.MIDIValue as MV--import qualified Synthesizer.Generic.Cut as CutG-import Control.DeepSeq (NFData, rnf, )--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 qualified Data.EventList.Relative.TimeBody as EventListTB--import qualified Numeric.NonNegative.Class as NonNeg98--- import qualified Numeric.NonNegative.Wrapper as NonNegW--- import qualified Numeric.NonNegative.Chunky as NonNegChunky--- import Numeric.NonNegative.Class ((-|), )--import qualified Algebra.Transcendental as Trans-import qualified Algebra.RealRing as RealRing-import qualified Algebra.Field as Field-import qualified Algebra.Additive as Additive--import qualified Data.Map as Map-import Data.Map (Map, )--import qualified Data.Accessor.Monad.Trans.State as AccState-import qualified Data.Accessor.Basic as Acc-import Control.Monad.Trans.State (State, evalState, state, get, put, )-import Control.Monad (liftM2, msum, )-import Data.Traversable (traverse, )-import Data.Foldable (traverse_, )-import Data.Monoid (Monoid, mempty, mappend, )--import Data.Maybe.HT (toMaybe, )-import Data.Tuple.HT (mapFst, mapPair, )-import qualified Data.List.HT as ListHT-import qualified Data.List as List--import NumericPrelude.Numeric-import NumericPrelude.Base-import qualified Prelude as P- (Num, Integral, fromInteger, fromIntegral, toInteger, sum, )---{--This data structure stores the initial values of all supported controllers-and an event list of all changes of individal controllers.--}-data T key a =- Cons {- initial :: Map key a,- stream :: EventListTT.T StrictTime [(key, a)]- }- deriving Show---mapStream ::- (EventListTT.T StrictTime [(key, a)] ->- EventListTT.T StrictTime [(key, a)]) ->- T key a -> T key a-mapStream f s = Cons (initial s) (f (stream s))---data Controller =- Controller VoiceMsg.Controller- | PitchBend- | Pressure- deriving (Show, Eq, Ord)--instance NFData Controller where- rnf (Controller c) =- rnf (VoiceMsg.fromController c)- rnf _ = ()---fromChannel ::- Channel ->- Ev.Filter (T Controller Int)-fromChannel chan =- fmap (Cons Map.empty) $- fmap (flip EventListTM.snocTime NonNeg98.zero) $- Ev.getSlice (maybeController chan)--maybeController ::- Channel -> Event.T -> Maybe (Controller, Int)-maybeController chan e = msum $- (fmap (mapFst Controller) $ Check.anyController chan e) :- (fmap ((,) PitchBend) $ Check.pitchBend chan e) :- (fmap ((,) Pressure) $ Check.channelPressure chan e) :- []---instance CutG.Read (T key a) where- null =- List.null . List.filter (> P.fromInteger 0) .- EventListTT.getTimes . stream- length =- fromIntegral . P.toInteger .- P.sum . EventListTT.getTimes . stream--instance Monoid (T key y) where- mempty = Cons Map.empty (EventListTT.pause mempty)- mappend x y =- Cons- (initial x)- (EventListTT.append (stream x) (flatten y))--instance (NFData key, NFData a) => CutG.NormalForm (T key a) where- evaluateHead xs = rnf (initial xs)--{- |-Prepend the initial values as events to the event-list.--}-flatten ::- T key a -> EventListTT.T StrictTime [(key, a)]-flatten xs =- EventListTT.cons- mempty (Map.toList $ initial xs)- (stream xs)---mapInsertMany ::- (Ord key) =>- [(key,a)] -> Map key a -> Map key a-mapInsertMany assignments inits =- foldl (flip (uncurry Map.insert)) inits assignments---reverseList ::- (Ord key) =>- (Map key a, [(key,a)]) ->- (Map key a, [(key,a)])-reverseList (inits,xs) =- foldl- (\(inits0,ys) (key,a) ->- let (ma,inits1) =- Map.insertLookupWithKey- (\ _k new _old -> new) key a inits0- in (inits1,- maybe- (error "MIDIControllerSet.reverse: uninitialized controller")- ((,) key) ma- : ys))- (inits, [])- xs--{- |-For reverse you must make sure,-that all controller events have an corresponding initial value.-Controllers that miss an initial value-their last constant piece will be undefined.--}-instance (Ord key) => CutG.Transform (T key y) where- take n =- mapStream (EventListTT.takeTime (P.fromIntegral n))-- drop n0 xs =- let recourse n inits =- EventListMT.switchTimeL $ \t xs1 ->- let (b,d) = snd $ NonNeg98.split t n- in mapStream (EventListTT.forceTimeHead) $- if not b- then Cons inits (EventListMT.consTime d xs1)- else- flip (EventListMT.switchBodyL- (Cons inits (EventListTT.pause mempty))) xs1 $ \assignments xs2 ->- recourse d (mapInsertMany assignments inits) xs2- in recourse (P.fromIntegral n0) (initial xs) (stream xs)-- -- cf. ChunkySize.dropMarginRem- dropMarginRem n m xs =- List.foldl'- (\(mi,xsi) k -> (mi-k, CutG.drop k xsi))- (m, xs)- (List.map P.fromIntegral $ EventListTT.getTimes $- EventListTT.takeTime (P.fromIntegral m) $- EventListTT.dropTime (P.fromIntegral n) $- stream xs)-- -- cf. StorableVector.Lazy.splitAt- splitAt n0 xs =- let recourse n inits =- EventListMT.switchTimeL $ \t xs1 ->- let (m, ~(b,d)) = NonNeg98.split t n- in mapPair- (EventListMT.consTime m,- mapStream (EventListTT.forceTimeHead)) $- if not b- then- (EventListBT.empty,- Cons inits (EventListMT.consTime d xs1))- else- flip (EventListMT.switchBodyL- (EventListBT.empty,- Cons inits (EventListTT.pause mempty))) xs1 $ \keyAs xs2 ->- mapFst (EventListMT.consBody keyAs) $- recourse d (mapInsertMany keyAs inits) xs2- in mapFst (Cons (initial xs)) $- recourse (P.fromIntegral n0) (initial xs) (stream xs)-- reverse xs =- EventListTT.foldl- (\(inits,ys) t -> Cons inits $ EventListMT.consTime t ys)- (\(Cons inits0 ys) evs0 ->- let (inits1, evs1) = reverseList (inits0, evs0)- in (inits1, EventListMT.consBody evs1 ys))- (initial xs, EventListBT.empty)- (stream xs)-{--*Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet Data.EventList.Relative.MixedTime> CutG.reverse $ Cons (Map.singleton 'a' GT) (2 /. [('a',EQ)] ./ 3 /. empty) :: T Char Ordering--}----type Filter = State (T Controller Int)---_errorUninitialized :: Controller -> Int-_errorUninitialized c =- error $- "getSlice: uninitialized controller " ++ show c--{-# INLINE getSlice #-}-getSlice ::- Controller ->- (Int -> a) ->- a -> Filter (PC.T a)-getSlice c f deflt =- state $ \xs ->- let (ys,zs) =- EventListTT.unzip $- fmap- (ListHT.partitionMaybe- (\(ci,a) -> toMaybe (c==ci) a))- (stream xs)- (yin0,zis) =- Map.updateLookupWithKey- (\ _k _a -> Nothing) c- (initial xs)- yin1 = maybe deflt f yin0- fill =- flip evalState yin1 .- traverse- (\ys0 -> traverse_ (put . f) ys0 >> get)- in (EventListMT.consBody yin1 (fill ys),- Cons zis zs)---{-# INLINE controllerLinear #-}-controllerLinear ::- (Field.C y) =>- Ev.Controller -> (y,y) -> y -> Filter (PC.T y)-controllerLinear ctrl bnd =- getSlice (Controller ctrl) (MV.controllerLinear bnd)---{-# INLINE controllerExponential #-}-controllerExponential ::- (Trans.C y) =>- Ev.Controller -> (y,y) -> y -> Filter (PC.T y)-controllerExponential ctrl bnd =- getSlice (Controller ctrl) (MV.controllerExponential bnd)----{- |-@pitchBend channel range center@:-emits frequencies on an exponential scale from-@center/range@ to @center*range@.--}-{-# INLINE pitchBend #-}-pitchBend ::- (Trans.C y) =>- y -> y ->- Filter (PC.T y)-pitchBend range center =- getSlice PitchBend (MV.pitchBend range center) center--{-# INLINE channelPressure #-}-channelPressure ::- (Trans.C y) =>- y -> y ->- Filter (PC.T y)-channelPressure maxVal =- getSlice Pressure (MV.controllerLinear (Additive.zero,maxVal))------ adapted from getSlice-{-# INLINE bendWheelPressure #-}-bendWheelPressure ::- (RealRing.C y, Trans.C y) =>- Int -> y -> y ->- Filter (PC.T (BM.T y))-bendWheelPressure pitchRange wheelDepth pressDepth =- state $ \xs ->- let (ys,zs) =- EventListTT.unzip $- fmap ListHT.unzipEithers $- flip evalState BWP.deflt $- traverse (traverse separateBWP) (stream xs)- move key field (bwp,mp) =- mapFst (maybe bwp (\y -> Acc.set field y bwp)) $- Map.updateLookupWithKey- (\ _k _a -> Nothing) key mp- (yin,zis) =- move PitchBend BWP.bend $- move (Controller VoiceMsg.modulation) BWP.wheel $- move Pressure BWP.pressure $- (BWP.deflt, initial xs)- fill =- flip evalState yin .- traverse- (\ys0 -> traverse_ put ys0 >> get)- in (fmap (BM.fromBendWheelPressure pitchRange wheelDepth pressDepth) $- EventListMT.consBody yin (fill ys),- Cons zis zs)--separateBWP ::- (Controller, Int) -> State BWP.T (Either BWP.T (Controller, Int))-separateBWP ev =- fmap (maybe (Right ev) Left) $- checkBendWheelPressure ev--checkBendWheelPressure ::- (Controller, Int) -> State BWP.T (Maybe BWP.T)-checkBendWheelPressure (ctrl,val) =- let update field = AccState.set field val >> fmap Just get- in case ctrl of- PitchBend -> update BWP.bend- Pressure -> update BWP.pressure- Controller cc ->- if cc == VoiceMsg.modulation- then update BWP.wheel- else return $ Nothing---{-# INLINE bendWheelPressureZip #-}-bendWheelPressureZip ::- (RealRing.C y, Trans.C y) =>- Int -> y -> y ->- Filter (PC.T (BM.T y))-bendWheelPressureZip pitchRange wheelDepth pressDepth =- liftM2 (PC.zipWith BM.Cons)- (pitchBend (2 ^? (fromIntegral pitchRange / 12)) 1)- (liftM2 (PC.zipWith (+))- (controllerLinear VoiceMsg.modulation (0,wheelDepth) 0)- (channelPressure pressDepth 0))
− src/Synthesizer/Storable/ALSA/MIDI.hs
@@ -1,319 +0,0 @@-{- |-Convert MIDI events of a MIDI controller to a control signal.--}-{-# LANGUAGE NoImplicitPrelude #-}-module Synthesizer.Storable.ALSA.MIDI (- chunkSizesFromLazyTime,- piecewiseConstant,- piecewiseConstantInit,- piecewiseConstantInitWith,- controllerLinear,- controllerExponential,- pitchBend,- channelPressure,- bendWheelPressure,-- Instrument, Bank,- sequenceCore,- sequence,- sequenceModulated,- sequenceMultiModulated,- applyModulation,- advanceModulationLazy,- advanceModulationStrict,- advanceModulationChunky,- sequenceMultiProgram,-- Gen.renderInstrument,- Gen.renderInstrumentIgnoreProgram,- Gen.evaluateVectorHead,- Gen.advanceModulationChunk,- ) where--import Synthesizer.EventList.ALSA.MIDI- (LazyTime, StrictTime, Filter, Note,- Program, Channel, Controller,- getControllerEvents, getSlice, )-import qualified Synthesizer.Generic.ALSA.MIDI as Gen-import qualified Synthesizer.MIDIValue as MV--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 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.ALSA.Check as Check-import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg--import qualified Synthesizer.PiecewiseConstant.Signal as PC--- import qualified Data.EventList.Relative.TimeTime as EventListTT--- import qualified Data.EventList.Relative.MixedTime as EventListMT--- import qualified Data.EventList.Relative.MixedBody as EventListMB-import qualified Data.EventList.Relative.BodyTime as EventListBT--- import qualified Data.EventList.Relative.BodyMixed as EventListBM--- import qualified Data.EventList.Relative.TimeMixed as EventListTM-import qualified Data.EventList.Relative.TimeBody as EventList--import Foreign.Storable (Storable, )---- import qualified Numeric.NonNegative.Class as NonNeg-import qualified Numeric.NonNegative.Wrapper as NonNegW-import qualified Numeric.NonNegative.Chunky as NonNegChunky--import qualified Algebra.Transcendental as Trans-import qualified Algebra.RealRing as RealRing-import qualified Algebra.Field as Field-import qualified Algebra.Additive as Additive--import Control.Monad.Trans.State (State, evalState, state, modify, put, get, )-import Control.Monad (liftM, )-import Data.Traversable (traverse, )-import Data.Foldable (traverse_, )--import NumericPrelude.Base hiding (sequence, )-import NumericPrelude.Numeric----chunkSizesFromStrictTime :: StrictTime -> NonNegChunky.T SigSt.ChunkSize-chunkSizesFromStrictTime =- NonNegChunky.fromChunks .- map (SVL.ChunkSize . NonNegW.toNumber) .- PC.chopLongTime---chunkSizesFromLazyTime :: LazyTime -> NonNegChunky.T SigSt.ChunkSize-chunkSizesFromLazyTime =- NonNegChunky.fromChunks .- map (SVL.ChunkSize . NonNegW.toNumber) .- concatMap PC.chopLongTime .- NonNegChunky.toChunks .- NonNegChunky.normalize----{--ToDo: move to Storable.Signal--}-{-# INLINE piecewiseConstant #-}-piecewiseConstant ::- (Storable y) =>- EventListBT.T StrictTime y -> SigSt.T y-piecewiseConstant =- EventListBT.foldrPair- (\y t -> SigSt.append (SigStV.replicate (chunkSizesFromStrictTime t) y))- SigSt.empty--{-# INLINE piecewiseConstantInit #-}-piecewiseConstantInit ::- (Storable y) =>- y -> EventList.T StrictTime y -> SigSt.T y-piecewiseConstantInit initial =- (\ ~(t,rest) ->- SigSt.append (SigStV.replicate (chunkSizesFromStrictTime t) initial) rest)- .- EventList.foldr- (,)- (\y ~(t,rest) ->- SigSt.append (SigStV.replicate (chunkSizesFromStrictTime t) y) rest)- (0, SigSt.empty)-{-- piecewiseConstant .--- EventListBM.switchBodyR const .--- EventListBM.snocTime NonNeg.zero .--- EventListMB.consBody initial .- -- switchBodyR causes a space leak- EventListTM.switchBodyR EventListBT.empty- (\xs _ -> EventListMT.consBody initial xs)--}--{-# INLINE piecewiseConstantInitWith #-}-piecewiseConstantInitWith ::- (Storable c) =>- (y -> c) ->- c -> EventList.T StrictTime [y] -> SigSt.T c-piecewiseConstantInitWith f initial =- piecewiseConstantInit initial .- flip evalState initial .- traverse (\evs -> traverse_ (put . f) evs >> get)---{-# INLINE controllerLinear #-}-controllerLinear ::- (Storable y, Field.C y) =>- Channel -> Controller ->- (y,y) -> y ->- Filter (SigSt.T y)-controllerLinear chan ctrl bnd initial =- liftM (piecewiseConstantInitWith (MV.controllerLinear bnd) initial) $- getControllerEvents chan ctrl---{-# INLINE controllerExponential #-}-controllerExponential ::- (Storable y, Trans.C y) =>- Channel -> Controller ->- (y,y) -> y ->- Filter (SigSt.T y)-controllerExponential chan ctrl bnd initial =- liftM (piecewiseConstantInitWith (MV.controllerExponential bnd) initial) $- getControllerEvents chan ctrl---{- |-@pitchBend channel range center@:-emits frequencies on an exponential scale from-@center/range@ to @center*range@.--}-{-# INLINE pitchBend #-}-pitchBend ::- (Storable y, Trans.C y) =>- Channel ->- y -> y ->- Filter (SigSt.T y)-pitchBend chan range center =- liftM (piecewiseConstantInitWith (MV.pitchBend range center) center) $- getSlice (Check.pitchBend chan)--- getPitchBendEvents chan--{-# INLINE channelPressure #-}-channelPressure ::- (Storable y, Trans.C y) =>- Channel ->- y -> y ->- Filter (SigSt.T y)-channelPressure chan maxVal initVal =- liftM (piecewiseConstantInitWith (MV.controllerLinear (0,maxVal)) initVal) $- getSlice (Check.channelPressure chan)---{--We could use 'getBendWheelPressureSignal' here,-but this may be less efficient.--}-{-# INLINE bendWheelPressure #-}-bendWheelPressure ::- (Storable y, RealRing.C y, Trans.C y) =>- Channel ->- Int -> y -> y -> y ->- Filter (SigSt.T y)-bendWheelPressure chan- pitchRange speed wheelDepth pressDepth =- do bend <- pitchBend chan (2^?(fromIntegral pitchRange/12)) 1- fm <- controllerLinear chan VoiceMsg.modulation (0,wheelDepth) 0- press <- channelPressure 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)---type Instrument y yv = Gen.Instrument y (SigSt.T yv)-type Bank y yv = Gen.Bank y (SigSt.T yv)---{-# INLINE sequenceCore #-}-sequenceCore ::- (Storable yv, Additive.C yv) =>- SVL.ChunkSize ->- Channel ->- Program ->- Gen.Modulator Note (SigSt.T yv) ->- Filter (SigSt.T yv)-sequenceCore chunkSize chan pgm modu =- fmap (CutSt.arrangeEquidist chunkSize) $- Gen.sequenceCore chan pgm modu---{-# INLINE sequence #-}-sequence ::- (Storable yv, Additive.C yv, Trans.C y) =>- SVL.ChunkSize ->- Channel ->- Instrument y yv ->- Filter (SigSt.T yv)-sequence chunkSize chan bank =- fmap (CutSt.arrangeEquidist chunkSize) $- Gen.sequence chan bank---{-# INLINE sequenceModulated #-}-sequenceModulated ::- (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)-sequenceModulated chunkSize modu chan instr =- fmap (CutSt.arrangeEquidist chunkSize) $- Gen.sequenceModulated modu chan instr---{-# INLINE sequenceMultiModulated #-}-sequenceMultiModulated ::- (Storable yv, Additive.C yv, Trans.C y) =>- SVL.ChunkSize ->- Channel ->- instrument ->- Gen.Modulator (instrument, Note) (Instrument y yv, Note) ->- Filter (SigSt.T yv)-sequenceMultiModulated chunkSize chan instr modu =- fmap (CutSt.arrangeEquidist chunkSize) $- Gen.sequenceMultiModulated chan instr modu---applyModulation ::- (Storable c) =>- SigSt.T c ->- Gen.Modulator (SigSt.T c -> instr, note) (instr, note)-applyModulation =- Gen.applyModulation--advanceModulationLazy, advanceModulationStrict, advanceModulationChunky ::- (Storable a) =>- LazyTime -> State (SigSt.T a) LazyTime--{--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--{--This one is too strict,-because the complete drop is forced-also if only the first chunk of the lazy time is requested.--}-advanceModulationStrict t = state $ \xs ->- let ys = SigStV.drop (chunkSizesFromLazyTime t) xs- in (Gen.evaluateVectorHead ys t, ys)--advanceModulationChunky =- Gen.advanceModulation---{-# INLINE sequenceMultiProgram #-}-sequenceMultiProgram ::- (Storable yv, Additive.C yv, Trans.C y) =>- SVL.ChunkSize ->- Channel ->- Program ->- [Instrument y yv] ->- Filter (SigSt.T yv)-sequenceMultiProgram chunkSize chan pgm bank =- fmap (CutSt.arrangeEquidist chunkSize) $- Gen.sequenceMultiProgram chan pgm bank
− src/Synthesizer/Storable/ALSA/Play.hs
@@ -1,210 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{- |-Play audio signals via ALSA.-The module could also be called @Output@,-because with a @file@ sink, data can also be written to disk.--}-module Synthesizer.Storable.ALSA.Play (- -- * auxiliary functions- Device,- defaultDevice,- defaultChunkSize,- makeSink,- write,- writeLazy,- -- * play functions- auto,- autoAndRecord,- autoAndRecordMany,- monoToInt16,- stereoToInt16,- ) where--import qualified Sound.ALSA.PCM 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 Data.Int (Int16, )-import qualified System.IO as IO-import qualified System.Exit as Exit---- 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.RealRing as RealRing--import qualified Data.Traversable as Trav-import qualified Data.Foldable as Fold--import NumericPrelude.Numeric-import NumericPrelude.Base---{- |-A suggested default chunk size.-It is not used by the functions in this module.--}-{--Better move to Storable.Server.Common or Dimensional.Server.Common?--}-defaultChunkSize :: SigSt.ChunkSize-defaultChunkSize = SigSt.chunkSize 512-{--At some epochs this chunk size leads to buffer underruns.-I cannot reproduce this:-Some months it works this way on Suse but not on Ubuntu or vice versa.-Other months it works the other way round.-defaultChunkSize = SigSt.chunkSize 256--}---type Device = String--defaultDevice :: Device-defaultDevice = "default"---{- |-Useful values for the output device are--* @\"default\"@ for mixing with the output of other applications.--* @\"plughw:0,0\"@ for accessing sound output in an exclusive way.--* @\"tee:default,'output.raw',raw\"@ for playing and simultaneously writing raw data to disk.--* @\"tee:default,'output.wav',wav\"@ for playing and writing to WAVE file format.- Note that the length cannot be written,- when the program is terminated,- leaving the file in an invalid format.--}-makeSink ::- (ALSA.SampleFmt y, RealRing.C t) =>- Device {- ^ ALSA output device -} ->- t {- ^ period (buffer) size expressed in seconds -} ->- ALSA.SampleFreq {- ^ sample rate -} ->- ALSA.SoundSink y ALSA.Pcm-makeSink device periodTime rate =- ALSA.alsaSoundSinkTime device- (ALSA.SoundFmt {- ALSA.sampleFreq = rate- }) $- ALSA.SoundBufferTime- (round (5000000*periodTime))- (round (1000000*periodTime))--{--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 y) =>- ALSA.SoundSink y handle ->- SigSt.T y -> IO ()-auto sink ys =- ALSA.withSoundSink sink $ \to ->- writeLazy sink to ys--{-# INLINE writeLazy #-}-writeLazy ::- (Storable a) =>- ALSA.SoundSink a handle -> handle ->- SVL.Vector a -> IO ()-writeLazy sink to ys =- mapM_ (write sink to) (SVL.chunks ys)--{-# INLINE write #-}-write ::- (Storable a) =>- ALSA.SoundSink a handle -> handle ->- SVB.Vector a -> IO ()-write sink to 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--{- |-Play a signal and write it to disk via SoX simultaneously.-Consider using 'auto' with @tee@ device.--}-{-# INLINE autoAndRecord #-}-autoAndRecord ::- (ALSA.SampleFmt y, SoxFrame.C y) =>- FilePath ->- ALSA.SoundSink y handle ->- SigSt.T y -> IO Exit.ExitCode-autoAndRecord fileName sink =- let rate = ALSA.sampleFreq $ ALSA.soundSinkFmt sink- in (\act ->- 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)---{- |-Play a signal and write it to multiple files.-The Functor @f@ may be @Maybe@ for no or one file to write,-or @[]@ for many files to write.--}-{-# INLINE autoAndRecordMany #-}-autoAndRecordMany ::- (ALSA.SampleFmt y, SoxFrame.C y,- Trav.Traversable f) =>- f FilePath ->- ALSA.SoundSink y handle ->- SigSt.T y -> IO (f Exit.ExitCode)-autoAndRecordMany fileNames sink =- let rate = ALSA.sampleFreq $ ALSA.soundSinkFmt sink- in (\act ->- SoxWrite.manyExtended act SoxOption.none SoxOption.none fileNames rate) $ \hs ys ->- ALSA.withSoundSink sink $ \to ->- flip mapM_ (SVL.chunks ys) $ \c ->- SVB.withStartPtr c $ \ptr size ->- ALSA.soundSinkWrite sink to ptr size >>- Fold.traverse_ (\h -> IO.hPutBuf h ptr (arraySize ptr size)) hs---{-# INLINE monoToInt16 #-}-monoToInt16 ::- (Storable y, RealRing.C y) =>- ALSA.SoundSink Int16 handle ->- SigSt.T y -> IO ()-monoToInt16 sink xs =- auto sink (SigSt.map BinSmp.int16FromCanonical xs)--{-# INLINE stereoToInt16 #-}-stereoToInt16 ::- (Storable y, RealRing.C y) =>- ALSA.SoundSink (Stereo.T Int16) handle ->- SigSt.T (Stereo.T y) -> IO ()-stereoToInt16 sink xs =- auto sink (SigSt.map (fmap BinSmp.int16FromCanonical) xs)
− src/Synthesizer/Storable/ALSA/Server.hs
@@ -1,113 +0,0 @@-module Main where--import qualified Synthesizer.Storable.ALSA.Server.Run as Run-import qualified Synthesizer.Storable.ALSA.Server.Test as Test-import Synthesizer.Storable.ALSA.Server.Common- (Real, play, sampleRate, chunkSize, periodTime, )--import qualified Synthesizer.Basic.Wave as Wave--import qualified Synthesizer.Storable.ALSA.Play as Play-import qualified Synthesizer.Storable.Oscillator as OsciSt-import qualified Synthesizer.Storable.Signal as SigSt-import qualified Data.StorableVector.Lazy as SVL--import NumericPrelude.Numeric (zero, )-import Prelude hiding (Real, break, id, (.), )---{--This program has still a very slowly growing memory leak.--}-main :: IO ()-main =- case 208::Int of- 001 -> print Test.keyboard3- 002 -> play (periodTime::Real) sampleRate Test.keyboard3- 003 -> Test.speed- 004 -> Test.frequency1- 005 -> Test.frequency2- 006 -> Test.frequency3-{-- 007 -> Test.frequency4--}- 008 -> Test.keyboard1- 009 -> SigSt.writeFile "test.f32" Test.keyboard2- 010 -> SigSt.writeFile "test.f32" Test.keyboard3- 011 -> SigSt.writeFile "test.f32" Test.keyboard4- 012 -> SigSt.writeFile "test.f32" Test.keyboard5-{-- 013 -> Test.keyboard6- 014 -> Test.keyboard7--}- 015 -> Test.arrangeSpaceLeak0- 016 -> Test.arrangeSpaceLeak1- 018 -> Test.arrangeSpaceLeak3- 019 -> Test.arrangeSpaceLeak4- 020 -> Test.chordSpaceLeak1--- 021 -> Test.chordSpaceLeak2--- 022 -> Test.chordSpaceLeak3--- 023 -> Test.chordSpaceLeak4- 023 -> Test.sequencePitchBend- 024 -> Test.sequencePitchBend1- 025 -> Test.sequencePitchBend2- 026 -> Test.sequencePitchBend3- 027 -> Test.sequencePitchBend4- 028 -> Test.sequencePitchBend4a- 029 -> Test.sequencePitchBend4b- 030 -> Test.sequencePitchBend4c- 031 -> Test.sequencePitchBend4d- 032 -> Test.sequencePitchBend4e- 033 -> Test.sequencePitchBend5- 040 -> Test.sequenceStaccato- 050 -> Test.speed- 051 -> Test.speedChunky- 052 -> Test.speedArrange- 053 -> Play.auto-{-- (ALSA.alsaSoundSinkTime Play.defaultDevice- (ALSA.SoundFmt {- ALSA.sampleFreq = sampleRate- }) $- ALSA.SoundBufferTime- (round (5000000*periodTime::Real))- (round (1000000*periodTime::Real))- ) $--}-{-- (ALSA.fileSoundSink "test.f32"- (ALSA.SoundFmt {- ALSA.sampleFreq = sampleRate- })) $--}- (Play.makeSink Play.defaultDevice (periodTime::Real) sampleRate) $- SVL.cycle $- SigSt.take 100000 $- OsciSt.static chunkSize (fmap (0.9*) Wave.sine) zero (1/100::Real)- 054 -> Play.auto- (Play.makeSink Play.defaultDevice (periodTime::Real) sampleRate) $- OsciSt.static chunkSize (fmap (0.9*) Wave.sine)- zero (600/sampleRate::Real)- 055 -> play (periodTime::Real) sampleRate $- OsciSt.static chunkSize (fmap (0.9*) Wave.sine)- zero (600/sampleRate::Real)- 100 -> Run.volume- 101 -> Run.frequency- 102 -> Run.frequencyCausal- 103 -> Run.pitchBend- 104 -> Run.volumeFrequency- 105 -> Run.volumeFrequencyCausal- 200 -> Run.keyboard- 201 -> Run.keyboardMulti- 202 -> Run.keyboardStereo- 203 -> Run.keyboardPitchbend- 204 -> Run.keyboardFM- 205 -> Run.keyboardDetuneFM- 206 -> Run.keyboardFilter- 207 -> Run.keyboardSample- 208 -> Run.keyboardVariousStereo- 209 -> Run.keyboardSampleTFM- 210 -> Run.keyboardNoisyTone- 211 -> Run.keyboardFilteredNoisyTone- 300 -> Run.keyboardCausal- _ -> error "not implemented server part"
− src/Synthesizer/Storable/ALSA/Server/Common.hs
@@ -1,98 +0,0 @@-module Synthesizer.Storable.ALSA.Server.Common where--import qualified Sound.ALSA.PCM as ALSA-import qualified Sound.ALSA.Sequencer.Event as Event-import qualified Synthesizer.Storable.ALSA.Play as Play--import qualified Synthesizer.EventList.ALSA.MIDI as MIDIEv-import Synthesizer.EventList.ALSA.MIDI (Channel, StrictTime, )--import qualified Synthesizer.Storable.Signal as SigSt-import qualified Data.StorableVector.Lazy as SVL--import qualified Synthesizer.Generic.Signal as SigG--import qualified Sound.MIDI.Message.Channel as ChannelMsg--import qualified Data.EventList.Relative.TimeBody as EventList--import qualified Sound.Sox.Frame as SoxFrame-import qualified System.Exit as Exit--import Control.Category ((.), )--import qualified Algebra.RealField as RealField-import qualified Algebra.Field as Field-import qualified Algebra.Ring as Ring-import qualified Algebra.ToInteger as ToInteger-import qualified Algebra.Additive as Additive--import NumericPrelude.Numeric (zero, round, )-import Prelude hiding (Real, round, break, id, (.), )---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--periodTime :: Field.C t => t-periodTime =- let (SVL.ChunkSize size) = chunkSize- in ToInteger.fromIntegral size Field./ Ring.fromInteger sampleRate--device :: Play.Device-device = Play.defaultDevice--clientName :: MIDIEv.ClientName-clientName = MIDIEv.ClientName "Haskell-Synthesizer"---type Real = Float---{-# INLINE withMIDIEvents #-}-withMIDIEvents ::- (Double -> Double -> a -> IO b) ->- (EventList.T StrictTime [Event.T] -> a) -> IO b-withMIDIEvents action proc =- let rate = sampleRate- per = periodTime- in MIDIEv.withMIDIEvents clientName per rate $- action per rate . proc---{-# INLINE play #-}-play ::- (RealField.C t, Additive.C y, ALSA.SampleFmt y) =>- t -> t -> SigSt.T y -> IO ()-play period rate =- Play.auto (Play.makeSink device period (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 -> t -> SigSt.T y -> IO Exit.ExitCode-playAndRecord fileName period rate =- Play.autoAndRecord fileName (Play.makeSink device period (round rate)) .- SigSt.append (SigSt.replicate chunkSize latency zero)
− src/Synthesizer/Storable/ALSA/Server/Instrument.hs
@@ -1,486 +0,0 @@-module Synthesizer.Storable.ALSA.Server.Instrument where--import Synthesizer.Storable.ALSA.Server.Common--import Synthesizer.Storable.ALSA.MIDI (- Instrument, chunkSizesFromLazyTime, )--import Synthesizer.EventList.ALSA.MIDI (LazyTime, )--import qualified Synthesizer.CausalIO.ALSA.Process as PAlsa-import qualified Synthesizer.CausalIO.Gate as Gate-import qualified Synthesizer.CausalIO.Process as PIO--import qualified Synthesizer.Basic.Wave as Wave-import qualified Synthesizer.Frame.Stereo as Stereo--import qualified Synthesizer.Causal.Process as Causal-import qualified Synthesizer.Causal.Oscillator as OsciC-import qualified Synthesizer.Causal.Interpolation as Interpolation-import qualified Synthesizer.Causal.Filter.Recursive.Integration as IntegC-import qualified Synthesizer.Causal.Filter.NonRecursive as FiltNRC-import qualified Synthesizer.Interpolation.Module as Ip-import Control.Arrow ((<<<), (^<<), (<<^), (***), )--import qualified Synthesizer.Storable.Filter.NonRecursive as FiltNRSt-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 as SV--import qualified Synthesizer.Generic.Wave as WaveG-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.Sox.Read as SoxRead-import qualified Sound.Sox.Option.Format as SoxOption--import Control.Monad.Trans.State (get, modify, )-import Control.Monad (mzero, )-import Control.Category ((.), )--import NumericPrelude.Numeric (zero, round, (*>), )-import Prelude hiding (Real, round, break, id, (.), )----{-# INLINE amplitudeFromVelocity #-}-amplitudeFromVelocity :: Real -> Real-amplitudeFromVelocity vel = 4**vel--{-# INLINE ping #-}-ping :: Real -> Real -> SigSt.T Real-ping vel freq =- SigS.toStorableSignal chunkSize $- FiltNRS.envelope (CtrlS.exponential2 (0.2*sampleRate) (amplitudeFromVelocity vel)) $- OsciS.static Wave.saw zero (freq/sampleRate)--pingDur :: Instrument Real Real-pingDur vel freq dur =- SigStV.take (chunkSizesFromLazyTime dur) $- ping vel freq--pingCausal :: PAlsa.Instrument Real (SV.Vector Real)-pingCausal vel freq =- (PIO.fromCausal $- Causal.applyStorableChunk $- Causal.feed $- FiltNRS.envelope- (CtrlS.exponential2 (0.2*sampleRate) (amplitudeFromVelocity vel)) $- OsciS.static Wave.saw zero (freq/sampleRate))- <<<- Gate.toStorableVector--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)--pingReleaseEnvelopeCausal :: Real -> PIO.T PAlsa.GateChunk (SV.Vector Real)-pingReleaseEnvelopeCausal vel =- PIO.continue- ((PIO.fromCausal $- Causal.applyStorableChunk $ Causal.feed $- CtrlS.exponential2 (0.4*sampleRate) (amplitudeFromVelocity vel))- <<<- Gate.toStorableVector- {-- <<<- arr (\x -> trace (show x) x) -})- (\y -> -- trace ("continue with " ++ show y) $- (PIO.fromCausal $- Causal.applyStorableChunk $ Causal.feed $- SigS.take (round (1*sampleRate :: Real)) $- CtrlS.exponential2 (0.1*sampleRate) y)- <<<- Gate.allToStorableVector)--pingReleaseCausal :: PAlsa.Instrument Real (SV.Vector Real)-pingReleaseCausal vel freq =- (PIO.fromCausal $- Causal.applyStorableChunk $- FiltNRC.envelope <<<- Causal.feedFst (OsciS.static Wave.saw zero (freq/sampleRate)))- <<<- pingReleaseEnvelopeCausal vel--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) $- 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))---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)--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)--{-# 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)))----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---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---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--{--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
− src/Synthesizer/Storable/ALSA/Server/Run.hs
@@ -1,330 +0,0 @@-module Synthesizer.Storable.ALSA.Server.Run where--import qualified Synthesizer.Storable.ALSA.Server.Instrument as Instr-import Synthesizer.Storable.ALSA.Server.Common- (Real, withMIDIEvents, play, device, clientName,- sampleRate, lazySize, chunkSize, periodTime, channel, )--import qualified Synthesizer.Storable.ALSA.MIDI as AlsaSt-import Synthesizer.Storable.ALSA.MIDI (applyModulation, )--import qualified Synthesizer.CausalIO.ALSA.Process as PAlsa-import qualified Synthesizer.CausalIO.Process as PIO--import qualified Synthesizer.Causal.Oscillator as OsciC-import qualified Synthesizer.Causal.Process as Causal-import qualified Synthesizer.Causal.Filter.NonRecursive as FiltNRC--import qualified Synthesizer.Basic.Wave as Wave--import qualified Synthesizer.Interpolation.Module as Ip--import qualified Synthesizer.Storable.Oscillator as OsciSt-import qualified Synthesizer.Storable.Signal as SigSt-import qualified Data.StorableVector.Lazy as SVL-import qualified Data.StorableVector as SV-import Foreign.Storable (Storable, )--import qualified Synthesizer.Generic.Loop as LoopG-import qualified Synthesizer.Generic.Signal as SigG-import qualified Synthesizer.State.Signal as SigS-import qualified Synthesizer.Plain.Filter.Recursive as FiltR-import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter--import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg--import Control.Monad.Trans.State (evalState, )-import Control.Category ((.), )-import Control.Arrow (arr, second, (&&&), )--import Data.Tuple.HT (mapSnd, )--import NumericPrelude.Numeric (zero, (*>), (^?), )-import Prelude hiding (Real, round, break, id, (.), )----volume :: IO ()-volume =- putStrLn "run 'aconnect' to connect to the MIDI controller" >>- (withMIDIEvents play $- SigSt.zipWith (*)- (OsciSt.static chunkSize Wave.sine zero (800/sampleRate)) .- evalState (AlsaSt.controllerLinear channel VoiceMsg.mainVolume (0,1) (0.2::Real)))--frequency :: IO ()-frequency =- withMIDIEvents play $- OsciSt.freqMod chunkSize Wave.sine zero .- evalState (AlsaSt.controllerExponential channel VoiceMsg.modulation- (400/sampleRate, 1600/sampleRate) (800/sampleRate::Real))---{-# INLINE storableChunk #-}-storableChunk ::- (SigG.Read sig a, Storable a) =>- sig a -> SV.Vector a-storableChunk chunk =- SigS.toStrictStorableSignal (SigG.length chunk) $- SigG.toState chunk--frequencyCausal :: IO ()-frequencyCausal =- PAlsa.playFromEvents device clientName 0.01 (periodTime::Double) sampleRate- ((PIO.fromCausal $- Causal.applyStorableChunk $- OsciC.freqMod (fmap (0.99*) Wave.sine) zero)- .- arr storableChunk- .- (PAlsa.controllerExponential channel VoiceMsg.modulation- (400/sampleRate, 1600/sampleRate) (800/sampleRate::Real)))---pitchBend :: IO ()-pitchBend =- withMIDIEvents play $- OsciSt.freqMod chunkSize Wave.sine zero .- evalState (AlsaSt.pitchBend channel 2 (880/sampleRate::Real))--volumeFrequency :: IO ()-volumeFrequency =- putStrLn "run 'aconnect' to connect to the MIDI controller" >>- (withMIDIEvents play $- evalState (do- vol <- AlsaSt.controllerLinear channel VoiceMsg.mainVolume (0,1) 0.5- freq <- AlsaSt.pitchBend channel 2 (880/sampleRate::Real)- return $- SigSt.zipWith (*) vol- (OsciSt.freqMod chunkSize Wave.sine zero freq)))--volumeFrequencyCausal :: IO ()-volumeFrequencyCausal =- PAlsa.playFromEvents device clientName 0.01 (periodTime::Double) sampleRate- ((PIO.fromCausal $- Causal.applyStorableChunk $- FiltNRC.envelope- .- second (OsciC.freqMod Wave.sine zero))- .- arr (uncurry (SV.zipWith (,)))- .- (arr storableChunk- .- PAlsa.controllerLinear channel VoiceMsg.mainVolume (0,0.99) (0.5::Real)- &&&- arr storableChunk- .- PAlsa.pitchBend channel 2 (880/sampleRate::Real)))---keyboard :: IO ()-keyboard =- withMIDIEvents play $--- playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate::Real) .- SigSt.map (0.2*) .- evalState (AlsaSt.sequence chunkSize channel Instr.tine)--keyboardMulti :: IO ()-keyboardMulti =- withMIDIEvents play $--- playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate::Real) .- SigSt.map (0.2*) .- evalState (AlsaSt.sequenceMultiProgram chunkSize channel- (VoiceMsg.toProgram 2)- [Instr.pingDur, Instr.pingRelease, Instr.tine])--keyboardStereo :: IO ()-keyboardStereo =- withMIDIEvents play $--- playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate::Real) .- SigSt.map ((0.2::Real)*>) .- evalState (AlsaSt.sequenceMultiProgram chunkSize channel- (VoiceMsg.toProgram 1)- [Instr.pingStereoRelease, Instr.tineStereo,- Instr.softString, Instr.softStringCausal])--keyboardPitchbend :: IO ()-keyboardPitchbend =- withMIDIEvents play $- SigSt.map ((0.2::Real)*>) .- evalState- (do bend <- AlsaSt.pitchBend channel (2^?(2/12)) 1- AlsaSt.sequenceModulated chunkSize bend channel Instr.stringStereoFM)--keyboardFM :: IO ()-keyboardFM =- withMIDIEvents play $- SigSt.map ((0.2::Real)*>) .- evalState- (do fm <- AlsaSt.bendWheelPressure channel- 2 (10/sampleRate) 0.04 0.03- AlsaSt.sequenceModulated chunkSize fm channel Instr.stringStereoFM)--keyboardDetuneFM :: IO ()-keyboardDetuneFM =- withMIDIEvents play $- SigSt.map ((0.2::Real)*>) .- evalState- (do fm <- AlsaSt.bendWheelPressure channel- 2 (10/sampleRate) 0.04 0.03- detune <- AlsaSt.controllerLinear channel- VoiceMsg.vectorX (0,0.005) 0- AlsaSt.sequenceMultiModulated- chunkSize channel Instr.stringStereoDetuneFM- (applyModulation fm .- applyModulation detune))---keyboardFilter :: IO ()-keyboardFilter =- withMIDIEvents play $- SigSt.map (0.2*) .- evalState- (do music <- AlsaSt.sequence chunkSize channel Instr.pingRelease- freq <- AlsaSt.controllerLinear channel- -- VoiceMsg.vectorY- (VoiceMsg.toController 21)- (100/sampleRate, 5000/sampleRate)- (700/sampleRate)- return $- SigS.toStorableSignal chunkSize $- SigS.map UniFilter.lowpass $- SigS.modifyModulated- UniFilter.modifier- (SigS.map UniFilter.parameter $- SigS.zipWith FiltR.Pole- (SigS.repeat (5 :: Real))- (SigS.fromStorableSignal freq)) $- SigS.fromStorableSignal music)---keyboardSample :: IO ()-keyboardSample =- do piano <- Instr.readPianoSample- string <- Instr.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 (AlsaSt.sequenceMultiProgram chunkSize channel- (VoiceMsg.toProgram 5) $- Instr.sampledSound piano :- Instr.sampledSound string :- Instr.sampledSound loopedString :- Instr.sampledSound fadedString :- Instr.sampledSound timeSineString :- Instr.sampledSound timeZigZagString :- Instr.sampledSoundTimeLoop Instr.loopTimeModSine string 8750 500 :- Instr.sampledSoundTimeLoop Instr.loopTimeModZigZag string 8750 500 :- [])---keyboardVariousStereo :: IO ()-keyboardVariousStereo =- do piano <- Instr.readPianoSample- string <- Instr.readStringSample- let loopedString =- LoopG.timeReverse lazySize Ip.linear Ip.linear- LoopG.timeControlZigZag 8750 500 string- withMIDIEvents play $- SigSt.map ((0.2::Real)*>) .- evalState (AlsaSt.sequenceMultiProgram chunkSize channel- (VoiceMsg.toProgram 0) $- Instr.pingStereoRelease :- Instr.tineStereo :- Instr.softString :- Instr.sampledSoundDetuneStereo 0.001 piano :- Instr.sampledSoundDetuneStereo 0.002 loopedString :- Instr.sampledSoundDetuneStereoRelease 0.1 0.001 piano :- Instr.sampledSoundDetuneStereoRelease 0.3 0.002 loopedString :- [])---keyboardSampleTFM :: IO ()-keyboardSampleTFM =- do instr <- Instr.readPianoSample- withMIDIEvents play $- evalState- (do fm <- AlsaSt.bendWheelPressure channel- 2 (10/sampleRate) 0.04 0.03- speed <- AlsaSt.controllerLinear channel- (VoiceMsg.toController 22)- (0,2) 1- offset <- AlsaSt.controllerLinear channel- (VoiceMsg.toController 21)- (0, fromIntegral (SVL.length (snd instr))) 0- AlsaSt.sequenceMultiModulated- chunkSize channel (Instr.timeModulatedSample instr)- (applyModulation fm .- applyModulation speed .- applyModulation offset))---keyboardNoisePipe :: IO ()-keyboardNoisePipe =- withMIDIEvents play $- evalState- (do fm <- AlsaSt.bendWheelPressure channel- 2 (10/sampleRate) 0.04 0.03- resonance <-- AlsaSt.controllerExponential channel- (VoiceMsg.toController 23)- (1, 100) 10- AlsaSt.sequenceMultiModulated- chunkSize channel Instr.colourNoise- (applyModulation fm .- applyModulation resonance))---keyboardNoisyTone :: IO ()-keyboardNoisyTone =- withMIDIEvents play $- evalState- (do fm <- AlsaSt.bendWheelPressure channel- 2 (10/sampleRate) 0.04 0.03- speed <- AlsaSt.controllerLinear channel- (VoiceMsg.toController 21)- (0,0.5) 0.1- AlsaSt.sequenceMultiModulated- chunkSize channel Instr.toneFromNoise- (applyModulation fm .- applyModulation speed))---keyboardFilteredNoisyTone :: IO ()-keyboardFilteredNoisyTone =- withMIDIEvents play $- evalState- (do fm <- AlsaSt.bendWheelPressure channel- 2 (10/sampleRate) 0.04 0.03- {-- speed must never be zero,- since this requires to fetch unlimited data from future.- -}- speed <- AlsaSt.controllerLinear channel- (VoiceMsg.toController 21)- (0.05,0.5) 0.1- cutoff <- AlsaSt.controllerExponential channel- (VoiceMsg.toController 22)- (1, 30) 10- resonance <- AlsaSt.controllerExponential channel- (VoiceMsg.toController 23)- (1, 20) 5- AlsaSt.sequenceMultiModulated- chunkSize channel Instr.toneFromFilteredNoise- (applyModulation fm .- applyModulation speed .- applyModulation cutoff .- applyModulation resonance))----keyboardCausal :: IO ()-keyboardCausal =- PAlsa.playFromEvents device clientName 0.01 (periodTime::Double) sampleRate $- arr (SV.map (0.2*))- .- PAlsa.sequenceStorable channel (\ _pgm -> Instr.pingReleaseCausal)
− src/Synthesizer/Storable/ALSA/Server/Test.hs
@@ -1,602 +0,0 @@-module Synthesizer.Storable.ALSA.Server.Test where--import qualified Synthesizer.Storable.ALSA.Server.Instrument as Instr-import Synthesizer.Storable.ALSA.Server.Common- (Real, withMIDIEvents, play,- sampleRate, chunkSize, channel, )--import qualified Sound.ALSA.Sequencer.Address as Addr-import qualified Sound.ALSA.Sequencer.Client as Client-import qualified Sound.ALSA.Sequencer.Port as Port-import qualified Sound.ALSA.Sequencer.Queue as Queue-import qualified Sound.ALSA.Sequencer.RealTime as RealTime-import qualified Sound.ALSA.Sequencer.Event as Event--import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC-import qualified Synthesizer.Generic.ALSA.MIDI as Gen-import qualified Synthesizer.Storable.ALSA.MIDI as AlsaSt-import Synthesizer.Storable.ALSA.MIDI (- Instrument, chunkSizesFromLazyTime, )--import qualified Synthesizer.EventList.ALSA.MIDI as MIDIEv-import Synthesizer.EventList.ALSA.MIDI (- LazyTime, StrictTime, Note(..), NoteBoundary(..),- matchNoteEvents, getSlice, getControllerEvents, )--import qualified Synthesizer.Basic.Wave as Wave--import qualified Synthesizer.Causal.Process as Causal-import Control.Arrow ((<<<), )--import qualified Synthesizer.Storable.Cut as CutSt-import qualified Synthesizer.Storable.Oscillator as OsciSt-import qualified Synthesizer.Storable.Signal as SigSt--- import qualified Data.StorableVector.Lazy.Builder as Bld-import qualified Data.StorableVector.Lazy.Pattern as SigStV-import qualified Data.StorableVector.Lazy as SVL-import qualified Data.StorableVector as SV--import qualified Synthesizer.State.Signal as SigS--import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg--import qualified Data.EventList.Relative.TimeBody as EventList-import qualified Data.EventList.Relative.BodyTime as EventListBT-import Data.EventList.Relative.MixedBody ((/.), (./), )--import qualified Control.Monad.Trans.State.Strict as MS-import Control.Monad.Trans.State (evalState, gets, )-import Control.Category ((.), )--import Data.Traversable (traverse, )---- import qualified Numeric.NonNegative.Class as NonNeg-import qualified Numeric.NonNegative.Wrapper as NonNegW-import qualified Numeric.NonNegative.Chunky as NonNegChunky--import Data.Maybe.HT (toMaybe, )--import NumericPrelude.Numeric (zero, round, (^?), )-import Prelude hiding (Real, round, break, id, (.), )---import Data.Word (Word8, )---frequency1 :: IO ()-frequency1 =- withMIDIEvents play $- const- (OsciSt.static chunkSize Wave.sine zero (800/sampleRate::Real))--frequency2 :: IO ()-frequency2 =- withMIDIEvents (const $ const print) $- evalState (getControllerEvents channel VoiceMsg.mainVolume)--frequency3 :: IO ()-frequency3 =- withMIDIEvents (const $ const print) $- evalState (getSlice Just)---keyboard1 :: IO ()-keyboard1 =- withMIDIEvents play $- const (Instr.ping 0 440)--keyboard2 :: SigSt.T Real-keyboard2 =- let music :: Real -> EventList.T StrictTime (SigSt.T Real)- music x = 5 /. SigSt.replicate chunkSize 6 x ./ music (x+1)- in CutSt.arrange chunkSize $- EventList.mapTime fromIntegral $ music 42--keyboard3 :: SigSt.T Real-keyboard3 =- let time :: Real -> Int- time t = round (t * sampleRate)- music :: Real -> EventList.T StrictTime (SigSt.T Real)- music x =- fromIntegral (time 0.2) /.- SigSt.take (time 0.4) (Instr.ping 0 x) ./- music (x*1.01)- in CutSt.arrange chunkSize $- EventList.mapTime fromIntegral $ music 110--makeLazyTime :: Real -> LazyTime-makeLazyTime t =- NonNegChunky.fromNumber $- NonNegW.fromNumberMsg "keyboard time" $- round (t * sampleRate)--makeStrictTime :: Real -> StrictTime-makeStrictTime t =- NonNegW.fromNumberMsg "keyboard time" $- round (t * sampleRate)--normalVelocity :: VoiceMsg.Velocity-normalVelocity =- VoiceMsg.toVelocity VoiceMsg.normalVelocity--pitch :: Int -> VoiceMsg.Pitch-pitch = VoiceMsg.toPitch--defaultProgram :: VoiceMsg.Program-defaultProgram = VoiceMsg.toProgram 0--embedDefaultProgram ::- EventList.T StrictTime [NoteBoundary Bool] ->- EventList.T StrictTime [NoteBoundary (Maybe VoiceMsg.Program)]-embedDefaultProgram =- fmap (fmap (\(NoteBoundary p v b) ->- NoteBoundary p v (toMaybe b defaultProgram)))--keyboard4 :: SigSt.T Real-keyboard4 =- let {-- idInstr :: Real -> Real -> SigSt.T Real- idInstr _vel freq = SigSt.repeat chunkSize freq- -}--- inf = time 0.4 + inf- music :: Int -> EventList.T StrictTime Note- music p =- makeStrictTime 0.2 /.--- (pitch p, normalVelocity, inf) ./- Note defaultProgram (pitch p) normalVelocity (makeLazyTime 0.4) ./- music (p+1)- in CutSt.arrange chunkSize $- EventList.mapTime fromIntegral $- fmap (Gen.renderInstrumentIgnoreProgram Instr.pingDur) $- music 0---notes0 :: Int -> EventList.T StrictTime (NoteBoundary Bool)-notes0 p =- makeStrictTime 0.2 /.- (let (oct,pc) = divMod p 12- in (NoteBoundary (pitch (50 + pc)) normalVelocity (even oct)))- ./- notes0 (p+1)--notes1 :: EventList.T StrictTime (NoteBoundary Bool)-notes1 =- makeStrictTime 0.2 /.- (NoteBoundary (pitch 50) normalVelocity True) ./- makeStrictTime 0.2 /.- (NoteBoundary (pitch 52) normalVelocity True) ./- makeStrictTime 0.2 /.- (NoteBoundary (pitch 54) normalVelocity True) ./- makeStrictTime 0.2 /.--- (NoteBoundary (pitch 50) normalVelocity False) ./- undefined--notes2 :: EventList.T StrictTime [NoteBoundary Bool]-notes2 =- makeStrictTime 0.2 /.- [] ./- makeStrictTime 0.2 /.- [] ./- makeStrictTime 0.2 /.- [NoteBoundary (pitch 50) normalVelocity True] ./- makeStrictTime 0.2 /.- [NoteBoundary (pitch 52) normalVelocity True] ./- makeStrictTime 0.2 /.- [NoteBoundary (pitch 54) normalVelocity True] ./- makeStrictTime 0.2 /.- [NoteBoundary (pitch 50) normalVelocity False] ./- undefined--notes3 :: EventList.T StrictTime [NoteBoundary (Maybe VoiceMsg.Program)]-notes3 =- embedDefaultProgram $- notes2--keyboard5 :: SigSt.T Real-keyboard5 =- CutSt.arrange chunkSize $- EventList.mapTime fromIntegral $- Gen.flatten $- fmap (map (Gen.renderInstrumentIgnoreProgram Instr.pingDur)) $- matchNoteEvents $- notes3--keyboard6 :: EventList.T StrictTime [Note]-keyboard6 =- matchNoteEvents $- embedDefaultProgram $- fmap (:[]) $- notes1--keyboard7 :: EventList.T StrictTime [(VoiceMsg.Pitch, VoiceMsg.Velocity)]-keyboard7 =- fmap (map (\ ~(Note _ p v _d) -> (p,v))) $- keyboard6--arrangeSpaceLeak0 :: IO ()-arrangeSpaceLeak0 =- SVL.writeFile "test.f32" $- CutSt.arrange chunkSize $- evalState (Gen.sequence channel- (error "no sound" :: Instrument Real Real)) $- let evs = EventList.cons 10 [] evs- in evs--arrangeSpaceLeak1 :: IO ()-arrangeSpaceLeak1 =- SVL.writeFile "test.f32" $- CutSt.arrange chunkSize $- evalState- (Gen.sequenceModulated- (SigSt.iterate chunkSize (1+) 0) channel- (error "no sound" :: SigSt.T Real -> Instrument Real Real)) $- let evs = EventList.cons 10 [] evs- in evs--makeNote :: Event.NoteEv -> Word8 -> Event.T-makeNote typ pit =- Event.Cons- { Event.highPriority = False- , Event.tag = 0- , Event.queue = Queue.direct- , Event.timestamp =- Event.RealTime $ RealTime.fromInteger 0- , Event.source = Addr.Cons {- Addr.client = Client.subscribers,- Addr.port = Port.unknown- }- , Event.dest = Addr.Cons {- Addr.client = Client.subscribers,- Addr.port = Port.unknown- }- , Event.body =- Event.NoteEv typ- (Event.simpleNote 0 pit 64)- }--{--a space leak can only be observed for more than one note,-maybe our 'break' improvement fixed the case for one played note--}-arrangeSpaceLeak3 :: IO ()-arrangeSpaceLeak3 =- SVL.writeFile "test.f32" $- CutSt.arrange chunkSize $- evalState- (Gen.sequenceModulated- (SigSt.iterate chunkSize (1e-7 +) 1) channel- Instr.stringStereoFM) $--- (const Instr.pingDur :: SigSt.T Real -> Instrument Real Real)) $- let evs t = EventList.cons t [] (evs (20-t))- in -- EventList.cons 10 [makeNote MIDI.NoteOn 60] $- -- EventList.cons 10 [makeNote MIDI.NoteOn 64] $- evs 10--arrangeSpaceLeak4 :: IO ()-arrangeSpaceLeak4 =- SVL.writeFile "test.f32" $- evalState- (do bend <- AlsaSt.pitchBend channel (2^?(2/12)) 1- AlsaSt.sequenceModulated chunkSize bend channel Instr.stringStereoFM) $- let evs t = EventList.cons t [] (evs (20-t))- in evs 10--chordSpaceLeak1 :: IO ()-chordSpaceLeak1 =- SVL.writeFile "test.f32" $- CutSt.arrange chunkSize $- evalState (Gen.sequence channel Instr.pingDur) $- let evs t = EventList.cons t [] (evs (20-t))- in EventList.cons 10 [makeNote Event.NoteOn 60] $- EventList.cons 10 [makeNote Event.NoteOn 64] $- evs 10---sequencePitchBend :: IO ()-sequencePitchBend =- SVL.writeFile "test.f32" $- CutSt.arrange chunkSize $- evalState- (let fm y = (EventListBT.cons $! y) 10 (fm (2-y))- in Gen.sequenceModulated (fm 1) channel- (error "no sound" ::- PC.T Real -> Instrument Real Real)) $- let evs = EventList.cons 10 [] evs- in evs--sequencePitchBend1 :: IO ()-sequencePitchBend1 =- SVL.writeFile "test.f32" $- CutSt.arrange chunkSize $- evalState- (let fm y = EventListBT.cons y 10 (fm (2-y))- instr :: PC.T Real -> Instrument Real Real- instr = error "no sound"- in Gen.sequenceCore- channel Gen.errorNoProgram- (Gen.Modulator (fm 1) Gen.advanceModulationChunk- (\note -> gets $ \c ->- Gen.renderInstrumentIgnoreProgram (instr c) note))) $- let evs = EventList.cons 10 [] evs- in evs--sequencePitchBend2 :: IO ()-sequencePitchBend2 =- SVL.writeFile "test.f32" $- let fm y = EventListBT.cons y 10 (fm (2-y))- -- fm = EventListBT.cons 1 10 fm- instr :: PC.T Real -> Instrument Real Real- instr = error "no sound"- evs = EventList.cons 10 [] evs- md =- Gen.Modulator- (fm 1)- Gen.advanceModulationChunkPC- -- Gen.advanceModulationChunk- (\note -> gets $ \c ->- Gen.renderInstrumentIgnoreProgram (instr c) note)- in CutSt.arrange chunkSize .- EventList.mapTime fromIntegral .- Gen.flatten .- Gen.applyModulator md $- evs--sequencePitchBend3 :: IO ()-sequencePitchBend3 =- SVL.writeFile "test.f32" $- let fm y = EventListBT.cons y 10 (fm (2-y))- -- fm = EventListBT.cons 1 10 fm- instr :: PC.T Real -> Instrument Real Real- instr = error "no sound"- evs = EventList.cons 10 [] evs- modEvent note =- gets $ \c ->- Gen.renderInstrumentIgnoreProgram (instr c) note- in CutSt.arrange chunkSize .- EventList.mapTime fromIntegral .- Gen.flatten .- flip evalState (fm 1) .- EventList.traverse- Gen.advanceModulationChunk- (traverse modEvent) $- evs--sequencePitchBend4 :: IO ()-sequencePitchBend4 =- SVL.writeFile "test.f32" $- let fm y = y : fm (2-y)- -- fm = repeat 1- instr :: [Real] -> Instrument Real Real- instr = error "no sound"- evs = EventList.cons 10 [] evs- modEvent note =- gets $ \c ->- Gen.renderInstrumentIgnoreProgram (instr c) note- in CutSt.arrange chunkSize .- EventList.mapTime fromIntegral .- Gen.flatten .- flip evalState (fm 1) .- EventList.traverse- Gen.advanceModulationChunk- (traverse modEvent) $- evs--sequencePitchBend4a :: IO ()-sequencePitchBend4a =- SVL.writeFile "test.f32" $- let fm y = y : fm (2-y)- -- fm = repeat 1- instr :: [Real] -> Instrument Real Real- instr = error "no sound"- evs = EventList.cons 10 [] evs- modEvent note =- MS.gets $ \c ->- Gen.renderInstrumentIgnoreProgram (instr c) note- in CutSt.arrange chunkSize .- EventList.mapTime fromIntegral .- Gen.flatten .- flip MS.evalState (fm 1) .- EventList.traverse- Gen.advanceModulationChunkStrict- (traverse modEvent) $- evs--sequencePitchBend4b :: IO ()-sequencePitchBend4b =- SVL.writeFile "test.f32" $- let fm y = y : fm (2-y)- -- fm = repeat 1- instr :: [Real] -> Instrument Real Real- instr = error "no sound"- evs = EventList.cons 10 [] evs- in CutSt.arrange chunkSize .- Gen.flatten $- EventList.foldrPair- (\t bs0 go s0 ->- let s1 = tail s0- bs1 =- map (Gen.renderInstrumentIgnoreProgram (instr s1)) bs0- in EventList.cons- (if null s1 then t else t) bs1 $- go s1)- (const EventList.empty) evs (fm 1)--sequencePitchBend4c :: IO ()-sequencePitchBend4c =- SVL.writeFile "test.f32" $- let fm y = y : fm (2-y)- -- fm = repeat 1- instr :: [Real] -> Instrument Real Real- instr = error "no sound"- in CutSt.arrange chunkSize .- Gen.flatten .- EventList.fromPairList $- foldr- (\(t,bs0) go s0 ->- let s1 = tail s0- bs1 =- map (Gen.renderInstrumentIgnoreProgram (instr s1)) bs0- in (if null s1 then t else t, bs1) :- go s1)- (const [])- (repeat (10,[]))- (fm 1)--sequencePitchBend4d :: IO ()-sequencePitchBend4d =- SVL.writeFile "test.f32" $- let fm y = y : fm (2-y)- -- fm = repeat 1- in CutSt.arrange chunkSize .- EventList.fromPairList $- foldr- (\(t,b) go s0 ->- let s1 = tail s0- in (if null s1 then t else t,- if null s1 then b else b) :- go s1)- (const [])- (repeat (10, SigSt.empty :: SigSt.T Real))- (fm 1 :: [Real])--sequencePitchBend4e :: IO ()-sequencePitchBend4e =- writeFile "test.txt" $- foldr- (\c go s0 ->- let s1 = tail s0- in (if null s1 then c else c) :- go s1)- (const [])- (repeat 'a')- (iterate not False)- -- (repeat True)--sequencePitchBend5 :: IO ()-sequencePitchBend5 =- SVL.writeFile "test.f32" $- let fm y = SigSt.iterate (SVL.ChunkSize 1) (y+) 0- instr :: SigSt.T Real -> Instrument Real Real- instr = error "no sound"- evs = EventList.cons 10 [] evs- modEvent note =- gets $ \c ->- Gen.renderInstrumentIgnoreProgram (instr c) note- in CutSt.arrange chunkSize .- EventList.mapTime fromIntegral .- Gen.flatten .- flip evalState (fm 1e-6) .- EventList.traverse- Gen.advanceModulationChunk- (traverse modEvent) $- evs--dummySound :: Instrument Real Real-dummySound =- \vel freq dur ->- SigStV.take (chunkSizesFromLazyTime dur) $- SigSt.repeat chunkSize (vel + 1e-3*freq)--sequenceStaccato :: IO ()-sequenceStaccato =- SVL.writeFile "test.f32" $- let evs t =- EventList.cons t [Right $ NoteBoundary (pitch 60) normalVelocity True] $- EventList.cons t [Right $ NoteBoundary (pitch 60) normalVelocity False] $- evs (20-t)- in CutSt.arrange chunkSize .- EventList.mapTime fromIntegral .- Gen.flatten .- EventList.mapBody- (map (Gen.renderInstrumentIgnoreProgram dummySound)) .- MIDIEv.matchNoteEvents .- MIDIEv.embedPrograms defaultProgram $- evs 10--sequenceStaccato3 :: IO ()-sequenceStaccato3 =- SVL.writeFile "test.f32" $- let evs t =- EventList.cons t [NoteBoundary (pitch 60) normalVelocity (Just defaultProgram)] $- EventList.cons t [NoteBoundary (pitch 60) normalVelocity Nothing] $- evs (20-t)- in CutSt.arrange chunkSize .- EventList.mapTime fromIntegral .- Gen.flatten .- EventList.mapBody- (map (Gen.renderInstrumentIgnoreProgram dummySound)) .- MIDIEv.matchNoteEvents $- evs 10--sequenceStaccato2 :: IO ()-sequenceStaccato2 =- SVL.writeFile "test.f32" $- let evs t =- EventList.cons t [makeNote Event.NoteOn 60] $- EventList.cons t [makeNote Event.NoteOff 60] $- evs (20-t)- in CutSt.arrange chunkSize .- EventList.mapTime fromIntegral .- Gen.flatten .- EventList.mapBody- (map (Gen.renderInstrumentIgnoreProgram dummySound)) .- MIDIEv.matchNoteEvents .- MIDIEv.embedPrograms defaultProgram .- evalState (MIDIEv.getNoteEvents channel) $- evs 10--sequenceStaccato1 :: IO ()-sequenceStaccato1 =- SVL.writeFile "test.f32" $- CutSt.arrange chunkSize $- evalState (Gen.sequence channel dummySound) $- let evs t =- EventList.cons t [makeNote Event.NoteOn 60] $- EventList.cons t [makeNote Event.NoteOff 60] $- evs (20-t)- in evs 10---speed :: IO ()-speed =- let _sig =- Causal.apply- (Instr.softStringCausalProcess 440 <<<- Instr.softStringReleaseEnvelopeCausalProcess 0)- (SigS.repeat True)- sig =- Causal.apply- (Instr.softStringCausalProcess 440)- (SigS.repeat 1)- in SV.writeFile "speed.f32" $- SigS.runViewL sig- (\next s -> fst $ SV.unfoldrN 1000000 next s)--speedChunky :: IO ()-speedChunky =- let sig =- Causal.apply- (Instr.softStringCausalProcess 440 <<<- Instr.softStringReleaseEnvelopeCausalProcess 0)- (SigS.repeat True)- in SVL.writeFile "speed.f32" $- SigSt.take 1000000 $- SigS.toStorableSignal (SVL.chunkSize 100) sig-{-- SigS.runViewL sig- (\next s -> SVL.take 1000000 (SVL.unfoldr (SVL.chunkSize 100) next s))--}--speedArrange :: IO ()-speedArrange =- let sig =- Causal.apply- (Instr.softStringCausalProcess 440 <<<- Instr.softStringReleaseEnvelopeCausalProcess 0)- (SigS.repeat True)- sigSt =- SigS.toStorableSignal (SVL.chunkSize 100) sig- in SVL.writeFile "speed.f32" $- SigSt.take 1000000 $- CutSt.arrangeEquidist (SVL.chunkSize 100) $- EventList.fromPairList [(10000,sigSt)]
− src/Test.hs
@@ -1,203 +0,0 @@-module Main where--import Synthesizer.Storable.ALSA.Server.Test (makeNote, )--import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC--import qualified Sound.ALSA.Sequencer.Event as Event-import qualified Synthesizer.Generic.ALSA.MIDI as Gen-import qualified Synthesizer.Storable.ALSA.Play as Play-import Synthesizer.Storable.ALSA.MIDI (- Instrument, chunkSizesFromLazyTime, )--import qualified Synthesizer.Basic.Wave as Wave-import qualified Synthesizer.Frame.Stereo as Stereo--import Foreign.Storable (Storable, )--import qualified Synthesizer.Storable.Cut as CutSt-import qualified Synthesizer.Storable.Signal as SigSt-import qualified Data.StorableVector.Lazy as SVL--import qualified Synthesizer.State.Signal as SigS-import qualified Synthesizer.State.Oscillator as OsciS-import qualified Synthesizer.State.Filter.NonRecursive as FiltNRS--import qualified Sound.MIDI.Message.Channel as ChannelMsg-import Sound.MIDI.Message.Channel (Channel, )--import qualified Data.EventList.Relative.TimeBody as EventList-import qualified Data.EventList.Relative.BodyTime as EventListBT--- import Data.EventList.Relative.MixedBody ((/.), (./), )--import Control.Monad.Trans.State (evalState, )-import Control.Monad (when, )--import qualified Algebra.Additive as Additive--import NumericPrelude.Numeric (zero, (^?), )-import Prelude hiding (Real, break, )---import qualified System.IO as IO----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--consNone ::- time ->- EventList.T time [body] ->- EventList.T time [body]-consNone t = EventList.cons t []--consSingle ::- time -> body ->- EventList.T time [body] ->- EventList.T time [body]-consSingle t b = EventList.cons t [b]---type Real = Float---evaluatePrefix ::- (Storable a, Additive.C a, Eq a) =>- SVL.Vector a -> Bool-evaluatePrefix =- (\x -> x==x) .- SVL.foldl' (Additive.+) zero .- SVL.take 100000---sequenceSpaceLeakEmpty :: Bool-sequenceSpaceLeakEmpty =- evaluatePrefix $- CutSt.arrange chunkSize $- evalState (Gen.sequence channel- (error "no sound" :: Instrument Real Real)) $- let evs = consNone 10 evs- in evs--sequenceSpaceLeakModulatedEmpty :: Bool-sequenceSpaceLeakModulatedEmpty =- evaluatePrefix $- CutSt.arrange chunkSize $- evalState- (Gen.sequenceModulated- (SigSt.iterate chunkSize (1+) 0) channel- (error "no sound" :: SigSt.T Real -> Instrument Real Real)) $- let evs = consNone 10 evs- in evs---sequenceSpaceLeakLazyDrop :: Bool-sequenceSpaceLeakLazyDrop =- evaluatePrefix $- CutSt.arrange chunkSize $- evalState- (let fm y = (EventListBT.cons $! y) 10 (fm (2-y))- in Gen.sequenceModulated (fm 1) channel- (error "no sound" ::- PC.T Real -> Instrument Real Real)) $- let evs = consNone 10 evs- in evs---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 (4^?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)---sequenceSpaceLeakModulatedInfinite :: Bool-sequenceSpaceLeakModulatedInfinite =- evaluatePrefix $- CutSt.arrange chunkSize $- evalState- (Gen.sequenceModulated- (SigSt.iterate chunkSize (1e-7 +) 1) channel- stringStereoFM) $- let evs t = consNone t (evs (20-t))- in consSingle 10 (makeNote Event.NoteOn 60) $- evs 10--sequenceSpaceLeakModulatedChordStep :: Bool-sequenceSpaceLeakModulatedChordStep =- evaluatePrefix $- CutSt.arrange chunkSize $- evalState- (Gen.sequenceModulated- (SigSt.iterate chunkSize (1e-7 +) 1) channel- stringStereoFM) $- let evs t = consNone t (evs (20-t))- in consSingle 10 (makeNote Event.NoteOn 60) $- consSingle 10 (makeNote Event.NoteOn 64) $- consSingle 10 (makeNote Event.NoteOn 67) $- evs 10--sequenceSpaceLeakModulatedChordSimultaneous :: Bool-sequenceSpaceLeakModulatedChordSimultaneous =- evaluatePrefix $- CutSt.arrange chunkSize $- evalState- (Gen.sequenceModulated- (SigSt.iterate chunkSize (1e-7 +) 1) channel- stringStereoFM) $- let evs t = EventList.cons t [] (evs (20-t))- in EventList.cons 10- [makeNote Event.NoteOn 60,- makeNote Event.NoteOn 64,- makeNote Event.NoteOn 67] $- evs 10--sequenceSpaceLeakStaccato :: Bool-sequenceSpaceLeakStaccato =- evaluatePrefix $- CutSt.arrange chunkSize $- evalState- (Gen.sequenceModulated- (SigSt.iterate chunkSize (1e-7 +) 1) channel- stringStereoFM) $- let evs t =- consSingle t (makeNote Event.NoteOn 60) $- consSingle t (makeNote Event.NoteOff 60) $- evs (20-t)- in evs 10---test :: String -> Bool -> IO ()-test name result = do- putStr name- IO.hFlush IO.stdout- when result (putStrLn " ok")--main :: IO ()-main = do- test "sequenceSpaceLeakEmpty" sequenceSpaceLeakEmpty- test "sequenceSpaceLeakModulatedEmpty" sequenceSpaceLeakModulatedEmpty- test "sequenceSpaceLeakLazyDrop" sequenceSpaceLeakLazyDrop- test "sequenceSpaceLeakModulatedInfinite" sequenceSpaceLeakModulatedInfinite- test "sequenceSpaceLeakModulatedChordStep" sequenceSpaceLeakModulatedChordStep- test "sequenceSpaceLeakModulatedChordSimultaneous" sequenceSpaceLeakModulatedChordSimultaneous- test "sequenceSpaceLeakStaccato" sequenceSpaceLeakStaccato
synthesizer-alsa.cabal view
@@ -1,5 +1,5 @@ Name: synthesizer-alsa-Version: 0.4+Version: 0.5 License: GPL License-File: LICENSE Author: Henning Thielemann <haskell@henning-thielemann.de>@@ -13,12 +13,13 @@ that can be used for audio effects. As demonstration there is a keyboard controlled music synthesizer. Stability: Experimental-Tested-With: GHC==6.4.1, GHC==6.8.2, GHC==6.10.4, GHC==6.12.3, GHC==7.0.4, GHC==7.2.1+Tested-With: GHC==6.4.1, GHC==6.8.2, GHC==6.10.4, GHC==6.12.3+Tested-With: GHC==7.0.4, GHC==7.2.1 Cabal-Version: >=1.6 Build-Type: Simple Source-Repository this- Tag: 0.4+ Tag: 0.5 Type: darcs Location: http://code.haskell.org/synthesizer/alsa/ @@ -37,37 +38,28 @@ description: Build example executables default: False -Flag buildTests- description: Build test executables- default: False- Library Build-Depends:- synthesizer-dimensional >=0.6 && <0.7,- synthesizer-core >=0.5 && <0.6,+ synthesizer-midi >=0.6 && <0.7,+ synthesizer-dimensional >=0.7 && <0.8,+ synthesizer-core >=0.6 && <0.7,+ midi-alsa >=0.2 && <0.3,+ midi >=0.2 && <0.3, sox >=0.2.1 && <0.3,- midi-alsa >=0.1.2 && <0.2,- alsa-seq >=0.5.1 && <0.6,- alsa-pcm >=0.5 && <0.6,+ alsa-seq >=0.6 && <0.7,+ alsa-pcm >=0.6 && <0.7, alsa-core >=0.5 && <0.6,- midi >=0.1.1 && <0.2,- storable-record >=0.0.2 && <0.1, storablevector >=0.2.5 && <0.3,- deepseq >=1.1 && <1.2,- numeric-prelude >=0.3 && <0.4,+ numeric-prelude >=0.3 && <0.5, non-negative >=0.1 && <0.2, event-list >=0.1 && <0.2,- data-accessor-transformers >=0.2.1 && <0.3,- data-accessor >=0.2.1 && <0.3,- containers >=0.1 && <0.5,- array >=0.1 && <0.4,- transformers >=0.2 && <0.3,+ transformers >=0.2 && <0.4, utility-ht >=0.0.1 && <0.1 If flag(splitBase) Build-Depends: random >= 1.0 && < 1.1,- old-time >= 1.0 && < 1.1,+ old-time >= 1.0 && < 1.2, base >= 3 && <5 Else Build-Depends:@@ -81,24 +73,10 @@ GHC-Options: -Wall Hs-source-dirs: src Exposed-modules:- Synthesizer.EventList.ALSA.MIDI- Synthesizer.Storable.ALSA.MIDI- Synthesizer.Storable.ALSA.Play- Synthesizer.PiecewiseConstant.ALSA.MIDI- Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet- Synthesizer.Generic.ALSA.MIDI- Synthesizer.Dimensional.ALSA.MIDI- Synthesizer.Dimensional.ALSA.Play- Synthesizer.CausalIO.ALSA.Process- Synthesizer.CausalIO.ALSA.MIDIControllerSet- Synthesizer.CausalIO.ALSA.MIDIControllerSelection- -- these modules would be better located in midi package,- -- but they are based on NumericPrelude- Synthesizer.MIDIValue- Synthesizer.MIDIValue.BendModulation- Synthesizer.MIDIValue.BendWheelPressure- Synthesizer.Dimensional.MIDIValue- Synthesizer.Dimensional.MIDIValuePlain+ Synthesizer.ALSA.EventList+ Synthesizer.ALSA.Storable.Play+ Synthesizer.ALSA.Dimensional.Play+ Synthesizer.ALSA.CausalIO.Process Executable realtimesynth If !flag(buildExamples)@@ -113,11 +91,10 @@ Extensions: CPP Hs-Source-Dirs: src Other-modules:- Synthesizer.Storable.ALSA.Server.Common- Synthesizer.Storable.ALSA.Server.Instrument- Synthesizer.Storable.ALSA.Server.Test- Synthesizer.Storable.ALSA.Server.Run- Main-Is: Synthesizer/Storable/ALSA/Server.hs+ Synthesizer.ALSA.Storable.Server.Common+ Synthesizer.ALSA.Storable.Server.Test+ Synthesizer.ALSA.Storable.Server.Run+ Main-Is: Synthesizer/ALSA/Storable/Server.hs Executable synthicate If !flag(buildExamples)@@ -132,22 +109,7 @@ Extensions: CPP Hs-Source-Dirs: src Other-modules:- Synthesizer.Dimensional.ALSA.Server.Common- Synthesizer.Dimensional.ALSA.Server.Instrument- Synthesizer.Dimensional.ALSA.Server.Test- Synthesizer.Dimensional.ALSA.Server.Run- Main-Is: Synthesizer/Dimensional/ALSA/Server.hs--Executable test- If !flag(buildTests)- Buildable: False- 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- If impl(ghc>=7.0)- GHC-Options: -fwarn-unused-do-bind- CPP-Options: -DNoImplicitPrelude=RebindableSyntax- Extensions: CPP- Hs-Source-Dirs: src- Main-Is: Test.hs+ Synthesizer.ALSA.Dimensional.Server.Common+ Synthesizer.ALSA.Dimensional.Server.Test+ Synthesizer.ALSA.Dimensional.Server.Run+ Main-Is: Synthesizer/ALSA/Dimensional/Server.hs