{- | 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.Fragile 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!!