RCMA/Translator/SortMessage.hs

   1 {-# LANGUAGE Arrows #-}
   2
   3 -- The idea is that the stream of data coming from the MIDI input port
   4 -- will be sorted in three categories: note on events, controller
   5 -- events and other events. The latter will be transmitted as is
   6 -- through the whole systems.
   7
   8 module RCMA.Translator.SortMessage where
   9
  10 import qualified Data.Bifunctor          as BF
  11 import           Data.Function           (on)
  12 import           Data.List               (groupBy)
  13 import           Data.Maybe
  14 import           Data.Ratio
  15 import           FRP.Yampa
  16 import           RCMA.Semantics
  17 import           RCMA.Translator.Message
  18
  19 -- TEMPORARY
  20 data Controller = Lol
  21 --
  22
  23 sortRawMessages :: [(Frames, RawMessage)]
  24                 -> ([(Frames,Message)], [(Frames,RawMessage)])
  25 sortRawMessages = sortRawMessages' ([],[])
  26   where sortRawMessages' r [] = r
  27         sortRawMessages' (m, rm) (x@(n,xm):xs)
  28           | isNothing nm = sortRawMessages' (m, x:rm) xs
  29           | otherwise = sortRawMessages' ((n,fromJust nm) :m, rm) xs
  30           where nm = fromRawMessage xm
  31
  32 -- Direct each message to a specific channel.
  33 -- /!\ To be modified.
  34 sortChannel :: [Message] -> [(Int,[Message])]
  35 sortChannel = map ((,) <$> (fst . head) <*> (map snd))
  36               . groupBy ((==) `on` fst) . map sortChannel'
  37   where sortChannel' :: Message -> (Int, Message)
  38         sortChannel' m = let c = getChannel m in (c,m)
  39
  40 -- NoteOn messages are on the right, other Control messages are on the
  41 -- left. For now we throw away NoteOff messages.
  42 sortNotes :: [(Frames, Message)]
  43           -> ([(Frames,Message)], [(Frames,Message)])
  44 sortNotes = sortNotes' ([],[])
  45   where sortNotes' r [] = r
  46         sortNotes' (n, c) (x@(_,m):xs)
  47           | isNoteOn m = sortNotes' (x:n, c) xs
  48           | isNoteOff m = sortNotes' (n,c) xs
  49           | isControl m = sortNotes' (n,x:c) xs
  50           | otherwise = sortNotes' (n,c) xs
  51
  52 -- Note messages are converted to PlayHeads
  53 convertMessages :: ([(Frames,Message)], [(Frames,Message)])
  54                 -> ([(Frames,Note)], [(Frames,Controller)])
  55 convertMessages = proc (notes, ctrl) -> do
  56   notes' <- arr $ map (BF.second convertNotes)   -< notes
  57   ctrl'  <- arr $ map (BF.second convertControl) -< ctrl
  58   returnA -< (notes', ctrl')
  59
  60 -- /!\ Unsafe function that shouldn't be exported.
  61 convertNotes :: Message -> Note
  62 convertNotes (NoteOn _ p s) = Note { notePch = p
  63                                    , noteStr = s
  64                                    , noteDur = 1 % 4
  65                                    , noteOrn = noOrn
  66                                    }
  67
  68 -- /!\ Unsafe function that shouldn't be exported.
  69 convertControl :: Message -> Controller
  70 convertControl _ = Lol
  71
  72 gatherMessages :: ([Note], [Controller], [RawMessage]) -> [Message]
  73 gatherMessages ([], [], []) = []
  74 gatherMessages _ = undefined
  75
  76 readMessages :: [(Frames,RawMessage)]
  77              -> ([(Frames,Note)], [(Frames,Controller)], [(Frames,RawMessage)])
  78 readMessages = proc r -> do
  79   (mes, raw) <- sortRawMessages -< r
  80   (notes, ctrl) <- convertMessages <<< sortNotes -< mes
  81   returnA -< (notes, ctrl, raw)