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 -- /!\ To be modified.
  57 sortChannel :: [Message] -> [(Int,[Message])]
  58 sortChannel = map ((,) <$> (fst . head) <*> map snd)
  59               . groupBy ((==) `on` fst) . map sortChannel'
  60   where sortChannel' :: Message -> (Int, Message)
  61         sortChannel' m = let c = getChannel m in (c,m)
  62
  63 -- NoteOn messages are on the right, other Control messages are on the
  64 -- left. For now we throw away NoteOff messages.
  65 sortNotes :: [(Frames, Message)]
  66           -> ([(Frames,Message)], [(Frames,Message)])
  67 sortNotes = sortNotes' ([],[])
  68   where sortNotes' r [] = r
  69         sortNotes' (n, c) (x@(_,m):xs)
  70           | isNoteOn m = sortNotes' (x:n, c) xs
  71           | isNoteOff m = sortNotes' (n,c) xs
  72           | isControl m = sortNotes' (n,x:c) xs
  73           | otherwise = sortNotes' (n,c) xs
  74
  75 -- Note messages are converted to PlayHeads
  76 convertMessages :: [(Frames,Message)] -> [(Frames,Note)]
  77 convertMessages = map (second messageToNote)
  78
  79
  80 -- Uses function defined in SortMessage. This is a pure function and
  81 -- it might not need to be a signal function.
  82 readMessages' :: [(Frames,RawMessage)]
  83               -> ([(Frames,Note)], [(Frames,Message)], [(Frames,RawMessage)])
  84 readMessages' = proc r -> do
  85   (mes, raw) <- sortRawMessages -< r
  86   (notes, ctrl) <- first convertMessages <<< sortNotes -< mes
  87   returnA -< (notes, ctrl, raw)
  88
  89 readMessages :: SF [(Frames, RawMessage)]
  90                    ([(Frames,Note)], [(Frames,Message)], [(Frames,RawMessage)])
  91 readMessages = arr readMessages'
  92 {-
  93 gatherMessages' :: LTempo
  94                 -> SampleRate
  95                 -> Int
  96                 -> ([(Frames,Note)],[(Frames,Message)],[(Frames,RawMessage)])
  97                 -> [(Frames, RawMessage)]
  98 gatherMessages' layTempo sr chan = proc (notes, ctrl, raw) -> do
  99   notes'   <- concat <<< map (noteToMessages layTempo sr chan) -< notes
 100   rawNotes <- map (second toRawMessage)                     -< notes'
 101   rawCtrl  <- map (second toRawMessage)                     -< ctrl
 102   returnA  -< rawNotes ++ rawCtrl ++ raw
 103
 104 gatherMessages :: SF
 105   ( LTempo, SampleRate, Int
 106   , ([(Frames,Note)],[(Frames,Message)],[(Frames,RawMessage)]))
 107   [(Frames, RawMessage)]
 108 gatherMessages = arr $ uncurry4 gatherMessages'
 109 -}
 110
 111 gatherMessages :: SampleRate
 112                -> Tempo
 113                -> M.IntMap ([Note],[Message])
 114                -> M.IntMap [(Frames,RawMessage)]
 115 gatherMessages sr t = M.map (map (second toRawMessage)) .
 116                       M.mapWithKey gatherMessages'
 117   where gatherMessages' :: Int
 118                         -> ([Note],[Message])
 119                         -> [(Frames,Message)]
 120         gatherMessages' chan (notes,messages) =
 121           zip (repeat 0) messages ++
 122           concatMap (noteToMessages sr chan t . (0,)) notes
 123
 124 -- Takes a list of time stamped "things", a sample rate and a buffer
 125 -- size. The function argument is a function that needs to tell which
 126 -- arguments are kept in the case where two would come into
 127 -- contact. On the left are the events that can be thrown into the
 128 -- buffer, on the right are the events that will need to wait. Both
 129 -- list are sorted.
 130 --
 131 -- /!\ The frame number is relative. A preprocessing operation
 132 -- removing all events too soon to be happening and shifting them is
 133 -- necessary.
 134 schedule :: Frames
 135          -> [(Frames, a)]
 136          -> ([(Frames,a)], [(Frames,a)])
 137 schedule size = {-first scatterEvents
 138                 . -}break ((>= size) . fst) . sortBy (comparing fst)
 139
 140 -- When to events are at the same frame, shift them so that they are
 141 -- all separated by one frame. Then take every list and make sure that
 142 -- the first frame of the next list is at least one frame after the
 143 -- last frame of that list.
 144 scatterEvents :: [(Frames, a)] -> [(Frames, a)]
 145 scatterEvents (x@(n,_):(m,b):xs) = x:scatterEvents ((m',b):xs)
 146   where m' = m + max 0 (1 + n - m)
 147 scatterEvents [x] = [x]
 148 scatterEvents _ = []