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 _ = []