module Synthesizer.ALSA.EventList 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.Port.InfoMonad as PortInfo
import qualified Sound.ALSA.Sequencer.Event as Event
import qualified Sound.ALSA.Sequencer.Queue as Queue
import qualified Sound.ALSA.Sequencer.Time as Time
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.TimeMixed as EventListTM
import qualified Data.EventList.Absolute.TimeBody as AbsEventList
import Sound.MIDI.ALSA.Check ()
import System.IO.Unsafe (unsafeInterleaveIO, )
import Control.Concurrent (threadDelay)
import System.Time (ClockTime(TOD), getClockTime, )
import Control.Monad.Trans.State
(evalState, modify, get, )
import qualified Numeric.NonNegative.Class as NonNeg
import qualified Numeric.NonNegative.Wrapper as NonNegW
import qualified Algebra.RealField as RealField
import qualified Algebra.Field as Field
import Data.Tuple.HT (mapPair, mapSnd, )
import Data.Ord.HT (limit, )
import Control.Monad (liftM, liftM2, )
import NumericPrelude.Numeric
import NumericPrelude.Base
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*(t1t0)
type StampedEvent time = (time, Event.T)
getStampedEvent ::
(Field.C time, SndSeq.AllowInput mode) =>
SndSeq.T mode -> IO (StampedEvent time)
getStampedEvent h =
liftM2 (,)
getTimeSeconds
(Event.input h)
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
realTimeToField :: (Field.C a) => RealTime.T -> a
realTimeToField (RealTime.Cons s n) =
fromIntegral s + fromIntegral n / (10^9)
addStamp ::
(RealField.C time) =>
Event.T -> StampedEvent time
addStamp ev =
(case Event.time ev of
Time.Cons Time.Absolute (Time.Real t) -> realTimeToField t
_ -> error "unsupported time stamp type",
ev)
getStampedEventsUntilTime ::
(RealField.C time,
SndSeq.AllowInput mode, SndSeq.AllowOutput mode) =>
SndSeq.T mode ->
Queue.T -> Port.T -> time ->
IO [StampedEvent time]
getStampedEventsUntilTime h q p t =
fmap (map addStamp) $ getEventsUntilTime h q p t
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
getEventsUntilTime ::
(RealField.C time,
SndSeq.AllowInput mode, SndSeq.AllowOutput mode) =>
SndSeq.T mode ->
Queue.T -> Port.T -> time ->
IO [Event.T]
getEventsUntilTime h q p t = do
c <- Client.getId h
_ <- Event.output h $
makeEcho c q p t (Event.Custom 0 0 0)
_ <- Event.drainOutput h
getEventsUntilEcho c h
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
newtype ClientName = ClientName String
deriving (Show)
withMIDIEvents :: (RealField.C time) =>
ClientName -> time -> time ->
(EventList.T StrictTime [Event.T] -> IO a) -> IO a
withMIDIEvents =
withMIDIEventsBlockEcho
withMIDIEventsNonblockWaitGrouped :: (RealField.C time) =>
ClientName -> time -> time ->
(EventList.T StrictTime [Event.T] -> IO a) -> IO a
withMIDIEventsNonblockWaitGrouped name beat rate proc =
withInPort name SndSeq.Nonblock $ \ h _p ->
do start <- getTimeSeconds
l <- lazySequence $
flip map (iterate (beat+) start) $ \t ->
wait t >>
liftM
(\evs -> (t, evs))
(getWaitingEvents h)
proc $
discretizeTime rate $
AbsEventList.fromPairList l
withMIDIEventsNonblockWaitDefer :: (RealField.C time) =>
ClientName -> time -> time ->
(EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a
withMIDIEventsNonblockWaitDefer name beat rate proc =
withInPort name 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 $
flip evalState start $
AbsEventList.mapTimeM (\t -> modify (max t) >> get) $
AbsEventList.fromPairList $ concat l
withMIDIEventsNonblockWaitSkip :: (RealField.C time) =>
ClientName -> time -> time ->
(EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a
withMIDIEventsNonblockWaitSkip name beat rate proc =
withInPort name SndSeq.Nonblock $ \ h _p ->
do start <- getTimeSeconds
l <- lazySequence $
flip map (iterate (beat+) start) $ \t ->
do wait t
t0 <- getTimeSeconds
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) =>
ClientName -> time -> time ->
(EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a
withMIDIEventsNonblockWaitMin name beat rate proc =
withInPort name 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)
proc $
discretizeTime rate $
AbsEventList.fromPairList $ concat l
withMIDIEventsNonblockConstantPause :: (RealField.C time) =>
ClientName -> time -> time ->
(EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a
withMIDIEventsNonblockConstantPause name beat rate proc =
withInPort name 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) =>
ClientName -> time -> time ->
(EventList.T StrictTime Event.T -> IO a) -> IO a
withMIDIEventsNonblockSimple name beat rate proc =
withInPort name SndSeq.Nonblock $ \ h _p ->
do l <- ioToLazyList $
threadDelay (round $ flip asTypeOf rate $ beat*1e6) >>
getWaitingStampedEvents h
proc $
discretizeTime rate $
AbsEventList.fromPairList $ concat l
setTimestamping ::
SndSeq.T mode -> Port.T -> Queue.T -> IO ()
setTimestamping h p q =
PortInfo.modify h p $ do
PortInfo.setTimestamping True
PortInfo.setTimestampReal True
PortInfo.setTimestampQueue q
withMIDIEventsBlockEcho :: (RealField.C time) =>
ClientName -> time -> time ->
(EventList.T StrictTime [Event.T] -> IO a) -> IO a
withMIDIEventsBlockEcho name beat rate proc =
withInPort name SndSeq.Block $ \ h p ->
Queue.with h $ \ q ->
do setTimestamping h p q
Queue.control h q Event.QueueStart Nothing
_ <- Event.drainOutput h
proc .
discretizeTime rate .
AbsEventList.fromPairList .
concat =<<
(lazySequence $
flip map (iterate (beat+) 0) $ \t ->
let end = t+beat
in
fmap ((t,[]) :) $
fmap (map (mapPair (limit (t,end), (:[])))) $
getStampedEventsUntilTime h q p end)
withMIDIEventsBlockEchoQuantised :: (RealField.C time) =>
ClientName -> time -> time ->
(EventList.T StrictTime [Event.T] -> IO a) -> IO a
withMIDIEventsBlockEchoQuantised name beat rate proc =
withInPort name SndSeq.Block $ \ h p ->
Queue.with h $ \ q ->
do Queue.control h q Event.QueueStart Nothing
_ <- Event.drainOutput h
proc .
discretizeTime rate .
AbsEventList.fromPairList =<<
(lazySequence $
flip map (iterate (beat+) 0) $ \t ->
liftM
(\evs -> (t, evs))
(getEventsUntilTime h q p (t+beat)))
withMIDIEventsChunked ::
(RealField.C time) =>
ClientName -> time -> time ->
([IO (EventListTT.T StrictTime [Event.T])] -> IO a) ->
IO a
withMIDIEventsChunked name beat rate proc =
withInPort name SndSeq.Block $ \ h p ->
Queue.with h $ \ q ->
do setTimestamping h p q
Queue.control h q Event.QueueStart Nothing
_ <- Event.drainOutput h
proc $
map
(\t ->
let end = t+beat
in liftM
(\evs ->
EventListTM.switchBodyR
(error "withMIDIEventsChunked: empty list, but there must be at least the end event")
const $
discretizeTime rate $
AbsEventList.fromPairList $
(t,[]) :
map (mapPair (limit (t , end recip rate), (:[]))) evs ++
(end, []) :
[])
(getStampedEventsUntilTime h q p end))
(iterate (beat+) 0)
withMIDIEventsChunkedQuantised ::
(RealField.C time) =>
ClientName -> time -> time ->
([IO (EventList.T StrictTime [Event.T])] -> IO a) ->
IO a
withMIDIEventsChunkedQuantised name beat rate proc =
withInPort name SndSeq.Block $ \ h p ->
Queue.with h $ \ q ->
do Queue.control h q Event.QueueStart Nothing
_ <- Event.drainOutput h
proc $
map
(\t ->
liftM
(\evs ->
EventList.cons NonNeg.zero evs $
EventList.singleton
(NonNegW.fromNumberMsg "chunked time conversion" $
round (beat*rate)) [])
(getEventsUntilTime h q p (t+beat)))
(iterate (beat+) 0)
makeEcho ::
RealField.C time =>
Client.T -> Queue.T -> Port.T ->
time -> Event.Custom -> Event.T
makeEcho c q p t dat =
(Event.simple
(Addr.Cons {
Addr.client = c,
Addr.port = Port.unknown
})
(Event.CustomEv Event.Echo dat))
{ Event.queue = q
, Event.time =
Time.consAbs $ Time.Real $ RealTime.fromInteger $
floor (10^9 * t)
, Event.dest = Addr.Cons {
Addr.client = c,
Addr.port = p
}
}
withMIDIEventsBlock :: (RealField.C time) =>
ClientName -> time ->
(EventList.T StrictTime Event.T -> IO a) -> IO a
withMIDIEventsBlock name rate proc =
withInPort name SndSeq.Block $ \ h _p ->
do l <- ioToLazyList $ getStampedEvent h
proc $
discretizeTime rate $
AbsEventList.fromPairList l
withInPort ::
ClientName ->
SndSeq.BlockMode ->
(SndSeq.T SndSeq.DuplexMode -> Port.T -> IO t) -> IO t
withInPort (ClientName name) blockMode act =
SndSeq.with SndSeq.defaultName blockMode $ \h ->
Client.setName h name >>
Port.withSimple h "input"
(Port.caps [Port.capWrite, Port.capSubsWrite])
Port.typeMidiGeneric
(act h)
discretizeTime :: (RealField.C time) =>
time -> AbsEventList.T time a -> EventList.T StrictTime a
discretizeTime sampleRate =
EventListMB.mapTimeHead (const $ NonNegW.fromNumber zero) .
EventList.fromAbsoluteEventList .
AbsEventList.mapTime
(NonNegW.fromNumberMsg "time conversion" . round . (sampleRate*))
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