-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# OPTIONS_GHC -funbox-strict-fields #-}
module Midi.Midi (
    WriteMessages, ReadMessages
    , WriteMessage(..), ReadMessage(..)

    -- * devices
    , ReadDevice, WriteDevice, read_device, write_device
    , read_device_text, write_device_text
    , peek_wdev, peek_rdev, with_wdev, with_rdev
    , add_timestamp, modify_timestamp

    -- * constructors
    , program_change, reset_channel
    , realtime_sysex
    -- ** rpn / nrpn
    , pitch_bend_range, nrpn_tuning
    , MpeZone(..), mpe_2_to_16
    , rpn, nrpn

    -- * modify
    , set_channel

    -- * predicates
    , valid_msg, valid_chan_msg, is_cc, is_sysex, is_note, is_note_on, is_state
    , is_pitched
    , channel_message, message_channel

    -- * types
    , Message(..), Channel, Velocity, Control, Program, ControlValue
    , PitchBendValue, Manufacturer
    , Key(..), from_key, to_key, to_closest_key
    , ChannelMessage(..), CommonMessage(..), RealtimeMessage(..)
    -- * MTC
    , Mtc(..), FrameRate(..), SmpteFragment(..), Smpte(..)
    , seconds_to_frame, frame_to_seconds, frame_to_smpte, seconds_to_smpte
    , generate_mtc
    , mtc_sync, mtc_fragments
    -- * tuning
    , NoteNumber
    , realtime_tuning

    -- * util
    , join14, split14, join4, split4
    -- ** manufacturer
    , manufacturer_name
    , yamaha_code, korg_code
) where
import qualified Control.DeepSeq as DeepSeq
import           Control.DeepSeq (rnf)
import qualified Data.Bits as Bits
import           Data.Bits ((.&.), (.|.))
import qualified Data.ByteString as ByteString
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Text.Encoding as Encoding
import           Data.Word (Word8)

import qualified Foreign.C

import qualified Util.FFI as FFI
import qualified Util.Num as Num
import qualified Util.Pretty as Pretty
import           Util.Pretty (format, (<+>))
import qualified Util.Lists as Lists
import qualified Util.Serialize as Serialize

import qualified Midi.CC as CC
import           Perform.RealTime (RealTime)

import           Global


-- | Declared abstract here so I can switch to a more compact representation
-- later.
type WriteMessages = [WriteMessage]
type ReadMessages = [ReadMessage]

data WriteMessage = WriteMessage {
    WriteMessage -> WriteDevice
wmsg_dev :: !WriteDevice
    , WriteMessage -> RealTime
wmsg_ts :: !RealTime
    , WriteMessage -> Message
wmsg_msg :: !Message
    } deriving (WriteMessage -> WriteMessage -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WriteMessage -> WriteMessage -> Bool
$c/= :: WriteMessage -> WriteMessage -> Bool
== :: WriteMessage -> WriteMessage -> Bool
$c== :: WriteMessage -> WriteMessage -> Bool
Eq, Eq WriteMessage
WriteMessage -> WriteMessage -> Bool
WriteMessage -> WriteMessage -> Ordering
WriteMessage -> WriteMessage -> WriteMessage
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: WriteMessage -> WriteMessage -> WriteMessage
$cmin :: WriteMessage -> WriteMessage -> WriteMessage
max :: WriteMessage -> WriteMessage -> WriteMessage
$cmax :: WriteMessage -> WriteMessage -> WriteMessage
>= :: WriteMessage -> WriteMessage -> Bool
$c>= :: WriteMessage -> WriteMessage -> Bool
> :: WriteMessage -> WriteMessage -> Bool
$c> :: WriteMessage -> WriteMessage -> Bool
<= :: WriteMessage -> WriteMessage -> Bool
$c<= :: WriteMessage -> WriteMessage -> Bool
< :: WriteMessage -> WriteMessage -> Bool
$c< :: WriteMessage -> WriteMessage -> Bool
compare :: WriteMessage -> WriteMessage -> Ordering
$ccompare :: WriteMessage -> WriteMessage -> Ordering
Ord, ReadPrec [WriteMessage]
ReadPrec WriteMessage
Int -> ReadS WriteMessage
ReadS [WriteMessage]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [WriteMessage]
$creadListPrec :: ReadPrec [WriteMessage]
readPrec :: ReadPrec WriteMessage
$creadPrec :: ReadPrec WriteMessage
readList :: ReadS [WriteMessage]
$creadList :: ReadS [WriteMessage]
readsPrec :: Int -> ReadS WriteMessage
$creadsPrec :: Int -> ReadS WriteMessage
Read, Int -> WriteMessage -> ShowS
[WriteMessage] -> ShowS
WriteMessage -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WriteMessage] -> ShowS
$cshowList :: [WriteMessage] -> ShowS
show :: WriteMessage -> String
$cshow :: WriteMessage -> String
showsPrec :: Int -> WriteMessage -> ShowS
$cshowsPrec :: Int -> WriteMessage -> ShowS
Show)
data ReadMessage = ReadMessage {
    ReadMessage -> ReadDevice
rmsg_dev :: !ReadDevice
    , ReadMessage -> RealTime
rmsg_ts :: !RealTime
    , ReadMessage -> Message
rmsg_msg :: !Message
    } deriving (ReadMessage -> ReadMessage -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReadMessage -> ReadMessage -> Bool
$c/= :: ReadMessage -> ReadMessage -> Bool
== :: ReadMessage -> ReadMessage -> Bool
$c== :: ReadMessage -> ReadMessage -> Bool
Eq, Eq ReadMessage
ReadMessage -> ReadMessage -> Bool
ReadMessage -> ReadMessage -> Ordering
ReadMessage -> ReadMessage -> ReadMessage
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ReadMessage -> ReadMessage -> ReadMessage
$cmin :: ReadMessage -> ReadMessage -> ReadMessage
max :: ReadMessage -> ReadMessage -> ReadMessage
$cmax :: ReadMessage -> ReadMessage -> ReadMessage
>= :: ReadMessage -> ReadMessage -> Bool
$c>= :: ReadMessage -> ReadMessage -> Bool
> :: ReadMessage -> ReadMessage -> Bool
$c> :: ReadMessage -> ReadMessage -> Bool
<= :: ReadMessage -> ReadMessage -> Bool
$c<= :: ReadMessage -> ReadMessage -> Bool
< :: ReadMessage -> ReadMessage -> Bool
$c< :: ReadMessage -> ReadMessage -> Bool
compare :: ReadMessage -> ReadMessage -> Ordering
$ccompare :: ReadMessage -> ReadMessage -> Ordering
Ord, ReadPrec [ReadMessage]
ReadPrec ReadMessage
Int -> ReadS ReadMessage
ReadS [ReadMessage]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ReadMessage]
$creadListPrec :: ReadPrec [ReadMessage]
readPrec :: ReadPrec ReadMessage
$creadPrec :: ReadPrec ReadMessage
readList :: ReadS [ReadMessage]
$creadList :: ReadS [ReadMessage]
readsPrec :: Int -> ReadS ReadMessage
$creadsPrec :: Int -> ReadS ReadMessage
Read, Int -> ReadMessage -> ShowS
[ReadMessage] -> ShowS
ReadMessage -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ReadMessage] -> ShowS
$cshowList :: [ReadMessage] -> ShowS
show :: ReadMessage -> String
$cshow :: ReadMessage -> String
showsPrec :: Int -> ReadMessage -> ShowS
$cshowsPrec :: Int -> ReadMessage -> ShowS
Show)

-- Midi msgs are already strict so deepseq is unnecessary, but an NFData
-- instance will make deepseq work on things that contain msgs.
instance DeepSeq.NFData WriteMessage where rnf :: WriteMessage -> ()
rnf WriteMessage
_ = ()
instance DeepSeq.NFData ReadMessage where rnf :: ReadMessage -> ()
rnf ReadMessage
_ = ()

instance Pretty ReadMessage where
    pretty :: ReadMessage -> Text
pretty (ReadMessage ReadDevice
dev RealTime
ts Message
msg) =
        forall a. Pretty a => a -> Text
pretty ReadDevice
dev forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty RealTime
ts forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Message
msg
instance Pretty WriteMessage where
    pretty :: WriteMessage -> Text
pretty (WriteMessage WriteDevice
dev RealTime
ts Message
msg) =
        forall a. Pretty a => a -> Text
pretty WriteDevice
dev forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty RealTime
ts forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Message
msg

-- * devices

-- | Implementation independent representation of a MIDI Device.
--
-- This can be saved to and loaded from files without regard for the devices
-- actually installed or opened.
newtype ReadDevice = ReadDevice ByteString.ByteString
    deriving (ReadDevice -> ReadDevice -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReadDevice -> ReadDevice -> Bool
$c/= :: ReadDevice -> ReadDevice -> Bool
== :: ReadDevice -> ReadDevice -> Bool
$c== :: ReadDevice -> ReadDevice -> Bool
Eq, Eq ReadDevice
ReadDevice -> ReadDevice -> Bool
ReadDevice -> ReadDevice -> Ordering
ReadDevice -> ReadDevice -> ReadDevice
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ReadDevice -> ReadDevice -> ReadDevice
$cmin :: ReadDevice -> ReadDevice -> ReadDevice
max :: ReadDevice -> ReadDevice -> ReadDevice
$cmax :: ReadDevice -> ReadDevice -> ReadDevice
>= :: ReadDevice -> ReadDevice -> Bool
$c>= :: ReadDevice -> ReadDevice -> Bool
> :: ReadDevice -> ReadDevice -> Bool
$c> :: ReadDevice -> ReadDevice -> Bool
<= :: ReadDevice -> ReadDevice -> Bool
$c<= :: ReadDevice -> ReadDevice -> Bool
< :: ReadDevice -> ReadDevice -> Bool
$c< :: ReadDevice -> ReadDevice -> Bool
compare :: ReadDevice -> ReadDevice -> Ordering
$ccompare :: ReadDevice -> ReadDevice -> Ordering
Ord, Int -> ReadDevice -> ShowS
[ReadDevice] -> ShowS
ReadDevice -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ReadDevice] -> ShowS
$cshowList :: [ReadDevice] -> ShowS
show :: ReadDevice -> String
$cshow :: ReadDevice -> String
showsPrec :: Int -> ReadDevice -> ShowS
$cshowsPrec :: Int -> ReadDevice -> ShowS
Show, ReadPrec [ReadDevice]
ReadPrec ReadDevice
Int -> ReadS ReadDevice
ReadS [ReadDevice]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ReadDevice]
$creadListPrec :: ReadPrec [ReadDevice]
readPrec :: ReadPrec ReadDevice
$creadPrec :: ReadPrec ReadDevice
readList :: ReadS [ReadDevice]
$creadList :: ReadS [ReadDevice]
readsPrec :: Int -> ReadS ReadDevice
$creadsPrec :: Int -> ReadS ReadDevice
Read, Get ReadDevice
Putter ReadDevice
forall a. Putter a -> Get a -> Serialize a
get :: Get ReadDevice
$cget :: Get ReadDevice
put :: Putter ReadDevice
$cput :: Putter ReadDevice
Serialize.Serialize)
    -- Storing these as ByteString gives a cheap marshal and unmarshal.  Not
    -- that it matters, but maybe it will someday for a different MIDI backend.
newtype WriteDevice = WriteDevice ByteString.ByteString
    deriving (WriteDevice -> WriteDevice -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WriteDevice -> WriteDevice -> Bool
$c/= :: WriteDevice -> WriteDevice -> Bool
== :: WriteDevice -> WriteDevice -> Bool
$c== :: WriteDevice -> WriteDevice -> Bool
Eq, Eq WriteDevice
WriteDevice -> WriteDevice -> Bool
WriteDevice -> WriteDevice -> Ordering
WriteDevice -> WriteDevice -> WriteDevice
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: WriteDevice -> WriteDevice -> WriteDevice
$cmin :: WriteDevice -> WriteDevice -> WriteDevice
max :: WriteDevice -> WriteDevice -> WriteDevice
$cmax :: WriteDevice -> WriteDevice -> WriteDevice
>= :: WriteDevice -> WriteDevice -> Bool
$c>= :: WriteDevice -> WriteDevice -> Bool
> :: WriteDevice -> WriteDevice -> Bool
$c> :: WriteDevice -> WriteDevice -> Bool
<= :: WriteDevice -> WriteDevice -> Bool
$c<= :: WriteDevice -> WriteDevice -> Bool
< :: WriteDevice -> WriteDevice -> Bool
$c< :: WriteDevice -> WriteDevice -> Bool
compare :: WriteDevice -> WriteDevice -> Ordering
$ccompare :: WriteDevice -> WriteDevice -> Ordering
Ord, Int -> WriteDevice -> ShowS
[WriteDevice] -> ShowS
WriteDevice -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WriteDevice] -> ShowS
$cshowList :: [WriteDevice] -> ShowS
show :: WriteDevice -> String
$cshow :: WriteDevice -> String
showsPrec :: Int -> WriteDevice -> ShowS
$cshowsPrec :: Int -> WriteDevice -> ShowS
Show, ReadPrec [WriteDevice]
ReadPrec WriteDevice
Int -> ReadS WriteDevice
ReadS [WriteDevice]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [WriteDevice]
$creadListPrec :: ReadPrec [WriteDevice]
readPrec :: ReadPrec WriteDevice
$creadPrec :: ReadPrec WriteDevice
readList :: ReadS [WriteDevice]
$creadList :: ReadS [WriteDevice]
readsPrec :: Int -> ReadS WriteDevice
$creadsPrec :: Int -> ReadS WriteDevice
Read, Get WriteDevice
Putter WriteDevice
forall a. Putter a -> Get a -> Serialize a
get :: Get WriteDevice
$cget :: Get WriteDevice
put :: Putter WriteDevice
$cput :: Putter WriteDevice
Serialize.Serialize)

read_device :: Text -> ReadDevice
read_device :: Text -> ReadDevice
read_device = ByteString -> ReadDevice
ReadDevice forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Encoding.encodeUtf8

write_device :: Text -> WriteDevice
write_device :: Text -> WriteDevice
write_device = ByteString -> WriteDevice
WriteDevice forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Encoding.encodeUtf8

read_device_text :: ReadDevice -> Text
read_device_text :: ReadDevice -> Text
read_device_text (ReadDevice ByteString
bs) = ByteString -> Text
FFI.decodeUtf8 ByteString
bs

write_device_text :: WriteDevice -> Text
write_device_text :: WriteDevice -> Text
write_device_text (WriteDevice ByteString
bs) = ByteString -> Text
FFI.decodeUtf8 ByteString
bs

peek_wdev :: Foreign.C.CString -> IO WriteDevice
peek_wdev :: CString -> IO WriteDevice
peek_wdev = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> WriteDevice
WriteDevice forall b c a. (b -> c) -> (a -> b) -> a -> c
. CString -> IO ByteString
ByteString.packCString

peek_rdev :: Foreign.C.CString -> IO ReadDevice
peek_rdev :: CString -> IO ReadDevice
peek_rdev = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ReadDevice
ReadDevice forall b c a. (b -> c) -> (a -> b) -> a -> c
. CString -> IO ByteString
ByteString.packCString

with_wdev :: WriteDevice -> (Foreign.C.CString -> IO a) -> IO a
with_wdev :: forall a. WriteDevice -> (CString -> IO a) -> IO a
with_wdev (WriteDevice ByteString
dev) = forall a. ByteString -> (CString -> IO a) -> IO a
ByteString.useAsCString ByteString
dev

with_rdev :: ReadDevice -> (Foreign.C.CString -> IO a) -> IO a
with_rdev :: forall a. ReadDevice -> (CString -> IO a) -> IO a
with_rdev (ReadDevice ByteString
dev) = forall a. ByteString -> (CString -> IO a) -> IO a
ByteString.useAsCString ByteString
dev

instance Pretty ReadDevice where pretty :: ReadDevice -> Text
pretty = ReadDevice -> Text
read_device_text
instance Pretty WriteDevice where pretty :: WriteDevice -> Text
pretty = WriteDevice -> Text
write_device_text

add_timestamp :: RealTime -> WriteMessage -> WriteMessage
add_timestamp :: RealTime -> WriteMessage -> WriteMessage
add_timestamp RealTime
ts WriteMessage
wmsg = WriteMessage
wmsg { wmsg_ts :: RealTime
wmsg_ts = WriteMessage -> RealTime
wmsg_ts WriteMessage
wmsg forall a. Num a => a -> a -> a
+ RealTime
ts }

modify_timestamp :: (RealTime -> RealTime) -> WriteMessage -> WriteMessage
modify_timestamp :: (RealTime -> RealTime) -> WriteMessage -> WriteMessage
modify_timestamp RealTime -> RealTime
f WriteMessage
wmsg = WriteMessage
wmsg { wmsg_ts :: RealTime
wmsg_ts = RealTime -> RealTime
f (WriteMessage -> RealTime
wmsg_ts WriteMessage
wmsg) }


-- * constructors

-- | Emit a program change with bank in [msb, lsb, pchange] order.
program_change :: Int -> Program -> [ChannelMessage]
program_change :: Int -> Manufacturer -> [ChannelMessage]
program_change Int
bank Manufacturer
program =
    [ Manufacturer -> Manufacturer -> ChannelMessage
ControlChange Manufacturer
CC.bank Manufacturer
msb, Manufacturer -> Manufacturer -> ChannelMessage
ControlChange Manufacturer
CC.bank_lsb Manufacturer
lsb
    , Manufacturer -> ChannelMessage
ProgramChange Manufacturer
program
    ]
    where (Manufacturer
lsb, Manufacturer
msb) = Int -> (Manufacturer, Manufacturer)
split14 Int
bank

reset_channel :: Channel -> [Message]
reset_channel :: Manufacturer -> [Message]
reset_channel Manufacturer
chan =
    -- There is also AllNotesOff, but AllSoundOff seems more widely supported.
    [ Manufacturer -> ChannelMessage -> Message
ChannelMessage Manufacturer
chan ChannelMessage
AllSoundOff
    , Manufacturer -> ChannelMessage -> Message
ChannelMessage Manufacturer
chan ChannelMessage
ResetAllControls
    ]

-- | This is a special kind of sysex which is meant to be interpreted in real
-- time.
realtime_sysex :: ByteString.ByteString -> Message
realtime_sysex :: ByteString -> Message
realtime_sysex = CommonMessage -> Message
CommonMessage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Manufacturer -> ByteString -> CommonMessage
SystemExclusive Manufacturer
0x7f

-- ** rpn / nrpn

-- | Emit a pitch bend range RPN message for the given range.
pitch_bend_range :: Double -> [ChannelMessage]
pitch_bend_range :: Double -> [ChannelMessage]
pitch_bend_range Double
range = (Manufacturer, Manufacturer)
-> (Manufacturer, Manufacturer) -> [ChannelMessage]
rpn (Manufacturer
0, Manufacturer
0) (Manufacturer
semitones, Manufacturer
cents) forall a. [a] -> [a] -> [a]
++ [ChannelMessage]
cancel_rpn
    where
    (Manufacturer
semitones, Double
frac) = forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction Double
range
    cents :: Manufacturer
cents = forall a b. (RealFrac a, Integral b) => a -> b
round (Double
frac forall a. Num a => a -> a -> a
* Double
100)

data MpeZone = Lower | Upper deriving (MpeZone -> MpeZone -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MpeZone -> MpeZone -> Bool
$c/= :: MpeZone -> MpeZone -> Bool
== :: MpeZone -> MpeZone -> Bool
$c== :: MpeZone -> MpeZone -> Bool
Eq, Int -> MpeZone -> ShowS
[MpeZone] -> ShowS
MpeZone -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MpeZone] -> ShowS
$cshowList :: [MpeZone] -> ShowS
show :: MpeZone -> String
$cshow :: MpeZone -> String
showsPrec :: Int -> MpeZone -> ShowS
$cshowsPrec :: Int -> MpeZone -> ShowS
Show)

-- | MPE config where channel 0 is the useless master and 1-15 are used for
-- notes.  This is the one the MPE doc recommends MPE synths start up in.
mpe_2_to_16 :: [Message]
mpe_2_to_16 :: [Message]
mpe_2_to_16 = MpeZone -> Maybe Manufacturer -> [Message]
mpe_configure MpeZone
Lower (forall a. a -> Maybe a
Just Manufacturer
15)

-- | MPE basically means "midi channels actually work."  Except we lose a
-- channel to be the master channel, where a channel message still affects all
-- the other channels too.  The MIDI backend doesn't support a separate master
-- channel, but it seems pretty useless because if I want to affect
-- all notes, I will send messages for all notes.
--
-- Still, MPE support is a good thing because at least 15 channels work
-- properly, and hopefully 'pitch_bend_range' is supported, though the default
-- of (-48, +48) is acceptable.
--
-- The other MPE innovation is that it might support cc 74, to do something
-- expressive.
mpe_configure :: MpeZone -> Maybe Channel -> [Message]
mpe_configure :: MpeZone -> Maybe Manufacturer -> [Message]
mpe_configure MpeZone
zone Maybe Manufacturer
channels =
    forall a b. (a -> b) -> [a] -> [b]
map (Manufacturer -> ChannelMessage -> Message
ChannelMessage Manufacturer
chan) ((Manufacturer, Manufacturer)
-> (Manufacturer, Manufacturer) -> [ChannelMessage]
rpn (Manufacturer
0, Manufacturer
6) (forall a. a -> Maybe a -> a
fromMaybe Manufacturer
0 Maybe Manufacturer
channels, Manufacturer
0))
    where
    chan :: Manufacturer
chan = case MpeZone
zone of
        MpeZone
Lower -> Manufacturer
0
        MpeZone
Upper -> Manufacturer
15

{- | This is an emulation of 'realtime_tuning' for Kontakt KSP, which
    understands NRPNs, but not sysex.

    Each key gets (50, 0) with the source key, (51, 0) with the destination,
    and (52, 0) with tenths of a cent as a 14-bit number.  I have to put
    source and destination NoteNumbers into separate NRPN numbers because
    msb and lsb arrive separately, so they pretty much have to be used as
    msb and lsb of a single number.

    The KSP for this is User/Elaforge/Instrument/Kontakt/ksp/nrpn_tuning.ksp.
-}
nrpn_tuning :: [(Key, NoteNumber)] -> [ChannelMessage]
nrpn_tuning :: [(Key, Double)] -> [ChannelMessage]
nrpn_tuning = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {b}. RealFrac b => (Key, b) -> [ChannelMessage]
retune_key
    where
    retune_key :: (Key, b) -> [ChannelMessage]
retune_key (Key
key, b
nn) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ Manufacturer -> Manufacturer -> [ChannelMessage]
emit Manufacturer
50 (forall a. Num a => Key -> a
from_key Key
key)
        , Manufacturer -> Manufacturer -> [ChannelMessage]
emit Manufacturer
51 Manufacturer
to_key
        , (Manufacturer, Manufacturer)
-> (Manufacturer, Manufacturer) -> [ChannelMessage]
nrpn (Manufacturer
0, Manufacturer
52) (Manufacturer
msb, Manufacturer
lsb)
        ]
        where
        emit :: Manufacturer -> Manufacturer -> [ChannelMessage]
emit Manufacturer
key Manufacturer
value = (Manufacturer, Manufacturer)
-> (Manufacturer, Manufacturer) -> [ChannelMessage]
nrpn (Manufacturer
0, Manufacturer
key) (Manufacturer
value, Manufacturer
0)
        (Manufacturer
lsb, Manufacturer
msb) = Int -> (Manufacturer, Manufacturer)
split14 forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ b
frac forall a. Num a => a -> a -> a
* b
centicent
        -- 2^14 = 16384, so I can fit 10000.  I think KSP only does integer
        -- math, so I can't properly rescale 2^14 to its millicents.
        centicent :: b
centicent = b
100 forall a. Num a => a -> a -> a
* b
100
        (Manufacturer
to_key, b
frac) = forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction b
nn

rpn :: (ControlValue, ControlValue) -> (ControlValue, ControlValue)
    -> [ChannelMessage]
rpn :: (Manufacturer, Manufacturer)
-> (Manufacturer, Manufacturer) -> [ChannelMessage]
rpn (Manufacturer
key_msb, Manufacturer
key_lsb) (Manufacturer
value_msb, Manufacturer
value_lsb) =
    [ Manufacturer -> Manufacturer -> ChannelMessage
ControlChange Manufacturer
CC.rpn_msb Manufacturer
key_msb
    , Manufacturer -> Manufacturer -> ChannelMessage
ControlChange Manufacturer
CC.rpn_lsb Manufacturer
key_lsb
    , Manufacturer -> Manufacturer -> ChannelMessage
ControlChange Manufacturer
CC.data_entry Manufacturer
value_msb
    , Manufacturer -> Manufacturer -> ChannelMessage
ControlChange Manufacturer
CC.data_entry_lsb Manufacturer
value_lsb
    ]

cancel_rpn :: [ChannelMessage]
cancel_rpn :: [ChannelMessage]
cancel_rpn = [Manufacturer -> Manufacturer -> ChannelMessage
ControlChange Manufacturer
CC.rpn_msb Manufacturer
127, Manufacturer -> Manufacturer -> ChannelMessage
ControlChange Manufacturer
CC.rpn_lsb Manufacturer
127]

nrpn :: (ControlValue, ControlValue) -> (ControlValue, ControlValue)
    -> [ChannelMessage]
nrpn :: (Manufacturer, Manufacturer)
-> (Manufacturer, Manufacturer) -> [ChannelMessage]
nrpn (Manufacturer
key_msb, Manufacturer
key_lsb) (Manufacturer
value_msb, Manufacturer
value_lsb) =
    [ Manufacturer -> Manufacturer -> ChannelMessage
ControlChange Manufacturer
CC.nrpn_msb Manufacturer
key_msb
    , Manufacturer -> Manufacturer -> ChannelMessage
ControlChange Manufacturer
CC.nrpn_lsb Manufacturer
key_lsb
    , Manufacturer -> Manufacturer -> ChannelMessage
ControlChange Manufacturer
CC.data_entry Manufacturer
value_msb
    , Manufacturer -> Manufacturer -> ChannelMessage
ControlChange Manufacturer
CC.data_entry_lsb Manufacturer
value_lsb
    ]

-- * modify

set_channel :: Channel -> Message -> Message
set_channel :: Manufacturer -> Message -> Message
set_channel Manufacturer
chan (ChannelMessage Manufacturer
_ ChannelMessage
msg) = Manufacturer -> ChannelMessage -> Message
ChannelMessage Manufacturer
chan ChannelMessage
msg
set_channel Manufacturer
_ Message
msg = Message
msg

-- * predicates

-- | Check to make sure midi msg vals are all in range.
valid_msg :: Message -> Bool
valid_msg :: Message -> Bool
valid_msg (ChannelMessage Manufacturer
chan ChannelMessage
msg) =
    Manufacturer
0 forall a. Ord a => a -> a -> Bool
<= Manufacturer
chan Bool -> Bool -> Bool
&& Manufacturer
chan forall a. Ord a => a -> a -> Bool
< Manufacturer
16 Bool -> Bool -> Bool
&& ChannelMessage -> Bool
valid_chan_msg ChannelMessage
msg
valid_msg Message
_ = Bool
True

valid_chan_msg :: ChannelMessage -> Bool
valid_chan_msg :: ChannelMessage -> Bool
valid_chan_msg ChannelMessage
msg = case ChannelMessage
msg of
    ControlChange Manufacturer
cc Manufacturer
val -> forall {a}. (Ord a, Num a) => a -> Bool
val7 Manufacturer
cc Bool -> Bool -> Bool
&& forall {a}. (Ord a, Num a) => a -> Bool
val7 Manufacturer
val
    NoteOn (Key Int
key) Manufacturer
vel -> forall {a}. (Ord a, Num a) => a -> Bool
val7 Int
key Bool -> Bool -> Bool
&& forall {a}. (Ord a, Num a) => a -> Bool
val7 Manufacturer
vel
    NoteOff (Key Int
key) Manufacturer
vel -> forall {a}. (Ord a, Num a) => a -> Bool
val7 Int
key Bool -> Bool -> Bool
&& forall {a}. (Ord a, Num a) => a -> Bool
val7 Manufacturer
vel
    PitchBend PitchBendValue
val -> -PitchBendValue
1 forall a. Ord a => a -> a -> Bool
<= PitchBendValue
val Bool -> Bool -> Bool
&& PitchBendValue
val forall a. Ord a => a -> a -> Bool
<= PitchBendValue
1
    ChannelMessage
_ -> Bool
True
    where val7 :: a -> Bool
val7 a
v = a
0 forall a. Ord a => a -> a -> Bool
<= a
v Bool -> Bool -> Bool
&& a
v forall a. Ord a => a -> a -> Bool
< a
128

is_cc :: Message -> Bool
is_cc :: Message -> Bool
is_cc (ChannelMessage Manufacturer
_ (ControlChange Manufacturer
_ Manufacturer
_)) = Bool
True
is_cc Message
_ = Bool
False

is_sysex :: Message -> Bool
is_sysex :: Message -> Bool
is_sysex (CommonMessage (SystemExclusive Manufacturer
_ ByteString
_)) = Bool
True
is_sysex Message
_ = Bool
False

is_note :: Message -> Bool
is_note :: Message -> Bool
is_note (ChannelMessage Manufacturer
_ (NoteOn Key
_ Manufacturer
_)) = Bool
True
is_note (ChannelMessage Manufacturer
_ (NoteOff Key
_ Manufacturer
_)) = Bool
True
is_note Message
_ = Bool
False

is_note_on :: Message -> Bool
is_note_on :: Message -> Bool
is_note_on (ChannelMessage Manufacturer
_ (NoteOn Key
_ Manufacturer
_)) = Bool
True
is_note_on Message
_ = Bool
False

-- | Is this a message that will change the channel state?  These are the
-- messages that will affect subsequent NoteOns.
is_state :: Message -> Bool
is_state :: Message -> Bool
is_state (ChannelMessage Manufacturer
_ ChannelMessage
msg) = case ChannelMessage
msg of
    NoteOn {} -> Bool
False
    NoteOff {} -> Bool
False
    ChannelMessage
_ -> Bool
True
is_state Message
_ = Bool
False

-- | True for messages with a pitch: NoteOn, NoteOff and PitchBend.
is_pitched :: Message -> Bool
is_pitched :: Message -> Bool
is_pitched Message
msg = Message -> Bool
is_note Message
msg Bool -> Bool -> Bool
|| case Message
msg of
    ChannelMessage Manufacturer
_ (PitchBend PitchBendValue
_) -> Bool
True
    Message
_ -> Bool
False

-- * projections

channel_message :: Message -> Maybe ChannelMessage
channel_message :: Message -> Maybe ChannelMessage
channel_message (ChannelMessage Manufacturer
_ ChannelMessage
m) = forall a. a -> Maybe a
Just ChannelMessage
m
channel_message Message
_ = forall a. Maybe a
Nothing

message_channel :: Message -> Maybe Channel
message_channel :: Message -> Maybe Manufacturer
message_channel (ChannelMessage Manufacturer
chan ChannelMessage
_) = forall a. a -> Maybe a
Just Manufacturer
chan
message_channel Message
_ = forall a. Maybe a
Nothing

-- * types

data Message =
    ChannelMessage !Channel !ChannelMessage
    | CommonMessage !CommonMessage
    | RealtimeMessage !RealtimeMessage
    | UnknownMessage !Word8 !Word8 !Word8
    deriving (Message -> Message -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Message -> Message -> Bool
$c/= :: Message -> Message -> Bool
== :: Message -> Message -> Bool
$c== :: Message -> Message -> Bool
Eq, Eq Message
Message -> Message -> Bool
Message -> Message -> Ordering
Message -> Message -> Message
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Message -> Message -> Message
$cmin :: Message -> Message -> Message
max :: Message -> Message -> Message
$cmax :: Message -> Message -> Message
>= :: Message -> Message -> Bool
$c>= :: Message -> Message -> Bool
> :: Message -> Message -> Bool
$c> :: Message -> Message -> Bool
<= :: Message -> Message -> Bool
$c<= :: Message -> Message -> Bool
< :: Message -> Message -> Bool
$c< :: Message -> Message -> Bool
compare :: Message -> Message -> Ordering
$ccompare :: Message -> Message -> Ordering
Ord, Int -> Message -> ShowS
[Message] -> ShowS
Message -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Message] -> ShowS
$cshowList :: [Message] -> ShowS
show :: Message -> String
$cshow :: Message -> String
showsPrec :: Int -> Message -> ShowS
$cshowsPrec :: Int -> Message -> ShowS
Show, ReadPrec [Message]
ReadPrec Message
Int -> ReadS Message
ReadS [Message]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Message]
$creadListPrec :: ReadPrec [Message]
readPrec :: ReadPrec Message
$creadPrec :: ReadPrec Message
readList :: ReadS [Message]
$creadList :: ReadS [Message]
readsPrec :: Int -> ReadS Message
$creadsPrec :: Int -> ReadS Message
Read)

instance Pretty Message where
    pretty :: Message -> Text
pretty (CommonMessage (SystemExclusive Manufacturer
manuf ByteString
bytes)) =
        Text
"sysex " forall a. Semigroup a => a -> a -> a
<> Manufacturer -> Text
manufacturer_name Manufacturer
manuf
            forall a. Semigroup a => a -> a -> a
<> Text
" <" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (ByteString -> Int
ByteString.length ByteString
bytes) forall a. Semigroup a => a -> a -> a
<> Text
" bytes>"
    pretty (ChannelMessage Manufacturer
chan ChannelMessage
msg) =
        Text
"chan:" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Manufacturer
chan forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty ChannelMessage
msg
    pretty Message
msg = forall a. Show a => a -> Text
showt Message
msg

-- | These will be encoded with 7-bits, via the usual truncation.  It's not
-- exactly safe, but then it's not like haskell checks for overflow anywhere
-- else either.
type Word7 = Word8
type Word4 = Word8

type Channel = Word4
type Velocity = Word7
type Control = CC.Control
type Program = Word7
type ControlValue = Word7
-- | This is converted to and from the -0x2000 and +0x2000 range by the parser.
type PitchBendValue = Float
type Manufacturer = Word7

newtype Key = Key Int
    deriving (Key -> Key -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Key -> Key -> Bool
$c/= :: Key -> Key -> Bool
== :: Key -> Key -> Bool
$c== :: Key -> Key -> Bool
Eq, Eq Key
Key -> Key -> Bool
Key -> Key -> Ordering
Key -> Key -> Key
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Key -> Key -> Key
$cmin :: Key -> Key -> Key
max :: Key -> Key -> Key
$cmax :: Key -> Key -> Key
>= :: Key -> Key -> Bool
$c>= :: Key -> Key -> Bool
> :: Key -> Key -> Bool
$c> :: Key -> Key -> Bool
<= :: Key -> Key -> Bool
$c<= :: Key -> Key -> Bool
< :: Key -> Key -> Bool
$c< :: Key -> Key -> Bool
compare :: Key -> Key -> Ordering
$ccompare :: Key -> Key -> Ordering
Ord, Integer -> Key
Key -> Key
Key -> Key -> Key
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> Key
$cfromInteger :: Integer -> Key
signum :: Key -> Key
$csignum :: Key -> Key
abs :: Key -> Key
$cabs :: Key -> Key
negate :: Key -> Key
$cnegate :: Key -> Key
* :: Key -> Key -> Key
$c* :: Key -> Key -> Key
- :: Key -> Key -> Key
$c- :: Key -> Key -> Key
+ :: Key -> Key -> Key
$c+ :: Key -> Key -> Key
Num, Int -> Key
Key -> Int
Key -> [Key]
Key -> Key
Key -> Key -> [Key]
Key -> Key -> Key -> [Key]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Key -> Key -> Key -> [Key]
$cenumFromThenTo :: Key -> Key -> Key -> [Key]
enumFromTo :: Key -> Key -> [Key]
$cenumFromTo :: Key -> Key -> [Key]
enumFromThen :: Key -> Key -> [Key]
$cenumFromThen :: Key -> Key -> [Key]
enumFrom :: Key -> [Key]
$cenumFrom :: Key -> [Key]
fromEnum :: Key -> Int
$cfromEnum :: Key -> Int
toEnum :: Int -> Key
$ctoEnum :: Int -> Key
pred :: Key -> Key
$cpred :: Key -> Key
succ :: Key -> Key
$csucc :: Key -> Key
Enum, Int -> Key -> ShowS
[Key] -> ShowS
Key -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Key] -> ShowS
$cshowList :: [Key] -> ShowS
show :: Key -> String
$cshow :: Key -> String
showsPrec :: Int -> Key -> ShowS
$cshowsPrec :: Int -> Key -> ShowS
Show, ReadPrec [Key]
ReadPrec Key
Int -> ReadS Key
ReadS [Key]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Key]
$creadListPrec :: ReadPrec [Key]
readPrec :: ReadPrec Key
$creadPrec :: ReadPrec Key
readList :: ReadS [Key]
$creadList :: ReadS [Key]
readsPrec :: Int -> ReadS Key
$creadsPrec :: Int -> ReadS Key
Read, Key -> ()
forall a. (a -> ()) -> NFData a
rnf :: Key -> ()
$crnf :: Key -> ()
DeepSeq.NFData)
    -- This was initially a Word7 to match MIDI's range, but unlike the other
    -- types, I sometimes do math on these, and Word7's tiny range is kind of
    -- scary for that.

instance Serialize.Serialize Key where
    -- The old encoding used Word8, so keep that for compatibility.
    put :: Putter Key
put Key
key = forall a. Serialize a => Putter a
Serialize.put (forall a. Num a => Key -> a
from_key Key
key :: Word8)
    get :: Get Key
get = (forall a. Integral a => a -> Key
to_key :: Word8 -> Key) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Serialize a => Get a
Serialize.get

instance Pretty Key where
    pretty :: Key -> Text
pretty (Key Int
key) = Text
note forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (Int
oct forall a. Num a => a -> a -> a
- Int
1) forall a. Semigroup a => a -> a -> a
<> Text
"(" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
key forall a. Semigroup a => a -> a -> a
<> Text
")"
        where
        (Int
oct, Int
k) = Int
key forall a. Integral a => a -> a -> (a, a)
`divMod` Int
12
        note :: Text
note = case Int
k of
            Int
0 -> Text
"c"; Int
1 -> Text
"cs"
            Int
2 -> Text
"d"; Int
3 -> Text
"ds"
            Int
4 -> Text
"e"
            Int
5 -> Text
"f"; Int
6 -> Text
"fs"
            Int
7 -> Text
"g"; Int
8 -> Text
"gs"
            Int
9 -> Text
"a"; Int
10 -> Text
"as"
            Int
11 -> Text
"b"
            Int
_ -> Text
""

from_key :: Num a => Key -> a
from_key :: forall a. Num a => Key -> a
from_key (Key Int
k) = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
k

to_key :: Integral a => a -> Key
to_key :: forall a. Integral a => a -> Key
to_key = Int -> Key
Key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
min a
127 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
max a
0

to_closest_key :: RealFrac a => a -> (Key, a)
to_closest_key :: forall a. RealFrac a => a -> (Key, a)
to_closest_key a
nn
    | a
frac forall a. Ord a => a -> a -> Bool
>= a
0.5 = (forall a. Integral a => a -> Key
to_key (Integer
dforall a. Num a => a -> a -> a
+Integer
1), a
frac forall a. Num a => a -> a -> a
- a
1)
    | Bool
otherwise = (forall a. Integral a => a -> Key
to_key Integer
d, a
frac)
    where (Integer
d, a
frac) = forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction a
nn

data ChannelMessage =
    NoteOff !Key !Velocity
    | NoteOn !Key !Velocity
    | Aftertouch !Key !ControlValue
    | ControlChange !Control !ControlValue
    | ProgramChange !Program
    | ChannelPressure !ControlValue
    | PitchBend !PitchBendValue
    -- | This is PitchBend, but with precise control over the bytes sent.
    | PitchBendInt !Word7 !Word7
    -- | channel mode messages (special control values)
    | AllSoundOff
    | ResetAllControls
    | LocalControl !Bool
    | AllNotesOff
    -- | There are a few values in the ChannelMode range left undefined.
    | UndefinedChannelMode !Word7 !Word7
    deriving (ChannelMessage -> ChannelMessage -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChannelMessage -> ChannelMessage -> Bool
$c/= :: ChannelMessage -> ChannelMessage -> Bool
== :: ChannelMessage -> ChannelMessage -> Bool
$c== :: ChannelMessage -> ChannelMessage -> Bool
Eq, Eq ChannelMessage
ChannelMessage -> ChannelMessage -> Bool
ChannelMessage -> ChannelMessage -> Ordering
ChannelMessage -> ChannelMessage -> ChannelMessage
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ChannelMessage -> ChannelMessage -> ChannelMessage
$cmin :: ChannelMessage -> ChannelMessage -> ChannelMessage
max :: ChannelMessage -> ChannelMessage -> ChannelMessage
$cmax :: ChannelMessage -> ChannelMessage -> ChannelMessage
>= :: ChannelMessage -> ChannelMessage -> Bool
$c>= :: ChannelMessage -> ChannelMessage -> Bool
> :: ChannelMessage -> ChannelMessage -> Bool
$c> :: ChannelMessage -> ChannelMessage -> Bool
<= :: ChannelMessage -> ChannelMessage -> Bool
$c<= :: ChannelMessage -> ChannelMessage -> Bool
< :: ChannelMessage -> ChannelMessage -> Bool
$c< :: ChannelMessage -> ChannelMessage -> Bool
compare :: ChannelMessage -> ChannelMessage -> Ordering
$ccompare :: ChannelMessage -> ChannelMessage -> Ordering
Ord, Int -> ChannelMessage -> ShowS
[ChannelMessage] -> ShowS
ChannelMessage -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChannelMessage] -> ShowS
$cshowList :: [ChannelMessage] -> ShowS
show :: ChannelMessage -> String
$cshow :: ChannelMessage -> String
showsPrec :: Int -> ChannelMessage -> ShowS
$cshowsPrec :: Int -> ChannelMessage -> ShowS
Show, ReadPrec [ChannelMessage]
ReadPrec ChannelMessage
Int -> ReadS ChannelMessage
ReadS [ChannelMessage]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ChannelMessage]
$creadListPrec :: ReadPrec [ChannelMessage]
readPrec :: ReadPrec ChannelMessage
$creadPrec :: ReadPrec ChannelMessage
readList :: ReadS [ChannelMessage]
$creadList :: ReadS [ChannelMessage]
readsPrec :: Int -> ReadS ChannelMessage
$creadsPrec :: Int -> ReadS ChannelMessage
Read)

data CommonMessage =
    -- | manufacturer id, data including eox
    SystemExclusive !Manufacturer !ByteString.ByteString
    | SongPositionPointer !Int
    | SongSelect !Word8
    | TuneRequest
    | EOX
    | UndefinedCommon !Word8
    deriving (CommonMessage -> CommonMessage -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CommonMessage -> CommonMessage -> Bool
$c/= :: CommonMessage -> CommonMessage -> Bool
== :: CommonMessage -> CommonMessage -> Bool
$c== :: CommonMessage -> CommonMessage -> Bool
Eq, Eq CommonMessage
CommonMessage -> CommonMessage -> Bool
CommonMessage -> CommonMessage -> Ordering
CommonMessage -> CommonMessage -> CommonMessage
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CommonMessage -> CommonMessage -> CommonMessage
$cmin :: CommonMessage -> CommonMessage -> CommonMessage
max :: CommonMessage -> CommonMessage -> CommonMessage
$cmax :: CommonMessage -> CommonMessage -> CommonMessage
>= :: CommonMessage -> CommonMessage -> Bool
$c>= :: CommonMessage -> CommonMessage -> Bool
> :: CommonMessage -> CommonMessage -> Bool
$c> :: CommonMessage -> CommonMessage -> Bool
<= :: CommonMessage -> CommonMessage -> Bool
$c<= :: CommonMessage -> CommonMessage -> Bool
< :: CommonMessage -> CommonMessage -> Bool
$c< :: CommonMessage -> CommonMessage -> Bool
compare :: CommonMessage -> CommonMessage -> Ordering
$ccompare :: CommonMessage -> CommonMessage -> Ordering
Ord, Int -> CommonMessage -> ShowS
[CommonMessage] -> ShowS
CommonMessage -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CommonMessage] -> ShowS
$cshowList :: [CommonMessage] -> ShowS
show :: CommonMessage -> String
$cshow :: CommonMessage -> String
showsPrec :: Int -> CommonMessage -> ShowS
$cshowsPrec :: Int -> CommonMessage -> ShowS
Show, ReadPrec [CommonMessage]
ReadPrec CommonMessage
Int -> ReadS CommonMessage
ReadS [CommonMessage]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [CommonMessage]
$creadListPrec :: ReadPrec [CommonMessage]
readPrec :: ReadPrec CommonMessage
$creadPrec :: ReadPrec CommonMessage
readList :: ReadS [CommonMessage]
$creadList :: ReadS [CommonMessage]
readsPrec :: Int -> ReadS CommonMessage
$creadsPrec :: Int -> ReadS CommonMessage
Read)

data RealtimeMessage = MtcQuarterFrame !Mtc | TimingClock | Start | Continue
    | Stop | ActiveSense | Reset | UndefinedRealtime !Word8
    deriving (RealtimeMessage -> RealtimeMessage -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RealtimeMessage -> RealtimeMessage -> Bool
$c/= :: RealtimeMessage -> RealtimeMessage -> Bool
== :: RealtimeMessage -> RealtimeMessage -> Bool
$c== :: RealtimeMessage -> RealtimeMessage -> Bool
Eq, Eq RealtimeMessage
RealtimeMessage -> RealtimeMessage -> Bool
RealtimeMessage -> RealtimeMessage -> Ordering
RealtimeMessage -> RealtimeMessage -> RealtimeMessage
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RealtimeMessage -> RealtimeMessage -> RealtimeMessage
$cmin :: RealtimeMessage -> RealtimeMessage -> RealtimeMessage
max :: RealtimeMessage -> RealtimeMessage -> RealtimeMessage
$cmax :: RealtimeMessage -> RealtimeMessage -> RealtimeMessage
>= :: RealtimeMessage -> RealtimeMessage -> Bool
$c>= :: RealtimeMessage -> RealtimeMessage -> Bool
> :: RealtimeMessage -> RealtimeMessage -> Bool
$c> :: RealtimeMessage -> RealtimeMessage -> Bool
<= :: RealtimeMessage -> RealtimeMessage -> Bool
$c<= :: RealtimeMessage -> RealtimeMessage -> Bool
< :: RealtimeMessage -> RealtimeMessage -> Bool
$c< :: RealtimeMessage -> RealtimeMessage -> Bool
compare :: RealtimeMessage -> RealtimeMessage -> Ordering
$ccompare :: RealtimeMessage -> RealtimeMessage -> Ordering
Ord, Int -> RealtimeMessage -> ShowS
[RealtimeMessage] -> ShowS
RealtimeMessage -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RealtimeMessage] -> ShowS
$cshowList :: [RealtimeMessage] -> ShowS
show :: RealtimeMessage -> String
$cshow :: RealtimeMessage -> String
showsPrec :: Int -> RealtimeMessage -> ShowS
$cshowsPrec :: Int -> RealtimeMessage -> ShowS
Show, ReadPrec [RealtimeMessage]
ReadPrec RealtimeMessage
Int -> ReadS RealtimeMessage
ReadS [RealtimeMessage]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RealtimeMessage]
$creadListPrec :: ReadPrec [RealtimeMessage]
readPrec :: ReadPrec RealtimeMessage
$creadPrec :: ReadPrec RealtimeMessage
readList :: ReadS [RealtimeMessage]
$creadList :: ReadS [RealtimeMessage]
readsPrec :: Int -> ReadS RealtimeMessage
$creadsPrec :: Int -> ReadS RealtimeMessage
Read)

instance DeepSeq.NFData Message where rnf :: Message -> ()
rnf Message
_ = ()
instance DeepSeq.NFData ChannelMessage where rnf :: ChannelMessage -> ()
rnf ChannelMessage
_ = ()
instance DeepSeq.NFData CommonMessage where rnf :: CommonMessage -> ()
rnf CommonMessage
_ = ()
instance DeepSeq.NFData RealtimeMessage where rnf :: RealtimeMessage -> ()
rnf RealtimeMessage
_ = ()

instance Pretty ChannelMessage where
    format :: ChannelMessage -> Doc
format ChannelMessage
msg = case ChannelMessage
msg of
        NoteOff Key
key Manufacturer
vel -> Doc
"NoteOff" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
format Key
key Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
format Manufacturer
vel
        NoteOn Key
key Manufacturer
vel -> Doc
"NoteOn" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
format Key
key Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
format Manufacturer
vel
        Aftertouch Key
key Manufacturer
vel -> Doc
"Aftertouch" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
format Key
key Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
format Manufacturer
vel
        ChannelMessage
_ -> Text -> Doc
Pretty.text (forall a. Show a => a -> Text
showt ChannelMessage
msg)

-- * MTC

data Mtc = Mtc !SmpteFragment !Word4
    deriving (Mtc -> Mtc -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Mtc -> Mtc -> Bool
$c/= :: Mtc -> Mtc -> Bool
== :: Mtc -> Mtc -> Bool
$c== :: Mtc -> Mtc -> Bool
Eq, Eq Mtc
Mtc -> Mtc -> Bool
Mtc -> Mtc -> Ordering
Mtc -> Mtc -> Mtc
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Mtc -> Mtc -> Mtc
$cmin :: Mtc -> Mtc -> Mtc
max :: Mtc -> Mtc -> Mtc
$cmax :: Mtc -> Mtc -> Mtc
>= :: Mtc -> Mtc -> Bool
$c>= :: Mtc -> Mtc -> Bool
> :: Mtc -> Mtc -> Bool
$c> :: Mtc -> Mtc -> Bool
<= :: Mtc -> Mtc -> Bool
$c<= :: Mtc -> Mtc -> Bool
< :: Mtc -> Mtc -> Bool
$c< :: Mtc -> Mtc -> Bool
compare :: Mtc -> Mtc -> Ordering
$ccompare :: Mtc -> Mtc -> Ordering
Ord, Int -> Mtc -> ShowS
[Mtc] -> ShowS
Mtc -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Mtc] -> ShowS
$cshowList :: [Mtc] -> ShowS
show :: Mtc -> String
$cshow :: Mtc -> String
showsPrec :: Int -> Mtc -> ShowS
$cshowsPrec :: Int -> Mtc -> ShowS
Show, ReadPrec [Mtc]
ReadPrec Mtc
Int -> ReadS Mtc
ReadS [Mtc]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Mtc]
$creadListPrec :: ReadPrec [Mtc]
readPrec :: ReadPrec Mtc
$creadPrec :: ReadPrec Mtc
readList :: ReadS [Mtc]
$creadList :: ReadS [Mtc]
readsPrec :: Int -> ReadS Mtc
$creadsPrec :: Int -> ReadS Mtc
Read)
data FrameRate = Frame24 | Frame25 | Frame29_97df | Frame30
    deriving (Int -> FrameRate
FrameRate -> Int
FrameRate -> [FrameRate]
FrameRate -> FrameRate
FrameRate -> FrameRate -> [FrameRate]
FrameRate -> FrameRate -> FrameRate -> [FrameRate]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: FrameRate -> FrameRate -> FrameRate -> [FrameRate]
$cenumFromThenTo :: FrameRate -> FrameRate -> FrameRate -> [FrameRate]
enumFromTo :: FrameRate -> FrameRate -> [FrameRate]
$cenumFromTo :: FrameRate -> FrameRate -> [FrameRate]
enumFromThen :: FrameRate -> FrameRate -> [FrameRate]
$cenumFromThen :: FrameRate -> FrameRate -> [FrameRate]
enumFrom :: FrameRate -> [FrameRate]
$cenumFrom :: FrameRate -> [FrameRate]
fromEnum :: FrameRate -> Int
$cfromEnum :: FrameRate -> Int
toEnum :: Int -> FrameRate
$ctoEnum :: Int -> FrameRate
pred :: FrameRate -> FrameRate
$cpred :: FrameRate -> FrameRate
succ :: FrameRate -> FrameRate
$csucc :: FrameRate -> FrameRate
Enum, Int -> FrameRate -> ShowS
[FrameRate] -> ShowS
FrameRate -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FrameRate] -> ShowS
$cshowList :: [FrameRate] -> ShowS
show :: FrameRate -> String
$cshow :: FrameRate -> String
showsPrec :: Int -> FrameRate -> ShowS
$cshowsPrec :: Int -> FrameRate -> ShowS
Show)
data SmpteFragment = FrameLsb | FrameMsb | SecondLsb | SecondMsb
    | MinuteLsb | MinuteMsb | HourLsb | RateHourMsb
    deriving (Int -> SmpteFragment
SmpteFragment -> Int
SmpteFragment -> [SmpteFragment]
SmpteFragment -> SmpteFragment
SmpteFragment -> SmpteFragment -> [SmpteFragment]
SmpteFragment -> SmpteFragment -> SmpteFragment -> [SmpteFragment]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: SmpteFragment -> SmpteFragment -> SmpteFragment -> [SmpteFragment]
$cenumFromThenTo :: SmpteFragment -> SmpteFragment -> SmpteFragment -> [SmpteFragment]
enumFromTo :: SmpteFragment -> SmpteFragment -> [SmpteFragment]
$cenumFromTo :: SmpteFragment -> SmpteFragment -> [SmpteFragment]
enumFromThen :: SmpteFragment -> SmpteFragment -> [SmpteFragment]
$cenumFromThen :: SmpteFragment -> SmpteFragment -> [SmpteFragment]
enumFrom :: SmpteFragment -> [SmpteFragment]
$cenumFrom :: SmpteFragment -> [SmpteFragment]
fromEnum :: SmpteFragment -> Int
$cfromEnum :: SmpteFragment -> Int
toEnum :: Int -> SmpteFragment
$ctoEnum :: Int -> SmpteFragment
pred :: SmpteFragment -> SmpteFragment
$cpred :: SmpteFragment -> SmpteFragment
succ :: SmpteFragment -> SmpteFragment
$csucc :: SmpteFragment -> SmpteFragment
Enum, SmpteFragment -> SmpteFragment -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SmpteFragment -> SmpteFragment -> Bool
$c/= :: SmpteFragment -> SmpteFragment -> Bool
== :: SmpteFragment -> SmpteFragment -> Bool
$c== :: SmpteFragment -> SmpteFragment -> Bool
Eq, Eq SmpteFragment
SmpteFragment -> SmpteFragment -> Bool
SmpteFragment -> SmpteFragment -> Ordering
SmpteFragment -> SmpteFragment -> SmpteFragment
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SmpteFragment -> SmpteFragment -> SmpteFragment
$cmin :: SmpteFragment -> SmpteFragment -> SmpteFragment
max :: SmpteFragment -> SmpteFragment -> SmpteFragment
$cmax :: SmpteFragment -> SmpteFragment -> SmpteFragment
>= :: SmpteFragment -> SmpteFragment -> Bool
$c>= :: SmpteFragment -> SmpteFragment -> Bool
> :: SmpteFragment -> SmpteFragment -> Bool
$c> :: SmpteFragment -> SmpteFragment -> Bool
<= :: SmpteFragment -> SmpteFragment -> Bool
$c<= :: SmpteFragment -> SmpteFragment -> Bool
< :: SmpteFragment -> SmpteFragment -> Bool
$c< :: SmpteFragment -> SmpteFragment -> Bool
compare :: SmpteFragment -> SmpteFragment -> Ordering
$ccompare :: SmpteFragment -> SmpteFragment -> Ordering
Ord, Int -> SmpteFragment -> ShowS
[SmpteFragment] -> ShowS
SmpteFragment -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SmpteFragment] -> ShowS
$cshowList :: [SmpteFragment] -> ShowS
show :: SmpteFragment -> String
$cshow :: SmpteFragment -> String
showsPrec :: Int -> SmpteFragment -> ShowS
$cshowsPrec :: Int -> SmpteFragment -> ShowS
Show, ReadPrec [SmpteFragment]
ReadPrec SmpteFragment
Int -> ReadS SmpteFragment
ReadS [SmpteFragment]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SmpteFragment]
$creadListPrec :: ReadPrec [SmpteFragment]
readPrec :: ReadPrec SmpteFragment
$creadPrec :: ReadPrec SmpteFragment
readList :: ReadS [SmpteFragment]
$creadList :: ReadS [SmpteFragment]
readsPrec :: Int -> ReadS SmpteFragment
$creadsPrec :: Int -> ReadS SmpteFragment
Read)

rate_fps :: FrameRate -> Double
rate_fps :: FrameRate -> Double
rate_fps FrameRate
Frame24 = Double
24
rate_fps FrameRate
Frame25 = Double
25
rate_fps FrameRate
Frame29_97df = Double
29.97
rate_fps FrameRate
Frame30 = Double
30

data Smpte = Smpte {
    Smpte -> Manufacturer
smpte_hours :: !Word8
    , Smpte -> Manufacturer
smpte_minutes :: !Word8
    , Smpte -> Manufacturer
smpte_seconds :: !Word8
    , Smpte -> Manufacturer
smpte_frames :: !Word8
    } deriving (Smpte -> Smpte -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Smpte -> Smpte -> Bool
$c/= :: Smpte -> Smpte -> Bool
== :: Smpte -> Smpte -> Bool
$c== :: Smpte -> Smpte -> Bool
Eq, Int -> Smpte -> ShowS
[Smpte] -> ShowS
Smpte -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Smpte] -> ShowS
$cshowList :: [Smpte] -> ShowS
show :: Smpte -> String
$cshow :: Smpte -> String
showsPrec :: Int -> Smpte -> ShowS
$cshowsPrec :: Int -> Smpte -> ShowS
Show)

type Seconds = Double
type Frames = Int

seconds_to_frame :: FrameRate -> Seconds -> Frames
seconds_to_frame :: FrameRate -> Double -> Int
seconds_to_frame FrameRate
rate = forall a b. (RealFrac a, Integral b) => a -> b
floor forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
* FrameRate -> Double
rate_fps FrameRate
rate)

frame_to_seconds :: FrameRate -> Frames -> Seconds
frame_to_seconds :: FrameRate -> Int -> Double
frame_to_seconds FrameRate
rate = (forall a. Fractional a => a -> a -> a
/ FrameRate -> Double
rate_fps FrameRate
rate) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral

frame_to_smpte :: FrameRate -> Frames -> Smpte
frame_to_smpte :: FrameRate -> Int -> Smpte
frame_to_smpte FrameRate
rate Int
frame = Manufacturer
-> Manufacturer -> Manufacturer -> Manufacturer -> Smpte
Smpte (Int -> Manufacturer
w7 Int
hours) (Int -> Manufacturer
w7 Int
mins) (Int -> Manufacturer
w7 Int
secs) (Int -> Manufacturer
w7 Int
t3)
    where
    fps :: Int
fps = case FrameRate
rate of
        FrameRate
Frame29_97df -> Int
30
        FrameRate
_ -> forall a b. (RealFrac a, Integral b) => a -> b
floor (FrameRate -> Double
rate_fps FrameRate
rate)
    (Int
hours, Int
t1) = FrameRate -> Int -> Int
undrop_frames FrameRate
rate Int
frame forall a. Integral a => a -> a -> (a, a)
`divMod` (Int
60 forall a. Num a => a -> a -> a
* Int
60 forall a. Num a => a -> a -> a
* Int
fps)
    (Int
mins, Int
t2) = Int
t1 forall a. Integral a => a -> a -> (a, a)
`divMod` (Int
60 forall a. Num a => a -> a -> a
* Int
fps)
    (Int
secs, Int
t3) = Int
t2 forall a. Integral a => a -> a -> (a, a)
`divMod` Int
fps
    w7 :: Int -> Word7
    w7 :: Int -> Manufacturer
w7 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a -> a
Num.clamp Int
0 Int
0x7f

seconds_to_smpte :: FrameRate -> Seconds -> Smpte
seconds_to_smpte :: FrameRate -> Double -> Smpte
seconds_to_smpte FrameRate
rate = FrameRate -> Int -> Smpte
frame_to_smpte FrameRate
rate forall b c a. (b -> c) -> (a -> b) -> a -> c
. FrameRate -> Double -> Int
seconds_to_frame FrameRate
rate

-- | Add dropped frames back in.  When converted back into SMPTE the effect is
-- that the dropped frames are skipped.
undrop_frames :: FrameRate -> Frames -> Frames
undrop_frames :: FrameRate -> Int -> Int
undrop_frames FrameRate
Frame29_97df Int
frames =
    Int
frames forall a. Num a => a -> a -> a
+ Int
2 forall a. Num a => a -> a -> a
* (Int
frames forall a. Integral a => a -> a -> a
`div` (Int
30 forall a. Num a => a -> a -> a
* Int
60)) forall a. Num a => a -> a -> a
- Int
2 forall a. Num a => a -> a -> a
* (Int
frames forall a. Integral a => a -> a -> a
`div` (Int
10 forall a. Num a => a -> a -> a
* Int
30 forall a. Num a => a -> a -> a
* Int
60))
undrop_frames FrameRate
_ Int
frames = Int
frames

-- | Send full MTC sync code.  This is supposed to happen every time there is
-- a time dicontinuity.
mtc_sync :: FrameRate -> Smpte -> Message
mtc_sync :: FrameRate -> Smpte -> Message
mtc_sync FrameRate
rate (Smpte Manufacturer
hours Manufacturer
mins Manufacturer
secs Manufacturer
frames) =
    ByteString -> Message
realtime_sysex forall a b. (a -> b) -> a -> b
$ [Manufacturer] -> ByteString
ByteString.pack
        [Manufacturer
chan, Manufacturer
01, Manufacturer
01, Manufacturer
rate_code forall a. Bits a => a -> a -> a
.|. Manufacturer
hours, Manufacturer
mins, Manufacturer
secs, Manufacturer
frames]
    where
    chan :: Manufacturer
chan = Manufacturer
0x7f -- send to all devices
    rate_code :: Manufacturer
rate_code = forall a. Bits a => a -> Int -> a
Bits.shiftL (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Enum a => a -> Int
fromEnum FrameRate
rate)) Int
5
    -- TODO is chan the same as MMC DeviceId?

-- | Generate MTC starting at the given time and going on until the well of
-- time runs dry.  Or 7 bits overflow.
--
-- Since MTC can only start on a frame, the first returned time might be
-- slightly before the requested time.
--
-- One MtcQuarterFrame is transmitted per quarter frame.  Since it takes 8
-- to make a complete SMPTE frame, you wind up getting every other frame.
generate_mtc :: FrameRate -> Frames -> [(Double, Message)]
generate_mtc :: FrameRate -> Int -> [(Double, Message)]
generate_mtc FrameRate
rate Int
frame = forall a b. [a] -> [b] -> [(a, b)]
zip [Double]
times (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Int -> [Message]
msgs (forall a. Num a => a -> a -> [a]
Lists.range_ Int
frame Int
2))
    where
    -- Round up to the previous whole frame, then step forward frames and time
    -- together.  frame_to_smpte will take care of drop frame.
    msgs :: Int -> [Message]
msgs Int
frame = forall a b. (a -> b) -> [a] -> [b]
map (RealtimeMessage -> Message
RealtimeMessage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mtc -> RealtimeMessage
MtcQuarterFrame) forall a b. (a -> b) -> a -> b
$
        FrameRate -> Smpte -> [Mtc]
mtc_fragments FrameRate
rate (FrameRate -> Int -> Smpte
frame_to_smpte FrameRate
rate Int
frame)
    times :: [Double]
times = forall a. Num a => a -> a -> [a]
Lists.range_ Double
start Double
fragment
    start :: Double
start = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
frame forall a. Fractional a => a -> a -> a
/ FrameRate -> Double
rate_fps FrameRate
rate
    fragment :: Double
fragment = Double
1 forall a. Fractional a => a -> a -> a
/ FrameRate -> Double
rate_fps FrameRate
rate forall a. Fractional a => a -> a -> a
/ Double
4

mtc_fragments :: FrameRate -> Smpte -> [Mtc]
mtc_fragments :: FrameRate -> Smpte -> [Mtc]
mtc_fragments FrameRate
rate (Smpte Manufacturer
hours Manufacturer
minutes Manufacturer
seconds Manufacturer
frames) = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry SmpteFragment -> Manufacturer -> Mtc
Mtc)
    [ (SmpteFragment
FrameLsb, Manufacturer
frame_lsb), (SmpteFragment
FrameMsb, Manufacturer
frame_msb)
    , (SmpteFragment
SecondLsb, Manufacturer
sec_lsb), (SmpteFragment
SecondMsb, Manufacturer
sec_msb)
    , (SmpteFragment
MinuteLsb, Manufacturer
min_lsb), (SmpteFragment
MinuteMsb, Manufacturer
min_msb)
    , (SmpteFragment
HourLsb, Manufacturer
hour_lsb), (SmpteFragment
RateHourMsb, Manufacturer
rate_code forall a. Bits a => a -> a -> a
.|. Manufacturer
hour_msb)
    ]
    where
    (Manufacturer
frame_msb, Manufacturer
frame_lsb) = Manufacturer -> (Manufacturer, Manufacturer)
split4 Manufacturer
frames
    (Manufacturer
sec_msb, Manufacturer
sec_lsb) = Manufacturer -> (Manufacturer, Manufacturer)
split4 Manufacturer
seconds
    (Manufacturer
min_msb, Manufacturer
min_lsb) = Manufacturer -> (Manufacturer, Manufacturer)
split4 Manufacturer
minutes
    (Manufacturer
hour_msb, Manufacturer
hour_lsb) = Manufacturer -> (Manufacturer, Manufacturer)
split4 Manufacturer
hours
    rate_code :: Manufacturer
rate_code = forall a. Bits a => a -> Int -> a
Bits.shiftL (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Enum a => a -> Int
fromEnum FrameRate
rate)) Int
1

-- * tuning

type NoteNumber = Double

-- | Create a realtime tuning msg.  Few synthesizers support this.
--
-- Based on <http://www.midi.org/techspecs/midituning.php>
realtime_tuning :: [(Key, NoteNumber)] -> Message
realtime_tuning :: [(Key, Double)] -> Message
realtime_tuning [(Key, Double)]
nns = ByteString -> Message
realtime_sysex forall a b. (a -> b) -> a -> b
$ [Manufacturer] -> ByteString
ByteString.pack forall a b. (a -> b) -> a -> b
$
    [Manufacturer
generic_device, Manufacturer
8, Manufacturer
2, Manufacturer
0, forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Key, Double)]
nns)]
        forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Key -> Double -> [Manufacturer]
retune_key) [(Key, Double)]
nns
    where
    retune_key :: Key -> NoteNumber -> [Word7]
    retune_key :: Key -> Double -> [Manufacturer]
retune_key Key
key Double
nn = [forall a. Num a => Key -> a
from_key Key
key, Manufacturer
nn_key, Manufacturer
msb, Manufacturer
lsb]
        where
        (Manufacturer
lsb, Manufacturer
msb) = Int -> (Manufacturer, Manufacturer)
split14 forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ Double
frac forall a. Num a => a -> a -> a
* Double
2forall a b. (Num a, Integral b) => a -> b -> a
^Integer
14
        (Manufacturer
nn_key, Double
frac) = forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction Double
nn

-- * util

-- | Split an Int into two 7 bit words.
split14 :: Int -> (Word7, Word7) -- ^ (LSB, MSB)
split14 :: Int -> (Manufacturer, Manufacturer)
split14 Int
i = (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
i forall a. Bits a => a -> a -> a
.&. Int
0x7f), forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bits a => a -> Int -> a
Bits.shiftR Int
i Int
7 forall a. Bits a => a -> a -> a
.&. Int
0x7f))

-- | Join (LSB, MSB) 7-bit words into an int.
join14 :: Word7 -> Word7 -> Int
join14 :: Manufacturer -> Manufacturer -> Int
join14 Manufacturer
lsb Manufacturer
msb =
    forall a. Bits a => a -> Int -> a
Bits.shiftL (forall a b. (Integral a, Num b) => a -> b
fromIntegral Manufacturer
msb forall a. Bits a => a -> a -> a
.&. Int
0x7f) Int
7 forall a. Bits a => a -> a -> a
.|. (forall a b. (Integral a, Num b) => a -> b
fromIntegral Manufacturer
lsb forall a. Bits a => a -> a -> a
.&. Int
0x7f)

-- | Split a Word8 into nibbles.
split4 :: Word8 -> (Word4, Word4) -- ^ (MSB, LSB)
split4 :: Manufacturer -> (Manufacturer, Manufacturer)
split4 Manufacturer
word = (forall a. Bits a => a -> Int -> a
Bits.shiftR Manufacturer
word Int
4 forall a. Bits a => a -> a -> a
.&. Manufacturer
0xf, Manufacturer
word forall a. Bits a => a -> a -> a
.&. Manufacturer
0xf)

-- | Join (MSB, LSB) into a Word7.
join4 :: Word4 -> Word4 -> Word7
join4 :: Manufacturer -> Manufacturer -> Manufacturer
join4 Manufacturer
d1 Manufacturer
d2 = (forall a. Bits a => a -> Int -> a
Bits.shiftL Manufacturer
d1 Int
4 forall a. Bits a => a -> a -> a
.&. Manufacturer
0xf0) forall a. Bits a => a -> a -> a
.|. (Manufacturer
d2 forall a. Bits a => a -> a -> a
.&. Manufacturer
0x0f)

-- * constants

-- | Softsynths don't care about device ID, so use this.
generic_device :: Word7
generic_device :: Manufacturer
generic_device = Manufacturer
0x7f

manufacturer_name :: Manufacturer -> Text
manufacturer_name :: Manufacturer -> Text
manufacturer_name Manufacturer
code = forall a. a -> Maybe a -> a
Maybe.fromMaybe (forall a. Show a => a -> Text
showt Manufacturer
code) forall a b. (a -> b) -> a -> b
$
    forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Manufacturer
code Map Manufacturer Text
manufacturer_codes

korg_code, yamaha_code :: Manufacturer
korg_code :: Manufacturer
korg_code = Manufacturer
0x42
yamaha_code :: Manufacturer
yamaha_code = Manufacturer
0x43

-- | TODO get a more complete list
manufacturer_codes :: Map Manufacturer Text
manufacturer_codes :: Map Manufacturer Text
manufacturer_codes = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [(Manufacturer
korg_code, Text
"korg"), (Manufacturer
yamaha_code, Text
"yamaha")]