{-# LANGUAGE ExistentialQuantification #-}
-- | Library provides functions to render 'Score' made with
-- 'temporal-music-notation' library to midi file from 'HCodecs' package.
module Temporal.Music.Notation.Demo(
-- * Types
MidiEvent,
-- * Instruments
instr, drumInstr,
-- * Render
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
-- cmath
log2 :: Double -> Double
log2 x = log10 x / log10 2
logB :: Double -> Double -> Double
logB b x = log10 x / log10 b
-----------------------------------------------------------------
-- Types
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)
-----------------------------------------------------------------
-- instruments
-- | Apply midi instrument.
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)
-- | Apply midi drum instrument.
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
-----------------------------------------------------------------
-- interpretation
-- | Render 'Score' to midi file and save results in current
-- directory.
exportMidi :: FilePath -> Score MidiEvent -> IO ()
exportMidi file sco = exportFile file $ renderMidi sco
-- | Render to 'Midi'.
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 = (NoteOn ch key vel, NoteOff ch key 64)
where key = fst $ lmeventPch x
vel = lmeventVol x
-}
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)
{- logBase (b/a) (x/a) -}
midiPch :: Frequency -> PitchId
midiPch x = properFraction $ bound $ 69 + 12 * log2 (x/440)
{- logBase 2 (x / 440) -}
where bound = max 0 . min 127
toTicks :: Time -> Ticks
toTicks = round . ( * division2)
division :: Ticks
division = 96
division2 :: Time
division2 = fromIntegral 96
-----------------------------------------------------
-- Microsound
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)
-- | c == (0, 0) = Nothing
-- | otherwise = 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)
-- | 1 semitone / 2^14
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