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)