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 Codec.Midi hiding (Time)
import Temporal.Music.Notation
import Temporal.Music.Notation.Note
log2 = logBase 2
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 = midiVol diap v
pch = maybe (i, 0) midiPch p
clipToMidi :: (Num a, Ord a) => a -> a
clipToMidi = min 127 . max 0
midiVol (a', b') (Volume (a, b) l) =
clipToMidi $ round $ (127 * ) $
x * logBase (b'/a') (b/a) + logBase (b'/a') (a/a')
where x = levelAsDoubleRel l
midiPch :: Seg s => Pitch s -> PitchId
midiPch (Pitch s t) = properFraction $ clipToMidi $
69 + 12 * (scaleStepFactor s n
+ scaleOctaveFactor s k + scaleBendFactor s n r)
where (d, r) = properFraction $ toneAsDouble t
(k, n) = divMod d $ scaleSize s
scaleStepFactor :: Scale -> Int -> Double
scaleStepFactor s n = log2 $ scaleStep s n * f0 / 440
where f0 = snd $ scaleBase s
scaleOctaveFactor :: Scale -> Int -> Double
scaleOctaveFactor s k
| abs (d 2) < 1e-9 = k'
| otherwise = k' * log2 d
where d = scaleOctave s
k' = fromIntegral k
scaleBendFactor :: Scale -> Int -> Double -> Double
scaleBendFactor s n x
| abs x < 1e-9 = 0
| x > 0 = x * log2 (r / c)
| otherwise = abs x * log2 (l / c)
where c = scaleStep s n
l = scaleStep s $ n 1
r = scaleStep s $ n + 1
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