{-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.MIDI.EventList where import qualified Sound.MIDI.Message.Class.Check as Check import qualified Sound.MIDI.Message.Channel as ChannelMsg import qualified Sound.MIDI.Message.Channel.Mode as Mode import qualified Data.EventList.Relative.TimeBody as EventList import qualified Data.EventList.Relative.MixedBody as EventListMB import qualified Data.EventList.Relative.BodyBody as EventListBB import Control.Monad.Trans.State (State, state, evalState, gets, put, ) import Data.Traversable (traverse, ) import qualified Numeric.NonNegative.Class as NonNeg import qualified Numeric.NonNegative.Wrapper as NonNegW import qualified Numeric.NonNegative.Chunky as NonNegChunky import Data.Array (Array, listArray, (!), bounds, inRange, ) import qualified Data.List.HT as ListHT import Data.Tuple.HT (mapPair, mapFst, mapSnd, ) import Data.Maybe.HT (toMaybe, ) import Data.Maybe (catMaybes, isNothing, ) import Control.Monad.HT ((<=<), ) import Control.Monad (guard, msum, ) import NumericPrelude.Numeric import NumericPrelude.Base type StrictTime = NonNegW.Integer {- Maybe we could use StorableVector.Pattern.LazySize or we could use synthesizer-core/ChunkySize. What package should we rely on? Which one is more portable? We do not use this type for timing in event lists anymore. It worked in principle but left us with a couple of memory leaks, that I could never identify and eliminate completely. -} type LazyTime = NonNegChunky.T NonNegW.Integer -- * event filters type Filter event = State (EventList.T StrictTime [event]) {- | We turn the strict time values into lazy ones according to the breaks by our beat. However for the laziness breaks we ignore the events that are filtered out. That is we loose laziness granularity but hopefully gain efficiency by larger blocks. -} getSlice :: (event -> Maybe a) -> Filter event (EventList.T StrictTime [a]) getSlice f = state $ EventList.unzip . fmap (ListHT.partitionMaybe f) type Channel = ChannelMsg.Channel type Controller = ChannelMsg.Controller type Pitch = ChannelMsg.Pitch type Velocity = ChannelMsg.Velocity type Program = ChannelMsg.Program getControllerEvents :: (Check.C event) => Channel -> Controller -> Filter event (EventList.T StrictTime [Int]) getControllerEvents chan ctrl = getSlice (Check.controller chan ctrl) {- getControllerEvents :: (Check.C event) => Channel -> Controller -> Filter event (EventList.T StrictTime (Maybe Int)) getControllerEvents chan ctrl = fmap (fmap (fmap snd . ListHT.viewR)) $ getSlice (Check.controller chan ctrl) -} data NoteBoundary a = NoteBoundary Pitch Velocity a | AllNotesOff deriving (Eq, Show) data Note = Note Program Pitch Velocity LazyTime deriving (Eq, Show) case_ :: Maybe a -> (a -> b) -> Maybe b case_ = flip fmap {- We could also provide a function which filters for specific programs/presets. -} getNoteEvents :: (Check.C event) => Channel -> Filter event (EventList.T StrictTime [Either Program (NoteBoundary Bool)]) getNoteEvents chan = getSlice $ checkNoteEvent chan checkNoteEvent :: (Check.C event) => Channel -> event -> Maybe (Either Program (NoteBoundary Bool)) checkNoteEvent chan e = msum $ case_ (Check.noteExplicitOff chan e) (\(velocity, pitch, press) -> Right $ NoteBoundary pitch velocity press) : case_ (Check.program chan e) Left : {- We do not handle AllSoundOff here, since this would also mean to clear reverb buffers and this cannot be handled here. -} (Check.mode chan e >>= \mode -> do guard (mode == Mode.AllNotesOff) return (Right AllNotesOff)) : [] embedPrograms :: Program -> EventList.T StrictTime [Either Program (NoteBoundary Bool)] -> EventList.T StrictTime [NoteBoundary (Maybe Program)] embedPrograms initPgm = fmap catMaybes . flip evalState initPgm . traverse (traverse embedProgramState) embedProgramState :: Either Program (NoteBoundary Bool) -> State Program (Maybe (NoteBoundary (Maybe Program))) embedProgramState = -- evaluate program for every event in order to prevent a space leak (\n -> state (\s -> (seq s n, s))) <=< either (\pgm -> put pgm >> return Nothing) (\bnd -> gets (Just . case bnd of AllNotesOff -> const AllNotesOff NoteBoundary p v press -> NoteBoundary p v . toMaybe press)) matchNoteEvents :: EventList.T StrictTime [NoteBoundary (Maybe Program)] -> EventList.T StrictTime [Note] matchNoteEvents = matchNoteEventsCore $ \bndOn -> case bndOn of AllNotesOff -> Nothing NoteBoundary pitchOn velOn pressOn -> flip fmap pressOn $ \pgm -> (\bndOff -> case bndOff of AllNotesOff -> True NoteBoundary pitchOff _velOff pressOff -> pitchOn == pitchOff && isNothing pressOff, Note pgm pitchOn velOn) matchNoteEventsCore :: (noteBnd -> Maybe (noteBnd -> Bool, LazyTime -> Note)) -> EventList.T StrictTime [noteBnd] -> EventList.T StrictTime [Note] matchNoteEventsCore methods = let recourseEvents = EventListMB.switchBodyL $ \evs0 xs0 -> case evs0 of [] -> ([], xs0) ev:evs -> case methods ev of Nothing -> recourseEvents (EventListMB.consBody evs xs0) Just (check, cons) -> case durationRemove check (EventListMB.consBody evs xs0) of (dur, xs1) -> mapFst (cons dur :) (recourseEvents xs1) recourse = EventList.switchL EventList.empty $ \(t,evs0) xs0 -> let (evs1,xs1) = recourseEvents (EventListMB.consBody evs0 xs0) in EventList.cons t evs1 $ recourse xs1 in recourse {- durationRemove Char.isUpper ("a" ./ 3 /. "bf" ./ 5 /. "aCcd" ./ empty :: Data.EventList.Relative.BodyBody.T StrictTime [Char]) -} {- | Search for specific event, return its time stamp and remove it. -} durationRemove :: (NonNeg.C time) => (body -> Bool) -> EventListBB.T time [body] -> (NonNegChunky.T time, EventListBB.T time [body]) durationRemove p = let errorEndOfList = (error "no matching body element found", error "list ended before matching element found") recourse = EventListMB.switchBodyL $ \evs xs0 -> let (prefix, suffix0) = break p evs (suffix1, rest) = case suffix0 of [] -> ([], flip (EventListMB.switchTimeL errorEndOfList) xs0 $ \t xs1 -> mapPair (NonNegChunky.fromChunks . (t:) . NonNegChunky.toChunks, EventListMB.consTime t) $ recourse xs1) _:ys -> (ys, (NonNeg.zero, xs0)) in mapSnd (EventListMB.consBody (prefix++suffix1)) rest in recourse durationRemoveTB :: (NonNeg.C time) => (body -> Bool) -> EventList.T time [body] -> (NonNegChunky.T time, EventList.T time [body]) durationRemoveTB p = let errorEndOfList = (error "no matching body element found", error "list ended before matching element found") recourse = EventList.switchL errorEndOfList $ \(t,evs) xs -> let (prefix, suffix0) = break p evs (suffix1, rest) = case suffix0 of [] -> ([], recourse xs) _:ys -> (ys, (NonNeg.zero, xs)) in mapPair (NonNegChunky.fromChunks . (t:) . NonNegChunky.toChunks, EventList.cons t (prefix++suffix1)) rest in recourse -- ToDo: move to somewhere else, this has nothing todo with event lists makeInstrumentArray :: [instr] -> Array Program instr makeInstrumentArray instrs = listArray (ChannelMsg.toProgram 0, ChannelMsg.toProgram (length instrs - 1)) instrs getInstrumentFromArray :: Array Program instr -> Program -> Program -> instr getInstrumentFromArray bank defltPgm pgm = bank ! if inRange (bounds bank) pgm then pgm else defltPgm