Event.hs

{- |
Datatype for MIDI events as they can be sent to a synthesizer.
That is, no timing is handled here.

Taken from Haskore.
-}

module Sound.MIDI.Event(
   T(..),
   Pitch, Program,
   Channel, Controller(..), ControllerValue, PitchBendRange, Pressure, Velocity,
   isNote, isNoteOn, isNoteOff, zeroKey,
   maximumVelocity, normalVelocity, toFloatVelocity,
   toFloatController,

   bankSelect, modulation, breathControl, footControl, portamentoTime,
   dataEntry, mainVolume, balance, panorama, expression,
   generalPurpose1, generalPurpose2, generalPurpose3, generalPurpose4,
   vectorX, vectorY,

   fromPitch,     toPitch,
   fromVelocity,  toVelocity,
   fromProgram,   toProgram,
   fromChannel,   toChannel,
   increasePitch, subtractPitch,
  ) where



{- * MIDI Events -}

newtype Pitch       = Pitch    {fromPitch    :: Int} deriving (Show, Eq, Ord)
newtype Velocity    = Velocity {fromVelocity :: Int} deriving (Show, Eq, Ord)
newtype Program     = Program  {fromProgram  :: Int} deriving (Show, Eq, Ord)
newtype Channel     = Channel  {fromChannel  :: Int} deriving (Show, Eq, Ord)

toPitch :: Int -> Pitch
toPitch = checkRange "Pitch" Pitch

toVelocity :: Int -> Velocity
toVelocity = checkRange "Velocity" Velocity

toProgram :: Int -> Program
toProgram = checkRange "Program" Program

toChannel :: Int -> Channel
toChannel = checkRange "Channel" Channel

checkRange :: (Bounded a, Ord a, Show a) =>
   String -> (Int -> a) -> Int -> a
checkRange typ f x =
   let y = f x
   in  if minBound <= y && y <= maxBound
         then y
         else error (typ ++ ": value " ++ show x ++ " outside range " ++
                     show ((minBound, maxBound) `asTypeOf` (y,y)))

instance Enum Program where
   toEnum   = toProgram
   fromEnum = fromProgram

instance Enum Channel where
   toEnum   = toChannel
   fromEnum = fromChannel

instance Enum Pitch where
   toEnum   = toPitch
   fromEnum = fromPitch

-- typical methods of a type class for affine spaces
increasePitch :: Int -> Pitch -> Pitch
increasePitch d = toPitch . (d+) . fromPitch

subtractPitch :: Pitch -> Pitch -> Int
subtractPitch (Pitch p0) (Pitch p1) = p1-p0


instance Bounded Pitch where
   minBound = Pitch   0
   maxBound = Pitch 127

instance Bounded Velocity where
   minBound = Velocity   0
   maxBound = Velocity 127

instance Bounded Program where
   minBound = Program   0
   maxBound = Program 127

instance Bounded Channel where
   minBound = Channel  0
   maxBound = Channel 15


{- |
A MIDI problem is that one cannot uniquely map
a MIDI key to a frequency.
The frequency depends on the instrument.
I don't know if the deviations are defined for General MIDI.
If this applies one could add transposition information
to the use patch map.
For now I have chosen a value that leads to the right frequency
for some piano sound in my setup.
-}

zeroKey :: Pitch
zeroKey = toPitch 48

{- |
The velocity of an ordinary key stroke and
the maximum possible velocity.
-}

normalVelocity, maximumVelocity :: Num quant => quant
   -- Velocity
normalVelocity  =  64
maximumVelocity = 127

{- |
64 is given as default value by the MIDI specification
and thus we map it to 1.
-}
toFloatVelocity :: (Integral a, Fractional b) => a -> b
toFloatVelocity x = fromIntegral x / normalVelocity

maximumControllerValue :: Num quant => quant
maximumControllerValue = 127

toFloatController :: (Integral a, Fractional b) => a -> b
toFloatController x = fromIntegral x / maximumControllerValue



type PitchBendRange  = Int
type Pressure        = Int
type ControllerValue = Int

data T =
     NoteOff       Pitch Velocity
   | NoteOn        Pitch Velocity
   | PolyAfter     Pitch Pressure
   | ProgramChange Program
   | Control       Controller ControllerValue
   | PitchBend     PitchBendRange
   | MonoAfter     Pressure
     deriving (Show, Eq, Ord)


isNote :: T -> Bool
isNote (NoteOn  _ _) = True
isNote (NoteOff _ _) = True
isNote _             = False

isNoteOn :: T -> Bool
isNoteOn (NoteOn  _ _) = True
isNoteOn _             = False

isNoteOff :: T -> Bool
isNoteOff (NoteOff _ _) = True
isNoteOff _             = False


{- |
Types of predefined MIDI controllers.
-}
data Controller =
     {-  00 00 -} BankSelectMSB
   | {-  01 01 -} ModulationMSB
   | {-  02 02 -} BreathControlMSB
   | {-  03 03 -} Controller03
   | {-  04 04 -} FootControlMSB
   | {-  05 05 -} PortamentoTimeMSB
   | {-  06 06 -} DataEntryMSB
   | {-  07 07 -} MainVolumeMSB
   | {-  08 08 -} BalanceMSB
   | {-  09 09 -} Controller09
   | {-  10 0A -} PanoramaMSB
   | {-  11 0B -} ExpressionMSB
   | {-  12 0C -} Controller0C
   | {-  13 0D -} Controller0D
   | {-  14 0E -} Controller0E
   | {-  15 0F -} Controller0F
   | {-  16 10 -} GeneralPurpose1MSB
   | {-  17 11 -} GeneralPurpose2MSB
   | {-  18 12 -} GeneralPurpose3MSB
   | {-  19 13 -} GeneralPurpose4MSB
   | {-  20 14 -} Controller14
   | {-  21 15 -} Controller15
   | {-  22 16 -} Controller16
   | {-  23 17 -} Controller17
   | {-  24 18 -} Controller18
   | {-  25 19 -} Controller19
   | {-  26 1A -} Controller1A
   | {-  27 1B -} Controller1B
   | {-  28 1C -} Controller1C
   | {-  29 1D -} Controller1D
   | {-  30 1E -} Controller1E
   | {-  31 1F -} Controller1F
   | {-  32 20 -} BankSelectLSB
   | {-  33 21 -} ModulationLSB
   | {-  34 22 -} BreathControlLSB
   | {-  35 23 -} Controller23
   | {-  36 24 -} FootControlLSB
   | {-  37 25 -} PortamentoTimeLSB
   | {-  38 26 -} DataEntryLSB
   | {-  39 27 -} MainVolumeLSB
   | {-  40 28 -} BalanceLSB
   | {-  41 29 -} Controller29
   | {-  42 2A -} PanoramaLSB
   | {-  43 2B -} ExpressionLSB
   | {-  44 2C -} Controller2C
   | {-  45 2D -} Controller2D
   | {-  46 2E -} Controller2E
   | {-  47 2F -} Controller2F
   | {-  48 30 -} GeneralPurpose1LSB
   | {-  49 31 -} GeneralPurpose2LSB
   | {-  50 32 -} GeneralPurpose3LSB
   | {-  51 33 -} GeneralPurpose4LSB
   | {-  52 34 -} Controller34
   | {-  53 35 -} Controller35
   | {-  54 36 -} Controller36
   | {-  55 37 -} Controller37
   | {-  56 38 -} Controller38
   | {-  57 39 -} Controller39
   | {-  58 3A -} Controller3A
   | {-  59 3B -} Controller3B
   | {-  60 3C -} Controller3C
   | {-  61 3D -} Controller3D
   | {-  62 3E -} Controller3E
   | {-  63 3F -} Controller3F
   {- Continuous 7 bit (switches: 0-3f=off, 40-7f=on) -}
   | {-  64 40 -} Sustain
   | {-  65 41 -} Porta
   | {-  66 42 -} Sustenuto
   | {-  67 43 -} SoftPedal
   | {-  68 44 -} Controller44
   | {-  69 45 -} Hold2
   | {-  70 46 -} Controller46
   | {-  71 47 -} Controller47
   | {-  72 48 -} Controller48
   | {-  73 49 -} Controller49
   | {-  74 4A -} Controller4A
   | {-  75 4B -} Controller4B
   | {-  76 4C -} Controller4C
   | {-  77 4D -} Controller4D
   | {-  78 4E -} Controller4E
   | {-  79 4F -} Controller4F
   | {-  80 50 -} GeneralPurpose5
   | {-  81 51 -} GeneralPurpose6
   | {-  82 52 -} GeneralPurpose7
   | {-  83 53 -} GeneralPurpose8
   | {-  84 54 -} Controller54
   | {-  85 55 -} Controller55
   | {-  86 56 -} Controller56
   | {-  87 57 -} Controller57
   | {-  88 58 -} Controller58
   | {-  89 59 -} Controller59
   | {-  90 5A -} Controller5A
   | {-  91 5B -} ExtDepth
   | {-  92 5C -} TremoloDepth
   | {-  93 5D -} ChorusDepth
   | {-  94 5E -} CelesteDepth
   | {-  95 5F -} PhaserDepth
   {- Parameters -}
   | {-  96 60 -} DataIncrement
   | {-  97 61 -} DataDecrement
   | {-  98 62 -} NonRegisteredParameterLSB
   | {-  99 63 -} NonRegisteredParameterMSB
   | {- 100 64 -} RegisteredParameterLSB
   | {- 101 65 -} RegisteredParameterMSB
   | {- 102 66 -} Controller66
   | {- 103 67 -} Controller67
   | {- 104 68 -} Controller68
   | {- 105 69 -} Controller69
   | {- 106 6A -} Controller6A
   | {- 107 6B -} Controller6B
   | {- 108 6C -} Controller6C
   | {- 109 6D -} Controller6D
   | {- 110 6E -} Controller6E
   | {- 111 6F -} Controller6F
   | {- 112 70 -} Controller70
   | {- 113 71 -} Controller71
   | {- 114 72 -} Controller72
   | {- 115 73 -} Controller73
   | {- 116 74 -} Controller74
   | {- 117 75 -} Controller75
   | {- 118 76 -} Controller76
   | {- 119 77 -} Controller77
   | {- 120 78 -} Controller78
   | {- 121 79 -} Controller79
   | {- 122 7A -} Controller7A
   | {- 123 7B -} Controller7B
   | {- 124 7C -} Controller7C
   | {- 125 7D -} Controller7D
   | {- 126 7E -} Controller7E
   | {- 127 7F -} Controller7F
       deriving (Show, Eq, Ord, Enum)

bankSelect, modulation, breathControl, footControl, portamentoTime,
   dataEntry, mainVolume, balance, panorama, expression,
   generalPurpose1, generalPurpose2, generalPurpose3, generalPurpose4,
   vectorX, vectorY :: Controller
bankSelect      = BankSelectMSB
modulation      = ModulationMSB
breathControl   = BreathControlMSB
footControl     = FootControlMSB
portamentoTime  = PortamentoTimeMSB
dataEntry       = DataEntryMSB
mainVolume      = MainVolumeMSB
balance         = BalanceMSB
panorama        = PanoramaMSB
expression      = ExpressionMSB
generalPurpose1 = GeneralPurpose1MSB
generalPurpose2 = GeneralPurpose2MSB
generalPurpose3 = GeneralPurpose3MSB
generalPurpose4 = GeneralPurpose4MSB

vectorX = generalPurpose1
vectorY = generalPurpose2