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) -}