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