music-score 1.8 → 1.8.1

raw patch · 33 files changed

+543/−530 lines, 33 filesdep −data-defaultdep −profunctorsdep −voiddep ~lilyponddep ~music-dynamics-literaldep ~music-pitch-literalPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: data-default, profunctors, void

Dependency ranges changed: lilypond, music-dynamics-literal, music-pitch-literal, musicxml2

API changes (from Hackage documentation)

Files

• music-score.cabal +8/−10
• src/Data/Clipped.hs +1/−1
• src/Music/Score/Export/Backend.hs +1/−2
• src/Music/Score/Export/Lilypond.hs +10/−8
• src/Music/Score/Export/Midi.hs +1/−2
• src/Music/Score/Export/MusicXml.hs +1/−2
• src/Music/Score/Export/NoteList.hs +1/−2
• src/Music/Score/Export/SuperCollider.hs +1/−2
• src/Music/Score/Internal/Export.hs +1/−1
• src/Music/Score/Internal/Instances.hs +0/−1
• src/Music/Score/Internal/Quantize.hs +444/−0
• src/Music/Score/Meta/Annotations.hs +3/−3
• src/Music/Score/Meta/Attribution.hs +0/−2
• src/Music/Score/Meta/Barline.hs +0/−3
• src/Music/Score/Meta/Clef.hs +0/−2
• src/Music/Score/Meta/Extract.hs +0/−1
• src/Music/Score/Meta/Fermata.hs +0/−3
• src/Music/Score/Meta/Key.hs +0/−2
• src/Music/Score/Meta/Pickup.hs +3/−4
• src/Music/Score/Meta/RehearsalMark.hs +3/−4
• src/Music/Score/Meta/Tempo.hs +2/−3
• src/Music/Score/Meta/Time.hs +0/−2
• src/Music/Score/Meta/Title.hs +0/−2
• src/Music/Score/Part.hs +1/−1
• src/Music/Score/Phrases.hs +1/−2
• src/Music/Score/Pitch.hs +10/−13
• src/Music/Score/Ties.hs +1/−1
• src/Music/Time/Duration.hs +1/−1
• src/Music/Time/Event.hs +14/−3
• src/Music/Time/Internal/Quantize.hs +0/−444
• src/Music/Time/Internal/Util.hs +1/−1
• src/Music/Time/Meta.hs +8/−2
• src/Music/Time/Score.hs +26/−0

@@ -1,6 +1,6 @@  name:                   music-score-version:                1.8+version:                1.8.1 author:                 Hans Hoglund maintainer:             Hans Hoglund license:                BSD3@@ -26,15 +26,13 @@                         lens                    >= 4.6      && < 4.7,                         process                 >= 1.2 && < 1.3,                         containers,-                        void,                         nats,          -                        data-default,                         average                 >= 0.6 && < 1,                         semigroups              >= 0.13.0.1 && < 1,-                        contravariant           >= 1.2 && < 2,                         comonad                 >= 4.2.2 && < 5,+                        contravariant           >= 1.2 && < 2,                         bifunctors              >= 4.1.1.1 && < 5,-                        profunctors             >= 4.2.0.1 && < 5,+                        -- profunctors             >= 4.2.0.1 && < 5,                         distributive            >= 0.4.4 && < 5,                         adjunctions             >= 4.2 && < 5,                         transformers            >= 0.3.0.0 && < 0.5,@@ -46,10 +44,10 @@                         HCodecs                 >= 0.5 && < 0.6,                         vector-space            >= 0.8.7 && < 0.9,                         vector-space-points     >= 0.2 && < 0.3,-                        musicxml2               == 1.8,-                        lilypond                == 1.8,-                        music-pitch-literal     == 1.8,-                        music-dynamics-literal  == 1.8,+                        musicxml2               == 1.8.1,+                        lilypond                == 1.8.1,+                        music-pitch-literal     == 1.8.1,+                        music-dynamics-literal  == 1.8.1,                         prettify,                         parsec     exposed-modules:    Data.Clipped@@ -130,7 +128,7 @@                         Music.Time.Internal.Convert                         Music.Time.Internal.Util                         Music.Time.Internal.Transform-                        Music.Time.Internal.Quantize+                        Music.Score.Internal.Quantize                         Music.Score.Internal.Instances                         Music.Score.Internal.Util                         Music.Score.Internal.Export

@@ -30,7 +30,7 @@  ----- import Data.Fixed-import           Data.Default+-- import           Data.Default import           Data.Ratio  import           Control.Applicative

@@ -47,7 +47,6 @@ import           Control.Comonad               (Comonad (..), extract) import           Control.Applicative import           Data.Colour.Names             as Color-import           Data.Default import           Data.Foldable                 (Foldable) import qualified Data.Foldable import           Data.Functor.Couple@@ -59,7 +58,7 @@ import qualified Music.MusicXml.Simple         as MusicXml import           Music.Score.Internal.Export   hiding (MVoice) import           System.Process-import           Music.Time.Internal.Quantize+import           Music.Score.Internal.Quantize import qualified Text.Pretty                   as Pretty import qualified Data.List import           Music.Score.Internal.Util (composed, unRatio, swap, retainUpdates)

@@ -58,12 +58,11 @@ import           Data.AffineSpace import           Data.Bifunctor import           Data.Colour.Names                       as Color-import           Data.Default import           Data.Either import           Data.Foldable                           (Foldable) import           Data.Functor.Adjunction                 (unzipR) import           Data.Functor.Context-import           Data.Functor.Contravariant+-- import           Data.Functor.Contravariant import           Data.Functor.Couple import qualified Data.List import           Data.Maybe@@ -91,6 +90,8 @@                                                           unRatio, withPrevNext) import           Music.Score.Meta import           Music.Score.Meta.Time+import           Music.Score.Meta.Title+import           Music.Score.Meta.Attribution import           Music.Score.Part import           Music.Score.Phrases import           Music.Score.Slide@@ -98,7 +99,7 @@ import           Music.Score.Ties import           Music.Score.Tremolo import           Music.Time-import           Music.Time.Internal.Quantize+import           Music.Score.Internal.Quantize  import qualified Music.Lilypond                          as Lilypond @@ -574,14 +575,15 @@ -- Convert a score to a Lilypond representation and write to a file. -- writeLilypond :: HasLilypond a => FilePath -> a -> IO ()-writeLilypond = writeLilypond' def+writeLilypond = writeLilypond' mempty  data LilypondOptions   = LyInlineFormat   | LyScoreFormat -instance Default LilypondOptions where-  def = LyInlineFormat+instance Monoid LilypondOptions where+  mempty  = LyInlineFormat+  mappend = const  -- | -- Convert a score to a Lilypond representation and write to a file.@@ -591,7 +593,7 @@   where     -- title    = fromMaybe "" $ flip getTitleAt 0                  $ metaAtStart sc     -- composer = fromMaybe "" $ flip getAttribution "composer"     $ metaAtStart sc-    title = ""+    title    = ""     composer = ""     -- TODO generalize metaAtStart! @@ -638,7 +640,7 @@ -- 'writeLilypond' that may not work well on all platforms.) -- openLilypond :: HasLilypond a => a -> IO ()-openLilypond = openLilypond' def+openLilypond = openLilypond' mempty  -- | -- Typeset a score using Lilypond and open it. (This is simple wrapper around

@@ -45,7 +45,6 @@ import           Control.Comonad               (Comonad (..), extract) import           Control.Applicative import           Data.Colour.Names             as Color-import           Data.Default import           Data.Foldable                 (Foldable) import qualified Data.Foldable import           Data.Functor.Couple@@ -56,7 +55,7 @@ import qualified Music.MusicXml.Simple         as MusicXml import           Music.Score.Internal.Export   hiding (MVoice) import           System.Process-import           Music.Time.Internal.Quantize+import           Music.Score.Internal.Quantize import qualified Text.Pretty                   as Pretty import qualified Data.List import           Music.Score.Internal.Util (composed, unRatio, swap, retainUpdates)

@@ -53,7 +53,6 @@ import           Data.AffineSpace import           Data.Bifunctor import           Data.Colour.Names                       as Color-import           Data.Default import           Data.Foldable                           (Foldable) import qualified Data.Foldable import           Data.Functor.Couple@@ -95,7 +94,7 @@ import           Music.Score.Ties import           Music.Score.Tremolo import           Music.Time-import           Music.Time.Internal.Quantize+import           Music.Score.Internal.Quantize  import qualified Text.Pretty                             as Pretty import qualified Music.MusicXml.Simple                   as MusicXml

@@ -42,7 +42,6 @@ import           Control.Comonad               (Comonad (..), extract) import           Control.Applicative import           Data.Colour.Names             as Color-import           Data.Default import           Data.Foldable                 (Foldable) import qualified Data.Foldable import           Data.Functor.Couple@@ -53,7 +52,7 @@ import qualified Music.MusicXml.Simple         as MusicXml import           Music.Score.Internal.Export   hiding (MVoice) import           System.Process-import           Music.Time.Internal.Quantize+import           Music.Score.Internal.Quantize import qualified Text.Pretty                   as Pretty import qualified Data.List import           Music.Score.Internal.Util (composed, unRatio, swap, retainUpdates)

@@ -50,7 +50,6 @@ import           Control.Comonad               (Comonad (..), extract) import           Control.Applicative import           Data.Colour.Names             as Color-import           Data.Default import           Data.Foldable                 (Foldable) import qualified Data.Foldable import           Data.Functor.Couple@@ -61,7 +60,7 @@ import qualified Music.MusicXml.Simple         as MusicXml import           Music.Score.Internal.Export   hiding (MVoice) import           System.Process-import           Music.Time.Internal.Quantize+import           Music.Score.Internal.Quantize import qualified Text.Pretty                   as Pretty import qualified Data.List import           Music.Score.Internal.Util (composed, unRatio, swap, retainUpdates)

@@ -54,7 +54,7 @@ import           Music.Score.Dynamics import           Music.Score.Part import           Music.Score.Pitch-import           Music.Time.Internal.Quantize+import           Music.Score.Internal.Quantize import           Music.Score.Ties import           Music.Score.Meta.Time import           Music.Time

@@ -32,7 +32,6 @@ import           Control.Lens             hiding (part, transform) import           Control.Monad import           Data.AffineSpace-import           Data.Default import           Data.Monoid.Average import           Data.Foldable import           Data.Functor.Adjunction  (unzipR)

@@ -0,0 +1,444 @@++{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE ViewPatterns               #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-- Rhythmical quantization.+--+-------------------------------------------------------------------------------------++module Music.Score.Internal.Quantize (+        -- * Rhythm type+        Rhythm(..),+        mapWithDur,++        -- * Quantization+        quantize,+        rewrite,+        dotMod,+        +        -- * Utility+        drawRhythm+  ) 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                    -- d is divisible by 2+  | Group      [Rhythm a]                    --+  | Dotted     Int (Rhythm a)                -- n > 0.+  | Tuplet     Duration (Rhythm a)           -- d is an emelent of 'konstTuplets'.+  deriving (Eq, Show, Functor, Foldable)+  -- RInvTuplet  Duration (Rhythm a)++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"++-- TODO return voice+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, Maybe a)+-- rhythmToTree = go+--     where+--         go (Beat d a)     = Node ("beat "  ++ showD d, Just a) []+--         go (Group rs)     = Node ("group", Nothing) (fmap rhythmToTree rs)+--         go (Dotted n r)   = Node ("dotted " ++ show n, Nothing) [rhythmToTree r]+--         go (Tuplet n r)   = Node ("tuplet " ++ showD n, Nothing) [rhythmToTree r]+--         showD = show . toRational+--+-- drawRhythm :: Show a => Rhythm a -> String+-- drawRhythm = drawTree . fmap (uncurry (++) <<< (++ " ") *** show) . rhythmToTree++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++-- Catenates using 'Group'+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)      = _duration a * dotMod n+  _duration (Tuplet c a)      = _duration a * 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+  -- TODO how does this preserve the invariant?++Beat d x `subDur` d' = Beat (d-d') x+++{-+    Rhythm rewrite laws (all up to realization equality)++    Note: Just sketching, needs more formal treatment.+++    Group [Group xs ...] = Group [xs ...]+        [JoinGroup]++    Tuplet m (Tuplet n x) = Tuplet (m * n) x+        [NestTuplet]++    Tuplet m (Group [a,b ...]) = Group [Tuplet m a, Tuplet m b ...]+        [DistributeTuplet]+        This is only OK in certain contexts! Which?++-}++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 . splitTupletIfLongEnough . singleGroup++-- | Removes single-note groups+singleGroup :: Rhythm a -> Rhythm a+singleGroup orig@(Group [x]) = x+singleGroup orig             = orig++-- | Removes dotted notes in 2/3 tuplets.+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 _duration r > (1/2) then splitTuplet r else r+-- TODO should compare against beat duration, not just (1/4)++-- | Splits a tuplet iff it contans a group which can be split into two halves whose+--   duration have the ratio 1/2, 1 or 1/2.+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++-- |+-- Given a list, return a list of all possible splits.+--+-- >>> splits [1,2,3]+-- [([],[1,2,3]),([1],[2,3]),([1,2],[3]),([1,2,3],[])]+--+splits :: [a] -> [([a],[a])]+splits xs = List.inits xs `zip` List.tails xs+++-- | Return the first @Just@ value, if any.+firstJust :: [Maybe a] -> Maybe a+firstJust = listToMaybe . fmap fromJust . List.dropWhile isNothing+++quantize :: Tiable a => [(Duration, a)] -> Either String (Rhythm a)+quantize = quantize' (atEnd rhythm)++testQuantize :: [Duration] -> IO ()+testQuantize x = case fmap rewrite $ quantize' (atEnd rhythm) $ fmap (\x -> (x,())) $ x of+  Left e -> error e+  Right x -> putStrLn $ drawRhythm x+++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 {++      -- Time scaling of the current note (from dots and tuplets).+      timeMod    :: Duration,++      -- Time subtracted from the current rhythm (from ties).+      timeSub    :: Duration,++      -- Number of tuplets above the current note (default 0).+      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)+++++++-- |+-- A @RhytmParser a b@ converts (Voice a) to b.+type RhythmParser a b = Parsec [(Duration, a)] RhythmContext b++quantize' :: Tiable a => RhythmParser a b -> [(Duration, a)] -> Either String b+quantize' p = over _Left show . runParser p mempty ""+++++++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++-- Matches a beat divisible by 2 (notated)+-- beat :: Tiable a => RhythmParser a (Rhythm a)+-- beat = do+--     RhythmContext tm ts _ <- getState+--     (\d -> (d^/tm) `subDur` ts) <$> match (\d _ ->+--         d - ts > 0  &&  isPowerOf 2 (d / tm - ts))++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)+++-- | Matches a dotted rhythm+dotted :: Tiable a => RhythmParser a (Rhythm a)+dotted = msum . fmap dotted' $ konstNumDotsAllowed++-- | Matches a bound rhythm+bound :: Tiable a => RhythmParser a (Rhythm a)+bound = msum . fmap bound' $ konstBounds++-- | Matches a tuplet+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)++-- | Return the scaling applied to a note with the given number of dots (i.e. 3/2, 7/4 etc).+dotMod :: Int -> Duration+dotMod n = dotMods !! (n-1)++-- [3/2, 7/4, 15/8, 31/16 ..]+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++  -- TODO doesn't know order+  return $ Group [Beat (getBeatDuration a) b, Beat d c]++-- tuplet' 2/3 for triplet, 4/5 for quintuplet etc+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)+++-------------------------------------------------------------------------------------++-- | Similar to 'many1', but tries longer sequences before trying one.+-- many1long :: Stream s m t => ParsecT s u m a -> ParsecT s u m [a]+-- many1long p = try (many2 p) <|> fmap return p++-- | Similar to 'many1', but applies the parser 2 or more times.+-- 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) }++-- Matches a (_duration, value) pair iff the predicate matches, returns beat+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++-- Matches a (_duration, value) pair iff the predicate matches, returns beat+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++-- |+-- Succeed only if the entire input is consumed.+--+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++-- | Just x or Nothing+assuming :: a -> Bool -> Maybe a+assuming x b = if b then Just x else Nothing+++{-+isDivisibleBy2 :: RealFrac a => a -> Bool+isDivisibleBy2 x = isInt x && even (round x)++isInt :: RealFrac a => a -> Bool+isInt x = x == fromInteger (round x)+-}++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)+++-- divides     = isDivisibleBy+-- divisibleBy = flip isDivisibleBy++-- As it sounds, do NOT use infix+-- Only works for simple n such as 2 or 3, TODO determine+isPowerOf :: Duration -> Duration -> Bool+isPowerOf n = (== 0.0) . snd . properFraction . logBaseR (toRational n) . toRational++isPowerOf2 :: Duration -> Bool+isPowerOf2 = isPowerOf 2+

@@ -6,7 +6,6 @@ {-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE ScopedTypeVariables        #-}@@ -28,6 +27,7 @@  module Music.Score.Meta.Annotations (         Annotation,+        getAnnotation,         annotate,         annotateSpan,         showAnnotations,@@ -40,7 +40,7 @@ import           Data.Semigroup import           Data.String import           Data.Typeable-import           Data.Void+-- import           Data.Void  import           Music.Score.Meta import           Music.Score.Part@@ -76,6 +76,6 @@ showAnnotations' prefix = withAnnotations (flip $ \s -> foldr (text . (prefix ++ )) s)  -- | Handle the annotations in a score.-withAnnotations :: HasText a => ([String] -> Score a -> Score a) -> Score a -> Score a+withAnnotations :: ([String] -> Score a -> Score a) -> Score a -> Score a withAnnotations f = withMeta (f . getAnnotation) 

@@ -6,7 +6,6 @@ {-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE ScopedTypeVariables        #-}@@ -64,7 +63,6 @@ import           Data.Traversable          (Traversable) import qualified Data.Traversable          as T import           Data.Typeable-import           Data.Void  import           Music.Pitch.Literal import           Music.Score.Meta

@@ -6,7 +6,6 @@ {-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE ScopedTypeVariables        #-}@@ -46,7 +45,6 @@  import           Control.Lens              (view) import           Control.Monad.Plus-import           Data.Default import           Data.Foldable             (Foldable) import qualified Data.Foldable             as F import qualified Data.List                 as List@@ -60,7 +58,6 @@ import           Data.Traversable          (Traversable) import qualified Data.Traversable          as T import           Data.Typeable-import           Data.Void  import           Music.Pitch.Literal import           Music.Score.Meta

@@ -6,7 +6,6 @@ {-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE ScopedTypeVariables        #-}@@ -55,7 +54,6 @@ import           Data.Traversable          (Traversable) import qualified Data.Traversable          as T import           Data.Typeable-import           Data.Void  import           Music.Pitch.Literal import           Music.Score.Meta

@@ -11,7 +11,6 @@ import Music.Score.Meta.Title import Music.Score.Meta.Time import Music.Score.Meta.Key--- import Music.Score.Meta.Pickup import Music.Score.Meta.Tempo import Music.Score.Part 

@@ -6,7 +6,6 @@ {-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE ScopedTypeVariables        #-}@@ -42,7 +41,6 @@  import           Control.Lens              (view) import           Control.Monad.Plus-import           Data.Default import           Data.Foldable             (Foldable) import qualified Data.Foldable             as F import qualified Data.List                 as List@@ -56,7 +54,6 @@ import           Data.Traversable          (Traversable) import qualified Data.Traversable          as T import           Data.Typeable-import           Data.Void  import           Music.Pitch.Literal import           Music.Score.Meta

@@ -6,7 +6,6 @@ {-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE ScopedTypeVariables        #-}@@ -58,7 +57,6 @@ import           Data.Traversable          (Traversable) import qualified Data.Traversable          as T import           Data.Typeable-import           Data.Void  import           Music.Pitch.Literal import           Music.Score.Meta

@@ -6,7 +6,6 @@ {-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE ScopedTypeVariables        #-}@@ -39,7 +38,6 @@  import           Control.Lens              (view) import           Control.Monad.Plus-import           Data.Default import           Data.Foldable             (Foldable) import qualified Data.Foldable             as F import qualified Data.List                 as List@@ -53,7 +51,6 @@ import           Data.Traversable          (Traversable) import qualified Data.Traversable          as T import           Data.Typeable-import           Data.Void  import           Music.Pitch.Literal import           Music.Score.Meta@@ -70,14 +67,16 @@     deriving (Eq, Ord, Typeable) -- name level(0=standard) +{- instance Default Pickup where     def = Pickup Nothing 0+-}  instance Semigroup Pickup where     Pickup n1 l1 <> Pickup n2 l2 = Pickup (n1 <> n2) (l1 `max` l2)  instance Monoid Pickup where-    mempty  = def+    mempty  = Pickup Nothing 0     mappend = (<>)  instance Show Pickup where

@@ -6,7 +6,6 @@ {-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE ScopedTypeVariables        #-}@@ -43,7 +42,6 @@  import           Control.Lens              (view) import           Control.Monad.Plus-import           Data.Default import           Data.Foldable             (Foldable) import qualified Data.Foldable             as F import qualified Data.List                 as List@@ -57,7 +55,6 @@ import           Data.Traversable          (Traversable) import qualified Data.Traversable          as T import           Data.Typeable-import           Data.Void  import           Music.Pitch.Literal import           Music.Score.Meta@@ -74,14 +71,16 @@     deriving (Eq, Ord, Typeable) -- name level(0=standard) +{- instance Default RehearsalMark where     def = RehearsalMark Nothing 0+-}  instance Semigroup RehearsalMark where     RehearsalMark n1 l1 <> RehearsalMark n2 l2 = RehearsalMark (n1 <> n2) (l1 `max` l2)  instance Monoid RehearsalMark where-    mempty  = def+    mempty  = RehearsalMark Nothing 0     mappend = (<>)  instance Show RehearsalMark where

@@ -6,7 +6,6 @@ {-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE ScopedTypeVariables        #-}@@ -60,7 +59,6 @@ import           Control.Lens import           Control.Monad.Plus import           Data.AffineSpace-import           Data.Default import           Data.Foldable             (Foldable) import qualified Data.Foldable             as F import qualified Data.List                 as List@@ -75,7 +73,6 @@ import qualified Data.Traversable          as T import           Data.Typeable import           Data.VectorSpace-import           Data.Void  import           Music.Pitch.Literal import           Music.Score.Meta@@ -115,8 +112,10 @@ showR' ((unRatio -> (x, 1))) = show x showR' ((unRatio -> (x, y))) = "(" ++ show x ++ "/" ++ show y ++ ")" +{- instance Default Tempo where     def = mempty+-}  instance Semigroup Tempo where     (<>) = mappend

@@ -6,7 +6,6 @@ {-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE ScopedTypeVariables        #-}@@ -70,7 +69,6 @@ import           Data.Traversable          (Traversable) import qualified Data.Traversable          as T import           Data.Typeable-import           Data.Void  import           Music.Pitch.Literal import           Music.Score.Meta

@@ -6,7 +6,6 @@ {-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE ScopedTypeVariables        #-}@@ -64,7 +63,6 @@ import           Data.Traversable          (Traversable) import qualified Data.Traversable          as T import           Data.Typeable-import           Data.Void  import           Music.Pitch.Literal import           Music.Score.Meta

@@ -73,7 +73,7 @@ import           Control.Comonad import           Control.Lens                  hiding (parts, transform) import           Control.Monad.Plus-import           Data.Default+-- import           Data.Default import           Data.Foldable import           Data.Functor.Couple import qualified Data.List                     as List

@@ -60,13 +60,12 @@ import           Data.AffineSpace import           Data.Bifunctor import           Data.Colour.Names          as Color-import           Data.Default import           Data.Either import           Data.Either import           Data.Foldable              (Foldable) import           Data.Functor.Adjunction    (unzipR) import           Data.Functor.Context-import           Data.Functor.Contravariant+import           Data.Functor.Contravariant (Op(..)) import           Data.Functor.Couple import qualified Data.List                  as List import qualified Data.List

@@ -52,6 +52,9 @@         pitches',                  -- * Transposition+        PitchPair,+        AffinePair,+        Transposable,         up,         down,         above,@@ -80,14 +83,8 @@          -- -- * Intervals         -- augmentIntervals,-         -- TODO pitchIs, to write filter pitchIs ... etc-        -- TODO gliss etc--        PitchPair,-        AffinePair,-        Transposable,-        +        -- TODO gliss etc           ) where  import           Control.Applicative@@ -430,7 +427,7 @@ -- -- Not to be confused with matrix transposition. ----- >>> up m3 c+-- >>> up m3 (c :: Pitch) -- eb -- -- >>> up _P5 [c,d,e :: Pitch]@@ -448,7 +445,7 @@ -- -- Not to be confused with matrix transposition. ----- >>> down m3 c+-- >>> down m3 (c :: Pitch) -- a -- -- >>> down _P5 [c,d,e]@@ -461,7 +458,7 @@ -- | -- Add the given interval above. ----- >>> above _P8 [c]+-- >>> above _P8 [c :: Pitch] -- [c,c'] -- above :: (Semigroup a, Transposable a) => Interval a -> a -> a@@ -471,7 +468,7 @@ -- | -- Add the given interval below. ----- >>> below _P8 [c]+-- >>> below _P8 [c :: Pitch] -- [c,c_] -- below :: (Semigroup a, Transposable a) => Interval a -> a -> a@@ -491,7 +488,7 @@ -- | -- Transpose up by the given number of octaves. ----- >>> octavesUp 2 c+-- >>> octavesUp 2 (c :: Pitch) -- c'' -- -- >>> octavesUp 1 [c,d,e]@@ -507,7 +504,7 @@ -- | -- Transpose down by the given number of octaves. ----- >>> octavesDown 2 c+-- >>> octavesDown 2 (c :: Pitch) -- c__ -- -- >>> octavesDown 1 [c,d,e]

@@ -45,7 +45,7 @@ import           Control.Monad import           Control.Monad.Plus import           Data.AffineSpace-import           Data.Default+-- import           Data.Default import           Data.Foldable           hiding (concat) import           Data.Functor.Adjunction (unzipR) import qualified Data.List               as List

@@ -42,7 +42,7 @@ import           Data.NumInstances    () import           Data.Semigroup       hiding () import           Data.VectorSpace     hiding (Sum (..))-import           Data.Functor.Contravariant+-- import           Data.Functor.Contravariant ()  -- | -- Class of values that have a duration.

@@ -1,4 +1,5 @@ +{-# LANGUAGE CPP                        #-} {-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE DeriveFoldable             #-} {-# LANGUAGE DeriveFunctor              #-}@@ -44,6 +45,7 @@ import           Data.Functor.Compose import           Control.Monad.Compose import           Control.Comonad+import           Data.Distributive (distribute) import           Control.Lens             hiding (Indexable, Level, above,                                            below, index, inside, parts,                                            reversed, transform, (<|), (|>))@@ -78,7 +80,8 @@ -- @ -- --- TODO+#ifndef GHCI+-- TODO move instance Traversable AddMeta where   traverse = annotated instance Eq1 AddMeta where@@ -89,6 +92,7 @@   compare1 = compare instance Ord a => Ord1 (Couple a) where   compare1 = compare+ instance Num (f (g a)) => Num (Compose f g a) where   Compose a + Compose b = Compose (a + b)   Compose a - Compose b = Compose (a - b)@@ -110,8 +114,10 @@   xs >>= f = Compose $ mbind (getCompose . f) (getCompose xs) instance (Comonad f, Comonad g) => Comonad (Compose f g) where   extract (Compose f) = (extract . extract) f+  duplicate = error "No Comonad Compose.duplicate (in Music.Time.Event)"   -- TODO duplicate-  +#endif+ newtype Event a = Event { getEvent :: Compose AddMeta (Couple Span) a }   deriving (     Eq,@@ -120,7 +126,7 @@     Foldable,     Applicative,     Monad,-    Comonad,+    -- Comonad,     Traversable,          Functor,@@ -164,6 +170,11 @@  instance (Show a, Transformable a) => Show (Event a) where   show x = show (x^.from event) ++ "^.event"++instance Comonad Event where+  extract e   = e^.eventValue+  duplicate e = set meta (e^.meta) $ (e^.eventSpan,e)^.event+    -- | View a event as a pair of the original value and the transformation (and vice versa). event :: Iso (Span, a) (Span, b) (Event a) (Event b)

@@ -1,444 +0,0 @@--{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE ViewPatterns               #-}------------------------------------------------------------------------------------------ |--- Copyright   : (c) Hans Hoglund 2012-2014------ License     : BSD-style------ Maintainer  : hans@hanshoglund.se--- Stability   : experimental--- Portability : non-portable (TF,GNTD)------ Rhythmical quantization.-------------------------------------------------------------------------------------------module Music.Time.Internal.Quantize (-        -- * Rhythm type-        Rhythm(..),-        mapWithDur,--        -- * Quantization-        quantize,-        rewrite,-        dotMod,-        -        -- * Utility-        drawRhythm-  ) 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                    -- d is divisible by 2-  | Group      [Rhythm a]                    ---  | Dotted     Int (Rhythm a)                -- n > 0.-  | Tuplet     Duration (Rhythm a)           -- d is an emelent of 'konstTuplets'.-  deriving (Eq, Show, Functor, Foldable)-  -- RInvTuplet  Duration (Rhythm a)--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"---- TODO return voice-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, Maybe a)--- rhythmToTree = go---     where---         go (Beat d a)     = Node ("beat "  ++ showD d, Just a) []---         go (Group rs)     = Node ("group", Nothing) (fmap rhythmToTree rs)---         go (Dotted n r)   = Node ("dotted " ++ show n, Nothing) [rhythmToTree r]---         go (Tuplet n r)   = Node ("tuplet " ++ showD n, Nothing) [rhythmToTree r]---         showD = show . toRational------ drawRhythm :: Show a => Rhythm a -> String--- drawRhythm = drawTree . fmap (uncurry (++) <<< (++ " ") *** show) . rhythmToTree--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---- Catenates using 'Group'-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)      = _duration a * dotMod n-  _duration (Tuplet c a)      = _duration a * 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-  -- TODO how does this preserve the invariant?--Beat d x `subDur` d' = Beat (d-d') x---{--    Rhythm rewrite laws (all up to realization equality)--    Note: Just sketching, needs more formal treatment.---    Group [Group xs ...] = Group [xs ...]-        [JoinGroup]--    Tuplet m (Tuplet n x) = Tuplet (m * n) x-        [NestTuplet]--    Tuplet m (Group [a,b ...]) = Group [Tuplet m a, Tuplet m b ...]-        [DistributeTuplet]-        This is only OK in certain contexts! Which?---}--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 . splitTupletIfLongEnough . singleGroup---singleGroup :: Rhythm a -> Rhythm a-singleGroup orig@(Group [x]) = x-singleGroup orig             = orig---- | Removes dotted notes in 2/3 tuplets.-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 _duration r > (1/2) then splitTuplet r else r--- TODO should compare against beat duration, not just (1/4)---- | Splits a tuplet iff it contans a group which can be split into two halves whose---   duration have the ratio 1/2, 1 or 1/2.-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---- |--- Given a list, return a list of all possible splits.------ >>> splits [1,2,3]--- [([],[1,2,3]),([1],[2,3]),([1,2],[3]),([1,2,3],[])]----splits :: [a] -> [([a],[a])]-splits xs = List.inits xs `zip` List.tails xs----- | Return the first @Just@ value, if any.-firstJust :: [Maybe a] -> Maybe a-firstJust = listToMaybe . fmap fromJust . List.dropWhile isNothing---quantize :: Tiable a => [(Duration, a)] -> Either String (Rhythm a)-quantize = quantize' (atEnd rhythm)--testQuantize :: [Duration] -> IO ()-testQuantize x = case fmap rewrite $ quantize' (atEnd rhythm) $ fmap (\x -> (x,())) $ x of-  Left e -> error e-  Right x -> putStrLn $ drawRhythm x---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 {--      -- Time scaling of the current note (from dots and tuplets).-      timeMod    :: Duration,--      -- Time subtracted from the current rhythm (from ties).-      timeSub    :: Duration,--      -- Number of tuplets above the current note (default 0).-      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)--------- |--- A @RhytmParser a b@ converts (Voice a) to b.-type RhythmParser a b = Parsec [(Duration, a)] RhythmContext b--quantize' :: Tiable a => RhythmParser a b -> [(Duration, a)] -> Either String b-quantize' p = over _Left show . runParser p mempty ""-------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---- Matches a beat divisible by 2 (notated)--- beat :: Tiable a => RhythmParser a (Rhythm a)--- beat = do---     RhythmContext tm ts _ <- getState---     (\d -> (d^/tm) `subDur` ts) <$> match (\d _ ->---         d - ts > 0  &&  isPowerOf 2 (d / tm - ts))--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)----- | Matches a dotted rhythm-dotted :: Tiable a => RhythmParser a (Rhythm a)-dotted = msum . fmap dotted' $ konstNumDotsAllowed---- | Matches a bound rhythm-bound :: Tiable a => RhythmParser a (Rhythm a)-bound = msum . fmap bound' $ konstBounds---- | Matches a tuplet-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)---- | Return the scaling applied to a note with the given number of dots (i.e. 3/2, 7/4 etc).-dotMod :: Int -> Duration-dotMod n = dotMods !! (n-1)---- [3/2, 7/4, 15/8, 31/16 ..]-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--  -- TODO doesn't know order-  return $ Group [Beat (getBeatDuration a) b, Beat d c]---- tuplet' 2/3 for triplet, 4/5 for quintuplet etc-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)-------------------------------------------------------------------------------------------- | Similar to 'many1', but tries longer sequences before trying one.--- many1long :: Stream s m t => ParsecT s u m a -> ParsecT s u m [a]--- many1long p = try (many2 p) <|> fmap return p---- | Similar to 'many1', but applies the parser 2 or more times.--- 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) }---- Matches a (_duration, value) pair iff the predicate matches, returns beat-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---- Matches a (_duration, value) pair iff the predicate matches, returns beat-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---- |--- Succeed only if the entire input is consumed.----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---- | Just x or Nothing-assuming :: a -> Bool -> Maybe a-assuming x b = if b then Just x else Nothing---{--isDivisibleBy2 :: RealFrac a => a -> Bool-isDivisibleBy2 x = isInt x && even (round x)--isInt :: RealFrac a => a -> Bool-isInt x = x == fromInteger (round x)--}--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)----- divides     = isDivisibleBy--- divisibleBy = flip isDivisibleBy---- As it sounds, do NOT use infix--- Only works for simple n such as 2 or 3, TODO determine-isPowerOf :: Duration -> Duration -> Bool-isPowerOf n = (== 0.0) . snd . properFraction . logBaseR (toRational n) . toRational--isPowerOf2 :: Duration -> Bool-isPowerOf2 = isPowerOf 2-

@@ -54,7 +54,7 @@ import qualified Data.Monoid import qualified Data.List import qualified Data.Ratio-import Data.Functor.Contravariant+import Data.Functor.Contravariant (Equivalence(..), contramap)  -- | Divide a list into parts of maximum length n. -- > category : List

@@ -55,6 +55,7 @@         getMeta,         mapMeta,         setMeta,+        metaTypes,         applyMeta,         setMetaAttr,         setMetaTAttr,@@ -84,7 +85,7 @@ import qualified Data.Set                  as Set import           Data.String import           Data.Typeable-import           Data.Void+-- import           Data.Void import           Data.Functor.Couple  import           Music.Time.Internal.Util@@ -136,7 +137,7 @@   rev = id  -- Meta is Transformable because the contents of the map is transformable-newtype Meta = Meta (Map String Attribute)+newtype Meta = Meta { _getMeta :: Map String Attribute }   deriving (Transformable, Reversible, Splittable)  instance Semigroup Meta where@@ -206,6 +207,11 @@ -- | Map over meta-data. mapMeta :: HasMeta a => (Meta -> Meta) -> a -> a mapMeta = over meta++-- | Show the types of meta-data attachd to this value.+--   Useful for debugging.+metaTypes :: HasMeta a => a -> [String]+metaTypes x = Map.keys $ _getMeta $ x^.meta  -- | Apply meta-information by combining it with existing meta-information. applyMeta :: HasMeta a => Meta -> a -> a

@@ -46,10 +46,14 @@         -- * Simultaneous         -- TODO check for overlapping values etc         -- simult,+        hasOverlappingEvents,         simultaneous,          -- * Normalize         normalizeScore,+        removeRests,+        +        -- * Utility         printEras,          -- * Unsafe versions@@ -395,6 +399,9 @@     reset x = set onset (view onset x `max` 0) x     normalizeScoreDurations = over (events . each . era) normalizeSpan +removeRests :: Score (Maybe a) -> Score a+removeRests = mcatMaybes+ -- TODO version that reverses the values where appropriate -- Use over (events . each) normalizeEvent or similar @@ -435,3 +442,22 @@ simultaneous :: (Transformable a, Semigroup a) => Score a -> Score a simultaneous = fmap (sconcat . NonEmpty.fromList) . simultaneous' +++hasOverlappingEvents :: Score a -> Bool+hasOverlappingEvents = anyDistinctOverlaps . toListOf (events.each.era)++hasDuplicates :: Eq a => [a] -> Bool+hasDuplicates xs = List.nub xs /= xs++anyDistinctOverlaps :: [Span] -> Bool+anyDistinctOverlaps xs = hasDuplicates xs || anyOverlaps xs+  where+    anyOverlaps = foldr (||) False . combined overlaps+-- If the span list has duplicates, we have overlaps.++combined :: Eq a => (a -> a -> b) -> [a] -> [b]+combined f as = mcatMaybes [if x == y then Nothing else Just (x `f` y) | x <- as, y <- as]++squared :: (a -> a -> b) -> [a] -> [b]+squared f as = [x `f` y | x <- as, y <- as]