synthesizer-alsa-0.1: src/Synthesizer/Storable/ALSA/MIDI.hs
{- |
Convert MIDI events of a MIDI controller to a control signal.
-}
{-# LANGUAGE NoImplicitPrelude #-}
module Synthesizer.Storable.ALSA.MIDI where
import Synthesizer.EventList.ALSA.MIDI
import qualified Synthesizer.Storable.Cut as CutSt
import qualified Synthesizer.Storable.Signal as SigSt
import qualified Data.StorableVector.Lazy.Pattern as SigStV
import qualified Data.StorableVector.Lazy as SVL
import qualified Synthesizer.State.Signal as SigS
import qualified Synthesizer.State.Oscillator as OsciS
import qualified Synthesizer.State.Displacement as DispS
import qualified Synthesizer.State.Filter.NonRecursive as FiltNRS
import qualified Synthesizer.Basic.Wave as Wave
import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
import qualified Data.EventList.Relative.TimeTime as EventListTT
import qualified Data.EventList.Relative.TimeMixed as EventListTM
import qualified Data.EventList.Relative.MixedTime as EventListMT
import qualified Data.EventList.Relative.BodyTime as EventListBT
import Foreign.Storable (Storable, )
-- import qualified 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.RealField as RealField
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 (liftM, )
import PreludeBase
import NumericPrelude
import Prelude ()
{-
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
-}
chunkSizesFromLazyTime :: LazyTime -> NonNegChunky.T SigSt.ChunkSize
chunkSizesFromLazyTime =
NonNegChunky.fromChunks .
map (SVL.ChunkSize . fromInteger . NonNegW.toNumber) .
NonNegChunky.toChunks .
NonNegChunky.normalize
{-# INLINE controllerValuesToSignal #-}
controllerValuesToSignal ::
(Storable y) =>
y -> EventListTT.T LazyTime y -> SigSt.T y
controllerValuesToSignal initial =
EventListBT.foldrPair
(\y t -> SigSt.append (SigStV.replicate (chunkSizesFromLazyTime t) y)) SigSt.empty .
EventListMT.consBody initial
{-# 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 getControllerSignal #-}
getControllerSignal ::
(Storable y, Field.C y) =>
Channel -> Controller ->
(y,y) -> y ->
Filter (SigSt.T y)
getControllerSignal chan ctrl bnd initial =
liftM (controllerValuesToSignal initial .
EventListTT.mapBody (controllerValueToSample bnd)) $
getControllerEvents chan ctrl
{-# INLINE controllerValueToSampleExp #-}
controllerValueToSampleExp ::
(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 ::
(Storable y, Trans.C y) =>
Channel -> Controller ->
(y,y) -> y ->
Filter (SigSt.T y)
getControllerSignalExp chan ctrl bnd initial =
liftM (controllerValuesToSignal initial .
EventListTT.mapBody (controllerValueToSampleExp bnd)) $
getControllerEvents chan ctrl
{-# INLINE pitchBendValueToSample #-}
pitchBendValueToSample ::
(Trans.C y) =>
y -> y -> Int -> y
pitchBendValueToSample range center n =
center * range ** (fromIntegral n / 8192)
{- |
@getPitchBendSignal channel range center@:
emits frequencies on an exponential scale from
@center/range@ to @center*range@.
-}
{-# INLINE getPitchBendSignal #-}
getPitchBendSignal ::
(Storable y, Trans.C y) =>
Channel ->
y -> y ->
Filter (SigSt.T y)
getPitchBendSignal chan range center =
liftM (controllerValuesToSignal center .
EventListTT.mapBody (pitchBendValueToSample range center)) $
getSlice (maybePitchBend chan)
-- getPitchBendEvents chan
{-# INLINE getChannelPressureSignal #-}
getChannelPressureSignal ::
(Storable y, Trans.C y) =>
Channel ->
y -> y ->
Filter (SigSt.T y)
getChannelPressureSignal chan maxVal initVal =
liftM (controllerValuesToSignal initVal .
EventListTT.mapBody (controllerValueToSample (0,maxVal))) $
getSlice (maybeChannelPressure chan)
{-# INLINE getFMSignalFromBendWheelPressure #-}
getFMSignalFromBendWheelPressure ::
(Storable y, RealField.C y, Trans.C y) =>
Channel ->
Int -> y -> y -> y ->
Filter (SigSt.T y)
getFMSignalFromBendWheelPressure chan
pitchRange speed wheelDepth pressDepth =
do bend <- getPitchBendSignal chan (2^?(fromIntegral pitchRange/12)) 1
fm <- getControllerSignal chan VoiceMsg.modulation (0,wheelDepth) 0
press <- getChannelPressureSignal chan pressDepth 0
return $
flip (SigS.zipWithStorable (*)) bend $
SigS.map (1+) $
FiltNRS.envelope
(DispS.mix
(SigS.fromStorableSignal fm)
(SigS.fromStorableSignal press))
(OsciS.static Wave.sine zero speed)
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))
{- |
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 ::
(Storable yv, Additive.C yv) =>
SVL.ChunkSize ->
Channel ->
Program ->
(EventListTT.T LazyTime Note ->
EventListTT.T LazyTime (SigSt.T yv)) ->
Filter (SigSt.T yv)
getNoteSignalCore chunkSize chan initPgm modulator =
fmap (CutSt.arrangeEquidist chunkSize .
EventListTM.switchTimeR const .
EventListTT.mapTime fromIntegral .
insertBreaks .
modulator .
matchNoteEvents .
embedPrograms initPgm) $
getNoteEvents chan
errorNoProgram :: Program
errorNoProgram =
error "MIDI program not initialized"
{-# INLINE getNoteSignal #-}
getNoteSignal ::
(Storable yv, Additive.C yv, Trans.C y) =>
SVL.ChunkSize ->
Channel ->
Instrument y yv ->
Filter (SigSt.T yv)
getNoteSignal chunkSize chan instr =
getNoteSignalCore chunkSize chan errorNoProgram (makeInstrumentSounds instr)
{-# INLINE getNoteSignalModulated #-}
getNoteSignalModulated ::
(Storable c, Storable yv, Additive.C yv, Trans.C y) =>
SVL.ChunkSize ->
SigSt.T c ->
Channel ->
(SigSt.T c -> Instrument y yv) ->
Filter (SigSt.T yv)
getNoteSignalModulated chunkSize ctrl chan instr =
getNoteSignalCore chunkSize chan errorNoProgram
(flip evalState ctrl .
EventListTT.mapM
advanceModulationChunky
(\note -> gets $ \c -> renderInstrumentIgnoreProgram (instr c) note))
{-# INLINE getNoteSignalMultiModulated #-}
getNoteSignalMultiModulated ::
(Storable yv, Additive.C yv, Trans.C y) =>
SVL.ChunkSize ->
Channel ->
instrument ->
(EventListTT.T LazyTime (instrument, Note) ->
EventListTT.T LazyTime (Instrument y yv, Note)) ->
Filter (SigSt.T yv)
getNoteSignalMultiModulated chunkSize chan instr modulator =
getNoteSignalCore chunkSize chan errorNoProgram
(EventListTT.mapBody (uncurry renderInstrumentIgnoreProgram) .
modulator .
EventListTT.mapBody ((,) instr))
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
advanceModulationLazy, advanceModulationStrict, advanceModulationChunky ::
(Storable a) =>
LazyTime -> State (SigSt.T a) LazyTime
{-
This one drops lazily,
such that the control signal will be cached until it is used.
That is, if for a long time no new note is played,
more and more memory will be allocated.
-}
advanceModulationLazy t =
modify (SigStV.drop (chunkSizesFromLazyTime t)) >> return t
{-
This one is too strict,
because the complete drop is forced
also if only the first chunk of the lazy time is requested.
-}
advanceModulationStrict t = state $ \xs ->
let ys = SigStV.drop (chunkSizesFromLazyTime t) xs
in (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)
{-# INLINE getNoteSignalMultiProgram #-}
getNoteSignalMultiProgram ::
(Storable yv, Additive.C yv, Trans.C y) =>
SVL.ChunkSize ->
Channel ->
Program ->
[Instrument y yv] ->
Filter (SigSt.T yv)
getNoteSignalMultiProgram chunkSize chan initPgm instrs =
let bank = makeInstrumentArray instrs
in getNoteSignalCore chunkSize chan initPgm
(EventListTT.mapBody (renderInstrument
(getInstrumentFromArray bank initPgm)))