{-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.EventList.ALSA.MIDI where import qualified Sound.Alsa.Sequencer as ALSA 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.Absolute.TimeBody as AbsEventList import qualified Sound.MIDI.Message.Channel as ChannelMsg import System.IO.Unsafe (unsafeInterleaveIO, ) import Control.Concurrent (threadDelay) import System.Time (ClockTime(TOD), getClockTime, ) import Control.Exception (bracket, ) import Control.Monad.Trans.State (State, state, evalState, modify, get, gets, put, ) -- import qualified Numeric.NonNegative.Class as NonNeg import qualified Numeric.NonNegative.Wrapper as NonNegW import qualified Numeric.NonNegative.ChunkyPrivate as NonNegChunky import Data.Monoid (Monoid, mappend, mempty, ) 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 Data.Tuple.HT (mapPair, mapSnd, ) import Data.Maybe.HT (toMaybe, ) import Data.Maybe (isNothing, ) import Control.Monad (liftM, liftM2, guard, ) import NumericPrelude import PreludeBase hiding (break, ) -- 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 ALSA.Event sometimes. -} type StampedEvent time = (time, ALSA.Event) {- | 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 => ALSA.SndSeq -> IO (StampedEvent time) getStampedEvent h = liftM2 (,) getTimeSeconds (ALSA.event_input h) {- | only use it for non-blocking sequencers -} getWaitingStampedEvents :: Field.C time => ALSA.SndSeq -> IO [StampedEvent time] getWaitingStampedEvents h = let loop = ALSA.alsa_catch (liftM2 (:) (getStampedEvent h) loop) (const $ return []) in loop getWaitingEvents :: ALSA.SndSeq -> IO [ALSA.Event] getWaitingEvents h = let loop = ALSA.alsa_catch (liftM2 (:) (ALSA.event_input h) loop) (const $ return []) in loop {- This should be a parameter for the functions, that use it. It is essential for controlling the maximum chunk size. -} beat :: Field.C time => time beat = 0.01 type StrictTime = NonNegW.Integer {- ghc -i:src -e 'withMIDIEventsNonblock 44100 print' src/Synthesizer/Storable/ALSA/MIDI.hs -} {- as a quick hack, we neglect the ALSA time stamp and use getTime or so 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. -} withMIDIEventsNonblock :: (RealField.C time) => time -> (EventList.T StrictTime (Maybe ALSA.Event) -> IO a) -> IO a withMIDIEventsNonblock = withMIDIEventsNonblockWaitGrouped withMIDIEventsNonblockWaitGrouped :: (RealField.C time) => time -> (EventList.T StrictTime (Maybe ALSA.Event) -> IO a) -> IO a withMIDIEventsNonblockWaitGrouped rate proc = withInPort ALSA.Nonblock $ \ h _p -> do start <- getTimeSeconds l <- lazySequence $ flip map (iterate (beat+) start) $ \t -> wait t >> liftM (\evs -> (t, Nothing : map Just evs)) (getWaitingEvents h) {- liftM2 (,) getTimeSeconds (liftM (\evs -> Nothing : map Just evs) $ getWaitingEvents h) -} proc $ EventList.flatten $ 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 -> (EventList.T StrictTime (Maybe ALSA.Event) -> IO a) -> IO a withMIDIEventsNonblockWaitDefer rate proc = withInPort ALSA.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 -> (EventList.T StrictTime (Maybe ALSA.Event) -> IO a) -> IO a withMIDIEventsNonblockWaitSkip rate proc = withInPort ALSA.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 -> (EventList.T StrictTime (Maybe ALSA.Event) -> IO a) -> IO a withMIDIEventsNonblockWaitMin rate proc = withInPort ALSA.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 -> (EventList.T StrictTime (Maybe ALSA.Event) -> IO a) -> IO a withMIDIEventsNonblockConstantPause rate proc = withInPort ALSA.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 -> (EventList.T StrictTime ALSA.Event -> IO a) -> IO a withMIDIEventsNonblockSimple rate proc = withInPort ALSA.Nonblock $ \ h _p -> do l <- ioToLazyList $ threadDelay (round $ flip asTypeOf rate $ beat*1e6) >> getWaitingStampedEvents h proc $ discretizeTime rate $ AbsEventList.fromPairList $ concat l withMIDIEventsBlock :: (RealField.C time) => time -> (EventList.T StrictTime ALSA.Event -> IO a) -> IO a withMIDIEventsBlock rate proc = withInPort ALSA.Block $ \ h _p -> do l <- ioToLazyList $ getStampedEvent h proc $ discretizeTime rate $ AbsEventList.fromPairList l withInPort :: ALSA.BlockMode -> (ALSA.SndSeq -> ALSA.Port -> IO t) -> IO t withInPort blockMode act = bracket (ALSA.open ALSA.default_seq_name ALSA.open_input blockMode) (ALSA.close) $ \h -> ALSA.set_client_name h "Haskell-Synthesizer" >> (bracket (ALSA.create_simple_port h "listener" (ALSA.caps [ALSA.cap_write, ALSA.cap_subs_write]) ALSA.type_midi_generic) (ALSA.delete_port h) $ \p -> act h p) {- | 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 (Maybe ALSA.Event)) {- 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? -} 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 :: (ALSA.Event -> Maybe a) -> Filter (EventListTT.T LazyTime a) getSlice f = fmap (EventListTT.catMaybesR . flip EventListTM.snocTime NonNegChunky.zero . EventList.mapTime NonNegChunky.fromNumber) $ state (partitionMaybeBeat f) -- state (partitionMaybe (maybe (Just Nothing) (fmap Just . f))) {- | Move all elements that are mapped to @Just@ into another list. -} partitionMaybe :: (a -> Maybe b) -> EventList.T StrictTime a -> (EventList.T StrictTime b, EventList.T StrictTime a) partitionMaybe f = mapPair (EventList.catMaybes, EventList.catMaybes) . EventList.foldrPair (\t a -> let (x,y) = case f a of Just b -> (Just b, Nothing) Nothing -> (Nothing, Just a) in mapPair (EventList.cons t x, EventList.cons t y)) (EventList.empty, EventList.empty) {- | Move all elements that are mapped to @Just@ into another list. @Nothing@ elements in the source list are maintained in both result lists as laziness breaks. -} partitionMaybeBeat :: (a -> Maybe b) -> EventList.T StrictTime (Maybe a) -> (EventList.T StrictTime (Maybe b), EventList.T StrictTime (Maybe a)) partitionMaybeBeat f = mapPair (EventList.catMaybes, EventList.catMaybes) . EventList.foldrPair (\t a0 -> let (x,y) = case a0 of Nothing -> (Just Nothing, Just Nothing) Just a1 -> case f a1 of Just b -> (Just $ Just b, Nothing) Nothing -> (Nothing, Just $ Just a1) in mapPair (EventList.cons t x, EventList.cons t y)) (EventList.empty, EventList.empty) type Channel = ChannelMsg.Channel type Controller = ChannelMsg.Controller type Pitch = ChannelMsg.Pitch type Velocity = ChannelMsg.Velocity type Program = ChannelMsg.Program maybeController :: Channel -> Controller -> ALSA.Event -> Maybe (Int, Int) maybeController chan ctrl e = let ALSA.TickTime n = ALSA.ev_timestamp e in case ALSA.ev_data e of ALSA.CtrlEv ALSA.Controller c -> toMaybe (fromIntegral (ALSA.ctrl_channel c) == ChannelMsg.fromChannel chan && fromIntegral (ALSA.ctrl_param c) == ChannelMsg.fromController ctrl) (fromIntegral n, fromIntegral $ ALSA.ctrl_value c) _ -> Nothing getControllerEvents :: Channel -> Controller -> Filter (EventListTT.T LazyTime Int) getControllerEvents chan ctrl = getSlice (fmap snd . maybeController chan ctrl) maybePitchBend :: Channel -> ALSA.Event -> Maybe Int maybePitchBend chan e = case ALSA.ev_data e of ALSA.CtrlEv ALSA.PitchBend c -> toMaybe (fromIntegral (ALSA.ctrl_channel c) == ChannelMsg.fromChannel chan) (fromIntegral $ ALSA.ctrl_value c) _ -> Nothing maybeChannelPressure :: Channel -> ALSA.Event -> Maybe Int maybeChannelPressure chan e = case ALSA.ev_data e of ALSA.CtrlEv ALSA.ChanPress c -> toMaybe (fromIntegral (ALSA.ctrl_channel c) == ChannelMsg.fromChannel chan) (fromIntegral $ ALSA.ctrl_value c) _ -> Nothing data NoteBoundary a = NoteBoundary Pitch Velocity a 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 (EventListTT.T LazyTime (Either Program (NoteBoundary Bool))) getNoteEvents chan = getSlice $ \e -> case ALSA.ev_data e of ALSA.NoteEv notePart note -> do guard (fromIntegral (ALSA.note_channel note) == ChannelMsg.fromChannel chan) (vel,press) <- case notePart of ALSA.NoteOn -> return $ let v = ALSA.note_velocity note in if v==0 then (64, False) else (fromIntegral v, True) ALSA.NoteOff -> return (fromIntegral $ ALSA.note_velocity note, False) _ -> Nothing return $ Right $ NoteBoundary (ChannelMsg.toPitch $ fromIntegral $ ALSA.note_note note) (ChannelMsg.toVelocity vel) press ALSA.CtrlEv ALSA.PgmChange ctrl -> do guard (fromIntegral (ALSA.ctrl_channel ctrl) == ChannelMsg.fromChannel chan) return $ Left $ ChannelMsg.toProgram $ fromIntegral $ ALSA.ctrl_value ctrl _ -> Nothing embedPrograms :: Program -> EventListTT.T LazyTime (Either Program (NoteBoundary Bool)) -> EventListTT.T LazyTime (NoteBoundary (Maybe Program)) embedPrograms initPgm = EventListTT.catMaybesR . flip evalState initPgm . EventListTT.mapBodyM (either (\pgm -> put pgm >> return Nothing) (\(NoteBoundary p v press) -> gets (Just . NoteBoundary p v . toMaybe press))) matchNoteEventsAlt :: EventListTT.T LazyTime (NoteBoundary (Maybe Program)) -> EventListTT.T LazyTime Note matchNoteEventsAlt = EventListTT.catMaybesR . matchNoteEventsMaybe . EventListTT.mapBody Just matchNoteEventsMaybe :: EventListTT.T LazyTime (Maybe (NoteBoundary (Maybe Program))) -> EventListTT.T LazyTime (Maybe Note) matchNoteEventsMaybe = EventListMT.mapTimeTail $ \r0 -> flip (EventListMT.switchBodyL EventListBT.empty) r0 $ \ev r1 -> case ev of Nothing -> EventListMT.consBody Nothing $ matchNoteEventsMaybe r1 Just (NoteBoundary pitchOn velOn pressOn) -> let (obj,r2) = case pressOn of Nothing -> (Nothing, r1) -- isolated NoteOff event Just pgm -> let (prefix,_noteOff,suffix) = break (maybe False (\(NoteBoundary pitchOff _velOff pressOff) -> pitchOn == pitchOff && isNothing pressOff)) r1 in (Just (Note pgm pitchOn velOn (lazyDuration prefix)), EventListTM.prependBodyEnd (EventListTM.snocBody prefix Nothing) suffix) in EventListMT.consBody obj $ matchNoteEventsMaybe r2 {- We need a version of 'append' that is specialised to the lazy time type. Otherwise @append (2 /. 'a' ./ 4 /. 'b' ./ 3 /. undefined) undefined@ does not return the @'b'@. This makes 'testKeyboard7' omitting the last defined note. In realtime performance this leads to the effect, that notes are only played after the key is released. -} matchNoteEvents :: EventListTT.T LazyTime (NoteBoundary (Maybe Program)) -> EventListTT.T LazyTime Note matchNoteEvents = EventListTT.catMaybesR . matchNoteEventsCore matchNoteEventsCore :: EventListTT.T LazyTime (NoteBoundary (Maybe Program)) -> EventListTT.T LazyTime (Maybe Note) matchNoteEventsCore = EventListMT.mapTimeTail $ \r0 -> flip (EventListMT.switchBodyL EventListBT.empty) r0 $ \(NoteBoundary pitchOn velOn pressOn) r1 -> let (obj,r2) = case pressOn of Nothing -> (Nothing, r1) -- isolated NoteOff event Just pgm -> let (prefix,_noteOff,suffix) = break (\(NoteBoundary pitchOff _velOff pressOff) -> pitchOn == pitchOff && isNothing pressOff) r1 in (Just $ Note pgm pitchOn velOn (lazyDuration prefix), appendTTLazy prefix suffix) in EventListMT.consBody obj $ matchNoteEventsCore r2 {- | This is like 'EventListTT.append' but more lazy, because it uses the structure of the time value. -} appendTTLazy :: (Monoid lazyTime) => EventListTT.T lazyTime body -> EventListTT.T lazyTime body -> EventListTT.T lazyTime body appendTTLazy xs ys = EventListTT.foldr (\t zs -> let (d,ws) = either EventListMT.viewTimeL ((,) mempty) zs in EventListMT.consTime (mappend t d) ws) (\b zs -> Right $ EventListMT.consBody b zs) (Left ys) xs lazyDuration :: (Monoid lazyTime) => EventListTT.T lazyTime body -> lazyTime lazyDuration = foldr mappend mempty . EventListTT.getTimes {- | Find the first matching body element. Event list must be infinite or it must contain a matching body element, otherwise 'body' and the end of the returned list will be undefined. -} break :: (body -> Bool) -> EventListTT.T LazyTime body -> (EventListTT.T LazyTime body, body, EventListTT.T LazyTime body) break p = EventListMT.switchTimeL $ \t xs -> let (prefix,suffix) = EventListBT.span (not . p) xs (b,r) = EventListMT.switchBodyL (error "no matching body element found", error "list ended before matching element found") (,) suffix in (EventListMT.consTime t prefix, b, r) {- | Remove the first matching body element. Event list must be infinite or it must contain a matching body element, otherwise 'body' and the end of the returned list will be undefined. -} remove :: (body -> Bool) -> EventListTT.T LazyTime body -> (body, EventListTT.T LazyTime body) remove p = EventListMT.switchTimeL $ \t xs -> let (prefix,suffix) = EventListBT.span p xs (b,r) = EventListMT.switchBodyL (error "no matching body element found", error "list ended before matching element found") (,) suffix in (b, EventListTT.append (EventListMT.consTime t prefix) r) 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 dump :: IO () dump = do putStrLn "Starting." h <- ALSA.open ALSA.default_seq_name ALSA.open_input ALSA.Block ALSA.set_client_name h "Haskell-Synthesizer" putStrLn "Created sequencer." p <- ALSA.create_simple_port h "one" (ALSA.caps [ALSA.cap_write, ALSA.cap_subs_write]) ALSA.type_midi_generic let loop = do putStrLn "waiting for an event:" e <- ALSA.event_input h print e loop loop ALSA.delete_port h p putStrLn "Deleted ports." ALSA.close h putStrLn "Closed sequencer."