midi-0.1.5: 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,
toFloatController,
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,
Controller, fromController, toController,
increasePitch, subtractPitch, frequencyFromPitch,
maximumVelocity, normalVelocity, toFloatVelocity,
) where
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
| Control Controller 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
instance Random Controller where
random = boundedEnumRandom
randomR = enumRandomR
instance Arbitrary Controller 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 = Int
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)
{- |
We do not define 'Controller' as enumeration with many constructors,
because some controllers have multiple names and some are undefined.
It is also more efficient this way.
Thus you cannot use @case@ for processing controller types,
but you can use 'Data.List.lookup' instead.
> maybe (putStrLn "unsupported controller") putStrLn $
> lookup ctrl $
> (portamento, "portamento") :
> (modulation, "modulation") :
> []
-}
newtype Controller = Controller {fromController :: 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
toController :: Int -> Controller
toController = checkRange "Controller" Controller
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
instance Enum Controller where
toEnum = toController
fromEnum = fromController
-- 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
instance Bounded Velocity where
minBound = Velocity 0
maxBound = Velocity 127
instance Bounded Program where
minBound = Program 0
maxBound = Program 127
instance Bounded Controller where
minBound = Controller 0
maxBound = Controller 119
{- |
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.
ToDo:
This should be of type 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.
0 is mapped to 0.
All other values are interpolated linearly.
ToDo:
MIDI specification says,
if velocity is simply mapped to amplitude,
then this should be done by an exponential function.
Thus we should be better map 'normalVelocity' to 0,
'maximumVelocity' to 1,
and 'minimumVelocity' to -1.
-}
toFloatVelocity :: (Integral a, Fractional b) => a -> b
toFloatVelocity x = fromIntegral x / normalVelocity
maximumControllerValue :: Num quant => quant
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.
-}
toFloatController :: (Integral a, Fractional b) => a -> b
toFloatController x = fromIntegral x / maximumControllerValue
-- * 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 :: 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
-- ** controllers for most-significant bytes of control values
bankSelectMSB, modulationMSB, breathControlMSB, footControlMSB,
portamentoTimeMSB, dataEntryMSB,
mainVolumeMSB, balanceMSB, panoramaMSB, expressionMSB,
generalPurpose1MSB, generalPurpose2MSB,
generalPurpose3MSB, generalPurpose4MSB :: Controller
-- ** controllers for least-significant bytes of control values
bankSelectLSB, modulationLSB, breathControlLSB, footControlLSB,
portamentoTimeLSB, dataEntryLSB,
mainVolumeLSB, balanceLSB, panoramaLSB, expressionLSB,
generalPurpose1LSB, generalPurpose2LSB,
generalPurpose3LSB, generalPurpose4LSB :: Controller
-- ** additional single byte controllers
sustain, porta, sustenuto, softPedal, hold2,
generalPurpose5, generalPurpose6, generalPurpose7, generalPurpose8,
extDepth, tremoloDepth, chorusDepth, celesteDepth, phaserDepth :: Controller
-- ** increment/decrement and parameter numbers
dataIncrement, dataDecrement,
nonRegisteredParameterLSB, nonRegisteredParameterMSB,
registeredParameterLSB, registeredParameterMSB :: Controller
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
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!!