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