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