{- | Treat a stream of MIDI events as parallel streams of MIDI controller events. -} {-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.MIDI.PiecewiseConstant.ControllerSet ( T(Cons), mapStream, Controller(Controller,PitchBend,Pressure), fromChannel, maybeController, controllerLinear, controllerExponential, pitchBend, channelPressure, bendWheelPressure, checkBendWheelPressure, bendWheelPressureZip, -- * internal data needed in synthesizer-llvm initial, stream, ) where import qualified Synthesizer.PiecewiseConstant.Signal as PC import qualified Synthesizer.MIDI.EventList as Ev import Synthesizer.MIDI.EventList (StrictTime, Channel, ) import qualified Sound.MIDI.Message.Class.Check as Check import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg import qualified Synthesizer.MIDI.Value.BendModulation as BM import qualified Synthesizer.MIDI.Value.BendWheelPressure as BWP import qualified Synthesizer.MIDI.Value as MV 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.Map as Map import Data.Map (Map, ) import qualified Data.Accessor.Monad.Trans.State as AccState import qualified Data.Accessor.Basic as Acc import Control.Monad.Trans.State (State, evalState, state, get, put, ) import Control.Monad (liftM2, msum, ) 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 {- 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 :: (Check.C event) => Channel -> Ev.Filter event (T Controller Int) fromChannel chan = fmap (Cons Map.empty) $ fmap (flip EventListTM.snocTime NonNeg98.zero) $ Ev.getSlice (maybeController chan) maybeController :: (Check.C event) => Channel -> event -> Maybe (Controller, Int) maybeController chan e = msum $ (fmap (mapFst Controller) $ Check.anyController chan e) : (fmap ((,) PitchBend) $ Check.pitchBend chan e) : (fmap ((,) Pressure) $ Check.channelPressure 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.MIDI.PiecewiseConstant.ControllerSet 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 {-# INLINE getSlice #-} 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)) -- adapted from getSlice {-# INLINE bendWheelPressure #-} bendWheelPressure :: (RealRing.C y, Trans.C y) => Int -> y -> y -> Filter (PC.T (BM.T y)) bendWheelPressure pitchRange wheelDepth pressDepth = state $ \xs -> let (ys,zs) = EventListTT.unzip $ fmap ListHT.unzipEithers $ flip evalState BWP.deflt $ traverse (traverse separateBWP) (stream xs) move key field (bwp,mp) = mapFst (maybe bwp (\y -> Acc.set field y bwp)) $ Map.updateLookupWithKey (\ _k _a -> Nothing) key mp (yin,zis) = move PitchBend BWP.bend $ move (Controller VoiceMsg.modulation) BWP.wheel $ move Pressure BWP.pressure $ (BWP.deflt, initial xs) fill = flip evalState yin . traverse (\ys0 -> traverse_ put ys0 >> get) in (fmap (BM.fromBendWheelPressure pitchRange wheelDepth pressDepth) $ EventListMT.consBody yin (fill ys), Cons zis zs) separateBWP :: (Controller, Int) -> State BWP.T (Either BWP.T (Controller, Int)) separateBWP ev = fmap (maybe (Right ev) Left) $ checkBendWheelPressure ev checkBendWheelPressure :: (Controller, Int) -> State BWP.T (Maybe BWP.T) checkBendWheelPressure (ctrl,val) = let update field = AccState.set field val >> fmap Just get in case ctrl of PitchBend -> update BWP.bend Pressure -> update BWP.pressure Controller cc -> if cc == VoiceMsg.modulation then update BWP.wheel else return $ Nothing {-# INLINE bendWheelPressureZip #-} bendWheelPressureZip :: (RealRing.C y, Trans.C y) => Int -> y -> y -> Filter (PC.T (BM.T y)) bendWheelPressureZip pitchRange wheelDepth pressDepth = liftM2 (PC.zipWith BM.Cons) (pitchBend (2 ^? (fromIntegral pitchRange / 12)) 1) (liftM2 (PC.zipWith (+)) (controllerLinear VoiceMsg.modulation (0,wheelDepth) 0) (channelPressure pressDepth 0))