src/RMCA/Translator/Message.hs

   1 module RMCA.Translator.Message where
   2
   3 import           RMCA.Semantics
   4 import qualified Sound.MIDI.Message               as Message
   5 import qualified Sound.MIDI.Message.Channel       as Channel
   6 import qualified Sound.MIDI.Message.Channel.Voice as Voice
   7
   8 -- We might want to move that to Semantics.
   9 type SampleRate = Int
  10
  11 type RawMessage = Message.T
  12
  13 type MidiVoice = Voice.T
  14
  15 type Channel = Channel.Channel
  16
  17 type ControllerIdx = Voice.Controller
  18
  19 type Frames = Int
  20
  21 -- Each channel is linked to a particular translation signal function
  22 -- itself linked to a particular layer. Therefore we will dispose of
  23 -- the channel number as soon as possible.
  24 ---
  25 -- /!\ This is dangerous as it only treats unipolar control values.
  26 data Message = NoteOn  Channel Pitch Strength
  27              | NoteOff Channel Pitch Strength
  28              | Instrument Channel Voice.Program
  29              | Control Channel ControllerIdx UCtrl
  30   deriving(Show)
  31
  32 getChannel :: Message -> Int
  33 getChannel (NoteOn c _ _) = Channel.fromChannel c
  34 getChannel (NoteOff c _ _) = Channel.fromChannel c
  35 getChannel (Control c _ _) = Channel.fromChannel c
  36 getChannel (Instrument c _ ) = Channel.fromChannel c
  37
  38 mkChannel :: Int -> Channel
  39 mkChannel = Channel.toChannel
  40
  41 mkProgram :: Int -> Channel.Program
  42 mkProgram = Channel.toProgram
  43
  44 -- Function to go back and forth with the representations of pitches,
  45 -- as they are different in our model and in the Jack API model.
  46 fromRawPitch :: Voice.Pitch -> Pitch
  47 fromRawPitch p = Pitch $ Voice.fromPitch p
  48
  49 toRawPitch :: Pitch -> Voice.Pitch
  50 toRawPitch (Pitch p) = Voice.toPitch p
  51
  52
  53 isNoteOn :: Message -> Bool
  54 isNoteOn NoteOn {} = True
  55 isNoteOn _ = False
  56
  57 isNoteOff :: Message -> Bool
  58 isNoteOff NoteOff {} = True
  59 isNoteOff _ = False
  60
  61 isControl :: Message -> Bool
  62 isControl Control {} = True
  63 isControl _ = False
  64
  65 switchOnOff :: Message -> Message
  66 switchOnOff (NoteOn  c p v) = NoteOff c p v
  67 switchOnOff (NoteOff c p v) = NoteOn  c p v
  68 switchOnOff m = error $ "The message " ++ show m ++ " is not a note message"
  69
  70 fromRawMessage :: RawMessage -> Maybe Message
  71 fromRawMessage (Message.Channel (Channel.Cons c
  72                                  (Channel.Voice (Voice.NoteOn  p v)))) =
  73   Just $ NoteOn  c (fromRawPitch p) (toUCtrl $ Voice.fromVelocity v)
  74 fromRawMessage (Message.Channel (Channel.Cons c
  75                                  (Channel.Voice (Voice.NoteOff p v)))) =
  76   Just $ NoteOff c (fromRawPitch p) (toUCtrl $ Voice.fromVelocity v)
  77 fromRawMessage (Message.Channel (Channel.Cons c
  78                                  (Channel.Voice (Voice.Control n v)))) =
  79   Just $ Control c n (toUCtrl v)
  80 fromRawMessage (Message.Channel (Channel.Cons c
  81                                  (Channel.Voice (Voice.ProgramChange p)))) =
  82   Just $ Instrument c p
  83 fromRawMessage _ = Nothing
  84
  85 toRawMessage :: Message -> RawMessage
  86 toRawMessage (NoteOn  c p v) =
  87   Message.Channel $ Channel.Cons c
  88   (Channel.Voice $ Voice.NoteOn  (toRawPitch p) (Voice.toVelocity $ fromUCtrl v))
  89 toRawMessage (NoteOff c p v) =
  90   Message.Channel $ Channel.Cons c
  91   (Channel.Voice $ Voice.NoteOff (toRawPitch p) (Voice.toVelocity $ fromUCtrl v))
  92 toRawMessage (Control c n v) =
  93   Message.Channel (Channel.Cons c
  94                     (Channel.Voice (Voice.Control n (fromUCtrl v))))
  95 toRawMessage (Instrument c p) =
  96   Message.Channel (Channel.Cons c
  97                     (Channel.Voice (Voice.ProgramChange p)))