10
\$\begingroup\$

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 Seq as 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
\$\endgroup\$
  • \$\begingroup\$ You'll need to set something up to receive the MIDI, like SimpleSynth. Including this in the question flagged it as spam :( \$\endgroup\$ – user1441998 Apr 26 '18 at 4:38

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.