> {-# LINE 8 "ToMidi.lhs" #-}

> module Euterpea.IO.MIDI.ToMidi where

> import Euterpea.Music
> import Euterpea.IO.MIDI.MEvent
> import Euterpea.IO.MIDI.GeneralMidi
> import Euterpea.IO.MIDI.MidiIO
> import Euterpea.IO.MIDI.ExportMidiFile
> import Sound.PortMidi
> import Data.List(partition)
> import Data.Char(toLower,toUpper)
> import Codec.Midi

> type ProgNum     = Int

> type UserPatchMap = [(InstrumentName, Channel)]

> makeGMMap :: [InstrumentName] -> UserPatchMap
> makeGMMap :: [InstrumentName] -> UserPatchMap
makeGMMap [InstrumentName]
ins = Int -> [InstrumentName] -> UserPatchMap
mkGMMap Int
0 [InstrumentName]
ins
>   where mkGMMap :: Int -> [InstrumentName] -> UserPatchMap
mkGMMap Int
_ []        = []
>         mkGMMap Int
n [InstrumentName]
_ | Int
nInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>=Int
15 = 
>                   [Char] -> UserPatchMap
forall a. HasCallStack => [Char] -> a
error [Char]
"makeGMMap: too many instruments."
>         mkGMMap Int
n (InstrumentName
Percussion : [InstrumentName]
ins)    = 
>                   (InstrumentName
Percussion, Int
9) (InstrumentName, Int) -> UserPatchMap -> UserPatchMap
forall a. a -> [a] -> [a]
: Int -> [InstrumentName] -> UserPatchMap
mkGMMap Int
n [InstrumentName]
ins
>         mkGMMap Int
n (InstrumentName
i : [InstrumentName]
ins) = 
>                   (InstrumentName
i, [Int]
chanList [Int] -> Int -> Int
forall a. [a] -> Int -> a
!! Int
n) (InstrumentName, Int) -> UserPatchMap -> UserPatchMap
forall a. a -> [a] -> [a]
: Int -> [InstrumentName] -> UserPatchMap
mkGMMap (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [InstrumentName]
ins
>         chanList :: [Int]
chanList = [Int
0..Int
8] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
10..Int
15]  --  channel 9 is for percussion


> upmLookup :: UserPatchMap  -> InstrumentName 
>                            -> (Channel, ProgNum)
> upmLookup :: UserPatchMap -> InstrumentName -> (Int, Int)
upmLookup UserPatchMap
upm InstrumentName
iName = (Int
chan, InstrumentName -> Int
toGM InstrumentName
iName)
>   where chan :: Int
chan = Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe  ([Char] -> Int
forall a. HasCallStack => [Char] -> a
error (  [Char]
"instrument " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ InstrumentName -> [Char]
forall a. Show a => a -> [Char]
show InstrumentName
iName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ 
>                                 [Char]
" not in patch map")  )
>                       Int -> Int
forall a. a -> a
id (InstrumentName -> UserPatchMap -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup InstrumentName
iName UserPatchMap
upm)

> toMidi :: [MEvent] -> Midi
> toMidi :: [MEvent] -> Midi
toMidi = UserPatchMap -> [MEvent] -> Midi
toMidiUPM UserPatchMap
defUpm

> toMidiUPM :: UserPatchMap -> [MEvent] -> Midi
> toMidiUPM :: UserPatchMap -> [MEvent] -> Midi
toMidiUPM UserPatchMap
upm [MEvent]
pf =
>    let split :: [(InstrumentName, [MEvent])]
split     = [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 (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)

> division :: Int
division = Int
96 :: Int

> allValid :: UserPatchMap -> [InstrumentName] -> Bool
> allValid :: UserPatchMap -> [InstrumentName] -> Bool
allValid UserPatchMap
upm = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool)
-> ([InstrumentName] -> [Bool]) -> [InstrumentName] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InstrumentName -> Bool) -> [InstrumentName] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (UserPatchMap -> InstrumentName -> Bool
lookupB UserPatchMap
upm)

> lookupB :: UserPatchMap -> InstrumentName -> Bool
> lookupB :: UserPatchMap -> InstrumentName -> Bool
lookupB UserPatchMap
upm InstrumentName
x = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or (((InstrumentName, Int) -> Bool) -> UserPatchMap -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map ((InstrumentName -> InstrumentName -> Bool
forall a. Eq a => a -> a -> Bool
== InstrumentName
x) (InstrumentName -> Bool)
-> ((InstrumentName, Int) -> InstrumentName)
-> (InstrumentName, Int)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InstrumentName, Int) -> InstrumentName
forall a b. (a, b) -> a
fst) UserPatchMap
upm)

> splitByInst :: [MEvent] ->  [(InstrumentName, [MEvent])]
> splitByInst :: [MEvent] -> [(InstrumentName, [MEvent])]
splitByInst [] = []
> splitByInst [MEvent]
pf = (InstrumentName
i, [MEvent]
pf1) (InstrumentName, [MEvent])
-> [(InstrumentName, [MEvent])] -> [(InstrumentName, [MEvent])]
forall a. a -> [a] -> [a]
: [MEvent] -> [(InstrumentName, [MEvent])]
splitByInst [MEvent]
pf2
>        where i :: InstrumentName
i          = MEvent -> InstrumentName
eInst ([MEvent] -> MEvent
forall a. [a] -> a
head [MEvent]
pf)
>              ([MEvent]
pf1, [MEvent]
pf2) = (MEvent -> Bool) -> [MEvent] -> ([MEvent], [MEvent])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\MEvent
e -> MEvent -> InstrumentName
eInst MEvent
e InstrumentName -> InstrumentName -> Bool
forall a. Eq a => a -> a -> Bool
== InstrumentName
i) [MEvent]
pf

> type MidiEvent = (Ticks, Message)

> defST :: Int
defST = Int
500000

> mevsToMessages ::  UserPatchMap
>                   -> (InstrumentName, [MEvent]) 
>                   -> [MidiEvent]
> mevsToMessages :: UserPatchMap -> (InstrumentName, [MEvent]) -> Track Int
mevsToMessages UserPatchMap
upm (InstrumentName
inm, [MEvent]
pf) =
>   let  (Int
chan,Int
progNum)   = UserPatchMap -> InstrumentName -> (Int, Int)
upmLookup UserPatchMap
upm InstrumentName
inm
>        setupInst :: (Int, Message)
setupInst        = (Int
0, Int -> Int -> Message
ProgramChange Int
chan Int
progNum)
>        setTempo :: (Int, Message)
setTempo         = (Int
0, Int -> Message
TempoChange Int
defST)
>        loop :: [MEvent] -> Track Int
loop []      =  []
>        loop (MEvent
e:[MEvent]
es)  =  let ((Int, Message)
mev1,(Int, Message)
mev2) = Int -> MEvent -> ((Int, Message), (Int, Message))
mkMEvents Int
chan MEvent
e
>                        in (Int, Message)
mev1 (Int, Message) -> Track Int -> Track Int
forall a. a -> [a] -> [a]
: (Int, Message) -> Track Int -> Track Int
insertMEvent (Int, Message)
mev2 ([MEvent] -> Track Int
loop [MEvent]
es)
>   in (Int, Message)
setupInst (Int, Message) -> Track Int -> Track Int
forall a. a -> [a] -> [a]
: (Int, Message)
setTempo (Int, Message) -> Track Int -> Track Int
forall a. a -> [a] -> [a]
: [MEvent] -> Track Int
loop [MEvent]
pf

  
> mkMEvents :: Channel -> MEvent -> (MidiEvent,MidiEvent)
> mkMEvents :: Int -> MEvent -> ((Int, Message), (Int, Message))
mkMEvents  Int
mChan (MEvent {  eTime :: MEvent -> PTime
eTime = PTime
t, ePitch :: MEvent -> Int
ePitch = Int
p, 
>                            eDur :: MEvent -> PTime
eDur = PTime
d, eVol :: MEvent -> Int
eVol = Int
v})
>                   = (  (PTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
toDelta PTime
t, Int -> Int -> Int -> Message
NoteOn  Int
mChan Int
p Int
v'),
>                        (PTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
toDelta (PTime
tPTime -> PTime -> PTime
forall a. Num a => a -> a -> a
+PTime
d), Int -> Int -> Int -> Message
NoteOff Int
mChan Int
p Int
v') )
>            where v' :: Int
v' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
127 (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v))

> toDelta :: a -> b
toDelta a
t = a -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (a
t a -> a -> a
forall a. Num a => a -> a -> a
* a
2.0 a -> a -> a
forall a. Num a => a -> a -> a
* Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
division)

> insertMEvent :: MidiEvent -> [MidiEvent] -> [MidiEvent]
> insertMEvent :: (Int, Message) -> Track Int -> Track Int
insertMEvent (Int, Message)
mev1  []         = [(Int, Message)
mev1]
> insertMEvent mev1 :: (Int, Message)
mev1@(Int
t1,Message
_) mevs :: Track Int
mevs@(mev2 :: (Int, Message)
mev2@(Int
t2,Message
_):Track Int
mevs') = 
>       if Int
t1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
t2 then (Int, Message)
mev1 (Int, Message) -> Track Int -> Track Int
forall a. a -> [a] -> [a]
: Track Int
mevs
>                   else (Int, Message)
mev2 (Int, Message) -> Track Int -> Track Int
forall a. a -> [a] -> [a]
: (Int, Message) -> Track Int -> Track Int
insertMEvent (Int, Message)
mev1 Track Int
mevs'

> defUpm :: UserPatchMap
> defUpm :: UserPatchMap
defUpm = [(InstrumentName
AcousticGrandPiano,Int
0),
>           (InstrumentName
Marimba,Int
1),
>           (InstrumentName
Vibraphone,Int
2),
>           (InstrumentName
AcousticBass,Int
3),
>           (InstrumentName
Flute,Int
4),
>           (InstrumentName
TenorSax,Int
5),
>           (InstrumentName
AcousticGuitarSteel,Int
6),
>           (InstrumentName
Viola,Int
7),
>           (InstrumentName
StringEnsemble1,Int
8),
>           (InstrumentName
AcousticGrandPiano,Int
9)]
>            --  the GM name for drums is unimportant, only channel 9



> writeMidi :: ToMusic1 a => FilePath -> Music a -> IO ()
> writeMidi :: [Char] -> Music a -> IO ()
writeMidi [Char]
fn Music a
m = [Char] -> Midi -> IO ()
exportMidiFile [Char]
fn (Midi -> IO ()) -> Midi -> IO ()
forall a b. (a -> b) -> a -> b
$ [MEvent] -> Midi
toMidi ([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

 play :: ToMusic1 a => Music a -> IO ()
 play = playM . toMidi . perform

 playM :: Midi -> IO ()
 playM midi = do
   initialize
   (defaultOutput playMidi) midi 
   terminate
   return ()