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