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 Numeric.NonNegative.Class as NonNeg98
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.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, )
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)
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
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)
dropMarginRem n m xs =
List.foldl'
(\(mi,xsi) k -> (mik, CutG.drop k xsi))
(m, xs)
(List.map P.fromIntegral $ EventListTT.getTimes $
EventListTT.takeTime (P.fromIntegral m) $
EventListTT.dropTime (P.fromIntegral n) $
stream xs)
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)
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))
controllerLinear ::
(Field.C y) =>
Ev.Controller -> (y,y) -> y -> Filter (PC.T y)
controllerLinear ctrl bnd =
getSlice (Controller ctrl) (MV.controllerLinear bnd)
controllerExponential ::
(Trans.C y) =>
Ev.Controller -> (y,y) -> y -> Filter (PC.T y)
controllerExponential ctrl bnd =
getSlice (Controller ctrl) (MV.controllerExponential bnd)
pitchBend ::
(Trans.C y) =>
y -> y ->
Filter (PC.T y)
pitchBend range center =
getSlice PitchBend (MV.pitchBend range center) center
channelPressure ::
(Trans.C y) =>
y -> y ->
Filter (PC.T y)
channelPressure maxVal =
getSlice Pressure (MV.controllerLinear (Additive.zero,maxVal))
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))