midi-0.1.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,
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,
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 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))) :
[]
coarbitrary = error "not implemented"
instance Random Pitch where
random = boundedEnumRandom
randomR = enumRandomR
instance Arbitrary Pitch where
arbitrary = chooseEnum
coarbitrary = error "not implemented"
instance Random Velocity where
random = boundedQuantityRandom fromVelocity toVelocity
randomR = quantityRandomR fromVelocity toVelocity
instance Arbitrary Velocity where
arbitrary = chooseQuantity fromVelocity toVelocity
coarbitrary = error "not implemented"
instance Random Program where
random = boundedEnumRandom
randomR = enumRandomR
instance Arbitrary Program where
arbitrary = chooseEnum
coarbitrary = error "not implemented"
instance Random Controller where
random = boundedEnumRandom
randomR = enumRandomR
instance Arbitrary Controller where
arbitrary = chooseEnum
coarbitrary = error "not implemented"
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 controller 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
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.
-}
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.
-}
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!!