module Sound.MIDI.Util (
Beats(..), TimeSig(..), Seconds(..), BPS(..)
, decodeFile, encodeFileBeats, minResolution
, readTempo, showTempo
, makeTempo, applyTempo, unapplyTempo, applyTempoTrack, unapplyTempoTrack
, TempoMap, makeTempoMap, unmakeTempoMap, tempoMapFromBPS, tempoMapToBPS, applyTempoMap, unapplyTempoMap
, readSignature, readSignatureFull, showSignature, showSignatureFull
, MeasureMap, MeasureBeats, MeasureMode(..), measures, makeMeasureMap, unmakeMeasureMap
, measureMapFromLengths, measureMapToLengths
, measureMapFromTimeSigs, measureMapToTimeSigs
, applyMeasureMap, unapplyMeasureMap
, measureLengthToTimeSig
, trackName, setTrackName, readTrackName, showTrackName
, trackSplitZero, trackGlueZero, trackTakeZero, trackDropZero
, trackJoin, trackSplit, trackTake, trackDrop
, extractFirst
) where
import qualified Data.Map as Map
import Data.Maybe (listToMaybe, mapMaybe, isNothing)
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid (Monoid)
#endif
import Data.Ratio (denominator)
import qualified Numeric.NonNegative.Wrapper as NN
import qualified Numeric.NonNegative.Class as NNC
import qualified Sound.MIDI.File as F
import qualified Sound.MIDI.File.Event as E
import qualified Sound.MIDI.File.Event.Meta as Meta
import qualified Data.EventList.Absolute.TimeBody as ATB
import qualified Data.EventList.Relative.TimeBody as RTB
data DoubleKey a b
= DoubleKey !a !b
| LookupA !a
| LookupB !b
deriving (Show, Read)
instance (Ord a, Ord b) => Eq (DoubleKey a b) where
dk1 == dk2 = compare dk1 dk2 == EQ
instance (Ord a, Ord b) => Ord (DoubleKey a b) where
compare (DoubleKey a1 _ ) (DoubleKey a2 _ ) = compare a1 a2
compare (DoubleKey a1 _ ) (LookupA a2 ) = compare a1 a2
compare (DoubleKey _ b1) (LookupB b2) = compare b1 b2
compare (LookupA a1 ) (DoubleKey a2 _ ) = compare a1 a2
compare (LookupA a1 ) (LookupA a2 ) = compare a1 a2
compare (LookupA _ ) (LookupB _ ) = error
"compare: internal error! tried to compare LookupA and LookupB"
compare (LookupB b1) (DoubleKey _ b2) = compare b1 b2
compare (LookupB _ ) (LookupA _ ) = error
"compare: internal error! tried to compare LookupB and LookupA"
compare (LookupB b1) (LookupB b2) = compare b1 b2
newtype Beats = Beats { fromBeats :: NN.Rational }
deriving (Eq, Ord, Show, Monoid, NNC.C, Num, Real, Fractional, RealFrac)
data TimeSig = TimeSig { timeSigLength :: !Beats, timeSigUnit :: !Beats }
deriving (Eq, Show)
newtype Seconds = Seconds { fromSeconds :: NN.Rational }
deriving (Eq, Ord, Show, Monoid, NNC.C, Num, Real, Fractional, RealFrac)
newtype BPS = BPS { fromBPS :: NN.Rational }
deriving (Eq, Ord, Show, Monoid, NNC.C, Num, Real, Fractional, RealFrac)
makeTempo :: Beats -> Seconds -> BPS
makeTempo (Beats b) (Seconds s) = BPS $ b / s
applyTempo :: BPS -> Beats -> Seconds
applyTempo (BPS bps) (Beats b) = Seconds $ b / bps
unapplyTempo :: BPS -> Seconds -> Beats
unapplyTempo (BPS bps) (Seconds s) = Beats $ bps * s
decodeFile :: F.T -> Either [RTB.T Beats E.T] [RTB.T Seconds E.T]
decodeFile (F.Cons _typ dvn trks) = case dvn of
F.Ticks res -> let
readTime tks = Beats $ fromIntegral tks / fromIntegral res
in Left $ map (RTB.mapTime readTime) trks
F.SMPTE fps tksPerFrame -> let
realFps = case fps of
29 -> 29.97
_ -> fromIntegral fps
readTime tks = Seconds $
fromIntegral tks / (realFps * fromIntegral tksPerFrame)
in Right $ map (RTB.mapTime readTime) trks
encodeFileBeats :: F.Type -> Integer -> [RTB.T Beats E.T] -> F.T
encodeFileBeats typ res
= F.Cons typ (F.Ticks $ fromIntegral res)
. map (RTB.discretize . RTB.mapTime (* fromIntegral res))
minResolution :: [RTB.T Beats E.T] -> Integer
minResolution
= foldr lcm 1
. map (denominator . NN.toNumber . fromBeats)
. concatMap RTB.getTimes
readTempo :: E.T -> Maybe BPS
readTempo (E.MetaEvent (Meta.SetTempo uspqn)) = let
spqn = fromIntegral uspqn / 1000000
qnps = recip spqn
in Just $ BPS qnps
readTempo _ = Nothing
showTempo :: BPS -> E.T
showTempo (BPS qnps) = let
spqn = recip qnps
uspqn = spqn * 1000000
in E.MetaEvent $ Meta.SetTempo $ round uspqn
readSignature :: E.T -> Maybe Beats
readSignature = fmap timeSigLength . readSignatureFull
readSignatureFull :: E.T -> Maybe TimeSig
readSignatureFull (E.MetaEvent (Meta.TimeSig n d _ _)) = Just $ let
unit = 4 / (2 ^ d)
len = fromIntegral n * unit
in TimeSig (Beats len) (Beats unit)
readSignatureFull _ = Nothing
logBase2 :: Integer -> Maybe Integer
logBase2 x = go 0 1 where
go !p !y = case compare x y of
EQ -> Just p
GT -> go (p + 1) (y * 2)
LT -> Nothing
showSignature :: Beats -> Maybe E.T
showSignature = showSignatureFull . measureLengthToTimeSig
showSignatureFull :: TimeSig -> Maybe E.T
showSignatureFull (TimeSig (Beats len) (Beats unit)) = case properFraction $ len / unit of
(numer, 0) -> case properFraction $ 1 / unit of
(denom, 0) -> do
denomPow <- logBase2 denom
Just $ E.MetaEvent $ Meta.TimeSig numer (fromIntegral denomPow + 2) 24 8
_ -> Nothing
_ -> Nothing
measureLengthToTimeSig :: Beats -> TimeSig
measureLengthToTimeSig b = let
d = denominator $ NN.toNumber $ fromBeats b
in TimeSig b $ 1 / fromIntegral d
translationError :: (Show t) => String -> t -> a
translationError f t = error $
"Sound.MIDI.Util." ++ f ++ ": internal error! couldn't translate position " ++ show t
newtype TempoMap = TempoMap (Map.Map (DoubleKey Beats Seconds) BPS)
deriving (Eq)
instance Show TempoMap where
showsPrec p = showsPrec p . tempoMapToBPS
makeTempoMap :: RTB.T Beats E.T -> TempoMap
makeTempoMap = tempoMapFromBPS . RTB.mapMaybe readTempo
unmakeTempoMap :: TempoMap -> RTB.T Beats E.T
unmakeTempoMap = fmap showTempo . tempoMapToBPS
tempoMapFromBPS :: RTB.T Beats BPS -> TempoMap
tempoMapFromBPS = TempoMap . Map.fromAscList . go 0 0 2 where
go :: Beats -> Seconds -> BPS -> RTB.T Beats BPS -> [(DoubleKey Beats Seconds, BPS)]
go b s bps rtb = (DoubleKey b s, bps) : case RTB.viewL rtb of
Nothing -> []
Just ((db, bps'), rtb') -> go (b + db) (s + applyTempo bps db) bps' rtb'
tempoMapToBPS :: TempoMap -> RTB.T Beats BPS
tempoMapToBPS (TempoMap m) = let
f (DoubleKey bts _, bps) = (bts, bps)
f _ = error
"Sound.MIDI.Util.tempoMapToBPS: internal error! TempoMap key wasn't DoubleKey"
in RTB.fromAbsoluteEventList $ ATB.fromPairList $ map f $ Map.toAscList m
applyTempoMap :: TempoMap -> Beats -> Seconds
applyTempoMap (TempoMap tm) bts = case Map.lookupLE (LookupA bts) tm of
Just (DoubleKey b s, bps) -> s + applyTempo bps (bts b)
_ -> translationError "applyTempoMap" bts
unapplyTempoMap :: TempoMap -> Seconds -> Beats
unapplyTempoMap (TempoMap tm) secs = case Map.lookupLE (LookupB secs) tm of
Just (DoubleKey b s, bps) -> b + unapplyTempo bps (secs s)
_ -> translationError "unapplyTempoMap" secs
applyTempoTrack :: TempoMap -> RTB.T Beats a -> RTB.T Seconds a
applyTempoTrack tm
= RTB.fromAbsoluteEventList
. ATB.mapTime (applyTempoMap tm)
. RTB.toAbsoluteEventList 0
unapplyTempoTrack :: TempoMap -> RTB.T Seconds a -> RTB.T Beats a
unapplyTempoTrack tm
= RTB.fromAbsoluteEventList
. ATB.mapTime (unapplyTempoMap tm)
. RTB.toAbsoluteEventList 0
newtype MeasureMap = MeasureMap (Map.Map (DoubleKey Beats Int) TimeSig)
deriving (Eq)
instance Show MeasureMap where
showsPrec p = showsPrec p . measureMapToLengths
type MeasureBeats = (Int, Beats)
data MeasureMode
= Error
| Ignore
| Truncate
deriving (Eq, Ord, Show, Read, Enum, Bounded)
measures :: Int -> Beats -> Beats
measures m b = fromIntegral m * b
makeMeasureMap :: MeasureMode -> RTB.T Beats E.T -> MeasureMap
makeMeasureMap mm = measureMapFromTimeSigs mm . RTB.mapMaybe readSignatureFull
unmakeMeasureMap :: MeasureMap -> RTB.T Beats E.T
unmakeMeasureMap = fmap showSignatureFull' . measureMapToTimeSigs where
showSignatureFull' tsig = case showSignatureFull tsig of
Just e -> e
Nothing -> error $ "Sound.MIDI.Util.unmakeMeasureMap: couldn't encode time signature " ++ show tsig
measureMapFromTimeSigs :: MeasureMode -> RTB.T Beats TimeSig -> MeasureMap
measureMapFromTimeSigs mm = MeasureMap . Map.fromAscList . go 0 0 (TimeSig 4 1) where
go :: Beats -> Int -> TimeSig -> RTB.T Beats TimeSig -> [(DoubleKey Beats Int, TimeSig)]
go b m tsig rtb = (DoubleKey b m, tsig) : case RTB.viewL rtb of
Nothing -> []
Just ((db, tsig'), rtb') -> case properFraction $ db / timeSigLength tsig of
(dm, 0 ) -> go (b + db) (m + dm) tsig' rtb'
(dm, leftoverMsrs) -> case mm of
Error -> error $ unwords
[ "makeMeasureMap: misaligned time signature found after"
, show m
, "measures and"
, show $ fromBeats db
, "beats"
]
Ignore -> go b m tsig $ RTB.delay db rtb'
Truncate -> let
leftoverBeats = measureLengthToTimeSig $ leftoverMsrs * timeSigLength tsig
truncated = (DoubleKey (b + measures dm (timeSigLength tsig)) (m + dm), leftoverBeats)
in truncated : go (b + db) (m + dm + 1) tsig' rtb'
measureMapFromLengths :: MeasureMode -> RTB.T Beats Beats -> MeasureMap
measureMapFromLengths mm = measureMapFromTimeSigs mm . fmap measureLengthToTimeSig
measureMapToTimeSigs :: MeasureMap -> RTB.T Beats TimeSig
measureMapToTimeSigs (MeasureMap m) = let
f (DoubleKey bts _, len) = (bts, len)
f _ = error
"Sound.MIDI.Util.measureMapToLengths: internal error! MeasureMap key wasn't DoubleKey"
in RTB.fromAbsoluteEventList $ ATB.fromPairList $ map f $ Map.toAscList m
measureMapToLengths :: MeasureMap -> RTB.T Beats Beats
measureMapToLengths = fmap timeSigLength . measureMapToTimeSigs
applyMeasureMap :: MeasureMap -> Beats -> MeasureBeats
applyMeasureMap (MeasureMap mm) bts = case Map.lookupLE (LookupA bts) mm of
Just (DoubleKey b msr, tsig) -> let
msrs = floor $ (bts b) / timeSigLength tsig
leftover = (bts b) fromIntegral msrs * timeSigLength tsig
in (msr + msrs, leftover)
_ -> translationError "applyMeasureMap" bts
unapplyMeasureMap :: MeasureMap -> MeasureBeats -> Beats
unapplyMeasureMap (MeasureMap mm) (msr, bts) = case Map.lookupLE (LookupB msr) mm of
Just (DoubleKey b m, tsig) -> b + fromIntegral (msr m) * timeSigLength tsig + bts
_ -> translationError "unapplyMeasureMap" (msr, bts)
trackSplitZero :: (NNC.C t) => RTB.T t a -> ([a], RTB.T t a)
trackSplitZero rtb = case RTB.viewL rtb of
Just ((dt, x), rtb') | dt == NNC.zero -> case trackSplitZero rtb' of
(xs, rtb'') -> (x : xs, rtb'')
_ -> ([], rtb)
trackGlueZero :: (NNC.C t) => [a] -> RTB.T t a -> RTB.T t a
trackGlueZero xs rtb = foldr (RTB.cons NNC.zero) rtb xs
trackTakeZero :: (NNC.C t) => RTB.T t a -> [a]
trackTakeZero = fst . trackSplitZero
trackDropZero :: (NNC.C t) => RTB.T t a -> (RTB.T t a)
trackDropZero = snd . trackSplitZero
trackName :: (NNC.C t) => RTB.T t E.T -> Maybe String
trackName = listToMaybe . mapMaybe readTrackName . trackTakeZero
setTrackName :: (NNC.C t) => String -> RTB.T t E.T -> RTB.T t E.T
setTrackName s rtb = case trackSplitZero rtb of
(zero, rest) -> let
zero' = showTrackName s : filter (isNothing . readTrackName) zero
in trackGlueZero zero' rest
readTrackName :: E.T -> Maybe String
readTrackName (E.MetaEvent (Meta.TrackName s)) = Just s
readTrackName _ = Nothing
showTrackName :: String -> E.T
showTrackName = E.MetaEvent . Meta.TrackName
trackJoin :: (NNC.C t, Ord a) => RTB.T t (RTB.T t a) -> RTB.T t a
trackJoin rtb = case RTB.viewL rtb of
Nothing -> RTB.empty
Just ((dt, x), rtb') -> RTB.delay dt $ RTB.merge x $ trackJoin rtb'
trackSplit :: (NNC.C t) => t -> RTB.T t a -> (RTB.T t a, RTB.T t a)
trackSplit t rtb = case RTB.viewL rtb of
Nothing -> (RTB.empty, RTB.empty)
Just ((dt, x), rtb') -> case NNC.split t dt of
(_, (True , d)) -> (RTB.empty, RTB.cons d x rtb')
(_, (False, d)) -> case trackSplit d rtb' of
(taken, dropped) -> (RTB.cons dt x taken, dropped)
trackTake :: (NNC.C t) => t -> RTB.T t a -> RTB.T t a
trackTake t rtb = fst $ trackSplit t rtb
trackDrop :: (NNC.C t) => t -> RTB.T t a -> RTB.T t a
trackDrop t rtb = snd $ trackSplit t rtb
extractFirst :: (NNC.C t) => (a -> Maybe b) -> RTB.T t a -> Maybe ((t, b), RTB.T t a)
extractFirst f rtb = do
((dt, x), rtb') <- RTB.viewL rtb
case f x of
Just y -> return ((dt, y), RTB.delay dt rtb')
Nothing -> do
((dt_, y_), rtb_) <- extractFirst f rtb'
return ((NNC.add dt dt_, y_), RTB.cons dt x rtb_)