module Mezzo.Render.MIDI
( MidiNote (..), Score, (><)
, renderScore, renderScores, withMusic, defScore, playLive, playLive' )
where
import Mezzo.Model
import Mezzo.Compose (_th, _si, _ei, _qu, _ha, _wh)
import Mezzo.Render.Score
import Mezzo.Compose.Builder
import Codec.Midi hiding (key, Key)
import qualified Codec.Midi as CM (key, Key)
import Euterpea.IO.MIDI.Play (playM')
import Euterpea.IO.MIDI.MidiIO (unsafeOutputID)
import Prelude hiding (min)
data MidiNote = MidiNote
{ noteNum :: Int
, vel :: Velocity
, startT :: Ticks
, noteDur :: Ticks
} deriving Show
type MidiEvent = (Ticks, Message)
type MidiTrack = Track Ticks
type Score = MidiTrack
midiNote :: Int -> Ticks -> MidiNote
midiNote root dur = MidiNote {noteNum = root, vel = 100, startT = 0, noteDur = dur}
midiRest :: Ticks -> MidiNote
midiRest dur = MidiNote {noteNum = 0, vel = 0, startT = 0, noteDur = dur}
keyDown :: MidiNote -> MidiEvent
keyDown n = (startT n, NoteOn {channel = 0, CM.key = noteNum n, velocity = vel n})
keyUp :: MidiNote -> MidiEvent
keyUp n = (startT n + noteDur n, NoteOn {channel = 0, CM.key = noteNum n, velocity = 0})
playNote :: Int -> Ticks -> MidiTrack
playNote root dur = map ($ midiNote root (dur * 60)) [keyDown, keyUp]
playRest :: Ticks -> MidiTrack
playRest dur = map ($ midiRest (dur * 60)) [keyDown, keyUp]
playTriplet :: [Int] -> Ticks -> MidiTrack
playTriplet ts dur = concatMap playShortNote ts
where playShortNote root = map ($ midiNote root (dur * 40)) [keyDown, keyUp]
(><) :: MidiTrack -> MidiTrack -> MidiTrack
m1 >< m2 = removeTrackEnds $ m1 `merge` m2
type Title = String
musicToMidi :: forall t k m r. Music (Sig :: Signature t k r) m -> Score
musicToMidi (m1 :|: m2) = musicToMidi m1 ++ musicToMidi m2
musicToMidi (m1 :-: m2) = musicToMidi m1 >< musicToMidi m2
musicToMidi (Note root dur) = playNote (prim root) (prim dur)
musicToMidi (Rest dur) = playRest (prim dur)
musicToMidi (Chord c d) = foldr1 (><) notes
where notes = map (`playNote` prim d) $ prim c
musicToMidi (Progression p) = foldr1 (++) chords
where chords = (toChords <$> init (prim p)) ++ [cadence (last (prim p))]
toChords :: [Int] -> Score
toChords = concat . replicate (prim (TimeSig @t)) . foldr1 (><) . map (`playNote` prim _qu)
cadence :: [Int] -> Score
cadence = foldr1 (><) . map (`playNote` prim _wh)
musicToMidi (Homophony m a) = musicToMidi m >< musicToMidi a
musicToMidi (Triplet d r1 r2 r3) = playTriplet [prim r1, prim r2, prim r3] (prim d)
withMusic :: ATerm (Music (Sig :: Signature t k r) m) (Attributes t k r) Score
withMusic atts m = [ (0, getTimeSig atts)
, (0, getKeySig atts)
, (0, TempoChange (60000000 `div` tempo atts))
] ++ musicToMidi m
defScore :: Music (Sig :: Signature 4 (Key C Natural MajorMode) Classical) m -> Score
defScore = score withMusic
midiSkeleton :: Title -> Score -> Midi
midiSkeleton trName mel = Midi
{ fileType = SingleTrack
, timeDiv = TicksPerBeat 480
, tracks =
[ [ (0, ChannelPrefix 0)
, (0, TrackName trName)
, (0, InstrumentName "GM Device 1")
]
++ mel
++ [ (0, TrackEnd) ]
]
}
exportMidi :: FilePath -> Title -> Score -> IO ()
exportMidi f trName notes = do
exportFile f $ midiSkeleton trName notes
putStrLn $ "Composition rendered to " ++ f ++ "."
renderScore :: FilePath -> Title -> Score -> IO ()
renderScore f compTitle sc = exportMidi f compTitle sc
renderScores :: FilePath -> Title -> [Score] -> IO ()
renderScores f compTitle ts = renderScore f compTitle (concat ts)
playLive' :: Score -> IO ()
playLive' s = playM' (Just $ unsafeOutputID 0) $ midiSkeleton "Live playback" s
playLive :: Music (Sig :: Signature 4 (Key C Natural MajorMode) Classical) m
-> IO ()
playLive m = playLive' (defScore m)