{-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.EventList.ALSA.MIDI where import qualified Sound.ALSA.Sequencer.Address as Addr import qualified Sound.ALSA.Sequencer.Client as Client import qualified Sound.ALSA.Sequencer.Port as Port import qualified Sound.ALSA.Sequencer.Event as Event import qualified Sound.ALSA.Sequencer.Queue as Queue import qualified Sound.ALSA.Sequencer.RealTime as RealTime import qualified Sound.ALSA.Sequencer as SndSeq import qualified Sound.ALSA.Exception as AlsaExc import qualified Data.EventList.Relative.TimeBody as EventList -- import qualified Data.EventList.Relative.TimeTime as EventListTT import qualified Data.EventList.Relative.MixedBody as EventListMB -- import qualified Data.EventList.Relative.BodyMixed as EventListBM -- 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.BodyBody as EventListBB import qualified Data.EventList.Absolute.TimeBody as AbsEventList import qualified Sound.MIDI.Message.Channel as ChannelMsg import qualified Sound.MIDI.Message.Channel.Mode as Mode import qualified Sound.MIDI.ALSA as MALSA import qualified Data.Accessor.Basic as Acc import Data.Accessor.Basic ((^.), ) import System.IO.Unsafe (unsafeInterleaveIO, ) import Control.Concurrent (threadDelay) import System.Time (ClockTime(TOD), getClockTime, ) import Control.Monad.Trans.State (State, state, evalState, modify, get, 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.Monoid (Monoid, mconcat, mappend, ) import qualified Algebra.ToRational as ToRational import qualified Algebra.RealField as RealField import qualified Algebra.Field as Field -- import qualified Algebra.Additive as Additive 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 (liftM, liftM2, guard, ) import qualified Data.List as List import NumericPrelude.Numeric import NumericPrelude.Base import qualified Prelude as P -- import Debug.Trace (trace, ) {- | The @time@ type needs high precision, so you will certainly have to instantiate it with 'Double'. 'Float' has definitely not enough bits. -} getTimeSeconds :: Field.C time => IO time getTimeSeconds = fmap clockTimeToSeconds getClockTime clockTimeToSeconds :: Field.C time => ClockTime -> time clockTimeToSeconds (TOD secs picos) = fromInteger secs + fromInteger picos * 1e-12 wait :: RealField.C time => time -> IO () wait t1 = do t0 <- getTimeSeconds threadDelay $ floor $ 1e6*(t1-t0) {- We cannot easily turn this into a custom type, since we need Maybe Event.T sometimes. -} type StampedEvent time = (time, Event.T) {- | only use it for non-blocking sequencers We ignore ALSA time stamps and use the time of fetching the event, because I don't know whether the ALSA time stamps are in sync with getClockTime. -} getStampedEvent :: (Field.C time, SndSeq.AllowInput mode) => SndSeq.T mode -> IO (StampedEvent time) getStampedEvent h = liftM2 (,) getTimeSeconds (Event.input h) {- | only use it for non-blocking sequencers -} getWaitingStampedEvents :: (Field.C time, SndSeq.AllowInput mode) => SndSeq.T mode -> IO [StampedEvent time] getWaitingStampedEvents h = let loop = AlsaExc.catch (liftM2 (:) (getStampedEvent h) loop) (const $ return []) in loop {- | only use it for blocking sequencers -} getEventsUntilEcho_ :: (Field.C time, SndSeq.AllowInput mode) => SndSeq.T mode -> IO [StampedEvent time] getEventsUntilEcho_ h = let loop = do ev <- Event.input h let t = case Event.timestamp ev of Event.RealTime rt -> -- realToFrac $ fromRational' $ toRational $ RealTime.toDouble rt _ -> error "unsupported time stamp type" case Event.body ev of Event.CustomEv Event.Echo _ -> return [] _ -> liftM ((t,ev):) loop in loop getEventsUntilEcho :: (SndSeq.AllowInput mode) => Client.T -> SndSeq.T mode -> IO [Event.T] getEventsUntilEcho c h = let loop = do ev <- Event.input h let abort = case Event.body ev of Event.CustomEv Event.Echo _ -> c == Addr.client (Event.source ev) _ -> False if abort then return [] else liftM (ev:) loop in loop getWaitingEvents :: (SndSeq.AllowInput mode) => SndSeq.T mode -> IO [Event.T] getWaitingEvents h = let loop = AlsaExc.catch (liftM2 (:) (Event.input h) loop) (const $ return []) in loop type StrictTime = NonNegW.Integer {- | Returns a list of non-zero times. -} {-# INLINE chopLongTime #-} chopLongTime :: StrictTime -> [StrictTime] chopLongTime n = let d = NonNegW.fromNumber $ fromIntegral (maxBound :: Int) (q,r) = P.divMod n d in List.genericReplicate q d ++ if r /= NonNeg.zero then [r] else [] {- ghc -i:src -e 'withMIDIEvents 44100 print' src/Synthesizer/Storable/ALSA/MIDI.hs -} {- Maybe it is better to not use type variable for sample rate, because ALSA supports only integers, and if ALSA sample rate and sample rate do not match due to rounding errors, then play and event fetching get out of sync over the time. -} withMIDIEvents :: (RealField.C time) => time -> time -> (EventList.T StrictTime [Event.T] -> IO a) -> IO a withMIDIEvents = withMIDIEventsBlockEcho {- as a quick hack, we neglect the ALSA time stamp and use getTime or so -} withMIDIEventsNonblockWaitGrouped :: (RealField.C time) => time -> time -> (EventList.T StrictTime [Event.T] -> IO a) -> IO a withMIDIEventsNonblockWaitGrouped beat rate proc = withInPort SndSeq.Nonblock $ \ h _p -> do start <- getTimeSeconds l <- lazySequence $ flip map (iterate (beat+) start) $ \t -> wait t >> liftM (\evs -> (t, evs)) (getWaitingEvents h) {- liftM2 (,) getTimeSeconds (getWaitingEvents h) -} proc $ discretizeTime rate $ AbsEventList.fromPairList l {- With this function latency becomes longer and longer if xruns occur, but the latency is not just adapted, but ones xruns occur, this implies more and more xruns. -} withMIDIEventsNonblockWaitDefer :: (RealField.C time) => time -> time -> (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a withMIDIEventsNonblockWaitDefer beat rate proc = withInPort SndSeq.Nonblock $ \ h _p -> do start <- getTimeSeconds l <- lazySequence $ flip map (iterate (beat+) start) $ \t -> wait t >> liftM (\ es -> (t, Nothing) : map (mapSnd Just) es) (getWaitingStampedEvents h) proc $ discretizeTime rate $ {- delay events that are in wrong order disadvantage: we cannot guarantee a beat with a minimal period -} flip evalState start $ AbsEventList.mapTimeM (\t -> modify (max t) >> get) $ AbsEventList.fromPairList $ concat l {- We risk and endless skipping when the beat is too short. (Or debug output slows down processing.) -} withMIDIEventsNonblockWaitSkip :: (RealField.C time) => time -> time -> (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a withMIDIEventsNonblockWaitSkip beat rate proc = withInPort SndSeq.Nonblock $ \ h _p -> do start <- getTimeSeconds l <- lazySequence $ flip map (iterate (beat+) start) $ \t -> do wait t t0 <- getTimeSeconds -- print (t-start,t0-start) es <- if t0>=t+beat then return [] else getWaitingStampedEvents h return $ (t0, Nothing) : map (mapSnd Just) es proc $ discretizeTime rate $ AbsEventList.fromPairList $ concat l withMIDIEventsNonblockWaitMin :: (RealField.C time) => time -> time -> (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a withMIDIEventsNonblockWaitMin beat rate proc = withInPort SndSeq.Nonblock $ \ h _p -> do start <- getTimeSeconds l <- lazySequence $ flip map (iterate (beat+) start) $ \t -> wait t >> liftM (\ es -> (minimum $ t : map fst es, Nothing) : map (mapSnd Just) es) (getWaitingStampedEvents h) {- mapM_ print $ EventList.toPairList $ discretizeTime rate $ AbsEventList.fromPairList $ concat l proc undefined -} proc $ discretizeTime rate $ AbsEventList.fromPairList $ concat l withMIDIEventsNonblockConstantPause :: (RealField.C time) => time -> time -> (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a withMIDIEventsNonblockConstantPause beat rate proc = withInPort SndSeq.Nonblock $ \ h _p -> do l <- ioToLazyList $ threadDelay (round $ flip asTypeOf rate $ beat*1e6) >> liftM2 (:) (liftM (\t->(t,Nothing)) getTimeSeconds) (liftM (map (mapSnd Just)) (getWaitingStampedEvents h)) proc $ discretizeTime rate $ AbsEventList.fromPairList $ concat l withMIDIEventsNonblockSimple :: (RealField.C time) => time -> time -> (EventList.T StrictTime Event.T -> IO a) -> IO a withMIDIEventsNonblockSimple beat rate proc = withInPort SndSeq.Nonblock $ \ h _p -> do l <- ioToLazyList $ threadDelay (round $ flip asTypeOf rate $ beat*1e6) >> getWaitingStampedEvents h proc $ discretizeTime rate $ AbsEventList.fromPairList $ concat l withMIDIEventsBlockEcho :: (RealField.C time) => time -> time -> (EventList.T StrictTime [Event.T] -> IO a) -> IO a withMIDIEventsBlockEcho beat rate proc = withInPort SndSeq.Block $ \ h p -> Queue.with h $ \ q -> do {- info <- PortInfo.get h p PortInfo.setTimestamping info True PortInfo.setTimestampReal info True PortInfo.setTimestampQueue info q PortInfo.set h p info -} Queue.control h q Event.QueueStart 0 Nothing Event.drainOutput h c <- Client.getId h l <- lazySequence $ flip map (iterate (beat+) 0) $ \t -> do Event.output h $ makeEcho c q p (t+beat) (Event.Custom 0 0 0) Event.drainOutput h liftM (\evs -> (t, evs)) (getEventsUntilEcho c h) proc $ discretizeTime rate $ AbsEventList.fromPairList l makeEcho :: RealField.C time => Client.T -> Queue.T -> Port.T -> time -> Event.Custom -> Event.T makeEcho c q p t dat = Event.Cons { Event.highPriority = False , Event.tag = 0 , Event.queue = q , Event.timestamp = Event.RealTime $ RealTime.fromInteger $ floor (10^9 * t) , Event.source = Addr.Cons { Addr.client = c, Addr.port = Port.unknown } , Event.dest = Addr.Cons { Addr.client = c, Addr.port = p } , Event.body = Event.CustomEv Event.Echo dat } withMIDIEventsBlock :: (RealField.C time) => time -> (EventList.T StrictTime Event.T -> IO a) -> IO a withMIDIEventsBlock rate proc = withInPort SndSeq.Block $ \ h _p -> do l <- ioToLazyList $ getStampedEvent h proc $ discretizeTime rate $ AbsEventList.fromPairList l withInPort :: SndSeq.BlockMode -> (SndSeq.T SndSeq.DuplexMode -> Port.T -> IO t) -> IO t withInPort blockMode act = SndSeq.with SndSeq.defaultName blockMode $ \h -> Client.setName h "Haskell-Synthesizer" >> Port.withSimple h "listener" (Port.caps [Port.capWrite, Port.capSubsWrite]) Port.typeMidiGeneric (act h) {- | We first discretize the absolute time values, then we compute differences, in order to avoid rounding errors in further computations. -} discretizeTime :: (RealField.C time) => time -> AbsEventList.T time a -> EventList.T StrictTime a discretizeTime sampleRate = EventListMB.mapTimeHead (const $ NonNegW.fromNumber zero) . -- clear first time since it is an absolute system time stamp EventList.fromAbsoluteEventList . AbsEventList.mapTime (NonNegW.fromNumberMsg "time conversion" . round . (sampleRate*)) -- * event filters type Filter = State (EventList.T StrictTime [Event.T]) {- 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 {- | 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.T -> Maybe a) -> Filter (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 maybeAnyController :: Channel -> Event.T -> Maybe (Controller, Int) maybeAnyController chan e = do -- let Event.TickTime n = Event.timestamp e Event.CtrlEv Event.Controller c <- Just $ Event.body e guard (c ^. MALSA.ctrlChannel == chan) MALSA.Controller cn cv <- Just $ c ^. MALSA.ctrlControllerMode return (cn, cv) maybeController :: Channel -> Controller -> Event.T -> Maybe Int maybeController chan ctrl e = do (c,n) <- maybeAnyController chan e guard (ctrl==c) return n getControllerEvents :: Channel -> Controller -> Filter (EventList.T StrictTime [Int]) getControllerEvents chan ctrl = getSlice (maybeController chan ctrl) {- getControllerEvents :: Channel -> Controller -> Filter (EventList.T StrictTime (Maybe Int)) getControllerEvents chan ctrl = fmap (fmap (fmap snd . ListHT.viewR)) $ getSlice (maybeController chan ctrl) -} maybePitchBend :: Channel -> Event.T -> Maybe Int maybePitchBend chan e = case Event.body e of Event.CtrlEv Event.PitchBend c -> toMaybe (c ^. MALSA.ctrlChannel == chan) (c ^. MALSA.ctrlValue) _ -> Nothing maybeChannelPressure :: Channel -> Event.T -> Maybe Int maybeChannelPressure chan e = case Event.body e of Event.CtrlEv Event.ChanPress c -> toMaybe (c ^. MALSA.ctrlChannel == chan) (c ^. MALSA.ctrlValue) _ -> Nothing data NoteBoundary a = NoteBoundary Pitch Velocity a | AllNotesOff deriving (Eq, Show) data Note = Note Program Pitch Velocity LazyTime deriving (Eq, Show) {- We could also provide a function which filters for specific programs/presets. -} getNoteEvents :: Channel -> Filter (EventList.T StrictTime [Either Program (NoteBoundary Bool)]) getNoteEvents chan = getSlice $ \e -> case Event.body e of Event.NoteEv notePart note -> do guard (note ^. MALSA.noteChannel == chan) let (part,vel) = MALSA.normalNoteFromEvent notePart note press <- case part of Event.NoteOn -> Just True Event.NoteOff -> Just False _ -> Nothing return $ Right $ NoteBoundary (note ^. MALSA.notePitch) vel press Event.CtrlEv Event.PgmChange ctrl -> do guard (ctrl ^. MALSA.ctrlChannel == chan) return $ Left $ ctrl ^. MALSA.ctrlProgram {- We do not handle AllSoundOff here, since this would also mean to clear reverb buffers and this cannot be handled here. -} Event.CtrlEv Event.Controller ctrl -> do guard (ctrl ^. MALSA.ctrlControllerMode == MALSA.Mode Mode.AllNotesOff) return $ Right AllNotesOff _ -> Nothing embedPrograms :: Program -> EventList.T StrictTime [Either Program (NoteBoundary Bool)] -> EventList.T StrictTime [NoteBoundary (Maybe Program)] embedPrograms initPgm = fmap catMaybes . flip evalState initPgm . traverse (traverse (-- 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 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 ioToLazyList :: IO a -> IO [a] ioToLazyList m = let go = unsafeInterleaveIO $ liftM2 (:) m go in go lazySequence :: [IO a] -> IO [a] lazySequence [] = return [] lazySequence (m:ms) = unsafeInterleaveIO $ liftM2 (:) m $ lazySequence ms