]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - RMCA/Translator/SortMessage.hs
Click handling appears correct.
[tmp/julm/arpeggigon.git] / RMCA / 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 RMCA.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 RMCA.Semantics
17 import RMCA.Translator.Controller
18 import RMCA.Translator.Message
19 import RMCA.Translator.Note
20
21 sortRawMessages :: [(Frames, RawMessage)]
22 -> ([(Frames,Message)], [(Frames,RawMessage)])
23 sortRawMessages = sortRawMessages' ([],[])
24 where sortRawMessages' r [] = r
25 sortRawMessages' (m, rm) (x@(n,xm):xs)
26 | isNothing nm = sortRawMessages' (m, x:rm) xs
27 | otherwise = sortRawMessages' ((n,fromJust nm) :m, rm) xs
28 where nm = fromRawMessage xm
29
30 -- Direct each message to a specific channel.
31 -- /!\ To be modified.
32 sortChannel :: [Message] -> [(Int,[Message])]
33 sortChannel = map ((,) <$> (fst . head) <*> map snd)
34 . groupBy ((==) `on` fst) . map sortChannel'
35 where sortChannel' :: Message -> (Int, Message)
36 sortChannel' m = let c = getChannel m in (c,m)
37
38 -- NoteOn messages are on the right, other Control messages are on the
39 -- left. For now we throw away NoteOff messages.
40 sortNotes :: [(Frames, Message)]
41 -> ([(Frames,Message)], [(Frames,Message)])
42 sortNotes = sortNotes' ([],[])
43 where sortNotes' r [] = r
44 sortNotes' (n, c) (x@(_,m):xs)
45 | isNoteOn m = sortNotes' (x:n, c) xs
46 | isNoteOff m = sortNotes' (n,c) xs
47 | isControl m = sortNotes' (n,x:c) xs
48 | otherwise = sortNotes' (n,c) xs
49
50 -- Note messages are converted to PlayHeads
51 convertMessages :: ([(Frames,Message)], [(Frames,Message)])
52 -> ([(Frames,Note)], [(Frames,Controller)])
53 convertMessages = proc (notes, ctrl) -> do
54 notes' <- arr $ map (BF.second messageToNote) -< notes
55 ctrl' <- arr $ map (BF.second messageToController) -< ctrl
56 returnA -< (notes', ctrl')