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, eachReaderT (MVarHeap) where Heap is a priority queue ordered by the timestamps. The producer decorates noteOn/noteOff pairs with a matching unique iduid 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. ItwhileMs 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 choseStateT (IntMap(Seq(uid, velocity))), where theIntMap key is the MIDI note number and channel, identifying a unique location where notes could potentially overlap.

• noteOns are prepended onto theSeq as the most recent currently playing note.
• noteOffs have to find their matching uid in theSeq;
  • If it was the only event, it can be emitted unmodified.
  • If the match was not the current head of theSeq, 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 theSeq, 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 ofIO because I have to be working in theMVar.

drain :: KeyStateT (CtxtRdrT IO) Booldrain = 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 hackageimport qualified Data.Heap                  as H-- also consider "heaps"    http://hackage.haskell.org/package/heaps-- and           "psqueues" http://hackage.haskell.org/package/psqueues-- PortMidi on hackageimport           Sound.PortMidi-- extra on hackageimport           Control.Monad.Extra        hiding (unit)import           Control.Concurrentimport           Control.Exception.Baseimport           Control.Arrowimport           Control.Monad.Readerimport           Control.Monad.Stateimport           Data.Functor.Composeimport           Data.Foldableimport           Data.Maybeimport           Data.Tupleimport           Data.Wordimport           Numeric.Natural-- containers on hackageimport qualified Data.IntMap.Lazy           as Iimport           Data.IntMap.Internal.Debugimport           Data.Sequence              (Seq (..), (<|), (><))import qualified Data.Sequence              as SmidiBuffer :: 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" =<< terminatenote n v b = Note  { midiNum = n  , vel     = v  , chan    = 0  , measure = 0  , beat    = b  , subdiv  = 0  , dur     = Whole  }when'  :: Applicative m  => Bool -> m () -> m Boolwhen' p = (p <$) . when p-- * configurationlatencyMS = 1 -- must be > 0, or portmidi ignores timestampsmyLatMS   = 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 -- bpmtimeSig   = TimeSig {numBeats = 4, unit = Quarter}-- * music utildata DurBase  = Whole  | Half  | Quarter  | Eighth  | Sixteenth  | ThirtySecond  deriving (Enum, Bounded, Show, Eq)data ModDur  = forall x. NoteDur x => Dotted x  | Triplet DurBasedata 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 existentialchangeDur 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 polymorphicinstance 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 durstartMS  :: (Real a, Fractional a)  => Note -> astartMS 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 itdata PMPolinstance 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 = sndtype PMQ = H.Heap PMPol QEventdata 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 noteOffsaddNote :: 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) Booldrain = 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 outdata 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 Naturaltype CtxtRdrT  = ReaderT Contexttype KeyStateT = StateT Keystype Keys      = I.IntMap (Seq (Natural, Word8))-- * general utilpauseSec  :: 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 dasksTo wrap sel body = do  mv <- asks sel  ReaderT $ \r -> wrap mv $ (`runReaderT` r) . bodyshowResult  :: Show a  => (String -> String) -> IO a -> IO ashowResult g f = do  x <- f  putStrLn . g $ show x  return xdoError :: String -> PMError -> IO BooldoError s e = do  putStr $ s ++ "... " ++ show e  let b = e /= NoError  when b . putStr . (": " ++) =<< getErrorText e  putStrLn ""  return buseStream  :: Traversable t  => t (Either a PMError)   -> String   -> (a -> IO Bool)   -> IO (t Bool)useStream s b a = traverse (a ||| doError b) s

• \$\begingroup\$You'll need to set something up to receive the MIDI, likeSimpleSynth. Including this in the question flagged it as spam :(\$\endgroup\$

  user1441998

  – user1441998

  2018-04-26 04:38:05 +00:00

  CommentedApr 26, 2018 at 4:38

0

Start asking to get answers

Find the answer to your question by asking.

Explore related questions

See similar questions with these tags.