module Fadno.Midi where
import Sound.MIDI.File as MFile
import Data.EventList.Relative.TimeBody as EList hiding (concat,traverse)
import Sound.MIDI.File.Event as MEvent
import Sound.MIDI.File.Event.Meta as MMeta
import Sound.MIDI.Message.Channel as MChan
import Sound.MIDI.Message.Channel.Voice as MVoice
import Sound.MIDI.File.Load
import Sound.MIDI.File.Save
import Sound.MIDI.General
import Fadno.Note
import Data.List (mapAccumL)
import Control.Lens
import Control.Arrow
import System.Process
import Control.Monad
import Data.Ratio
type MidiData = MFile.T
type IPitch = Int
type IDur = Int
class MidiNotes a where
toMidiNotes :: a -> [([IPitch],IDur)]
instance MidiNotes [([IPitch],IDur)] where toMidiNotes = id
instance (Integral p, Traversable c, Integral d, Traversable t) => MidiNotes (t (Note (c p) d)) where
toMidiNotes = map ((map fromIntegral . toListOf traverse) *** fromIntegral) .
toListOf (traverse.toPair)
instance (Integral p, Integral d, Traversable t) => MidiNotes (t (Note p d)) where
toMidiNotes = map (return.fromIntegral *** fromIntegral) . toListOf (traverse.toPair)
newtype MidiTempo = MidiTempo Int
deriving (Eq,Show,Enum,Bounded,Ord,Num,Real,Integral)
newtype MidiChan = MidiChan Int
deriving (Eq,Show,Enum,Bounded,Ord,Num,Real,Integral)
newtype MidiVelocity = MidiVelocity Int
deriving (Eq,Show,Enum,Bounded,Ord,Num,Real,Integral)
newtype MidiProgram = MidiProgram Int
deriving (Eq,Show,Enum,Bounded,Ord,Num,Real,Integral)
newtype MidiTicks = MidiTicks Int
deriving (Eq,Show,Enum,Bounded,Ord,Num,Real,Integral)
toTicks :: MidiTicks -> Iso' Rational IDur
toTicks t = iso to' from' where
to' = truncate . (* fromIntegral (t*4))
from' = (% fromIntegral (t*4)) . fromIntegral
data MidiEvent = Pad IDur | Event MEvent.T
type MidiTrack = Track
writeMidiFile :: FilePath -> MidiData -> IO ()
writeMidiFile = toFile
showMidiFile :: FilePath -> IO ()
showMidiFile = showFile
midi :: MidiTicks -> [MidiTrack] -> MidiData
midi ticks = MFile.Cons Parallel (Ticks (toTempo $ fromIntegral ticks))
makeTrackFull
:: (MidiNotes notes) =>
MidiTempo
-> MidiChan
-> MidiProgram
-> MidiVelocity
-> notes
-> MidiTrack
makeTrackFull tempo chan prog vel notes =
makeTrack $ setTempo tempo:
programChange chan prog:
toNoteEvents chan vel notes
fromBPM :: (Real a, Show a) => a -> MidiTempo
fromBPM b | b > 0 = floor (60 * 1000000 / toRational b)
| otherwise = error $ "fromBPM: must be > 0: " ++ show b
fromInstrument :: Instrument -> MidiProgram
fromInstrument = fromIntegral . fromEnum
makeTrack :: [MidiEvent] -> MidiTrack
makeTrack = fromPairList . concat . snd . mapAccumL conv 0
where conv :: IDur -> MidiEvent -> (IDur,[(ElapsedTime,MEvent.T)])
conv _ (Pad dur) = (dur,[])
conv off (Event e) = (0,[(toElapsedTime $ fromIntegral off,e)])
toNoteEvents :: MidiNotes notes => MidiChan -> MidiVelocity -> notes -> [MidiEvent]
toNoteEvents chan vel = concatMap (noteEvents chan vel) . toMidiNotes
voiceEvent :: MidiChan -> MVoice.T -> MidiEvent
voiceEvent chan = midiEvent chan . Voice
setTempo :: MidiTempo -> MidiEvent
setTempo = metaEvent . SetTempo . toTempo . fromIntegral
metaEvent :: MMeta.T -> MidiEvent
metaEvent = Event . MetaEvent
midiEvent :: MidiChan -> MChan.Body -> MidiEvent
midiEvent chan = Event . MIDIEvent . MChan.Cons (toChannel $ fromIntegral chan)
programChange :: MidiChan -> MidiProgram -> MidiEvent
programChange chan prog = voiceEvent chan (ProgramChange (toProgram $ fromIntegral prog))
noteEvents :: MidiChan -> MidiVelocity -> ([IPitch],IDur) -> [MidiEvent]
noteEvents chan vel (ps,dur) = evs noteOn ++ [Pad dur] ++ evs noteOff
where evs f = map (f chan vel . fromIntegral) ps
noteEvent :: (Pitch -> Velocity -> MVoice.T) ->
MidiChan -> MidiVelocity -> IPitch -> MidiEvent
noteEvent f chan vel pitch = voiceEvent chan
(f (toPitch (fromIntegral pitch))
(toVelocity $ fromIntegral vel))
noteOn :: MidiChan -> MidiVelocity -> IPitch -> MidiEvent
noteOn = noteEvent NoteOn
noteOff :: MidiChan -> MidiVelocity -> IPitch -> MidiEvent
noteOff = noteEvent NoteOff
test1 :: IO ()
test1 = playMidi "/tmp/first.midi" 120 [(AcousticGrandPiano,
map (uncurry Note)
[([60 :: Int],48 :: Int),([61],48),([62],24),([64],64),
([],96),([60,66],96)])]
playMidi :: MidiNotes n => FilePath -> Int -> [(Instrument,n)] -> IO ()
playMidi file bpm tracks = do
writeMidiFile file $ midi 96 $ map (\(inst,notes) -> makeTrackFull (fromBPM bpm) 0 (fromInstrument inst) 127 notes) tracks
void $ createProcess (shell $ "scripts/qt7play.applescript " ++ file)