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.MixedBody as EventListMB
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 qualified Algebra.ToRational as ToRational
import qualified Algebra.RealField as RealField
import qualified Algebra.Field as Field
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
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
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 ->
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
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 []
withMIDIEvents :: (RealField.C time) =>
time -> time ->
(EventList.T StrictTime [Event.T] -> IO a) -> IO a
withMIDIEvents =
withMIDIEventsBlockEcho
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)
proc $
discretizeTime rate $
AbsEventList.fromPairList l
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 $
flip evalState start $
AbsEventList.mapTimeM (\t -> modify (max t) >> get) $
AbsEventList.fromPairList $ concat l
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
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)
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
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)
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*))
type Filter = State (EventList.T StrictTime [Event.T])
type LazyTime = NonNegChunky.T NonNegW.Integer
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
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)
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)
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
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
(
(\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 ::
(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