midi-0.2: src/Sound/MIDI/Message/Channel/Voice.hs
{- |
Channel voice messages
-}
module Sound.MIDI.Message.Channel.Voice (
T(..), get, putWithStatus,
ControllerValue, PitchBendRange, Pressure,
isNote, isNoteOn, isNoteOff, zeroKey,
explicitNoteOff, implicitNoteOff,
realFromControllerValue,
bankSelect, modulation, breathControl, footControl, portamentoTime,
dataEntry, mainVolume, balance, panorama, expression,
generalPurpose1, generalPurpose2, generalPurpose3, generalPurpose4,
vectorX, vectorY,
bankSelectMSB, modulationMSB, breathControlMSB, footControlMSB,
portamentoTimeMSB, dataEntryMSB, mainVolumeMSB, balanceMSB,
panoramaMSB, expressionMSB, generalPurpose1MSB, generalPurpose2MSB,
generalPurpose3MSB, generalPurpose4MSB, bankSelectLSB, modulationLSB,
breathControlLSB, footControlLSB, portamentoTimeLSB, dataEntryLSB,
mainVolumeLSB, balanceLSB, panoramaLSB, expressionLSB,
generalPurpose1LSB, generalPurpose2LSB, generalPurpose3LSB, generalPurpose4LSB,
sustain, porta, sustenuto, softPedal, hold2,
generalPurpose5, generalPurpose6, generalPurpose7, generalPurpose8,
extDepth, tremoloDepth, chorusDepth, celesteDepth, phaserDepth,
dataIncrement, dataDecrement,
nonRegisteredParameterLSB, nonRegisteredParameterMSB,
registeredParameterLSB, registeredParameterMSB,
Pitch, fromPitch, toPitch,
Velocity, fromVelocity, toVelocity,
Program, fromProgram, toProgram,
CtrlP.Controller, CtrlP.fromController, CtrlP.toController,
increasePitch, subtractPitch, frequencyFromPitch,
maximumVelocity, normalVelocity, realFromVelocity,
) where
import qualified Sound.MIDI.ControllerPrivate as CtrlP
import qualified Sound.MIDI.Controller as Ctrl
import Sound.MIDI.Parser.Primitive
import qualified Sound.MIDI.Parser.Class as Parser
import Control.Monad (liftM, liftM2, )
import qualified Sound.MIDI.Writer.Status as StatusWriter
import qualified Sound.MIDI.Writer.Basic as Writer
import qualified Sound.MIDI.Bit as Bit
import Sound.MIDI.Monoid ((+#+))
import Data.Ix (Ix)
import Sound.MIDI.Utility (checkRange,
quantityRandomR, boundedQuantityRandom, chooseQuantity,
enumRandomR, boundedEnumRandom, chooseEnum, )
import Test.QuickCheck (Arbitrary(arbitrary), )
import qualified Test.QuickCheck as QC
import System.Random (Random(random, randomR), )
-- * message type
data T =
NoteOff Pitch Velocity
| NoteOn Pitch Velocity
| PolyAftertouch Pitch Pressure
| ProgramChange Program
{-
Shall we add support for registered parameters?
-}
| Control Ctrl.T ControllerValue
| PitchBend PitchBendRange
| MonoAftertouch Pressure
deriving (Show, Eq, Ord)
instance Arbitrary T where
arbitrary =
QC.frequency $
(10, liftM2 NoteOff arbitrary arbitrary) :
(10, liftM2 NoteOn arbitrary arbitrary) :
( 1, liftM2 PolyAftertouch arbitrary (QC.choose (0,127))) :
( 1, liftM ProgramChange arbitrary) :
( 1, liftM2 Control arbitrary (QC.choose (0,127))) :
( 1, liftM PitchBend (QC.choose (0,12))) :
( 1, liftM MonoAftertouch (QC.choose (0,127))) :
[]
instance Random Pitch where
random = boundedEnumRandom
randomR = enumRandomR
instance Arbitrary Pitch where
arbitrary = chooseEnum
instance Random Velocity where
random = boundedQuantityRandom fromVelocity toVelocity
randomR = quantityRandomR fromVelocity toVelocity
instance Arbitrary Velocity where
arbitrary = chooseQuantity fromVelocity toVelocity
instance Random Program where
random = boundedEnumRandom
randomR = enumRandomR
instance Arbitrary Program where
arbitrary = chooseEnum
isNote :: T -> Bool
isNote (NoteOn _ _) = True
isNote (NoteOff _ _) = True
isNote _ = False
{- |
NoteOn with zero velocity is considered NoteOff according to MIDI specification.
-}
isNoteOn :: T -> Bool
isNoteOn (NoteOn _ v) = v > toVelocity 0
isNoteOn _ = False
{- |
NoteOn with zero velocity is considered NoteOff according to MIDI specification.
-}
isNoteOff :: T -> Bool
isNoteOff (NoteOn _ v) = v == toVelocity 0
isNoteOff (NoteOff _ _) = True
isNoteOff _ = False
{- |
Convert all @NoteOn p 0@ to @NoteOff p 64@.
The latter one is easier to process.
-}
explicitNoteOff :: T -> T
explicitNoteOff msg =
case msg of
NoteOn p v ->
if v == toVelocity 0
then NoteOff p $ toVelocity 64
else msg
_ -> msg
{- |
Convert all @NoteOff p 64@ to @NoteOn p 0@.
The latter one can be encoded more efficiently using the running status.
-}
implicitNoteOff :: T -> T
implicitNoteOff msg =
case msg of
NoteOff p v ->
if v == toVelocity 64
then NoteOn p $ toVelocity 0
else msg
_ -> msg
-- * Primitive types in Voice messages
type PitchBendRange = Int
type Pressure = Int
type ControllerValue = Ctrl.Value
newtype Pitch = Pitch {fromPitch :: Int} deriving (Show, Eq, Ord, Ix)
newtype Velocity = Velocity {fromVelocity :: Int} deriving (Show, Eq, Ord)
newtype Program = Program {fromProgram :: Int} deriving (Show, Eq, Ord, Ix)
toPitch :: Int -> Pitch
toPitch = checkRange "Pitch" Pitch
toVelocity :: Int -> Velocity
toVelocity = checkRange "Velocity" Velocity
toProgram :: Int -> Program
toProgram = checkRange "Program" Program
instance Enum Pitch where
toEnum = toPitch
fromEnum = fromPitch
{-
I do not like an Enum Velocity instance,
because Velocity is an artificially sampled continuous quantity.
-}
instance Enum Program where
toEnum = toProgram
fromEnum = fromProgram
-- 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
{- |
Convert pitch to frequency
according to the default tuning
given in MIDI 1.0 Detailed Specification.
-}
frequencyFromPitch :: (Floating a) => Pitch -> a
frequencyFromPitch (Pitch p) =
440 * 2 ** (fromIntegral (p + 3 - 6*12) / 12)
instance Bounded Pitch where
minBound = Pitch 0
maxBound = Pitch 127
{- |
ToDo:
We have defined minBound = Velocity 0,
but strictly spoken the minimum Velocity is 1,
since Velocity zero means NoteOff.
One can at least think of NoteOff with (Velocity 0),
but I have never seen that.
-}
instance Bounded Velocity where
minBound = Velocity 0
maxBound = Velocity 127
instance Bounded Program where
minBound = Program 0
maxBound = Program 127
{- |
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 :: Velocity
normalVelocity = Velocity 64
maximumVelocity = maxBound
{- |
MIDI specification says,
if velocity is simply mapped to amplitude,
then this should be done by an exponential function.
Thus we map 'normalVelocity' (64) to 0,
'maximumVelocity' (127) to 1,
and 'minimumVelocity' (1) to -1.
That is, normally you should write something like
@amplitude = 2 ** realFromVelocity vel@ or @3 ** realFromVelocity vel@.
-}
realFromVelocity :: (Fractional b) => Velocity -> b
realFromVelocity (Velocity x) =
fromIntegral (x - fromVelocity normalVelocity) /
fromIntegral (fromVelocity maximumVelocity - fromVelocity normalVelocity)
maximumControllerValue :: Num a => a
maximumControllerValue = 127
{- |
Map integral MIDI controller value to floating point value.
Maximum integral MIDI controller value 127 is mapped to 1.
Minimum integral MIDI controller value 0 is mapped to 0.
-}
realFromControllerValue :: (Integral a, Fractional b) => a -> b
realFromControllerValue x = fromIntegral x / maximumControllerValue
{-
These definitions will be deprecated
and then replaced by the ones from MIDI.Controller.
-}
-- * predefined MIDI controllers
-- ** simple names for controllers, if only most-significant bytes are used
bankSelect, modulation, breathControl, footControl, portamentoTime,
dataEntry, mainVolume, balance, panorama, expression,
generalPurpose1, generalPurpose2, generalPurpose3, generalPurpose4,
vectorX, vectorY :: Ctrl.T
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
-- ** controllers for most-significant bytes of control values
bankSelectMSB, modulationMSB, breathControlMSB, footControlMSB,
portamentoTimeMSB, dataEntryMSB,
mainVolumeMSB, balanceMSB, panoramaMSB, expressionMSB,
generalPurpose1MSB, generalPurpose2MSB,
generalPurpose3MSB, generalPurpose4MSB :: Ctrl.T
-- ** controllers for least-significant bytes of control values
bankSelectLSB, modulationLSB, breathControlLSB, footControlLSB,
portamentoTimeLSB, dataEntryLSB,
mainVolumeLSB, balanceLSB, panoramaLSB, expressionLSB,
generalPurpose1LSB, generalPurpose2LSB,
generalPurpose3LSB, generalPurpose4LSB :: Ctrl.T
-- ** additional single byte controllers
sustain, porta, sustenuto, softPedal, hold2,
generalPurpose5, generalPurpose6, generalPurpose7, generalPurpose8,
extDepth, tremoloDepth, chorusDepth, celesteDepth, phaserDepth :: Ctrl.T
-- ** increment/decrement and parameter numbers
dataIncrement, dataDecrement,
nonRegisteredParameterLSB, nonRegisteredParameterMSB,
registeredParameterLSB, registeredParameterMSB :: Ctrl.T
bankSelectMSB = toEnum 0x00 {- 00 00 -}
modulationMSB = toEnum 0x01 {- 01 01 -}
breathControlMSB = toEnum 0x02 {- 02 02 -}
footControlMSB = toEnum 0x04 {- 04 04 -}
portamentoTimeMSB = toEnum 0x05 {- 05 05 -}
dataEntryMSB = toEnum 0x06 {- 06 06 -}
mainVolumeMSB = toEnum 0x07 {- 07 07 -}
balanceMSB = toEnum 0x08 {- 08 08 -}
panoramaMSB = toEnum 0x0A {- 10 0A -}
expressionMSB = toEnum 0x0B {- 11 0B -}
generalPurpose1MSB = toEnum 0x10 {- 16 10 -}
generalPurpose2MSB = toEnum 0x11 {- 17 11 -}
generalPurpose3MSB = toEnum 0x12 {- 18 12 -}
generalPurpose4MSB = toEnum 0x13 {- 19 13 -}
bankSelectLSB = toEnum 0x20 {- 32 20 -}
modulationLSB = toEnum 0x21 {- 33 21 -}
breathControlLSB = toEnum 0x22 {- 34 22 -}
footControlLSB = toEnum 0x24 {- 36 24 -}
portamentoTimeLSB = toEnum 0x25 {- 37 25 -}
dataEntryLSB = toEnum 0x26 {- 38 26 -}
mainVolumeLSB = toEnum 0x27 {- 39 27 -}
balanceLSB = toEnum 0x28 {- 40 28 -}
panoramaLSB = toEnum 0x2A {- 42 2A -}
expressionLSB = toEnum 0x2B {- 43 2B -}
generalPurpose1LSB = toEnum 0x30 {- 48 30 -}
generalPurpose2LSB = toEnum 0x31 {- 49 31 -}
generalPurpose3LSB = toEnum 0x32 {- 50 32 -}
generalPurpose4LSB = toEnum 0x33 {- 51 33 -}
sustain = toEnum 0x40 {- 64 40 -}
porta = toEnum 0x41 {- 65 41 -}
sustenuto = toEnum 0x42 {- 66 42 -}
softPedal = toEnum 0x43 {- 67 43 -}
hold2 = toEnum 0x45 {- 69 45 -}
generalPurpose5 = toEnum 0x50 {- 80 50 -}
generalPurpose6 = toEnum 0x51 {- 81 51 -}
generalPurpose7 = toEnum 0x52 {- 82 52 -}
generalPurpose8 = toEnum 0x53 {- 83 53 -}
extDepth = toEnum 0x5B {- 91 5B -}
tremoloDepth = toEnum 0x5C {- 92 5C -}
chorusDepth = toEnum 0x5D {- 93 5D -}
celesteDepth = toEnum 0x5E {- 94 5E -}
phaserDepth = toEnum 0x5F {- 95 5F -}
dataIncrement = toEnum 0x60 {- 96 60 -}
dataDecrement = toEnum 0x61 {- 97 61 -}
nonRegisteredParameterLSB = toEnum 0x62 {- 98 62 -}
nonRegisteredParameterMSB = toEnum 0x63 {- 99 63 -}
registeredParameterLSB = toEnum 0x64 {- 100 64 -}
registeredParameterMSB = toEnum 0x65 {- 101 65 -}
-- * serialization
get :: Parser.C parser => Int -> Int -> Parser.Fallible parser T
get code firstData =
let pitch = toPitch firstData
getVel = liftM toVelocity get1
in case code of
08 -> liftM (NoteOff pitch) getVel
09 -> liftM (NoteOn pitch) getVel
10 -> liftM (PolyAftertouch pitch) get1
{-
Whether firstData is a controller and not a mode
is checked in Message.Channel.get.
-}
11 -> liftM (Control (toEnum firstData)) get1
12 -> return (ProgramChange (toProgram firstData))
13 -> return (MonoAftertouch firstData)
14 -> liftM (\msb -> PitchBend (firstData+128*msb)) get1
_ -> Parser.giveUp ("invalid Voice message code:" ++ show code)
putWithStatus :: Writer.C writer =>
(Int -> StatusWriter.T writer) -> T -> StatusWriter.T writer
putWithStatus putChan e =
let putC code bytes =
putChan code +#+
StatusWriter.fromWriter (Writer.putByteList (map fromIntegral bytes))
in case e of
NoteOff p v -> putC 8 [fromPitch p, fromVelocity v]
NoteOn p v -> putC 9 [fromPitch p, fromVelocity v]
PolyAftertouch p pr -> putC 10 [fromPitch p, pr]
Control cn cv -> putC 11 [fromEnum cn, cv]
ProgramChange pn -> putC 12 [fromProgram pn]
MonoAftertouch pr -> putC 13 [pr]
PitchBend pb ->
let (hi,lo) = Bit.splitAt 7 pb in putC 14 [lo,hi] -- little-endian!!