module Music.Score.Rhythm (
Rhythm(..),
quantize,
dotMod,
) where
import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum)
import Data.Semigroup
import Control.Applicative
import Control.Monad (ap, join, MonadPlus(..))
import Data.Maybe
import Data.Either
import Data.Foldable
import Data.Traversable
import Data.Function (on)
import Data.Ord (comparing)
import Data.Ratio
import Data.VectorSpace
import Text.Parsec hiding ((<|>))
import Text.Parsec.Pos
import Music.Time
import Music.Score.Ties
data Rhythm a
= Beat DurationT a
| Group [Rhythm a]
| Dotted Int (Rhythm a)
| Tuplet DurationT (Rhythm a)
deriving (Eq, Show, Functor, Foldable)
getBeatValue :: Rhythm a -> a
getBeatValue (Beat d a) = a
getBeatValue _ = error "getBeatValue: Not a beat"
getBeatDuration :: Rhythm a -> DurationT
getBeatDuration (Beat d a) = d
getBeatDuration _ = error "getBeatValue: Not a beat"
instance Semigroup (Rhythm a) where
(<>) = mappend
instance Monoid (Rhythm a) where
mempty = Group []
Group as `mappend` Group bs = Group (as <> bs)
r `mappend` Group bs = Group ([r] <> bs)
Group as `mappend` r = Group (as <> [r])
instance AdditiveGroup (Rhythm a) where
zeroV = error "No zeroV for (Rhythm a)"
(^+^) = error "No ^+^ for (Rhythm a)"
negateV = error "No negateV for (Rhythm a)"
instance VectorSpace (Rhythm a) where
type Scalar (Rhythm a) = DurationT
a *^ Beat d x = Beat (a*d) x
Beat d x `subDur` d' = Beat (dd') x
quantize :: Tiable a => [(DurationT, a)] -> Either String (Rhythm a)
quantize = quantize' (atEnd rhythm)
testQuantize :: [DurationT] -> Either String (Rhythm ())
testQuantize = quantize' (atEnd rhythm) . fmap (\x->(x,()))
dotMod :: Int -> DurationT
dotMod n = dotMods !! (n1)
dotMods :: [DurationT]
dotMods = zipWith (/) (fmap pred $ drop 2 times2) (drop 1 times2)
where
times2 = iterate (*2) 1
tupletMods :: [DurationT]
tupletMods = [2/3, 4/5, 4/7, 8/9]
data RState = RState {
timeMod :: DurationT,
timeSub :: DurationT,
tupleDepth :: Int
}
instance Monoid RState where
mempty = RState { timeMod = 1, timeSub = 0, tupleDepth = 0 }
a `mappend` _ = a
modifyTimeMod :: (DurationT -> DurationT) -> RState -> RState
modifyTimeMod f (RState tm ts td) = RState (f tm) ts td
modifyTimeSub :: (DurationT -> DurationT) -> RState -> RState
modifyTimeSub f (RState tm ts td) = RState tm (f ts) td
modifyTupleDepth :: (Int -> Int) -> RState -> RState
modifyTupleDepth f (RState tm ts td) = RState tm ts (f td)
type RhythmParser a b = Parsec [(DurationT, a)] RState b
quantize' :: Tiable a => RhythmParser a b -> [(DurationT, a)] -> Either String b
quantize' p = left show . runParser p mempty ""
match :: Tiable a => (DurationT -> a -> Bool) -> RhythmParser a (Rhythm a)
match p = tokenPrim show next test
where
show x = ""
next pos _ _ = updatePosChar pos 'x'
test (d,x) = if p d x then Just (Beat d x) else Nothing
rhythm :: Tiable a => RhythmParser a (Rhythm a)
rhythm = Group <$> many1 (rhythm' <|> bound)
rhythmNoBound :: Tiable a => RhythmParser a (Rhythm a)
rhythmNoBound = Group <$> many1 rhythm'
rhythm' :: Tiable a => RhythmParser a (Rhythm a)
rhythm' = mzero
<|> beat
<|> dotted
<|> tuplet
beat :: Tiable a => RhythmParser a (Rhythm a)
beat = do
RState tm ts _ <- getState
(\d -> (d^/tm) `subDur` ts) <$> match (\d _ ->
d ts > 0
&&
isDivisibleBy 2 (d / tm ts))
dotted :: Tiable a => RhythmParser a (Rhythm a)
dotted = msum . fmap dotted' $ [1..2]
dotted' :: Tiable a => Int -> RhythmParser a (Rhythm a)
dotted' n = do
modifyState $ modifyTimeMod (* dotMod n)
a <- beat
modifyState $ modifyTimeMod (/ dotMod n)
return (Dotted n a)
bound :: Tiable a => RhythmParser a (Rhythm a)
bound = bound' (1/2)
bound' :: Tiable a => DurationT -> RhythmParser a (Rhythm a)
bound' d = do
modifyState $ modifyTimeSub (+ d)
a <- beat
modifyState $ modifyTimeSub (subtract d)
let (b,c) = toTied $ getBeatValue a
return $ Group [Beat (getBeatDuration a) $ b, Beat (1/2) $ c]
tuplet :: Tiable a => RhythmParser a (Rhythm a)
tuplet = msum . fmap tuplet' $ tupletMods
tuplet' :: Tiable a => DurationT -> RhythmParser a (Rhythm a)
tuplet' d = do
RState _ _ depth <- getState
onlyIf (depth < 1) $ do
modifyState $ modifyTimeMod (* d)
. modifyTupleDepth succ
a <- rhythmNoBound
modifyState $ modifyTimeMod (/ d)
. modifyTupleDepth pred
return (Tuplet d a)
many1long :: Stream s m t => ParsecT s u m a -> ParsecT s u m [a]
many1long p = try (many2 p) <|> fmap return p
many2 :: Stream s m t => ParsecT s u m a -> ParsecT s u m [a]
many2 p = do { x <- p; xs <- many1 p; return (x : xs) }
atEnd :: RhythmParser a b -> RhythmParser a b
atEnd p = do
x <- p
notFollowedBy' anyToken' <?> "end of input"
return x
where
notFollowedBy' p = try $ (try p >> unexpected "") <|> return ()
anyToken' = tokenPrim (const "") (\pos _ _ -> pos) Just
onlyIf :: MonadPlus m => Bool -> m b -> m b
onlyIf b p = if b then p else mzero
logBaseR :: forall a . (RealFloat a, Floating a) => Rational -> Rational -> a
logBaseR k n
| isInfinite (fromRational n :: a) = logBaseR k (n/k) + 1
logBaseR k n
| isDenormalized (fromRational n :: a) = logBaseR k (n*k) 1
logBaseR k n = logBase (fromRational k) (fromRational n)
isDivisibleBy :: DurationT -> DurationT -> Bool
isDivisibleBy n = (== 0.0) . snd . properFraction . logBaseR (toRational n) . toRational
left f (Left x) = Left (f x)
left f (Right y) = Right y