ToMidi2: a module for allowing multiple tracks with the same GM instrument.
Author: Donya Quick

The writeMidi2 function allows use of the CustomInstrument constructor
in a very specific way to permit two tracks that have the same instrument.
The expected format is:

CustomInstrument "GMInstrumentName UniqueIdentifier"

For example:

 import Euterpea
 import Euterpea.IO.MIDI.ToMidi2
 m = instrument (CustomInstrument "Flute A") (c 4 qn :+: d 4 qn) :=:
     instrument (CustomInstrument "Flute B") (c 5 qn) :=:
     instrument HonkyTonkPiano (rest hn :+: c 4 hn)
 main = writeMidi2 "test.mid" m

This will create a MIDI file with three tracks, two of which are assigned
the Flute instrument and the third with the HonkyTonkPiano instrument.

Note: this module does NOT allow specification of particular track numbers.
The order in which the tracks appear in the MIDI file is determined by the
structure of the particular Music value.

> module Euterpea.IO.MIDI.ToMidi2 (writeMidi2, resolveInstrumentName) where
> import Euterpea.IO.MIDI.ToMidi
> import Euterpea.IO.MIDI.GeneralMidi
> import Euterpea.IO.MIDI.MEvent
> import Euterpea.Music
> import Euterpea.IO.MIDI.ExportMidiFile
> import Data.List
> import Codec.Midi

> instNameOnly :: String -> String
> instNameOnly :: String -> String
instNameOnly [] = []
> instNameOnly (Char
x:String
xs) = if Char
xChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
' ' then [] else Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
instNameOnly String
xs

> resolveInstrumentName :: InstrumentName -> InstrumentName
> resolveInstrumentName :: InstrumentName -> InstrumentName
resolveInstrumentName x :: InstrumentName
x@(CustomInstrument String
s) =
>     let iName :: String
iName = String -> String
instNameOnly String
s
>         allInsts :: [InstrumentName]
allInsts = Int -> [InstrumentName] -> [InstrumentName]
forall a. Int -> [a] -> [a]
take Int
128 ([InstrumentName] -> [InstrumentName])
-> [InstrumentName] -> [InstrumentName]
forall a b. (a -> b) -> a -> b
$ InstrumentName -> [InstrumentName]
forall a. Enum a => a -> [a]
enumFrom InstrumentName
AcousticGrandPiano
>         i :: Int
i = Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (-Int
1) Int -> Int
forall a. a -> a
id (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
iName) ([String] -> Maybe Int) -> [String] -> Maybe Int
forall a b. (a -> b) -> a -> b
$ (InstrumentName -> String) -> [InstrumentName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map InstrumentName -> String
forall a. Show a => a -> String
show ([InstrumentName] -> [String]) -> [InstrumentName] -> [String]
forall a b. (a -> b) -> a -> b
$ [InstrumentName]
allInsts
>     in  if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 then [InstrumentName]
allInsts [InstrumentName] -> Int -> InstrumentName
forall a. HasCallStack => [a] -> Int -> a
!! Int
i else InstrumentName
x
> resolveInstrumentName InstrumentName
x = InstrumentName
x

> resolveMEventInsts :: [(InstrumentName, [MEvent])] -> [(InstrumentName, [MEvent])]
> resolveMEventInsts :: [(InstrumentName, [MEvent])] -> [(InstrumentName, [MEvent])]
resolveMEventInsts = ((InstrumentName, [MEvent]) -> (InstrumentName, [MEvent]))
-> [(InstrumentName, [MEvent])] -> [(InstrumentName, [MEvent])]
forall a b. (a -> b) -> [a] -> [b]
map (InstrumentName, [MEvent]) -> (InstrumentName, [MEvent])
f1 where
>     f1 :: (InstrumentName, [MEvent]) -> (InstrumentName, [MEvent])
f1 (InstrumentName
iname, [MEvent]
mevs) = (InstrumentName -> InstrumentName
resolveInstrumentName InstrumentName
iname, (MEvent -> MEvent) -> [MEvent] -> [MEvent]
forall a b. (a -> b) -> [a] -> [b]
map MEvent -> MEvent
f2 [MEvent]
mevs)
>     f2 :: MEvent -> MEvent
f2 MEvent
mev = MEvent
mev{eInst = resolveInstrumentName (eInst mev)}


> writeMidi2 :: ToMusic1 a => FilePath -> Music a -> IO ()
> writeMidi2 :: forall a. ToMusic1 a => String -> Music a -> IO ()
writeMidi2 String
fn Music a
m = String -> Midi -> IO ()
exportMidiFile String
fn (Midi -> IO ()) -> Midi -> IO ()
forall a b. (a -> b) -> a -> b
$ UserPatchMap -> [MEvent] -> Midi
toMidiUPM2 UserPatchMap
defUpm ([MEvent] -> Midi) -> [MEvent] -> Midi
forall a b. (a -> b) -> a -> b
$ Music a -> [MEvent]
forall a. ToMusic1 a => Music a -> [MEvent]
perform Music a
m

> toMidiUPM2 :: UserPatchMap -> [MEvent] -> Midi
> toMidiUPM2 :: UserPatchMap -> [MEvent] -> Midi
toMidiUPM2 UserPatchMap
upm [MEvent]
pf =
>    let split :: [(InstrumentName, [MEvent])]
split     = [(InstrumentName, [MEvent])] -> [(InstrumentName, [MEvent])]
resolveMEventInsts ([(InstrumentName, [MEvent])] -> [(InstrumentName, [MEvent])])
-> [(InstrumentName, [MEvent])] -> [(InstrumentName, [MEvent])]
forall a b. (a -> b) -> a -> b
$ [MEvent] -> [(InstrumentName, [MEvent])]
splitByInst [MEvent]
pf
>        insts :: [InstrumentName]
insts     = ((InstrumentName, [MEvent]) -> InstrumentName)
-> [(InstrumentName, [MEvent])] -> [InstrumentName]
forall a b. (a -> b) -> [a] -> [b]
map (InstrumentName, [MEvent]) -> InstrumentName
forall a b. (a, b) -> a
fst [(InstrumentName, [MEvent])]
split
>        rightMap :: UserPatchMap
rightMap  =  if (UserPatchMap -> [InstrumentName] -> Bool
allValid UserPatchMap
upm [InstrumentName]
insts) then UserPatchMap
upm
>                     else ([InstrumentName] -> UserPatchMap
makeGMMap [InstrumentName]
insts)
>    in FileType -> TimeDiv -> [Track Int] -> Midi
Midi  (if [(InstrumentName, [MEvent])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(InstrumentName, [MEvent])]
split Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1  then FileType
SingleTrack
>                                    else FileType
MultiTrack)
>             (Int -> TimeDiv
TicksPerBeat Int
division)
>             (((InstrumentName, [MEvent]) -> Track Int)
-> [(InstrumentName, [MEvent])] -> [Track Int]
forall a b. (a -> b) -> [a] -> [b]
map (Track Int -> Track Int
forall a. Num a => Track a -> Track a
fromAbsTime (Track Int -> Track Int)
-> ((InstrumentName, [MEvent]) -> Track Int)
-> (InstrumentName, [MEvent])
-> Track Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserPatchMap -> (InstrumentName, [MEvent]) -> Track Int
mevsToMessages UserPatchMap
rightMap) [(InstrumentName, [MEvent])]
split)