packages feed

synthesizer-alsa 0.1 → 0.3

raw patch · 24 files changed

+4161/−2177 lines, 24 filesdep +alsa-coredep +alsa-pcmdep +alsa-seqdep −alsadep ~arraydep ~basedep ~event-listnew-component:exe:test

Dependencies added: alsa-core, alsa-pcm, alsa-seq, containers, data-accessor, deepseq, midi-alsa

Dependencies removed: alsa

Dependency ranges changed: array, base, event-list, non-negative, numeric-prelude, sox, synthesizer-core, synthesizer-dimensional, transformers

Files

− src/RealTimeSynthesizer.hs 
@@ -1,989 +0,0 @@-module Main where--import qualified Sound.Alsa as ALSA-import qualified Sound.Alsa.Sequencer as MIDI-import qualified Synthesizer.Storable.ALSA.Play as Play-import Synthesizer.Storable.ALSA.MIDI (-   Instrument, makeInstrumentSounds,-   getNoteSignal, getNoteSignalMultiProgram, getNoteSignalModulated,-   getNoteSignalMultiModulated, applyModulation,-   getFMSignalFromBendWheelPressure, getPitchBendSignal,-   getControllerSignal, getControllerSignalExp,-   chunkSizesFromLazyTime, insertBreaks, )--import Synthesizer.EventList.ALSA.MIDI (-   Channel, LazyTime, StrictTime, Note(..), NoteBoundary(..),-   withMIDIEventsNonblock,-   matchNoteEvents, partitionMaybe,-   getSlice, getControllerEvents, )--import qualified Synthesizer.Basic.Wave          as Wave-import qualified Synthesizer.Frame.Stereo        as Stereo---- import Foreign.Storable (Storable, )--- import Data.Int (Int16, )--import qualified Synthesizer.Causal.Process as Causal-import qualified Synthesizer.Causal.Interpolation as Interpolation-import qualified Synthesizer.Causal.Oscillator as OsciC-import qualified Synthesizer.Causal.Filter.Recursive.Integration as IntegC-import Control.Arrow ((<<<), (^<<), (<<^), (***), )-import qualified Synthesizer.Interpolation.Module as Ip--import qualified Synthesizer.Storable.Filter.NonRecursive as FiltNRSt-import qualified Synthesizer.Storable.Cut         as CutSt-import qualified Synthesizer.Storable.Oscillator  as OsciSt-import qualified Synthesizer.Storable.Signal      as SigSt--- import qualified Data.StorableVector.Lazy.Builder as Bld-import qualified Data.StorableVector.Lazy.Pattern as SigStV-import qualified Data.StorableVector.Lazy         as SVL-import qualified Data.StorableVector              as SV--import qualified Synthesizer.Generic.Signal    as SigG--- import qualified Synthesizer.Generic.Cut       as CutG-import qualified Synthesizer.Generic.Wave      as WaveG-import qualified Synthesizer.Generic.Loop      as LoopG-import qualified Synthesizer.State.Signal      as SigS-import qualified Synthesizer.State.Control     as CtrlS-import qualified Synthesizer.State.Noise       as NoiseS-import qualified Synthesizer.State.Oscillator  as OsciS-import qualified Synthesizer.State.Displacement as DispS-import qualified Synthesizer.State.Filter.NonRecursive as FiltNRS-import qualified Synthesizer.Plain.Filter.Recursive    as FiltR-import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter--- import qualified Synthesizer.Generic.Filter.NonRecursive as FiltG--- import qualified Synthesizer.Basic.Phase       as Phase--import qualified Sound.MIDI.Message.Channel       as ChannelMsg-import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg--import qualified Data.EventList.Relative.TimeBody  as EventList-import qualified Data.EventList.Relative.TimeTime  as EventListTT-import qualified Data.EventList.Relative.MixedBody as EventListMB--- 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 Data.EventList.Relative.MixedBody ((/.), (./), )--import qualified Sound.Sox.Read          as SoxRead-import qualified Sound.Sox.Frame         as SoxFrame-import qualified Sound.Sox.Option.Format as SoxOption--import Control.Monad.Trans.State (state, evalState, get, modify, )-import Control.Monad (mzero, )---- import qualified Numeric.NonNegative.Class   as NonNeg-import qualified Numeric.NonNegative.Wrapper as NonNegW-import qualified Numeric.NonNegative.ChunkyPrivate as NonNegChunky--import qualified Algebra.RealField as RealField-import qualified Algebra.Additive  as Additive--import Data.Tuple.HT (mapSnd, )-import Data.Maybe.HT (toMaybe, )--import NumericPrelude (zero, round, (*>), (^?), )-import Prelude hiding (Real, round, break, )---channel :: Channel-channel = ChannelMsg.toChannel 0--sampleRate :: Num a => a--- sampleRate = 24000-sampleRate = 48000--- sampleRate = 44100--latency :: Int--- latency = 0--- latency = 256-latency = 1000--chunkSize :: SVL.ChunkSize-chunkSize = Play.defaultChunkSize--lazySize :: SigG.LazySize-lazySize =-   let (SVL.ChunkSize size) = chunkSize-   in  SigG.LazySize size---type Real = Float---{-# INLINE withMIDIEvents #-}-withMIDIEvents ::-   (Double -> a -> IO b) ->-   (EventList.T StrictTime (Maybe MIDI.Event) -> a) -> IO b-withMIDIEvents action proc =-   let rate = sampleRate-   in  withMIDIEventsNonblock rate $-       action rate . proc---{-# INLINE play #-}-play ::-   (RealField.C t, Additive.C y, ALSA.SampleFmt y) =>-   t -> SigSt.T y -> IO ()-play rate =-   Play.auto (round rate) .-   SigSt.append (SigSt.replicate chunkSize latency zero)---   FiltG.delayPosLazySize chunkSize latency---   FiltG.delayPos latency---- ToDo: do not record the empty chunk that is inserted for latency-{-# INLINE playAndRecord #-}-playAndRecord ::-   (RealField.C t, Additive.C y, ALSA.SampleFmt y, SoxFrame.C y) =>-   FilePath -> t -> SigSt.T y -> IO ()-playAndRecord fileName rate =-   Play.autoAndRecord fileName (round rate) .-   SigSt.append (SigSt.replicate chunkSize latency zero)---exampleVolume :: IO ()-exampleVolume =-   putStrLn "run 'aconnect' to connect to the MIDI controller" >>-   (withMIDIEvents play $-      SigSt.zipWith (*)-         (OsciSt.static chunkSize Wave.sine zero (800/sampleRate)) .-      evalState (getControllerSignal channel VoiceMsg.mainVolume (0,1) (0::Real)))--exampleFrequency :: IO ()-exampleFrequency =-   withMIDIEvents play $-      OsciSt.freqMod chunkSize Wave.sine zero .-      evalState (getControllerSignal channel VoiceMsg.mainVolume-         (400/sampleRate, 1200/sampleRate) (800/sampleRate::Real))--testFrequency1 :: IO ()-testFrequency1 =-   withMIDIEvents play $-      const-        (OsciSt.static chunkSize Wave.sine zero (800/sampleRate::Real))--testFrequency2 :: IO ()-testFrequency2 =-   withMIDIEvents (const print) $-      evalState (getControllerEvents channel VoiceMsg.mainVolume)--testFrequency3 :: IO ()-testFrequency3 =-   withMIDIEvents (const print) $-      evalState (getSlice Just)--testFrequency4 :: IO ()-testFrequency4 =-   withMIDIEvents (const print) $-      evalState (fmap-         (EventListTT.catMaybesR .-          flip EventListTM.snocTime 0 .-          EventList.mapTime NonNegChunky.fromNumber) $-        state (partitionMaybe (maybe (Just Nothing) (fmap Just . Just))))--examplePitchBend :: IO ()-examplePitchBend =-   withMIDIEvents play $-      OsciSt.freqMod chunkSize Wave.sine zero .-      evalState (getPitchBendSignal channel 2 (880/sampleRate::Real))--exampleVolumeFrequency :: IO ()-exampleVolumeFrequency =-   putStrLn "run 'aconnect' to connect to the MIDI controller" >>-   (withMIDIEvents play $-      evalState (do-         vol  <- getControllerSignal channel VoiceMsg.mainVolume (0,1) 0-         freq <- getPitchBendSignal channel 2 (880/sampleRate::Real)-         return $-            SigSt.zipWith (*) vol-               (OsciSt.freqMod chunkSize Wave.sine zero freq)))---{-# 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--pingReleaseEnvelope :: Real -> LazyTime -> SigSt.T Real-pingReleaseEnvelope vel dur =-   SigSt.switchR SigSt.empty-      (\body x ->-          SigSt.append body $-          SigS.toStorableSignal chunkSize $-          SigS.take (round (0.3*sampleRate :: Real)) $-          CtrlS.exponential2 (0.1*sampleRate) x) $-   SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $-   CtrlS.exponential2 (0.4*sampleRate) (amplitudeFromVelocity vel)--pingRelease :: Instrument Real Real-pingRelease vel freq dur =-   SigS.zipWithStorable (*)-      (OsciS.static Wave.saw zero (freq/sampleRate))-      (pingReleaseEnvelope vel dur)--pingStereoRelease :: Instrument Real (Stereo.T Real)-pingStereoRelease vel freq dur =---   SigS.zipWithStorable (\y c -> fmap (c*) y)-   SigS.zipWithStorable (flip (*>))-      (SigS.zipWith Stereo.cons-         (OsciS.static Wave.saw zero (freq*0.999/sampleRate))-         (OsciS.static Wave.saw zero (freq*1.001/sampleRate)))-      (pingReleaseEnvelope vel dur)--tine :: Instrument Real Real-tine vel freq dur =-   SigS.zipWithStorable (*)-      (OsciS.phaseMod Wave.sine (freq/sampleRate)-         (FiltNRS.envelope-            (CtrlS.exponential (1*sampleRate) (vel+1))-            (OsciS.static Wave.sine zero (2*freq/sampleRate))))-      (pingReleaseEnvelope 0 dur)--tineStereo :: Instrument Real (Stereo.T Real)-tineStereo vel freq dur =-   let ctrl f =-          FiltNRS.envelope-             (CtrlS.exponential (1*sampleRate) (vel+1))-             (OsciS.static Wave.sine zero (2*f/sampleRate))-   in  SigS.zipWithStorable (flip (*>))-          (SigS.zipWith Stereo.cons-             (OsciS.phaseMod Wave.sine (freq*0.995/sampleRate) (ctrl freq))-             (OsciS.phaseMod Wave.sine (freq*1.005/sampleRate) (ctrl freq)))-          (pingReleaseEnvelope 0 dur)---softStringReleaseEnvelope ::-   Real -> LazyTime -> SigSt.T Real-softStringReleaseEnvelope vel dur =-   let attackTime = sampleRate-       amp = amplitudeFromVelocity vel-       cnst = CtrlS.constant amp-       {--       release <- take attackTime beginning-       would yield a space leak, thus we first split 'beginning'-       and then concatenate it again-       -}-       {--       We can not easily generate attack and sustain separately,-       because we want to use the chunk structure implied by 'dur'.-       -}-       (attack, sustain) =-          SigSt.splitAt attackTime $-          SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $-          flip SigS.append cnst $-          SigS.map ((amp*) . sin) $-          CtrlS.line attackTime (0, pi/2)-       release = SigSt.reverse attack-   in  attack `SigSt.append` sustain `SigSt.append` release---- it's better to avoid inlining here-softString :: Instrument Real (Stereo.T Real)-softString vel freq dur =-   let f = freq/sampleRate-       {-# INLINE osci #-}-       osci d =-          OsciS.static Wave.saw zero (d * f)-   in  flip (SigS.zipWithStorable (flip (*>)))-          (softStringReleaseEnvelope vel dur)-          (SigS.map ((0.3::Real)*>) $-           SigS.zipWith Stereo.cons-             (DispS.mix-                (osci 1.005)-                (osci 0.998))-             (DispS.mix-                (osci 1.002)-                (osci 0.995)))---softStringReleaseEnvelopeCausal ::-   Real -> LazyTime -> SigSt.T Real-softStringReleaseEnvelopeCausal vel dur =-   Causal.apply-      (softStringReleaseEnvelopeCausalProcess vel)-      (SigSt.append-         (SigStV.replicate (chunkSizesFromLazyTime dur) True)-         (SigSt.repeat chunkSize False))---{-# INLINE softStringReleaseEnvelopeCausalProcess #-}-softStringReleaseEnvelopeCausalProcess ::-   Real -> Causal.T Bool Real-softStringReleaseEnvelopeCausalProcess vel =-   let vol = amplitudeFromVelocity vel-       attackTime = sampleRate-       {-# INLINE sine #-}-       sine x = sin (x*pi/(2*attackTime))-   in  Causal.fromStateMaybe-          (\b ->-             get >>= \n ->-             if b-               then-                 if n==attackTime-                   then return vol-                   else-                     modify (1+) >>-                     return (vol * sine n)-               else-                 if n==0-                   then mzero-                   else-                     modify (subtract 1) >>-                     return (vol * sine n))-          zero--{-# INLINE softStringCausalProcess #-}-softStringCausalProcess :: Real -> Causal.T Real (Stereo.T Real)-softStringCausalProcess freq =-   let f = freq/sampleRate-       {-# INLINE osci #-}-       osci d =-          OsciS.static Wave.saw zero (d * f)-   in  Causal.applySnd-          (Causal.map (uncurry (*>)))-          (SigS.map ((0.3::Real)*>) $-           SigS.zipWith Stereo.cons-             (DispS.mix-                (osci 1.005)-                (osci 0.998))-             (DispS.mix-                (osci 1.002)-                (osci 0.995)))--softStringCausal :: Instrument Real (Stereo.T Real)-softStringCausal vel freq dur =-   Causal.apply-      (softStringCausalProcess freq <<<-       softStringReleaseEnvelopeCausalProcess vel)-      (SigSt.append-         (SigStV.replicate (chunkSizesFromLazyTime dur) True)-         (SigSt.repeat chunkSize False))---exampleKeyboard :: IO ()-exampleKeyboard =-   withMIDIEvents play $---      playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate::Real) .-      SigSt.map (0.2*) .-      evalState (getNoteSignalMultiProgram chunkSize channel-         (VoiceMsg.toProgram 2)-         [pingDur, pingRelease, tine])--exampleKeyboardStereo :: IO ()-exampleKeyboardStereo =-   withMIDIEvents play $---      playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate::Real) .-      SigSt.map ((0.2::Real)*>) .-      evalState (getNoteSignalMultiProgram chunkSize channel-         (VoiceMsg.toProgram 1)-         [pingStereoRelease, tineStereo, softString, softStringCausal])--stringStereoFM :: SigSt.T Real -> Instrument Real (Stereo.T Real)-stringStereoFM fmSt vel freq dur =-   let fm = SigS.fromStorableSignal fmSt-   in  SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $-       FiltNRS.amplifyVector (amplitudeFromVelocity vel) $-       SigS.zipWith Stereo.cons-          (OsciS.freqMod Wave.saw zero $-           FiltNRS.amplify (freq*0.999/sampleRate) fm)-          (OsciS.freqMod Wave.saw zero $-           FiltNRS.amplify (freq*1.001/sampleRate) fm)--exampleKeyboardPitchbend :: IO ()-exampleKeyboardPitchbend =-   withMIDIEvents play $-      SigSt.map ((0.2::Real)*>) .-      evalState-         (do bend <- getPitchBendSignal channel (2^?(2/12)) 1-             getNoteSignalModulated chunkSize bend channel stringStereoFM)--exampleKeyboardFM :: IO ()-exampleKeyboardFM =-   withMIDIEvents play $-      SigSt.map ((0.2::Real)*>) .-      evalState-         (do fm <- getFMSignalFromBendWheelPressure channel-                      2 (10/sampleRate) 0.04 0.03-             getNoteSignalModulated chunkSize fm channel stringStereoFM)--stringStereoDetuneFM ::-   SigSt.T Real -> SigSt.T Real -> Instrument Real (Stereo.T Real)-stringStereoDetuneFM detuneSt fmSt vel freq dur =-   let fm = SigS.fromStorableSignal fmSt-       detune = SigS.fromStorableSignal detuneSt-       {-# INLINE osci #-}-       osci =-          OsciS.freqMod Wave.saw zero .-          FiltNRS.amplify (freq/sampleRate) .-          FiltNRS.envelope fm-   in  SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $-       FiltNRS.amplifyVector (amplitudeFromVelocity vel) $-       SigS.zipWith Stereo.cons-          (osci $ SigS.map (1-) detune)-          (osci $ SigS.map (1+) detune)--exampleKeyboardDetuneFM :: IO ()-exampleKeyboardDetuneFM =-   withMIDIEvents play $-      SigSt.map ((0.2::Real)*>) .-      evalState-         (do fm <- getFMSignalFromBendWheelPressure channel-                      2 (10/sampleRate) 0.04 0.03-             detune <- getControllerSignal channel-                          VoiceMsg.vectorX (0,0.005) 0-             getNoteSignalMultiModulated-                chunkSize channel stringStereoDetuneFM-                (applyModulation fm .-                 applyModulation detune))---exampleKeyboardFilter :: IO ()-exampleKeyboardFilter =-   withMIDIEvents play $-      SigSt.map (0.2*) .-      evalState-         (do music <- getNoteSignal chunkSize channel pingRelease-             freq  <- getControllerSignal 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)--{-# INLINE sampledSoundGenerator #-}-sampledSoundGenerator :: (Real, SigSt.T Real) -> Real -> SigS.T Real-sampledSoundGenerator (period, sample) freq =-   Causal.apply-      (Interpolation.relativeZeroPad zero Ip.linear zero-          (SigS.fromStorableSignal sample)) $-   SigS.repeat (freq/sampleRate*period)--sampledSound :: (Real, SigSt.T Real) -> Instrument Real Real-sampledSound sound vel freq dur =-   SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $-   SigS.map ((amplitudeFromVelocity vel) *) $-   sampledSoundGenerator sound freq--sampledSoundDetuneStereo ::-   Real -> (Real, SigSt.T Real) -> Instrument Real (Stereo.T Real)-sampledSoundDetuneStereo detune sound vel freq dur =-   SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $-   SigS.map ((amplitudeFromVelocity vel) *>) $-   SigS.zipWith Stereo.cons-      (sampledSoundGenerator sound (freq*(1-detune)))-      (sampledSoundGenerator sound (freq*(1+detune)))--sampleReleaseEnvelope :: Real -> Real -> LazyTime -> SigSt.T Real-sampleReleaseEnvelope halfLife vel dur =-   let amp = amplitudeFromVelocity vel-   in  SigSt.append-          (SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $-           CtrlS.constant amp)-          (SigS.toStorableSignal chunkSize $-           SigS.take (round (5*halfLife*sampleRate :: Real)) $-           CtrlS.exponential2 (halfLife*sampleRate) amp)--sampledSoundDetuneStereoRelease ::-   Real -> Real -> (Real, SigSt.T Real) -> Instrument Real (Stereo.T Real)-sampledSoundDetuneStereoRelease release detune sound vel freq dur =-   flip (SigS.zipWithStorable (flip (*>)))-      (sampleReleaseEnvelope release vel dur) $-   SigS.zipWith Stereo.cons-      (sampledSoundGenerator sound (freq*(1-detune)))-      (sampledSoundGenerator sound (freq*(1+detune)))---readPianoSample :: IO (Real, SigSt.T Real)-readPianoSample =-   fmap ((,) 96) $-   SoxRead.withHandle1 (SVL.hGetContentsSync chunkSize) =<<-   SoxRead.open SoxOption.none "a-piano3"--readStringSample :: IO (Real, SigSt.T Real)-readStringSample =-   fmap ((,) 64) $-   SoxRead.withHandle1 (SVL.hGetContentsSync chunkSize) =<<-   SoxRead.open SoxOption.none "strings7.s8"---{- |-Resample a sampled sound with a smooth loop-using our time manipulation algorithm.-Time is first controlled linearly,-then switches to a sine or triangular control.-Loop start must be large enough in order provide enough spare data-for interpolation at the beginning-and loop start plus length must preserve according space at the end.-One period is enough space for linear interpolation.-The infinite sound we generate is not just a cycle,-that uses bounded space.-Instead we need to compute all the time.-In order to avoid duplicate interpolation,-we have merged resampling and time looping.--}-{-# INLINE sampledSoundTimeLoop #-}-sampledSoundTimeLoop ::-   (Real -> Real -> Real -> Real -> SigS.T Real) ->-   (Real, SigSt.T Real) -> Real -> Real -> Instrument Real Real-sampledSoundTimeLoop loopTimeMod-     (period, sample) loopLen loopStart vel freq dur =-   let wave = WaveG.sampledTone Ip.linear Ip.linear period sample-   in  SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $-       (((0.2 * amplitudeFromVelocity vel) *) ^<<-        OsciC.shapeMod wave zero (freq/sampleRate))-       `Causal.apply`-          loopTimeMod period (loopLen/2) (loopStart + loopLen/2) freq--{--Graphics.Gnuplot.Simple.plotList [] (SigS.toList $ SigS.take 20000 $ loopTimeMod 64 1000 2000 440)--}-loopTimeModSine :: Real -> Real -> Real -> Real -> SigS.T Real-loopTimeModSine period loopDepth loopCenter freq =-   let rate = freq*period/sampleRate-   in  SigS.append-          (SigS.takeWhile (loopCenter>=) $-           SigS.iterate (rate+) zero)-          (SigS.map (\t -> loopCenter + loopDepth * sin t) $-           SigS.iterate ((rate/loopDepth)+) zero)--loopTimeModZigZag :: Real -> Real -> Real -> Real -> SigS.T Real-loopTimeModZigZag period loopDepth loopCenter freq =-   let rate = freq*period/sampleRate-   in  SigS.append-          (SigS.takeWhile (loopCenter>=) $-           SigS.iterate (rate+) zero)-          (SigS.map (\t -> loopCenter + loopDepth * t) $-           OsciS.static Wave.triangle zero (rate/(4*loopDepth)))----exampleKeyboardSample :: IO ()-exampleKeyboardSample =-   do piano <- readPianoSample-      string <- readStringSample-      let loopedString     = mapSnd (LoopG.simple 8750 500) string-          fadedString      = mapSnd (LoopG.fade (undefined::Real) 8750 500) string-          timeSineString   = LoopG.timeReverse lazySize Ip.linear Ip.linear LoopG.timeControlSine 8750 500 string-          timeZigZagString = LoopG.timeReverse lazySize Ip.linear Ip.linear LoopG.timeControlZigZag 8750 500 string-      withMIDIEvents play $-         SigSt.map (0.2*) .-         evalState (getNoteSignalMultiProgram chunkSize channel-               (VoiceMsg.toProgram 5) $-            sampledSound piano :-            sampledSound string :-            sampledSound loopedString :-            sampledSound fadedString :-            sampledSound timeSineString :-            sampledSound timeZigZagString :-            sampledSoundTimeLoop loopTimeModSine string 8750 500 :-            sampledSoundTimeLoop loopTimeModZigZag string 8750 500 :-            [])---exampleKeyboardVariousStereo :: IO ()-exampleKeyboardVariousStereo =-   do piano <- readPianoSample-      string <- readStringSample-      let loopedString =-             LoopG.timeReverse lazySize Ip.linear Ip.linear-                LoopG.timeControlZigZag 8750 500 string-      withMIDIEvents (playAndRecord "session.wav") $-         SigSt.map ((0.2::Real)*>) .-         evalState (getNoteSignalMultiProgram chunkSize channel-               (VoiceMsg.toProgram 0) $-            pingStereoRelease :-            tineStereo :-            softString :-            sampledSoundDetuneStereo 0.001 piano :-            sampledSoundDetuneStereo 0.002 loopedString :-            sampledSoundDetuneStereoRelease 0.1 0.001 piano :-            sampledSoundDetuneStereoRelease 0.3 0.002 loopedString :-            [])---timeModulatedSample :: (Real, SigSt.T Real) ->-   SigSt.T Real -> SigSt.T Real -> SigSt.T Real -> Instrument Real Real-timeModulatedSample (period, sample) offsetMod speedMod freqMod vel freq dur =-   let wave = WaveG.sampledTone Ip.linear Ip.linear period sample-   in  SigStV.take (chunkSizesFromLazyTime dur) $-{--       (((0.2 * amplitudeFromVelocity vel) *) ^<<-        OsciC.freqMod Wave.saw zero <<<-        Causal.map ((freq/sampleRate) *))-       `Causal.apply` freqMod--}-       (((0.2 * amplitudeFromVelocity vel) *) ^<<-        OsciC.shapeFreqMod wave zero <<<-        (uncurry (+) ^<< Causal.feedFst offsetMod <<< IntegC.run) ***-         Causal.map ((freq/sampleRate) *))-       `Causal.applyFst` speedMod-       `Causal.apply` freqMod--exampleKeyboardSampleTFM :: IO ()-exampleKeyboardSampleTFM =-   do instr <- readPianoSample-      withMIDIEvents play $-         evalState-            (do fm <- getFMSignalFromBendWheelPressure channel-                         2 (10/sampleRate) 0.04 0.03-                speed <- getControllerSignal channel-                             (VoiceMsg.toController 22)-                             (0,2) 1-                offset <- getControllerSignal channel-                             (VoiceMsg.toController 21)-                             (0, fromIntegral (SVL.length (snd instr))) 0-                getNoteSignalMultiModulated-                   chunkSize channel (timeModulatedSample instr)-                   (applyModulation fm .-                    applyModulation speed .-                    applyModulation offset))----colourNoise ::-   SigSt.T Real -> SigSt.T Real ->-   Instrument Real Real-colourNoise resonanceMod freqMod vel freq dur =-   SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $-   ((((sqrt sampleRate/2000 * amplitudeFromVelocity vel) *) . UniFilter.lowpass) ^<<-    UniFilter.causal)-   `Causal.applyFst`-      SigS.zipWith-         (\r f -> UniFilter.parameter $ FiltR.Pole r (f*freq/sampleRate))-         (SigS.fromStorableSignal resonanceMod)-         (SigS.fromStorableSignal freqMod)-   `Causal.apply` NoiseS.white--exampleKeyboardNoisePipe :: IO ()-exampleKeyboardNoisePipe =-   withMIDIEvents play $-      evalState-         (do fm <- getFMSignalFromBendWheelPressure channel-                      2 (10/sampleRate) 0.04 0.03-             resonance <--                   getControllerSignalExp channel-                      (VoiceMsg.toController 23)-                      (1, 100) 10-             getNoteSignalMultiModulated-                chunkSize channel colourNoise-                (applyModulation fm .-                 applyModulation resonance))---toneFromNoise ::-   SigSt.T Real -> SigSt.T Real ->-   Instrument Real Real-toneFromNoise speedMod freqMod vel freq dur =-   SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $-   (((0.1 * amplitudeFromVelocity vel) *) ^<<-    OsciC.shapeFreqModFromSampledTone-       Ip.linear Ip.linear-       100 (SigS.toStorableSignal chunkSize NoiseS.white)-       zero zero <<<-    Causal.second (Causal.map ((freq/sampleRate)*)))-   `Causal.applyFst`-      SigS.fromStorableSignal speedMod-   `Causal.apply`-      SigS.fromStorableSignal freqMod--exampleKeyboardNoisyTone :: IO ()-exampleKeyboardNoisyTone =-   withMIDIEvents play $-      evalState-         (do fm <- getFMSignalFromBendWheelPressure channel-                      2 (10/sampleRate) 0.04 0.03-             speed <- getControllerSignal channel-                          (VoiceMsg.toController 21)-                          (0,0.5) 0.1-             getNoteSignalMultiModulated-                chunkSize channel toneFromNoise-                (applyModulation fm .-                 applyModulation speed))--{--I like to control the filter parameters-before phase and time modulation.-Unfortunately this means,-that we have to translate those control signals back-using the speed profile, which is tricky.-We need an inverse frequency modulation, that is:--freqMod ctrl (invFreqMod ctrl signal) = signal--The problem is, that the chunk boundaries will not match.-invFreqMod must be a StorableSignal function and it is not causal-in any of its inputs.--}-toneFromFilteredNoise ::-   SigSt.T Real -> SigSt.T Real ->-   SigSt.T Real -> SigSt.T Real ->-   Instrument Real Real-toneFromFilteredNoise resonanceMod cutoffMod speedMod freqMod vel freq dur =-   let period = 100-       filtNoise =-          ((((amplitudeFromVelocity vel) *) . UniFilter.lowpass) ^<<-           UniFilter.causal <<< Causal.feedSnd NoiseS.white-           <<^ (\(r,f) -> UniFilter.parameter $-                  FiltR.Pole r (f/period)))-          `Causal.applyFst`-             FiltNRSt.inverseFrequencyModulationFloor chunkSize speedMod resonanceMod-          `Causal.apply`-             FiltNRSt.inverseFrequencyModulationFloor chunkSize speedMod cutoffMod-   in  SigStV.take (chunkSizesFromLazyTime dur) $-       (((0.1 * amplitudeFromVelocity vel) *) ^<<-        OsciC.shapeFreqModFromSampledTone-           Ip.linear Ip.linear-           period filtNoise-           zero zero <<<-        Causal.second (Causal.map ((freq/sampleRate)*)))-       `Causal.applyFst` speedMod-       `Causal.apply`    freqMod---exampleKeyboardFilteredNoisyTone :: IO ()-exampleKeyboardFilteredNoisyTone =-   withMIDIEvents play $-      evalState-         (do fm <- getFMSignalFromBendWheelPressure channel-                      2 (10/sampleRate) 0.04 0.03-             {--             speed must never be zero,-             since this requires to fetch unlimited data from future.-             -}-             speed <- getControllerSignal channel-                          (VoiceMsg.toController 21)-                          (0.05,0.5) 0.1-             cutoff <- getControllerSignalExp channel-                          (VoiceMsg.toController 22)-                          (1, 30) 10-             resonance <- getControllerSignalExp channel-                          (VoiceMsg.toController 23)-                          (1, 20) 5-             getNoteSignalMultiModulated-                chunkSize channel toneFromFilteredNoise-                (applyModulation fm .-                 applyModulation speed .-                 applyModulation cutoff .-                 applyModulation resonance))---testKeyboard1 :: IO ()-testKeyboard1 =-   withMIDIEvents play $-      const (ping 0 440)--testKeyboard2 :: SigSt.T Real-testKeyboard2 =-   let music :: Real -> EventList.T StrictTime (SigSt.T Real)-       music x = 5 /. SigSt.replicate chunkSize 6 x ./ music (x+1)-   in  CutSt.arrange chunkSize $-       EventList.mapTime fromIntegral $ music 42--testKeyboard3 :: SigSt.T Real-testKeyboard3 =-   let time :: Real -> Int-       time t = round (t * sampleRate)-       music :: Real -> EventList.T StrictTime (SigSt.T Real)-       music x =-          fromIntegral (time 0.2) /.-          SigSt.take (time 0.4) (ping 0 x) ./-          music (x*1.01)-   in  CutSt.arrange chunkSize $-       EventList.mapTime fromIntegral $ music 110--makeLazyTime :: Real -> LazyTime-makeLazyTime t =-   NonNegChunky.fromNumber $-   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 ::-   EventListTT.T LazyTime (NoteBoundary Bool) ->-   EventListTT.T LazyTime (NoteBoundary (Maybe VoiceMsg.Program))-embedDefaultProgram =-   EventListTT.mapBody (\(NoteBoundary p v b) ->-      NoteBoundary p v (toMaybe b defaultProgram))--testKeyboard4 :: SigSt.T Real-testKeyboard4 =-   let {--       idInstr :: Real -> Real -> SigSt.T Real-       idInstr _vel freq = SigSt.repeat chunkSize freq-       -}---       inf = time 0.4 + inf-       music :: Int -> EventListTT.T LazyTime Note-       music p =-          makeLazyTime 0.2 EventListMT./.---          (pitch p, normalVelocity, inf) EventListMT../-          Note defaultProgram (pitch p) normalVelocity (makeLazyTime 0.4) EventListMT../-          music (p+1)-   in  CutSt.arrange chunkSize $-       EventListTM.switchTimeR const $-       EventListTT.mapTime fromIntegral $-       insertBreaks $-       makeInstrumentSounds pingDur $-       music 0--exampleNotes0 :: Int -> EventListTT.T LazyTime (NoteBoundary Bool)-exampleNotes0 p =-   makeLazyTime 0.2 EventListMT./.-   (let (oct,pc) = divMod p 12-    in  (NoteBoundary (pitch (50 + pc)) normalVelocity (even oct)))-      EventListMT../-   exampleNotes0 (p+1)--exampleNotes1 :: EventListTT.T LazyTime (NoteBoundary Bool)-exampleNotes1 =-   makeLazyTime 0.2 EventListMT./.-   (NoteBoundary (pitch 50) normalVelocity True) EventListMT../-   makeLazyTime 0.2 EventListMT./.-   (NoteBoundary (pitch 52) normalVelocity True) EventListMT../-   makeLazyTime 0.2 EventListMT./.-   (NoteBoundary (pitch 54) normalVelocity True) EventListMT../-   makeLazyTime 0.2 EventListMT./.---   (NoteBoundary (pitch 50) normalVelocity False) EventListMT../-   undefined--testKeyboard5 :: SigSt.T Real-testKeyboard5 =-   CutSt.arrange chunkSize $-       EventListTM.switchTimeR const $-       EventListTT.mapTime fromIntegral $-       insertBreaks $-       makeInstrumentSounds pingDur $-       matchNoteEvents $-       embedDefaultProgram $-       exampleNotes0 0--testKeyboard6 :: EventListTT.T LazyTime Note-testKeyboard6 =-   matchNoteEvents $-   embedDefaultProgram $-   exampleNotes1--testKeyboard7 :: EventListTT.T LazyTime (VoiceMsg.Pitch, VoiceMsg.Velocity)-testKeyboard7 =-   EventListTT.mapBody (\ ~(Note _ p v _d) -> (p,v)) $-   testKeyboard6--testSpeed :: IO ()-testSpeed =-   let _sig =-          Causal.apply-             (softStringCausalProcess 440 <<<-              softStringReleaseEnvelopeCausalProcess 0)-             (SigS.repeat True)-       sig =-          Causal.apply-             (softStringCausalProcess 440)-             (SigS.repeat 1)-   in  SV.writeFile "speed.f32" $-       SigS.runViewL sig-       (\next s -> fst $ SV.unfoldrN 1000000 next s)--testSpeedChunky :: IO ()-testSpeedChunky =-   let sig =-          Causal.apply-             (softStringCausalProcess 440 <<<-              softStringReleaseEnvelopeCausalProcess 0)-             (SigS.repeat True)-   in  SVL.writeFile "speed.f32" $-       SigSt.take 1000000 $-       SigS.toStorableSignal (SVL.chunkSize 100) sig-{--       SigS.runViewL sig-       (\next s -> SVL.take 1000000 (SVL.unfoldr (SVL.chunkSize 100) next s))--}--testSpeedArrange :: IO ()-testSpeedArrange =-   let sig =-          Causal.apply-             (softStringCausalProcess 440 <<<-              softStringReleaseEnvelopeCausalProcess 0)-             (SigS.repeat True)-       sigSt =-          SigS.toStorableSignal (SVL.chunkSize 100) sig-   in  SVL.writeFile "speed.f32" $-       SigSt.take 1000000 $-       CutSt.arrangeEquidist (SVL.chunkSize 100) $-       EventList.fromPairList [(10000,sigSt)]--{--This program has still a very slowly growing memory leak.--}-main :: IO ()-main =---   Play.auto 44100 $ OsciSt.static chunkSize Wave.sine zero (800/sampleRate::Real)---   print testKeyboard3---   playMono sampleRate testKeyboard3---   examplePitchBend---   exampleKeyboard---   exampleKeyboardStereo---   exampleKeyboardPitchbend---   exampleKeyboardFM---   exampleKeyboardDetuneFM---   exampleKeyboardFilter---   exampleKeyboardSample-   exampleKeyboardVariousStereo---   exampleKeyboardSampleTFM---   exampleKeyboardNoisyTone---   exampleKeyboardFilteredNoisyTone---   testSpeed---{--main :: IO ()-main =-  do putStrLn "Starting."-     h <- open default_seq_name OpenInput Block-     set_client_name h "HS1"-     putStrLn "Created sequencer."-     p1 <- create_simple_port h "one"-            (caps [cap_write,cap_subs_write]) type_midi_generic--     p2 <- create_simple_port h "two"-            (caps [cap_write,cap_subs_write]) type_midi_generic-     putStrLn "Created ports."-     let loop = do putStrLn "waiting for an event:"-                   e <- event_input h-                   print e-                   loop-     loop-     delete_port h p1-     delete_port h p2-     putStrLn "Deleted ports."-     close h-     putStrLn "Closed sequencer."-  `alsa_catch` \e -> putStrLn ("Problem: " ++ exception_description e)--}
− src/RealTimeSynthesizerDim.hs 
@@ -1,426 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE Rank2Types #-}-module Main where--import qualified Synthesizer.Dimensional.ALSA.Play as Play-import qualified Synthesizer.Dimensional.ALSA.MIDI as MIDI--import qualified Sound.Alsa as ALSA-import qualified Sound.Alsa.Sequencer as AlsaMidi--import qualified Synthesizer.EventList.ALSA.MIDI as MIDIEv--import qualified Synthesizer.Storable.ALSA.Play as PlaySt--import qualified Synthesizer.Dimensional.Causal.Process    as Causal-import qualified Synthesizer.Dimensional.Causal.Oscillator as Osci-import qualified Synthesizer.Dimensional.Causal.Filter     as Filt-import qualified Synthesizer.Dimensional.Causal.ControlledProcess as CProc--import qualified Synthesizer.Dimensional.Rate as Rate-import qualified Synthesizer.Dimensional.Rate.Cut as CutR-import qualified Synthesizer.Dimensional.Rate.Control as CtrlR-import qualified Synthesizer.Dimensional.Rate.Oscillator as OsciR-import qualified Synthesizer.Dimensional.Rate.Filter as FiltR-import qualified Synthesizer.Dimensional.Amplitude as Amp-import qualified Synthesizer.Dimensional.Amplitude.Cut as CutA-import qualified Synthesizer.Dimensional.Amplitude.Control as CtrlA-import qualified Synthesizer.Dimensional.Amplitude.Displacement as DispA-import qualified Synthesizer.Dimensional.Amplitude.Flat as Flat-import qualified Synthesizer.Dimensional.Amplitude.Analysis as AnaA-import qualified Synthesizer.Dimensional.Amplitude.Filter as FiltA-import qualified Synthesizer.Dimensional.RateAmplitude.Control as CtrlD-import qualified Synthesizer.Dimensional.ChunkySize.Signal as SigC-import qualified Synthesizer.Dimensional.Signal.Private as SigA-import qualified Synthesizer.Dimensional.Process as Proc-import qualified Synthesizer.Dimensional.Wave as WaveD--import Synthesizer.Dimensional.Causal.Process ((<<<), )-import Synthesizer.Dimensional.Wave ((&*~), )-import Synthesizer.Dimensional.Process (($:), (.:), )-import Synthesizer.Dimensional.Signal ((&*^), )-import Control.Applicative (liftA2, liftA3, )--import qualified Synthesizer.Basic.Wave          as Wave-import qualified Synthesizer.Frame.Stereo        as Stereo---- import Foreign.Storable (Storable, )--- import Data.Int (Int16, )--import qualified Synthesizer.Storable.Signal      as SigSt--- import qualified Synthesizer.State.Signal         as SigS--import qualified Sound.MIDI.Message.Channel       as ChannelMsg-import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg--import qualified Data.EventList.Relative.TimeBody  as EventList---- import qualified Numeric.NonNegative.Class   as NonNeg--- import qualified Numeric.NonNegative.Wrapper as NonNegW--- import qualified Numeric.NonNegative.ChunkyPrivate as NonNegChunky--import qualified Algebra.Module         as Module-import qualified Algebra.RealField      as RealField-import qualified Algebra.Field          as Field-import qualified Algebra.Ring           as Ring--import qualified Algebra.DimensionTerm as Dim-import qualified Number.DimensionTerm  as DN--import NumericPrelude-import PreludeBase hiding (break, )---channel :: ChannelMsg.Channel-channel = ChannelMsg.toChannel 0--sampleRate :: Ring.C a => DN.Frequency a-sampleRate = DN.frequency 48000--- sampleRate = 44100--latency :: Field.C a => DN.Time a-latency = DN.time 0.01--{--chunkSize :: SVL.ChunkSize-chunkSize = Play.defaultChunkSize--}---type Real = Float---{-# INLINE withMIDIEvents #-}-withMIDIEvents ::-   Ring.C t =>-   (DN.Frequency t -> a -> IO b) ->-   (EventList.T MIDIEv.StrictTime (Maybe AlsaMidi.Event) -> a) -> IO b-withMIDIEvents action proc =-   MIDIEv.withMIDIEventsNonblock-      (DN.toNumberWithDimension Dim.frequency sampleRate :: Double) $-   action sampleRate . proc--{-# INLINE play #-}-play ::-   (Module.C y yv, ALSA.SampleFmt yv, RealField.C t) =>-   DN.Frequency t ->-   (forall s. Proc.T s Dim.Time t-      (Play.StorableSignal s Dim.Voltage y yv)) ->-   IO ()-play rate sig =-   Play.renderTimeVoltageStorable rate-   (FiltR.delay latency $: sig)---channelVolume :: VoiceMsg.Controller-channelVolume = VoiceMsg.modulation--exampleVolume :: IO ()-exampleVolume =-   putStrLn "run 'aconnect' to connect to the MIDI controller" >>-   (withMIDIEvents play $-   \evs ->-      liftA3-          (\env osci vol ->-              Causal.apply-                 (Causal.applySnd env osci) $ vol)-          Filt.envelopeScalarDimension-          (OsciR.static (DN.voltage 1 &*~ Wave.sine) zero (DN.frequency (880::Real)))-          (MIDI.runFilter evs (MIDI.getControllerSignal channel channelVolume-              (DN.scalar 0, DN.scalar 1) (DN.scalar (1::Real)))))--examplePitchBend :: IO ()-examplePitchBend =-   withMIDIEvents play $-   \evs ->-      liftA2 Causal.apply-          (Osci.freqMod (DN.voltage (1::Real) &*~ Wave.sine) zero)-          (MIDI.runFilter evs (MIDI.getPitchBendSignal channel 2 (DN.frequency (880::Real))))---- preserve chunk structure of channel volume-exampleVolumePitchBend0 :: IO ()-exampleVolumePitchBend0 =-   putStrLn "run 'aconnect' to connect to the MIDI controller" >>-   (withMIDIEvents play $-   \evs ->-      liftA3-          (\osci env (freq,vol) ->-              Causal.apply-                 (Causal.applySnd env (osci $ SigA.restore freq)) $ vol)-          (OsciR.freqMod (DN.voltage 1 &*~ Wave.sine) zero)-          Filt.envelopeScalarDimension-          (MIDI.runFilter evs $ liftA2 (,)-             (MIDI.getPitchBendSignal channel 2 (DN.frequency (880::Real)))-             (MIDI.getControllerSignal channel channelVolume-                (DN.scalar 0, DN.scalar 1) (DN.scalar (1::Real)))))---- preserve chunk structure of pitch bender-exampleVolumePitchBend1 :: IO ()-exampleVolumePitchBend1 =-   putStrLn "run 'aconnect' to connect to the MIDI controller" >>-   (withMIDIEvents play $-   \evs ->-      liftA3-          (\osci env (freq,vol) ->-              Causal.apply-                 (Causal.applyFst env (SigA.restore vol) <<< osci)-                 freq)-          (Osci.freqMod (DN.voltage 1 &*~ Wave.sine) zero)-          Filt.envelopeScalarDimension-          (MIDI.runFilter evs $ liftA2 (,)-             (MIDI.getPitchBendSignal channel 2 (DN.frequency (880::Real)))-             (MIDI.getControllerSignal channel channelVolume-                (DN.scalar 0, DN.scalar 1) (DN.scalar (1::Real)))))---{-# INLINE ping #-}-ping :: MIDI.Instrument s Dim.Time Dim.Voltage Real Real-ping vel freq =-   fmap (flip SigC.store)-      (FiltR.envelope-         $: CtrlR.exponential2 (DN.time 0.2)-         $: OsciR.static (DN.voltage (4**vel) &*~ Wave.saw) zero freq)---exampleKeyboard :: IO ()-exampleKeyboard =-   withMIDIEvents play $-   \evs ->-      MIDI.runFilter evs-         (MIDI.getNoteSignal PlaySt.defaultChunkSize (DN.voltage 1) channel ping)---{--Generating the envelope requires great care:- - you must avoid an append function that determines the common volume automatically,-   because the volume of the second part is only known after the first part is complete- - you must terminate the release phase,-   otherwise you get an infinite signal for every played note--}-{-# INLINE pingReleaseEnvelope #-}-pingReleaseEnvelope ::-   Real ->-   Proc.T s Dim.Time Real-      (MIDI.LazyTime s ->-       SigA.T (Rate.Phantom s) (Amp.Dimensional Dim.Scalar Real) (SigSt.T Real))-pingReleaseEnvelope vel =-   Proc.withParam $ \dur ->-   do decay <--         fmap (SigC.store dur) $-         CtrlR.exponential2 (DN.time 0.4)-      end <- fmap (AnaA.endPrimitive zero) $ fmap ($decay) SigA.embedSampleRate-      release <--         SigA.store (DN.time 0.01) $:-         (CutR.take (DN.time 0.3) $:-          fmap Flat.canonicalize-            (DN.scalar end &*^ CtrlR.exponential2 (DN.time 0.1)))-      append <- CutR.append-      return $ (DispA.inflate (DN.fromNumber $ 4**vel) (append decay release))---      return $ DispA.inflate (DN.fromNumber $ 4**vel) decay--{--   Proc.withParam $ \dur ->-   liftA2-      (\embed env ->-          let x = SigC.store dur env-              y = AnaA.end $ embed x-          in  )-      SigA.embedSampleRate-      (FiltR.envelope-         $: CtrlR.exponential2 (DN.time 0.2)-         $: OsciR.static (DN.voltage (4**vel) &*~ Wave.saw) zero freq)--}--{-# INLINE pingRelease #-}-pingRelease :: MIDI.Instrument s Dim.Time Dim.Voltage Real Real-pingRelease vel freq =-   liftA3-      (\env ctrl osci dur ->-          Causal.apply-             (env <<< Causal.feedSnd osci)-             (ctrl dur))-      Filt.envelopeScalarDimension-      (pingReleaseEnvelope vel)-      (OsciR.static (DN.voltage 1 &*~ Wave.saw) zero freq)---exampleKeyboardMulti :: IO ()-exampleKeyboardMulti =-   withMIDIEvents play $-   \evs ->-      MIDI.runFilter evs-         (MIDI.getNoteSignalMultiProgram PlaySt.defaultChunkSize (DN.voltage 1) channel-             (VoiceMsg.toProgram 0)-             [ping, pingRelease])---             [string])---{-# INLINE pingReleaseFM #-}-pingReleaseFM ::-   MIDI.ModulatedInstrument s Dim.Time Real-      (MIDI.Signal s Dim.Scalar Real Real ->-       MIDI.Signal s Dim.Voltage Real Real)-pingReleaseFM vel freq =-   liftA3-      (\env ctrl osci dur fm ->-          Causal.apply-             (env <<<-              Causal.feedSnd (osci (FiltA.amplifyScalarDimension freq $ SigA.restore fm)))-             (ctrl dur))-      Filt.envelopeScalarDimension-      (pingReleaseEnvelope vel)-      (OsciR.freqMod (DN.voltage 1 &*~ Wave.saw) zero)--exampleKeyboardFM :: IO ()-exampleKeyboardFM =-   withMIDIEvents play $-   \evs ->-      fmap (FiltA.amplify 0.3) $-         (MIDI.runFilter evs-            (MIDI.getNoteSignalModulated PlaySt.defaultChunkSize (DN.voltage 1) channel pingReleaseFM $:-             MIDI.getFMSignalFromBendWheelPressure channel 2 (DN.frequency 10) 0.04 0.03))---             MIDI.getPitchBendSignal channel (2 ** recip 12) (DN.scalar one)))---{-# INLINE pingStereoDetuneFM #-}-pingStereoDetuneFM ::-   MIDI.ModulatedInstrument s Dim.Time Real-      (MIDI.Signal s Dim.Scalar Real Real ->-       MIDI.Signal s Dim.Scalar Real Real ->-       MIDI.Signal s Dim.Voltage Real (Stereo.T Real))-pingStereoDetuneFM vel freq =-   liftA3-      (\env ctrl osci dur detuneSt fmSt ->-          let fm     = SigA.restore fmSt-              detune = SigA.restore detuneSt-              osciChan d =-                 osci (FiltA.amplifyScalarDimension freq-                    (FiltA.envelope (DispA.raise 1 d) fm))-          in  SigA.rewriteAmplitudeDimension Dim.identityLeft $-              Causal.apply-                 (env <<<-                  Causal.feedSnd (CutA.mergeStereo-                     (osciChan detune)-                     (osciChan $ FiltA.negate detune)))-                 (ctrl dur))-      Filt.envelopeVectorDimension-      (pingReleaseEnvelope vel)-      (OsciR.freqMod (DN.voltage 1 &*~ Wave.saw) zero)--extraController :: VoiceMsg.Controller-extraController =-   VoiceMsg.vectorX---   VoiceMsg.toController 21--extraController1 :: VoiceMsg.Controller-extraController1 =-   VoiceMsg.modulation---   VoiceMsg.vectorY---   VoiceMsg.toController 22---exampleKeyboardDetuneFM :: IO ()-exampleKeyboardDetuneFM =-   withMIDIEvents play $-   \evs ->-      fmap (FiltA.amplify 0.3) $-         (MIDI.runFilter evs-            (MIDI.getNoteSignalMultiModulated PlaySt.defaultChunkSize (DN.voltage 1) channel pingStereoDetuneFM-              (fmap MIDI.applyModulation-                  (MIDI.getFMSignalFromBendWheelPressure channel 2 (DN.frequency 10) 0.04 0.03) .:-               fmap MIDI.applyModulation-                  (MIDI.getControllerSignal channel extraController (0, 0.005) 0))-               ))---{- INLINE stringReleaseEnvelope -}-stringReleaseEnvelope ::-   Real ->-   Proc.T s Dim.Time Real-      (MIDI.LazyTime s ->-       SigA.T (Rate.Phantom s) (Amp.Dimensional Dim.Scalar Real) (SigSt.T Real))-stringReleaseEnvelope vel =-   Proc.withParam $ \dur ->-   do let attackTime = DN.time 1-      cnst <- CtrlR.constant-      {--      release <- take attackTime beginning-      would yield a space leak, thus we first split 'beginning'-      and then concatenate it again-      -}-      {--      We can not easily generate attack and sustain separately,-      because we want to use the chunk structure implied by 'dur'.-      -}-      (attack, sustain) <--         CutR.splitAt attackTime $:-         (fmap (SigC.store dur .-                flip CutA.appendPrimitive cnst .-                DispA.map sin . Flat.canonicalize)-            (CtrlD.line attackTime (0, DN.scalar (pi/2))))-      let release = CutA.reverse attack---          infixr 5 append-      append <- CutR.append-      return $-         DispA.inflate (DN.fromNumber $ 4**vel) $-         attack `append` sustain `append` release--{- INLINE string -}-string ::-   MIDI.ModulatedInstrument s Dim.Time Real-      (MIDI.Signal s Dim.Voltage Real (Stereo.T Real))-string vel freq =-   liftA3-      (\env ctrl osci dur ->-          SigA.rewriteAmplitudeDimension Dim.identityLeft $-          Causal.apply-             (env <<< Causal.feedSnd osci)-             (ctrl dur))-      Filt.envelopeVectorDimension-      (stringReleaseEnvelope vel)-      (Proc.pure CutA.mergeStereo-         $: (Proc.pure DispA.mix-              $: OsciR.static (DN.voltage 0.5 &*~ Wave.saw) zero (DN.scale 1.005 freq)-              $: OsciR.static (DN.voltage 0.5 &*~ Wave.saw) zero (DN.scale 0.998 freq))-         $: (Proc.pure DispA.mix-              $: OsciR.static (DN.voltage 0.5 &*~ Wave.saw) zero (DN.scale 1.002 freq)-              $: OsciR.static (DN.voltage 0.5 &*~ Wave.saw) zero (DN.scale 0.995 freq)))---exampleKeyboardFilter :: IO ()-exampleKeyboardFilter =-   withMIDIEvents play $-   \evs ->-        liftA3-           (\osci filt (music,speed,depth) ->-              (Filt.lowpassFromUniversal <<<-               filt (CtrlA.constant 10)-                 (DispA.mapExponential 4 (DN.frequency 1000) $-                  FiltA.envelope (SigA.restore depth) $-                  osci (SigA.restore speed)))-              `Causal.apply`-              FiltA.amplify 0.2 music)-           (OsciR.freqMod (WaveD.flat Wave.sine) zero)-           (CProc.runSynchronous2 Filt.universal)---           FiltR.universal-           (MIDI.runFilter evs-              (liftA3 (,,)-                 (MIDI.getNoteSignal PlaySt.defaultChunkSize (DN.voltage 1) channel string)-                 (MIDI.getControllerSignalExp channel extraController-                     (DN.frequency 0.1, DN.frequency 5) (DN.frequency 0.2))-                 (MIDI.getControllerSignal channel extraController1-                     (0, 1 :: DN.Scalar Real) 0.5)-            ))----main :: IO ()-main =---   exampleVolume---   examplePitchBend---   exampleVolumePitchBend1---   exampleKeyboard-   exampleKeyboardMulti---   exampleKeyboardFM---   exampleKeyboardDetuneFM---   exampleKeyboardFilter
src/Synthesizer/Dimensional/ALSA/MIDI.hs view
@@ -4,12 +4,18 @@ {-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.Dimensional.ALSA.MIDI where -import Synthesizer.EventList.ALSA.MIDI (Channel, Controller, Note(Note), Program, )+import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as AlsaPC import qualified Synthesizer.EventList.ALSA.MIDI as AlsaEL-import qualified Synthesizer.Storable.ALSA.MIDI as AlsaSt+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 as ALSA+import qualified Sound.ALSA.Sequencer.Event as Event +import qualified Synthesizer.Dimensional.MIDIValue as DMV+import qualified Synthesizer.MIDIValue as MV+ import qualified Synthesizer.Dimensional.Causal.Process    as Causal import qualified Synthesizer.Dimensional.Causal.Filter     as Filt @@ -30,6 +36,8 @@  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@@ -39,8 +47,8 @@ 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.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 @@ -63,20 +71,21 @@ 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 PreludeBase-import NumericPrelude+import NumericPrelude.Base hiding (id, (.), )+import NumericPrelude.Numeric import Prelude (RealFrac, )  -type Signal s v y yv =-   AmpSignal s (Amp.Dimensional v y) yv+type Signal s v y signal =+   AmpSignal s (Amp.Dimensional v y) signal -type AmpSignal s amp yv =-   SigA.T (Rate.Phantom s) amp (SigSt.T yv)+type AmpSignal s amp signal =+   SigA.T (Rate.Phantom s) amp signal  {- | This type ensures that all signals generated from the event list@@ -87,7 +96,7 @@  {-# INLINE runFilter #-} runFilter ::-   EventList.T AlsaEL.StrictTime (Maybe ALSA.Event) ->+   EventList.T AlsaEL.StrictTime [Event.T] ->    Filter s u t a -> Proc.T s u t a runFilter evs (Filter f) =    evalState f evs@@ -102,107 +111,93 @@       Filter (liftA2 (<*>) f x)  -{-# INLINE controllerValueToSample #-}-controllerValueToSample ::-   (Field.C y, Dim.C v) =>-   DN.T v y -> (DN.T v y, DN.T v y) -> Int -> y-controllerValueToSample amp (lower,upper) n =-   let k = fromIntegral n / 127-   in  DN.divToScalar (DN.scale (1-k) lower + DN.scale k upper) amp+{-# INLINE 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 getControllerSignal #-}-getControllerSignal ::-   (Storable y, Field.C y, Ord y, Dim.C u, Dim.C v) =>+{-# 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 y)-getControllerSignal chan ctrl bnd initial =+   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 .-           AlsaSt.controllerValuesToSignal (DN.divToScalar initial amp) .-           EventListTT.mapBody (controllerValueToSample amp bnd)) $+           AlsaPC.initWith+              (DMV.controllerLinear amp bnd) (DN.divToScalar initial amp)) $    AlsaEL.getControllerEvents chan ctrl  -{-# INLINE controllerValueToSampleExp #-}-controllerValueToSampleExp ::-   (Trans.C y, Dim.C v) =>-   DN.T v y -> (DN.T v y, DN.T v y) -> Int -> y-controllerValueToSampleExp amp (lower,upper) n =-   let k = fromIntegral n / 127-   in  DN.divToScalar lower amp ** (1-k) *-       DN.divToScalar upper amp ** k--{-# INLINE getControllerSignalExp #-}-getControllerSignalExp ::-   (Storable y, Trans.C y, Ord y, Dim.C u, Dim.C v) =>+{-# 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 y)-getControllerSignalExp chan ctrl bnd initial =+   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 .-           AlsaSt.controllerValuesToSignal (DN.divToScalar initial amp) .-           EventListTT.mapBody (controllerValueToSampleExp amp bnd)) $+           AlsaPC.initWith+              (DMV.controllerExponential amp bnd) (DN.divToScalar initial amp)) $    AlsaEL.getControllerEvents chan ctrl  -{-# INLINE pitchBendValueToSample #-}-pitchBendValueToSample ::-   (Trans.C y, Dim.C v) =>-   DN.T v y -> y -> DN.T v y -> Int -> y-pitchBendValueToSample amp range center n =-   DN.divToScalar center amp * range ** (fromIntegral n / 8192)- {- |-@getPitchBendSignal channel range center@:+@pitchBend channel range center@: emits frequencies on an exponential scale from @center/range@ to @center*range@. -}-{-# INLINE getPitchBendSignal #-}-getPitchBendSignal ::-   (Storable y, Trans.C y, Ord y, Dim.C u, Dim.C v) =>+{-# 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 y)-getPitchBendSignal chan range center =+   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 .-           AlsaSt.controllerValuesToSignal (DN.divToScalar center amp) .-           EventListTT.mapBody (pitchBendValueToSample amp range center)) $+           AlsaPC.initWith+              (DMV.pitchBend amp range center) (DN.divToScalar center amp)) $    AlsaEL.getSlice (AlsaEL.maybePitchBend chan) --   AlsaEL.getPitchBendEvents chan  -{-# INLINE getChannelPressureSignal #-}-getChannelPressureSignal ::-   (Storable y, Trans.C y, Ord y, Dim.C u, Dim.C v) =>+{-# 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 y)-getChannelPressureSignal chan maxVal initVal =+   Filter s u t (Signal s v y (AlsaPC.T y))+channelPressure chan maxVal initVal =    Filter $    liftM       (return . SigA.fromBody maxVal .-       AlsaSt.controllerValuesToSignal (DN.divToScalar initVal maxVal) .-       EventListTT.mapBody (controllerValueToSample maxVal (zero,maxVal))) $+       AlsaPC.initWith+          (DMV.controllerLinear maxVal (zero,maxVal))+          (DN.divToScalar initVal maxVal)) $    AlsaEL.getSlice (AlsaEL.maybeChannelPressure chan) --   AlsaEL.getPitchBendEvents chan  -{-# INLINE getFMSignalFromBendWheelPressure #-}-getFMSignalFromBendWheelPressure ::-   (Storable q, RealField.C q, Trans.C q, Module.C q q, Dim.C u) =>+{-# 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 q)-getFMSignalFromBendWheelPressure chan+   Filter s u q (Signal s Dim.Scalar q (sig q))+bendWheelPressure chan      pitchRange speed wheelDepth pressDepth =    pure       (\bend fm press  osci env ->@@ -216,11 +211,11 @@           in  Causal.apply                 (env <<< Causal.feedSnd modu <<< Causal.canonicalizeFlat)-                bend)+                (piecewiseConstant bend)) -    $: getPitchBendSignal chan (2^?(fromIntegral pitchRange/12)) (DN.scalar 1)-    $: getControllerSignal chan VoiceMsg.modulation (zero, DN.scalar wheelDepth) zero-    $: getChannelPressureSignal chan (DN.scalar pressDepth) 0+    $: 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)@@ -230,8 +225,8 @@ -- type LazyTime s = SigA.T (Rate.Phantom s) Amp.Abstract SigStV.LazySize -- type LazyTime s = SigA.T (Rate.Phantom s) Amp.Abstract AlsaEL.LazyTime -type Instrument s u v q y =-   ModulatedInstrument s u q (Signal s v q y)+type 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 ->@@ -245,7 +240,8 @@ chunkySizeFromLazyTime :: AlsaEL.LazyTime -> ChunkySize.T chunkySizeFromLazyTime =    Chunky.fromChunks .-   map (SigG.LazySize . fromInteger . NonNegW.toNumber) .+   map (SigG.LazySize . fromIntegral . NonNegW.toNumber) .+   concatMap AlsaEL.chopLongTime .    Chunky98.toChunks .    Chunky98.normalize @@ -259,11 +255,8 @@ renderInstrument instrument (Note pgm pitch vel dur) =    fmap ($ SigA.abstractFromBody $ chunkySizeFromLazyTime dur) $    instrument pgm-      (fromIntegral (VoiceMsg.fromVelocity vel - 64)/63)-      {- This is the default tuning according to MIDI 1.0 Detailed Specification -}-      (DN.scale-         (2 ** (fromIntegral (VoiceMsg.fromPitch pitch + 3 - 6*12) / 12))-         (DN.frequency 440))+      (MV.velocity vel)+      (DMV.frequencyFromPitch pitch)  {- | Instrument parameters are:@@ -275,34 +268,34 @@ makeInstrumentSounds ::    (Trans.C q) =>    Bank s Dim.Time q signal ->-   EventListTT.T time Note ->-   Proc.T s Dim.Time q (EventListTT.T time signal)+   EventList.T time [Note] ->+   Proc.T s Dim.Time q (EventList.T time [signal]) makeInstrumentSounds bank =-   EventListTT.mapBodyM (renderInstrument bank)+   EventList.mapBodyM (mapM (renderInstrument bank))  -{-# INLINE getNoteSignal #-}-getNoteSignal ::+{-# 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 s Dim.Time q (Signal s v q y)-getNoteSignal chunkSize amp chan instr =-   fmap (renderNoteSignal chunkSize amp) $-   prepareTones chan AlsaSt.errorNoProgram (const instr)+   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 getNoteSignal #-}-getNoteSignal ::+{-# 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 y))-getNoteSignal chunkSize amp chan instr =+   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 .@@ -314,45 +307,49 @@ -}  -{-# INLINE getNoteSignalModulated #-}-getNoteSignalModulated ::-   (RealFrac q, Storable y, Storable c,+{-# 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 c -> Signal s v q y) ->+      (AmpSignal s amp ctrl -> Signal s v q (SigSt.T y)) ->    Filter s Dim.Time q-      (AmpSignal s amp c -> Signal s v q y)-getNoteSignalModulated chunkSize amp chan instr =+      (AmpSignal s amp ctrl -> Signal s v q (SigSt.T y))+sequenceModulated chunkSize amp chan instr =    fmap (flip $ \ctrl ->-      renderNoteSignal chunkSize amp .-      applyModulation ctrl) $-   prepareTones chan AlsaSt.errorNoProgram (const instr)+      renderSequence chunkSize amp .+      applyModulator (applyModulation ctrl)) $+   prepareTones chan errorNoProgram (const instr) -{-# INLINE getNoteSignalModulated2 #-}-getNoteSignalModulated2 ::-   (RealFrac q, Storable y, Storable c0, Storable c1,+{-# 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 c0 -> AmpSignal s amp1 c1 -> Signal s v q y) ->+      (AmpSignal s amp0 ctrl0 -> AmpSignal s amp1 ctrl1 -> Signal s v q (SigSt.T y)) ->    Filter s Dim.Time q-      (AmpSignal s amp0 c0 -> AmpSignal s amp1 c1 -> Signal s v q y)-getNoteSignalModulated2 chunkSize amp chan instr =+      (AmpSignal s amp0 ctrl0 -> AmpSignal s amp1 ctrl1 -> Signal s v q (SigSt.T y))+sequenceModulated2 chunkSize amp chan instr =    fmap (\evs ctrl0 ctrl1 ->-      renderNoteSignal chunkSize amp .-      applyModulation ctrl1 .-      applyModulation ctrl0+      renderSequence chunkSize amp .+      applyModulator+         (applyModulation ctrl1 .+          applyModulation ctrl0)       $ evs) $-   prepareTones chan AlsaSt.errorNoProgram (const instr)+   prepareTones chan errorNoProgram (const instr)  -{-# INLINE getNoteSignalMultiModulated #-}-getNoteSignalMultiModulated ::+{-# INLINE sequenceMultiModulated #-}+sequenceMultiModulated ::    (RealFrac q, Storable y,     Module.C q y, Trans.C q, Dim.C v) =>    SVL.ChunkSize ->@@ -360,13 +357,12 @@    Channel ->    ModulatedInstrument s Dim.Time q instrument ->    Filter s Dim.Time q-      (EventListTT.T AlsaEL.LazyTime instrument ->-       EventListTT.T AlsaEL.LazyTime (Signal s v q y)) ->-   Filter s Dim.Time q (Signal s v q y)-getNoteSignalMultiModulated chunkSize amp chan instr modu =-   fmap (renderNoteSignal chunkSize amp) $-   (modu $:-    prepareTones chan AlsaSt.errorNoProgram (const instr))+      (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 ::@@ -375,7 +371,7 @@    Channel ->    Program ->    Bank s Dim.Time q signal ->-   Filter s Dim.Time q (EventListTT.T AlsaEL.LazyTime signal)+   Filter s Dim.Time q (EventList.T AlsaEL.StrictTime [signal]) prepareTones chan initPgm instr =    Filter $    fmap (makeInstrumentSounds instr .@@ -385,34 +381,43 @@  {-# INLINE applyModulation #-} applyModulation ::-   (Storable y) =>-   AmpSignal s amp y ->-   EventListTT.T AlsaEL.LazyTime (AmpSignal s amp y -> body) ->-   EventListTT.T AlsaEL.LazyTime body+   (CutG.Transform signal, CutG.NormalForm signal) =>+   AmpSignal s amp signal ->+   AlsaG.Modulator (AmpSignal s amp signal -> body) body applyModulation ctrl =-   flip evalState ctrl .-   EventListTT.mapM advanceModulationChunky gets+   AlsaG.Modulator ctrl advanceModulationChunk gets -{-# INLINE renderNoteSignal #-}-renderNoteSignal ::+{-# 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 ->-   EventListTT.T AlsaEL.LazyTime (Signal s u q y) ->-   Signal s u q y-renderNoteSignal chunkSize amp =+   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 .-   EventListTM.switchTimeR const .-   EventListTT.mapTime fromIntegral .-   AlsaSt.insertBreaks .-   EventListTT.mapBody (SigA.vectorSamples (flip DN.divToScalar amp))+   {- 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 ::-   (Storable y) =>-   AlsaEL.LazyTime -> State (AmpSignal s amp y) AlsaEL.LazyTime+   (CutG.Transform signal, CutG.NormalForm signal) =>+   AlsaEL.LazyTime -> State (AmpSignal s amp signal) AlsaEL.LazyTime advanceModulationChunky =    liftM Chunky98.fromChunks .    mapM advanceModulationChunk .@@ -420,25 +425,25 @@  {-# INLINE advanceModulationChunk #-} advanceModulationChunk ::-   (Storable y) =>-   NonNegW.Integer -> State (AmpSignal s amp y) NonNegW.Integer+   (CutG.Transform signal, CutG.NormalForm signal) =>+   AlsaEL.StrictTime -> State (AmpSignal s amp signal) AlsaEL.StrictTime advanceModulationChunk t = state $ \xs ->-   let ys = SigA.processBody (SigSt.drop (fromIntegral t)) xs-   in  (AlsaSt.evaluateVectorHead (SigA.body ys) t, ys)+   let ys = SigA.processBody (CutG.drop (fromIntegral t)) xs+   in  (AlsaG.evaluateVectorHead (SigA.body ys) t, ys)  -{-# INLINE getNoteSignalMultiProgram #-}-getNoteSignalMultiProgram ::+{-# 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 y) ->-   [Instrument s Dim.Time v q y] ->-   Filter s Dim.Time q (Signal s v q y)-getNoteSignalMultiProgram chunkSize amp chan initPgm instrs =+--   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 (renderNoteSignal chunkSize amp) $+   in  fmap (renderSequence chunkSize amp) $        prepareTones chan initPgm $        AlsaEL.getInstrumentFromArray bank initPgm
src/Synthesizer/Dimensional/ALSA/Play.hs view
@@ -14,21 +14,21 @@  import qualified Synthesizer.Storable.Signal as SigSt -import qualified Sound.Alsa as ALSA+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.RealField      as RealField+import qualified Algebra.RealRing      as RealRing -- import qualified Algebra.Field          as Field -- import qualified Algebra.Ring           as Ring  import Foreign.Storable (Storable, ) --- import NumericPrelude-import PreludeBase+-- import NumericPrelude.Numeric+import NumericPrelude.Base   type RenderedStorableSignal u t v y yv =@@ -40,61 +40,70 @@  {-# INLINE timeVoltageStorable #-} timeVoltageStorable ::-   (Module.C y yv, ALSA.SampleFmt yv, RealField.C t) =>+   (Module.C y yv, ALSA.SampleFmt yv, RealRing.C t) =>+   DN.Time t->    RenderedStorableSignal Dim.Time t Dim.Voltage y yv ->    IO ()-timeVoltageStorable sig =+timeVoltageStorable period sig =    let rate = DN.toNumberWithDimension Dim.frequency (SigA.actualSampleRate sig)-   in  Play.auto (RealField.round rate)+       per  = DN.toNumberWithDimension Dim.time period+   in  Play.auto per (RealRing.round rate)           (SigA.vectorSamples (DN.toNumberWithDimension Dim.voltage) sig)  {-# INLINE timeVoltageMonoStorableToInt16 #-} timeVoltageMonoStorableToInt16 ::-   (Storable y, RealField.C y, RealField.C t) =>+   (Storable y, RealRing.C y, RealRing.C t) =>+   DN.Time t->    RenderedStorableSignal Dim.Time t Dim.Voltage y y ->    IO ()-timeVoltageMonoStorableToInt16 sig =+timeVoltageMonoStorableToInt16 period sig =    let rate = DN.toNumberWithDimension Dim.frequency (SigA.actualSampleRate sig)-   in  Play.monoToInt16 (RealField.round rate)+       per  = DN.toNumberWithDimension Dim.time period+   in  Play.monoToInt16 per (RealRing.round rate)           (SigA.scalarSamples (DN.toNumberWithDimension Dim.voltage) sig)  {-# INLINE timeVoltageStereoStorableToInt16 #-} timeVoltageStereoStorableToInt16 ::-   (Storable y, Module.C y y, RealField.C y, RealField.C t) =>+   (Storable y, Module.C y y, RealRing.C y, RealRing.C t) =>+   DN.Time t->    RenderedStorableSignal Dim.Time t Dim.Voltage y (Stereo.T y) ->    IO ()-timeVoltageStereoStorableToInt16 sig =+timeVoltageStereoStorableToInt16 period sig =    let rate = DN.toNumberWithDimension Dim.frequency (SigA.actualSampleRate sig)-   in  Play.stereoToInt16 (RealField.round rate)+       per  = DN.toNumberWithDimension Dim.time period+   in  Play.stereoToInt16 per (RealRing.round rate)           (SigA.vectorSamples (DN.toNumberWithDimension Dim.voltage) sig)   {-# INLINE renderTimeVoltageStorable #-} renderTimeVoltageStorable ::-   (Module.C y yv, ALSA.SampleFmt yv, RealField.C t) =>+   (Module.C y yv, ALSA.SampleFmt yv, RealRing.C t) =>+   DN.Time t->    DN.T Dim.Frequency t ->    (forall s. Proc.T s Dim.Time t       (StorableSignal s Dim.Voltage y yv)) ->    IO ()-renderTimeVoltageStorable rate sig =-   timeVoltageStorable (SigA.render rate sig)+renderTimeVoltageStorable period rate sig =+   timeVoltageStorable period (SigA.render rate sig)  {-# INLINE renderTimeVoltageMonoStorableToInt16 #-} renderTimeVoltageMonoStorableToInt16 ::-   (Storable y, RealField.C y, RealField.C t) =>+   (Storable y, RealRing.C y, RealRing.C t) =>+   DN.Time t->    DN.T Dim.Frequency t ->    (forall s. Proc.T s Dim.Time t       (StorableSignal s Dim.Voltage y y)) ->    IO ()-renderTimeVoltageMonoStorableToInt16 rate sig =-   timeVoltageMonoStorableToInt16 (SigA.render rate sig)+renderTimeVoltageMonoStorableToInt16 period rate sig =+   timeVoltageMonoStorableToInt16 period (SigA.render rate sig)  {-# INLINE renderTimeVoltageStereoStorableToInt16 #-} renderTimeVoltageStereoStorableToInt16 ::-   (Storable y, Module.C y y, RealField.C y, RealField.C t) =>+   (Storable y, Module.C y y, RealRing.C y, RealRing.C t) =>+   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 rate sig =-   timeVoltageStereoStorableToInt16 (SigA.render rate sig)+renderTimeVoltageStereoStorableToInt16 period rate sig =+   timeVoltageStereoStorableToInt16 period (SigA.render rate sig)
+ src/Synthesizer/Dimensional/ALSA/Server.hs view
@@ -0,0 +1,18 @@+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 view
@@ -0,0 +1,89 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE Rank2Types #-}+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+++type Real = Double+++{-# INLINE withMIDIEvents #-}+withMIDIEvents ::+   Field.C t =>+   (DN.Time t -> DN.Frequency t -> a -> IO b) ->+   (EventList.T MIDIEv.StrictTime [Event.T] -> a) -> IO b+withMIDIEvents action proc =+   MIDIEv.withMIDIEvents+      (DN.toNumberWithDimension Dim.time periodTime :: Double)+      (DN.toNumberWithDimension Dim.frequency sampleRate :: Double) $+   action periodTime sampleRate . proc++{-# 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 period rate+   (FiltR.delay latency $: sig)
+ src/Synthesizer/Dimensional/ALSA/Server/Instrument.hs view
@@ -0,0 +1,208 @@+{-# 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 qualified Synthesizer.Dimensional.Wave as WaveD++import Synthesizer.Dimensional.Causal.Process ((<<<), )+import Synthesizer.Dimensional.Wave ((&*~), )+import Synthesizer.Dimensional.Process (($:), )+import Synthesizer.Dimensional.Signal ((&*^), )+import Control.Applicative (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.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, )+++{-# 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 view
@@ -0,0 +1,188 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE Rank2Types #-}+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.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.Process as Proc+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 Algebra.Ring           as Ring++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) ->+              (Filt.lowpassFromUniversal <<<+               filt (CtrlA.constant 10)+                 (DispA.mapExponential 4 (DN.frequency 1000) $+                  FiltA.envelope (SigA.restore depth) $+                  osci (SigA.restore speed)))+              `Causal.apply`+              FiltA.amplify 0.2 music)+           (OsciR.freqMod (WaveD.flat Wave.sine) zero)+           (CProc.runSynchronous2 Filt.universal)+--           FiltR.universal+           (MIDI.runFilter evs+              (liftA3 (,,)+                 (MIDI.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 view
@@ -0,0 +1,58 @@+{-# 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.Ring           as Ring++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 view
@@ -0,0 +1,56 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Functions for converting MIDI controller and key values+to something meaningful for signal processing.+-}+module Synthesizer.Dimensional.MIDIValue 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, DN.T v y) -> Int -> y+controllerLinear amp (lower,upper) n =+   let k = fromIntegral n / 127+   in  DN.divToScalar (DN.scale (1-k) lower + DN.scale k upper) 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 (lower,upper) n =+   let k = fromIntegral n / 127+   in  DN.divToScalar lower amp ** (1-k) *+       DN.divToScalar upper amp ** k++{-# 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 center amp * range ** (fromIntegral n / 8192)++{- |+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 view
@@ -1,45 +1,65 @@ {-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.EventList.ALSA.MIDI where -import qualified Sound.Alsa.Sequencer as ALSA+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.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.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.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 as ChannelMsg+import qualified Sound.MIDI.Message.Channel.Mode as Mode+import qualified Sound.MIDI.ALSA as MALSA +import qualified Data.Accessor.Basic as Acc+import Data.Accessor.Basic ((^.), )+ import System.IO.Unsafe (unsafeInterleaveIO, ) import Control.Concurrent (threadDelay) import System.Time (ClockTime(TOD), getClockTime, )-import Control.Exception (bracket, ) -import Control.Monad.Trans.State (State, state, evalState, modify, get, gets, put, )+import 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.Class   as NonNeg import qualified Numeric.NonNegative.Wrapper as NonNegW-import qualified Numeric.NonNegative.ChunkyPrivate as NonNegChunky-import Data.Monoid (Monoid, mappend, mempty, )+import qualified 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.ToRational as ToRational+import qualified Algebra.RealField  as RealField+import qualified Algebra.Field      as Field -- import qualified Algebra.Additive as Additive  import Data.Array (Array, listArray, (!), bounds, inRange, ) -import Data.Tuple.HT (mapPair, mapSnd, )+import qualified Data.List.HT as ListHT+import Data.Tuple.HT (mapPair, mapFst, mapSnd, ) import Data.Maybe.HT (toMaybe, )-import Data.Maybe (isNothing, )+import Data.Maybe (catMaybes, isNothing, )+import Control.Monad.HT ((<=<), ) import Control.Monad (liftM, liftM2, guard, ) -import NumericPrelude-import PreludeBase hiding (break, )+import qualified Data.List as List +import NumericPrelude.Numeric+import NumericPrelude.Base+import qualified Prelude as P+ -- import Debug.Trace (trace, )  @@ -64,9 +84,9 @@  {- We cannot easily turn this into a custom type,-since we need Maybe ALSA.Event sometimes.+since we need Maybe Event.T sometimes. -}-type StampedEvent time = (time, ALSA.Event)+type StampedEvent time = (time, Event.T)   {- |@@ -75,80 +95,125 @@ We ignore ALSA time stamps and use the time of fetching the event, because I don't know whether the ALSA time stamps are in sync with getClockTime. -}-getStampedEvent :: Field.C time =>-   ALSA.SndSeq -> IO (StampedEvent time)+getStampedEvent ::+   (Field.C time, SndSeq.AllowInput mode) =>+   SndSeq.T mode -> IO (StampedEvent time) getStampedEvent h =    liftM2 (,)       getTimeSeconds-      (ALSA.event_input h)+      (Event.input h)  {- | only use it for non-blocking sequencers -}-getWaitingStampedEvents :: Field.C time =>-   ALSA.SndSeq -> IO [StampedEvent time]+getWaitingStampedEvents ::+   (Field.C time, SndSeq.AllowInput mode) =>+   SndSeq.T mode -> IO [StampedEvent time] getWaitingStampedEvents h =    let loop =-          ALSA.alsa_catch+          AlsaExc.catch              (liftM2 (:) (getStampedEvent h) loop)              (const $ return [])    in  loop +{- | only use it for blocking sequencers -}+getEventsUntilEcho_ ::+   (Field.C time, SndSeq.AllowInput mode) =>+   SndSeq.T mode -> IO [StampedEvent time]+getEventsUntilEcho_ h =+   let loop = do+          ev <- Event.input h+          let t =+                 case Event.timestamp ev of+                    Event.RealTime rt ->+--                       realToFrac $+                       fromRational' $ toRational $+                       RealTime.toDouble rt+                    _ -> error "unsupported time stamp type"+          case Event.body ev of+             Event.CustomEv Event.Echo _ -> return []+             _ -> liftM ((t,ev):) loop+   in  loop -getWaitingEvents :: ALSA.SndSeq -> IO [ALSA.Event]+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+++getWaitingEvents ::+   (SndSeq.AllowInput mode) =>+   SndSeq.T mode -> IO [Event.T] getWaitingEvents h =    let loop =-          ALSA.alsa_catch-             (liftM2 (:) (ALSA.event_input h) loop)+          AlsaExc.catch+             (liftM2 (:) (Event.input h) loop)              (const $ return [])    in  loop   -{--This should be a parameter for the functions, that use it.-It is essential for controlling the maximum chunk size.+type StrictTime = NonNegW.Integer++{- |+Returns a list of non-zero times. -}-beat :: Field.C time => time-beat = 0.01+{-# INLINE chopLongTime #-}+chopLongTime :: StrictTime -> [StrictTime]+chopLongTime n =+   let d = NonNegW.fromNumber $ fromIntegral (maxBound :: Int)+       (q,r) = P.divMod n d+   in  List.genericReplicate q d +++       if r /= NonNeg.zero then [r] else []  -type StrictTime = NonNegW.Integer- {--ghc -i:src -e 'withMIDIEventsNonblock 44100 print' src/Synthesizer/Storable/ALSA/MIDI.hs+ghc -i:src -e 'withMIDIEvents 44100 print' src/Synthesizer/Storable/ALSA/MIDI.hs -} {--as a quick hack, we neglect the ALSA time stamp and use getTime or so- Maybe it is better to not use type variable for sample rate, because ALSA supports only integers, and if ALSA sample rate and sample rate do not match due to rounding errors, then play and event fetching get out of sync over the time. -}-withMIDIEventsNonblock :: (RealField.C time) =>-   time -> (EventList.T StrictTime (Maybe ALSA.Event) -> IO a) -> IO a-withMIDIEventsNonblock =-   withMIDIEventsNonblockWaitGrouped+withMIDIEvents :: (RealField.C time) =>+   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) =>-   time -> (EventList.T StrictTime (Maybe ALSA.Event) -> IO a) -> IO a-withMIDIEventsNonblockWaitGrouped rate proc =-   withInPort ALSA.Nonblock $ \ h _p ->+   time -> time ->+   (EventList.T StrictTime [Event.T] -> IO a) -> IO a+withMIDIEventsNonblockWaitGrouped beat rate proc =+   withInPort SndSeq.Nonblock $ \ h _p ->    do start <- getTimeSeconds       l <- lazySequence $               flip map (iterate (beat+) start) $ \t ->                  wait t >>                  liftM-                    (\evs -> (t, Nothing : map Just evs))+                    (\evs -> (t, evs))                     (getWaitingEvents h) {-                  liftM2 (,)                     getTimeSeconds-                    (liftM (\evs -> Nothing : map Just evs) $-                     getWaitingEvents h)+                    (getWaitingEvents h) -}       proc $-         EventList.flatten $          discretizeTime rate $          AbsEventList.fromPairList l @@ -158,9 +223,10 @@ but ones xruns occur, this implies more and more xruns. -} withMIDIEventsNonblockWaitDefer :: (RealField.C time) =>-   time -> (EventList.T StrictTime (Maybe ALSA.Event) -> IO a) -> IO a-withMIDIEventsNonblockWaitDefer rate proc =-   withInPort ALSA.Nonblock $ \ h _p ->+   time -> time ->+   (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a+withMIDIEventsNonblockWaitDefer beat rate proc =+   withInPort SndSeq.Nonblock $ \ h _p ->    do start <- getTimeSeconds       l <- lazySequence $               flip map (iterate (beat+) start) $ \t ->@@ -183,9 +249,10 @@ (Or debug output slows down processing.) -} withMIDIEventsNonblockWaitSkip :: (RealField.C time) =>-   time -> (EventList.T StrictTime (Maybe ALSA.Event) -> IO a) -> IO a-withMIDIEventsNonblockWaitSkip rate proc =-   withInPort ALSA.Nonblock $ \ h _p ->+   time -> time ->+   (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a+withMIDIEventsNonblockWaitSkip beat rate proc =+   withInPort SndSeq.Nonblock $ \ h _p ->    do start <- getTimeSeconds       l <- lazySequence $            flip map (iterate (beat+) start) $ \t ->@@ -204,9 +271,10 @@          AbsEventList.fromPairList $ concat l  withMIDIEventsNonblockWaitMin :: (RealField.C time) =>-   time -> (EventList.T StrictTime (Maybe ALSA.Event) -> IO a) -> IO a-withMIDIEventsNonblockWaitMin rate proc =-   withInPort ALSA.Nonblock $ \ h _p ->+   time -> time ->+   (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a+withMIDIEventsNonblockWaitMin beat rate proc =+   withInPort SndSeq.Nonblock $ \ h _p ->    do start <- getTimeSeconds       l <- lazySequence $               flip map (iterate (beat+) start) $ \t ->@@ -227,9 +295,10 @@          AbsEventList.fromPairList $ concat l  withMIDIEventsNonblockConstantPause :: (RealField.C time) =>-   time -> (EventList.T StrictTime (Maybe ALSA.Event) -> IO a) -> IO a-withMIDIEventsNonblockConstantPause rate proc =-   withInPort ALSA.Nonblock $ \ h _p ->+   time -> time ->+   (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a+withMIDIEventsNonblockConstantPause beat rate proc =+   withInPort SndSeq.Nonblock $ \ h _p ->    do l <- ioToLazyList $ threadDelay (round $ flip asTypeOf rate $ beat*1e6) >>               liftM2 (:)                  (liftM (\t->(t,Nothing)) getTimeSeconds)@@ -239,9 +308,10 @@          AbsEventList.fromPairList $ concat l  withMIDIEventsNonblockSimple :: (RealField.C time) =>-   time -> (EventList.T StrictTime ALSA.Event -> IO a) -> IO a-withMIDIEventsNonblockSimple rate proc =-   withInPort ALSA.Nonblock $ \ h _p ->+   time -> time ->+   (EventList.T StrictTime Event.T -> IO a) -> IO a+withMIDIEventsNonblockSimple beat rate proc =+   withInPort SndSeq.Nonblock $ \ h _p ->    do l <- ioToLazyList $               threadDelay (round $ flip asTypeOf rate $ beat*1e6) >>               getWaitingStampedEvents h@@ -249,30 +319,80 @@          discretizeTime rate $          AbsEventList.fromPairList $ concat l +withMIDIEventsBlockEcho :: (RealField.C time) =>+   time -> time ->+   (EventList.T StrictTime [Event.T] -> IO a) -> IO a+withMIDIEventsBlockEcho beat rate proc =+   withInPort SndSeq.Block $ \ h p ->+   Queue.with h $ \ q ->+   do {-+      info <- PortInfo.get h p+      PortInfo.setTimestamping info True+      PortInfo.setTimestampReal info True+      PortInfo.setTimestampQueue info q+      PortInfo.set h p info+      -}++      Queue.control h q Event.QueueStart 0 Nothing+      Event.drainOutput h++      c <- Client.getId h+      l <-+         lazySequence $+         flip map (iterate (beat+) 0) $ \t -> do+            Event.output h $+               makeEcho c q p (t+beat) (Event.Custom 0 0 0)+            Event.drainOutput h+            liftM+               (\evs -> (t, evs))+               (getEventsUntilEcho c h)++      proc $+         discretizeTime rate $+         AbsEventList.fromPairList l++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) =>-   time -> (EventList.T StrictTime ALSA.Event -> IO a) -> IO a+   time ->+   (EventList.T StrictTime Event.T -> IO a) -> IO a withMIDIEventsBlock rate proc =-   withInPort ALSA.Block $ \ h _p ->+   withInPort SndSeq.Block $ \ h _p ->    do l <- ioToLazyList $ getStampedEvent h       proc $          discretizeTime rate $          AbsEventList.fromPairList l  withInPort ::-   ALSA.BlockMode -> (ALSA.SndSeq -> ALSA.Port -> IO t) -> IO t+   SndSeq.BlockMode -> (SndSeq.T SndSeq.DuplexMode -> Port.T -> IO t) -> IO t withInPort blockMode act =-   bracket-      (ALSA.open ALSA.default_seq_name ALSA.open_input blockMode)-      (ALSA.close) $-   \h ->-   ALSA.set_client_name h "Haskell-Synthesizer" >>-   (bracket-      (ALSA.create_simple_port h "listener"-          (ALSA.caps [ALSA.cap_write, ALSA.cap_subs_write])-          ALSA.type_midi_generic)-      (ALSA.delete_port h) $-   \p ->-   act h p)+   SndSeq.with SndSeq.defaultName blockMode $ \h ->+   Client.setName h "Haskell-Synthesizer" >>+   Port.withSimple h "listener"+      (Port.caps [Port.capWrite, Port.capSubsWrite])+      Port.typeMidiGeneric+      (act h)  {- | We first discretize the absolute time values,@@ -290,7 +410,7 @@  -- * event filters -type Filter = State (EventList.T StrictTime (Maybe ALSA.Event))+type Filter = State (EventList.T StrictTime [Event.T])   {-@@ -298,9 +418,14 @@ 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.@@ -309,52 +434,12 @@ but hopefully gain efficiency by larger blocks. -} getSlice ::-   (ALSA.Event -> Maybe a) ->-   Filter (EventListTT.T LazyTime a)+   (Event.T -> Maybe a) ->+   Filter (EventList.T StrictTime [a]) getSlice f =-   fmap-      (EventListTT.catMaybesR .-       flip EventListTM.snocTime NonNegChunky.zero .-       EventList.mapTime NonNegChunky.fromNumber) $-   state (partitionMaybeBeat f)---   state (partitionMaybe (maybe (Just Nothing) (fmap Just . f)))--{- |-Move all elements that are mapped to @Just@ into another list.--}-partitionMaybe ::-   (a -> Maybe b) -> EventList.T StrictTime a ->-   (EventList.T StrictTime b, EventList.T StrictTime a)-partitionMaybe f =-   mapPair (EventList.catMaybes, EventList.catMaybes) .-   EventList.foldrPair (\t a ->-      let (x,y) =-             case f a of-                Just b  -> (Just b,  Nothing)-                Nothing -> (Nothing, Just a)-      in  mapPair (EventList.cons t x, EventList.cons t y))-      (EventList.empty, EventList.empty)--{- |-Move all elements that are mapped to @Just@ into another list.-@Nothing@ elements in the source list-are maintained in both result lists as laziness breaks.--}-partitionMaybeBeat ::-   (a -> Maybe b) -> EventList.T StrictTime (Maybe a) ->-   (EventList.T StrictTime (Maybe b), EventList.T StrictTime (Maybe a))-partitionMaybeBeat f =-   mapPair (EventList.catMaybes, EventList.catMaybes) .-   EventList.foldrPair (\t a0 ->-      let (x,y) =-             case a0 of-                Nothing -> (Just Nothing, Just Nothing)-                Just a1 ->-                   case f a1 of-                      Just b  -> (Just $ Just b,  Nothing)-                      Nothing -> (Nothing, Just $ Just a1)-      in  mapPair (EventList.cons t x, EventList.cons t y))-      (EventList.empty, EventList.empty)+   state $+   EventList.unzip .+   fmap (ListHT.partitionMaybe f)   type Channel    = ChannelMsg.Channel@@ -364,46 +449,59 @@ type Program    = ChannelMsg.Program  -maybeController :: Channel -> Controller -> ALSA.Event -> Maybe (Int, Int)-maybeController chan ctrl e =-   let ALSA.TickTime n = ALSA.ev_timestamp e-   in  case ALSA.ev_data e of-          ALSA.CtrlEv ALSA.Controller c ->-             toMaybe-                (fromIntegral (ALSA.ctrl_channel c) == ChannelMsg.fromChannel chan &&-                 fromIntegral (ALSA.ctrl_param   c) == ChannelMsg.fromController ctrl)-                (fromIntegral n, fromIntegral $ ALSA.ctrl_value c)-          _ -> Nothing+maybeAnyController ::+   Channel -> Event.T -> Maybe (Controller, Int)+maybeAnyController chan e = do+   -- let Event.TickTime n = Event.timestamp e+   Event.CtrlEv Event.Controller c <- Just $ Event.body e+   guard (c ^. MALSA.ctrlChannel  ==  chan)+   MALSA.Controller cn cv <- Just $ c ^. MALSA.ctrlControllerMode+   return (cn, cv) +maybeController :: Channel -> Controller -> Event.T -> Maybe Int+maybeController chan ctrl e = do+   (c,n) <- maybeAnyController chan e+   guard (ctrl==c)+   return n + getControllerEvents ::    Channel -> Controller ->-   Filter (EventListTT.T LazyTime Int)+   Filter (EventList.T StrictTime [Int]) getControllerEvents chan ctrl =-   getSlice (fmap snd . maybeController chan ctrl)+   getSlice (maybeController chan ctrl) +{-+getControllerEvents ::+   Channel -> Controller ->+   Filter (EventList.T StrictTime (Maybe Int))+getControllerEvents chan ctrl =+   fmap (fmap (fmap snd . ListHT.viewR)) $+   getSlice (maybeController chan ctrl)+-} -maybePitchBend :: Channel -> ALSA.Event -> Maybe Int+maybePitchBend :: Channel -> Event.T -> Maybe Int maybePitchBend chan e =-   case ALSA.ev_data e of-      ALSA.CtrlEv ALSA.PitchBend c ->+   case Event.body e of+      Event.CtrlEv Event.PitchBend c ->          toMaybe-            (fromIntegral (ALSA.ctrl_channel c) == ChannelMsg.fromChannel chan)-            (fromIntegral $ ALSA.ctrl_value c)+            (c ^. MALSA.ctrlChannel == chan)+            (c ^. MALSA.ctrlValue)       _ -> Nothing -maybeChannelPressure :: Channel -> ALSA.Event -> Maybe Int+maybeChannelPressure :: Channel -> Event.T -> Maybe Int maybeChannelPressure chan e =-   case ALSA.ev_data e of-      ALSA.CtrlEv ALSA.ChanPress c ->+   case Event.body e of+      Event.CtrlEv Event.ChanPress c ->          toMaybe-            (fromIntegral (ALSA.ctrl_channel c) == ChannelMsg.fromChannel chan)-            (fromIntegral $ ALSA.ctrl_value c)+            (c ^. MALSA.ctrlChannel == chan)+            (c ^. MALSA.ctrlValue)       _ -> Nothing   data NoteBoundary a =      NoteBoundary Pitch Velocity a+   | AllNotesOff    deriving (Eq, Show)  data Note = Note Program Pitch Velocity LazyTime@@ -415,180 +513,153 @@ -} getNoteEvents ::    Channel ->-   Filter (EventListTT.T LazyTime (Either Program (NoteBoundary Bool)))+   Filter (EventList.T StrictTime [Either Program (NoteBoundary Bool)]) getNoteEvents chan =    getSlice $ \e ->-      case ALSA.ev_data e of-         ALSA.NoteEv notePart note ->-            do guard (fromIntegral (ALSA.note_channel note) ==-                      ChannelMsg.fromChannel chan)-               (vel,press) <--                  case notePart of-                     ALSA.NoteOn ->-                        return $-                        let v = ALSA.note_velocity note-                        in  if v==0-                              then (64, False)-                              else (fromIntegral v, True)-                     ALSA.NoteOff ->-                        return-                           (fromIntegral $ ALSA.note_velocity note, False)+      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  -> Just True+                     Event.NoteOff -> Just False                      _ -> Nothing                return $ Right $ NoteBoundary-                  (ChannelMsg.toPitch $ fromIntegral $ ALSA.note_note note)-                  (ChannelMsg.toVelocity vel)-                  press-         ALSA.CtrlEv ALSA.PgmChange ctrl ->-            do guard (fromIntegral (ALSA.ctrl_channel ctrl) ==-                      ChannelMsg.fromChannel chan)-               return $ Left $ ChannelMsg.toProgram $-                  fromIntegral $ ALSA.ctrl_value ctrl+                  (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          _ -> Nothing  embedPrograms ::    Program ->-   EventListTT.T LazyTime (Either Program (NoteBoundary Bool)) ->-   EventListTT.T LazyTime (NoteBoundary (Maybe Program))+   EventList.T StrictTime [Either Program (NoteBoundary Bool)] ->+   EventList.T StrictTime [NoteBoundary (Maybe Program)] embedPrograms initPgm =-   EventListTT.catMaybesR .+   fmap catMaybes .    flip evalState initPgm .-   EventListTT.mapBodyM-      (either+   traverse (traverse+      (-- 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)-          (\(NoteBoundary p v press) ->-              gets (Just . NoteBoundary p v . toMaybe press)))+          (\bnd ->+             gets (Just .+             case bnd of+                AllNotesOff -> const AllNotesOff+                NoteBoundary p v press ->+                   NoteBoundary p v . toMaybe press))))  -matchNoteEventsAlt ::-   EventListTT.T LazyTime (NoteBoundary (Maybe Program)) ->-   EventListTT.T LazyTime Note-matchNoteEventsAlt =-   EventListTT.catMaybesR .-   matchNoteEventsMaybe .-   EventListTT.mapBody Just--matchNoteEventsMaybe ::-   EventListTT.T LazyTime (Maybe (NoteBoundary (Maybe Program))) ->-   EventListTT.T LazyTime (Maybe Note)-matchNoteEventsMaybe =-   EventListMT.mapTimeTail $ \r0 ->-   flip (EventListMT.switchBodyL EventListBT.empty) r0 $-   \ev r1 ->-      case ev of-         Nothing ->-            EventListMT.consBody Nothing $-            matchNoteEventsMaybe r1-         Just (NoteBoundary pitchOn velOn pressOn) ->-            let (obj,r2) =-                   case pressOn of-                     Nothing -> (Nothing, r1) -- isolated NoteOff event-                     Just pgm ->-                        let (prefix,_noteOff,suffix) =-                               break (maybe False-                                  (\(NoteBoundary pitchOff _velOff pressOff) ->-                                     pitchOn == pitchOff && isNothing pressOff)) r1-                        in  (Just (Note pgm pitchOn velOn (lazyDuration prefix)),-                             EventListTM.prependBodyEnd-                                (EventListTM.snocBody prefix Nothing) suffix)-            in  EventListMT.consBody obj $-                matchNoteEventsMaybe r2--{--We need a version of 'append' that is specialised to the lazy time type.-Otherwise @append (2 /. 'a' ./ 4 /. 'b' ./ 3 /. undefined) undefined@-does not return the @'b'@.-This makes 'testKeyboard7' omitting the last defined note.-In realtime performance this leads to the effect,-that notes are only played after the key is released.--} matchNoteEvents ::-   EventListTT.T LazyTime (NoteBoundary (Maybe Program)) ->-   EventListTT.T LazyTime Note+   EventList.T StrictTime [NoteBoundary (Maybe Program)] ->+   EventList.T StrictTime [Note] matchNoteEvents =-   EventListTT.catMaybesR .-   matchNoteEventsCore+   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 ::-   EventListTT.T LazyTime (NoteBoundary (Maybe Program)) ->-   EventListTT.T LazyTime (Maybe Note)-matchNoteEventsCore =-   EventListMT.mapTimeTail $ \r0 ->-   flip (EventListMT.switchBodyL EventListBT.empty) r0 $-   \(NoteBoundary pitchOn velOn pressOn) r1 ->-   let (obj,r2) =-          case pressOn of-             Nothing -> (Nothing, r1) -- isolated NoteOff event-             Just pgm ->-               let (prefix,_noteOff,suffix) =-                      break (\(NoteBoundary pitchOff _velOff pressOff) ->-                          pitchOn == pitchOff && isNothing pressOff) r1-               in  (Just $ Note pgm pitchOn velOn (lazyDuration prefix),-                    appendTTLazy prefix suffix)-   in  EventListMT.consBody obj $-       matchNoteEventsCore r2--{- |-This is like 'EventListTT.append' but more lazy,-because it uses the structure of the time value.--}-appendTTLazy ::-   (Monoid lazyTime) =>-   EventListTT.T lazyTime body ->-   EventListTT.T lazyTime body ->-   EventListTT.T lazyTime body-appendTTLazy xs ys =-   EventListTT.foldr-      (\t zs ->-          let (d,ws) = either EventListMT.viewTimeL ((,) mempty) zs-          in  EventListMT.consTime (mappend t d) ws)-      (\b zs -> Right $ EventListMT.consBody b zs)-      (Left ys) xs--lazyDuration ::-   (Monoid lazyTime) =>-   EventListTT.T lazyTime body -> lazyTime-lazyDuration =-   foldr mappend mempty . EventListTT.getTimes+   (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  -{- |-Find the first matching body element.-Event list must be infinite or it must contain a matching body element,-otherwise 'body' and the end of the returned list will be undefined.+{-+durationRemove Char.isUpper ("a" ./ 3 /. "bf" ./ 5 /. "aCcd" ./ empty :: Data.EventList.Relative.BodyBody.T StrictTime [Char]) -}-break ::-   (body -> Bool) -> EventListTT.T LazyTime body ->-   (EventListTT.T LazyTime body, body, EventListTT.T LazyTime body)-break p =-   EventListMT.switchTimeL $ \t xs ->-      let (prefix,suffix) = EventListBT.span (not . p) xs-          (b,r) =-             EventListMT.switchBodyL-                (error "no matching body element found",-                 error "list ended before matching element found")-                (,)-                suffix-      in  (EventListMT.consTime t prefix, b, r)- {- |-Remove the first matching body element.-Event list must be infinite or it must contain a matching body element,-otherwise 'body' and the end of the returned list will be undefined.+Search for specific event,+return its time stamp and remove it. -}-remove ::-   (body -> Bool) -> EventListTT.T LazyTime body ->-   (body, EventListTT.T LazyTime body)-remove p =-   EventListMT.switchTimeL $ \t xs ->-      let (prefix,suffix) = EventListBT.span p xs-          (b,r) =-             EventListMT.switchBodyL-                (error "no matching body element found",-                 error "list ended before matching element found")-                (,)-                suffix-      in  (b, EventListTT.append (EventListMT.consTime t prefix) r)+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@@ -614,24 +685,3 @@ lazySequence [] = return [] lazySequence (m:ms) =    unsafeInterleaveIO $ liftM2 (:) m $ lazySequence ms---dump :: IO ()-dump =-   do putStrLn "Starting."-      h <- ALSA.open ALSA.default_seq_name ALSA.open_input ALSA.Block-      ALSA.set_client_name h "Haskell-Synthesizer"-      putStrLn "Created sequencer."-      p <- ALSA.create_simple_port h "one"-             (ALSA.caps [ALSA.cap_write, ALSA.cap_subs_write]) ALSA.type_midi_generic-      let loop = do putStrLn "waiting for an event:"-                    e <- ALSA.event_input h-                    print e-                    loop-      loop-      ALSA.delete_port h p-      putStrLn "Deleted ports."-      ALSA.close h-      putStrLn "Closed sequencer."--
+ src/Synthesizer/Generic/ALSA/MIDI.hs view
@@ -0,0 +1,354 @@+{-# 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,+    chopLongTime, )++import qualified Sound.MIDI.Message.Channel as ChannelMsg++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+         (fromInteger $ NonNegW.toNumber t) y) $+   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 Arranger signal =+   EventList.T NonNegW.Int signal -> 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) =>+   Arranger signal ->+   Channel ->+   Program ->+   Modulator Note signal ->+   Filter signal+sequenceCore arranger chan initPgm md =+   fmap (arranger .+         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) =>+   Arranger signal ->+   Channel ->+   Instrument y signal ->+   Filter signal+sequence arranger chan instr =+   sequenceCore arranger chan errorNoProgram+      (Modulator () return+          (return . renderInstrumentIgnoreProgram instr))+++{-# INLINE sequenceModulated #-}+sequenceModulated ::+   (CutG.Transform ctrl, CutG.NormalForm ctrl,+    Monoid signal, Trans.C y) =>+   Arranger signal ->+   ctrl ->+   Channel ->+   (ctrl -> Instrument y signal) ->+   Filter signal+sequenceModulated arranger ctrl chan instr =+   sequenceCore arranger chan errorNoProgram+      (Modulator ctrl advanceModulationChunk+          (\note -> gets $ \c -> renderInstrumentIgnoreProgram (instr c) note))+++{-# INLINE sequenceMultiModulated #-}+sequenceMultiModulated ::+   (Monoid signal, Trans.C y) =>+   Arranger signal ->+   Channel ->+   instrument ->+   Modulator (instrument, Note) (Instrument y signal, Note) ->+   Filter signal+sequenceMultiModulated arranger chan instr+      (Modulator modulatorInit modulatorTime modulatorBody) =+   sequenceCore arranger chan errorNoProgram+      (Modulator modulatorInit modulatorTime+          (fmap (uncurry renderInstrumentIgnoreProgram) .+           modulatorBody .+           (,) instr))++{-# INLINE sequenceMultiProgram #-}+sequenceMultiProgram ::+   (Monoid signal, Trans.C y) =>+   Arranger signal ->+   Channel ->+   Program ->+   [Instrument y signal] ->+   Filter signal+sequenceMultiProgram arranger chan initPgm instrs =+   let bank = makeInstrumentArray instrs+   in  sequenceCore arranger chan initPgm+          (Modulator () return+              (return . renderInstrument+                 (getInstrumentFromArray bank initPgm)))++{-# INLINE sequenceModulatedMultiProgram #-}+sequenceModulatedMultiProgram ::+   (CutG.Transform ctrl, CutG.NormalForm ctrl,+    Monoid signal, Trans.C y) =>+   Arranger signal ->+   ctrl ->+   Channel ->+   Program ->+   [ctrl -> Instrument y signal] ->+   Filter signal+sequenceModulatedMultiProgram arranger ctrl chan initPgm instrs =+   let bank = makeInstrumentArray instrs+   in  sequenceCore arranger chan initPgm+          (Modulator+              ctrl advanceModulationChunk+              (\note -> gets $ \c -> renderInstrument+                 (\pgm -> getInstrumentFromArray bank initPgm pgm c) note))
+ src/Synthesizer/MIDIValue.hs view
@@ -0,0 +1,57 @@+{-# 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 qualified Algebra.Additive       as Additive++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/PiecewiseConstant/ALSA/MIDI.hs view
@@ -0,0 +1,316 @@+{- |+Convert MIDI events of a MIDI controller to a control signal.+-}+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.PiecewiseConstant.ALSA.MIDI (+   T,+   subdivide,+   subdivideInt,+   duration,+   zipWith,++   initWith,+   controllerLinear,+   controllerExponential,+   pitchBend,+   channelPressure,+   BendModulation(BendModulation),+   shiftBendModulation,+   bendWheelPressure,+   ) where++import qualified Synthesizer.EventList.ALSA.MIDI as Ev+import Synthesizer.EventList.ALSA.MIDI (LazyTime, StrictTime, Filter, Channel, )++import qualified Synthesizer.MIDIValue as MV+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg++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 Numeric.NonNegative.Class ((-|), )++import qualified Algebra.Transcendental as Trans+import qualified Algebra.RealRing      as RealRing+import qualified Algebra.Field          as Field+import qualified Algebra.Ring           as Ring+import qualified Algebra.Additive       as Additive++import Control.Monad.Trans.State (evalState, get, put, )+import Control.Monad (liftM, liftM2, )+import Data.Traversable (traverse, )+import Data.Foldable (traverse_, )+import Control.DeepSeq (NFData, rnf, )++import Data.Maybe.HT (toMaybe, )+import qualified Data.List as List+import Data.Maybe (Maybe(Just, Nothing), maybe, )+import Data.Ord (Ordering(LT,GT,EQ), min, compare, )+import Data.Bool (Bool(False,True), (||), )+import Data.Function ((.), ($), flip, id, )++import NumericPrelude.Numeric+import Prelude as P+   (Eq, Show, uncurry, fmap, return, (>>), )+++type T = EventListBT.T StrictTime+++duration :: T y -> LazyTime+duration =+   NonNegChunky.fromChunks . EventListBT.getTimes++{-+ToDo: move to PiecewiseConstant.Signal or so.+-}+{-# INLINE subdivide #-}+subdivide ::+   EventListBT.T LazyTime y -> EventListBT.T StrictTime y+subdivide =+   EventListBT.foldrPair+      (\y lt r ->+         List.foldr+            (\dt ->+               EventListMT.consBody y .+               EventListMT.consTime dt) r $+         NonNegChunky.toChunks (NonNegChunky.normalize lt))+      EventListBT.empty++{- |+Subdivide lazy times into chunks that fit into the number range+representable by @Int@.+-}+{-# INLINE subdivideInt #-}+subdivideInt ::+   EventListBT.T LazyTime y -> EventListBT.T NonNegW.Int y+subdivideInt =+   EventListBT.mapTime+      (NonNegW.fromNumber .+       fromIntegral .+       NonNegW.toNumber) .+   subdivide .+   EventListBT.mapTime+      (NonNegChunky.fromChunks .+       List.concatMap Ev.chopLongTime .+       NonNegChunky.toChunks)+++{-# 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 (Ev.maybePitchBend 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 (Ev.maybeChannelPressure chan)+++data BendModulation a = BendModulation a a+   deriving (P.Show, P.Eq)++instance (NFData a) => NFData (BendModulation a) where+   rnf (BendModulation bend depth) =+      case rnf bend of () -> rnf depth+++{- |+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.+-}+shiftBendModulation ::+   (Ring.C a) =>+   a -> BendModulation a -> BendModulation a+shiftBendModulation k (BendModulation bend depth) =+   BendModulation (k*bend) depth+++_subdivideMaybe ::+   EventListBT.T LazyTime y -> EventListBT.T StrictTime (Maybe y)+_subdivideMaybe =+   EventListBT.foldrPair+      (\y lt r ->+         case NonNegChunky.toChunks (NonNegChunky.normalize lt) of+            [] -> r+            (t:ts) ->+               EventListBT.cons (Just y) t $+               List.foldr (EventListBT.cons Nothing) r ts)+      EventListBT.empty++{- |+When a lazy time value is split into chunks+then do not just replicate the sample for the whole time,+but insert 'Nothing's.+-}+{-# INLINE subdivideMaybe #-}+subdivideMaybe ::+   EventListTT.T LazyTime y ->+   EventListTT.T StrictTime (Maybe y)+subdivideMaybe =+   EventListTT.foldr+      (\lt r ->+         uncurry EventListMT.consTime $+         case NonNegChunky.toChunks (NonNegChunky.normalize lt) of+            [] ->+               (NonNegW.fromNumber zero, r)+            (t:ts) ->+               (t, List.foldr (EventListBT.cons Nothing) r ts))+      (\y r -> EventListMT.consBody (Just y) r)+      EventListBT.empty++{-# INLINE unionMaybe #-}+unionMaybe ::+   EventListTT.T StrictTime (Maybe y) ->+   EventListTT.T LazyTime y+unionMaybe =+   EventListTT.foldr+      (\t ->+         EventListMT.mapTimeHead+            (NonNegChunky.fromChunks . (t:) . NonNegChunky.toChunks))+      (\my ->+         case my of+            Nothing -> id+            Just y ->+               EventListMT.consTime NonNegChunky.zero .+               EventListMT.consBody y)+      (EventListTT.pause NonNegChunky.zero)++{-+ToDo: move to PiecewiseConstant.Signal or so.+-}+zipWithCore ::+   (a -> b -> c) ->+   a -> b ->+   EventListTT.T StrictTime (Maybe a) ->+   EventListTT.T StrictTime (Maybe b) ->+   EventListTT.T StrictTime (Maybe c)+zipWithCore f =+   let switch ac ar g =+          flip (EventListMT.switchBodyL EventListBT.empty) ar $ \am ar1 ->+          g (maybe (False,ac) ((,) True) am) ar1+       cont j ac bc as bs =+          EventListMT.consBody (toMaybe j $ f ac bc) $+          recourse ac bc as bs+       recourse ac bc as bs =+          flip EventListMT.switchTimeL as $ \at ar ->+          flip EventListMT.switchTimeL bs $ \bt br ->+          let ct = min at bt+          in  -- ToDo: redundant comparison of 'at' and 'bt'+              EventListMT.consTime ct $+              case compare at bt of+                 LT ->+                    switch ac ar $ \(ab,a) ar1 ->+                       cont ab a bc ar1 (EventListMT.consTime (bt-|ct) br)+                 GT ->+                    switch bc br $ \(bb,b) br1 ->+                       cont bb ac b (EventListMT.consTime (at-|ct) ar) br1+                 EQ ->+                    switch ac ar $ \(ab,a) ar1 ->+                    switch bc br $ \(bb,b) br1 ->+                       cont (ab||bb) a b ar1 br1+   in  recourse++zipWith ::+   (a -> b -> c) ->+   EventListBT.T StrictTime a ->+   EventListBT.T StrictTime b ->+   EventListBT.T StrictTime c+zipWith f as0 bs0 =+   flip (EventListMT.switchBodyL EventListBT.empty) as0 $ \a0 as1 ->+   flip (EventListMT.switchBodyL EventListBT.empty) bs0 $ \b0 bs1 ->+   let c0 = f a0 b0+   in  EventListMT.consBody c0 $+       flip evalState c0 $+       traverse (\mc -> maybe (return ()) put mc >> get) $+       zipWithCore f a0 b0 (fmap Just as1) (fmap Just bs1)++_zipWithLazy ::+   (a -> b -> c) ->+   EventListBT.T LazyTime a ->+   EventListBT.T LazyTime b ->+   EventListBT.T LazyTime c+_zipWithLazy f as0 bs0 =+   flip (EventListMT.switchBodyL EventListBT.empty) as0 $ \a0 as1 ->+   flip (EventListMT.switchBodyL EventListBT.empty) bs0 $ \b0 bs1 ->+   EventListMT.consBody (f a0 b0) $ unionMaybe $+   zipWithCore f a0 b0 (subdivideMaybe as1) (subdivideMaybe bs1)+{-+*Synthesizer.PiecewiseConstant.ALSA.MIDI Data.EventList.Relative.MixedTime> zipWithLazy (,) ('a' ./ 2 /. 'b' ./ 7 /. EventListBT.empty) ('c' ./ (1 P.+ 1) /. 'd' ./ 1 /. EventListBT.empty)+-}+++{-# INLINE bendWheelPressure #-}+bendWheelPressure ::+   (RealRing.C y, Trans.C y) =>+   Channel ->+   Int -> y -> y ->+   Filter (T (BendModulation y))+bendWheelPressure chan+     pitchRange wheelDepth pressDepth =+   liftM2 (zipWith BendModulation)+      (pitchBend chan (2^?(fromIntegral pitchRange/12)) 1)+      (liftM2 (zipWith (+))+         (controllerLinear chan VoiceMsg.modulation (0,wheelDepth) 0)+         (channelPressure chan pressDepth 0))
+ src/Synthesizer/PiecewiseConstant/ALSA/MIDIControllerSet.hs view
@@ -0,0 +1,314 @@+{- |+Treat a stream of MIDI events as parallel streams of MIDI controller events.+-}+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet (+   T,+   Controller(Controller,PitchBend,Pressure),+   fromChannel,+   controllerLinear,+   controllerExponential,+   pitchBend,+   channelPressure,+   PC.BendModulation(PC.BendModulation),+   PC.shiftBendModulation,+   bendWheelPressure,+   ) where++import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC+import qualified Synthesizer.EventList.ALSA.MIDI as Ev+import Synthesizer.EventList.ALSA.MIDI (StrictTime, Channel, )++import qualified Synthesizer.MIDIValue as MV+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg++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.Set as Set+import qualified Data.Map as Map+import Data.Map (Map, )++import Control.Monad.Trans.State (State, evalState, state, get, put, )+import Control.Monad (liftM2, msum, fmap, )+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 (\e -> msum $+      (fmap (mapFst Controller) $ Ev.maybeAnyController chan e) :+      (fmap ((,) PitchBend) $ Ev.maybePitchBend chan e) :+      (fmap ((,) Pressure) $ Ev.maybeChannelPressure 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++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))++++{-# INLINE bendWheelPressure #-}+bendWheelPressure ::+   (RealRing.C y, Trans.C y) =>+   Int -> y -> y ->+   Filter (PC.T (PC.BendModulation y))+bendWheelPressure pitchRange wheelDepth pressDepth =+   liftM2 (PC.zipWith PC.BendModulation)+      (pitchBend (2 ^? (fromIntegral pitchRange / 12)) 1)+      (liftM2 (PC.zipWith (+))+         (controllerLinear VoiceMsg.modulation (0,wheelDepth) 0)+         (channelPressure pressDepth 0))
src/Synthesizer/Storable/ALSA/MIDI.hs view
@@ -2,9 +2,42 @@ Convert MIDI events of a MIDI controller to a control signal. -} {-# LANGUAGE NoImplicitPrelude #-}-module Synthesizer.Storable.ALSA.MIDI where+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,+           maybePitchBend, maybeChannelPressure,+           chopLongTime, )+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@@ -19,10 +52,13 @@  import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg -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.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, ) @@ -31,138 +67,147 @@ import qualified Numeric.NonNegative.Chunky as NonNegChunky  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 Control.Monad.Trans.State (State, evalState, state, modify, gets, )+import Control.Monad.Trans.State (State, evalState, state, modify, put, get, ) import Control.Monad (liftM, )+import Data.Traversable (traverse, )+import Data.Foldable (traverse_, ) -import PreludeBase-import NumericPrelude-import Prelude ()+import NumericPrelude.Base hiding (sequence, )+import NumericPrelude.Numeric   -{--readMIDIController ::-   Storable a =>-   Int -> Int -> Int -> IO (SigSt.T a)-readMIDIController chunkSize sampleRate ctrl =-   withInPort ALSA.Block $ \ h _p ->-   do let loop = do putStrLn "waiting for an event:"-                    e <- ALSA.event_input h-                    print e-                    loop-      loop-      return SigSt.empty--}+chunkSizesFromStrictTime :: StrictTime -> NonNegChunky.T SigSt.ChunkSize+chunkSizesFromStrictTime =+   NonNegChunky.fromChunks .+   map (SVL.ChunkSize . fromInteger . NonNegW.toNumber) .+   chopLongTime + chunkSizesFromLazyTime :: LazyTime -> NonNegChunky.T SigSt.ChunkSize chunkSizesFromLazyTime =    NonNegChunky.fromChunks .    map (SVL.ChunkSize . fromInteger . NonNegW.toNumber) .+   concatMap chopLongTime .    NonNegChunky.toChunks .    NonNegChunky.normalize  -{-# INLINE controllerValuesToSignal #-}-controllerValuesToSignal ::++{-+ToDo: move to Storable.Signal+-}+{-# INLINE piecewiseConstant #-}+piecewiseConstant ::    (Storable y) =>-   y -> EventListTT.T LazyTime y -> SigSt.T y-controllerValuesToSignal initial =+   EventListBT.T StrictTime y -> SigSt.T y+piecewiseConstant =    EventListBT.foldrPair-      (\y t -> SigSt.append (SigStV.replicate (chunkSizesFromLazyTime t) y)) SigSt.empty .-   EventListMT.consBody initial+      (\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 controllerValueToSample #-}-controllerValueToSample ::-   (Field.C y) =>-   (y,y) -> Int -> y-controllerValueToSample (lower,upper) n =-   let k = fromIntegral n / 127-   in  (1-k) * lower + k * upper+{-# 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 getControllerSignal #-}-getControllerSignal ::++{-# INLINE controllerLinear #-}+controllerLinear ::    (Storable y, Field.C y) =>    Channel -> Controller ->    (y,y) -> y ->    Filter (SigSt.T y)-getControllerSignal chan ctrl bnd initial =-   liftM (controllerValuesToSignal initial .-          EventListTT.mapBody (controllerValueToSample bnd)) $+controllerLinear chan ctrl bnd initial =+   liftM (piecewiseConstantInitWith (MV.controllerLinear bnd) initial) $    getControllerEvents chan ctrl  -{-# INLINE controllerValueToSampleExp #-}-controllerValueToSampleExp ::-   (Trans.C y) =>-   (y,y) -> Int -> y-controllerValueToSampleExp (lower,upper) n =-   let k = fromIntegral n / 127-   in  lower**(1-k) * upper**k--{-# INLINE getControllerSignalExp #-}-getControllerSignalExp ::+{-# INLINE controllerExponential #-}+controllerExponential ::    (Storable y, Trans.C y) =>    Channel -> Controller ->    (y,y) -> y ->    Filter (SigSt.T y)-getControllerSignalExp chan ctrl bnd initial =-   liftM (controllerValuesToSignal initial .-          EventListTT.mapBody (controllerValueToSampleExp bnd)) $+controllerExponential chan ctrl bnd initial =+   liftM (piecewiseConstantInitWith (MV.controllerExponential bnd) initial) $    getControllerEvents chan ctrl  -{-# INLINE pitchBendValueToSample #-}-pitchBendValueToSample ::-   (Trans.C y) =>-   y -> y -> Int -> y-pitchBendValueToSample range center n =-   center * range ** (fromIntegral n / 8192)- {- |-@getPitchBendSignal channel range center@:+@pitchBend channel range center@: emits frequencies on an exponential scale from @center/range@ to @center*range@. -}-{-# INLINE getPitchBendSignal #-}-getPitchBendSignal ::+{-# INLINE pitchBend #-}+pitchBend ::    (Storable y, Trans.C y) =>    Channel ->    y -> y ->    Filter (SigSt.T y)-getPitchBendSignal chan range center =-   liftM (controllerValuesToSignal center .-          EventListTT.mapBody (pitchBendValueToSample range center)) $+pitchBend chan range center =+   liftM (piecewiseConstantInitWith (MV.pitchBend range center) center) $    getSlice (maybePitchBend chan) --   getPitchBendEvents chan -{-# INLINE getChannelPressureSignal #-}-getChannelPressureSignal ::+{-# INLINE channelPressure #-}+channelPressure ::    (Storable y, Trans.C y) =>    Channel ->    y -> y ->    Filter (SigSt.T y)-getChannelPressureSignal chan maxVal initVal =-   liftM (controllerValuesToSignal initVal .-          EventListTT.mapBody (controllerValueToSample (0,maxVal))) $+channelPressure chan maxVal initVal =+   liftM (piecewiseConstantInitWith (MV.controllerLinear (0,maxVal)) initVal) $    getSlice (maybeChannelPressure chan)  -{-# INLINE getFMSignalFromBendWheelPressure #-}-getFMSignalFromBendWheelPressure ::-   (Storable y, RealField.C y, Trans.C y) =>+{-+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)-getFMSignalFromBendWheelPressure chan+bendWheelPressure chan      pitchRange speed wheelDepth pressDepth =-   do bend  <- getPitchBendSignal chan (2^?(fromIntegral pitchRange/12)) 1-      fm    <- getControllerSignal chan VoiceMsg.modulation (0,wheelDepth) 0-      press <- getChannelPressureSignal chan pressDepth 0+   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+) $@@ -173,158 +218,63 @@             (OsciS.static Wave.sine zero speed)  -type Instrument y yv = y -> y -> LazyTime -> SigSt.T yv-type Bank y yv = Program -> Instrument y yv--renderInstrument ::-   (Trans.C y) =>-   Bank y yv ->-   Note ->-   SigSt.T yv-renderInstrument instrument (Note pgm pitch vel dur) =-   instrument pgm-      (fromIntegral (VoiceMsg.fromVelocity vel - 64)/63)-      {- This is the default tuning according to MIDI 1.0 Detailed Specification -}-      (440 * 2 ^? (fromIntegral (VoiceMsg.fromPitch pitch + 3 - 6*12) / 12))-      dur--renderInstrumentIgnoreProgram ::-   (Trans.C y) =>-   Instrument y yv ->-   Note ->-   SigSt.T yv-renderInstrumentIgnoreProgram instrument =-   renderInstrument (const instrument)--{- |-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--}-makeInstrumentSounds ::-   (Trans.C y) =>-   Instrument y yv ->-   EventListTT.T time Note ->-   EventListTT.T time (SigSt.T yv)-makeInstrumentSounds instrument =-   EventListTT.mapBody (renderInstrument (const instrument))+type Instrument y yv = Gen.Instrument y (SigSt.T yv)+type Bank y yv = Gen.Bank y (SigSt.T yv)  -{- |-Turn an event list with lazy times-to an event list with strict times.-This is much like the version we started on.-We could avoid this function with a more sophisticated version of 'arrange'.--}-insertBreaksGen ::-   signal ->-   EventListTT.T LazyTime   signal ->-   EventListTT.T StrictTime signal-insertBreaksGen empty =-   EventListTT.foldr-      (\lt r ->-         {- uncurry matches lazy, thus the constructor represented by consTime-            can be generated before the particular time is known -}-         uncurry EventListMT.consTime $-         case NonNegChunky.toChunks (NonNegChunky.normalize lt) of-            [] -> (0, r)-            (t:ts) ->-               (,) t $-               foldr (\dt ->-                   EventListMT.consBody empty .-                   EventListMT.consTime dt) r ts)-      EventListMT.consBody-      EventListBT.empty--insertBreaks ::-   (Storable y) =>-   EventListTT.T LazyTime   (SigSt.T y) ->-   EventListTT.T StrictTime (SigSt.T y)-insertBreaks =-   insertBreaksGen SigSt.empty--{-# INLINE getNoteSignalCore #-}-getNoteSignalCore ::+{-# INLINE sequenceCore #-}+sequenceCore ::    (Storable yv, Additive.C yv) =>    SVL.ChunkSize ->    Channel ->    Program ->-   (EventListTT.T LazyTime Note ->-    EventListTT.T LazyTime (SigSt.T yv)) ->+   Gen.Modulator Note (SigSt.T yv) ->    Filter (SigSt.T yv)-getNoteSignalCore chunkSize chan initPgm modulator =-   fmap (CutSt.arrangeEquidist chunkSize .-         EventListTM.switchTimeR const .-         EventListTT.mapTime fromIntegral .-         insertBreaks .-         modulator .-         matchNoteEvents .-         embedPrograms initPgm) $-   getNoteEvents chan+sequenceCore chunkSize =+   Gen.sequenceCore (CutSt.arrangeEquidist chunkSize)  -errorNoProgram :: Program-errorNoProgram =-   error "MIDI program not initialized"--{-# INLINE getNoteSignal #-}-getNoteSignal ::+{-# INLINE sequence #-}+sequence ::    (Storable yv, Additive.C yv, Trans.C y) =>    SVL.ChunkSize ->    Channel ->    Instrument y yv ->    Filter (SigSt.T yv)-getNoteSignal chunkSize chan instr =-   getNoteSignalCore chunkSize chan errorNoProgram (makeInstrumentSounds instr)+sequence chunkSize =+   Gen.sequence (CutSt.arrangeEquidist chunkSize)  -{-# INLINE getNoteSignalModulated #-}-getNoteSignalModulated ::+{-# 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)-getNoteSignalModulated chunkSize ctrl chan instr =-   getNoteSignalCore chunkSize chan errorNoProgram-   (flip evalState ctrl .-    EventListTT.mapM-       advanceModulationChunky-       (\note -> gets $ \c -> renderInstrumentIgnoreProgram (instr c) note))+sequenceModulated chunkSize =+   Gen.sequenceModulated (CutSt.arrangeEquidist chunkSize)  -{-# INLINE getNoteSignalMultiModulated #-}-getNoteSignalMultiModulated ::+{-# INLINE sequenceMultiModulated #-}+sequenceMultiModulated ::    (Storable yv, Additive.C yv, Trans.C y) =>    SVL.ChunkSize ->    Channel ->    instrument ->-   (EventListTT.T LazyTime (instrument, Note) ->-    EventListTT.T LazyTime (Instrument y yv, Note)) ->+   Gen.Modulator (instrument, Note) (Instrument y yv, Note) ->    Filter (SigSt.T yv)-getNoteSignalMultiModulated chunkSize chan instr modulator =-   getNoteSignalCore chunkSize chan errorNoProgram-      (EventListTT.mapBody (uncurry renderInstrumentIgnoreProgram) .-       modulator .-       EventListTT.mapBody ((,) instr))+sequenceMultiModulated chunkSize =+   Gen.sequenceMultiModulated (CutSt.arrangeEquidist chunkSize) + applyModulation ::    (Storable c) =>    SigSt.T c ->-   EventListTT.T LazyTime (SigSt.T c -> instr, note) ->-   EventListTT.T LazyTime (instr, note)-applyModulation ctrl =-   flip evalState ctrl .-   EventListTT.mapM-      advanceModulationChunky-      (\(instr,note) -> gets $ \c -> (instr c, note))--evaluateVectorHead ::-   (Storable a) =>-   SigSt.T a -> t -> t-evaluateVectorHead xs t =-   if SigSt.null xs then t else t+   Gen.Modulator (SigSt.T c -> instr, note) (instr, note)+applyModulation =+   Gen.applyModulation  advanceModulationLazy, advanceModulationStrict, advanceModulationChunky ::    (Storable a) =>@@ -346,31 +296,19 @@ -} advanceModulationStrict t = state $ \xs ->    let ys = SigStV.drop (chunkSizesFromLazyTime t) xs-   in  (evaluateVectorHead ys t, ys)+   in  (Gen.evaluateVectorHead ys t, ys)  advanceModulationChunky =-   liftM NonNegChunky.fromChunks .-   mapM advanceModulationChunk .-   NonNegChunky.toChunks--advanceModulationChunk ::-   (Storable a) =>-   NonNegW.Integer -> State (SigSt.T a) NonNegW.Integer-advanceModulationChunk t = state $ \xs ->-   let ys = SigSt.drop (fromIntegral t) xs-   in  (evaluateVectorHead ys t, ys)+   Gen.advanceModulation  -{-# INLINE getNoteSignalMultiProgram #-}-getNoteSignalMultiProgram ::+{-# INLINE sequenceMultiProgram #-}+sequenceMultiProgram ::    (Storable yv, Additive.C yv, Trans.C y) =>    SVL.ChunkSize ->    Channel ->    Program ->    [Instrument y yv] ->    Filter (SigSt.T yv)-getNoteSignalMultiProgram chunkSize chan initPgm instrs =-   let bank = makeInstrumentArray instrs-   in  getNoteSignalCore chunkSize chan initPgm-          (EventListTT.mapBody (renderInstrument-              (getInstrumentFromArray bank initPgm)))+sequenceMultiProgram chunkSize =+   Gen.sequenceMultiProgram (CutSt.arrangeEquidist chunkSize)
src/Synthesizer/Storable/ALSA/Play.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE NoImplicitPrelude #-} {- | Convert MIDI events of a MIDI controller to a control signal. -}@@ -9,7 +10,7 @@    defaultChunkSize,    ) where -import qualified Sound.Alsa as ALSA+import qualified Sound.ALSA.PCM as ALSA  import qualified Synthesizer.Frame.Stereo as Stereo import qualified Synthesizer.Basic.Binary as BinSmp@@ -29,16 +30,33 @@ import qualified Data.StorableVector.Lazy        as SVL import qualified Data.StorableVector.Base        as SVB -import qualified Algebra.RealField as RealField+import qualified Algebra.RealRing as RealRing --- import NumericPrelude (round, )-import Prelude hiding (round, break, )+import NumericPrelude.Numeric+import NumericPrelude.Base   defaultChunkSize :: SigSt.ChunkSize defaultChunkSize = SigSt.chunkSize 256  +makeSink ::+   (ALSA.SampleFmt y, RealRing.C t) =>+   t ->+   ALSA.SampleFreq ->+   ALSA.SoundSink y ALSA.Pcm+makeSink periodTime rate =+   let {-# INLINE soundFormat #-}+       soundFormat :: ALSA.SoundFmt y+       soundFormat =+          ALSA.SoundFmt {+             ALSA.sampleFreq = rate+          }+   in  ALSA.alsaSoundSinkTime "plughw:0,0" soundFormat $+       ALSA.SoundBufferTime+          (round (5000000*periodTime))+          (round (1000000*periodTime))+ {- alsaOpen: only few buffer underruns with        let buffer_time = 200000 -- 0.20s@@ -54,20 +72,12 @@ -} {-# INLINE auto #-} auto ::-   (ALSA.SampleFmt a) =>-   Int -> SigSt.T a -> IO ()-auto rate ys =-   let sink =-          ALSA.alsaSoundSinkTime "plughw:0,0" soundFormat $-          ALSA.SoundBufferTime 50000 10000--       {-# INLINE soundFormat #-}-       soundFormat :: ALSA.SoundFmt y-       soundFormat =-          ALSA.SoundFmt {-             ALSA.sampleFreq = rate-            }-+   (ALSA.SampleFmt y, RealRing.C t) =>+   t {- ^ period (buffer) size expressed in seconds -} ->+   ALSA.SampleFreq {- ^ sample rate -} ->+   SigSt.T y -> IO ()+auto periodTime rate ys =+   let sink = makeSink periodTime rate    in  ALSA.withSoundSink sink $ \to ->        flip mapM_ (SVL.chunks ys) $ \c ->        SVB.withStartPtr c $ \ptr size ->@@ -80,20 +90,13 @@  {-# INLINE autoAndRecord #-} autoAndRecord ::-   (ALSA.SampleFmt a, SoxFrame.C a) =>-   FilePath -> Int -> SigSt.T a -> IO ()-autoAndRecord fileName rate =-   let sink =-          ALSA.alsaSoundSinkTime "plughw:0,0" soundFormat $-          ALSA.SoundBufferTime 50000 10000--       {-# INLINE soundFormat #-}-       soundFormat :: ALSA.SoundFmt y-       soundFormat =-          ALSA.SoundFmt {-             ALSA.sampleFreq = rate-            }-+   (ALSA.SampleFmt y, SoxFrame.C y, RealRing.C t) =>+   t ->+   FilePath ->+   ALSA.SampleFreq ->+   SigSt.T y -> IO ()+autoAndRecord periodTime fileName rate =+   let sink = makeSink periodTime rate    in  (\act ->           fmap (const ()) .           SoxWrite.simple act SoxOption.none fileName rate) $ \h ys ->@@ -106,16 +109,20 @@  {-# INLINE monoToInt16 #-} monoToInt16 ::-   (Storable y, RealField.C y) =>-   Int -> SigSt.T y -> IO ()-monoToInt16 rate xs =-   auto rate+   (Storable y, RealRing.C y, RealRing.C t) =>+   t ->+   ALSA.SampleFreq ->+   SigSt.T y -> IO ()+monoToInt16 periodTime rate xs =+   auto periodTime rate       (SigSt.map BinSmp.int16FromCanonical xs)  {-# INLINE stereoToInt16 #-} stereoToInt16 ::-   (Storable y, RealField.C y) =>-   Int -> SigSt.T (Stereo.T y) -> IO ()-stereoToInt16 rate xs =-   auto rate+   (Storable y, RealRing.C y, RealRing.C t) =>+   t ->+   ALSA.SampleFreq ->+   SigSt.T (Stereo.T y) -> IO ()+stereoToInt16 periodTime rate xs =+   auto periodTime rate       (SigSt.map (fmap BinSmp.int16FromCanonical) xs)
+ src/Synthesizer/Storable/ALSA/Server.hs view
@@ -0,0 +1,83 @@+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 Algebra.Additive  as Additive++import NumericPrelude.Numeric (zero, )+import Prelude hiding (Real, round, break, id, (.), )+++{-+This program has still a very slowly growing memory leak.+-}+main :: IO ()+main =+   case 110::Int of+      000 -> Play.auto (periodTime::Real) 44100 $+                OsciSt.static chunkSize Wave.sine zero (800/sampleRate::Real)+      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+      100 -> Run.pitchBend+      101 -> Run.volumeFrequency+      102 -> Run.keyboard+      103 -> Run.keyboardMulti+      104 -> Run.keyboardStereo+      105 -> Run.keyboardPitchbend+      106 -> Run.keyboardFM+      107 -> Run.keyboardDetuneFM+      108 -> Run.keyboardFilter+      109 -> Run.keyboardSample+      110 -> Run.keyboardVariousStereo+      111 -> Run.keyboardSampleTFM+      112 -> Run.keyboardNoisyTone+      113 -> Run.keyboardFilteredNoisyTone+      _   -> error "not implemented server part"
+ src/Synthesizer/Storable/ALSA/Server/Common.hs view
@@ -0,0 +1,93 @@+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 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+++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 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 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 ()+playAndRecord fileName period rate =+   Play.autoAndRecord period fileName (round rate) .+   SigSt.append (SigSt.replicate chunkSize latency zero)++
+ src/Synthesizer/Storable/ALSA/Server/Instrument.hs view
@@ -0,0 +1,449 @@+module Synthesizer.Storable.ALSA.Server.Instrument where++import Synthesizer.Storable.ALSA.Server.Common++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, )++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.Interpolation as Interpolation+import qualified Synthesizer.Causal.Oscillator as OsciC+import qualified Synthesizer.Causal.Filter.Recursive.Integration as IntegC+import Control.Arrow ((<<<), (^<<), (<<^), (***), )+import qualified Synthesizer.Interpolation.Module as Ip++import qualified Synthesizer.Storable.Filter.NonRecursive as FiltNRSt+import qualified Synthesizer.Storable.Signal      as SigSt+import qualified Data.StorableVector.Lazy.Pattern as SigStV+import qualified Data.StorableVector.Lazy         as SVL++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 qualified Algebra.RealRing as RealRing+-- 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, (.), )++++{-# 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++pingReleaseEnvelope :: Real -> LazyTime -> SigSt.T Real+pingReleaseEnvelope vel dur =+   SigSt.switchR SigSt.empty+      (\body x ->+          SigSt.append body $+          SigS.toStorableSignal chunkSize $+          SigS.take (round (0.3*sampleRate :: Real)) $+          CtrlS.exponential2 (0.1*sampleRate) x) $+   SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $+   CtrlS.exponential2 (0.4*sampleRate) (amplitudeFromVelocity vel)++pingRelease :: Instrument Real Real+pingRelease vel freq dur =+   SigS.zipWithStorable (*)+      (OsciS.static Wave.saw zero (freq/sampleRate))+      (pingReleaseEnvelope vel dur)++pingStereoRelease :: Instrument Real (Stereo.T Real)+pingStereoRelease vel freq dur =+--   SigS.zipWithStorable (\y c -> fmap (c*) y)+   SigS.zipWithStorable (flip (*>))+      (SigS.zipWith Stereo.cons+         (OsciS.static Wave.saw zero (freq*0.999/sampleRate))+         (OsciS.static Wave.saw zero (freq*1.001/sampleRate)))+      (pingReleaseEnvelope vel dur)++tine :: Instrument Real Real+tine vel freq dur =+   SigS.zipWithStorable (*)+      (OsciS.phaseMod Wave.sine (freq/sampleRate)+         (FiltNRS.envelope+            (CtrlS.exponential (1*sampleRate) (vel+1))+            (OsciS.static Wave.sine zero (2*freq/sampleRate))))+      (pingReleaseEnvelope 0 dur)++tineStereo :: Instrument Real (Stereo.T Real)+tineStereo vel freq dur =+   let ctrl f =+          FiltNRS.envelope+             (CtrlS.exponential (1*sampleRate) (vel+1))+             (OsciS.static Wave.sine zero (2*f/sampleRate))+   in  SigS.zipWithStorable (flip (*>))+          (SigS.zipWith Stereo.cons+             (OsciS.phaseMod Wave.sine (freq*0.995/sampleRate) (ctrl freq))+             (OsciS.phaseMod Wave.sine (freq*1.005/sampleRate) (ctrl freq)))+          (pingReleaseEnvelope 0 dur)+++softStringReleaseEnvelope ::+   Real -> LazyTime -> SigSt.T Real+softStringReleaseEnvelope vel dur =+   let attackTime = sampleRate+       amp = amplitudeFromVelocity vel+       cnst = CtrlS.constant amp+       {-+       release <- take attackTime beginning+       would yield a space leak, thus we first split 'beginning'+       and then concatenate it again+       -}+       {-+       We can not easily generate attack and sustain separately,+       because we want to use the chunk structure implied by 'dur'.+       -}+       (attack, sustain) =+          SigSt.splitAt attackTime $+          SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $+          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 view
@@ -0,0 +1,272 @@+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, playAndRecord,+           sampleRate, lazySize, chunkSize, channel, )++import qualified Synthesizer.Storable.ALSA.MIDI as AlsaSt+import Synthesizer.Storable.ALSA.MIDI (applyModulation, )++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 Synthesizer.Generic.Loop      as LoopG+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 qualified Algebra.Additive  as Additive++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::Real)))++frequency :: IO ()+frequency =+   withMIDIEvents play $+      OsciSt.freqMod chunkSize Wave.sine zero .+      evalState (AlsaSt.controllerLinear channel VoiceMsg.mainVolume+         (400/sampleRate, 1200/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)))+++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 (playAndRecord "session.wav") $+         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))
+ src/Synthesizer/Storable/ALSA/Server/Test.hs view
@@ -0,0 +1,602 @@+module Synthesizer.Storable.ALSA.Server.Test where++import qualified Synthesizer.Storable.ALSA.Server.Instrument as Instr+import Synthesizer.Storable.ALSA.Server.Common+          (Real, withMIDIEvents, play,+           sampleRate, chunkSize, channel, )++import qualified Sound.ALSA.Sequencer.Address as Addr+import qualified Sound.ALSA.Sequencer.Client as Client+import qualified Sound.ALSA.Sequencer.Port as Port+import qualified Sound.ALSA.Sequencer.Queue as Queue+import qualified Sound.ALSA.Sequencer.RealTime as RealTime+import qualified Sound.ALSA.Sequencer.Event as Event++import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC+import qualified Synthesizer.Generic.ALSA.MIDI as Gen+import qualified Synthesizer.Storable.ALSA.MIDI as AlsaSt+import Synthesizer.Storable.ALSA.MIDI (+   Instrument, chunkSizesFromLazyTime, )++import qualified Synthesizer.EventList.ALSA.MIDI as MIDIEv+import Synthesizer.EventList.ALSA.MIDI (+   LazyTime, StrictTime, Note(..), NoteBoundary(..),+   matchNoteEvents, getSlice, getControllerEvents, )++import qualified Synthesizer.Basic.Wave          as Wave++import qualified Synthesizer.Causal.Process as Causal+import Control.Arrow ((<<<), )++import qualified Synthesizer.Storable.Cut         as CutSt+import qualified Synthesizer.Storable.Oscillator  as OsciSt+import qualified Synthesizer.Storable.Signal      as SigSt+-- import qualified Data.StorableVector.Lazy.Builder as Bld+import qualified Data.StorableVector.Lazy.Pattern as SigStV+import qualified Data.StorableVector.Lazy         as SVL+import qualified Data.StorableVector              as SV++import qualified Synthesizer.State.Signal      as SigS++import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg++import qualified Data.EventList.Relative.TimeBody  as EventList+import qualified Data.EventList.Relative.MixedBody as EventListMB+import qualified Data.EventList.Relative.BodyTime  as EventListBT+import Data.EventList.Relative.MixedBody ((/.), (./), )++import qualified Control.Monad.Trans.State.Strict as MS+import Control.Monad.Trans.State (evalState, gets, )+import Control.Category ((.), )++import Data.Traversable (traverse, )++-- import qualified Numeric.NonNegative.Class   as NonNeg+import qualified Numeric.NonNegative.Wrapper as NonNegW+import qualified Numeric.NonNegative.Chunky as NonNegChunky++import qualified Algebra.RealRing as RealRing+import qualified Algebra.Additive  as Additive++import Data.Maybe.HT (toMaybe, )++import NumericPrelude.Numeric (zero, round, (^?), )+import Prelude hiding (Real, round, break, id, (.), )+++import Data.Word (Word8, )+++frequency1 :: IO ()+frequency1 =+   withMIDIEvents play $+      const+        (OsciSt.static chunkSize Wave.sine zero (800/sampleRate::Real))++frequency2 :: IO ()+frequency2 =+   withMIDIEvents (const $ const print) $+      evalState (getControllerEvents channel VoiceMsg.mainVolume)++frequency3 :: IO ()+frequency3 =+   withMIDIEvents (const $ const print) $+      evalState (getSlice Just)+++keyboard1 :: IO ()+keyboard1 =+   withMIDIEvents play $+      const (Instr.ping 0 440)++keyboard2 :: SigSt.T Real+keyboard2 =+   let music :: Real -> EventList.T StrictTime (SigSt.T Real)+       music x = 5 /. SigSt.replicate chunkSize 6 x ./ music (x+1)+   in  CutSt.arrange chunkSize $+       EventList.mapTime fromIntegral $ music 42++keyboard3 :: SigSt.T Real+keyboard3 =+   let time :: Real -> Int+       time t = round (t * sampleRate)+       music :: Real -> EventList.T StrictTime (SigSt.T Real)+       music x =+          fromIntegral (time 0.2) /.+          SigSt.take (time 0.4) (Instr.ping 0 x) ./+          music (x*1.01)+   in  CutSt.arrange chunkSize $+       EventList.mapTime fromIntegral $ music 110++makeLazyTime :: Real -> LazyTime+makeLazyTime t =+   NonNegChunky.fromNumber $+   NonNegW.fromNumberMsg "keyboard time" $+   round (t * sampleRate)++makeStrictTime :: Real -> StrictTime+makeStrictTime t =+   NonNegW.fromNumberMsg "keyboard time" $+   round (t * sampleRate)++normalVelocity :: VoiceMsg.Velocity+normalVelocity =+   VoiceMsg.toVelocity VoiceMsg.normalVelocity++pitch :: Int -> VoiceMsg.Pitch+pitch = VoiceMsg.toPitch++defaultProgram :: VoiceMsg.Program+defaultProgram = VoiceMsg.toProgram 0++embedDefaultProgram ::+   EventList.T StrictTime [NoteBoundary Bool] ->+   EventList.T StrictTime [NoteBoundary (Maybe VoiceMsg.Program)]+embedDefaultProgram =+   fmap (fmap (\(NoteBoundary p v b) ->+      NoteBoundary p v (toMaybe b defaultProgram)))++keyboard4 :: SigSt.T Real+keyboard4 =+   let {-+       idInstr :: Real -> Real -> SigSt.T Real+       idInstr _vel freq = SigSt.repeat chunkSize freq+       -}+--       inf = time 0.4 + inf+       music :: Int -> EventList.T StrictTime Note+       music p =+          makeStrictTime 0.2 /.+--          (pitch p, normalVelocity, inf) ./+          Note defaultProgram (pitch p) normalVelocity (makeLazyTime 0.4) ./+          music (p+1)+   in  CutSt.arrange chunkSize $+       EventList.mapTime fromIntegral $+       fmap (Gen.renderInstrumentIgnoreProgram Instr.pingDur) $+       music 0+++notes0 :: Int -> EventList.T StrictTime (NoteBoundary Bool)+notes0 p =+   makeStrictTime 0.2 /.+   (let (oct,pc) = divMod p 12+    in  (NoteBoundary (pitch (50 + pc)) normalVelocity (even oct)))+      ./+   notes0 (p+1)++notes1 :: EventList.T StrictTime (NoteBoundary Bool)+notes1 =+   makeStrictTime 0.2 /.+   (NoteBoundary (pitch 50) normalVelocity True) ./+   makeStrictTime 0.2 /.+   (NoteBoundary (pitch 52) normalVelocity True) ./+   makeStrictTime 0.2 /.+   (NoteBoundary (pitch 54) normalVelocity True) ./+   makeStrictTime 0.2 /.+--   (NoteBoundary (pitch 50) normalVelocity False) ./+   undefined++notes2 :: EventList.T StrictTime [NoteBoundary Bool]+notes2 =+   makeStrictTime 0.2 /.+   [] ./+   makeStrictTime 0.2 /.+   [] ./+   makeStrictTime 0.2 /.+   [NoteBoundary (pitch 50) normalVelocity True] ./+   makeStrictTime 0.2 /.+   [NoteBoundary (pitch 52) normalVelocity True] ./+   makeStrictTime 0.2 /.+   [NoteBoundary (pitch 54) normalVelocity True] ./+   makeStrictTime 0.2 /.+   [NoteBoundary (pitch 50) normalVelocity False] ./+   undefined++notes3 :: EventList.T StrictTime [NoteBoundary (Maybe VoiceMsg.Program)]+notes3 =+   embedDefaultProgram $+   notes2++keyboard5 :: SigSt.T Real+keyboard5 =+   CutSt.arrange chunkSize $+   EventList.mapTime fromIntegral $+   Gen.flatten $+   fmap (map (Gen.renderInstrumentIgnoreProgram Instr.pingDur)) $+   matchNoteEvents $+   notes3++keyboard6 :: EventList.T StrictTime [Note]+keyboard6 =+   matchNoteEvents $+   embedDefaultProgram $+   fmap (:[]) $+   notes1++keyboard7 :: EventList.T StrictTime [(VoiceMsg.Pitch, VoiceMsg.Velocity)]+keyboard7 =+   fmap (map (\ ~(Note _ p v _d) -> (p,v))) $+   keyboard6++arrangeSpaceLeak0 :: IO ()+arrangeSpaceLeak0 =+   SVL.writeFile "test.f32" $+   evalState (Gen.sequence (CutSt.arrange chunkSize) channel+      (error "no sound" :: Instrument Real Real)) $+   let evs = EventList.cons 10 [] evs+   in  evs++arrangeSpaceLeak1 :: IO ()+arrangeSpaceLeak1 =+   SVL.writeFile "test.f32" $+   evalState+      (Gen.sequenceModulated (CutSt.arrange chunkSize)+         (SigSt.iterate chunkSize (1+) 0) channel+         (error "no sound" :: SigSt.T Real -> Instrument Real Real)) $+   let evs = EventList.cons 10 [] evs+   in  evs++makeNote :: Event.NoteEv -> Word8 -> Event.T+makeNote typ pit =+   Event.Cons+      { Event.highPriority = False+      , Event.tag = 0+      , Event.queue = Queue.direct+      , Event.timestamp =+           Event.RealTime $ RealTime.fromInteger 0+      , Event.source = Addr.Cons {+           Addr.client = Client.subscribers,+           Addr.port = Port.unknown+        }+      , Event.dest = Addr.Cons {+           Addr.client = Client.subscribers,+           Addr.port = Port.unknown+        }+      , Event.body =+           Event.NoteEv typ+              (Event.simpleNote 0 pit 64)+      }++{-+a space leak can only be observed for more than one note,+maybe our 'break' improvement fixed the case for one played note+-}+arrangeSpaceLeak3 :: IO ()+arrangeSpaceLeak3 =+   SVL.writeFile "test.f32" $+   evalState+      (Gen.sequenceModulated (CutSt.arrange chunkSize)+         (SigSt.iterate chunkSize (1e-7 +) 1) channel+         Instr.stringStereoFM) $+--         (const Instr.pingDur :: SigSt.T Real -> Instrument Real Real)) $+   let evs t = EventList.cons t [] (evs (20-t))+   in  -- EventList.cons 10 [makeNote MIDI.NoteOn 60] $+       -- EventList.cons 10 [makeNote MIDI.NoteOn 64] $+       evs 10++arrangeSpaceLeak4 :: IO ()+arrangeSpaceLeak4 =+   SVL.writeFile "test.f32" $+   evalState+      (do bend <- AlsaSt.pitchBend channel (2^?(2/12)) 1+          AlsaSt.sequenceModulated chunkSize bend channel Instr.stringStereoFM) $+   let evs t = EventList.cons t [] (evs (20-t))+   in  evs 10++chordSpaceLeak1 :: IO ()+chordSpaceLeak1 =+   SVL.writeFile "test.f32" $+   evalState+      (Gen.sequence (CutSt.arrange chunkSize)+          channel Instr.pingDur) $+   let evs t = EventList.cons t [] (evs (20-t))+   in  EventList.cons 10 [makeNote Event.NoteOn 60] $+       EventList.cons 10 [makeNote Event.NoteOn 64] $+       evs 10+++sequencePitchBend :: IO ()+sequencePitchBend =+   SVL.writeFile "test.f32" $+      evalState+         (let fm y = (EventListBT.cons $! y) 10 (fm (2-y))+          in  Gen.sequenceModulated (CutSt.arrange chunkSize) (fm 1) channel+                 (error "no sound" ::+                     PC.T Real -> Instrument Real Real)) $+      let evs = EventList.cons 10 [] evs+      in  evs++sequencePitchBend1 :: IO ()+sequencePitchBend1 =+   SVL.writeFile "test.f32" $+      evalState+         (let fm y = EventListBT.cons y 10 (fm (2-y))+              instr :: PC.T Real -> Instrument Real Real+              instr = error "no sound"+          in  Gen.sequenceCore+                 (CutSt.arrange chunkSize) channel Gen.errorNoProgram+                 (Gen.Modulator (fm 1) Gen.advanceModulationChunk+                     (\note -> gets $ \c ->+                         Gen.renderInstrumentIgnoreProgram (instr c) note))) $+      let evs = EventList.cons 10 [] evs+      in  evs++sequencePitchBend2 :: IO ()+sequencePitchBend2 =+   SVL.writeFile "test.f32" $+      let fm y = EventListBT.cons y 10 (fm (2-y))+          -- fm = EventListBT.cons 1 10 fm+          instr :: PC.T Real -> Instrument Real Real+          instr = error "no sound"+          evs = EventList.cons 10 [] evs+          md =+             Gen.Modulator+                (fm 1)+                Gen.advanceModulationChunkPC+                -- Gen.advanceModulationChunk+                (\note -> gets $ \c ->+                    Gen.renderInstrumentIgnoreProgram (instr c) note)+      in  CutSt.arrange chunkSize .+          EventList.mapTime fromIntegral .+          Gen.flatten .+          Gen.applyModulator md $+          evs++sequencePitchBend3 :: IO ()+sequencePitchBend3 =+   SVL.writeFile "test.f32" $+      let fm y = EventListBT.cons y 10 (fm (2-y))+          -- fm = EventListBT.cons 1 10 fm+          instr :: PC.T Real -> Instrument Real Real+          instr = error "no sound"+          evs = EventList.cons 10 [] evs+          modEvent note =+             gets $ \c ->+                Gen.renderInstrumentIgnoreProgram (instr c) note+      in  CutSt.arrange chunkSize .+          EventList.mapTime fromIntegral .+          Gen.flatten .+          flip evalState (fm 1) .+          EventList.traverse+             Gen.advanceModulationChunk+             (traverse modEvent) $+          evs++sequencePitchBend4 :: IO ()+sequencePitchBend4 =+   SVL.writeFile "test.f32" $+      let fm y = y : fm (2-y)+          -- fm = repeat 1+          instr :: [Real] -> Instrument Real Real+          instr = error "no sound"+          evs = EventList.cons 10 [] evs+          modEvent note =+             gets $ \c ->+                Gen.renderInstrumentIgnoreProgram (instr c) note+      in  CutSt.arrange chunkSize .+          EventList.mapTime fromIntegral .+          Gen.flatten .+          flip evalState (fm 1) .+          EventList.traverse+             Gen.advanceModulationChunk+             (traverse modEvent) $+          evs++sequencePitchBend4a :: IO ()+sequencePitchBend4a =+   SVL.writeFile "test.f32" $+      let fm y = y : fm (2-y)+          -- fm = repeat 1+          instr :: [Real] -> Instrument Real Real+          instr = error "no sound"+          evs = EventList.cons 10 [] evs+          modEvent note =+             MS.gets $ \c ->+                Gen.renderInstrumentIgnoreProgram (instr c) note+      in  CutSt.arrange chunkSize .+          EventList.mapTime fromIntegral .+          Gen.flatten .+          flip MS.evalState (fm 1) .+          EventList.traverse+             Gen.advanceModulationChunkStrict+             (traverse modEvent) $+          evs++sequencePitchBend4b :: IO ()+sequencePitchBend4b =+   SVL.writeFile "test.f32" $+      let fm y = y : fm (2-y)+          -- fm = repeat 1+          instr :: [Real] -> Instrument Real Real+          instr = error "no sound"+          evs = EventList.cons 10 [] evs+      in  CutSt.arrange chunkSize .+          Gen.flatten $+          EventList.foldrPair+             (\t bs0 go s0 ->+                let s1 = tail s0+                    bs1 =+                       map (Gen.renderInstrumentIgnoreProgram (instr s1)) bs0+                in  EventList.cons+                       (if null s1 then t else t) bs1 $+                    go s1)+             (const EventList.empty) evs (fm 1)++sequencePitchBend4c :: IO ()+sequencePitchBend4c =+   SVL.writeFile "test.f32" $+      let fm y = y : fm (2-y)+          -- fm = repeat 1+          instr :: [Real] -> Instrument Real Real+          instr = error "no sound"+      in  CutSt.arrange chunkSize .+          Gen.flatten .+          EventList.fromPairList $+          foldr+             (\(t,bs0) go s0 ->+                let s1 = tail s0+                    bs1 =+                       map (Gen.renderInstrumentIgnoreProgram (instr s1)) bs0+                in  (if null s1 then t else t, bs1) :+                    go s1)+             (const [])+             (repeat (10,[]))+             (fm 1)++sequencePitchBend4d :: IO ()+sequencePitchBend4d =+   SVL.writeFile "test.f32" $+      let fm y = y : fm (2-y)+          -- fm = repeat 1+      in  CutSt.arrange chunkSize .+          EventList.fromPairList $+          foldr+             (\(t,b) go s0 ->+                let s1 = tail s0+                in  (if null s1 then t else t,+                     if null s1 then b else b) :+                    go s1)+             (const [])+             (repeat (10, SigSt.empty :: SigSt.T Real))+             (fm 1 :: [Real])++sequencePitchBend4e :: IO ()+sequencePitchBend4e =+   writeFile "test.txt" $+   foldr+      (\c go s0 ->+         let s1 = tail s0+         in  (if null s1 then c else c) :+             go s1)+      (const [])+      (repeat 'a')+      (iterate not False)+      -- (repeat True)++sequencePitchBend5 :: IO ()+sequencePitchBend5 =+   SVL.writeFile "test.f32" $+      let fm y = SigSt.iterate (SVL.ChunkSize 1) (y+) 0+          instr :: SigSt.T Real -> Instrument Real Real+          instr = error "no sound"+          evs = EventList.cons 10 [] evs+          modEvent note =+             gets $ \c ->+                Gen.renderInstrumentIgnoreProgram (instr c) note+      in  CutSt.arrange chunkSize .+          EventList.mapTime fromIntegral .+          Gen.flatten .+          flip evalState (fm 1e-6) .+          EventList.traverse+             Gen.advanceModulationChunk+             (traverse modEvent) $+          evs++dummySound :: Instrument Real Real+dummySound =+   \vel freq dur ->+      SigStV.take (chunkSizesFromLazyTime dur) $+      SigSt.repeat chunkSize (vel + 1e-3*freq)++sequenceStaccato :: IO ()+sequenceStaccato =+   SVL.writeFile "test.f32" $+      let evs t =+             EventList.cons t [Right $ NoteBoundary (pitch 60) normalVelocity True] $+             EventList.cons t [Right $ NoteBoundary (pitch 60) normalVelocity False] $+             evs (20-t)+      in  CutSt.arrange chunkSize .+          EventList.mapTime fromIntegral .+          Gen.flatten .+          EventList.mapBody+             (map (Gen.renderInstrumentIgnoreProgram dummySound)) .+          MIDIEv.matchNoteEvents .+          MIDIEv.embedPrograms defaultProgram $+          evs 10++sequenceStaccato3 :: IO ()+sequenceStaccato3 =+   SVL.writeFile "test.f32" $+      let evs t =+             EventList.cons t [NoteBoundary (pitch 60) normalVelocity (Just defaultProgram)] $+             EventList.cons t [NoteBoundary (pitch 60) normalVelocity Nothing] $+             evs (20-t)+      in  CutSt.arrange chunkSize .+          EventList.mapTime fromIntegral .+          Gen.flatten .+          EventList.mapBody+             (map (Gen.renderInstrumentIgnoreProgram dummySound)) .+          MIDIEv.matchNoteEvents $+          evs 10++sequenceStaccato2 :: IO ()+sequenceStaccato2 =+   SVL.writeFile "test.f32" $+      let evs t =+             EventList.cons t [makeNote Event.NoteOn  60] $+             EventList.cons t [makeNote Event.NoteOff 60] $+             evs (20-t)+      in  CutSt.arrange chunkSize .+          EventList.mapTime fromIntegral .+          Gen.flatten .+          EventList.mapBody+             (map (Gen.renderInstrumentIgnoreProgram dummySound)) .+          MIDIEv.matchNoteEvents .+          MIDIEv.embedPrograms defaultProgram .+          evalState (MIDIEv.getNoteEvents channel) $+          evs 10++sequenceStaccato1 :: IO ()+sequenceStaccato1 =+   SVL.writeFile "test.f32" $+      evalState+         (do Gen.sequence (CutSt.arrange chunkSize) channel dummySound) $+      let evs t =+             EventList.cons t [makeNote Event.NoteOn  60] $+             EventList.cons t [makeNote Event.NoteOff 60] $+             evs (20-t)+      in  evs 10+++speed :: IO ()+speed =+   let _sig =+          Causal.apply+             (Instr.softStringCausalProcess 440 <<<+              Instr.softStringReleaseEnvelopeCausalProcess 0)+             (SigS.repeat True)+       sig =+          Causal.apply+             (Instr.softStringCausalProcess 440)+             (SigS.repeat 1)+   in  SV.writeFile "speed.f32" $+       SigS.runViewL sig+       (\next s -> fst $ SV.unfoldrN 1000000 next s)++speedChunky :: IO ()+speedChunky =+   let sig =+          Causal.apply+             (Instr.softStringCausalProcess 440 <<<+              Instr.softStringReleaseEnvelopeCausalProcess 0)+             (SigS.repeat True)+   in  SVL.writeFile "speed.f32" $+       SigSt.take 1000000 $+       SigS.toStorableSignal (SVL.chunkSize 100) sig+{-+       SigS.runViewL sig+       (\next s -> SVL.take 1000000 (SVL.unfoldr (SVL.chunkSize 100) next s))+-}++speedArrange :: IO ()+speedArrange =+   let sig =+          Causal.apply+             (Instr.softStringCausalProcess 440 <<<+              Instr.softStringReleaseEnvelopeCausalProcess 0)+             (SigS.repeat True)+       sigSt =+          SigS.toStorableSignal (SVL.chunkSize 100) sig+   in  SVL.writeFile "speed.f32" $+       SigSt.take 1000000 $+       CutSt.arrangeEquidist (SVL.chunkSize 100) $+       EventList.fromPairList [(10000,sigSt)]
+ src/Test.hs view
@@ -0,0 +1,197 @@+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 qualified Synthesizer.Storable.ALSA.MIDI as AlsaSt+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 $+   evalState (Gen.sequence (CutSt.arrange chunkSize) channel+      (error "no sound" :: Instrument Real Real)) $+   let evs = consNone 10 evs+   in  evs++sequenceSpaceLeakModulatedEmpty :: Bool+sequenceSpaceLeakModulatedEmpty =+   evaluatePrefix $+   evalState+      (Gen.sequenceModulated (CutSt.arrange chunkSize)+         (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 $+   evalState+      (let fm y = (EventListBT.cons $! y) 10 (fm (2-y))+       in  Gen.sequenceModulated (CutSt.arrange chunkSize) (fm 1) channel+              (error "no sound" ::+                  PC.T Real -> Instrument Real Real)) $+   let evs = 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 $+   evalState+      (Gen.sequenceModulated (CutSt.arrange chunkSize)+         (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 $+   evalState+      (Gen.sequenceModulated (CutSt.arrange chunkSize)+         (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 $+   evalState+      (Gen.sequenceModulated (CutSt.arrange chunkSize)+         (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 $+   evalState+      (Gen.sequenceModulated (CutSt.arrange chunkSize)+         (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.1+Version:        0.3 License:        GPL License-File:   LICENSE Author:         Henning Thielemann <haskell@henning-thielemann.de>@@ -29,25 +29,34 @@   description: Build example executables   default:     False +Flag buildTests+  description: Build test executables+  default:     False+ Library   Build-Depends:-    synthesizer-dimensional >=0.4 && < 0.5,-    synthesizer-core >=0.3 && < 0.4,-    sox >=0.1 && <0.2,-    alsa >=0.3 && <0.4,+    synthesizer-dimensional >=0.5 && < 0.6,+    synthesizer-core >=0.4 && < 0.5,+    sox >=0.2 && <0.3,+    midi-alsa >=0.1 && <0.2,+    alsa-seq >=0.5 && <0.6,+    alsa-pcm >=0.5 && <0.6,+    alsa-core >=0.5 && <0.6,     midi >=0.1.1 && <0.2,     storablevector >=0.2.5 && <0.3,-    numeric-prelude >=0.0.3 && <0.2,-    non-negative >=0.0.5 && <0.1,-    event-list >=0.0.8 && <0.1,-    -- data-accessor >=0.1 && <0.2,-    array >=0.1 && <0.3,-    transformers >=0.1.1 && <0.2,+    deepseq >=1.1 && <1.2,+    numeric-prelude >=0.2 && <0.3,+    non-negative >=0.1 && <0.2,+    event-list >=0.1 && <0.2,+    data-accessor >=0.2.1 && <0.3,+    containers >=0.1 && <0.4,+    array >=0.1 && <0.4,+    transformers >=0.2 && <0.3,     utility-ht >=0.0.1 && <0.1    If flag(splitBase)     Build-Depends:-      base >= 3 && <5,+      base >= 3 && <6,       random >= 1.0 && < 1.1,       old-time >= 1.0 && < 1.1   Else@@ -60,8 +69,15 @@     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+    -- these modules would be better located in midi package,+    -- but they are based on NumericPrelude+    Synthesizer.MIDIValue+    Synthesizer.Dimensional.MIDIValue  Executable realtimesynth   If !flag(buildExamples)@@ -71,7 +87,12 @@   GHC-Options: -Wall -fexcess-precision -threaded -- -ddump-simpl-stats -ddump-asm   Hs-Source-Dirs: src-  Main-Is: RealTimeSynthesizer.hs+  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  Executable synthicate   If !flag(buildExamples)@@ -81,4 +102,19 @@   GHC-Options: -Wall -fexcess-precision -threaded -- -ddump-simpl-stats   Hs-Source-Dirs: src-  Main-Is: RealTimeSynthesizerDim.hs+  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+  Hs-Source-Dirs: src+  Main-Is: Test.hs