synthesizer-alsa-0.3: src/Synthesizer/PiecewiseConstant/ALSA/MIDIControllerSet.hs
{- |
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))