]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/Translator/Translator.hs
Merge branch 'master' of gitlab.com:chupin/arpeggigon
[tmp/julm/arpeggigon.git] / src / RMCA / Translator / Translator.hs
1 {-# LANGUAGE Arrows, TupleSections #-}
2
3 module RMCA.Translator.Translator where
4
5 import Control.Arrow
6 import Data.Function (on)
7 import qualified Data.IntMap as M
8 import Data.List (groupBy, sortBy)
9 import Data.Maybe
10 import Data.Ord
11 import Data.Ratio
12 import FRP.Yampa
13 import RMCA.Global.Clock
14 import RMCA.Semantics
15 import RMCA.Translator.Message
16
17 messageToNote :: Message -> Note
18 messageToNote (NoteOn _ p s) = Note { notePch = p
19 , noteStr = s
20 , noteDur = 1 % 4
21 , noteOrn = noOrn
22 }
23 messageToNote m = error $ "In messageToNote: the message "
24 ++ show m ++ " is not a note message"
25
26 -- noteToMessage gives a pair of two time-stamped messages. The one on
27 -- the left is a note message, the other a note off.
28 noteToMessages :: SampleRate
29 -> Int -- channel number
30 -> LTempo
31 -> (Frames,Note)
32 -> [(Frames,Message)]
33 noteToMessages sr chan lt (t,n@Note { noteDur = d })
34 | d == 0 = []
35 | otherwise = [(t,nm),(t + dn,switchOnOff nm)]
36 where nm = noteOnToMessage chan n
37 dt :: Double
38 dt = fromRational (d * toRational (tempoToQNoteIvl lt))
39 dn = floor $ dt * fromIntegral sr
40
41 noteOnToMessage :: Int -> Note -> Message
42 noteOnToMessage c Note { notePch = p
43 , noteStr = s
44 } = NoteOn (mkChannel c) p s
45
46 sortRawMessages :: [(Frames, RawMessage)]
47 -> ([(Frames,Message)], [(Frames,RawMessage)])
48 sortRawMessages = sortRawMessages' ([],[])
49 where sortRawMessages' r [] = r
50 sortRawMessages' (m, rm) (x@(n,xm):xs)
51 | isNothing nm = sortRawMessages' (m, x:rm) xs
52 | otherwise = sortRawMessages' ((n,fromJust nm) :m, rm) xs
53 where nm = fromRawMessage xm
54
55 -- Direct each message to a specific channel.
56 -- (Simplified version not using <$> or <*>
57 sortChannel :: [Message] -> [(Int,[Message])]
58 sortChannel ms = [ (getChannel (head ms'), ms')
59 | ms' <- groupBy ((==) `on` getChannel) ms ]
60
61 {-
62 -- Direct each message to a specific channel.
63 -- /!\ To be modified.
64 sortChannel :: [Message] -> [(Int,[Message])]
65 sortChannel = map ((,) <$> (fst . head) <*> map snd)
66 . groupBy ((==) `on` fst) . map sortChannel'
67 where sortChannel' :: Message -> (Int, Message)
68 sortChannel' m = let c = getChannel m in (c,m)
69 -}
70
71 -- NoteOn messages are on the right, other Control messages are on the
72 -- left. For now we throw away NoteOff messages.
73 sortNotes :: [(Frames, Message)]
74 -> ([(Frames,Message)], [(Frames,Message)])
75 sortNotes = sortNotes' ([],[])
76 where sortNotes' r [] = r
77 sortNotes' (n, c) (x@(_,m):xs)
78 | isNoteOn m = sortNotes' (x:n, c) xs
79 | isNoteOff m = sortNotes' (n,c) xs
80 | isVolume m || isInstrument m = sortNotes' (n,x:c) xs
81 | otherwise = sortNotes' (n,c) xs
82
83 -- Note messages are converted to PlayHeads
84 convertMessages :: [(Frames,Message)] -> [(Frames,Note)]
85 convertMessages = map (second messageToNote)
86
87
88 -- Uses function defined in SortMessage. This is a pure function and
89 -- it might not need to be a signal function.
90 readMessages' :: [(Frames,RawMessage)]
91 -> ([(Frames,Note)], [(Frames,Message)], [(Frames,RawMessage)])
92 readMessages' = proc r -> do
93 (mes, raw) <- sortRawMessages -< r
94 (notes, ctrl) <- first convertMessages <<< sortNotes -< mes
95 returnA -< (notes, ctrl, raw)
96
97 readMessages :: SF [(Frames, RawMessage)]
98 ([(Frames,Note)], [(Frames,Message)], [(Frames,RawMessage)])
99 readMessages = arr readMessages'
100 {-
101 gatherMessages' :: LTempo
102 -> SampleRate
103 -> Int
104 -> ([(Frames,Note)],[(Frames,Message)],[(Frames,RawMessage)])
105 -> [(Frames, RawMessage)]
106 gatherMessages' layTempo sr chan = proc (notes, ctrl, raw) -> do
107 notes' <- concat <<< map (noteToMessages layTempo sr chan) -< notes
108 rawNotes <- map (second toRawMessage) -< notes'
109 rawCtrl <- map (second toRawMessage) -< ctrl
110 returnA -< rawNotes ++ rawCtrl ++ raw
111
112 gatherMessages :: SF
113 ( LTempo, SampleRate, Int
114 , ([(Frames,Note)],[(Frames,Message)],[(Frames,RawMessage)]))
115 [(Frames, RawMessage)]
116 gatherMessages = arr $ uncurry4 gatherMessages'
117 -}
118
119 gatherMessages :: SampleRate
120 -> Tempo
121 -> M.IntMap ([Note],[Message])
122 -> M.IntMap [(Frames,RawMessage)]
123 gatherMessages sr t = M.map (map (second toRawMessage)) .
124 M.mapWithKey gatherMessages'
125 where gatherMessages' :: Int
126 -> ([Note],[Message])
127 -> [(Frames,Message)]
128 gatherMessages' chan (notes,messages) =
129 zip (repeat 0) messages ++
130 concatMap (noteToMessages sr chan t . (0,)) notes
131
132 -- Takes a list of time stamped "things", a sample rate and a buffer
133 -- size. The function argument is a function that needs to tell which
134 -- arguments are kept in the case where two would come into
135 -- contact. On the left are the events that can be thrown into the
136 -- buffer, on the right are the events that will need to wait. Both
137 -- list are sorted.
138 --
139 -- /!\ The frame number is relative. A preprocessing operation
140 -- removing all events too soon to be happening and shifting them is
141 -- necessary.
142 schedule :: Frames
143 -> [(Frames, a)]
144 -> ([(Frames,a)], [(Frames,a)])
145 schedule size = {-first scatterEvents
146 . -}break ((>= size) . fst) . sortBy (comparing fst)
147
148 -- When to events are at the same frame, shift them so that they are
149 -- all separated by one frame. Then take every list and make sure that
150 -- the first frame of the next list is at least one frame after the
151 -- last frame of that list.
152 scatterEvents :: [(Frames, a)] -> [(Frames, a)]
153 scatterEvents (x@(n,_):(m,b):xs) = x:scatterEvents ((m',b):xs)
154 where m' = m + max 0 (1 + n - m)
155 scatterEvents [x] = [x]
156 scatterEvents _ = []