Problem Background
MIDI is a serial representation of control signals to a sound generator. Typically, a noteOn message initiates the attack phase of a sound at a given pitch. The note will continue through decay and sustain phases until later, a noteOff message initiates a release phase to terminate the sound. Because of the serial representation, multiple noteOns may be sent at a single pitch with no interleaved noteOffs; typically each will simultaneously terminate (initiate the release phase of) the previous sound and trigger the initiation (attack) of a new sound, perhaps with updated parameters (namely velocity, MIDI's intensity parameter). A single noteOff will then terminate that last, most recently initiated, sound.
That makes sense when physical keys are triggering MIDI events, but in a context where an algorithm generates the notes, a different semantics may be preferred. For example, overlapping notes at a single pitch could be matched to their own noteOffs, so that a single noteOff will not terminate previously playing notes that have not yet finished. There are many sensible semantics of how overlapping notes could be interpreted -- overlapping quiet notes could "sum" to a louder note, the loudest note could win, etc. Similarly, when an overlapping note terminates and we want to restore a "background" note, there are many sensible choices -- retrigger the background note with its original parameters, continue the overlapping note (in order to prevent an undesired attack phase) perhaps with updated parameters, etc.
I am writing a MIDI buffer to handle these possibilities. It also allows messages to be generated asynchronously out of order, so each is stored with a timestamp until it is time to actually emit it.
My Solution
MIDI events are produced and consumed in separate threads, each ReaderT (MVarHeap) where Heap is a priority queue ordered by the timestamps. The producer decorates noteOn/noteOff pairs with a matching unique id uid so they can be reassociated in the event of overlap.
So far so good, but the consumer turns out to be relatively convoluted, and smells too imperative. I suspect there is a more functional approach that would simplify it. It whileMs until the queue is empty, threadDelays until the timestamp of the most imminent event, and then has to maintain state representing the overlap structure of currently playing notes. I chose StateT (IntMap(Seq(uid, velocity))), where the IntMap key is the MIDI note number and channel, identifying a unique location where notes could potentially overlap.
- noteOns are prepended onto the
Seqas the most recent currently playing note. - noteOffs have to find their matching uid in the
Seq;- If it was the only event, it can be emitted unmodified.
- If the match was not the current head of the
Seq, it is suppressed, since it is a noteOff for a note that was superseded by a subsequent note that has not yet finished. - If the noteOff does match the current head and the tail is not empty, it is replaced by a noteOn with the velocity from the next item in the
Seq, the next most recently initiated note.
This implements an example of the overlapping semantics I described above, but the code is hardly pleasing. All the data structures are functional, but it still feels very procedural. I don't see a way to work on this kind of problem without lots of state manipulation. I know I could break this into smaller functions, but there aren't any opportunities for reuse and it wouldn't even get me out of IO because I have to be working in the MVar.
drain :: KeyStateT (CtxtRdrT IO) Bool
drain = do
s <- asks stream
t <- liftIO time
let cleanup nq del next = return (nq, (next, del, H.null nq))
(next, del, out) <- lift . asksTo modifyMVar queue $ \q ->
(flip $ maybe (cleanup q False Nothing)) (H.view q) $ \(next, rest) -> do
e <- liftIO $ useStream s "existing error" hasHostError
if timestamp (evt next) <= myLatMS + t || fromMaybe True e
then cleanup rest False $ Just next
else cleanup q True Nothing
let evtNext = evt <$> next
new <- flip (maybe $ return evtNext) -- nothing in queue or not time yet
(decodeMsg . message <$> evtNext) $ \msg ->
let vel = fromIntegral . data2 $ msg
u = uid . fromJust $ next
uv = (u, vel)
chanXkey
= (1 + fromIntegral (maxBound :: Word8))
* (fromIntegral . status $ msg)
+ (fromIntegral . data1 $ msg)
in {- (liftIO . print =<<) . -} (StateT $ getCompose . (`I.alterF` chanXkey) (Compose <$>
if vel == 0 -- can't figure out how to factor out the `return` from all clauses below
then maybe (error "too many noteOffs") $ \xs -> do
let (pre, match :<| post) = S.breakl ((== u) . fst) xs
rest = pre >< post
liftIO $ putStrLn $ "match: " ++ show match
if S.null rest
then return (evtNext, Nothing) -- noteOff for currently playing note
else do
let next' = if S.null pre
then (\x -> x {message = encodeMsg $ msg {data2 = fromIntegral $ snd hd}})
<$> evtNext
else Nothing -- later note still playing
where hd :<| _ = post
liftIO $ putStrLn $ "next: " ++ show next'
return (next', Just rest)
else return . (evtNext, ) . Just . maybe (S.singleton uv) (uv <|)))
<* (liftIO . putStrLn . showTree =<< get)
(`traverse_` new) $ liftIO . useStream s "checking for new errors (writeEvents)"
. ((doError "writing events" =<<) .) . (flip writeEvents . return)
when del . liftIO . pauseSec $ toRational myLatMS / 1000
return $ not out
Here's a complete running example:
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
module MidiBuffer
( midiBuffer
) where
-- heap on hackage
import qualified Data.Heap as H
-- also consider "heaps" http://hackage.haskell.org/package/heaps
-- and "psqueues" http://hackage.haskell.org/package/psqueues
-- PortMidi on hackage
import Sound.PortMidi
-- extra on hackage
import Control.Monad.Extra hiding (unit)
import Control.Concurrent
import Control.Exception.Base
import Control.Arrow
import Control.Monad.Reader
import Control.Monad.State
import Data.Functor.Compose
import Data.Foldable
import Data.Maybe
import Data.Tuple
import Data.Word
import Numeric.Natural
-- containers on hackage
import qualified Data.IntMap.Lazy as I
import Data.IntMap.Internal.Debug
import Data.Sequence (Seq (..), (<|), (><))
import qualified Data.Sequence as S
midiBuffer :: IO ()
midiBuffer = do
doError "initializing" =<< initialize
n <- showResult (("found " ++) . (++ " devices")) countDevices
traverse_
(\x ->
putStrLn . (("device " ++ show x ++ ": ") ++) . show =<< getDeviceInfo x)
[0 .. n - 1]
d <- getDefaultOutputDeviceID
putStrLn $ "default output is " ++ show d
s <- traverse (`openOutput` latencyMS) d
let t = "opening stream"
u = useStream s
u t $ (False <$) . putStrLn . ((t ++ ": ") ++) . show
t <- time -- must be evaluated after opening stream, which resets the counter! portmidi.h says:
-- "If the application wants to use PortTime, it should start the timer (call Pt_Start) before calling Pm_OpenInput or Pm_OpenOutput."
-- but PortMidi.hs neither exposes Pt_Start nor calls it
q <- newMVar (H.empty :: PMQ)
let withContext = flip runReaderT Context
{ queue = q
, startTime = fromIntegral t
, stream = s
}
chan = 0
base = 60
ns = [1 .. 4]
notes = zipWith3
note
(replicate (length ns) base)
(fromIntegral . (20 +) . (25 *) <$> ns)
ns
notes' = zipWith
(\x y -> changeDur x {measure = 1} y)
notes
[Whole, Half, Eighth, Eighth]
run :: s -> StateT s (CtxtRdrT IO) a -> IO ()
-- run :: (MonadReader Context m, MonadState s m, MonadIO m) => s -> m a -> IO () -- why won't this work?
run x = withContext . void . (`runStateT` x)
void . (`forkFinally` putStrLn . (displayException ||| const "producer: clean exit"))
. run 0 $ traverse_ addNote (notes ++ notes')
whileM $ H.null <$> readMVar q -- funny bug if you forget ($)
run I.empty $ whileM drain
u "checking for new errors (hasHostError)"
$ (`when'` putStrLn "\n***PortMidi host error") <=< hasHostError
-- PortMidi.hs doesn't expose Pm_GetHostErrorText()
u "checking for new errors (close)" $ (doError "closing stream" =<<) . close
void . doError "terminating" =<< terminate
note n v b = Note
{ midiNum = n
, vel = v
, chan = 0
, measure = 0
, beat = b
, subdiv = 0
, dur = Whole
}
when'
:: Applicative m
=> Bool -> m () -> m Bool
when' p = (p <$) . when p
-- * configuration
latencyMS = 1 -- must be > 0, or portmidi ignores timestamps
myLatMS = 1 -- the latency of our scheduler (events need to be added this far ahead of time in order to be output in order, otherwise they will just be emitted immediately)
tempo = 200 -- bpm
timeSig = TimeSig {numBeats = 4, unit = Quarter}
-- * music util
data DurBase
= Whole
| Half
| Quarter
| Eighth
| Sixteenth
| ThirtySecond
deriving (Enum, Bounded, Show, Eq)
data ModDur
= forall x. NoteDur x => Dotted x
| Triplet DurBase
data TimeSig = TimeSig
{ numBeats :: Int
, unit :: DurBase
}
data Note = forall x. NoteDur x => Note
{ midiNum :: Word8
, vel :: Word8
, chan :: Word8
, measure :: forall a. Integral a => a -- new ghc: no longer compiles without forall a here... why?
, beat :: Int
, subdiv :: forall a. (Real a, Fractional a) => a -- % of beat -- new ghc: no longer compiles without forall a here... why?
, dur :: x
}
instance Show Note where
show n = show (midiNum n, vel n)
-- http://www.haskell.org/ghc/docs/6.12-latest/html/users_guide/release-6-12-1.html#id2887987
-- Record updates can now be used with datatypes containing existential type variables, provided the fields being altered do not mention the existential types.
changeDur
:: (NoteDur b)
=> Note -> b -> Note -- would rather use existential record update syntax, but dur is existential
changeDur Note {..} d =
Note {midiNum, vel, chan, measure, beat, subdiv, dur = d}
class NoteDur a where
quarters
:: (Real x, Fractional x)
=> a -> x
durMS
:: (Real x, Fractional x)
=> a -> x
durMS d = 1000 * 60 * beats d / realToFrac tempo
beats
:: (Real x, Fractional x)
=> a -> x
beats d = uncurry (/) $ both quarters (d, unit timeSig)
where
both (f :: forall a b. (NoteDur a, Real b, Fractional b) => a -> b)
(x, y) = (f x, f y) -- lame that this has to be class specific (copumpkin @ #haskell says a 'forall classes' would be nice)
-- beats d = (quarters d) / (quarters $ unit timeSig) -- want to factor out the application of quarters
-- beats d = uncurry (/) $ join (***) quarters (d, unit timeSig) -- join (***) from Saizan_ @ #haskell, but isn't existentially polymorphic
instance NoteDur DurBase where
quarters x = fromJust . lookup x . zip [minBound .. maxBound] $
map (fromRational . (2 ^^)) [2,1 ..]
instance NoteDur ModDur where
quarters (Dotted x) = quarters x * 3 / 2
quarters (Triplet x) = quarters x * 2 / 3
{- why isn't something like this OK? scree @ #haskell points out that if NoteDur were a type instead of a class it would work, but then we have to carry around another constructor (ie: NoteDur Dotted Eighth)
quarters (x y) = quarters y * case x of
Dotted -> 3 / 2
Triplet -> 2 / 3
-}
instance NoteDur Note where
quarters Note {..} = quarters dur
startMS
:: (Real a, Fractional a)
=> Note -> a
startMS n
= realToFrac (subdiv n + fromIntegral ((measure n * numBeats timeSig) + beat n))
* durMS (unit timeSig)
-- * our scheduler ensures we send monotonic increasing timestamps to portmidi
-- igel @ #haskell (Data.Heap's author) agrees there's no way to reuse MinPolicy here -- HeapItem MinPolicy a is already defined for all a
-- edward says it might have been possible for him to use a class that would let us override it
data PMPol
instance H.HeapItem PMPol QEvent where
newtype Prio PMPol QEvent = PMP (Integer, Integer)
deriving (Eq, Ord)
type Val PMPol QEvent = QEvent
split = PMP -- velocity is 2nd component of ordering so noteoffs happen before noteons
. (fromIntegral . timestamp &&& fromIntegral . data2 . decodeMsg . message) . evt
&&& id
merge = snd
type PMQ = H.Heap PMPol QEvent
data QEvent = QEvent
{ evt :: PMEvent
, uid :: Natural
}
instance Show QEvent where
show = show . uid
-- in midi, a noteOff at a given midi number turns off that note no matter how many previous noteOns occurred
-- so previously scheduled noteOffs might prematurely cut off any new note
-- or a new note may prematurely cut off previously scheduled notes
-- also new notes permanently overwrite previously playing notes' velocities at that midi number
-- we fix this by keeping track of currently playing notes and their future noteOffs
addNote :: Note -> IdStateT (CtxtRdrT IO) ()
addNote n = do
t <- asks startTime
uid <- state $ id &&& (+ 1) -- does this occur even if uid never needed (ex: zero dur event)?
let start = PMEvent {message = encodeMsg noteOn , timestamp = startT}
end = PMEvent {message = encodeMsg noteOff, timestamp = endT }
startT = t + round (startMS n)
endT = startT + round (durMS n)
noteOn = PMMsg
{ status = fromIntegral $ onCode + chan n
, data1 = fromIntegral $ midiNum n
, data2 = fromIntegral $ vel n
}
noteOff = noteOn {data2 = 0}
onCode = 0x90
lift $ when (startT < endT) $ asksTo modifyMVar_ queue $ \q -> do
liftIO . putStrLn $ "uid: " ++ show uid
return . foldr H.insert q $ (\evt -> QEvent {uid, evt}) <$> [start, end] -- triggers bad hlint suggestion of const QEvent{uid,evt}
drain :: KeyStateT (CtxtRdrT IO) Bool
drain = do
s <- asks stream
t <- liftIO time
let cleanup nq del next = return (nq, (next, del, H.null nq))
(next, del, out) <- lift . asksTo modifyMVar queue $ \q ->
(flip $ maybe (cleanup q False Nothing)) (H.view q) $ \(next, rest) -> do
e <- liftIO $ useStream s "existing error" hasHostError
if timestamp (evt next) <= myLatMS + t || fromMaybe True e
then cleanup rest False $ Just next
else cleanup q True Nothing
let evtNext = evt <$> next
new <- flip (maybe $ return evtNext) -- nothing in queue or not time yet
(decodeMsg . message <$> evtNext) $ \msg ->
let vel = fromIntegral . data2 $ msg
u = uid . fromJust $ next
uv = (u, vel)
chanXkey
= (1 + fromIntegral (maxBound :: Word8))
* (fromIntegral . status $ msg)
+ (fromIntegral . data1 $ msg)
in {- (liftIO . print =<<) . -} (StateT $ getCompose . (`I.alterF` chanXkey) (Compose <$>
if vel == 0 -- can't figure out how to factor out the `return` from all clauses below
then maybe (error "too many noteOffs") $ \xs -> do
let (pre, match :<| post) = S.breakl ((== u) . fst) xs
rest = pre >< post
liftIO $ putStrLn $ "match: " ++ show match
if S.null rest
then return (evtNext, Nothing) -- noteOff for currently playing note
else do
let next' = if S.null pre
then (\x -> x {message = encodeMsg $ msg {data2 = fromIntegral $ snd hd}})
<$> evtNext
else Nothing -- later note still playing
where hd :<| _ = post
liftIO $ putStrLn $ "next: " ++ show next'
return (next', Just rest)
else return . (evtNext, ) . Just . maybe (S.singleton uv) (uv <|)))
<* (liftIO . putStrLn . showTree =<< get)
(`traverse_` new) $ liftIO . useStream s "checking for new errors (writeEvents)"
. ((doError "writing events" =<<) .) . (flip writeEvents . return)
when del . liftIO . pauseSec $ toRational myLatMS / 1000
return $ not out
data Context = Context
{ queue :: MVar PMQ
, startTime :: forall a. Real a => a -- new ghc: no longer compiles without forall a here... why?
, stream :: Maybe (Either PMStream PMError)
}
type IdStateT = StateT Natural
type CtxtRdrT = ReaderT Context
type KeyStateT = StateT Keys
type Keys = I.IntMap (Seq (Natural, Word8))
-- * general util
pauseSec
:: Real a
=> a -> IO ()
pauseSec = threadDelay . round . (* 1000000) . realToFrac -- threadDealy's resolution looks to be 10ms, seems very large? (seems ~2x better in 6.12?)
-- from ski @ #haskell (see http://tunes.org/~nef//logs/haskell/09.08.06)
-- solution to this problem: lpaste.net/7915
-- avoids nesting liftIO's, which gives a compiler error, when one wants more than one MVar from a ReaderT simultaneously using form:
-- asks selector >>= liftIO . (flip xxxMVar) (\x ->
-- it's still not as polymorphic as we'd like -- it only works for ReaderT's instead of all MonadReader's
-- why not allow nested liftIO's, and if there is a good reason, is there a more general solution than asksTo?
-- does MonadIO do it?
-- ski mentioned this is "monad tunneling" but i can't find other references to that term...
asksTo
:: Monad m
=> (a -> (b -> m1 c) -> m d) -- modifyMVar :: MVar a -> (a -> IO (a, b)) -> IO b
-> (r -> a)
-> (b -> ReaderT r m1 c)
-> ReaderT r m d
asksTo wrap sel body = do
mv <- asks sel
ReaderT $ \r -> wrap mv $ (`runReaderT` r) . body
showResult
:: Show a
=> (String -> String) -> IO a -> IO a
showResult g f = do
x <- f
putStrLn . g $ show x
return x
doError :: String -> PMError -> IO Bool
doError s e = do
putStr $ s ++ "... " ++ show e
let b = e /= NoError
when b . putStr . (": " ++) =<< getErrorText e
putStrLn ""
return b
useStream
:: Traversable t
=> t (Either a PMError)
-> String
-> (a -> IO Bool)
-> IO (t Bool)
useStream s b a = traverse (a ||| doError b) s
