module Temporal.Music.Notation.Demo(
MidiEvent,
instr, drumInstr,
renderMidi, FilePath, exportMidi)
where
import Data.List(sortBy, partition)
import Data.Function(on)
import Data.Word
import Data.Binary
import Data.Binary.Put
import Foreign.C.Math.Double(log10)
import Codec.Midi hiding (Time)
import Temporal.Music.Notation
import Temporal.Music.Notation.Note
log2 :: Double -> Double
log2 x = log10 x / log10 2
logB :: Double -> Double -> Double
logB b x = log10 x / log10 b
type Instr = Int
type VolumeId = Int
type PitchId = (Int, Bend)
data MidiEvent = forall nVol nPch . (
Seg nVol, Seg nPch) => MidiEvent
{ meventInstr :: Instr
, meventVol :: Volume nVol
, meventPch :: Maybe (Pitch nPch)
}
data LowMidiEvent = LowMidiEvent
{ lmeventVol :: VolumeId
, lmeventPch :: PitchId
}
instance LevelFunctor MidiEvent where
mapLevel f (MidiEvent i v p) = MidiEvent i (mapLevel f v) p
instance VolumeFunctor MidiEvent where
mapVolume f (MidiEvent i v p) = MidiEvent i (mapVolume f v) p
instance ToneFunctor MidiEvent where
mapTone f (MidiEvent i v p) = MidiEvent i v (fmap (mapTone f) p)
instance PitchFunctor MidiEvent where
mapPitch f (MidiEvent i v p) = MidiEvent i v (fmap (mapPitch f) p)
instr :: (Seg nVol, Seg nPch) =>
Preset -> Score (Note nVol nPch a) -> Score MidiEvent
instr id = fmap $ \(Note v p a) -> MidiEvent id v (Just p)
drumInstr :: Seg nVol =>
Key -> Score (Drum nVol a) -> Score MidiEvent
drumInstr id = fmap $ \(Drum v a) -> MidiEvent id v drumPch
drumPch :: Maybe (Pitch DrumPitch)
drumPch = Nothing
data DrumPitch = DrumPitch
deriving (Enum, Bounded)
instance Seg DrumPitch
exportMidi :: FilePath -> Score MidiEvent -> IO ()
exportMidi file sco = exportFile file $ renderMidi sco
renderMidi :: Score MidiEvent -> Midi
renderMidi = render' . renderScore
render' :: EventList Dur MidiEvent -> Midi
render' (EventList totalDur xs) = setMidi tracks
where td = totalDiapason $ map eventContent xs
tracks = map (formTrack td totalDur) $
assignChannels $ groupByInstr xs
formTrack :: Diapason -> Dur
-> (Channel, (Maybe Instr, [Event Dur MidiEvent]))
-> Track Ticks
formTrack td d (ch, (i, es)) =
renderTrack d i ch $ fmap (fmap $ lowLevel td) $ sortEvents es
sortEvents :: Ord t => [Event t a] -> [Event t a]
sortEvents = sortBy (compare `on` eventStart)
setMidi :: [Track Ticks] -> Midi
setMidi = Midi MultiTrack (TicksPerBeat division)
assignChannels :: [(Maybe Instr, [Event Dur MidiEvent])]
-> [(Channel, (Maybe Instr, [Event Dur MidiEvent]))]
assignChannels xs = zip (assignIds xs') xs'
where xs' = sortBy (compare `on` fst) $ take 16 xs
assignIds = maybe drumIds (const noteIds) . fst . head
drumIds = 9 : [0 .. 8] ++ [10 .. 15]
noteIds = [0 .. 15]
groupByInstr :: [Event Dur MidiEvent]
-> [(Maybe Instr, [Event Dur MidiEvent])]
groupByInstr es =
case es of
[] -> []
x:xs ->
let (a, b) = partition ((instrId x == ) . instrId) xs
in (instrId x, x : a) : groupByInstr b
instrId :: Event Dur MidiEvent -> Maybe Instr
instrId x =
case eventContent x of
MidiEvent i _ p -> fmap (const i) p
defST :: Int
defST = 1000000
renderTrack :: Dur -> Maybe Instr -> Channel
-> [Event Dur LowMidiEvent] -> Track Ticks
renderTrack totalDur instr ch xs = sets ++ body
where sets = trackSettings instr ch
body = fromAbsTime $ trackBody ch xs
++ return (toTicks totalDur, TrackEnd)
trackSettings :: Maybe Instr -> Channel -> Track Ticks
trackSettings instr ch = tempo : program
where tempo = (0, TempoChange defST)
program = maybe []
(return . \x -> (0, ProgramChange ch x)) instr
trackBody :: Channel
-> [Event Dur LowMidiEvent] -> Track Ticks
trackBody ch es =
case es of
[] -> []
x:xs -> let (n, m) = toMessages ch $ eventContent x
tn = toTicks $ eventStart x
tm = toTicks $ eventStart x + eventDur x
xs' = insertNoteOff (tm, m) (trackBody ch xs)
in map (markTime tn) n ++ xs'
markTime :: t -> Message -> (t, Message)
markTime = (,)
insertNoteOff :: (Ticks, Message) -> Track Ticks -> Track Ticks
insertNoteOff a ms =
case ms of
[] -> [a]
x:xs -> if t a <= t x
then a:ms
else x:insertNoteOff a xs
where t = fst
toMessages :: Channel -> LowMidiEvent -> ([Message], Message)
toMessages ch x = toMessages' ch vel key tune
where key = fst $ lmeventPch x
vel = lmeventVol x
tune = uncurry tuneParams $ lmeventPch x
toMessages' :: Channel -> VolumeId -> Key -> Maybe TuneId
-> ([Message], Message)
toMessages' ch v p t = (tune ++ [NoteOn ch p v], NoteOff ch p 64)
where tune = maybe [] (return . tuneMessage) t
totalDiapason :: [MidiEvent] -> Diapason
totalDiapason = foldl1 merge . map diap
where diap (MidiEvent _ v _) = volumeDiapason v
merge (a, b) (a', b') = (min a a', max b b')
lowLevel :: Diapason -> MidiEvent -> LowMidiEvent
lowLevel diap (MidiEvent i v p) = LowMidiEvent vol pch
where vol = fitToMidiDiapason diap $ absVolume v
pch = maybe (i, 0) (midiPch . absPitch) p
fitToMidiDiapason :: Diapason -> Amplitude -> VolumeId
fitToMidiDiapason (a, b) x = round $ 127 * logB (b/a) (x/a)
midiPch :: Frequency -> PitchId
midiPch x = properFraction $ bound $ 69 + 12 * log2 (x/440)
where bound = max 0 . min 127
toTicks :: Time -> Ticks
toTicks = round . ( * division2)
division :: Ticks
division = 96
division2 :: Time
division2 = fromIntegral 96
type TuneId = (KeyId, Cents)
type KeyId = Word8
type Cent0 = Word8
type Cent1 = Word8
type Cents = (Cent0, Cent1)
tuneParams :: Int -> Double -> Maybe TuneId
tuneParams p d = Just (fromIntegral p, c)
where c = cents d
cents :: Double -> (Cent0, Cent1)
cents d = (fromIntegral c0, fromIntegral c1)
where (c0, c1) = flip divMod (128::Int) $
fst $ properFraction (d/deltaTune)
deltaTune :: Double
deltaTune = 0.000061
tuneMessage :: TuneId -> Message
tuneMessage (x, (a, b)) = Sysex 240 $
runPut $ do
putWord8 127
putWord8 0
putWord8 8
putWord8 2
putWord8 0
putWord8 1
putWord8 x
putWord8 x
putWord8 a
putWord8 b
putWord8 247