synthesizer-alsa-0.1: src/Synthesizer/EventList/ALSA/MIDI.hs
{-# 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."