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


> upmLookup :: UserPatchMap  -> InstrumentName 
>                            -> (Channel, ProgNum)
> upmLookup :: UserPatchMap -> InstrumentName -> (Ticks, Ticks)
upmLookup UserPatchMap
upm InstrumentName
iName = (Ticks
chan, InstrumentName -> Ticks
toGM InstrumentName
iName)
>   where chan :: Ticks
chan = Ticks -> (Ticks -> Ticks) -> Maybe Ticks -> Ticks
forall b a. b -> (a -> b) -> Maybe a -> b
maybe  ([Char] -> Ticks
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")  )
>                       Ticks -> Ticks
forall a. a -> a
id (InstrumentName -> UserPatchMap -> Maybe Ticks
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 Ticks] -> Midi
Midi  (if [(InstrumentName, [MEvent])] -> Ticks
forall a. [a] -> Ticks
forall (t :: * -> *) a. Foldable t => t a -> Ticks
length [(InstrumentName, [MEvent])]
split Ticks -> Ticks -> Bool
forall a. Eq a => a -> a -> Bool
== Ticks
1  then FileType
SingleTrack 
>                                    else FileType
MultiTrack)
>             (Ticks -> TimeDiv
TicksPerBeat Ticks
division)
>             (((InstrumentName, [MEvent]) -> Track Ticks)
-> [(InstrumentName, [MEvent])] -> [Track Ticks]
forall a b. (a -> b) -> [a] -> [b]
map (Track Ticks -> Track Ticks
forall a. Num a => Track a -> Track a
fromAbsTime (Track Ticks -> Track Ticks)
-> ((InstrumentName, [MEvent]) -> Track Ticks)
-> (InstrumentName, [MEvent])
-> Track Ticks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserPatchMap -> (InstrumentName, [MEvent]) -> Track Ticks
mevsToMessages UserPatchMap
rightMap) [(InstrumentName, [MEvent])]
split)

> division :: Ticks
division = Ticks
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, Ticks) -> 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, Ticks) -> InstrumentName)
-> (InstrumentName, Ticks)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InstrumentName, Ticks) -> 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. HasCallStack => [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 :: Ticks
defST = Ticks
500000

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

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

> toDelta :: a -> b
toDelta a
t = a -> b
forall b. Integral b => 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
* Ticks -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Ticks
division)

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

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



> writeMidi :: ToMusic1 a => FilePath -> Music a -> IO ()
> writeMidi :: forall a. ToMusic1 a => [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 ()