module Temporal.Music.Demo(
module Temporal.Music,
MidiNote,
Instr, instr, drumInstr,
renderMidi, FilePath, exportMidi)
where
import Data.Default
import Control.Arrow(first, second)
import Control.Applicative
import Data.Maybe
import Data.List
import Data.Function(on)
import Data.Word
import Data.Binary
import Data.Binary.Put
import qualified Codec.Midi as M
import Temporal.Music
type T = Double
type Instr = Int
data MidiId = InstrId Int | DrumId Int
type MidiNote = Note MidiId
type MidiEvent = Event T LowMidiNote
data LowMidiNote = LowMidiNote {
midiNoteInstr :: Maybe Instr,
midiNoteVolume :: MidiVolume,
midiNotePitch :: MidiPitch
} deriving (Show)
newtype MidiVolume = MidiVolume { volumeId :: Int }
deriving (Show)
data MidiPitch = MidiPitch {
pitchId :: Int,
bendId :: Double
} deriving (Show)
type VolumeId = Int
type PitchId = Int
isDrum :: LowMidiNote -> Bool
isDrum = isNothing . midiNoteInstr
exportMidi :: FilePath -> Score MidiNote -> IO ()
exportMidi f = M.exportFile f . renderMidi
instr :: Instr -> Score (Note a) -> Score MidiNote
instr i = fmap $ mapNoteParam (const $ Just $ InstrId i)
drumInstr :: Instr -> Score (Drum a) -> Score MidiNote
drumInstr i = fmap $
\n -> Note
{ noteVolume = drumVolume n
, notePitch = def
, noteParam = Just $ DrumId i
}
toLowMidiNote :: MidiNote -> LowMidiNote
toLowMidiNote n = case fromJust $ noteParam n of
InstrId i -> instrLowNote i n
DrumId i -> drumInstrLowNote i n
instrLowNote :: Int -> MidiNote -> LowMidiNote
instrLowNote i n = LowMidiNote (Just i)
(midiVolume $ getVolume n)
(midiPitch $ getPitch n)
drumInstrLowNote :: Int -> MidiNote -> LowMidiNote
drumInstrLowNote i n = LowMidiNote Nothing
(midiVolume $ getVolume n)
(MidiPitch i 0)
renderMidi :: Score MidiNote -> M.Midi
renderMidi s = M.Midi M.SingleTrack timeDiv [toTrack s]
timeDiv :: M.TimeDiv
timeDiv = M.TicksPerBeat 96
toTrack :: Score MidiNote -> M.Track M.Ticks
toTrack = addEndMsg . maybe [] phi . checkOnEmpty . render . fmap toLowMidiNote
where phi = tfmTime . mergeInstr . groupInstr
checkOnEmpty x
| null x = Nothing
| otherwise = Just x
addEndMsg :: M.Track M.Ticks -> M.Track M.Ticks
addEndMsg = (++ [(0, M.TrackEnd)])
tfmTime :: M.Track Double -> M.Track M.Ticks
tfmTime = M.fromAbsTime . M.fromRealTime timeDiv .
sortBy (compare `on` fst)
groupInstr :: [Event T LowMidiNote] -> ([[MidiEvent]], [MidiEvent])
groupInstr = first groupByInstrId .
partition (not . isDrum . eventContent) . alignByZero
where groupByInstrId = groupBy ((==) `on` instrId) .
sortBy (compare `on` instrId)
mergeInstr :: ([[MidiEvent]], [MidiEvent]) -> M.Track Double
mergeInstr (instrs, drums) = concat $ drums' : instrs'
where instrs' = zipWith setChannel ([0 .. 8] ++ [10 .. 15]) instrs
drums' = setDrumChannel drums
setChannel :: M.Channel -> [MidiEvent] -> M.Track Double
setChannel ch ms = case ms of
[] -> []
x:xs -> (0, M.ProgramChange ch (instrId x)) : (fromEvent ch =<< ms)
setDrumChannel :: [MidiEvent] -> M.Track Double
setDrumChannel ms = fromEvent drumChannel =<< ms
where drumChannel = 9
instrId = fromJust . midiNoteInstr . eventContent
fromEvent :: M.Channel -> MidiEvent -> M.Track Double
fromEvent ch e = (t1, m1) : zip (repeat t0) m0
where t0 = eventStart e
t1 = eventStart e + eventDur e
(m0, m1) = toMessages ch $ eventContent e
clipToMidi :: (Ord a, Num a) => a -> a
clipToMidi = max 0 . min 127
toMessages :: M.Channel -> LowMidiNote
-> ([M.Message], M.Message)
toMessages ch e = toMessages' ch (midiNoteVolume e) (midiNotePitch e)
toMessages' :: M.Channel -> MidiVolume -> MidiPitch
-> ([M.Message], M.Message)
toMessages' ch mv mp = (addTune [M.NoteOn ch p v], M.NoteOff ch p 64)
where addTune = maybe id (:) $ tuneMessage <$> tuneParams mp
v = clipToMidi $ volumeId mv
p = clipToMidi $ pitchId mp
midiVolume :: Volume -> MidiVolume
midiVolume v = MidiVolume $ floor $ 127 * volumeAsDouble v
midiPitch :: Pitch -> MidiPitch
midiPitch p = uncurry MidiPitch $ properFraction $
69 + 12 * (scaleStepFactor s n
+ scaleOctaveFactor s k + scaleBendFactor s n r)
where (d, r) = properFraction $ pitchAsDouble p
(k, n) = divMod d $ scaleLength s
s = pitchScale p
log2 :: (Floating a) => a -> a
log2 = logBase 2
scaleStepFactor :: Scale -> Int -> Interval
scaleStepFactor s n = log2 $ (scaleStep s n) * f0 / 440
where f0 = scaleBase s
scaleOctaveFactor :: Scale -> Int -> Interval
scaleOctaveFactor s k
| abs (d 2) < 1e-9 = k'
| otherwise = k' * log2 d
where d = scaleOctave s
k' = fromIntegral k
scaleBendFactor :: Scale -> Int -> Interval -> Interval
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
type TuneId = (KeyId, Cents)
type KeyId = Word8
type Cent0 = Word8
type Cent1 = Word8
type Cents = (Cent0, Cent1)
cents :: Double -> (Cent0, Cent1)
cents d = (fromIntegral c0, fromIntegral c1)
where (c0, c1) = flip divMod (128::Int) $
fst $ properFraction (d/deltaTune)
tuneParams :: MidiPitch -> Maybe TuneId
tuneParams (MidiPitch p d)
| c == (0, 0) = Nothing
| otherwise = Just (fromIntegral p, c)
where c = cents d
deltaTune :: Double
deltaTune = 0.000061
tuneMessage :: TuneId -> M.Message
tuneMessage (x, (a, b)) = M.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