diff --git a/music-score.cabal b/music-score.cabal --- a/music-score.cabal +++ b/music-score.cabal @@ -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 diff --git a/src/Data/Clipped.hs b/src/Data/Clipped.hs --- a/src/Data/Clipped.hs +++ b/src/Data/Clipped.hs @@ -30,7 +30,7 @@ ----- import Data.Fixed -import Data.Default +-- import Data.Default import Data.Ratio import Control.Applicative diff --git a/src/Music/Score/Export/Backend.hs b/src/Music/Score/Export/Backend.hs --- a/src/Music/Score/Export/Backend.hs +++ b/src/Music/Score/Export/Backend.hs @@ -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) diff --git a/src/Music/Score/Export/Lilypond.hs b/src/Music/Score/Export/Lilypond.hs --- a/src/Music/Score/Export/Lilypond.hs +++ b/src/Music/Score/Export/Lilypond.hs @@ -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 diff --git a/src/Music/Score/Export/Midi.hs b/src/Music/Score/Export/Midi.hs --- a/src/Music/Score/Export/Midi.hs +++ b/src/Music/Score/Export/Midi.hs @@ -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) diff --git a/src/Music/Score/Export/MusicXml.hs b/src/Music/Score/Export/MusicXml.hs --- a/src/Music/Score/Export/MusicXml.hs +++ b/src/Music/Score/Export/MusicXml.hs @@ -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 diff --git a/src/Music/Score/Export/NoteList.hs b/src/Music/Score/Export/NoteList.hs --- a/src/Music/Score/Export/NoteList.hs +++ b/src/Music/Score/Export/NoteList.hs @@ -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) diff --git a/src/Music/Score/Export/SuperCollider.hs b/src/Music/Score/Export/SuperCollider.hs --- a/src/Music/Score/Export/SuperCollider.hs +++ b/src/Music/Score/Export/SuperCollider.hs @@ -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) diff --git a/src/Music/Score/Internal/Export.hs b/src/Music/Score/Internal/Export.hs --- a/src/Music/Score/Internal/Export.hs +++ b/src/Music/Score/Internal/Export.hs @@ -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 diff --git a/src/Music/Score/Internal/Instances.hs b/src/Music/Score/Internal/Instances.hs --- a/src/Music/Score/Internal/Instances.hs +++ b/src/Music/Score/Internal/Instances.hs @@ -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) diff --git a/src/Music/Score/Internal/Quantize.hs b/src/Music/Score/Internal/Quantize.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Internal/Quantize.hs @@ -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 + diff --git a/src/Music/Score/Meta/Annotations.hs b/src/Music/Score/Meta/Annotations.hs --- a/src/Music/Score/Meta/Annotations.hs +++ b/src/Music/Score/Meta/Annotations.hs @@ -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) diff --git a/src/Music/Score/Meta/Attribution.hs b/src/Music/Score/Meta/Attribution.hs --- a/src/Music/Score/Meta/Attribution.hs +++ b/src/Music/Score/Meta/Attribution.hs @@ -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 diff --git a/src/Music/Score/Meta/Barline.hs b/src/Music/Score/Meta/Barline.hs --- a/src/Music/Score/Meta/Barline.hs +++ b/src/Music/Score/Meta/Barline.hs @@ -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 diff --git a/src/Music/Score/Meta/Clef.hs b/src/Music/Score/Meta/Clef.hs --- a/src/Music/Score/Meta/Clef.hs +++ b/src/Music/Score/Meta/Clef.hs @@ -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 diff --git a/src/Music/Score/Meta/Extract.hs b/src/Music/Score/Meta/Extract.hs --- a/src/Music/Score/Meta/Extract.hs +++ b/src/Music/Score/Meta/Extract.hs @@ -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 diff --git a/src/Music/Score/Meta/Fermata.hs b/src/Music/Score/Meta/Fermata.hs --- a/src/Music/Score/Meta/Fermata.hs +++ b/src/Music/Score/Meta/Fermata.hs @@ -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 diff --git a/src/Music/Score/Meta/Key.hs b/src/Music/Score/Meta/Key.hs --- a/src/Music/Score/Meta/Key.hs +++ b/src/Music/Score/Meta/Key.hs @@ -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 diff --git a/src/Music/Score/Meta/Pickup.hs b/src/Music/Score/Meta/Pickup.hs --- a/src/Music/Score/Meta/Pickup.hs +++ b/src/Music/Score/Meta/Pickup.hs @@ -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 diff --git a/src/Music/Score/Meta/RehearsalMark.hs b/src/Music/Score/Meta/RehearsalMark.hs --- a/src/Music/Score/Meta/RehearsalMark.hs +++ b/src/Music/Score/Meta/RehearsalMark.hs @@ -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 diff --git a/src/Music/Score/Meta/Tempo.hs b/src/Music/Score/Meta/Tempo.hs --- a/src/Music/Score/Meta/Tempo.hs +++ b/src/Music/Score/Meta/Tempo.hs @@ -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 diff --git a/src/Music/Score/Meta/Time.hs b/src/Music/Score/Meta/Time.hs --- a/src/Music/Score/Meta/Time.hs +++ b/src/Music/Score/Meta/Time.hs @@ -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 diff --git a/src/Music/Score/Meta/Title.hs b/src/Music/Score/Meta/Title.hs --- a/src/Music/Score/Meta/Title.hs +++ b/src/Music/Score/Meta/Title.hs @@ -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 diff --git a/src/Music/Score/Part.hs b/src/Music/Score/Part.hs --- a/src/Music/Score/Part.hs +++ b/src/Music/Score/Part.hs @@ -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 diff --git a/src/Music/Score/Phrases.hs b/src/Music/Score/Phrases.hs --- a/src/Music/Score/Phrases.hs +++ b/src/Music/Score/Phrases.hs @@ -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 diff --git a/src/Music/Score/Pitch.hs b/src/Music/Score/Pitch.hs --- a/src/Music/Score/Pitch.hs +++ b/src/Music/Score/Pitch.hs @@ -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] diff --git a/src/Music/Score/Ties.hs b/src/Music/Score/Ties.hs --- a/src/Music/Score/Ties.hs +++ b/src/Music/Score/Ties.hs @@ -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 diff --git a/src/Music/Time/Duration.hs b/src/Music/Time/Duration.hs --- a/src/Music/Time/Duration.hs +++ b/src/Music/Time/Duration.hs @@ -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. diff --git a/src/Music/Time/Event.hs b/src/Music/Time/Event.hs --- a/src/Music/Time/Event.hs +++ b/src/Music/Time/Event.hs @@ -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) diff --git a/src/Music/Time/Internal/Quantize.hs b/src/Music/Time/Internal/Quantize.hs deleted file mode 100644 --- a/src/Music/Time/Internal/Quantize.hs +++ /dev/null @@ -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 - diff --git a/src/Music/Time/Internal/Util.hs b/src/Music/Time/Internal/Util.hs --- a/src/Music/Time/Internal/Util.hs +++ b/src/Music/Time/Internal/Util.hs @@ -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 diff --git a/src/Music/Time/Meta.hs b/src/Music/Time/Meta.hs --- a/src/Music/Time/Meta.hs +++ b/src/Music/Time/Meta.hs @@ -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 diff --git a/src/Music/Time/Score.hs b/src/Music/Time/Score.hs --- a/src/Music/Time/Score.hs +++ b/src/Music/Time/Score.hs @@ -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]