> module Euterpea.IO.MIDI.Play (
>     play -- standard playback, allows infinite values

>     ,playDev -- play to a custom device, allows infinite values

>     ,playS -- play with strict timing (finite values only)

>     ,playDevS -- play to a custom device with strict timing (finite values only)

>     ,playC -- custom playback implementation to replace playA, playS, playDev, etc.

>     ,devices -- function that prints available MIDI device information

>     ,musicToMsgs' -- music to MIDI message conversion

>     ,linearCP -- linear channel assignment policy

>     ,dynamicCP -- dynamic channel assignment policy

>     ,predefinedCP -- user-specified channel map (for MUIs)

>     ,defParams
>     ,playM'
>     ,PlayParams(..)
>     ,ChannelMapFun
>     ,ChannelMap
>     ) where

> import Codec.Midi hiding (Tempo)
> import Control.DeepSeq
> import Control.Monad
> import Control.Concurrent
> import Control.Exception
> import Data.List
> import Euterpea.IO.MIDI.MidiIO
> import Euterpea.IO.MIDI.ToMidi
> import Euterpea.IO.MIDI.MEvent
> import Euterpea.Music
> import Sound.PortMidi

--------------------------

 | User-Level Functions |
--------------------------


Playback parameter data type.

> data PlayParams = PlayParams{
>     PlayParams -> Bool
strict :: Bool, -- strict timing (False for infinite values)

>     PlayParams -> ChannelMapFun
chanPolicy :: ChannelMapFun, -- channel assignment policy

>     PlayParams -> Maybe OutputDeviceID
devID :: Maybe OutputDeviceID, -- output device (Nothing means to use the OS default)

>     PlayParams -> Time
closeDelay :: Time, -- offset in seconds to avoid truncated notes

>     PlayParams -> Music1 -> [MEvent]
perfAlg :: Music1 -> [MEvent]
>     }

Default parameters are the default pmap+context, allowing for infinite playback,
using a linear channel assignment policy for 16 channels with percussion on
channel 9 (which is channel 10 when indexing from 1), using the default MIDI
device as set by the operating system, and using a closing offset of 1.0sec.

> defParams :: PlayParams
defParams = Bool
-> ChannelMapFun
-> Maybe OutputDeviceID
-> Time
-> (Music1 -> [MEvent])
-> PlayParams
PlayParams Bool
False (NumChannels -> NumChannels -> ChannelMapFun
linearCP NumChannels
16 NumChannels
9) Maybe OutputDeviceID
forall a. Maybe a
Nothing Time
1.0 Music1 -> [MEvent]
perform1

New implementation of play using default parameters:

> play :: (ToMusic1 a, NFData a) => Music a -> IO ()
> play :: Music a -> IO ()
play = PlayParams -> Music a -> IO ()
forall a. (ToMusic1 a, NFData a) => PlayParams -> Music a -> IO ()
playC PlayParams
defParams

> playS :: (ToMusic1 a, NFData a) => Music a -> IO ()
> playS :: Music a -> IO ()
playS = PlayParams -> Music a -> IO ()
forall a. (ToMusic1 a, NFData a) => PlayParams -> Music a -> IO ()
playC PlayParams
defParams{strict :: Bool
strict=Bool
True}

> playDev :: (ToMusic1 a, NFData a) => Int -> Music a -> IO ()
> playDev :: NumChannels -> Music a -> IO ()
playDev NumChannels
i = PlayParams -> Music a -> IO ()
forall a. (ToMusic1 a, NFData a) => PlayParams -> Music a -> IO ()
playC PlayParams
defParams{devID :: Maybe OutputDeviceID
devID = OutputDeviceID -> Maybe OutputDeviceID
forall a. a -> Maybe a
Just (OutputDeviceID -> Maybe OutputDeviceID)
-> OutputDeviceID -> Maybe OutputDeviceID
forall a b. (a -> b) -> a -> b
$ NumChannels -> OutputDeviceID
unsafeOutputID NumChannels
i}

> playDevS :: (ToMusic1 a, NFData a) => Int -> Music a -> IO()
> playDevS :: NumChannels -> Music a -> IO ()
playDevS NumChannels
i = PlayParams -> Music a -> IO ()
forall a. (ToMusic1 a, NFData a) => PlayParams -> Music a -> IO ()
playC PlayParams
defParams{strict :: Bool
strict=Bool
True, devID :: Maybe OutputDeviceID
devID = OutputDeviceID -> Maybe OutputDeviceID
forall a. a -> Maybe a
Just (OutputDeviceID -> Maybe OutputDeviceID)
-> OutputDeviceID -> Maybe OutputDeviceID
forall a b. (a -> b) -> a -> b
$ NumChannels -> OutputDeviceID
unsafeOutputID NumChannels
i}

"Custom play" interface:

> playC :: (ToMusic1 a, NFData a) => PlayParams -> Music a -> IO ()
> playC :: PlayParams -> Music a -> IO ()
playC PlayParams
p = if PlayParams -> Bool
strict PlayParams
p then PlayParams -> Music a -> IO ()
forall a. (ToMusic1 a, NFData a) => PlayParams -> Music a -> IO ()
playStrict PlayParams
p else PlayParams -> Music a -> IO ()
forall a. ToMusic1 a => PlayParams -> Music a -> IO ()
playInf PlayParams
p

Getting a list of all MIDI input and output devices, showing both
their device IDs and names.

> devices :: IO ()
devices = do
>   ([(InputDeviceID, DeviceInfo)]
devsIn, [(OutputDeviceID, DeviceInfo)]
devsOut) <- IO ([(InputDeviceID, DeviceInfo)], [(OutputDeviceID, DeviceInfo)])
getAllDevices
>   let f :: (a, DeviceInfo) -> [Char]
f (a
devid, DeviceInfo
devname) = [Char]
"  "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++a -> [Char]
forall a. Show a => a -> [Char]
show a
devid [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\t" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ DeviceInfo -> [Char]
name DeviceInfo
devname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
>       strIn :: [Char]
strIn = ((InputDeviceID, DeviceInfo) -> [Char])
-> [(InputDeviceID, DeviceInfo)] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (InputDeviceID, DeviceInfo) -> [Char]
forall a. Show a => (a, DeviceInfo) -> [Char]
f [(InputDeviceID, DeviceInfo)]
devsIn
>       strOut :: [Char]
strOut = ((OutputDeviceID, DeviceInfo) -> [Char])
-> [(OutputDeviceID, DeviceInfo)] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (OutputDeviceID, DeviceInfo) -> [Char]
forall a. Show a => (a, DeviceInfo) -> [Char]
f [(OutputDeviceID, DeviceInfo)]
devsOut
>   [Char] -> IO ()
putStrLn [Char]
"\nInput devices: " IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> IO ()
putStrLn [Char]
strIn
>   [Char] -> IO ()
putStrLn [Char]
"Output devices: " IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> IO ()
putStrLn [Char]
strOut


------------------------------------

 | Supporting functions for playC |
------------------------------------


Strict playback: timing will be as close to perfect as possible, but the
Music value must be finite. Timing will be correct starting from the first
note, even if there is a long computation offset prior to any sound.

> playStrict :: (ToMusic1 a, NFData a) => PlayParams -> Music a -> IO ()
> playStrict :: PlayParams -> Music a -> IO ()
playStrict PlayParams
p Music a
m = Music a
m Music a -> IO () -> IO ()
forall a b. NFData a => a -> b -> b
`deepseq`
>     let x :: Midi
x = [MEvent] -> Midi
toMidi (PlayParams -> Music1 -> [MEvent]
perfAlg PlayParams
p (Music1 -> [MEvent]) -> Music1 -> [MEvent]
forall a b. (a -> b) -> a -> b
$ Music a -> Music1
forall a. ToMusic1 a => Music a -> Music1
toMusic1 Music a
m)
>     in  Midi
x Midi -> IO () -> IO ()
forall a b. NFData a => a -> b -> b
`deepseq` Maybe OutputDeviceID -> Midi -> IO ()
playM' (PlayParams -> Maybe OutputDeviceID
devID PlayParams
p) Midi
x

> playM' :: Maybe OutputDeviceID -> Midi -> IO ()
> playM' :: Maybe OutputDeviceID -> Midi -> IO ()
playM' Maybe OutputDeviceID
devID Midi
midi = IO () -> IO ()
forall a. IO a -> IO a
handleCtrlC (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
>     IO (Either PMError PMSuccess)
initialize
>     ((Midi -> IO ())
-> (OutputDeviceID -> Midi -> IO ())
-> Maybe OutputDeviceID
-> Midi
-> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((OutputDeviceID -> Midi -> IO ()) -> Midi -> IO ()
forall a b. (OutputDeviceID -> a -> IO b) -> a -> IO b
defaultOutput OutputDeviceID -> Midi -> IO ()
playMidi) OutputDeviceID -> Midi -> IO ()
playMidi Maybe OutputDeviceID
devID) Midi
midi
>     IO (Either PMError PMSuccess)
terminate
>     () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () where
>     handleCtrlC :: IO a -> IO a
>     handleCtrlC :: IO a -> IO a
handleCtrlC IO a
op = IO a -> IO (Either PMError PMSuccess) -> IO a
forall a b. IO a -> IO b -> IO a
onException IO a
op IO (Either PMError PMSuccess)
terminate


Infinite playback: arbitrarily long music values can be played, although
with the compromise that timing may be imperfect due to lazy evaluation of
the Music value. Delays may happen if a section of the Music value is time-
consuming to compute. Infinite parallelism is not supported.

> playInf :: ToMusic1 a => PlayParams -> Music a -> IO ()
> playInf :: PlayParams -> Music a -> IO ()
playInf PlayParams
p Music a
m = IO () -> IO ()
forall a. IO a -> IO a
handleCtrlC (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
>     IO ()
initializeMidi
>     (([(Time, MidiMessage)] -> IO ())
-> (OutputDeviceID -> [(Time, MidiMessage)] -> IO ())
-> Maybe OutputDeviceID
-> [(Time, MidiMessage)]
-> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((OutputDeviceID -> [(Time, MidiMessage)] -> IO ())
-> [(Time, MidiMessage)] -> IO ()
forall a b. (OutputDeviceID -> a -> IO b) -> a -> IO b
defaultOutput OutputDeviceID -> [(Time, MidiMessage)] -> IO ()
forall a.
RealFrac a =>
OutputDeviceID -> [(a, MidiMessage)] -> IO ()
playRec) OutputDeviceID -> [(Time, MidiMessage)] -> IO ()
forall a.
RealFrac a =>
OutputDeviceID -> [(a, MidiMessage)] -> IO ()
playRec (PlayParams -> Maybe OutputDeviceID
devID PlayParams
p)) ([(Time, MidiMessage)] -> IO ()) -> [(Time, MidiMessage)] -> IO ()
forall a b. (a -> b) -> a -> b
$ PlayParams -> Music a -> [(Time, MidiMessage)]
forall a.
ToMusic1 a =>
PlayParams -> Music a -> [(Time, MidiMessage)]
musicToMsgs' PlayParams
p Music a
m
>     NumChannels -> IO ()
threadDelay (NumChannels -> IO ()) -> NumChannels -> IO ()
forall a b. (a -> b) -> a -> b
$ Time -> NumChannels
forall a b. (RealFrac a, Integral b) => a -> b
round (PlayParams -> Time
closeDelay PlayParams
p Time -> Time -> Time
forall a. Num a => a -> a -> a
* Time
1000000)
>     IO ()
terminateMidi
>     () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () where
>     handleCtrlC :: IO a -> IO a
>     handleCtrlC :: IO a -> IO a
handleCtrlC IO a
op = do
>         OutputDeviceID
dev <- Maybe OutputDeviceID -> IO OutputDeviceID
resolveOutDev (PlayParams -> Maybe OutputDeviceID
devID PlayParams
p)
>         IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
onException IO a
op (OutputDeviceID -> NumChannels -> IO ()
stopMidiOut (OutputDeviceID
dev) NumChannels
16)

Bug fix on Sept 24, 2018: on Mac, the default output device may not be zero.
In rare cases on Mac, there are outputs but the default ID is Nothing, but
in these cases the default always seems to be the first output in the list.

> resolveOutDev :: Maybe OutputDeviceID -> IO OutputDeviceID
resolveOutDev Maybe OutputDeviceID
Nothing = do
>    Maybe NumChannels
outDevM <- IO (Maybe NumChannels)
getDefaultOutputDeviceID
>    ([(InputDeviceID, DeviceInfo)]
ins,[(OutputDeviceID, DeviceInfo)]
outs) <- IO ([(InputDeviceID, DeviceInfo)], [(OutputDeviceID, DeviceInfo)])
getAllDevices
>    let allOutDevs :: [OutputDeviceID]
allOutDevs = ((OutputDeviceID, DeviceInfo) -> OutputDeviceID)
-> [(OutputDeviceID, DeviceInfo)] -> [OutputDeviceID]
forall a b. (a -> b) -> [a] -> [b]
map (OutputDeviceID, DeviceInfo) -> OutputDeviceID
forall a b. (a, b) -> a
fst [(OutputDeviceID, DeviceInfo)]
outs
>    let outDev :: OutputDeviceID
outDev = case Maybe NumChannels
outDevM of
>                     Maybe NumChannels
Nothing ->
>                            if [OutputDeviceID] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [OutputDeviceID]
allOutDevs then [Char] -> OutputDeviceID
forall a. HasCallStack => [Char] -> a
error [Char]
"No MIDI outputs!"
>                            else [OutputDeviceID] -> OutputDeviceID
forall a. [a] -> a
head [OutputDeviceID]
allOutDevs
>                     Just NumChannels
x -> NumChannels -> OutputDeviceID
unsafeOutputID NumChannels
x
>    OutputDeviceID -> IO OutputDeviceID
forall (m :: * -> *) a. Monad m => a -> m a
return OutputDeviceID
outDev
> resolveOutDev (Just OutputDeviceID
x) = OutputDeviceID -> IO OutputDeviceID
forall (m :: * -> *) a. Monad m => a -> m a
return OutputDeviceID
x

> stopMidiOut :: OutputDeviceID -> Channel -> IO ()
> stopMidiOut :: OutputDeviceID -> NumChannels -> IO ()
stopMidiOut OutputDeviceID
dev NumChannels
i = if NumChannels
iNumChannels -> NumChannels -> Bool
forall a. Ord a => a -> a -> Bool
<NumChannels
0 then NumChannels -> IO ()
threadDelay NumChannels
1000000 IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
terminateMidi else do
>     OutputDeviceID -> (Time, MidiMessage) -> IO ()
deliverMidiEvent OutputDeviceID
dev (Time
0, Message -> MidiMessage
Std (Message -> MidiMessage) -> Message -> MidiMessage
forall a b. (a -> b) -> a -> b
$ NumChannels -> NumChannels -> NumChannels -> Message
ControlChange NumChannels
i NumChannels
123 NumChannels
0)
>     OutputDeviceID -> NumChannels -> IO ()
stopMidiOut OutputDeviceID
dev (NumChannels
iNumChannels -> NumChannels -> NumChannels
forall a. Num a => a -> a -> a
-NumChannels
1)

> playRec :: OutputDeviceID -> [(a, MidiMessage)] -> IO ()
playRec OutputDeviceID
dev [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
> playRec OutputDeviceID
dev (x :: (a, MidiMessage)
x@(a
t,MidiMessage
m):[(a, MidiMessage)]
ms) =
>     if a
t a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0 then NumChannels -> IO ()
threadDelay (a -> NumChannels
forall a b. (RealFrac a, Integral b) => a -> b
toMicroSec a
t) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> OutputDeviceID -> [(a, MidiMessage)] -> IO ()
playRec OutputDeviceID
dev ((a
0,MidiMessage
m)(a, MidiMessage) -> [(a, MidiMessage)] -> [(a, MidiMessage)]
forall a. a -> [a] -> [a]
:[(a, MidiMessage)]
ms) else
>     let mNow :: [(a, MidiMessage)]
mNow = (a, MidiMessage)
x (a, MidiMessage) -> [(a, MidiMessage)] -> [(a, MidiMessage)]
forall a. a -> [a] -> [a]
: ((a, MidiMessage) -> Bool)
-> [(a, MidiMessage)] -> [(a, MidiMessage)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<=a
0)(a -> Bool) -> ((a, MidiMessage) -> a) -> (a, MidiMessage) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(a, MidiMessage) -> a
forall a b. (a, b) -> a
fst) [(a, MidiMessage)]
ms
>         mLater :: [(a, MidiMessage)]
mLater = NumChannels -> [(a, MidiMessage)] -> [(a, MidiMessage)]
forall a. NumChannels -> [a] -> [a]
drop ([(a, MidiMessage)] -> NumChannels
forall (t :: * -> *) a. Foldable t => t a -> NumChannels
length [(a, MidiMessage)]
mNow NumChannels -> NumChannels -> NumChannels
forall a. Num a => a -> a -> a
- NumChannels
1) [(a, MidiMessage)]
ms
>     in  OutputDeviceID -> Maybe [(a, MidiMessage)] -> IO ()
forall (t :: * -> *) a.
Foldable t =>
OutputDeviceID -> Maybe (t (a, MidiMessage)) -> IO ()
doMidiOut OutputDeviceID
dev ([(a, MidiMessage)] -> Maybe [(a, MidiMessage)]
forall a. a -> Maybe a
Just ([(a, MidiMessage)] -> Maybe [(a, MidiMessage)])
-> [(a, MidiMessage)] -> Maybe [(a, MidiMessage)]
forall a b. (a -> b) -> a -> b
$ [(a, MidiMessage)]
mNow) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> OutputDeviceID -> [(a, MidiMessage)] -> IO ()
playRec OutputDeviceID
dev [(a, MidiMessage)]
mLater where
>     doMidiOut :: OutputDeviceID -> Maybe (t (a, MidiMessage)) -> IO ()
doMidiOut OutputDeviceID
dev Maybe (t (a, MidiMessage))
Nothing = OutputDeviceID -> IO ()
outputMidi OutputDeviceID
dev
>     doMidiOut OutputDeviceID
dev (Just t (a, MidiMessage)
ms) = do
>         OutputDeviceID -> IO ()
outputMidi OutputDeviceID
dev
>         ((a, MidiMessage) -> IO ()) -> t (a, MidiMessage) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(a
t,MidiMessage
m) -> OutputDeviceID -> (Time, MidiMessage) -> IO ()
deliverMidiEvent OutputDeviceID
dev (Time
0, MidiMessage
m)) t (a, MidiMessage)
ms
>     toMicroSec :: a -> b
toMicroSec a
x = a -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (a
x a -> a -> a
forall a. Num a => a -> a -> a
* a
1000000)


---------------------------------

 | Music to Message conversion |
---------------------------------


Music to message conversion will take place differently depending
on the channel assignment method. Using linearCP will assign the first
n instruments to channels 0 through n-1 (or 1 through n). Using
dynamicCP will fill up n channels and then replace the last-used
instrument's channel with the new instrument.

Some synthesizers only recognize 10 unique channels, others use the
full 16 allowed by general MIDI. Drums are usually on channel 9
(channel 10 when indexing from 1), but not always.  Sometimes drums
can be assigned to a custom channel.

A ChannelMap stores which instrument is assigned to which channel.
This table is built automatically when playing a Music value; the
user does not need to worry about constructing it.

> type ChannelMap = [(InstrumentName, Channel)]

Given an InstrumentName and a ChannelMap, a ChannelMapFun picks a new
channel to assign to the instrument and retruns both that and the
updated ChannelMap. This is done each time a new InstrumentName is
encountered (in other words, it is not in the current ChannelMap).

> type ChannelMapFun = InstrumentName -> ChannelMap -> (Channel, ChannelMap)

The function below first converts to ANote values and then to Std On/Off
pairs. This is needed to avoid timing issues associated with using ANote
and trying to call terminateMIDI, since if there is an ANote at the end
it will sometimes have its NoteOff lost, which can cause errors.

> musicToMsgs' :: (ToMusic1 a) => PlayParams -> Music a -> [(Time, MidiMessage)]
> musicToMsgs' :: PlayParams -> Music a -> [(Time, MidiMessage)]
musicToMsgs' PlayParams
p Music a
m =
>     let perf :: [MEvent]
perf = PlayParams -> Music1 -> [MEvent]
perfAlg PlayParams
p (Music1 -> [MEvent]) -> Music1 -> [MEvent]
forall a b. (a -> b) -> a -> b
$ Music a -> Music1
forall a. ToMusic1 a => Music a -> Music1
toMusic1 Music a
m -- obtain the performance

>         evsA :: [(Time, MidiMessage)]
evsA = ChannelMapFun -> ChannelMap -> [MEvent] -> [(Time, MidiMessage)]
channelMap (PlayParams -> ChannelMapFun
chanPolicy PlayParams
p) [] [MEvent]
perf -- time-stamped ANote values

>         evs :: [(Time, MidiMessage)]
evs = [(Time, MidiMessage)] -> [(Time, MidiMessage)]
stdMerge [(Time, MidiMessage)]
evsA -- merged On/Off events sorted by absolute time

>         times :: [Time]
times = ((Time, MidiMessage) -> Time) -> [(Time, MidiMessage)] -> [Time]
forall a b. (a -> b) -> [a] -> [b]
map (Time, MidiMessage) -> Time
forall a b. (a, b) -> a
fst [(Time, MidiMessage)]
evs -- absolute times in seconds

>         newTimes :: [Time]
newTimes = (Time -> Time -> Time) -> [Time] -> [Time] -> [Time]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Time -> Time -> Time
forall a. Num a => a -> a -> a
subtract ([Time] -> Time
forall a. [a] -> a
head [Time]
times Time -> [Time] -> [Time]
forall a. a -> [a] -> [a]
: [Time]
times) [Time]
times -- relative times

>     in  [Time] -> [MidiMessage] -> [(Time, MidiMessage)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Time]
newTimes (((Time, MidiMessage) -> MidiMessage)
-> [(Time, MidiMessage)] -> [MidiMessage]
forall a b. (a -> b) -> [a] -> [b]
map (Time, MidiMessage) -> MidiMessage
forall a b. (a, b) -> b
snd [(Time, MidiMessage)]
evs) where
>     -- stdMerge: converts ANotes into a sorted list of On/Off events

>     stdMerge :: [(Time, MidiMessage)] -> [(Time, MidiMessage)]
>     stdMerge :: [(Time, MidiMessage)] -> [(Time, MidiMessage)]
stdMerge [] = []
>     stdMerge ((Time
t,ANote NumChannels
c NumChannels
k NumChannels
v Time
d):[(Time, MidiMessage)]
es) =
>         (Time
t, Message -> MidiMessage
Std (Message -> MidiMessage) -> Message -> MidiMessage
forall a b. (a -> b) -> a -> b
$ NumChannels -> NumChannels -> NumChannels -> Message
NoteOn NumChannels
c NumChannels
k NumChannels
v) (Time, MidiMessage)
-> [(Time, MidiMessage)] -> [(Time, MidiMessage)]
forall a. a -> [a] -> [a]
:
>         [(Time, MidiMessage)] -> [(Time, MidiMessage)]
stdMerge (((Time, MidiMessage) -> (Time, MidiMessage) -> Ordering)
-> (Time, MidiMessage)
-> [(Time, MidiMessage)]
-> [(Time, MidiMessage)]
forall a. (a -> a -> Ordering) -> a -> [a] -> [a]
insertBy (\(Time
a,MidiMessage
b) (Time
x,MidiMessage
y) -> Time -> Time -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Time
a Time
x) (Time
tTime -> Time -> Time
forall a. Num a => a -> a -> a
+Time
d, Message -> MidiMessage
Std (Message -> MidiMessage) -> Message -> MidiMessage
forall a b. (a -> b) -> a -> b
$ NumChannels -> NumChannels -> NumChannels -> Message
NoteOff NumChannels
c NumChannels
k NumChannels
v) [(Time, MidiMessage)]
es)
>     stdMerge ((Time, MidiMessage)
e1:[(Time, MidiMessage)]
es) = (Time, MidiMessage)
e1 (Time, MidiMessage)
-> [(Time, MidiMessage)] -> [(Time, MidiMessage)]
forall a. a -> [a] -> [a]
: [(Time, MidiMessage)] -> [(Time, MidiMessage)]
stdMerge [(Time, MidiMessage)]
es
>     -- channelMap: performs instrument assignment for a list of Events

>     channelMap :: ChannelMapFun -> ChannelMap -> [MEvent] -> [(Time, MidiMessage)]
>     channelMap :: ChannelMapFun -> ChannelMap -> [MEvent] -> [(Time, MidiMessage)]
channelMap ChannelMapFun
cf ChannelMap
cMap [] = []
>     channelMap ChannelMapFun
cf ChannelMap
cMap (MEvent
e:[MEvent]
es) =
>         let i :: InstrumentName
i = MEvent -> InstrumentName
eInst MEvent
e
>             ((NumChannels
chan, ChannelMap
cMap'), Bool
newI) = case InstrumentName -> ChannelMap -> Maybe NumChannels
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup InstrumentName
i ChannelMap
cMap of Maybe NumChannels
Nothing -> (ChannelMapFun
cf InstrumentName
i ChannelMap
cMap, Bool
True)
>                                                           Just NumChannels
x  -> ((NumChannels
x, ChannelMap
cMap), Bool
False)
>             e' :: (Time, MidiMessage)
e' = (Rational -> Time
forall a. Fractional a => Rational -> a
fromRational (MEvent -> Rational
eTime MEvent
e),
>                   NumChannels -> NumChannels -> NumChannels -> Time -> MidiMessage
ANote NumChannels
chan (MEvent -> NumChannels
ePitch MEvent
e) (MEvent -> NumChannels
eVol MEvent
e) (Rational -> Time
forall a. Fractional a => Rational -> a
fromRational (Rational -> Time) -> Rational -> Time
forall a b. (a -> b) -> a -> b
$ MEvent -> Rational
eDur MEvent
e))
>             es' :: [(Time, MidiMessage)]
es' = ChannelMapFun -> ChannelMap -> [MEvent] -> [(Time, MidiMessage)]
channelMap ChannelMapFun
cf ChannelMap
cMap' [MEvent]
es
>             iNum :: NumChannels
iNum = if InstrumentName
iInstrumentName -> InstrumentName -> Bool
forall a. Eq a => a -> a -> Bool
==InstrumentName
Percussion then NumChannels
0 else InstrumentName -> NumChannels
forall a. Enum a => a -> NumChannels
fromEnum InstrumentName
i
>         in  if Bool
newI then ((Time, MidiMessage) -> Time
forall a b. (a, b) -> a
fst (Time, MidiMessage)
e', Message -> MidiMessage
Std (Message -> MidiMessage) -> Message -> MidiMessage
forall a b. (a -> b) -> a -> b
$ NumChannels -> NumChannels -> Message
ProgramChange NumChannels
chan NumChannels
iNum) (Time, MidiMessage)
-> [(Time, MidiMessage)] -> [(Time, MidiMessage)]
forall a. a -> [a] -> [a]
: (Time, MidiMessage)
e' (Time, MidiMessage)
-> [(Time, MidiMessage)] -> [(Time, MidiMessage)]
forall a. a -> [a] -> [a]
: [(Time, MidiMessage)]
es'
>             else (Time, MidiMessage)
e' (Time, MidiMessage)
-> [(Time, MidiMessage)] -> [(Time, MidiMessage)]
forall a. a -> [a] -> [a]
: [(Time, MidiMessage)]
es'

The linearCP channel map just fills up channels left to right until it hits
the maximum number and then throws an error. Percussion is handled as a
special case.

> type NumChannels = Int -- maximum number of channels (i.e. 0-15 is 16 channels)

> type PercChan = Int -- percussion channel, using indexing from zero


> linearCP :: NumChannels -> PercChan -> ChannelMapFun
> linearCP :: NumChannels -> NumChannels -> ChannelMapFun
linearCP NumChannels
cLim NumChannels
pChan InstrumentName
i ChannelMap
cMap = if InstrumentName
iInstrumentName -> InstrumentName -> Bool
forall a. Eq a => a -> a -> Bool
==InstrumentName
Percussion then (NumChannels
pChan, (InstrumentName
i,NumChannels
pChan)(InstrumentName, NumChannels) -> ChannelMap -> ChannelMap
forall a. a -> [a] -> [a]
:ChannelMap
cMap) else
>     let n :: NumChannels
n = ChannelMap -> NumChannels
forall (t :: * -> *) a. Foldable t => t a -> NumChannels
length (ChannelMap -> NumChannels) -> ChannelMap -> NumChannels
forall a b. (a -> b) -> a -> b
$ ((InstrumentName, NumChannels) -> Bool) -> ChannelMap -> ChannelMap
forall a. (a -> Bool) -> [a] -> [a]
filter ((InstrumentName -> InstrumentName -> Bool
forall a. Eq a => a -> a -> Bool
/=InstrumentName
Percussion)(InstrumentName -> Bool)
-> ((InstrumentName, NumChannels) -> InstrumentName)
-> (InstrumentName, NumChannels)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InstrumentName, NumChannels) -> InstrumentName
forall a b. (a, b) -> a
fst) ChannelMap
cMap
>         newChan :: NumChannels
newChan = if NumChannels
nNumChannels -> NumChannels -> Bool
forall a. Ord a => a -> a -> Bool
>=NumChannels
pChan then NumChannels
nNumChannels -> NumChannels -> NumChannels
forall a. Num a => a -> a -> a
+NumChannels
1 else NumChannels
n -- step over the percussion channel

>     in if NumChannels
newChan NumChannels -> NumChannels -> Bool
forall a. Ord a => a -> a -> Bool
< NumChannels
cLim then (NumChannels
newChan, (InstrumentName
i, NumChannels
newChan) (InstrumentName, NumChannels) -> ChannelMap -> ChannelMap
forall a. a -> [a] -> [a]
: ChannelMap
cMap) else
>        [Char] -> (NumChannels, ChannelMap)
forall a. HasCallStack => [Char] -> a
error ([Char]
"Cannot use more than "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++NumChannels -> [Char]
forall a. Show a => a -> [Char]
show NumChannels
cLim[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" instruments.")

For the dynamicCP channel map, new assignements are added in the left side
of the channel map/list. This means that the item farthest to the right
is the oldest and should be replaced when the table is full. Percussion
is handled separately.

> dynamicCP :: NumChannels -> PercChan -> ChannelMapFun
> dynamicCP :: NumChannels -> NumChannels -> ChannelMapFun
dynamicCP NumChannels
cLim NumChannels
pChan InstrumentName
i ChannelMap
cMap =
>     if InstrumentName
iInstrumentName -> InstrumentName -> Bool
forall a. Eq a => a -> a -> Bool
==InstrumentName
Percussion then (NumChannels
pChan, (InstrumentName
i, NumChannels
pChan)(InstrumentName, NumChannels) -> ChannelMap -> ChannelMap
forall a. a -> [a] -> [a]
:ChannelMap
cMap) else
>         let cMapNoP :: ChannelMap
cMapNoP = ((InstrumentName, NumChannels) -> Bool) -> ChannelMap -> ChannelMap
forall a. (a -> Bool) -> [a] -> [a]
filter ((InstrumentName -> InstrumentName -> Bool
forall a. Eq a => a -> a -> Bool
/=InstrumentName
Percussion)(InstrumentName -> Bool)
-> ((InstrumentName, NumChannels) -> InstrumentName)
-> (InstrumentName, NumChannels)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InstrumentName, NumChannels) -> InstrumentName
forall a b. (a, b) -> a
fst) ChannelMap
cMap
>             extra :: ChannelMap
extra = if ChannelMap -> NumChannels
forall (t :: * -> *) a. Foldable t => t a -> NumChannels
length ChannelMap
cMapNoP NumChannels -> NumChannels -> Bool
forall a. Eq a => a -> a -> Bool
== ChannelMap -> NumChannels
forall (t :: * -> *) a. Foldable t => t a -> NumChannels
length ChannelMap
cMap then [] else [(InstrumentName
Percussion, NumChannels
pChan)]
>             newChan :: NumChannels
newChan = (InstrumentName, NumChannels) -> NumChannels
forall a b. (a, b) -> b
snd ((InstrumentName, NumChannels) -> NumChannels)
-> (InstrumentName, NumChannels) -> NumChannels
forall a b. (a -> b) -> a -> b
$ ChannelMap -> (InstrumentName, NumChannels)
forall a. [a] -> a
last ChannelMap
cMapNoP
>         in  if ChannelMap -> NumChannels
forall (t :: * -> *) a. Foldable t => t a -> NumChannels
length ChannelMap
cMapNoP NumChannels -> NumChannels -> Bool
forall a. Ord a => a -> a -> Bool
< NumChannels
cLim NumChannels -> NumChannels -> NumChannels
forall a. Num a => a -> a -> a
- NumChannels
1 then NumChannels -> NumChannels -> ChannelMapFun
linearCP NumChannels
cLim NumChannels
pChan InstrumentName
i ChannelMap
cMap
>         else (NumChannels
newChan, (InstrumentName
i, NumChannels
newChan) (InstrumentName, NumChannels) -> ChannelMap -> ChannelMap
forall a. a -> [a] -> [a]
: (NumChannels -> ChannelMap -> ChannelMap
forall a. NumChannels -> [a] -> [a]
take (ChannelMap -> NumChannels
forall (t :: * -> *) a. Foldable t => t a -> NumChannels
length ChannelMap
cMapNoP NumChannels -> NumChannels -> NumChannels
forall a. Num a => a -> a -> a
- NumChannels
1) ChannelMap
cMapNoP)ChannelMap -> ChannelMap -> ChannelMap
forall a. [a] -> [a] -> [a]
++ChannelMap
extra)


A predefined policy will send instruments to user-defined channels. If new
instruments are found that are not accounted for, an error is thrown.

> predefinedCP :: ChannelMap -> ChannelMapFun
> predefinedCP :: ChannelMap -> ChannelMapFun
predefinedCP ChannelMap
cMapFixed InstrumentName
i ChannelMap
_ = case InstrumentName -> ChannelMap -> Maybe NumChannels
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup InstrumentName
i ChannelMap
cMapFixed of
>     Maybe NumChannels
Nothing -> [Char] -> (NumChannels, ChannelMap)
forall a. HasCallStack => [Char] -> a
error (InstrumentName -> [Char]
forall a. Show a => a -> [Char]
show InstrumentName
i [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is not included in the channel map.")
>     Just NumChannels
c -> (NumChannels
c, ChannelMap
cMapFixed)

-------------------------------

 | NFData instances for Midi |
-------------------------------


> instance NFData FileType where
>     rnf :: FileType -> ()
rnf FileType
x = ()

> instance NFData TimeDiv where
>     rnf :: TimeDiv -> ()
rnf (TicksPerBeat NumChannels
i) = NumChannels -> ()
forall a. NFData a => a -> ()
rnf NumChannels
i
>     rnf (TicksPerSecond NumChannels
i NumChannels
j) = NumChannels -> ()
forall a. NFData a => a -> ()
rnf NumChannels
j () -> () -> ()
`seq` NumChannels -> ()
forall a. NFData a => a -> ()
rnf NumChannels
i

> instance NFData Midi where
>     rnf :: Midi -> ()
rnf (Midi FileType
ft TimeDiv
td [Track NumChannels]
ts) = FileType -> ()
forall a. NFData a => a -> ()
rnf FileType
ft () -> () -> ()
`seq` TimeDiv -> ()
forall a. NFData a => a -> ()
rnf TimeDiv
td () -> () -> ()
`seq` [Track NumChannels] -> ()
forall a. NFData a => a -> ()
rnf [Track NumChannels]
ts

> instance NFData Message where
>     rnf :: Message -> ()
rnf (NoteOff NumChannels
c NumChannels
k NumChannels
v) = NumChannels -> ()
forall a. NFData a => a -> ()
rnf NumChannels
c () -> () -> ()
`seq` NumChannels -> ()
forall a. NFData a => a -> ()
rnf NumChannels
k () -> () -> ()
`seq` NumChannels -> ()
forall a. NFData a => a -> ()
rnf NumChannels
v
>     rnf (NoteOn NumChannels
c NumChannels
k NumChannels
v) = NumChannels -> ()
forall a. NFData a => a -> ()
rnf NumChannels
c () -> () -> ()
`seq` NumChannels -> ()
forall a. NFData a => a -> ()
rnf NumChannels
k () -> () -> ()
`seq` NumChannels -> ()
forall a. NFData a => a -> ()
rnf NumChannels
v
>     rnf (KeyPressure NumChannels
c NumChannels
k NumChannels
v) = NumChannels -> ()
forall a. NFData a => a -> ()
rnf NumChannels
c () -> () -> ()
`seq` NumChannels -> ()
forall a. NFData a => a -> ()
rnf NumChannels
k () -> () -> ()
`seq` NumChannels -> ()
forall a. NFData a => a -> ()
rnf NumChannels
v
>     rnf (ProgramChange NumChannels
c NumChannels
v) = NumChannels -> ()
forall a. NFData a => a -> ()
rnf NumChannels
c () -> () -> ()
`seq` NumChannels -> ()
forall a. NFData a => a -> ()
rnf NumChannels
v
>     rnf (ChannelPressure NumChannels
c NumChannels
v) = NumChannels -> ()
forall a. NFData a => a -> ()
rnf NumChannels
c () -> () -> ()
`seq` NumChannels -> ()
forall a. NFData a => a -> ()
rnf NumChannels
v
>     rnf (PitchWheel NumChannels
c NumChannels
v) = NumChannels -> ()
forall a. NFData a => a -> ()
rnf NumChannels
c () -> () -> ()
`seq` NumChannels -> ()
forall a. NFData a => a -> ()
rnf NumChannels
v
>     rnf (TempoChange NumChannels
t) = NumChannels -> ()
forall a. NFData a => a -> ()
rnf NumChannels
t
>     rnf Message
x = () -- no other message types are currently used by Euterpea


> instance NFData MidiMessage where
>     rnf :: MidiMessage -> ()
rnf (Std Message
m) = Message -> ()
forall a. NFData a => a -> ()
rnf Message
m
>     rnf (ANote NumChannels
c NumChannels
k NumChannels
v Time
d) = NumChannels -> ()
forall a. NFData a => a -> ()
rnf NumChannels
c () -> () -> ()
`seq` NumChannels -> ()
forall a. NFData a => a -> ()
rnf NumChannels
k () -> () -> ()
`seq` NumChannels -> ()
forall a. NFData a => a -> ()
rnf NumChannels
v () -> () -> ()
`seq` Time -> ()
forall a. NFData a => a -> ()
rnf Time
d


--------------------------------

 | NFData instances for Music |
--------------------------------


> instance NFData a => NFData (Music a) where
>     rnf :: Music a -> ()
rnf (Music a
a :+: Music a
b) = Music a -> ()
forall a. NFData a => a -> ()
rnf Music a
a () -> () -> ()
`seq` Music a -> ()
forall a. NFData a => a -> ()
rnf Music a
b
>     rnf (Music a
a :=: Music a
b) = Music a -> ()
forall a. NFData a => a -> ()
rnf Music a
a () -> () -> ()
`seq` Music a -> ()
forall a. NFData a => a -> ()
rnf Music a
b
>     rnf (Prim Primitive a
p) = Primitive a -> ()
forall a. NFData a => a -> ()
rnf Primitive a
p
>     rnf (Modify Control
c Music a
m) = Control -> ()
forall a. NFData a => a -> ()
rnf Control
c () -> () -> ()
`seq` Music a -> ()
forall a. NFData a => a -> ()
rnf Music a
m

> instance NFData a => NFData (Primitive a) where
>     rnf :: Primitive a -> ()
rnf (Note Rational
d a
a) = Rational -> ()
forall a. NFData a => a -> ()
rnf Rational
d () -> () -> ()
`seq` a -> ()
forall a. NFData a => a -> ()
rnf a
a
>     rnf (Rest Rational
d) = Rational -> ()
forall a. NFData a => a -> ()
rnf Rational
d

> instance NFData Control where
>     rnf :: Control -> ()
rnf (Tempo Rational
t) = Rational -> ()
forall a. NFData a => a -> ()
rnf Rational
t
>     rnf (Transpose NumChannels
t) = NumChannels -> ()
forall a. NFData a => a -> ()
rnf NumChannels
t
>     rnf (Instrument InstrumentName
i) = InstrumentName -> ()
forall a. NFData a => a -> ()
rnf InstrumentName
i
>     rnf (Phrase [PhraseAttribute]
xs) = [PhraseAttribute] -> ()
forall a. NFData a => a -> ()
rnf [PhraseAttribute]
xs
>     rnf (Custom [Char]
s) = [Char] -> ()
forall a. NFData a => a -> ()
rnf [Char]
s
>     rnf (KeySig PitchClass
r Mode
m) = PitchClass -> ()
forall a. NFData a => a -> ()
rnf PitchClass
r () -> () -> ()
`seq` Mode -> ()
forall a. NFData a => a -> ()
rnf Mode
m

> instance NFData PitchClass where
>     rnf :: PitchClass -> ()
rnf PitchClass
p = ()

> instance NFData Mode where
>     rnf :: Mode -> ()
rnf Mode
x = ()

> instance NFData PhraseAttribute where
>     rnf :: PhraseAttribute -> ()
rnf (Dyn Dynamic
d) = Dynamic -> ()
forall a. NFData a => a -> ()
rnf Dynamic
d
>     rnf (Tmp Tempo
t) = Tempo -> ()
forall a. NFData a => a -> ()
rnf Tempo
t
>     rnf (Art Articulation
a) = Articulation -> ()
forall a. NFData a => a -> ()
rnf Articulation
a
>     rnf (Orn Ornament
o) = Ornament -> ()
forall a. NFData a => a -> ()
rnf Ornament
o

> instance NFData Dynamic where
>     rnf :: Dynamic -> ()
rnf (Accent Rational
r) = Rational -> ()
forall a. NFData a => a -> ()
rnf Rational
r
>     rnf (Crescendo Rational
r) = Rational -> ()
forall a. NFData a => a -> ()
rnf Rational
r
>     rnf (Diminuendo Rational
r) = Rational -> ()
forall a. NFData a => a -> ()
rnf Rational
r
>     rnf (StdLoudness StdLoudness
x) = StdLoudness -> ()
forall a. NFData a => a -> ()
rnf StdLoudness
x
>     rnf (Loudness Rational
r) = Rational -> ()
forall a. NFData a => a -> ()
rnf Rational
r

> instance NFData StdLoudness where
>     rnf :: StdLoudness -> ()
rnf StdLoudness
x = ()

> instance NFData Articulation where
>     rnf :: Articulation -> ()
rnf (Staccato Rational
r) = Rational -> ()
forall a. NFData a => a -> ()
rnf Rational
r
>     rnf (Legato Rational
r) = Rational -> ()
forall a. NFData a => a -> ()
rnf Rational
r
>     rnf Articulation
x = ()

> instance NFData Ornament where
>     rnf :: Ornament -> ()
rnf Ornament
x = ()

> instance NFData Tempo where
>     rnf :: Tempo -> ()
rnf (Ritardando Rational
r) = Rational -> ()
forall a. NFData a => a -> ()
rnf Rational
r
>     rnf (Accelerando Rational
r) = Rational -> ()
forall a. NFData a => a -> ()
rnf Rational
r

> instance NFData InstrumentName where
>     rnf :: InstrumentName -> ()
rnf InstrumentName
x = ()

> instance NFData NoteAttribute where
>     rnf :: NoteAttribute -> ()
rnf (Volume NumChannels
v) = NumChannels -> ()
forall a. NFData a => a -> ()
rnf NumChannels
v
>     rnf (Fingering Integer
f) = Integer -> ()
forall a. NFData a => a -> ()
rnf Integer
f
>     rnf (Dynamics [Char]
d) = [Char] -> ()
forall a. NFData a => a -> ()
rnf [Char]
d
>     rnf (Params [Time]
p) = [Time] -> ()
forall a. NFData a => a -> ()
rnf [Time]
p