module Music.Score.Internal.Quantize (
Rhythm(..),
mapWithDur,
quantize,
rewrite,
dotMod,
drawRhythm,
testQuantize,
) where
import Prelude hiding (concat, concatMap, foldl, foldr,
mapM, maximum, minimum, sum)
import Control.Applicative
import Control.Lens (over, (^.), _Left)
import Control.Monad (MonadPlus (..), ap, join)
import Data.Either
import Data.Foldable
import Data.Function (on)
import qualified Data.List as List
import Data.Maybe
import Data.Ord (comparing)
import Data.Ratio
import Data.Semigroup
import Data.Traversable
import Data.Tree
import Data.VectorSpace
import Text.Parsec hiding ((<|>))
import Text.Parsec.Pos
import Music.Score.Ties
import Music.Score.Internal.Util
import Music.Time
data Rhythm a
= Beat Duration a
| Group [Rhythm a]
| Dotted Int (Rhythm a)
| Tuplet Duration (Rhythm a)
deriving (Eq, Show, Functor, Foldable)
instance Transformable (Rhythm a) where
transform s (Beat d x) = Beat (transform s d) x
transform s (Group rs) = Group (fmap (transform s) rs)
transform s (Dotted n r) = Dotted n (transform s r)
transform s (Tuplet n r) = Tuplet n (transform s r)
getBeatValue :: Rhythm a -> a
getBeatValue (Beat d a) = a
getBeatValue _ = error "getBeatValue: Not a beat"
getBeatDuration :: Rhythm a -> Duration
getBeatDuration (Beat d a) = d
getBeatDuration _ = error "getBeatValue: Not a beat"
realize :: Rhythm a -> [Note a]
realize (Beat d a) = [(d, a)^.note]
realize (Group rs) = rs >>= realize
realize (Dotted n r) = dotMod n `stretch` realize r
realize (Tuplet n r) = n `stretch` realize r
rhythmToTree :: Rhythm a -> Tree String
rhythmToTree = go
where
go (Beat d a) = Node ("" ++ showD d) []
go (Group rs) = Node ("") (fmap rhythmToTree rs)
go (Dotted n r) = Node (replicate n '.') [rhythmToTree r]
go (Tuplet n r) = Node ("*^ " ++ showD n) [rhythmToTree r]
showD = (\x -> show (numerator x) ++ "/" ++ show (denominator x)) . toRational
drawRhythm :: Show a => Rhythm a -> String
drawRhythm = drawTree . rhythmToTree
mapWithDur :: (Duration -> a -> b) -> Rhythm a -> Rhythm b
mapWithDur f = go
where
go (Beat d x) = Beat d (f d x)
go (Dotted n (Beat d x)) = Dotted n $ Beat d (f (dotMod n * d) x)
go (Group rs) = Group $ fmap (mapWithDur f) rs
go (Tuplet m r) = Tuplet m (mapWithDur f r)
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])
a `mappend` b = Group [a, b]
instance HasDuration (Rhythm a) where
_duration (Beat d _) = d
_duration (Dotted n a) = a^.duration * dotMod n
_duration (Tuplet c a) = a^.duration * c
_duration (Group as) = sum (fmap (^.duration) as)
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) = Duration
a *^ Beat d x = Beat (a*d) x
Beat d x `subDur` d' = Beat (dd') x
rewrite :: Rhythm a -> Rhythm a
rewrite = rewriteR . rewrite1
rewriteR = go where
go (Beat d a) = Beat d a
go (Group rs) = Group (fmap (rewriteR . rewrite1) rs)
go (Dotted n r) = Dotted n ((rewriteR . rewrite1) r)
go (Tuplet n r) = Tuplet n ((rewriteR . rewrite1) r)
rewrite1 = tupletDot . singleGroup
singleGroup :: Rhythm a -> Rhythm a
singleGroup orig@(Group [x]) = x
singleGroup orig = orig
tupletDot :: Rhythm a -> Rhythm a
tupletDot orig@(Tuplet ((unRatio.realToFrac) -> (2,3)) (Dotted 1 x)) = x
tupletDot orig = orig
splitTupletIfLongEnough :: Rhythm a -> Rhythm a
splitTupletIfLongEnough r = if r^.duration > (1/2) then splitTuplet r else r
splitTuplet :: Rhythm a -> Rhythm a
splitTuplet orig@(Tuplet n (Group xs)) = case trySplit xs of
Nothing -> orig
Just (as, bs) -> Tuplet n (Group as) <> Tuplet n (Group bs)
splitTuplet orig = orig
trySplit :: [Rhythm a] -> Maybe ([Rhythm a], [Rhythm a])
trySplit = firstJust . fmap g . splits
where
g (part1, part2)
| (sum . fmap (^.duration)) part1 `rel` (sum . fmap (^.duration)) part2 = Just (part1, part2)
| otherwise = Nothing
rel x y
| x == y = True
| x == y*2 = True
| x*2 == y = True
| otherwise = False
splits :: [a] -> [([a],[a])]
splits xs = List.inits xs `zip` List.tails xs
firstJust :: [Maybe a] -> Maybe a
firstJust = listToMaybe . fmap fromJust . List.dropWhile isNothing
quantize :: Tiable a => [(Duration, a)] -> Either String (Rhythm a)
quantize xs = case quOrig xs of
Right x -> Right x
Left e1 -> case quSimp xs of
Right x -> Right x
Left e2 -> Left $ e1 ++ ", " ++ e2
testQuantize :: [Duration] -> IO ()
testQuantize x = case fmap rewrite $ qAlg $ fmap (\x -> (x,())) $ x of
Left e -> error e
Right x -> putStrLn $ drawRhythm x
where
qAlg = quantize
quOrig = quantize' (atEnd rhythm)
konstNumDotsAllowed :: [Int]
konstNumDotsAllowed = [1..2]
konstBounds :: [Duration]
konstBounds = [ 1/2, 1/4, 1/8, 1/16 ]
konstTuplets :: [Duration]
konstTuplets = [ 2/3, 4/5, 4/7, 8/9, 8/11, 8/13, 8/15, 16/17, 16/18, 16/19, 16/21, 16/23 ]
konstMaxTupletNest :: Int
konstMaxTupletNest = 1
data RhythmContext = RhythmContext {
timeMod :: Duration,
timeSub :: Duration,
tupleDepth :: Int
}
instance Monoid RhythmContext where
mempty = RhythmContext { timeMod = 1, timeSub = 0, tupleDepth = 0 }
a `mappend` _ = a
modifyTimeMod :: (Duration -> Duration) -> RhythmContext -> RhythmContext
modifyTimeMod f (RhythmContext tm ts td) = RhythmContext (f tm) ts td
modifyTimeSub :: (Duration -> Duration) -> RhythmContext -> RhythmContext
modifyTimeSub f (RhythmContext tm ts td) = RhythmContext tm (f ts) td
modifyTupleDepth :: (Int -> Int) -> RhythmContext -> RhythmContext
modifyTupleDepth f (RhythmContext tm ts td) = RhythmContext tm ts (f td)
type RhythmParser a b = Parsec [(Duration, a)] RhythmContext b
quantize' :: Tiable a => RhythmParser a b -> [(Duration, a)] -> Either String b
quantize' p rh = over _Left show . runParser p mempty ("Rhythm pattern: '" ++ show (fmap fst rh) ++ "'") $ rh
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
RhythmContext tm ts _ <- getState
match' $ \d x ->
let d2 = d / tm ts
in (d2, x) `assuming` (d ts > 0 && isPowerOf2 d2)
dotted :: Tiable a => RhythmParser a (Rhythm a)
dotted = msum . fmap dotted' $ konstNumDotsAllowed
bound :: Tiable a => RhythmParser a (Rhythm a)
bound = msum $ fmap bound' $ konstBounds
tuplet :: Tiable a => RhythmParser a (Rhythm a)
tuplet = msum . fmap tuplet' $ konstTuplets
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)
dotMod :: Int -> Duration
dotMod n = dotMods !! (n1)
dotMods :: [Duration]
dotMods = zipWith (/) (fmap pred $ drop 2 times2) (drop 1 times2)
where
times2 = iterate (*2) 1
bound' :: Tiable a => Duration -> 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 d c
]
tuplet' :: Tiable a => Duration -> RhythmParser a (Rhythm a)
tuplet' d = do
RhythmContext _ _ depth <- getState
onlyIf (depth < konstMaxTupletNest) $ do
modifyState $ modifyTimeMod (* d)
. modifyTupleDepth succ
a <- rhythmNoBound
modifyState $ modifyTimeMod (/ d)
. modifyTupleDepth pred
return (Tuplet d a)
match :: Tiable a => (Duration -> 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
match' :: Tiable a => (Duration -> a -> Maybe (Duration, b)) -> RhythmParser a (Rhythm b)
match' f = tokenPrim show next test
where
show x = ""
next pos _ _ = updatePosChar pos 'x'
test (d,x) = case f d x of
Nothing -> Nothing
Just (d,x) -> Just $ Beat d x
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
assuming :: a -> Bool -> Maybe a
assuming x b = if b then Just x else Nothing
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 | otherwise = logBase (fromRational k) (fromRational n)
isPowerOf n = (== 0.0) . snd . properFraction . logBaseR (toRational n) . toRational
isPowerOf2 = isPowerOf 2
greatestSmallerPowerOf2 :: Integer -> Integer
greatestSmallerPowerOf2 x
| x < 0 = error "greatestSmallerPowerOf2: Must be > 0"
| isPowerOf2 x = x
| otherwise = greatestSmallerPowerOf2 (x 1)
quSimp :: Tiable a => [(Duration, a)] -> Either String (Rhythm a)
quSimp = Right . qu1 1
where
qu1 totDur xs = if isPowerOf2 n then
Group (fmap (\(_,a) -> Beat (totDur/fromIntegral n) a) xs) else
Tuplet (q) (Group (fmap (\(_,a) -> Beat (totDur/fromIntegral p) a) xs))
where
q = fromIntegral p / fromIntegral n :: Duration
p = greatestSmallerPowerOf2 n :: Integer
n = fromIntegral $ length xs