music-score 1.7.1 → 1.7.2

raw patch · 59 files changed

+2077/−1176 lines, 59 filesdep +averagedep ~adjunctionsdep ~bifunctorsdep ~comonadPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: average

Dependency ranges changed: adjunctions, bifunctors, comonad, contravariant, distributive, lens, lilypond, music-dynamics-literal, music-pitch-literal, musicxml2, profunctors

API changes (from Hackage documentation)

Files

• music-score.cabal +18/−18
• src/Control/Lens/Cons/Middle.hs +0/−9
• src/Data/Average.hs +0/−127
• src/Data/Functor/Couple.hs +2/−2
• src/Data/List/Ordered.hs +96/−0
• src/Data/Semigroup/Instances.hs +5/−2
• src/Music/Score.hs +0/−4
• src/Music/Score/Articulation.hs +16/−47
• src/Music/Score/Color.hs +18/−2
• src/Music/Score/Convert.hs +0/−179
• src/Music/Score/Dynamics.hs +2/−14
• src/Music/Score/Export/Backend.hs +5/−7
• src/Music/Score/Export/DynamicNotation.hs +16/−2
• src/Music/Score/Export/Lilypond.hs +117/−151
• src/Music/Score/Export/Midi.hs +4/−5
• src/Music/Score/Export/MusicXml.hs +115/−122
• src/Music/Score/Export/NoteList.hs +0/−2
• src/Music/Score/Export/SuperCollider.hs +0/−2
• src/Music/Score/Harmonics.hs +0/−4
• src/Music/Score/Instances.hs +3/−24
• src/Music/Score/Internal/Export.hs +1/−1
• src/Music/Score/Meta.hs +0/−4
• src/Music/Score/Meta/Extract.hs +63/−0
• src/Music/Score/Meta/Pickup.hs +98/−0
• src/Music/Score/Meta/Tempo.hs +20/−0
• src/Music/Score/Part.hs +6/−7
• src/Music/Score/Phrases.hs +104/−26
• src/Music/Score/Pitch.hs +143/−90
• src/Music/Score/Slide.hs +2/−6
• src/Music/Score/Text.hs +11/−5
• src/Music/Score/Ties.hs +4/−1
• src/Music/Score/Tremolo.hs +75/−6
• src/Music/Time.hs +1/−3
• src/Music/Time/Behavior.hs +6/−4
• src/Music/Time/Bound.hs +0/−3
• src/Music/Time/Chord.hs +11/−6
• src/Music/Time/Delayed.hs +29/−17
• src/Music/Time/Future.hs +4/−1
• src/Music/Time/Graces.hs +57/−0
• src/Music/Time/Internal/Convert.hs +175/−0
• src/Music/Time/Internal/Quantize.hs +19/−13
• src/Music/Time/Internal/Transform.hs +119/−50
• src/Music/Time/Internal/Util.hs +15/−1
• src/Music/Time/Juxtapose.hs +2/−54
• src/Music/Time/Meta.hs +21/−15
• src/Music/Time/Nominal.hs +56/−0
• src/Music/Time/Note.hs +23/−5
• src/Music/Time/Past.hs +68/−9
• src/Music/Time/Position.hs +6/−5
• src/Music/Time/Reactive.hs +10/−5
• src/Music/Time/Reverse.hs +5/−4
• src/Music/Time/Score.hs +59/−28
• src/Music/Time/Segment.hs +19/−12
• src/Music/Time/Split.hs +10/−3
• src/Music/Time/Stretched.hs +25/−16
• src/Music/Time/Track.hs +1/−2
• src/Music/Time/Transform.hs +6/−10
• src/Music/Time/Types.hs +182/−20
• src/Music/Time/Voice.hs +204/−21

@@ -1,6 +1,6 @@  name:                   music-score-version:                1.7.1+version:                1.7.2 author:                 Hans Hoglund maintainer:             Hans Hoglund license:                BSD3@@ -21,36 +21,35 @@   location:           git://github.com/music-suite/music-score.git    library-    build-depends:      base                    >= 4       && < 5,+    build-depends:      base                    >= 4 && < 5,                         aeson                   >= 0.7.0.6 && < 1,-                        lens                    >= 4.3 && < 4.4,+                        lens                    >= 4.3.3 && < 4.4,                         process                 >= 1.2 && < 1.3,                         containers,-                         void,                         nats,                                   data-default,+                        average                 >= 0.6 && < 1,                         semigroups              >= 0.13.0.1 && < 1,                         semigroupoids,-                        contravariant           >= 0.4.4 && < 1,-                        comonad,-                        bifunctors,-                        profunctors,-                        distributive,-                        adjunctions             >= 4.1 && < 5,+                        contravariant           >= 1.2 && < 2,+                        comonad                 >= 4.2.2 && < 5,+                        bifunctors              >= 4.1.1.1 && < 5,+                        profunctors             >= 4.2.0.1 && < 5,+                        distributive            >= 0.4.4 && < 5,+                        adjunctions             >= 4.2 && < 5,                         transformers            >= 0.3.0.0 && < 0.5,                         mtl                     >= 2.1.2 && < 2.3,                         monadplus,                         NumInstances,-                         colour                  >= 2.3.3 && < 3.0,                         HCodecs                 >= 0.5 && < 0.6,                         vector-space            >= 0.8.7 && < 0.9,                         vector-space-points     >= 0.2 && < 0.3,-                        musicxml2               == 1.7.1,-                        lilypond                == 1.7.1,-                        music-pitch-literal     == 1.7.1,-                        music-dynamics-literal  == 1.7.1,+                        musicxml2               == 1.7.2,+                        lilypond                == 1.7.2,+                        music-pitch-literal     == 1.7.2,+                        music-dynamics-literal  == 1.7.2,                          prettify,                         parsec@@ -59,10 +58,9 @@                         Data.Functor.Couple                         Data.Functor.Context                         Data.Functor.Rep.Lens+                        Data.List.Ordered                         Data.Semigroup.Instances-                        Data.Average                         Control.Monad.Compose-                        Control.Lens.Cons.Middle                         Music.Time                         Music.Time.Types                         Music.Time.Transform@@ -105,6 +103,8 @@                         Music.Score.Meta.Tempo                         Music.Score.Meta.Time                         Music.Score.Meta.Title+                        Music.Score.Meta.Pickup+                        Music.Score.Meta.Extract                         -- Music.Score.Clef                         Music.Score.Pitch                         Music.Score.Articulation@@ -126,9 +126,9 @@                         Music.Score.Import.Abc                         Music.Score.Import.Lilypond                         Music.Score.Import.Midi-                        Music.Score.Convert                         Music.Score.Instances                         -- We expose these to allow GHCI development+                        Music.Time.Internal.Convert                         Music.Time.Internal.Util                         Music.Time.Internal.Transform                         Music.Time.Internal.Quantize

@@ -1,9 +0,0 @@--module Control.Lens.Cons.Middle (-      _middle-  ) where--import Control.Lens--_middle :: (Snoc s s a a, Cons s s b b) => Traversal' s s-_middle = _tail._init

@@ -1,127 +0,0 @@--{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module Data.Average (-    Average(..),-    average,-    maybeAverage-  ) where--import Prelude hiding ((**))---- import Test.QuickCheck(Arbitrary(..))--import Data.Typeable-import Data.Maybe-import Data.Semigroup-import Data.AdditiveGroup-import Data.VectorSpace-import Data.AffineSpace-import Control.Monad-import Control.Applicative---- |--- A monoid for 'Average' values.------ This is actually just the free monoid with an extra function 'average' for--- extracing the (arithmetic) mean. This function is used to implement 'Real',--- so you can use 'Average' whenever a ('Monoid', 'Real') is required.------ >>> toRational $ mconcat [1,2::Average Rational]--- 3 % 2--- >>> toRational $ mconcat [1,2::Sum Rational]--- 3 % 1--- >>> toRational $ mconcat [1,2::Product Rational]--- 2 % 1----newtype Average a = Average { getAverage :: [a] }-  deriving (Show, {-Enum, Bounded,-} Semigroup, Monoid, -    Typeable, Functor, Applicative)--instance (Fractional a, Eq a) => Eq (Average a) where-  a == b = average a == average b--instance (Fractional a, Ord a) => Ord (Average a) where-  a `compare` b = average a `compare` average b-  --- What should (+) and (*) do for Average values?--- --- The important thing is to preserve scalar addition and multiplication (for example--- scaling all components of) an average value by some constant factor, so we can just as--- well use the standard list instance. What about averages with more components? I *think*--- 'average' is a linear map, so they would work as expected:--- --- >>> average (2<>2<>3)+average (3<>3)--- 16 % 3--- >>> average $ (2<>2<>3)+(3<>3)--- 16 % 3--- >>> average (mconcat [5,6,9])*average (mconcat[-1,0])--- (-10) % 3--- >>> average $ (mconcat [5,6,9])*(mconcat[-1,0])--- (-10) % 3--- --instance Num a => Num (Average a) where-  (+) = liftA2 (+)-  (*) = liftA2 (*)-  negate = fmap negate-  abs    = fmap abs-  signum = fmap signum-  fromInteger = pure . fromInteger-  -instance (Fractional a, Num a) => Fractional (Average a) where-  (/) = liftA2 (/)-  fromRational = pure . fromRational--instance (Real a, Fractional a) => Real (Average a) where-  toRational = toRational . average--instance Floating a => Floating (Average a) where-  pi = pure pi-  exp = fmap exp-  sqrt = fmap sqrt-  log = fmap log-  sin = fmap sin-  tan = fmap tan-  cos = fmap cos-  asin = fmap asin-  atan = fmap atan-  acos = fmap acos-  sinh = fmap sinh-  tanh = fmap tanh-  cosh = fmap cosh-  asinh = fmap asinh-  atanh = fmap atanh-  acosh = fmap acosh-  -instance AdditiveGroup a => AdditiveGroup (Average a) where-  zeroV = pure zeroV-  (^+^) = liftA2 (^+^)-  negateV = fmap negateV--instance VectorSpace a => VectorSpace (Average a) where-  type Scalar (Average a) = Scalar a-  s *^ v = liftA2 (*^) (pure s) v--instance AffineSpace a => AffineSpace (Average a) where-  type Diff (Average a) = Average (Diff a)-  p1 .-. p2 = liftA2 (.-.) p1 p2-  p .+^ v   = liftA2 (.+^) p v--{--instance Arbitrary a => Arbitrary (Average a) where-  arbitrary = fmap Average arbitrary--}---- | Return the average of all monoidal components. If given 'mempty', return zero.-average :: Fractional a => Average a -> a-average = fromMaybe 0 . maybeAverage---- | Return the average of all monoidal components. If given 'mempty', return 'Nothing'.-maybeAverage :: Fractional a => Average a -> Maybe a-maybeAverage (Average []) = Nothing-maybeAverage (Average xs) = Just $ sum xs / fromIntegral (length xs)--

@@ -41,7 +41,7 @@ -- A variant of pair/writer with lifted instances for the numeric classes, using 'Applicative'. -- newtype Twain b a = Twain { getTwain :: (b, a) }-  deriving (Show, Functor, Foldable, Typeable, Applicative, Monad, Comonad, Semigroup, Monoid)+  deriving (Show, Functor, Traversable, Foldable, Typeable, Applicative, Monad, Comonad, Semigroup, Monoid)  instance Wrapped (Twain b a) where   type Unwrapped (Twain b a) = (b, a)@@ -116,7 +116,7 @@ -- A variant of pair/writer with lifted instances for the numeric classes, using 'Applicative'. -- newtype Couple b a = Couple { getCouple :: (b, a) }-  deriving (Show, Functor, Foldable, Typeable, Applicative, Monad, Comonad, Semigroup, Monoid)+  deriving (Show, Functor, Foldable, Traversable, Typeable, Applicative, Monad, Comonad, Semigroup, Monoid)  instance Wrapped (Couple b a) where   type Unwrapped (Couple b a) = (b, a)

@@ -0,0 +1,96 @@++{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ViewPatterns               #-}+{-# LANGUAGE CPP #-}++module Data.List.Ordered where++import           Control.Lens (Iso', iso, Prism', prism')+import           Control.Applicative+import           Control.Comonad+import           Data.Functor.Couple+import           Data.Ord            (comparing)+import           Data.List           (takeWhile, sort, sortBy, group)+import           Data.Maybe+import           Data.Semigroup+import           Control.Monad++import qualified Data.Set as Set+import qualified Data.Map as Map+import Numeric.Natural+++-- TODO full definition+type Positive = Natural+++-- TODO move+#ifndef GHCI+instance Comonad Min where+  extract (Min x) = x+  duplicate (Min x) = Min (Min x)+instance Comonad Max where+  extract (Max x) = x+  duplicate (Max x) = Max (Max x)+#endif++-- TODO move+-- TODO use positive+-- newtype Ordered a = Ordered { getOrdered :: Set.Set (a, Positive) }+-- OR+newtype Ordered a = Ordered { getOrdered :: {-Ord a =>-} Map.Map a Positive }+  deriving ({-, Foldable, Traversable-})++instance (Ord a) => Eq (Ordered a) where+  Ordered a == Ordered b = a == b++instance Ord a => Ord (Ordered a) where+  Ordered a < Ordered b = a < b++-- | Alas, not a functor+map :: (Ord a, Ord b) => (a -> b) -> Ordered a -> Ordered b+map f (Ordered m) = Ordered (Map.mapKeys f m)++toList :: Ordered a -> [a]+toList (Ordered xs) = concatMap (uncurry $ flip $ replicate . fromIntegral) $ Map.toList xs++unsafeFromList :: Ord a => [a] -> Ordered a+unsafeFromList = fromMaybe (error "unsafeFromList: Not sorted") . fromList++-- Safe (but slow) conversion from lists to ordered lists+fromList :: Ord a => [a] -> Maybe (Ordered a)+fromList xs+  | xs /= sort xs = Nothing+  | otherwise     = Just $ Ordered $ Map.fromList $ +    Prelude.map (\x -> (head x, fromIntegral $ Prelude.length x)) $ group xs++-- Safe (but slow) prism from lists to ordered lists+ordered :: Ord a => Prism' [a] (Ordered a)+ordered = prism' toList fromList+{-+  where+    prism' bs sma = prism bs (\s -> maybe (Left s) Right (sma s))+    prism bt seta = dimap seta (either pure (fmap bt)) . right'+-}++unsafeOrdered :: Ord a => Iso' [a] (Ordered a)+unsafeOrdered = iso unsafeFromList toList+{-+  where+    iso sa bt = dimap sa (fmap bt)+-}++elem :: Ord a => a -> Ordered a -> Bool+elem k = (> 0) . occs k    +    +occs :: Ord a => a -> Ordered a -> Int+occs k = maybe 0 fromIntegral . Map.lookup k . getOrdered++null :: Ordered k -> Bool+null = Map.null . getOrdered++length :: Ordered a -> Int+length = Prelude.length . toList+-- elem x (Ordered xs) = x

@@ -16,9 +16,10 @@  -- TODO move these to semigroups and music-pitch-literal -#if (__GLASGOW_HASKELL__ < 781)+#if !MIN_VERSION_base(4,7,0) deriving instance Num a => Num (Sum a) #endif+ deriving instance Real a => Real (Sum a) deriving instance Fractional a => Fractional (Sum a) deriving instance AdditiveGroup a => AdditiveGroup (Sum a)@@ -33,9 +34,10 @@   Sum p .+^ Sum v = Sum (p .+^ v)  -#if (__GLASGOW_HASKELL__ < 781)+#if !MIN_VERSION_base(4,7,0) deriving instance Num a => Num (Product a) #endif+ deriving instance Real a => Real (Product a) deriving instance Fractional a => Fractional (Product a) deriving instance AdditiveGroup a => AdditiveGroup (Product a)@@ -48,6 +50,7 @@   type Diff (Product a) = Product (Diff a)   Product p .-. Product q = Product (p .-. q)   Product p .+^ Product v = Product (p .+^ v)+   deriving instance IsDynamics a => IsDynamics (Sum a)

@@ -9,8 +9,6 @@ -- Stability   : experimental -- Portability : non-portable (TF,GNTD) ----- Provides a musical score representation.--- -------------------------------------------------------------------------------------  module Music.Score (@@ -23,7 +21,6 @@         module Data.VectorSpace,         module Data.AffineSpace,         module Data.AffineSpace.Point,-        module Data.Average,          module Music.Time,         -- module Music.Score.Combinators,@@ -91,7 +88,6 @@ import           Data.Traversable import           Data.Typeable import           Data.VectorSpace               hiding (Sum, getSum)-import           Data.Average  import           Music.Time                     hiding (time) 

@@ -70,18 +70,22 @@          -- * Articulation transformer         ArticulationT(..),++        -- * Context+        varticulation,+        addArtCon,   ) where  import           Control.Applicative import           Control.Comonad import           Control.Lens                  hiding (above, below, transform)-import           Control.Lens.Cons.Middle import           Data.AffineSpace import           Data.Foldable import           Data.Functor.Couple import           Data.Semigroup import           Data.Typeable import           Data.VectorSpace              hiding (Sum)+import           Data.Functor.Context  import           Music.Score.Part import           Music.Time@@ -95,7 +99,6 @@ import           Music.Score.Slide import           Music.Score.Text import           Music.Score.Ties-import           Music.Score.Tremolo   @@ -256,8 +259,6 @@  type instance Articulation (Couple c a)        = Articulation a type instance SetArticulation g (Couple c a)   = Couple c (SetArticulation g a)-type instance Articulation (TremoloT a)        = Articulation a-type instance SetArticulation g (TremoloT a)   = TremoloT (SetArticulation g a) type instance Articulation (TextT a)           = Articulation a type instance SetArticulation g (TextT a)      = TextT (SetArticulation g a) type instance Articulation (HarmonicT a)       = Articulation a@@ -272,11 +273,6 @@ instance (HasArticulation a b) => HasArticulation (Couple c a) (Couple c b) where   articulation = _Wrapped . articulation -instance (HasArticulations a b) => HasArticulations (TremoloT a) (TremoloT b) where-  articulations = _Wrapped . articulations-instance (HasArticulation a b) => HasArticulation (TremoloT a) (TremoloT b) where-  articulation = _Wrapped . articulation- instance (HasArticulations a b) => HasArticulations (TextT a) (TextT b) where   articulations = _Wrapped . articulations instance (HasArticulation a b) => HasArticulation (TextT a) (TextT b) where@@ -319,44 +315,9 @@     accentuation :: Lens' a (Accentuation a)     separation   :: Lens' a (Separation a) -{---- TODO move-instance Num () where-  _ + _ = ()-  _ - _ = ()-  _ * _ = ()-  signum _ = ()-  abs _ = ()-  fromInteger _ = ()--instance Fractional () where-  _ / _ = ()-  fromRational _ = ()--instance VectorSpace () where-  type Scalar () = ()-  _ *^ _ = ()--instance AffineSpace () where-  type Diff () = ()-  _ .-. _ = ()-  _ .+^ _ = ()--instance Articulated () where-  accentuation = id-  separation   = id--}- instance (AffineSpace a, AffineSpace b, Fractional a, Fractional b) => Articulated (a, b) where-  accentuation = _1'-  separation   = _2'--_1' :: Lens' (a, b) a-_1' = _1--_2' :: Lens' (a, b) b-_2' = _2-  +  accentuation = _1+  separation   = _2   accent :: (HasPhrases' s b, HasArticulations' b, Articulation b ~ a, Articulated a) => s -> s@@ -456,7 +417,6 @@ --     rem = liftA2 rem --     toInteger = toInteger . extract --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (ArticulationT p a) where   type Unwrapped (ArticulationT p a) = (p, a)   _Wrapped' = iso getArticulationT ArticulationT@@ -483,3 +443,12 @@     where       (a1,a2) = toTied a       (d1,d2) = toTied d+++-- TODO move+addArtCon :: (+  HasPhrases s t a b, HasArticulation' a, HasArticulation a b, Articulation a ~ d, Articulation b ~ Ctxt d+  ) => s -> t+addArtCon = over (phrases.varticulation) withContext+varticulation = lens (fmap $ view articulation) (flip $ zipVoiceWithNoScale (set articulation))+

@@ -39,6 +39,7 @@         color,         colorRed,         colorBlue,+        colorBlack,          -- * Representation         ColorT(..),@@ -95,7 +96,6 @@ deriving instance Enum a => Enum (ColorT a) deriving instance Bounded a => Bounded (ColorT a) --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (ColorT a) where   type Unwrapped (ColorT a) = Couple (Option (Last (Colour Double))) a   _Wrapped' = iso getColorT ColorT@@ -118,11 +118,27 @@   -- |--- Set the number of tremolo divisions for all notes in the score.+-- Set color of all notes in the score. -- color :: HasColor a => Colour Double -> a -> a color = setColor +-- |+-- Color all notes in the score red.+--+colorRed :: HasColor a => a -> a colorRed = color C.red++-- |+-- Color all notes in the score blue.+--+colorBlue :: HasColor a => a -> a colorBlue = color C.blue++-- |+-- Color all notes in the score black.+--+colorBlack :: HasColor a => a -> a+colorBlack = color C.black+ 

@@ -1,179 +0,0 @@--{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoMonomorphismRestriction  #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE ViewPatterns               #-}------------------------------------------------------------------------------------------ |--- Copyright   : (c) Hans Hoglund 2012-2014------ License     : BSD-style------ Maintainer  : hans@hanshoglund.se--- Stability   : experimental--- Portability : non-portable (TF,GNTD)------ Provides conversion betwen temporal container.------ /Warning/ This module will be removed soon.-------------------------------------------------------------------------------------------module Music.Score.Convert (-        voiceToScore,-        voiceToScore',-        scoreToVoice,-        reactiveToVoice',-  ) where--import           Control.Applicative-import           Control.Lens hiding (transform, time)-import           Control.Monad-import           Control.Monad.Plus-import           Data.AffineSpace-import           Data.AffineSpace.Point-import           Data.Foldable          (Foldable (..))-import           Data.Ord-import           Data.Ratio-import           Data.Semigroup-import           Data.String-import           Data.Traversable-import           Data.VectorSpace--import           Music.Score.Part-import           Music.Time-import           Music.Time.Reactive--import qualified Data.Foldable          as Foldable-import qualified Data.List              as List---{---- | Convert a note to an _onset and a voice.-noteToVoice :: Note a -> (Time, Voice a)-noteToVoice (view (from note) -> (s,x)) = (_onset s, stretchTo (_duration s) $ return x)--}--{---- | Convert a note to a score.-noteToScore :: Note a -> Score a-noteToScore (view (from note) -> (s,x)) = s `transform` return x--}---- scoreToNotes :: Score a -> [Note a]--- scoreToNotes = Foldable.toList . reifyScore---- notesToScore :: [Note a] -> Score a--- notesToScore = pcat . fmap noteToScore--{--reactiveToVoice :: Duration -> Reactive a -> Voice a-reactiveToVoice d r = (^. voice) $ fmap (^. stretched) $ durs `zip` (fmap (r `atTime`) times)-    where-        times = 0 : filter (\t -> 0 < t && t < 0 .+^ d) (occs r)-        durs  = toRelativeTimeN' (0 .+^ d) times--}--reactiveToVoice' :: Span -> Reactive a -> Voice a-reactiveToVoice' (view range -> (u,v)) r = (^. voice) $ fmap (^. stretched) $ durs `zip` (fmap (r `atTime`) times)-    where-        times = 0 : filter (\t -> u < t && t < v) (occs r)-        durs  = toRelativeTimeN' v times-{-# DEPRECATED reactiveToVoice' "" #-}---- |--- Convert a score to a voice. Fails if the score contain overlapping events.----scoreToVoice :: Transformable a => Score a -> Voice (Maybe a)-scoreToVoice = (^. voice) . fmap (^. stretched) . fmap throwTime . addRests . (^. events)-    where-       throwTime (t,d,x) = (d,x)-       addRests = concat . snd . mapAccumL g 0-           where-               g u (t, d, x)-                   | u == t    = (t .+^ d, [(t, d, Just x)])-                   | u <  t    = (t .+^ d, [(u, t .-. u, Nothing), (t, d, Just x)])-                   | otherwise = error "scoreToVoice: Strange prevTime"-{-# DEPRECATED scoreToVoice "" #-}---- |--- Convert a voice to a score.----voiceToScore :: Voice a -> Score a-voiceToScore = scat . fmap g . (^. stretcheds) where g = (^. stretchedValue) . fmap return-{-# DEPRECATED voiceToScore "" #-}--{---- | Join voices in a given part into a score.-voicesToScore :: HasPart a => [(Part a, Voice a)] -> Score a-voicesToScore = pcat . fmap (voiceToScore . uncurry (\n -> fmap (setPart n)))--}---- |--- Convert a voice which may contain rests to a score.----voiceToScore' :: Voice (Maybe a) -> Score a-voiceToScore' = mcatMaybes . voiceToScore-{-# DEPRECATED voiceToScore' "" #-}--{---- |--- Convert a track to a score where each event is given a fixed duration.----trackToScore :: Transformable a => Duration -> Track a -> Score a-trackToScore x = trackToScore' (const x)---- |--- Convert a track to a score, using durations determined by the values.----trackToScore' :: Transformable a => (a -> Duration) -> Track a -> Score a-trackToScore' f = (^. from events) . fmap (\(t,x) -> (t,f x,x)) . map (^. from delayed) . (^. delayeds)--}----- TODO rename during-noteToReactive :: Monoid a => Note a -> Reactive a-noteToReactive n = (pure <$> n) `activate` pure mempty---- JUNK---- | Split a reactive into mkNotes, as well as the values before and after the first/last update-splitReactive :: Reactive a -> Either a ((a, Time), [Note a], (Time, a))-splitReactive r = case updates r of-    []          -> Left  (initial r)-    (t,x):[]    -> Right ((initial r, t), [], (t, x))-    (t,x):xs    -> Right ((initial r, t), fmap mkNote $ mrights (res $ (t,x):xs), head $ mlefts (res $ (t,x):xs))--    where--        mkNote (t,u,x) = (t <-> u, x)^.note--        -- Always returns a 0 or more Right followed by one left-        res :: [(Time, a)] -> [Either (Time, a) (Time, Time, a)]-        res rs = let (ts,xs) = unzip rs in-            flip fmap (withNext ts `zip` xs) $-                \ ((t, mu), x) -> case mu of-                    Nothing -> Left (t, x)-                    Just u  -> Right (t, u, x)--        -- lenght xs == length (withNext xs)-        withNext :: [a] -> [(a, Maybe a)]-        withNext = go-            where-                go []       = []-                go [x]      = [(x, Nothing)]-                go (x:y:rs) = (x, Just y) : withNext (y : rs)--activate :: Note (Reactive a) -> Reactive a -> Reactive a-activate (view (from note) -> (view range -> (start,stop), x)) y = y `turnOn` (x `turnOff` y)-  where-    turnOn  = switchR start-    turnOff = switchR stop-

@@ -61,8 +61,6 @@         DynamicT(..),          -- * Context-        -- TODO move-        Ctxt,         vdynamic,         addDynCon, @@ -91,7 +89,6 @@ import           Music.Score.Slide import           Music.Score.Text import           Music.Score.Ties-import           Music.Score.Tremolo import           Music.Score.Internal.Util     (through) import           Music.Time import           Music.Time.Internal.Transform@@ -266,8 +263,6 @@  type instance Dynamic (Couple c a)        = Dynamic a type instance SetDynamic g (Couple c a)   = Couple c (SetDynamic g a)-type instance Dynamic (TremoloT a)        = Dynamic a-type instance SetDynamic g (TremoloT a)   = TremoloT (SetDynamic g a) type instance Dynamic (TextT a)           = Dynamic a type instance SetDynamic g (TextT a)      = TextT (SetDynamic g a) type instance Dynamic (HarmonicT a)       = Dynamic a@@ -285,13 +280,7 @@   dynamic = _Wrapped . dynamic  -instance (HasDynamics a b) => HasDynamics (TremoloT a) (TremoloT b) where-  dynamics = _Wrapped . dynamics -instance (HasDynamic a b) => HasDynamic (TremoloT a) (TremoloT b) where-  dynamic = _Wrapped . dynamic-- instance (HasDynamics a b) => HasDynamics (TextT a) (TextT b) where   dynamics = _Wrapped . dynamics @@ -376,7 +365,7 @@   HasPosition a, HasDynamics a a,    Dynamic a ~ Behavior c, Fractional c   ) => Duration -> a -> a-fadeIn d x = x & dynamics *~ (_onset x >-> d `transform` unit)+fadeIn d x = x & dynamics *~ ((_onset x >-> d) `transform` unit)  -- | -- Fade in.@@ -385,7 +374,7 @@   HasPosition a, HasDynamics a a,    Dynamic a ~ Behavior c, Fractional c   ) => Duration -> a -> a-fadeOut d x = x & dynamics *~ (d <-< _offset x `transform` rev unit)+fadeOut d x = x & dynamics *~ ((d <-< _offset x) `transform` rev unit)   @@ -437,7 +426,6 @@ --     rem = liftA2 rem --     toInteger = toInteger . extract --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (DynamicT p a) where   type Unwrapped (DynamicT p a) = (p, a)   _Wrapped' = iso getDynamicT DynamicT

@@ -52,23 +52,22 @@ import qualified Data.Foldable import           Data.Functor.Couple import           Data.Maybe+import           Data.Monoid.Average import           Data.Ratio import           Data.Traversable              (Traversable, sequenceA) import qualified Music.Lilypond                as Lilypond import qualified Music.MusicXml.Simple         as MusicXml import           Music.Score.Internal.Export   hiding (MVoice)-import           Music.Time.Internal.Transform (whilstLD) import           System.Process import           Music.Time.Internal.Quantize import qualified Text.Pretty                   as Pretty import qualified Data.List-import           Music.Score.Convert (reactiveToVoice') -- TODO import           Music.Score.Internal.Util (composed, unRatio, swap, retainUpdates) import Music.Score.Export.DynamicNotation import Music.Score.Export.ArticulationNotation import Data.Semigroup import Data.Semigroup.Instances-+import Data.Functor.Context  import Music.Time import Music.Score.Dynamics@@ -106,7 +105,8 @@   Articulation b  ~ Ctxt (Articulation a),   Articulation c ~ ArticulationNotation,   -- TODO generalize-  Articulation a ~ (Sum Double, Sum Double)+  -- Articulated (Articulation a), Real (Separation (Articulation a)), Real (Accentuation (Articulation a))+  Articulation a ~ (Average Double, Average Double)  )  @@ -214,7 +214,5 @@ -- Backend developers are encouraged to provide wrappers on the form 'toX', 'writeX' etc. -- export :: (HasBackendScore b s, HasBackendNote b (BackendScoreEvent b s)) => b -> s -> BackendMusic b-export b = finalizeExport b . export'-  where-    export' = fmap (exportNote b) . exportScore b+export b = finalizeExport b . fmap (exportNote b) . exportScore b 

@@ -34,13 +34,19 @@     CrescDim(..),     DynamicNotation(..),     notateDynamic,+    +    -- * Utility+    removeCloseDynMarks,+    removeDynMark,   ) where  import Data.Semigroup import Data.Functor.Context+import Data.AffineSpace import Control.Lens -- () import Music.Score.Dynamics import Music.Score.Ties+import Music.Score.Phrases import Music.Time  @@ -102,9 +108,17 @@     (EQ,EQ) -> ([],                   False)     (LT,GT) -> ([EndCresc, BeginDim], True)     (GT,LT) -> ([EndDim, BeginCresc], True)--   (Just x,  y, Nothing) -> case (x `compare` y) of     LT      -> ([EndCresc],   True)     EQ      -> ([],           False)     GT      -> ([EndDim],     True)+++removeCloseDynMarks :: (HasPhrases' s a, HasDynamics' a, Dynamic a ~ DynamicNotation, a ~ SetDynamic (Dynamic a) a) => s -> s+removeCloseDynMarks = mapPhrasesWithPrevAndCurrentOnset f+  where+    f Nothing t    = id+    f (Just t1) t2 = if (t2 .-. t1) > 1.5 then id else over (_head.mapped) removeDynMark++removeDynMark :: (HasDynamics' a, Dynamic a ~ DynamicNotation, a ~ SetDynamic (Dynamic a) a) => a -> a+removeDynMark x = set (dynamics' . _Wrapped' . _2) Nothing x

@@ -1,4 +1,5 @@ +{-# LANGUAGE CPP                       #-} {-# LANGUAGE ConstraintKinds           #-} {-# LANGUAGE DefaultSignatures         #-} {-# LANGUAGE DeriveFoldable            #-}@@ -74,9 +75,7 @@ import           System.Process import qualified Text.Pretty                             as Pretty - import           Music.Dynamics.Literal-import qualified Music.Lilypond                          as Lilypond import           Music.Pitch.Literal import           Music.Score.Articulation import           Music.Score.Color@@ -101,6 +100,7 @@ import           Music.Time import           Music.Time.Internal.Quantize +import qualified Music.Lilypond                          as Lilypond   @@ -108,6 +108,12 @@   +#define COMPLEX_POLY_STUFF 1+++++ -- | -- Extract instrument info as per "Music.Part" -- This is really crude, needs rethinking!@@ -156,9 +162,9 @@  {- TODO move-instance Monoid Lilypond.Music where-  mempty      = pcatLy []-  mappend x y = pcatLy [x,y]+instance Monoid LyMusic where+  mempty      = pcatL []+  mappend x y = pcatL [x,y] -}  type LyMusic = Lilypond.Music@@ -171,8 +177,8 @@    finalizeExport _ = finalizeScore     where-      finalizeScore :: LyScore LyMusic -> Lilypond.Music-      finalizeScore (LyScore (info, x)) = pcatLy . map finalizeStaff $ x+      finalizeScore :: LyScore LyMusic -> LyMusic+      finalizeScore (LyScore (info, x)) = pcatL . map finalizeStaff $ x        -- TODO finalizeStaffGroup @@ -181,11 +187,11 @@         = addStaff         . addPartName (staffName info)         . addClef (staffClef info)-        . scatLy . map finalizeBar $ x+        . scatL . map finalizeBar $ x         where           addStaff                = Lilypond.New "Staff" Nothing-          addClef c x             = scatLy [Lilypond.Clef c, x]-          addPartName partName xs = scatLy [longName, shortName, xs]+          addClef c x             = scatL [Lilypond.Clef c, x]+          addPartName partName xs = scatL [longName, shortName, xs]             where               longName  = Lilypond.Set "Staff.instrumentName" (Lilypond.toValue partName)               shortName = Lilypond.Set "Staff.shortInstrumentName" (Lilypond.toValue partName)@@ -200,18 +206,19 @@           -- TODO rehearsal marks           -- TODO bar number change           -- TODO compound time signatures-          setTimeSignature (getTimeSignature -> (ms, n)) x = scatLy [Lilypond.Time (sum ms) n, x]+          setTimeSignature (getTimeSignature -> (ms, n)) x = scatL [Lilypond.Time (sum ms) n, x]        renderBarMusic :: Rhythm LyMusic -> LyMusic       renderBarMusic = go         where           go (Beat d x)            = Lilypond.removeSingleChords x           go (Dotted n (Beat d x)) = Lilypond.removeSingleChords x-          go (Group rs)            = scatLy $ map renderBarMusic rs+          go (Group rs)            = scatL $ map renderBarMusic rs           go (Tuplet m r)          = Lilypond.Times (realToFrac m) (renderBarMusic r)             where               (a,b) = bimap fromIntegral fromIntegral $ unRatio $ realToFrac m +#ifdef COMPLEX_POLY_STUFF instance (   HasDynamicNotation a b c,   HasArticulationNotation c d e,@@ -219,24 +226,46 @@   HasOrdPart a,   Transformable a,   Semigroup a,-  Tiable e,-  HasOrdPart c, Show (Part c), HasLilypondInstrument (Part c)+  Tiable e, HasOrdPart c, Show (Part c), +  HasLilypondInstrument (Part c),+  Satisfied   )   => HasBackendScore Lilypond (Score a) where+#else+instance (+  Tiable a, HasOrdPart a, Show (Part a), +  HasLilypondInstrument (Part a),+  Satisfied+  )+  => HasBackendScore Lilypond (Score a) where+#endif++#ifdef COMPLEX_POLY_STUFF   type BackendScoreEvent Lilypond (Score a) = SetArticulation ArticulationNotation (SetDynamic DynamicNotation a)+#else+  type BackendScoreEvent Lilypond (Score a) = a+#endif+   exportScore b score = LyScore     . (ScoreInfo,)+    -- Store time signatures etc for later use by finalizeScore     . map (uncurry $ exportPart timeSignatureMarks barDurations) +#ifdef COMPLEX_POLY_STUFF+    -- Notate articulation     . map (second $ over articulations notateArticulation)     . map (second $ preserveMeta addArtCon) +    -- Notate dynamics     . map (second $ removeCloseDynMarks)     . map (second $ over dynamics notateDynamic)     . map (second $ preserveMeta addDynCon) +    -- Merge simultaneous chords     . map (second $ preserveMeta simultaneous)-    . extractParts'+#endif++    . extractPartsWithInfo     $ normScore     where       (timeSignatureMarks, barDurations) = extractTimeSignatures normScore@@ -329,10 +358,10 @@ instance HasBackendNote Lilypond Integer where   -- TODO can we get rid of exportChord alltogether and just use LyContext?   exportNote  _ (LyContext d Nothing)    = (^*realToFrac (4*d)) Lilypond.rest-  exportNote  _ (LyContext d (Just x))   = (^*realToFrac (4*d)) $ Lilypond.note $ spellLy x+  exportNote  _ (LyContext d (Just x))   = (^*realToFrac (4*d)) $ Lilypond.note $ spellL x    exportChord _ (LyContext d Nothing)    = (^*realToFrac (4*d)) Lilypond.rest-  exportChord _ (LyContext d (Just xs))  = (^*realToFrac (4*d)) $ Lilypond.chord $ fmap spellLy xs+  exportChord _ (LyContext d (Just xs))  = (^*realToFrac (4*d)) $ Lilypond.chord $ fmap spellL xs  instance HasBackendNote Lilypond Int where   exportNote b = exportNote b . fmap toInteger@@ -364,6 +393,8 @@   exportNote b = exportNote b . fmap extract   exportChord b = exportChord b . fmap (fmap extract) ++#ifdef COMPLEX_POLY_STUFF instance HasBackendNote Lilypond a => HasBackendNote Lilypond (DynamicT DynamicNotation a) where   exportNote b = uncurry notate . getDynamicT . fmap (exportNote b) . sequenceA     where@@ -389,7 +420,12 @@        -- Use rcomposed as notateDynamic returns "mark" order, not application order       rcomposed = composed . reverse+#else+instance HasBackendNote Lilypond a => HasBackendNote Lilypond (DynamicT b a) where+  exportNote b = exportNote b . fmap extract+#endif +#ifdef COMPLEX_POLY_STUFF instance HasBackendNote Lilypond a => HasBackendNote Lilypond (ArticulationT ArticulationNotation a) where   exportNote b = uncurry notate . getArticulationT . fmap (exportNote b) . sequenceA     where@@ -413,6 +449,10 @@        -- Use rcomposed as notateDynamic returns "mark" order, not application order       rcomposed = composed . reverse+#else+instance HasBackendNote Lilypond a => HasBackendNote Lilypond (ArticulationT {-ArticulationNotation-}b a) where+  exportNote b = exportNote b . fmap extract     +#endif  instance HasBackendNote Lilypond a => HasBackendNote Lilypond (ColorT a) where   exportNote b = uncurry notate . getCouple . getColorT . fmap (exportNote b) . sequenceA@@ -436,44 +476,26 @@ instance HasBackendNote Lilypond a => HasBackendNote Lilypond (TremoloT a) where   -- TODO can this instance use the new shorter idiom?   exportNote b (LyContext d x) =-    fst (notate x d) $ exportNote b $ LyContext (snd $ notate x d) (fmap extract x)-    where-      notate Nothing d                               = (id, d)-      notate (Just (TremoloT (Couple (Max 0, _)))) d = (id, d)-      notate (Just (TremoloT (Couple (Max n, _)))) d = let-        scale   = 2^n-        newDur  = (d `min` (1/4)) / scale-        repeats = d / newDur-        in (Lilypond.Tremolo (round repeats), newDur)+    fst (notateTremolo x d) $ exportNote b $ LyContext (snd $ notateTremolo x d) (fmap extract x) + instance HasBackendNote Lilypond a => HasBackendNote Lilypond (TextT a) where-  exportNote b = uncurry notate . getCouple . getTextT . fmap (exportNote b) . sequenceA+  exportNote b = uncurry notateText . getCouple . getTextT . fmap (exportNote b) . sequenceA     where-      notate texts = composed (fmap Lilypond.addText texts) + instance HasBackendNote Lilypond a => HasBackendNote Lilypond (HarmonicT a) where-  exportNote b = uncurry notate . getCouple . getHarmonicT . fmap (exportNote b) . sequenceA-    where-      notate (Any isNat, Sum n) = case (isNat, n) of-        (_,     0) -> id-        (True,  n) -> notateNatural n-        (False, n) -> notateArtificial n-      notateNatural n = Lilypond.addFlageolet -- addOpen?-      notateArtificial n = id -- TODO+  exportNote b = uncurry notateHarmonic . getCouple . getHarmonicT . fmap (exportNote b) . sequenceA  instance HasBackendNote Lilypond a => HasBackendNote Lilypond (SlideT a) where   exportNote b  = uncurry notateGliss . getCouple . getSlideT . fmap (exportNote b) . sequenceA   exportChord b = uncurry notateGliss . getCouple . getSlideT . fmap (exportChord b) . sequenceA . fmap sequenceA -notateGliss ((Any eg, Any es),(Any bg, Any bs))-  | bg  = Lilypond.beginGlissando-  | bs  = Lilypond.beginGlissando-  | otherwise = id  {-   exportNote        :: b -> BC a   -> BN   exportChord       :: b -> BC [a] -> BN-  uncurry notateTie :: ((Any, Any), Lilypond.Music) -> Lilypond.Music+  uncurry notateTie :: ((Any, Any), LyMusic) -> LyMusic      BC (TieT a)        sequenceA   TieT (BC a)        fmap (exportNote b)@@ -490,6 +512,35 @@   exportNote b  = uncurry notateTie . getTieT . fmap (exportNote b) . sequenceA   exportChord b = uncurry notateTie . getTieT . fmap (exportChord b) . sequenceA . fmap sequenceA ++notateTremolo :: RealFrac b => Maybe (TremoloT a) -> b -> (LyMusic -> LyMusic, b)+notateTremolo Nothing d                        = (id, d)+notateTremolo (Just (runTremoloT -> (0, _))) d = (id, d)+notateTremolo (Just (runTremoloT -> (n, _))) d = let+  scale   = 2^n+  newDur  = (d `min` (1/4)) / scale+  repeats = d / newDur+  in (Lilypond.Tremolo (round repeats), newDur)++notateText :: [String] -> LyMusic -> LyMusic+notateText texts = composed (fmap Lilypond.addText texts)++notateHarmonic :: (Eq t, Num t) => (Any, Sum t) -> LyMusic -> LyMusic+notateHarmonic (Any isNat, Sum n) = case (isNat, n) of+  (_,     0) -> id+  (True,  n) -> notateNatural n+  (False, n) -> notateArtificial n+  where+    notateNatural n = Lilypond.addFlageolet -- addOpen?+    notateArtificial n = id -- TODO++notateGliss :: ((Any, Any), (Any, Any)) -> LyMusic -> LyMusic+notateGliss ((Any eg, Any es),(Any bg, Any bs))+  | bg  = Lilypond.beginGlissando+  | bs  = Lilypond.beginGlissando+  | otherwise = id++notateTie :: (Any, Any) -> LyMusic -> LyMusic notateTie (Any ta, Any tb)   | ta && tb  = Lilypond.beginTie   | tb        = Lilypond.beginTie@@ -502,17 +553,16 @@ type HasLilypond a = (HasBackendNote Lilypond (BackendScoreEvent Lilypond a), HasBackendScore Lilypond a)  -- |--- Convert a score to a Lilypond string.----toLilypondString :: HasLilypond a => a -> String-toLilypondString = show . Pretty.pretty . toLilypond---- | -- Convert a score to a Lilypond representation. ---toLilypond :: HasLilypond a => a -> Lilypond.Music+toLilypond :: HasLilypond a => a -> LyMusic toLilypond = export (undefined::Lilypond) +-- |+-- Convert a score to a Lilypond string.+--+toLilypondString :: HasLilypond a => a -> String+toLilypondString = show . Pretty.pretty . toLilypond  -- | -- Convert a score to a Lilypond representaiton and print it on the standard output.@@ -600,7 +650,8 @@   runLilypond >> cleanLilypond >> runOpen     where       runLilypond = void $ runCommand-        "lilypond -f pdf test.ly"  >>= waitForProcess+        -- "lilypond -f pdf test.ly"  >>= waitForProcess+        "lilypond -f pdf test.ly 2>/dev/null"  >>= waitForProcess       cleanLilypond = void $ runCommand         "rm -f test-*.tex test-*.texi test-*.count test-*.eps test-*.pdf test.eps"       runOpen = void $ runCommand@@ -633,123 +684,38 @@   --- TODO move-addArtCon :: (-  HasPhrases s t a b, HasArticulation a a, HasArticulation a b,-  Articulation a ~ d, Articulation b ~ Ctxt d-  ) => s -> t-addArtCon = over (phrases.varticulation) withContext-varticulation = lens (fmap $ view articulation) (flip $ zipVoiceWithNoScale (set articulation)) -removeCloseDynMarks :: (HasPhrases' s a, HasDynamics' a, Dynamic a ~ DynamicNotation, a ~ SetDynamic (Dynamic a) a) => s -> s-removeCloseDynMarks = mapPhrasesWithPrevAndCurrentOnset f-  where-    f Nothing t    = id-    f (Just t1) t2 = if (t2 .-. t1) > 1.5 then id else over (_head.mapped) removeDynMark -removeDynMark :: (HasDynamics' a, Dynamic a ~ DynamicNotation, a ~ SetDynamic (Dynamic a) a) => a -> a-removeDynMark x = set (dynamics' . _Wrapped' . _2) Nothing x --- type PVoice a = [Either Duration (Phrase a)]-type TVoice a = Track (Phrase a) --- foo :: HasPhrases' s a => s -> [TVoice a]-mapPhrasesWithPrevAndCurrentOnset :: HasPhrases s t a b => (Maybe Time -> Time -> Phrase a -> Phrase b) -> s -> t-mapPhrasesWithPrevAndCurrentOnset f = over (mvoices . mVoiceTVoice) (withPrevAndCurrentOnset f) -withPrevAndCurrentOnset :: (Maybe Time -> Time -> a -> b) -> Track a -> Track b-withPrevAndCurrentOnset f = over delayeds (fmap (\(x,y,z) -> fmap (f (fmap _onset x) (_onset y)) y) . withPrevNext)--mVoiceTVoice :: Lens (MVoice a) (MVoice b) (TVoice a) (TVoice b)-mVoiceTVoice = mvoicePVoice . pVoiceTVoice--pVoiceTVoice :: Lens (PVoice a) (PVoice b) (TVoice a) (TVoice b)-pVoiceTVoice = lens pVoiceToTVoice (flip tVoiceToPVoice)-  where-    pVoiceToTVoice :: PVoice a -> TVoice a-    pVoiceToTVoice x = mkTrack $ rights $ map (sequenceA) $ mapZip (offsetPoints (0::Time)) (withDurationR x)--    -- TODO assert no overlapping-    tVoiceToPVoice :: TVoice a -> PVoice b -> PVoice a-    tVoiceToPVoice tv pv = set _rights newPhrases pv-      where-        newPhrases = toListOf traverse tv---_rights :: Lens [Either a b] [Either a c] [b] [c]-_rights = lens _rightsGet (flip _rightsSet)--_rightsGet :: [Either a b] -> [b]-_rightsGet = rights--_rightsSet :: [c] -> [Either a b] -> [Either a c]-_rightsSet cs = sndMapAccumL f cs-  where-    f cs     (Left a)  = (cs, Left a)-    f (c:cs) (Right b) = (cs, Right c)-    f []     (Right _) = error "No more cs"--sndMapAccumL f z = snd . Data.List.mapAccumL f z---- unsafePVoiceTVoice :: Iso (PVoice a) (PVoice b) (TVoice a) (TVoice b)--- unsafePVoiceTVoice = iso pVoiceToTVoice tVoiceToPVoice---   where---     pVoiceToTVoice :: PVoice a -> TVoice a---     pVoiceToTVoice x = mkTrack $ rights $ map (sequenceA) $ mapZip (offsetPoints (0::Time)) (withDurationR x)------     -- TODO assert no overlapping---     tVoiceToPVoice :: TVoice a -> PVoice a---     tVoiceToPVoice = undefined---mapZip :: ([a] -> [b]) -> [(a,c)] -> [(b,c)]-mapZip f = uncurry zip . first f . unzipR--mkTrack :: [(Time, a)] -> Track a-mkTrack = view track . map (view delayed)--withDurationR :: (Functor f, HasDuration a) => f a -> f (Duration, a)-withDurationR = fmap $ \x -> (_duration x, x)---- TODO generalize and move-mapWithDuration :: HasDuration a => (Duration -> a -> b) -> a -> b-mapWithDuration = over dual withDurationL . uncurry-  where-    withDurationL :: (Contravariant f, HasDuration a) => f (Duration, a) -> f a-    withDurationL = contramap $ \x -> (_duration x, x)--    dual :: Iso (a -> b) (c -> d) (Op b a) (Op d c)-    dual = iso Op getOp--dursToVoice :: [Duration] -> Voice ()-dursToVoice = mconcat . map (\d -> stretch d $ return ())---- *Music.Score.Export.Lilypond> print $ view (mVoiceTVoice) $ (fmap Just (dursToVoice [1,2,1]) <> return Nothing <> return (Just ()))                                                                             --- TODO This function is a workaround--- Whenever it is used, we should make the original function preserve meta instead-preserveMeta :: (HasMeta a, HasMeta b) => (a -> b) -> a -> b-preserveMeta f x = let m = view meta x in set meta m (f x)--pcatLy :: [Lilypond.Music] -> Lilypond.Music-pcatLy = pcatLy' False+pcatL :: [LyMusic] -> LyMusic+pcatL = pcatL' False -pcatLy' :: Bool -> [Lilypond.Music] -> Lilypond.Music-pcatLy' p = foldr Lilypond.simultaneous (Lilypond.Simultaneous p [])+pcatL' :: Bool -> [LyMusic] -> LyMusic+pcatL' p = foldr Lilypond.simultaneous (Lilypond.Simultaneous p []) -scatLy :: [Lilypond.Music] -> Lilypond.Music-scatLy = foldr Lilypond.sequential (Lilypond.Sequential [])+scatL :: [LyMusic] -> LyMusic+scatL = foldr Lilypond.sequential (Lilypond.Sequential []) -spellLy :: Integer -> Lilypond.Note-spellLy a = Lilypond.NotePitch (spellLy' a) Nothing+spellL :: Integer -> Lilypond.Note+spellL a = Lilypond.NotePitch (spellL' a) Nothing -spellLy' :: Integer -> Lilypond.Pitch-spellLy' p = Lilypond.Pitch (+spellL' :: Integer -> Lilypond.Pitch+spellL' p = Lilypond.Pitch (   toEnum $ fromIntegral pc,   fromIntegral alt,   fromIntegral oct   )   where (pc,alt,oct) = spellPitch (p + 72)++-- | A constraint that is always satisfied.+type Satisfied = (() ~ ())++-- | A constraint that is never satisfied.+type Unsatisfied = (() ~ Bool)+ 

@@ -1,3 +1,4 @@+ {-# LANGUAGE TupleSections              #-} {-# LANGUAGE ViewPatterns               #-} {-# LANGUAGE ConstraintKinds            #-}@@ -54,12 +55,10 @@ import qualified Music.Lilypond                as Lilypond import qualified Music.MusicXml.Simple         as MusicXml import           Music.Score.Internal.Export   hiding (MVoice)-import           Music.Time.Internal.Transform (whilstLD) import           System.Process import           Music.Time.Internal.Quantize import qualified Text.Pretty                   as Pretty import qualified Data.List-import Music.Score.Convert (reactiveToVoice') -- TODO import           Music.Score.Internal.Util (composed, unRatio, swap, retainUpdates) import Music.Score.Export.DynamicNotation import Data.Semigroup.Instances@@ -190,7 +189,7 @@  instance (HasPart' a, Ord (Part a), HasMidiProgram (Part a)) => HasBackendScore Midi (Score a) where   type BackendScoreEvent Midi (Score a) = a-  exportScore _ xs = MidiScore (map (\(p,sc) -> ((getMidiChannel p, getMidiProgram p), fmap Identity sc)) $ extractParts' $ fixTempo xs)+  exportScore _ xs = MidiScore (map (\(p,sc) -> ((getMidiChannel p, getMidiProgram p), fmap Identity sc)) $ extractPartsWithInfo $ fixTempo xs)     where       -- We actually want to extract *all* tempo changes and transform the score appropriately       -- For the time being, we assume the whole score has the same tempo@@ -218,11 +217,11 @@   exportChord b = exportChord b . fmap (fmap (! 0))  -instance HasBackendNote Midi a => HasBackendNote Midi (DynamicT (Sum Double) a) where+instance (Real d, HasBackendNote Midi a) => HasBackendNote Midi (DynamicT d a) where   -- TODO   -- We have not standarized dynamic levels   -- Assume for now -6.5 to 6.5 where (-3.5 is ppp, -0.5 is mp, 0.5 is mf, 3.5 is fff etc)-  exportNote b (Identity (DynamicT (Sum d, x))) = setV (dynLevel d) <$> exportNote b (Identity x)+  exportNote b (Identity (DynamicT (realToFrac -> d, x))) = setV (dynLevel d) <$> exportNote b (Identity x)   dynLevel :: Double -> Midi.Velocity

@@ -1,20 +1,20 @@ -{-# LANGUAGE TupleSections              #-}-{-# LANGUAGE ViewPatterns               #-}-{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE DefaultSignatures          #-}-{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE DeriveTraversable          #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE NoMonomorphismRestriction  #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE RankNTypes                 #-}-{-# LANGUAGE StandaloneDeriving         #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE ConstraintKinds           #-}+{-# LANGUAGE DefaultSignatures         #-}+{-# LANGUAGE DeriveFoldable            #-}+{-# LANGUAGE DeriveFunctor             #-}+{-# LANGUAGE DeriveTraversable         #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE StandaloneDeriving        #-}+{-# LANGUAGE TupleSections             #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE UndecidableInstances      #-}+{-# LANGUAGE ViewPatterns              #-}  ------------------------------------------------------------------------------------- -- |@@ -34,75 +34,74 @@     MusicXml,     XmlContext(..),     HasMusicXml,-    +     -- ** Converting to MusicXml     toMusicXml,-    toMusicXmlString,    -    +    toMusicXmlString,+     -- ** MusicXml I/O     showMusicXml,     openMusicXml,     writeMusicXml,   ) where -import           Music.Dynamics.Literal-import           Music.Pitch.Literal-import qualified Codec.Midi                    as Midi-import           Control.Comonad               (Comonad (..), extract)+import qualified Codec.Midi                              as Midi import           Control.Applicative+import           Control.Comonad                         (Comonad (..), extract)+import           Control.Lens                            hiding (rewrite)+import           Control.Monad+import           Data.AffineSpace import           Data.Bifunctor-import           Data.Colour.Names             as Color+import           Data.Colour.Names                       as Color import           Data.Default-import           Data.Foldable                 (Foldable)+import           Data.Foldable                           (Foldable) import qualified Data.Foldable import           Data.Functor.Couple+import           Data.Functor.Identity+import qualified Data.List import           Data.Maybe import           Data.Ratio-import           Data.Traversable              (Traversable, sequenceA)-import qualified Music.Lilypond                as Lilypond-import qualified Music.MusicXml.Simple         as MusicXml-import           Music.Score.Internal.Export   hiding (MVoice)-import           Music.Time.Internal.Transform (whilstLD)+import           Data.Semigroup+import           Data.Semigroup.Instances+import           Data.Traversable                        (Traversable,+                                                          sequenceA)+import           Data.VectorSpace                        hiding (Sum (..)) import           System.Process-import           Music.Time.Internal.Quantize-import qualified Text.Pretty                   as Pretty-import qualified Data.List-import Music.Score.Convert (reactiveToVoice') -- TODO-import           Music.Score.Internal.Util (composed, unRatio, swap, retainUpdates)-import Music.Score.Export.DynamicNotation-import Music.Score.Export.ArticulationNotation-import Data.Semigroup.Instances -import Music.Score.Export.Backend -import Data.Functor.Identity-import Data.Semigroup-import Control.Monad-import Data.VectorSpace hiding (Sum(..))-import Data.AffineSpace-import Control.Lens hiding (rewrite)--- import Control.Lens.Operators hiding ((|>))+import           Music.Dynamics.Literal+import           Music.Pitch.Literal+import           Music.Score.Articulation+import           Music.Score.Color+import           Music.Time.Internal.Convert             (reactiveToVoice')+import           Music.Score.Dynamics+import           Music.Score.Export.ArticulationNotation+import           Music.Score.Export.Backend+import           Music.Score.Export.DynamicNotation+import           Music.Score.Harmonics+import           Music.Score.Internal.Export             hiding (MVoice)+import           Music.Score.Internal.Util               (composed,+                                                          retainUpdates, swap,+                                                          unRatio)+import           Music.Score.Meta+import           Music.Score.Meta.Attribution+import           Music.Score.Meta.Tempo+import           Music.Score.Meta.Time+import           Music.Score.Meta.Title+import           Music.Score.Part+import           Music.Score.Phrases+import           Music.Score.Slide+import           Music.Score.Text+import           Music.Score.Ties+import           Music.Score.Tremolo+import           Music.Time+import           Music.Time.Internal.Quantize -import Music.Time-import Music.Score.Meta-import Music.Score.Meta.Title-import Music.Score.Meta.Attribution-import Music.Score.Dynamics-import Music.Score.Articulation-import Music.Score.Part-import Music.Score.Tremolo-import Music.Score.Text-import Music.Score.Harmonics-import Music.Score.Slide-import Music.Score.Color-import Music.Score.Ties-import Music.Score.Export.Backend-import Music.Score.Meta.Time-import Music.Score.Meta.Tempo-import Music.Score.Phrases+import qualified Text.Pretty                             as Pretty+import qualified Music.MusicXml.Simple                   as MusicXml  --- | +-- | -- Extract instrument info as per "Music.Part" -- This is really crude, needs rethinking! --@@ -112,7 +111,7 @@   --- TODO move +-- TODO move deriving instance Show MusicXml.Line deriving instance Show MusicXml.ClefSign -- deriving instance Eq MusicXml.PartList@@ -129,7 +128,7 @@ -- | A token to represent the MusicXml backend. data MusicXml -data ScoreInfo = ScoreInfo { scoreTitle :: String,+data ScoreInfo = ScoreInfo { scoreTitle    :: String,                              scoreComposer :: String,                              scorePartList :: MusicXml.PartList,                              scoreTempo    :: Tempo@@ -137,10 +136,10 @@   deriving (Eq, Show)  -data StaffInfo = StaffInfo { staffClef :: (MusicXml.ClefSign, MusicXml.Line) } +data StaffInfo = StaffInfo { staffClef :: (MusicXml.ClefSign, MusicXml.Line) }   deriving (Eq, Show) -data BarInfo = BarInfo { x_barTimeSignature :: Maybe TimeSignature } +data BarInfo = BarInfo { x_barTimeSignature :: Maybe TimeSignature }   deriving (Eq, Show)  -- | Hierachical representation of a MusicXml score.@@ -153,7 +152,7 @@   deriving (Functor, Eq, Show)  -- | A bar is a sequential composition of chords/notes/rests.-data XmlBar a = XmlBar { getXmlBar :: (BarInfo, Rhythm a) } +data XmlBar a = XmlBar { getXmlBar :: (BarInfo, Rhythm a) }   deriving (Functor, Eq, Show)  -- | Context passed to the note export.@@ -175,8 +174,8 @@     where  finalizeScore :: XmlScore MusicXml.Music -> MusicXml.Score-finalizeScore (XmlScore (info, x)) -  = MusicXml.fromParts title composer partList +finalizeScore (XmlScore (info, x))+  = MusicXml.fromParts title composer partList   . map (finalizeStaff tempo) $ x   where     title    = scoreTitle info@@ -187,8 +186,8 @@ -- TODO finalizeStaffGroup  finalizeStaff :: Tempo -> XmlStaff MusicXml.Music -> [MusicXml.Music]-finalizeStaff tempo (XmlStaff (info, x)) -  = id +finalizeStaff tempo (XmlStaff (info, x))+  = id   -- Staff name is not added here as MusicXML uses a separate part list   . addStartInfo   . addClef (staffClef info)@@ -218,15 +217,15 @@  finalizeBar :: XmlBar MusicXml.Music -> MusicXml.Music finalizeBar (XmlBar (BarInfo timeSignature, x))-  = maybe id setBarTimeSignature timeSignature +  = maybe id setBarTimeSignature timeSignature   . renderBarMusic $ x   where     -- TODO key signatures     -- TODO rehearsal marks     -- TODO bar number change     -- TODO compound time signatures-    setBarTimeSignature (getTimeSignature -> (ms, n)) x = mconcat [MusicXml.time (fromIntegral $ sum ms) (fromIntegral n), x]    -          +    setBarTimeSignature (getTimeSignature -> (ms, n)) x = mconcat [MusicXml.time (fromIntegral $ sum ms) (fromIntegral n), x]+ renderBarMusic :: Rhythm MusicXml.Music -> MusicXml.Music renderBarMusic = go   where@@ -248,13 +247,13 @@   )   => HasBackendScore MusicXml (Score a) where   type BackendScoreEvent MusicXml (Score a) = SetDynamic DynamicNotation a-  exportScore b score = XmlScore +  exportScore b score = XmlScore     . (ScoreInfo title composer partList tempo,)     . map (uncurry $ exportPart timeSignatureMarks barDurations)-    . map (second (over dynamics notateDynamic)) +    . map (second (over dynamics notateDynamic))     . map (second (preserveMeta addDynCon))-    . map (second (preserveMeta simultaneous)) -    . extractParts'+    . map (second (preserveMeta simultaneous))+    . extractPartsWithInfo     . normalizeScore     $ score     where@@ -262,46 +261,46 @@       composer = fromMaybe "" $ flip getAttribution "composer" $ metaAtStart score       partList = MusicXml.partList (fmap show $ allParts score)       tempo    = (metaAtStart score :: Tempo)-      (timeSignatureMarks, barDurations) = extractTimeSignatures score +      (timeSignatureMarks, barDurations) = extractTimeSignatures score         -- | Export a score as a single part. Overlapping notes will cause an error.       exportPart :: (         Tiable a,         HasMusicXmlInstrument (Part a)-        ) -        => [Maybe TimeSignature] -        -> [Duration] -        -> Part a -        -> Score a +        )+        => [Maybe TimeSignature]+        -> [Duration]+        -> Part a+        -> Score a         -> XmlStaff (XmlContext a) -      exportStaff :: Tiable a -        => [Maybe TimeSignature] -        -> [Duration] +      exportStaff :: Tiable a+        => [Maybe TimeSignature]+        -> [Duration]         -> Int    -- ^ clef, as per Music.Parts-        -> MVoice a +        -> MVoice a         -> XmlStaff (XmlContext a) -      exportBar :: Tiable a -        => Maybe TimeSignature -        -> MVoice a +      exportBar :: Tiable a+        => Maybe TimeSignature+        -> MVoice a         -> XmlBar (XmlContext a) -      quantizeBar :: Tiable a -        => MVoice a +      quantizeBar :: Tiable a+        => MVoice a         -> Rhythm (XmlContext a)        exportPart timeSignatureMarks barDurations part         = exportStaff timeSignatureMarks barDurations (getMusicXmlClef part)         . view singleMVoice -      exportStaff timeSignatures barDurations clefId -        = XmlStaff +      exportStaff timeSignatures barDurations clefId+        = XmlStaff         . addStaffInfo-        . zipWith exportBar timeSignatures +        . zipWith exportBar timeSignatures         . splitIntoBars barDurations-        where         +        where           clef = case clefId of             0 -> (MusicXml.GClef, 2)             1 -> (MusicXml.CClef, 3)@@ -310,11 +309,11 @@           splitIntoBars = splitTiesVoiceAt        exportBar timeSignature-        = XmlBar -        . addBarInfo +        = XmlBar+        . addBarInfo         . quantizeBar        where-         addBarInfo = (,) $ BarInfo timeSignature+         addBarInfo = (,) $ BarInfo timeSignature        quantizeBar = mapWithDur XmlContext . rewrite . handleErrors . quantize . view eventsV         where@@ -327,7 +326,7 @@ {-   Note:     We want all note transformers to be applicative morphisms, i.e.-      +       notate (pure x)   = pure (notate x)      Specifically@@ -339,8 +338,8 @@       exportNote b = uncurry notate . fmap (exportNote b) . getTieT . sequenceA     The latter looks a lot like cotraverse. Generalization?-   -      ++ -}  instance HasBackendNote MusicXml a => HasBackendNote MusicXml [a] where@@ -349,7 +348,7 @@ instance HasBackendNote MusicXml Integer where   -- TODO can we get rid of exportChord alltogether and just use XmlContext?   exportNote  _ (XmlContext d Nothing)    = MusicXml.rest (realToFrac d)-  exportNote  _ (XmlContext d (Just x))   = (`MusicXml.note` realToFrac d)  . spellMusicXml . fromIntegral $ x+  exportNote  _ (XmlContext d (Just x))   = (`MusicXml.note` realToFrac d)  . spellMusicXml . fromIntegral $ x    exportChord _ (XmlContext d Nothing)    = MusicXml.rest (realToFrac d)   exportChord _ (XmlContext d (Just xs))  = (`MusicXml.chord` realToFrac d) . fmap (spellMusicXml . fromIntegral) $ xs@@ -390,8 +389,8 @@ instance HasBackendNote MusicXml a => HasBackendNote MusicXml (DynamicT DynamicNotation a) where   exportNote b = uncurry notate . fmap (exportNote b) . getDynamicT . sequenceA     where-      notate (DynamicNotation (crescDims, level)) -        = composed (fmap notateCrescDim crescDims) +      notate (DynamicNotation (crescDims, level))+        = composed (fmap notateCrescDim crescDims)         . notateLevel level        notateCrescDim crescDims = case crescDims of@@ -405,7 +404,7 @@       notateLevel showLevel = case showLevel of          Nothing -> id          Just lvl -> (<>) $ MusicXml.dynamic (fromDynamics (DynamicsL (Just (fixLevel . realToFrac $ lvl), Nothing)))-      +       fixLevel :: Double -> Double       fixLevel x = fromIntegral (round (x - 0.5)) + 0.5 @@ -419,7 +418,7 @@   --     notate (ArticulationNotation (slurs, marks))   --       = composed (fmap notateMark marks)   --       . composed (fmap notateSlur slurs)-  -- +  --   --     notateMark mark = case mark of   --       NoMark         -> id   --       Staccato       -> MusicXml.staccato@@ -427,7 +426,7 @@   --       Marcato        -> MusicXml.strongAccent   --       Accent         -> MusicXml.accent   --       Tenuto         -> MusicXml.tenuto-  -- +  --   --     notateSlur slurs = case slurs of   --       NoSlur    -> id   --       BeginSlur -> MusicXml.beginSlur@@ -442,7 +441,7 @@       -- TODO handle any color       notate (Option Nothing)             = id       notate (Option (Just (Last color))) = \x -> MusicXml.Sequential [-        MusicXml.Override "NoteHead#' color" +        MusicXml.Override "NoteHead#' color"           (MusicXml.toLiteralValue $ "#" ++ colorName color),         x,         MusicXml.Revert "NoteHead#' color"@@ -455,12 +454,12 @@         | otherwise        = error "MusicXml backend: Unkown color" -} instance HasBackendNote MusicXml a => HasBackendNote MusicXml (TremoloT a) where-  exportNote b = uncurry notate . fmap (exportNote b) . getCouple . getTremoloT . sequenceA+  exportNote b = uncurry notate . fmap (exportNote b) . runTremoloT . sequenceA     where-      notate (Max n) = case n of+      notate n = case n of         0 -> id         n -> MusicXml.tremolo (fromIntegral n)-    + instance HasBackendNote MusicXml a => HasBackendNote MusicXml (TextT a) where   exportNote b = uncurry notate . fmap (exportNote b) . getCouple . getTextT . sequenceA     where@@ -480,8 +479,8 @@       -- Most programs do not recognize the harmonic tag       -- We set a single diamond notehead instead, which can be manually replaced       notateArtificial n = id -- TODO-       + instance HasBackendNote MusicXml a => HasBackendNote MusicXml (SlideT a) where   exportNote b = uncurry notateX . fmap (exportNote b) . getCouple . getSlideT . sequenceA     where@@ -551,11 +550,5 @@     fromIntegral oct     )     where (pc,alt,oct) = spellPitch (p + 60)---- TODO This function is a workaround--- Whenever it is used, we should make the original function preserve meta instead-preserveMeta :: (HasMeta a, HasMeta b) => (a -> b) -> a -> b-preserveMeta f x = let m = view meta x in set meta m (f x) -- End internal- 

@@ -52,12 +52,10 @@ import qualified Music.Lilypond                as Lilypond import qualified Music.MusicXml.Simple         as MusicXml import           Music.Score.Internal.Export   hiding (MVoice)-import           Music.Time.Internal.Transform (whilstLD) import           System.Process import           Music.Time.Internal.Quantize import qualified Text.Pretty                   as Pretty import qualified Data.List-import Music.Score.Convert (reactiveToVoice') -- TODO import           Music.Score.Internal.Util (composed, unRatio, swap, retainUpdates) import Music.Score.Export.DynamicNotation import Data.Semigroup.Instances

@@ -60,12 +60,10 @@ import qualified Music.Lilypond                as Lilypond import qualified Music.MusicXml.Simple         as MusicXml import           Music.Score.Internal.Export   hiding (MVoice)-import           Music.Time.Internal.Transform (whilstLD) import           System.Process import           Music.Time.Internal.Quantize import qualified Text.Pretty                   as Pretty import qualified Data.List-import Music.Score.Convert (reactiveToVoice') -- TODO import           Music.Score.Internal.Util (composed, unRatio, swap, retainUpdates) import Music.Score.Export.DynamicNotation import Data.Semigroup.Instances

@@ -24,8 +24,6 @@ -- -- Provides a representation of harmonics.  ----- /Warning/ This module is experimental.--- -------------------------------------------------------------------------------------  module Music.Score.Harmonics (@@ -84,8 +82,6 @@   setNatural b = fmap (setNatural b)   setHarmonic n = fmap (setHarmonic n) ---- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (HarmonicT a) where   type Unwrapped (HarmonicT a) = Couple (Any, Sum Int) a   _Wrapped' = iso getHarmonicT HarmonicT

@@ -21,8 +21,7 @@ -- Stability   : experimental -- Portability : non-portable (TF,GNTD) ----- Instances for note transformers. This module should be imported as part--- of "Music.Score".+-- Provides miscellaneous instances. -- ------------------------------------------------------------------------------------- @@ -34,7 +33,7 @@ import           Control.Monad import           Data.AffineSpace import           Data.Default-import           Data.Average+import           Data.Monoid.Average import           Data.Foldable import           Data.Functor.Adjunction  (unzipR) import           Data.Functor.Couple@@ -45,6 +44,7 @@ import           Data.Typeable import           Data.VectorSpace hiding (Sum) import           Data.Semigroup.Instances+import           Data.Functor.Context  import           Music.Dynamics.Literal import           Music.Pitch.Alterable@@ -78,8 +78,6 @@     (<>) = liftA2 (<>) instance Semigroup a => Semigroup (TextT a) where     (<>) = liftA2 (<>)-instance Semigroup a => Semigroup (TremoloT a) where-    (<>) = liftA2 (<>) instance Semigroup a => Semigroup (PartT n a) where     PartT (v1,x1) <> PartT (v2,x2) = PartT (v1, x1 <> x2) @@ -179,15 +177,8 @@ deriving instance HasSlide a => HasSlide (TieT a) deriving instance HasText a => HasText (TieT a) -instance Tiable a => Tiable (TremoloT a) where-    toTied = unzipR . fmap toTied -type instance Part (TremoloT a) = Part a-deriving instance HasHarmonic a => HasHarmonic (TremoloT a)-deriving instance HasSlide a => HasSlide (TremoloT a)-deriving instance HasText a => HasText (TremoloT a) - -- TextT  instance Tiable a => Tiable (TextT a) where@@ -218,15 +209,7 @@   -deriving instance (Monoid b, IsPitch a) => IsPitch (Couple b a)-deriving instance (Monoid b, IsDynamics a) => IsDynamics (Couple b a)-deriving instance (Monoid b, Transformable a) => Transformable (Couple b a)-deriving instance (Monoid b, Reversible a) => Reversible (Couple b a)-deriving instance (Monoid b, Alterable a) => Alterable (Couple b a)-deriving instance (Monoid b, Augmentable a) => Augmentable (Couple b a) -deriving instance IsPitch a => IsPitch (TremoloT a)-deriving instance IsDynamics a => IsDynamics (TremoloT a) deriving instance IsPitch a => IsPitch (TextT a) deriving instance IsDynamics a => IsDynamics (TextT a) deriving instance IsPitch a => IsPitch (HarmonicT a)@@ -248,22 +231,18 @@ deriving instance Transformable a => Transformable (SlideT a) deriving instance Transformable a => Transformable (HarmonicT a) deriving instance Transformable a => Transformable (TextT a)-deriving instance Transformable a => Transformable (TremoloT a)  deriving instance Reversible a => Reversible (SlideT a) deriving instance Reversible a => Reversible (HarmonicT a) deriving instance Reversible a => Reversible (TextT a)-deriving instance Reversible a => Reversible (TremoloT a)  deriving instance Alterable a => Alterable (SlideT a) deriving instance Alterable a => Alterable (HarmonicT a) deriving instance Alterable a => Alterable (TextT a)-deriving instance Alterable a => Alterable (TremoloT a)  deriving instance Augmentable a => Augmentable (SlideT a) deriving instance Augmentable a => Augmentable (HarmonicT a) deriving instance Augmentable a => Augmentable (TextT a)-deriving instance Augmentable a => Augmentable (TremoloT a)   

@@ -50,7 +50,7 @@ import           Data.VectorSpace  import           Music.Score.Articulation-import           Music.Score.Convert      (reactiveToVoice', scoreToVoice)+import           Music.Time.Internal.Convert import           Music.Score.Dynamics import           Music.Score.Part import           Music.Score.Pitch

@@ -22,10 +22,6 @@ -- Stability   : experimental -- Portability : non-portable (TF,GNTD) ----- Combinators for manipulating scores and related structures.------ /Warning/ This module is experimental.--- -------------------------------------------------------------------------------------  module Music.Score.Meta (

@@ -0,0 +1,63 @@++{-# LANGUAGE FlexibleContexts #-}++-- Utility to extract meta-data at a specific point in time.+module Music.Score.Meta.Extract where++import Control.Lens+import Control.Monad++import Music.Score.Meta.Attribution+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++import Music.Time+import Music.Time.Meta++attributionAt :: HasMeta a => Time -> String -> a -> Maybe String+attributionAt t n x = join+  $ fmap (`getAttribution` n)+  $ fmap (`atTime` t)+  $ unwrapMeta+  $ x^.meta++-- TODO get all *set* attributions+attributionsAt :: HasMeta a => Time -> a -> [(String, Maybe String)]+attributionsAt t x = [+  ("composer", attributionAt t "composer" x),+  ("lyricist", attributionAt t "lyricist" x)+  -- TODO etc+  ]++-- TODO rename getTitleAt etc in Meta.Title to prevent confunsion+titleAt :: HasMeta a => Time -> a -> Maybe Title+titleAt _ _ = Nothing++-- TODO key++-- TODO time++-- TODO tempo++partNames :: (HasParts' a, Show (Part a)) => a -> [String]+partNames = fmap show . toListOf parts'++commonMetaAt :: HasMeta a => Time -> a -> [(String, Maybe String)]+commonMetaAt t x = +  ("title", join $ fmap getTitle1 $ titleAt t x) +  : ("subtitle", join $ fmap getTitle2 $ titleAt t x) +  : ("subsubtitle", join $ fmap getTitle3 $ titleAt t x) +  : attributionsAt t x+  where+    getTitle1 = (`getTitleAt` 0)+    getTitle2 = (`getTitleAt` 1)+    getTitle3 = (`getTitleAt` 2)++--     >>> commonMetaAt 0 $ asScore $ composer "Hans" $ lyricist "Sondheim" c    +--     [("title",Nothing),("subtitle",Nothing),("subsubtitle",Nothing),("composer",Just "Hans"),("lyricist",Just "Sondheim")]++

@@ -0,0 +1,98 @@++{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeFamilies               #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-- Provides tempo meta-data.+--+-- /Warning/ This is not supported by any backends yet.+--+-------------------------------------------------------------------------------------++module Music.Score.Meta.Pickup (+        -- * Pickup type+        Pickup,+        +        -- TODO++  ) where+++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+import           Data.Map                  (Map)+import qualified Data.Map                  as Map+import           Data.Maybe+import           Data.Semigroup+import           Data.Set                  (Set)+import qualified Data.Set                  as Set+import           Data.String+import           Data.Traversable          (Traversable)+import qualified Data.Traversable          as T+import           Data.Typeable+import           Data.Void++import           Music.Pitch.Literal+import           Music.Score.Meta+import           Music.Score.Part+import           Music.Score.Pitch+import           Music.Score.Internal.Util+import           Music.Time+import           Music.Time.Reactive++-- | Represents a rehearsal mark.+--+-- TODO this needs zero-duration spans to work properly.+data Pickup = Pickup (Maybe String) Int+    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+    mappend = (<>)++instance Show Pickup where+    show (Pickup name level) = "A" -- TODo+++-- metronome :: Duration -> Bpm -> Tempo+-- metronome noteVal bpm = Tempo Nothing (Just noteVal) $ 60 / (bpm * noteVal)++rehearsalMark :: (HasMeta a, HasPosition a) => Pickup -> a -> a+rehearsalMark c x = rehearsalMarkDuring (_getEra x) c x++rehearsalMarkDuring :: HasMeta a => Span -> Pickup -> a -> a+rehearsalMarkDuring s x = addMetaNote $ view note (s, x)++withPickup :: (Pickup -> Score a -> Score a) -> Score a -> Score a+withPickup = withMeta+

@@ -42,6 +42,16 @@         tempo,         tempoDuring, +        -- ** Common tempi+        presto,+        allegro,+        allegretto,+        moderato,+        andante,+        adagio,+        largo,+        lento,+                 -- * Extracting tempo         renderTempo,   ) where@@ -308,6 +318,16 @@   -}++presto     = metronome (1/4) 125+allegro    = metronome (1/4) 115+allegretto = metronome (1/4) 105+moderato   = metronome (1/4) 95+andante    = metronome (1/4) 85+adagio     = metronome (1/4) 65+largo      = metronome (1/4) 55+lento      = metronome (1/4) 45+   -- TODO consolidate

@@ -49,10 +49,10 @@          -- * Extracting parts         extracted,-        extracted',+        extractedWithInfo,         extractPart,         extractParts,-        extractParts',+        extractPartsWithInfo,          -- * Manipulating parts @@ -240,14 +240,14 @@ filterPart :: (MonadPlus f, HasPart a a) => (Part a -> Bool) -> f a -> f a filterPart p = mfilter (\x -> p (x ^. part)) -extractParts' :: (Ord (Part a), HasPart' a) => Score a -> [(Part a, Score a)]-extractParts' x = zip (allParts x) (extractParts x)+extractPartsWithInfo :: (Ord (Part a), HasPart' a) => Score a -> [(Part a, Score a)]+extractPartsWithInfo x = zip (allParts x) (extractParts x)  extracted :: (Ord (Part a), HasPart' a{-, HasPart a b-}) => Iso (Score a) (Score b) [Score a] [Score b] extracted = iso extractParts mconcat -extracted' :: (Ord (Part a), Ord (Part b), HasPart' a, HasPart' b) => Iso (Score a) (Score b) [(Part a, Score a)] [(Part b, Score b)]-extracted' = iso extractParts' $ mconcat . fmap (uncurry $ set parts')+extractedWithInfo :: (Ord (Part a), Ord (Part b), HasPart' a, HasPart' b) => Iso (Score a) (Score b) [(Part a, Score a)] [(Part b, Score b)]+extractedWithInfo = iso extractPartsWithInfo $ mconcat . fmap (uncurry $ set parts')   @@ -255,7 +255,6 @@   deriving (Eq, Ord, Show, Typeable, Functor,     Applicative, Comonad, Monad, Transformable) --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (PartT p a) where   type Unwrapped (PartT p a) = (p, a)   _Wrapped' = iso getPartT PartT

@@ -24,8 +24,6 @@ -- -- This module provides phrase-wise traversal. ----- /Warning/ This module is experimental.--- -------------------------------------------------------------------------------------  module Music.Score.Phrases (@@ -39,26 +37,54 @@     Phrase,     MVoice,     PVoice,+    TVoice,      -- ** Utility-    mvoicePVoice,-    unsafeMvoicePVoice,+    mVoicePVoice,+    mVoiceTVoice,+    pVoiceTVoice,+    unsafeMVoicePVoice,     singleMVoice,+    mapPhrasesWithPrevAndCurrentOnset,   ) where  import           Control.Applicative-import           Control.Exception   (assert)+import           Control.Applicative+import           Control.Comonad            (Comonad (..), extract)+import           Control.Exception          (assert) import           Control.Lens+import           Control.Lens               hiding (rewrite)+import           Control.Monad import           Control.Monad.Plus import           Data.AffineSpace-import qualified Data.List           as List+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.Couple+import qualified Data.List                  as List+import qualified Data.List import           Data.Maybe+import           Data.Maybe import           Data.Ord+import           Data.Ratio import           Data.Semigroup+import           Data.Semigroup+import           Data.Traversable+import           Data.Traversable           (Traversable, sequenceA)+import           Data.VectorSpace           hiding (Sum (..))+import           System.Process  import           Music.Score.Part-import           Music.Score.Convert import           Music.Time+import           Music.Time.Internal.Convert+import           Music.Time.Internal.Util   -- |@@ -106,7 +132,7 @@   -- | Traverses all phrases in a voice. instance HasPhrases (PVoice a) (PVoice b) a b where   -- Note: This is actually OK in 'phr', as that just becomes (id . each . _Right)-  mvoices = from unsafeMvoicePVoice+  mvoices = from unsafeMVoicePVoice  -- | Traverses all phrases in each voice, using 'extracted'. instance (HasPart' a, {-HasPart a b, -}{-Transformable a,-} Ord (Part a)) =>@@ -119,7 +145,7 @@ Phrase traversal for score:  phrasesS :: (Ord (Part a), HasPart' a, Transformable a) => Traversal' (Score a) (Phrase a)-phrasesS = extracted . each . singleMVoice . mvoicePVoice . each . _Right+phrasesS = extracted . each . singleMVoice . mVoicePVoice . each . _Right  More generally: -}@@ -134,14 +160,13 @@ -- A generic phrase-traversal. -- phrases :: HasPhrases s t a b => Traversal s t (Phrase a) (Phrase b)-phrases = mvoices . mvoicePVoice . each . _Right+phrases = mvoices . mVoicePVoice . each . _Right  -- | -- View an 'MVoice' as a 'PVoice'. ---mvoicePVoice :: Lens (MVoice a) (MVoice b) (PVoice a) (PVoice b)-mvoicePVoice = unsafeMvoicePVoice--- TODO rename mVoicePVoice!+mVoicePVoice :: Lens (MVoice a) (MVoice b) (PVoice a) (PVoice b)+mVoicePVoice = unsafeMVoicePVoice -- TODO meta  -- |@@ -149,9 +174,8 @@ -- -- This a valid 'Iso' up to meta-data equivalence. ---unsafeMvoicePVoice :: Iso (MVoice a) (MVoice b) (PVoice a) (PVoice b)-unsafeMvoicePVoice = iso mvoiceToPVoice pVoiceToMVoice--- TODO rename unsafeMVoicePVoice!+unsafeMVoicePVoice :: Iso (MVoice a) (MVoice b) (PVoice a) (PVoice b)+unsafeMVoicePVoice = iso mvoiceToPVoice pVoiceToMVoice   where     mvoiceToPVoice :: MVoice a -> PVoice a     mvoiceToPVoice =@@ -177,12 +201,8 @@     phraseToVoice = fmap Just  --- -- TODO failure--- TODO why Transformable?-singleMVoice :: {-Transformable a =>-} Prism (Score a) (Score b) (MVoice a) (MVoice b)+singleMVoice :: Prism (Score a) (Score b) (MVoice a) (MVoice b) singleMVoice = iso scoreToVoice voiceToScore'   where     scoreToVoice :: {-Transformable a =>-} Score a -> MVoice a@@ -207,13 +227,71 @@     voiceToScore' = mcatMaybes . voiceToScore  --- instance (Transformable a, Transformable b) => Cons (Phrase a) (Phrase b) a b where-  -- _Cons = undefined--- instance (Transformable a, Transformable b) => Snoc (Phrase a) (Phrase b) a b where-  -- _Snoc = prism' pure (preview lastV)+-- foo :: HasPhrases' s a => s -> [TVoice a]+mapPhrasesWithPrevAndCurrentOnset :: HasPhrases s t a b => (Maybe Time -> Time -> Phrase a -> Phrase b) -> s -> t+mapPhrasesWithPrevAndCurrentOnset f = over (mvoices . mVoiceTVoice) (withPrevAndCurrentOnset f) +withPrevAndCurrentOnset :: (Maybe Time -> Time -> a -> b) -> Track a -> Track b+withPrevAndCurrentOnset f = over delayeds (fmap (\(x,y,z) -> fmap (f (fmap _onset x) (_onset y)) y) . withPrevNext) --- TODO move+mVoiceTVoice :: Lens (MVoice a) (MVoice b) (TVoice a) (TVoice b)+mVoiceTVoice = mVoicePVoice . pVoiceTVoice++pVoiceTVoice :: Lens (PVoice a) (PVoice b) (TVoice a) (TVoice b)+pVoiceTVoice = lens pVoiceToTVoice (flip tVoiceToPVoice)+  where+    pVoiceToTVoice :: PVoice a -> TVoice a+    pVoiceToTVoice x = mkTrack $ rights $ map (sequenceA) $ firsts (offsetPoints (0::Time)) (withDurationR x)++    -- TODO assert no overlapping+    tVoiceToPVoice :: TVoice a -> PVoice b -> PVoice a+    tVoiceToPVoice tv pv = set _rights newPhrases pv+      where+        newPhrases = toListOf traverse tv+++_rights :: Lens [Either a b] [Either a c] [b] [c]+_rights = lens _rightsGet (flip _rightsSet)+  where+    _rightsGet :: [Either a b] -> [b]+    _rightsGet = rights++    _rightsSet :: [c] -> [Either a b] -> [Either a c]+    _rightsSet cs = sndMapAccumL f cs+      where+        f cs     (Left a)  = (cs, Left a)+        f (c:cs) (Right b) = (cs, Right c)+        f []     (Right _) = error "No more cs"++    sndMapAccumL f z = snd . List.mapAccumL f z++firsts :: ([a] -> [b]) -> [(a,c)] -> [(b,c)]+firsts f = uncurry zip . first f . unzipR++mkTrack :: [(Time, a)] -> Track a+mkTrack = view track . map (view delayed)++withDurationR :: (Functor f, HasDuration a) => f a -> f (Duration, a)+withDurationR = fmap $ \x -> (_duration x, x)++-- TODO generalize and move+mapWithDuration :: HasDuration a => (Duration -> a -> b) -> a -> b+mapWithDuration = over dual withDurationL . uncurry+  where+    withDurationL :: (Contravariant f, HasDuration a) => f (Duration, a) -> f a+    withDurationL = contramap $ \x -> (_duration x, x)++    dual :: Iso (a -> b) (c -> d) (Op b a) (Op d c)+    dual = iso Op getOp++dursToVoice :: [Duration] -> Voice ()+dursToVoice = mconcat . map (\d -> stretch d $ return ())++{-+>>> print $ view (mVoiceTVoice) $ (fmap Just (dursToVoice [1,2,1]) <> return Nothing <> return (Just ()))+++-}  -- | -- Group contigous sequences matching/not-matching the predicate.

@@ -35,31 +35,27 @@  module Music.Score.Pitch (         -        -- * Pitch type functions+        -- * Pitch type         Pitch,         SetPitch,         Interval,         -        -- * Accessing pitch-        HasPitches(..),+        -- * HasPitch classes         HasPitch(..),+        HasPitches(..),+        fromPitch',+         -- ** Simple versions-        HasPitches',         HasPitch',+        HasPitches',         pitch',         pitches',         -        -- * Converting pitch to container-        fromPitch',-        -        -- * Manipulating pitch-        Transposable,+        -- * Transposition         up,         down,         above,         below,-        inv,-        invertPitches,         octavesUp,         octavesDown,         octavesAbove,@@ -68,23 +64,30 @@         fifthsDown,         fifthsAbove,         fifthsBelow,-        -- ** Utility         _15va,         _8va,         _8vb,         _15vb, -        -- * Inspecting pitch-        highestPitch,-        lowestPitch,+        -- * Inversion+        inv,+        invertPitches,++        -- * Folds+        highest,+        lowest,         meanPitch, -        -- * Intervals-        augmentIntervals,+        -- -- * Intervals+        -- augmentIntervals,          -- TODO pitchIs, to write filter pitchIs ... etc         -- TODO gliss etc +        PitchPair,+        AffinePair,+        Transposable,+           ) where  import           Control.Applicative@@ -109,64 +112,59 @@ import           Music.Score.Slide import           Music.Score.Text import           Music.Score.Ties-import           Music.Score.Tremolo+-- import           Music.Score.Tremolo import           Music.Score.Phrases import           Music.Time import           Music.Time.Internal.Transform  -- |--- This type fuction is used to retrive the /pitch type/ for a given concrete type.------ For types representing pitch, it is generally 'Identity', i.e------ @--- Pitch Integer ~ Integer--- Pitch Double ~ Double--- @------ and so on.+-- This type fuction is used to access the pitch type for a given type. ----- For containers, 'Pitch' provides a morphism:+type family Pitch (s :: *) :: * -- -- @ -- 'Pitch' (c,a)             ~ 'Pitch' a -- 'Pitch' [a]               ~ 'Pitch' a -- 'Pitch' ('Note' a)          ~ 'Pitch' a--- 'Pitch' ('Delayed' a)       ~ 'Pitch' a--- 'Pitch' ('Stretched' a)     ~ 'Pitch' a -- 'Pitch' ('Voice' a)         ~ 'Pitch' a--- 'Pitch' ('Chord' a)         ~ 'Pitch' a--- 'Pitch' ('Track' a)         ~ 'Pitch' a -- 'Pitch' ('Score' a)         ~ 'Pitch' a -- @ ---type family Pitch (s :: *) :: *---- |--- This type fuction is used to retrive the /pitch type/ for a given concrete type.------ For types representing pitch, it is generally 'Constant', i.e+-- For types representing pitch, it is generally 'Identity', i.e -- -- @--- SetPitch a Double ~ a--- SetPitch a Integer ~ a+-- Pitch Integer ~ Integer+-- Pitch Double ~ Double -- @ --+-- and so on.+-- -- For containers, 'Pitch' provides a morphism: --++-- |+-- This type fuction is used to update the pitch type for a given type.+-- The first argument is the new type.+--+type family SetPitch (b :: *) (s :: *) :: *+-- -- @ -- 'SetPitch' b (c,a)          ~ (c, 'SetPitch' b a) -- 'SetPitch' b [a]            ~ ['SetPitch' b a] -- 'SetPitch' g ('Note' a)       ~ Note ('SetPitch' g a)--- 'SetPitch' g ('Delayed' a)    ~ Delayed ('SetPitch' g a)--- 'SetPitch' g ('Stretched' a)  ~ Stretched ('SetPitch' g a) -- 'SetPitch' g ('Voice' a)      ~ 'Voice' ('SetPitch' g a)--- 'SetPitch' g ('Chord' a)      ~ 'Chord' ('SetPitch' g a)--- 'SetPitch' g ('Track' a)      ~ 'Track' ('SetPitch' g a) -- 'SetPitch' g ('Score' a)      ~ 'Score' ('SetPitch' g a) -- @ ---type family SetPitch (b :: *) (s :: *) :: *+-- For types representing pitch, it is generally 'Constant', i.e+--+-- @+-- SetPitch a Double ~ a+-- SetPitch a Integer ~ a+-- @+--+-- For containers, 'SetPitch' provides a morphism:+--  -- | -- Class of types that provide a single pitch.@@ -179,20 +177,18 @@   --   for example:   --   --   @-  --   'view' 'pitch' :: HasPitch a a-  --   @-  ---  --   @-  --   'over' 'pitch'         :: HasPitch' a => a -> Pitch a-  --   'pitch' %~ 'succ'      :: HasPitch' a => a -> a-  --   'pitch' +~ 2         :: (HasPitch' a, Num (Pitch a)) => a -> a-  --   'pitch' .~ c         :: (HasPitch' a, IsPitch a) => a -> a+  --   'pitch' .~ c    :: ('HasPitch'' a, 'IsPitch' a)      => a -> a+  --   'pitch' +~ 2    :: ('HasPitch'' a, 'Num' ('Pitch' a))  => a -> a+  --   'pitch' %~ 'succ' :: ('HasPitch'' a, 'Enum' ('Pitch' a)) => a -> a+  --   'view' 'pitch'    :: 'HasPitches'' a                 => a -> 'Pitch' a+  --   'set'  'pitch'    :: 'HasPitches' a b                => 'Pitch' b -> a -> b+  --   'over' 'pitch'    :: 'HasPitches' a b                => ('Pitch' a -> 'Pitch' b) -> a -> b   --   @   --   pitch :: Lens s t (Pitch s) (Pitch t)  -- |--- Class of types that provide a pitch traversal.+-- Class of types that provide zero or more pitches. -- class (Transformable (Pitch s),        Transformable (Pitch t),@@ -204,15 +200,11 @@   --   for example:   --   --   @-  --   'lengthOf' 'pitches' :: HasPitches a a => a -> Int-  --   @-  ---  --   @-  --   'toListOf' 'pitches' :: HasPitches' a => a -> Pitch a-  --   @-  ---  --   @-  --   'over' 'pitches' :: HasPitches a b => a -> b+  --   'toListOf' 'pitches'  :: 'HasPitches'' a                  => a -> ['Pitch' a]+  --   'allOf' 'pitches'     :: ('HasPitches'' a)                => ('Pitch' a -> 'Bool') -> a -> 'Bool'+  --   'maximumOf' 'pitches' :: ('HasPitches'' a, 'Ord' ('Pitch' a)) => a -> 'Maybe' ('Pitch' a)+  --   'set'  'pitches'      :: 'HasPitches' a b                 => 'Pitch' b -> a -> b+  --   'over' 'pitches'      :: 'HasPitches' a b                 => ('Pitch' a -> 'Pitch' b) -> a -> b   --   @   --   pitches :: Traversal s t (Pitch s) (Pitch t)@@ -222,25 +214,31 @@ type HasPitches' a = HasPitches a a  --- |--- Pitch type.+-- | +-- Access the pitch. --+-- Same as 'pitch', but without polymorphic update.+-- pitch' :: (HasPitch s t, s ~ t) => Lens' s (Pitch s) pitch' = pitch {-# INLINE pitch' #-} --- |--- Pitch type.+-- | +-- Access all pitches.+-- +-- Same as 'pitches', but without polymorphic update. -- pitches' :: (HasPitches s t, s ~ t) => Traversal' s (Pitch s) pitches' = pitches {-# INLINE pitches' #-} ---- TODO flip name of this and Literal.fromPitch (or call that fromPitchL)+-- |+-- Inject a pitch into some larger type.+-- fromPitch' :: (HasPitches' a, IsPitch a) => Pitch a -> a fromPitch' x = c & pitches' .~ x {-# INLINE fromPitch' #-}+-- TODO swap name of this and Music.Pitch.Literal.fromPitch (or call that something else, i.e. fromPitchL)   #define PRIM_PITCH_INSTANCE(TYPE)       \@@ -357,8 +355,7 @@  type instance Pitch (Couple c a)        = Pitch a type instance SetPitch g (Couple c a)   = Couple c (SetPitch g a)-type instance Pitch (TremoloT a)        = Pitch a-type instance SetPitch g (TremoloT a)   = TremoloT (SetPitch g a)+ type instance Pitch (TextT a)           = Pitch a type instance SetPitch g (TextT a)      = TextT (SetPitch g a) type instance Pitch (HarmonicT a)       = Pitch a@@ -372,12 +369,7 @@   pitches = _Wrapped . pitches instance (HasPitch a b) => HasPitch (Couple c a) (Couple c b) where   pitch = _Wrapped . pitch--instance (HasPitches a b) => HasPitches (TremoloT a) (TremoloT b) where-  pitches = _Wrapped . pitches-instance (HasPitch a b) => HasPitch (TremoloT a) (TremoloT b) where-  pitch = _Wrapped . pitch-+   instance (HasPitches a b) => HasPitches (TextT a) (TextT b) where   pitches = _Wrapped . pitches instance (HasPitch a b) => HasPitch (TextT a) (TextT b) where@@ -404,38 +396,70 @@ -- type Interval a = Diff (Pitch a) +type PitchPair  v w = (Num (Scalar v), IsInterval v, IsPitch w)+type AffinePair v w = (VectorSpace v, AffineSpace w)+ -- | -- Class of types that can be transposed, inverted and so on. ---type Transposable a-  = (HasPitches a a,-     VectorSpace (Interval a), AffineSpace (Pitch a),-     IsInterval (Interval a), IsPitch (Pitch a),-     Num (Scalar (Interval a)))+type Transposable a = (+  HasPitches' a,+  AffinePair (Interval a) (Pitch a),+  PitchPair (Interval a) (Pitch a)+  )  -- |--- Transpose up.+-- Transpose pitch upwards. --+-- Not to be confused with matrix transposition.+--+-- >>> up m3 c+-- eb+--+-- >>> up _P5 [c,d,e :: Pitch]+-- [g,a,b]+--+-- >>> up _P5 [440 :: Hertz, 442, 810]+-- [g,a,b]+-- up :: Transposable a => Interval a -> a -> a up v = pitches %~ (.+^ v)+{-# INLINE up #-}  -- |--- Transpose down.+-- Transpose pitch downwards. --+-- Not to be confused with matrix transposition.+--+-- >>> down m3 c+-- a+--+-- >>> down _P5 [c,d,e]+-- [f_,g_,a_]+-- down :: Transposable a => Interval a -> a -> a down v = pitches %~ (.-^ v)+{-# INLINE down #-}  -- | -- Add the given interval above. --+-- >>> above _P8 [c]+-- [c,c']+-- above :: (Semigroup a, Transposable a) => Interval a -> a -> a above v x = x <> up v x+{-# INLINE above #-}  -- | -- Add the given interval below. --+-- >>> below _P8 [c]+-- [c,c_]+-- below :: (Semigroup a, Transposable a) => Interval a -> a -> a below v x = x <> down v x+{-# INLINE below #-}  inv :: Transposable a => Pitch a -> a -> a inv = invertPitches@@ -450,80 +474,109 @@ -- | -- Transpose up by the given number of octaves. --+-- >>> octavesUp 2 c+-- c''+--+-- >>> octavesUp 1 [c,d,e]+-- [c',d',e']+--+-- >>> octavesUp (-1) [c,d,e]+-- [c_,d_,e_]+-- octavesUp :: Transposable a => Scalar (Interval a) -> a -> a octavesUp n = up (_P8^*n)+{-# INLINE octavesUp #-}  -- | -- Transpose down by the given number of octaves. --+-- >>> octavesDown 2 c+-- c__+--+-- >>> octavesDown 1 [c,d,e]+-- [c_,d_,e_]+--+-- >>> octavesDown (-1) [c,d,e]+-- [c',d',e']+-- octavesDown :: Transposable a => Scalar (Interval a) -> a -> a octavesDown n = down (_P8^*n)+{-# INLINE octavesDown #-}  -- | -- Add the given octave above. -- octavesAbove :: (Semigroup a, Transposable a) => Scalar (Interval a) -> a -> a octavesAbove n = above (_P8^*n)+{-# INLINE octavesAbove #-}  -- | -- Add the given octave below. -- octavesBelow :: (Semigroup a, Transposable a) => Scalar (Interval a) -> a -> a octavesBelow n = below (_P8^*n)+{-# INLINE octavesBelow #-}  -- | -- Transpose up by the given number of fifths. -- fifthsUp :: Transposable a => Scalar (Interval a) -> a -> a fifthsUp n = up (_P8^*n)+{-# INLINE fifthsUp #-}  -- | -- Transpose down by the given number of fifths. -- fifthsDown :: Transposable a => Scalar (Interval a) -> a -> a fifthsDown n = down (_P8^*n)+{-# INLINE fifthsDown #-}  -- | -- Add the given octave above. -- fifthsAbove :: (Semigroup a, Transposable a) => Scalar (Interval a) -> a -> a fifthsAbove n = above (_P8^*n)+{-# INLINE fifthsAbove #-}  -- | -- Add the given octave below. -- fifthsBelow :: (Semigroup a, Transposable a) => Scalar (Interval a) -> a -> a fifthsBelow n = below (_P8^*n)+{-# INLINE fifthsBelow #-}  -- | Shorthand for @'octavesUp' 2@. _15va :: Transposable a => a -> a _15va = octavesUp 2+{-# INLINE _15va #-}  -- | Shorthand for @'octavesUp' 1@. _8va :: Transposable a => a -> a _8va  = octavesUp 1+{-# INLINE _8va #-}  -- | Shorthand for @'octavesDown' 1@. _8vb :: Transposable a => a -> a _8vb  = octavesDown 1+{-# INLINE _8vb #-}  -- | Shorthand for @'octavesDown' 2@. _15vb :: Transposable a => a -> a _15vb = octavesDown 2-+{-# INLINE _15vb #-}   -- | -- Return the highest pitch in the given music. ---highestPitch :: (HasPitches' a, Ord (Pitch a)) => a -> Pitch a-highestPitch = maximum . toListOf pitches'+highest :: (HasPitches' a, Ord (Pitch a)) => a -> Maybe (Pitch a)+highest = maximumOf pitches'  -- | -- Return the lowest pitch in the given music. ---lowestPitch :: (HasPitches' a, Ord (Pitch a)) => a -> Pitch a-lowestPitch = maximum . toListOf pitches'+lowest :: (HasPitches' a, Ord (Pitch a)) => a -> Maybe (Pitch a)+lowest = minimumOf pitches'  -- | -- Return the mean pitch in the given music.

@@ -25,8 +25,6 @@ -- Provides a representation of musical /slides/, commonly known as /glissando/ or -- /portamento/.  ----- /Warning/ This module is experimental.--- -------------------------------------------------------------------------------------  module Music.Score.Slide (@@ -40,7 +38,6 @@ import           Control.Applicative import           Control.Comonad import           Control.Lens            hiding (transform)-import           Control.Lens.Cons.Middle import           Data.Foldable import           Data.Foldable import           Data.Functor.Couple@@ -104,7 +101,6 @@ newtype SlideT a = SlideT { getSlideT :: Couple ((Any, Any), (Any, Any)) a }   deriving (Eq, Show, Ord, Functor, Foldable, Typeable, Applicative, Monad, Comonad) --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (SlideT a) where   type Unwrapped (SlideT a) = Couple ((Any, Any), (Any, Any)) a   _Wrapped' = iso getSlideT SlideT@@ -138,7 +134,7 @@ slide :: (HasPhrases' s a, HasSlide a) => s -> s slide = mapPhraseWise3 (setBeginSlide True) (setBeginSlide True . setEndSlide True) (setEndSlide True)   where-    mapPhraseWise3 f g h = over phrases' (over _head f . over _middle g . over _last h)+    mapPhraseWise3 f g h = over phrases' (over _head f . over (_tail . _init) g . over _last h)  -- | -- Add a glissando between the first and the last note.@@ -146,4 +142,4 @@ glissando :: (HasPhrases' s a, HasSlide a) => s -> s glissando = mapPhraseWise3 (setBeginGliss True) (setBeginGliss True . setEndGliss True) (setEndGliss True)   where-    mapPhraseWise3 f g h = over phrases' (over _head f . over _middle g . over _last h)+    mapPhraseWise3 f g h = over phrases' (over _head f . over (_tail . _init) g . over _last h)

@@ -28,12 +28,11 @@   module Music.Score.Text (-         -- * Text         HasText(..),         TextT(..),         text,-+        textLast,   ) where  import           Control.Applicative@@ -84,7 +83,6 @@ instance HasText a => HasText (Score a) where   addText s = fmap (addText s) --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (TextT a) where   type Unwrapped (TextT a) = Couple [String] a   _Wrapped' = iso getTextT TextT@@ -104,9 +102,17 @@ deriving instance (Real a, Enum a, Integral a) => Integral (TextT a)  -- |--- Attach the given text to the first note in the score.+-- Attach the given text to the first note. -- text :: (HasPhrases' s a, HasText a) => String -> s -> s-text s = over (phrases'._head) (addText s)+text s = over (phrases' . _head) (addText s)++-- |+-- Attach the given text to the last note.+--+textLast :: (HasPhrases' s a, HasText a) => String -> s -> s+textLast s = over (phrases' . _last) (addText s)++  

@@ -53,6 +53,7 @@ import           Data.Ratio import           Data.Semigroup import           Data.Typeable+import           Data.Monoid.Average import           Data.VectorSpace        hiding (Sum)  import           Music.Dynamics.Literal@@ -96,7 +97,6 @@ newtype TieT a = TieT { getTieT :: ((Any, Any), a) }   deriving (Eq, Ord, Show, Functor, Foldable, Typeable, Applicative, Monad, Comonad) --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (TieT a) where   type Unwrapped (TieT a) = ((Any, Any), a)   _Wrapped' = iso getTieT TieT@@ -129,6 +129,9 @@   toTied = unzipR . fmap toTied  instance Tiable a => Tiable (Maybe a) where+  toTied = unzipR . fmap toTied++instance Tiable a => Tiable (Average a) where   toTied = unzipR . fmap toTied  instance Tiable a => Tiable (Sum a) where

@@ -28,12 +28,13 @@   module Music.Score.Tremolo (-         -- * Tremolo         HasTremolo(..),-        TremoloT(..),         tremolo, +        -- ** Tremolo note transformer+        TremoloT,+        runTremoloT,   ) where  import           Control.Applicative@@ -46,6 +47,7 @@ import           Data.Semigroup import           Data.Typeable import           Data.Word+import           Data.Functor.Adjunction  (unzipR)  import           Music.Dynamics.Literal import           Music.Pitch.Alterable@@ -53,6 +55,20 @@ import           Music.Pitch.Literal import           Music.Score.Part import           Music.Score.Phrases+import           Music.Dynamics.Literal+import           Music.Pitch.Alterable+import           Music.Pitch.Augmentable+import           Music.Pitch.Literal+import           Music.Score.Articulation+-- import           Music.Score.Color+import           Music.Score.Dynamics+import           Music.Score.Harmonics+import           Music.Score.Meta+import           Music.Score.Part+import           Music.Score.Pitch+import           Music.Score.Slide+import           Music.Score.Text+import           Music.Score.Ties import           Music.Time  class HasTremolo a where@@ -70,8 +86,27 @@ instance HasTremolo a => HasTremolo (Score a) where   setTrem n = fmap (setTrem n) +-- |+-- Set the number of tremolo divisions for all notes in the score.+--+tremolo :: HasTremolo a => Int -> a -> a+tremolo = setTrem  +++-- TODO these must be moved upwards+deriving instance (Monoid b, IsPitch a) => IsPitch (Couple b a)+deriving instance (Monoid b, IsDynamics a) => IsDynamics (Couple b a)+deriving instance (Monoid b, Transformable a) => Transformable (Couple b a)+deriving instance (Monoid b, Reversible a) => Reversible (Couple b a)+deriving instance (Monoid b, Alterable a) => Alterable (Couple b a)+deriving instance (Monoid b, Augmentable a) => Augmentable (Couple b a)+instance Tiable a => Tiable (Couple b a) where+  toTied = unzipR . fmap toTied+++ newtype TremoloT a = TremoloT { getTremoloT :: Couple (Max Word) a }     deriving (Eq, Show, Ord, Functor, Foldable, Typeable, Applicative, Monad, Comonad) --@@ -79,7 +114,6 @@ -- Preferably we would use Natural but unfortunately this is not an instance of Bounded -- --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (TremoloT a) where   type Unwrapped (TremoloT a) = Couple (Max Word) a   _Wrapped' = iso getTremoloT TremoloT@@ -98,9 +132,44 @@ deriving instance (Num a, Ord a, Real a) => Real (TremoloT a) deriving instance (Real a, Enum a, Integral a) => Integral (TremoloT a) +deriving instance IsPitch a => IsPitch (TremoloT a)+deriving instance IsDynamics a => IsDynamics (TremoloT a)+deriving instance Semigroup a => Semigroup (TremoloT a)+deriving instance Tiable a => Tiable (TremoloT a)++deriving instance HasHarmonic a => HasHarmonic (TremoloT a)+deriving instance HasSlide a => HasSlide (TremoloT a)+deriving instance HasText a => HasText (TremoloT a)+deriving instance Transformable a => Transformable (TremoloT a)+deriving instance Reversible a => Reversible (TremoloT a)+deriving instance Alterable a => Alterable (TremoloT a)+deriving instance Augmentable a => Augmentable (TremoloT a)++type instance Pitch (TremoloT a)              = Pitch a+type instance SetPitch g (TremoloT a)         = TremoloT (SetPitch g a)+type instance Dynamic (TremoloT a)            = Dynamic a+type instance SetDynamic g (TremoloT a)       = TremoloT (SetDynamic g a)+type instance Articulation (TremoloT a)       = Articulation a+type instance SetArticulation g (TremoloT a)  = TremoloT (SetArticulation g a)++instance (HasPitches a b) => HasPitches (TremoloT a) (TremoloT b) where+  pitches = _Wrapped . pitches+instance (HasPitch a b) => HasPitch (TremoloT a) (TremoloT b) where+  pitch = _Wrapped . pitch++instance (HasDynamics a b) => HasDynamics (TremoloT a) (TremoloT b) where+  dynamics = _Wrapped . dynamics+instance (HasDynamic a b) => HasDynamic (TremoloT a) (TremoloT b) where+  dynamic = _Wrapped . dynamic++instance (HasArticulations a b) => HasArticulations (TremoloT a) (TremoloT b) where+  articulations = _Wrapped . articulations+instance (HasArticulation a b) => HasArticulation (TremoloT a) (TremoloT b) where+  articulation = _Wrapped . articulation+ -- |--- Set the number of tremolo divisions for all notes in the score.+-- Get the number of tremolo divisions. ---tremolo :: HasTremolo a => Int -> a -> a-tremolo = setTrem+runTremoloT :: TremoloT a -> (Int, a)+runTremoloT (TremoloT (Couple (Max n, a))) = (fromIntegral n, a) 

@@ -9,8 +9,6 @@ -- Stability   : experimental -- Portability : non-portable (TF,GNTD) ----- Provides generic functions for manipulating time-based structures.--- -------------------------------------------------------------------------------------  module Music.Time (@@ -38,7 +36,6 @@     module Music.Time.Past,     module Music.Time.Nominal,     module Music.Time.Graces,-    module Music.Time.Note,     module Music.Time.Voice,     module Music.Time.Chord,     module Music.Time.Track,@@ -76,3 +73,4 @@ import           Music.Time.Stretched import           Music.Time.Track import           Music.Time.Voice+

@@ -24,8 +24,6 @@ -- Stability   : experimental -- Portability : non-portable (TF,GNTD) ----- Behaviors, or time-varying values.--- -------------------------------------------------------------------------------------  module Music.Time.Behavior (@@ -69,6 +67,7 @@ import           Data.Set                      (Set) import qualified Data.Set                      as Set import           Data.VectorSpace+import           Data.String import           Prelude  import           Control.Applicative@@ -175,6 +174,9 @@ -- #ifdef INCLUDE_LIFTED deriving instance AdditiveGroup a => AdditiveGroup (Behavior a) +instance IsString a => IsString (Behavior a) where+  fromString = pure . fromString+ instance IsPitch a => IsPitch (Behavior a) where   fromPitch = pure . fromPitch @@ -337,7 +339,7 @@ -- This can be used to modify a behavior in a specific range, as in -- -- @--- 'line' & 'focusing' ``on`` (2 '<->' 3) '+a~' 1+-- 'line' & 'focusing' `on` (2 '<->' 3) '+a~' 1 -- 'line' & 'focusingOn' (2 '<->' 3) '+~' 1 -- @ --@@ -347,7 +349,7 @@ -}  -- focusing `on` s == focusingOn s-f `on` s = flip whilstM (negateV s) . f+f `on` s = transformed (negateV s) . f  -- | -- Instantly switch from one behavior to another.

@@ -24,8 +24,6 @@ -- Stability   : experimental -- Portability : non-portable (TF,GNTD) ----- /Warning/ This module is experimental.--- -------------------------------------------------------------------------------------  module Music.Time.Bound (@@ -103,7 +101,6 @@ -- set (namely [(t, t)^.from range | t <- {Time} ]). -- --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (Bound a) where   type Unwrapped (Bound a) = (Span, a)   _Wrapped' = iso getBound Bound

@@ -26,8 +26,6 @@ -- Stability   : experimental -- Portability : non-portable (TF,GNTD) ----- /Warning/ This module is experimental.--- -------------------------------------------------------------------------------------  module Music.Time.Chord (@@ -37,9 +35,10 @@        -- * Construction       chord,+      unchord,       unsafeChord, -      -- invertC,+      -- invertChord,       -- inversions,       -- chordToScore,       -- arpUp3,@@ -64,6 +63,7 @@ import           Data.Set               (Set) import qualified Data.Set               as Set import           Data.VectorSpace+import           Data.String  import           Music.Time.Delayed import           Music.Time.Reverse@@ -113,7 +113,6 @@   return = view _Unwrapped . return . return   xs >>= f = view _Unwrapped $ (view _Wrapped . f) `mbind` view _Wrapped xs --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (Chord a) where   type Unwrapped (Chord a) = (ChordList (ChordEv a))   _Wrapped' = iso getChord Chord@@ -136,12 +135,18 @@ -- instance HasMeta (Chord a) where   -- meta = error "Not implemented: meta" -chord :: Lens (Chord a) (Chord b) [Delayed a] [Delayed b]-chord = _Wrapped+chord :: Getter [Delayed a] (Chord a)+chord = from unsafeChord +unchord :: Lens (Chord a) (Chord b) [Delayed a] [Delayed b]+unchord = _Wrapped+ -- TODO names are not consistent with other types unsafeChord :: Iso (Chord a) (Chord b) [Delayed a] [Delayed b] unsafeChord = _Wrapped++instance IsString a => IsString (Chord a) where+  fromString = pure . fromString  deriving instance IsPitch a => IsPitch (Chord a)	  deriving instance IsInterval a => IsInterval (Chord a)	 

@@ -30,14 +30,12 @@ -------------------------------------------------------------------------------------  module Music.Time.Delayed (-      -- * Delayed type-      Delayed,--      -- * Construction-      delayed,+        -- * Delayed type+        Delayed, -      -- ** Inspecting delayed values-      delayedValue,+        -- * Construction+        delayed,+        delayedValue,   ) where  import           Data.AffineSpace@@ -50,9 +48,8 @@ import           Data.Set               (Set) import qualified Data.Set               as Set import           Data.VectorSpace--import           Music.Time.Reverse-import           Music.Time.Split+import           Data.String+import           Data.Functor.Adjunction  (unzipR)  import           Control.Applicative import           Control.Comonad@@ -67,6 +64,8 @@  import           Music.Dynamics.Literal import           Music.Pitch.Literal+import           Music.Time.Reverse+import           Music.Time.Split   -- |@@ -90,9 +89,9 @@ -- @ -- -deriving instance Show a => Show (Delayed a)+instance (Show a, Transformable a) => Show (Delayed a) where+  show x = show (x^.from delayed) ++ "^.delayed" --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (Delayed a) where   type Unwrapped (Delayed a) = (Time, a)   _Wrapped' = iso _delayedValue Delayed@@ -112,8 +111,23 @@   rev = revDefault  instance Splittable a => Splittable (Delayed a) where-  -- FIXME+  -- TODO is this right?+  split t = unzipR . fmap (split t) +-- Lifted instances++instance IsString a => IsString (Delayed a) where+  fromString = pure . fromString++instance IsPitch a => IsPitch (Delayed a) where+  fromPitch = pure . fromPitch++instance IsInterval a => IsInterval (Delayed a) where+  fromInterval = pure . fromInterval++instance IsDynamics a => IsDynamics (Delayed a) where+  fromDynamics = pure . fromDynamics+ -- | -- View a delayed value as a pair of a the original value and a delay time. --@@ -136,9 +150,7 @@  runDelayed :: Transformable a => Delayed a -> a runDelayed = uncurry delayTime . view _Wrapped-+  where+    delayTime t = delay (t .-. 0) -deriving instance IsPitch a => IsPitch (Delayed a)	 -deriving instance IsInterval a => IsInterval (Delayed a)	 -deriving instance IsDynamics a => IsDynamics (Delayed a) 

@@ -1,3 +1,6 @@ -module Music.Time.Future where+module Music.Time.Future (+    module Music.Time.Past+) where +import Music.Time.Past

@@ -1,2 +1,59 @@ +{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeFamilies               #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012–2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------+ module Music.Time.Graces where++import           Control.Applicative+import           Control.Monad+import           Control.Monad.Compose+import           Control.Monad.Plus+import           Data.Foldable          (Foldable)+import qualified Data.Foldable          as Foldable+import           Data.Traversable       (Traversable)+import qualified Data.Traversable       as T+import           Data.Typeable++import Music.Time.Split+import Music.Time.Reverse+import Music.Time.Nominal+import Music.Time.Voice++newtype Graces f a = Graces { getGraces :: (Nominal f a, f a, Nominal f a) }+  deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)++-- TODO move+instance Alternative f => Alternative (Nominal f) where+  empty = Nominal empty+  Nominal a <|> Nominal b = Nominal (a <|> b)++instance (Applicative f, Alternative f) => Applicative (Graces f) where+  pure x = Graces (empty, pure x, empty)++-- deriving instance Transformable a => Transformable (Graces a) where+-- deriving instance Splittable a => Splittable (Graces a) where+-- deriving instance Reversible a => Reversible (Graces a) where+

@@ -0,0 +1,175 @@++{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE ViewPatterns               #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-- Provides miscellaneous conversions.+--+-------------------------------------------------------------------------------------++module Music.Time.Internal.Convert (+        voiceToScore,+        voiceToScore',+        scoreToVoice,+        reactiveToVoice',+  ) where++import           Control.Applicative+import           Control.Lens hiding (transform, time)+import           Control.Monad+import           Control.Monad.Plus+import           Data.AffineSpace+import           Data.AffineSpace.Point+import           Data.Foldable          (Foldable (..))+import           Data.Ord+import           Data.Ratio+import           Data.Semigroup+import           Data.String+import           Data.Traversable+import           Data.VectorSpace++import           Music.Time++import qualified Data.Foldable          as Foldable+import qualified Data.List              as List+++{-+-- | Convert a note to an _onset and a voice.+noteToVoice :: Note a -> (Time, Voice a)+noteToVoice (view (from note) -> (s,x)) = (_onset s, stretchTo (_duration s) $ return x)+-}++{-+-- | Convert a note to a score.+noteToScore :: Note a -> Score a+noteToScore (view (from note) -> (s,x)) = s `transform` return x+-}++-- scoreToNotes :: Score a -> [Note a]+-- scoreToNotes = Foldable.toList . reifyScore++-- notesToScore :: [Note a] -> Score a+-- notesToScore = pcat . fmap noteToScore++{-+reactiveToVoice :: Duration -> Reactive a -> Voice a+reactiveToVoice d r = (^. voice) $ fmap (^. stretched) $ durs `zip` (fmap (r `atTime`) times)+    where+        times = 0 : filter (\t -> 0 < t && t < 0 .+^ d) (occs r)+        durs  = toRelativeTimeN' (0 .+^ d) times+-}++reactiveToVoice' :: Span -> Reactive a -> Voice a+reactiveToVoice' (view range -> (u,v)) r = (^. voice) $ fmap (^. stretched) $ durs `zip` (fmap (r `atTime`) times)+    where+        times = 0 : filter (\t -> u < t && t < v) (occs r)+        durs  = toRelativeTimeN' v times+{-# DEPRECATED reactiveToVoice' "" #-}++-- |+-- Convert a score to a voice. Fails if the score contain overlapping events.+--+scoreToVoice :: Transformable a => Score a -> Voice (Maybe a)+scoreToVoice = (^. voice) . fmap (^. stretched) . fmap throwTime . addRests . (^. events)+    where+       throwTime (t,d,x) = (d,x)+       addRests = concat . snd . mapAccumL g 0+           where+               g u (t, d, x)+                   | u == t    = (t .+^ d, [(t, d, Just x)])+                   | u <  t    = (t .+^ d, [(u, t .-. u, Nothing), (t, d, Just x)])+                   | otherwise = error "scoreToVoice: Strange prevTime"+{-# DEPRECATED scoreToVoice "" #-}++-- |+-- Convert a voice to a score.+--+voiceToScore :: Voice a -> Score a+voiceToScore = scat . fmap g . (^. stretcheds) where g = (^. stretchedValue) . fmap return+{-# DEPRECATED voiceToScore "" #-}++{-+-- | Join voices in a given part into a score.+voicesToScore :: HasPart a => [(Part a, Voice a)] -> Score a+voicesToScore = pcat . fmap (voiceToScore . uncurry (\n -> fmap (setPart n)))+-}++-- |+-- Convert a voice which may contain rests to a score.+--+voiceToScore' :: Voice (Maybe a) -> Score a+voiceToScore' = mcatMaybes . voiceToScore+{-# DEPRECATED voiceToScore' "" #-}++{-+-- |+-- Convert a track to a score where each event is given a fixed duration.+--+trackToScore :: Transformable a => Duration -> Track a -> Score a+trackToScore x = trackToScore' (const x)++-- |+-- Convert a track to a score, using durations determined by the values.+--+trackToScore' :: Transformable a => (a -> Duration) -> Track a -> Score a+trackToScore' f = (^. from events) . fmap (\(t,x) -> (t,f x,x)) . map (^. from delayed) . (^. delayeds)+-}+++-- TODO rename during+noteToReactive :: Monoid a => Note a -> Reactive a+noteToReactive n = (pure <$> n) `activate` pure mempty++-- JUNK++-- | Split a reactive into mkNotes, as well as the values before and after the first/last update+splitReactive :: Reactive a -> Either a ((a, Time), [Note a], (Time, a))+splitReactive r = case updates r of+    []          -> Left  (initial r)+    (t,x):[]    -> Right ((initial r, t), [], (t, x))+    (t,x):xs    -> Right ((initial r, t), fmap mkNote $ mrights (res $ (t,x):xs), head $ mlefts (res $ (t,x):xs))++    where++        mkNote (t,u,x) = (t <-> u, x)^.note++        -- Always returns a 0 or more Right followed by one left+        res :: [(Time, a)] -> [Either (Time, a) (Time, Time, a)]+        res rs = let (ts,xs) = unzip rs in+            flip fmap (withNext ts `zip` xs) $+                \ ((t, mu), x) -> case mu of+                    Nothing -> Left (t, x)+                    Just u  -> Right (t, u, x)++        -- lenght xs == length (withNext xs)+        withNext :: [a] -> [(a, Maybe a)]+        withNext = go+            where+                go []       = []+                go [x]      = [(x, Nothing)]+                go (x:y:rs) = (x, Just y) : withNext (y : rs)++activate :: Note (Reactive a) -> Reactive a -> Reactive a+activate (view (from note) -> (view range -> (start,stop), x)) y = y `turnOn` (x `turnOff` y)+  where+    turnOn  = switchR start+    turnOff = switchR stop+

@@ -16,13 +16,7 @@ -- Stability   : experimental -- Portability : non-portable (TF,GNTD) ----- Provides rhythmical quantization.------ You generally need not worry about this module, as quantization is handled--- automatically by 'HasBackendScore' instances.------ /Warning/ This modules is poorly named and will probably be split or moved--- soon.+-- Rhythmical quantization. -- ------------------------------------------------------------------------------------- @@ -309,14 +303,14 @@ -- beat = do --     RhythmContext tm ts _ <- getState --     (\d -> (d^/tm) `subDur` ts) <$> match (\d _ ->---         d - ts > 0  &&  isDivisibleBy 2 (d / tm - ts))+--         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 && isDivisibleBy 2 d2)+      in (d2, x) `assuming` (d - ts > 0 && isPowerOf2 d2)   -- | Matches a dotted rhythm@@ -422,17 +416,29 @@ 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+-- divides     = isDivisibleBy+-- divisibleBy = flip isDivisibleBy  -- As it sounds, do NOT use infix -- Only works for simple n such as 2 or 3, TODO determine-isDivisibleBy :: Duration -> Duration -> Bool-isDivisibleBy n = (== 0.0) . snd . properFraction . logBaseR (toRational n) . toRational+isPowerOf :: Duration -> Duration -> Bool+isPowerOf n = (== 0.0) . snd . properFraction . logBaseR (toRational n) . toRational++isPowerOf2 :: Duration -> Bool+isPowerOf2 = isPowerOf 2 

@@ -30,15 +30,18 @@  module Music.Time.Internal.Transform ( +        module Music.Time.Types,+         -- * The Transformable class         Transformable(..),         itransform,         transformed,+        itransformed,          -- * Apply under a transformation         whilst,-        whilstM,         whilstL,+        whilstL2,         whilstLT,         whilstLD,         whilstStretch,@@ -48,18 +51,18 @@         conjugateS,          -- * Specific transformations-        delay,-        undelay,-        stretch,-        compress,-        -- ** Applied transformations+        -- ** Transformations         delaying,         undelaying,         stretching,         compressing, -        -- ** Utility-        delayTime,    +        -- ** Transforming values+        delay,+        undelay,+        stretch,+        compress,+        delayTime,    ) where @@ -76,8 +79,11 @@ import           Data.Map               (Map) import qualified Data.Map               as Map import           Data.Semigroup+import           Data.Semigroup.Instances () import           Data.Sequence          (Seq) import qualified Data.Sequence          as Seq+import           Data.Set               (Set)+import qualified Data.Set               as Set import           Data.VectorSpace       hiding (Sum (..))  -- |@@ -171,6 +177,9 @@ instance Transformable a => Transformable (Seq a) where   transform t = fmap (transform t) +instance (Ord a, Transformable a) => Transformable (Set a) where+  transform t = Set.map (transform t)+ instance (Ord k, Transformable a) => Transformable (Map k a) where   transform t = Map.map (transform t) @@ -195,20 +204,45 @@ -- | -- View the given value in the context of the given transformation. --+transformed :: (Transformable a, Transformable b) => Span -> Iso a b a b+transformed s = iso (transform s) (itransform s)+++-- |+-- Transforms a lens of to a 'Transformable' type to act inside a transformation.+--+itransformed :: (Transformable a, Transformable b) => Span -> Iso a b a b+itransformed s = transformed (negateV s)++spanned = itransformed+{-# DEPRECATED spanned "Use itransformed" #-}++-- |+-- Apply a function under transformation.+--+-- Designed to be used infix, as in+-- -- @--- 'over' ('transformed' s) = (``whilst`` s)+-- 'stretch' 2 `whilst` 'delaying' 2 -- @ ---transformed :: Transformable a => Span -> Iso' a a-transformed s = iso (transform s) (itransform s)+whilst :: (Transformable a, Transformable b) => (a -> b) -> Span -> a -> b+-- f `whilst` t = transform (negateV t) . f . transform t+f `whilst` t = over (transformed t) f  +delayed :: (Transformable a, Transformable b) => Time -> Iso a b a b+delayed = transformed . delayingTime +stretched :: (Transformable a, Transformable b) => Duration -> Iso a b a b+stretched = transformed . stretching+ -- | -- A transformation that moves a value forward in time. -- delaying :: Duration -> Span delaying x = (0 .+^ x) >-> 1+delayingTime x = x >-> 1  -- | -- A transformation that stretches (augments) a value by the given factor.@@ -261,8 +295,7 @@ -- the value is starting at time zero. -- delayTime :: Transformable a => Time -> a -> a-delayTime t = delay (t .-. 0)-+delayTime = transform . delayingTime   --@@ -287,47 +320,90 @@ -- -- Perhaps we should call the inline version `whilst`, as in @f `whilst` delaying 2@? +{- --- |--- Apply a function under transformation.------ Designed to be used infix, as in------ @--- 'stretch' 2 ``whilst`` 'delaying' 2--- @----whilst :: (Transformable a, Transformable b) => (a -> b) -> Span -> a -> b-f `whilst` t = transform (negateV t) . f . transform t+-- flip whilstM is a lens+flip whilstM :: (Functor f, Transformable a, Transformable b) => (a -> f b) -> Span -> a -> f b+s `flip whilstM` f = fmap (transform (negateV t)) . f . transform t --- |--- Apply a morphism under transformation (monadic version).---+-- is this the same as transformed? -whilstM :: (Functor f, Transformable a, Transformable b) => (a -> f b) -> Span -> a -> f b-f `whilstM` t = fmap (transform (negateV t)) . f . transform t -{---- |--- Apply a morphism under transformation (co-monadic version).----whilstW :: (Functor f, Transformable a, Transformable b) => (f a -> b) -> Span -> f a -> b-f `whilstW` t = transform (negateV t) . f . fmap (transform t)+From lens:+  iso sa bt = dimap sa (fmap bt)+From profunctor:+  dimap ab cd bc = cd . bc . ab+  dimap ab cd    = \f -> cd . f . ab+  ++flip whilstM = transformed+flip whilstM = \s -> iso (transform s) (itransform s)+flip whilstM = \s -> dimap (transform s) (fmap $ itransform s)+flip whilstM = \s f -> (fmap $ itransform s) . f . transform s+flip (\f t -> fmap (transform (negateV t)) . f . transform t) = \s f -> (fmap $ itransform s) . f . transform s++\t f -> fmap (transform (negateV t)) . f . transform t +=+\t f -> (fmap $ itransform t) . f . transform t++\t f -> fmap (itransform t) . f . transform t +=+\t f -> fmap (itransform t) . f . transform t+++++Something similar to whilstL* is being used in Note/Delayed/Stretched+Are they the same?++whilstL l f (s,a)  = (s,) <$> (l $ transformed s f) a+whilstL id f (s,a) = (s,) <$> (transformed s f) a+whilstL id         = \f (s,a) -> (s,) <$> (transformed s f) a++whilstL id+  :: (Transformable a, Transformable b, Functor f) =>+     (a -> f b) -> (Span, a) -> f (Span, b)+ -}++-- dofoo+  -- :: Functor f => (t -> t2) -> (a1 -> a) -> (t2 -> f a1) -> (t1, t) -> f (t1, a)+dofoo v w = \f (s,a) -> (s,) <$> w s <$> f ((v s) a)++++dobar :: (Functor f) ++  => +  (sp -> (s -> f t) -> (s -> f t)) +  -> ((s -> f t) -> a -> f b)+  -> (s -> f t)  -> ((sp, a) -> f (sp, b))++dobar q l = \f (s,a) -> (s,) <$> (l (q s f)) a++-- whilstL2 :: (Transformable a, Transformable b) => Lens (Span, a) (Span, b) a b+whilstL2 = dofoo (transform) (transform . negateV)+ whilstL :: (Functor f, Transformable a, Transformable b)   => LensLike f s t a b   -> LensLike f (Span,s) (Span,t) a b-whilstL  l f (s,a) = (s,) <$> (l $ f `whilstM` s) a+  -- whilstL l = whilstL2 . l+whilstL l = dobar transformed l +{-+If we could rewrite (whilstL l) as (whilstLXX . l)++-}+ whilstLT :: (Functor f, Transformable a, Transformable b)   => LensLike f s t a b   -> LensLike f (Time,s) (Time,t) a b-whilstLT l f (t,a) = (t,) <$> (l $ f `whilstM` (t >-> 1)) a+whilstLT = dobar delayed  whilstLD :: (Functor f, Transformable a, Transformable b)   => LensLike f s t a b   -> LensLike f (Duration,s) (Duration,t) a b-whilstLD l f (d,a) = (d,) <$> (l $ f `whilstM` (0 >-> d)) a+whilstLD = dobar stretched   -- |@@ -352,23 +428,16 @@ -- | -- Transforms a lens of to a 'Transformable' type to act inside a transformation. ---spanned :: (Transformable a, Transformable b) => Span -> Lens a b a b-spanned s = flip whilstM (negateV s)---- |--- Transforms a lens of to a 'Transformable' type to act inside a transformation.--- -- Designed to be used infix, as in -- -- @--- l ``onSpan`` (2 \<-> 3)+-- l `onSpan` (2 \<-> 3) -- @ ---onSpan :: (Transformable a, Functor f) => LensLike' f a b -> Span -> LensLike' f a b+onSpan :: (Transformable s, Transformable t, Functor f) +  => LensLike f s t a b -> Span -> LensLike f s t a b f `onSpan` s = spanned s . f -- TODO name --- TODO move!-deriving instance Functor Sum-deriving instance Functor Product-+-- deriving instance Functor Sum+-- deriving instance Functor Product

@@ -15,7 +15,21 @@ -- ------------------------------------------------------------------------------------- -module Music.Time.Internal.Util where+module Music.Time.Internal.Util (+  showRatio,+  list,+  single,+  inspecting,+  inspectingBy,+  withPrevNext,+  rotate,+  tripped,+  through,+  uncurry3,+  partial,+  partial2,+  partial3,+  ) where  {-     Rules:

@@ -66,7 +66,7 @@ -- Move a value so that -- -- @--- '_offset' (a ``lead`` b) = '_onset' b+-- '_offset' (a `lead` b) = '_onset' b -- @ -- --@@ -77,7 +77,7 @@ -- Move a value so that -- -- @--- '_offset' a = '_onset' (a ``follow`` b)+-- '_offset' a = '_onset' (a `follow` b) -- @ -- follow :: (HasPosition a, HasPosition b, Transformable b) => a -> b -> b@@ -167,55 +167,3 @@ times :: (Semigroup a, Monoid a, HasPosition a, Transformable a) => Int -> a -> a times n = scat . replicate n -{----- |--- Like '<>', but scaling the second agument to the duration of the first.------ > Score a -> Score a -> Score a----sustain         :: (Semigroup a, Stretchable a, HasDuration a, Fractional d, d ~ Duration) =>-                a -> a -> a---- |--- Like '|>' but with a negative delay on the second element.------ > Duration -> Score a -> Score a -> Score a----anticipate      :: (Semigroup a, Transformable a, HasOnset a, HasOffset a, Ord d, d ~ Duration) =>-                d -> a -> a -> a--x `sustain` y     = x <> duration x `stretchTo` y-anticipate t a b  =  a <> startAt (offset a .-^ t) b---- Like '<>', but truncating the second agument to the duration of the first.--- prolong x y = x <> before (duration x) y---- |--- Repeat once for each element in the list.------ Example:------ > repeated [1,2,1] (c^*)------ Simple type:------ > [a] -> (a -> Score Note) -> Score Note----repeated        :: (Monoid' b, Transformable b, HasOnset b, HasOffset b) =>-                [a] -> (a -> b) -> b---- |--- Repeat a number of times and scale down by the same amount.------ > Duration -> Score a -> Score a----group           :: (Monoid' a, Transformable a, Fractional d, d ~ Duration, HasOnset a, HasOffset a) =>-                Int -> a -> a--times n     = scat . replicate n-repeated    = flip (\f -> scat . fmap f)-group n     = times n . (fromIntegral n `compress`)--}---- JUNK

@@ -23,16 +23,8 @@ -- Stability   : experimental -- Portability : non-portable (TF,GNTD) ----- Provides a way to annotate data-types with 'Transformable' meta-data. See--- "Music.Score.Meta" for more specific applications.------ Inspired by Clojure and Diagram's styles, in turn based on xmonad's @Message@ type,--- in turn based on ideas in:------ Simon Marlow.--- /An Extensible Dynamically-Typed Hierarchy of Exceptions/.--- Proceedings of the 2006 ACM SIGPLAN workshop on--- Haskell. <http://research.microsoft.com/apps/pubs/default.aspx?id=67968>.+-- Provides a way to annotate data-types with 'Transformable' meta-data.+-- Inspired by Clojure meta-data and Diagrams styles. -- ------------------------------------------------------------------------------------- @@ -59,10 +51,13 @@          -- ** The HasMeta class         HasMeta(..),+        getMeta,+        mapMeta,         setMeta,+        applyMeta,         setMetaAttr,         setMetaTAttr,-        applyMeta,+        preserveMeta,          -- ** Add meta-data to arbitrary types         AddMeta,@@ -199,12 +194,19 @@ instance HasMeta a => HasMeta (Twain b a) where   meta = _Wrapped . meta --- TODO call withMeta a la Clojure?+-- | Extract meta-data.+getMeta :: HasMeta a => a -> Meta+getMeta = view meta++-- | Update meta-data. setMeta :: HasMeta a => Meta -> a -> a-setMeta m = set meta m+setMeta = set meta --- | Apply meta-information by combining it (on the left) with the---   existing meta-information.+-- | Map over meta-data.+mapMeta :: HasMeta a => (Meta -> Meta) -> a -> a+mapMeta = over meta++-- | Apply meta-information by combining it with existing meta-information. applyMeta :: HasMeta a => Meta -> a -> a applyMeta m = over meta (<> m) @@ -215,6 +217,10 @@ -- | Update a meta attribute. setMetaTAttr :: (TAttributeClass b, HasMeta a) => b -> a -> a setMetaTAttr a = applyMeta (wrapTMeta a)++-- | Apply a function without affecting meta-data.+preserveMeta :: (HasMeta a, HasMeta b) => (a -> b) -> a -> b+preserveMeta f x = let m = view meta x in set meta m (f x)  -- | -- Annotate an arbitrary type with meta-data, preserving instances of

@@ -1,2 +1,58 @@ +{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeFamilies               #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012–2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------+ module Music.Time.Nominal where++import           Control.Applicative+import           Control.Monad+import           Control.Monad.Compose+import           Control.Monad.Plus+import           Data.Foldable          (Foldable)+import qualified Data.Foldable          as Foldable+import           Data.Traversable       (Traversable)+import qualified Data.Traversable       as T+import           Data.Typeable++import Music.Time.Split+import Music.Time.Reverse++newtype Nominal f a = Nominal { getNominal :: f a }+  deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Monad)++instance Applicative f => Applicative (Nominal f) where+  pure = Nominal . pure+  Nominal f <*> Nominal x = Nominal (f <*> x)++instance Transformable (Nominal f a) where+  transform _ = id++instance Splittable (Nominal f a) where+  split _ x = (x,x)++instance Reversible (f a) => Reversible (Nominal f a) where+  rev (Nominal x) = Nominal (rev x)+

@@ -47,11 +47,9 @@ import           Data.Semigroup import           Data.Set               (Set) import qualified Data.Set               as Set+import           Data.String import           Data.VectorSpace -import           Music.Time.Reverse-import           Music.Time.Split- import           Control.Applicative import           Control.Comonad import           Control.Comonad.Env@@ -62,8 +60,15 @@ import qualified Data.Foldable          as Foldable import           Data.PairMonad import           Data.Typeable++import           Music.Pitch.Literal+import           Music.Dynamics.Literal import           Music.Time.Internal.Util (through, tripped) +import           Music.Time.Reverse+import           Music.Time.Split++ -- | -- A 'Note' is a value with an 'onset' and and 'offset' in time. It is an instance -- of 'Transformable'.@@ -105,7 +110,6 @@ -- instance ComonadEnv Span Note where   -- ask = noteValueSpan --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (Note a) where   type Unwrapped (Note a) = (Span, a)   _Wrapped' = iso _noteValue Note@@ -124,10 +128,24 @@ instance Splittable a => Splittable (Note a) where   -- beginning d = over _Wrapped $ \(s, v) -> (beginning d s, beginning (transform (negateV s) d) v)   beginning d = over _Wrapped $ \(s, v) -> (beginning d s, beginning (d / _duration s) v)-  ending    d = over _Wrapped $ \(s, v) -> (ending    d s, ending    (1 - (d / _duration s)) v)+  ending    d = over _Wrapped $ \(s, v) -> (ending    d s, ending    (d / _duration s) v)  instance Reversible (Note a) where   rev = revDefault++-- Lifted instances++instance IsString a => IsString (Note a) where+  fromString = pure . fromString++instance IsPitch a => IsPitch (Note a) where+  fromPitch = pure . fromPitch++instance IsInterval a => IsInterval (Note a) where+  fromInterval = pure . fromInterval++instance IsDynamics a => IsDynamics (Note a) where+  fromDynamics = pure . fromDynamics  -- | -- View a note as a pair of the original value and the transformation (and vice versa).

@@ -1,24 +1,83 @@ +{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ViewPatterns               #-}+{-# LANGUAGE CPP #-}+ module Music.Time.Past where -import Music.Time.Split-import Music.Time.Reverse-import Music.Time.Segment-import Music.Time.Behavior+import Control.Lens -- DEBUG+import           Control.Applicative+import           Control.Comonad+import           Data.Functor.Couple+import           Data.Ord            (comparing)+import           Data.List           (takeWhile, sort, sortBy, group)+import           Data.List.Ordered+import           Data.Maybe+import           Data.Semigroup+import           Control.Monad +import           Music.Time.Behavior+import           Music.Time.Reverse+import           Music.Time.Segment+import           Music.Time.Split+ -- |--- Past represents a value occuring /up to/ some point in time.+-- 'Past' represents a value occuring /before and at/ some point in time. ----- It may be seen as a note whose era is a left-open time interval.+-- It may be seen as a note whose era is a left-open, right-inclusive time interval. ---newtype Past a = Past { getPast :: (a, Time) }+newtype Past a = Past { getPast :: (Min Time, a) }+  deriving (Eq, Ord, Functor) --- | Query a past value.+-- |+-- 'Future' represents a value occuring /at and after/ some point in time.+--+-- It may be seen as a note whose era is a left-open, right-inclusive time interval.+--+newtype Future a = Future { getFuture :: (Max Time, a) }+  deriving (Eq, Ord, Functor)++instance HasDuration (Past a) where+  _duration _ = 0++instance HasDuration (Future a) where+  _duration _ = 0++instance HasPosition (Past a) where+  _position (Past (extract -> t,_)) _ = t++instance HasPosition (Future a) where+  _position (Future (extract -> t,_)) _ = t++-- | Query a past value. Semantic function. past :: Past a -> Time -> Maybe a-past (Past (x, t)) t'+past (Past (extract -> t, x)) t'   | t' <= t    = Just x   | otherwise  = Nothing +-- | Query a future value. Semantic function.+future :: Future a -> Time -> Maybe a+future (Future (extract -> t, x)) t'+  | t' >= t    = Just x+  | otherwise  = Nothing++-- TODO more elegant+indexPast :: [Past a] -> Time -> Maybe a+indexPast ps t = firstTrue $ fmap (\p -> past p t) $ sortBy (comparing _onset) ps++firstTrue :: [Maybe a] -> Maybe a+firstTrue = listToMaybe . join . fmap maybeToList+-- firstTrue = join . listToMaybe . dropWhile isNothing+ -- | Project a segment (backwards) up to the given point. pastSeg :: Past (Segment a) -> Behavior (Maybe a) pastSeg = undefined++-- | Project a segment starting from the given point.+futureSeg :: Future (Segment a) -> Behavior (Maybe a)+futureSeg = undefined+++

@@ -37,21 +37,22 @@        -- * The HasPosition class       HasPosition(..),-      -- * Inspecting position++      -- * Era       era,++      -- * Position       position, -      -- * Specific positions+      -- ** Specific positions       onset,       midpoint,       offset,       preOnset,       postOffset,--      -- ** Deprecated       postOnset, -      -- * Moving to absolute positions+      -- * Moving       startAt,       stopAt,       placeAt,

@@ -29,8 +29,8 @@ module Music.Time.Reactive (         -- * Reactive type         Reactive,-      -        -- * Construction++        -- * Query         initial,         final,         intermediate,@@ -38,19 +38,24 @@         updates,         occs,         atTime,-        splitReactive,++        -- * Construction       -        -- * Combinators+        -- * Combine         switchR,         trimR, -        -- * Sampling and discretization+        -- * Split+        splitReactive,++        -- * Sampling         continous,         continousWith,         sample,         -- TODO         -- window,         -- windowed,   +   ) where  -- Reactive values, or piecewise functions of time.

@@ -36,7 +36,7 @@         -- * The Reversible class         Reversible(..), -        -- * Reversed values+        -- * Reversing         reversed,         revDefault, @@ -90,7 +90,7 @@ -- @ -- -- @--- 'rev' s ``transform`` a = 'rev' (s ``transform`` a)+-- 'rev' s `transform` a = 'rev' (s `transform` a) -- @ -- -- or equivalently,@@ -168,6 +168,7 @@ -- revDefault x = (stretch (-1) `whilst` undelaying (_position x 0.5 .-. 0)) x revDefault x = stretch (-1) x + newtype NoReverse a = NoReverse { getNoReverse :: a }   deriving (Typeable, Eq, Ord, Show) @@ -180,8 +181,8 @@ -- | -- View the reverse of a value. ----- >>> [1,2,3] & reversed %~ sort--- > [3,2,1]+-- >>> [1,2,3] & reversed %~ Data.List.sort+-- [3,2,1] -- reversed :: Reversible a => Iso' a a reversed = iso rev rev

@@ -33,22 +33,24 @@         -- * Score type         Score, +        -- * Query+         -- * Construction         score,-      -        -- ** Extracting values         notes,+        eras,         events,-      -        -- ** Pattern matching         singleNote, -        -- ** Unsafe versions-        unsafeNotes,-        unsafeEvents,-+        -- * Traversal+        mapWithSpan,+        filterWithSpan,+        mapFilterWithSpan,+        mapEvents,+        filterEvents,+        mapFilterEvents, -        -- * Simultaneous values+        -- * Simultaneous         -- TODO check for overlapping values etc         simult,         simultaneous,@@ -56,15 +58,11 @@         -- * Normalize         normalizeScore,         printEras,-        -        -- * Traversing-        mapWithSpan,-        filterWithSpan,-        mapFilterWithSpan,-        mapEvents,-        filterEvents,-        mapFilterEvents, +        -- * Unsafe versions+        unsafeNotes,+        unsafeEvents,+           ) where  import           Data.AffineSpace@@ -77,6 +75,7 @@ import           Data.Set               (Set) import qualified Data.Set               as Set import           Data.VectorSpace+import           Data.String import           Data.Functor.Adjunction  (unzipR)  import           Music.Time.Juxtapose   (scat)@@ -168,6 +167,7 @@   mzero = mempty   mplus = mappend +{- instance FunctorWithIndex Span Score where   imap f = over (_Wrapped._2) $ imap f @@ -176,6 +176,7 @@  instance TraversableWithIndex Span Score where   itraverse f (Score (m,x)) = fmap (\x -> Score (m,x)) $ itraverse f x+-}  instance Transformable (Score a) where   transform t (Score (m,x)) = Score (transform t m, transform t x)@@ -189,18 +190,21 @@       (m1, m2) = split t m       (x1, x2) = split t x +-- TODO move these two "implementations" to NScore instance HasPosition (Score a) where-  _onset (Score (_,x))    = _onset x-  _offset (Score (_,x))   = _offset x-  _position (Score (_,x)) = _position x+  _position = _position . snd . view _Wrapped' . normalizeScore'+  -- TODO clean up in terms of AddMeta and optimize  instance HasDuration (Score a) where-  _duration (Score (_,x)) = _duration x+  _duration x = _offset x .-. _onset x    -- Lifted instances +instance IsString a => IsString (Score a) where+  fromString = pure . fromString+ instance IsPitch a => IsPitch (Score a) where   fromPitch = pure . fromPitch @@ -246,7 +250,9 @@ newtype NScore a = NScore { getNScore :: [ScoreNote a] }   deriving ({-Eq, -}{-Ord, -}{-Show, -}Functor, Foldable, Traversable, Semigroup, Monoid, Typeable, Show, Eq) --- | Unsafe: Do not use 'Wrapped' instances+instance (Show a, Transformable a) => Show (Score a) where+  show x = show (x^.notes) ++ "^.score"+ instance Wrapped (NScore a) where   type Unwrapped (NScore a) = [ScoreNote a]   _Wrapped' = iso getNScore NScore@@ -269,6 +275,7 @@   mzero = mempty   mplus = mappend +{- instance FunctorWithIndex Span NScore where   imap = undefined   -- TODO@@ -280,6 +287,7 @@ instance TraversableWithIndex Span NScore where   itraverse = undefined   -- TODO+-}  instance Transformable (NScore a) where   transform t (NScore xs) = NScore (fmap (transform t) xs)@@ -459,6 +467,7 @@ singleNote :: Prism' (Score a) (Note a) singleNote = unsafeNotes . single {-# INLINE singleNote #-}+{-# DEPRECATED singleNote "Use 'unsafeNotes . single'" #-} -- TODO make prism fail if score contains meta-data -- (or else second prism law is not satisfied) @@ -512,16 +521,38 @@  -- | Mainly useful for backends. normalizeScore :: Score a -> Score a-normalizeScore = reset . absDurations+normalizeScore = reset . normalizeScore'   where     reset x = set onset (view onset x `max` 0) x-    absDurations = over (notes.each.era.delta._2) abs +normalizeScore' = over (notes . each . era) normalizeSpan+-- TODO version that reverses the values where appropriate+-- Use over (notes . each) normalizeNote or similar++-- normalizeScore = reset . absDurations+--   where+--     reset x = set onset (view onset x `max` 0) x+--     absDurations = over (notes.each.era.delta._2) abs++-- |+-- Extract all eras of the given score.+--+-- >>> printEras $ scat [c,d,e :: Score Integer]+-- 0 <-> 1+-- 1 <-> 2+-- 2 <-> 3+-- printEras :: Score a -> IO ()-printEras = mapM_ print . toListOf (notes.each.era)+printEras = mapM_ print . toListOf eras -eras :: Transformable a => Score a -> [Span]-eras = toListOf (notes . each . era)+-- |+-- Print all eras of the given score.+--+-- >>> toListOf eras $ scat [c,d,e :: Score Integer]+-- [0 <-> 1,1 <-> 2,2 <-> 3]+--+eras :: Traversal' (Score a) Span+eras = notes . each . era  chordEvents :: Transformable a => Span -> Score a -> [a] chordEvents s = fmap extract . filter ((== s) . view era) . view notes@@ -534,7 +565,7 @@     -- es :: [Era]     -- evs :: [[a]]     -- vs :: [(Time, Duration, [a])]-    es  = List.nub $ eras sc+    es  = List.nub $ toListOf eras sc     evs = fmap (`chordEvents` sc) es     vs  = zipWith (\(view delta -> (t,d)) a -> (t,d,a)) es evs 

@@ -37,18 +37,11 @@         -- $musicTimeBehaviorExamples         -- (!^),         -- behavior',-        behavior, -        -- ** Combinators-        switch,-        switch',-        splice,-        trim,-        trimBefore,-        trimAfter,-        concatB,+        -- * Construction+        behavior, -        -- * Common behaviors+        -- ** Common versions         line,         unit,         impulse,@@ -58,21 +51,35 @@         sine,         cosine, +        -- ** Combine+        switch,+        switch',+        splice,+        trim,+        trimBefore,+        trimAfter,+        concatB,+         -- * Segment type         Segment,         -- ** Examples         -- $XXmusicTimeSegmentExamples++        -- * Construction         segment, -        -- ** Combinators+        -- * Combine         focusing,         apSegments',         apSegments,         -- concatS, +        -- * Bound type         Bound,+        -- * Query                 bounds,         bounding,+        -- * Combine         trim,         splice,         bounded',@@ -355,7 +362,7 @@ -- View part of a 'Behavior' as a 'Segment'. -- -- @--- 'line' & 'focusing' ``onSpan`` (2 '<->' 3) '*~' 0+-- 'line' & 'focusing' `onSpan` (2 '<->' 3) '*~' 0 -- @ -- focusing :: Lens' (Behavior a) (Segment a)

@@ -35,8 +35,9 @@          -- * The Splittable class         Splittable(..),++        -- * Miscellaneous         splitAbs,-             chunks,    ) where@@ -72,12 +73,18 @@ -- -- @ -- '_duration' ('beginning' t x) + '_duration' ('ending' t x) = '_duration' x--- '_duration' ('beginning' t x) = t ``min`` '_duration' x                    iff t >= 0--- '_duration' ('ending' t x)    = '_duration' x - (t ``min`` '_duration' x)    iff t >= 0+-- '_duration' ('beginning' t x) = t `min` '_duration' x                    iff t >= 0+-- '_duration' ('ending' t x)    = '_duration' x - (t `min` '_duration' x)    iff t >= 0 -- @ -- -- (Note that any of these three laws can be derived from the other two, so it is -- sufficient to prove two!).+--+-- >>> (\x -> fmap (flip split x) [-2,-1,0,0.5,1,2]) $ (1::Duration)+-- [(0,1),(0,1),(0,1),((1/2),(1/2)),(1,0),(1,0)]+--+-- >>> (\x -> fmap (flip split x) [-2,-1,0,0.5,1,2]) $ (0<->1)+-- [(0 <-> 0,0 <-> 1),(0 <-> 0,0 <-> 1),(0 <-> 0,0 <-> 1),(0 <-> (1/2),(1/2) <-> 1),(0 <-> 1,1 <-> 1),(0 <-> 1,1 <-> 1)] -- class Splittable a where   split      :: Duration -> a -> (a, a)

@@ -29,14 +29,12 @@ -------------------------------------------------------------------------------------  module Music.Time.Stretched (--        -- * Stretched values+        -- * Stretched type         Stretched,          -- * Construction         stretched,         stretchedValue,   -   ) where  import           Data.AffineSpace@@ -49,11 +47,9 @@ import           Data.Set               (Set) import qualified Data.Set               as Set import           Data.VectorSpace+import           Data.String import           Data.Functor.Couple -import           Music.Time.Reverse-import           Music.Time.Split- import           Control.Applicative import           Control.Comonad import           Control.Comonad.Env@@ -65,6 +61,12 @@ import           Data.PairMonad import           Data.Typeable +import           Music.Dynamics.Literal+import           Music.Pitch.Literal+import           Music.Time.Reverse+import           Music.Time.Split++ -- | -- A 'Stretched' value has a known 'duration', but no 'position'. --@@ -82,9 +84,6 @@ -- @ -- --- TODO move-deriving instance Traversable (Couple a)- -- >>> stretch 2 $ (5,1)^.stretched -- (10,1)^.stretched --@@ -96,14 +95,12 @@ deriving instance Num a => Num (Stretched a) deriving instance Fractional a => Fractional (Stretched a) deriving instance Floating a => Floating (Stretched a)- deriving instance Ord a => Ord (Stretched a) deriving instance Real a => Real (Stretched a) deriving instance RealFrac a => RealFrac (Stretched a)  deriving instance Typeable1 Stretched --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (Stretched a) where   type Unwrapped (Stretched a) = (Duration, a)   _Wrapped' = iso (getCouple . _stretchedValue) (Stretched . Couple)@@ -123,8 +120,23 @@   beginning d = over _Wrapped $ \(s, v) -> (beginning d s, beginning d v)   ending    d = over _Wrapped $ \(s, v) -> (ending    d s, ending    d v) -deriving instance Show a => Show (Stretched a)+instance (Show a, Transformable a) => Show (Stretched a) where+  show x = show (x^.from stretched) ++ "^.stretched" +-- Lifted instances++instance IsString a => IsString (Stretched a) where+  fromString = pure . fromString++instance IsPitch a => IsPitch (Stretched a) where+  fromPitch = pure . fromPitch++instance IsInterval a => IsInterval (Stretched a) where+  fromInterval = pure . fromInterval++instance IsDynamics a => IsDynamics (Stretched a) where+  fromDynamics = pure . fromDynamics+ -- | -- View a stretched value as a pair of the original value and a stretch factor. --@@ -139,9 +151,6 @@ stretchedValue = lens runStretched (flip $ _stretched . const)   where     _stretched f (Stretched (Couple (d, x))) = Stretched (Couple (d, f `whilst` stretching d $ x))+    runStretched = uncurry stretch . view _Wrapped {-# INLINE stretchedValue #-} -runStretched :: Transformable a => Stretched a -> a-runStretched = uncurry stretch . view _Wrapped---- JUNK

@@ -79,7 +79,7 @@ -- newtype Track a = Track { getTrack :: TrackList (TrackEv a) }   deriving (Functor, Foldable, Traversable, Semigroup, Monoid, Typeable, Show, Eq)-{-# DEPRECATED Track "Use 'Chord'" #-}+-- {-# DEPRECATED Track "Use 'Chord'" #-}  -- A track is a list of events with explicit onset. --@@ -113,7 +113,6 @@   return = view _Unwrapped . return . return   xs >>= f = view _Unwrapped $ (view _Wrapped . f) `mbind` view _Wrapped xs --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (Track a) where   type Unwrapped (Track a) = (TrackList (TrackEv a))   _Wrapped' = iso getTrack Track

@@ -36,27 +36,23 @@         Transformable(..),         itransform,         transformed,--        -- * Apply under a transformation         whilst,         spanned,         onSpan,-        -- conjugateS,+        conjugateS,          -- * Specific transformations         -- ** Transformations-        delay,-        undelay,-        stretch,-        compress,--        -- ** Transforming values         delaying,         undelaying,         stretching,         compressing, -        -- * Utility+        -- ** Transforming values+        delay,+        undelay,+        stretch,+        compress,         delayTime,    ) where

@@ -86,7 +86,29 @@         isProper,         isBefore,         encloses,+        properlyEncloses,         overlaps,+        +        afterOnset,+        strictlyAfterOnset,+        beforeOnset,+        strictlyBeforeOnset,+        afterOffset,+        strictlyAfterOffset,+        beforeOffset,+        strictlyBeforeOffset,+        +        startsWhenStarts,+        startsWhenStops,+        stopsWhenStops,+        stopsWhenStarts,+        +        startsBefore,+        startsLater,+        stopsAtTheSameTime,+        stopsBefore,+        stopsLater,+                 -- union         -- intersection (alt name 'overlap')         -- difference (would actually become a split)@@ -130,6 +152,7 @@ -- for 'Fractional' and 'RealFrac'. -- type TimeBase = Rational+-- type TimeBase = Fixed E12 {- type TimeBase = Fixed E12 @@ -264,8 +287,8 @@ -- | -- @length (offsetPoints x xs) = length xs + 1@ ----- >>> offsetPoints 0 [1,2,1]--- [0,1,2,1]+-- >>> offsetPoints (0 ::Double) [1,2,1]+-- [0.0,1.0,3.0,4.0] -- -- @ -- offsetPoints :: 'AffineSpace' a => 'Time' -> ['Duration'] -> ['Time']@@ -371,17 +394,17 @@ -- $musicTimeSpanIsos -- -- >>> (2 <-> 3)^.range--- > (2, 3)--- >--- >>> hs> (2 <-> 3)^.delta--- > (2, 1)--- >--- >>> hs> (10 >-> 5)^.range--- > (10, 15)--- >--- >>> hs> (10 >-> 5)^.delta--- > (10, 5)+-- (2,3) --+-- >>> (2 <-> 3)^.delta+-- (2,1)+--+-- >>> (10 >-> 5)^.range+-- (10,15)+--+-- >>> (10 >-> 5)^.delta+-- (10,5)+--  instance Show Span where   -- show = showDelta@@ -422,6 +445,10 @@ -- (b .-^ a) <-> b = a <-< b -- +infixl 6 <->+infixl 6 >->+infixl 6 <-<+ -- | -- @t \<-\> u@ represents the span between @t@ and @u@. --@@ -514,11 +541,8 @@ -- -- A span is either /forward/, /backward/ or /empty/. ----- >>> any id [isForwardSpan x, isBackwardSpan x, isEmptySpan x]--- True------ >>> all not [isForwardSpan x, isBackwardSpan x, isEmptySpan x]--- False+-- @any id [isForwardSpan x, isBackwardSpan x, isEmptySpan x] == True@+-- @all not [isForwardSpan x, isBackwardSpan x, isEmptySpan x] == False@ --  -- |@@ -571,23 +595,161 @@ isProper (view range -> (t, u)) = t < u {-# DEPRECATED isProper "Use 'isForwardSpan'" #-} +infixl 5 `inside`+infixl 5 `encloses`+infixl 5 `properlyEncloses`+infixl 5 `overlaps`+-- infixl 5 `encloses`+-- infixl 5 `encloses`+-- infixl 5 `encloses`+ -- | -- Whether the given point falls inside the given span (inclusively). -- -- Designed to be used infix, for example ----- @--- 0.5 ``inside`` (1 '<->' 2)--- @+-- >>> 0.5 `inside` 1 <-> 2+-- False --+-- >>> 1.5 `inside` 1 <-> 2+-- True+--+-- >>> 1 `inside` 1 <-> 2+-- True+-- inside :: Time -> Span -> Bool inside x (view range -> (t, u)) = t <= x && x <= u  -- | -- Whether the first given span encloses the second span. --+-- >>> 0 <-> 3 `encloses` 1 <-> 2+-- True+--+-- >>> 0 <-> 2 `encloses` 1 <-> 2+-- True+--+-- >>> 1 <-> 3 `encloses` 1 <-> 2+-- True+--+-- >>> 1 <-> 2 `encloses` 1 <-> 2+-- True+-- encloses :: Span -> Span -> Bool a `encloses` b = _onsetS b `inside` a && _offsetS b `inside` a++-- |+-- Whether the first given span encloses the second span.+--+-- >>> 0 <-> 3 `properlyEncloses` 1 <-> 2+-- True+--+-- >>> 0 <-> 2 `properlyEncloses` 1 <-> 2+-- True+--+-- >>> 1 <-> 3 `properlyEncloses` 1 <-> 2+-- True+--+-- >>> 1 <-> 2 `properlyEncloses` 1 <-> 2+-- False+--+properlyEncloses :: Span -> Span -> Bool+a `properlyEncloses` b = a `encloses` b && a /= b++++-- TODO more intuitive param order++afterOnset :: Time -> Span -> Bool+t `afterOnset` s = t >= _onsetS s++strictlyAfterOnset :: Time -> Span -> Bool+t `strictlyAfterOnset` s = t > _onsetS s++beforeOnset :: Time -> Span -> Bool+t `beforeOnset` s = t <= _onsetS s++strictlyBeforeOnset :: Time -> Span -> Bool+t `strictlyBeforeOnset` s = t < _onsetS s++afterOffset :: Time -> Span -> Bool+t `afterOffset` s = t >= _offsetS s++strictlyAfterOffset :: Time -> Span -> Bool+t `strictlyAfterOffset` s = t > _offsetS s++beforeOffset :: Time -> Span -> Bool+t `beforeOffset` s = t <= _offsetS s++strictlyBeforeOffset :: Time -> Span -> Bool+t `strictlyBeforeOffset` s = t < _offsetS s+++-- Param order OK++-- Name?+startsWhenStarts :: Span -> Span -> Bool+a `startsWhenStarts` b = _onsetS a == _onsetS b++-- Name?+startsWhenStops :: Span -> Span -> Bool+a `startsWhenStops` b = _onsetS a == _offsetS b++-- Name?+stopsWhenStops :: Span -> Span -> Bool+a `stopsWhenStops` b = _offsetS a == _offsetS b++-- Name?+stopsWhenStarts :: Span -> Span -> Bool+a `stopsWhenStarts` b = _offsetS a == _onsetS b+++startsBefore :: Span -> Span -> Bool+a `startsBefore` b = _onsetS a < _onsetS b++startsLater :: Span -> Span -> Bool+a `startsLater` b = _onsetS a > _onsetS b++stopsAtTheSameTime :: Span -> Span -> Bool+a `stopsAtTheSameTime` b = _offsetS a == _offsetS b++stopsBefore :: Span -> Span -> Bool+a `stopsBefore` b = _offsetS a < _offsetS b++stopsLater :: Span -> Span -> Bool+a `stopsLater` b = _offsetS a > _offsetS b++{-+contains+curtails+delays+happensDuring+intersects+trisects+isCongruentTo+overlapsAllOf+overlapsOnlyOnsetOf+overlapsOnlyOffsetOf+overlapsOnsetOf+overlapsOffsetOf++++-}++-- timespantools.timespan_2_starts_during_timespan_1+-- timespantools.timespan_2_starts_when_timespan_1_starts+-- timespantools.timespan_2_starts_when_timespan_1_stops+-- timespantools.timespan_2_stops_after_timespan_1_starts+-- timespantools.timespan_2_stops_after_timespan_1_stops+-- timespantools.timespan_2_stops_before_timespan_1_starts+-- timespantools.timespan_2_stops_before_timespan_1_stops+-- timespantools.timespan_2_stops_during_timespan_1+-- timespantools.timespan_2_stops_when_timespan_1_starts+-- timespantools.timespan_2_stops_when_timespan_1_stops+-- timespantools.timespan_2_trisects_timespan_1     ++  -- | -- Whether the given span overlaps.

@@ -46,12 +46,14 @@         fuse,         fuseBy, -        -- ** Special cases+        -- ** Fuse rests         fuseRests,         coverRests, -        -- * Traversing+        -- * Traversal         -- ** Separating rhythms and values+        valuesV,+        durationsV,         withValues,         withDurations,         rotateValues,@@ -65,6 +67,7 @@         zipVoice3,         zipVoice4,         zipVoiceNoScale,+        -- FIXME compose with (lens assoc unassoc) for the 3 and 4 versions         zipVoiceNoScale3,         zipVoiceNoScale4,         zipVoiceWith,@@ -95,6 +98,9 @@ import           Data.Semigroup import           Data.Set                 (Set) import qualified Data.Set                 as Set+import           Data.Sequence            (Seq)+import qualified Data.Sequence            as Seq+import           Data.String import           Data.VectorSpace  import           Music.Time.Reverse@@ -123,8 +129,11 @@ -- A 'Voice' is a sequential composition of values. Events may not overlap. -- newtype Voice a = Voice { getVoice :: VoiceList (VoiceEv a) }-  deriving (Functor, Foldable, Traversable, Semigroup, Monoid, Typeable, Show, Eq)+  deriving (Functor, Foldable, Traversable, Semigroup, Monoid, Typeable, Eq) +instance (Show a, Transformable a) => Show (Voice a) where+  show x = show (x^.stretcheds) ++ "^.voice"+ -- -- $semantics Voice -- type Voice a = [Stretched a]@@ -146,9 +155,14 @@  -- Can use any type as long as voiceEv provides an Iso type VoiceEv a = Stretched a+-- type VoiceEv a = ((),Stretched a)  voiceEv :: Iso (Stretched a) (Stretched b) (VoiceEv a) (VoiceEv b) voiceEv = id+-- voiceEv = iso add remove+--   where+--     add x = ((),x)+--     remove ((),x) = x  instance Applicative Voice where   pure  = return@@ -166,7 +180,6 @@   mzero = mempty   mplus = mappend   --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (Voice a) where   type Unwrapped (Voice a) = (VoiceList (VoiceEv a))   _Wrapped' = iso getVoice Voice@@ -197,26 +210,15 @@     where       split' = error "TODO" -      -- split' :: Time -> (Duration -> a -> (a,a)) -> [Stretched a] -> ([Stretched a], [Stretched a])-      -- split' t f = over both mcatMaybes . unzipR . snd . Data.List.mapAccumL go (0::Time)-      --   where-      --     go :: Time -> Stretched a -> (Time, (Maybe (Stretched a), Maybe (Stretched a)))-      --     go currentOnset (view (from stretched) -> (d,x))-      --       = let currentOffset = currentOnset .+^ d-      --             theSplit = if t              <= currentOnset           then (Nothing, Just (view stretched (d,x))) else-      --                        if currentOnset   <  t && t < currentOffset then-      --                          let x1 = x-      --                              x2 = x in-      --                          (Just (view stretched (t .-^ currentOnset,x1)), Just (view stretched (d ^-^ (t .-^ currentOnset),x2))) else-      --                        if currentOffset  <= t                      then (Just (view stretched (d,x)), Nothing) else error "Impossible"-      --           in (currentOnset .+^ d, theSplit)- instance Reversible a => Reversible (Voice a) where   rev = over _Wrapped' (fmap rev) -- TODO OK?   -- Lifted instances +instance IsString a => IsString (Voice a) where+  fromString = pure . fromString+ instance IsPitch a => IsPitch (Voice a) where   fromPitch = pure . fromPitch @@ -329,6 +331,7 @@ singleStretched :: Prism' (Voice a) (Stretched a) singleStretched = unsafeStretcheds . single {-# INLINE singleStretched #-}+{-# DEPRECATED singleStretched "Use 'unsafeStretcheds . single'" #-}   -- |@@ -396,7 +399,7 @@ -- Join the given voices without combining durations. -- zipVoiceWithNoScale :: (a -> b -> c) -> Voice a -> Voice b -> Voice c-zipVoiceWithNoScale f a b = zipVoiceWith' (\x y -> x) f a b+zipVoiceWithNoScale = zipVoiceWith' const  -- | -- Join the given voices by combining durations and values using the given function.@@ -451,7 +454,7 @@     merge (Just x) Nothing  = True     merge Nothing  (Just x) = True     merge (Just x) (Just y) = False-    hasOnlyRests = all isNothing $ toListOf traverse x -- norm+    hasOnlyRests = all isNothing $ toListOf traverse x -- norm   withContext :: Voice a -> Voice (Ctxt a)@@ -523,7 +526,7 @@ reverseValues :: Voice a -> Voice a reverseValues = over valuesV reverse --- Lens "filtered" throuygh a voice+-- Lens "filtered" through a voice voiceLens :: (s -> a) -> (b -> s -> t) -> Lens (Voice s) (Voice t) (Voice a) (Voice b) voiceLens getter setter = lens (fmap getter) (flip $ zipVoiceWithNoScale setter) @@ -548,4 +551,184 @@ -- Implement meta-data -- +-- List functions+headV, lastV :: Voice a -> Maybe (Stretched a)+headV = preview _head+lastV = preview _head++tailV, initV :: Voice a -> Maybe (Voice a)+tailV = preview _tail+initV = preview _init++consV :: Stretched a -> Voice a -> Voice a+unconsV :: Voice a -> Maybe (Stretched a, Voice a)+consV = cons+unconsV = uncons++snocV :: Voice a -> Stretched a -> Voice a+unsnocV :: Voice a -> Maybe (Voice a, Stretched a)+snocV = snoc+unsnocV = unsnoc++nullV :: Voice a -> Bool+nullV = nullOf eventsV++lengthV :: Voice a -> Int+lengthV = lengthOf eventsV++mapV :: (a -> b) -> Voice a -> Voice b+mapV = fmap+++-- Voice-specific++sameDurations :: Voice a -> Voice b -> Bool+sameDurations a b = view durationsV a == view durationsV b++mergeIfSameDuration :: Voice a -> Voice b -> Maybe (Voice (a, b))+mergeIfSameDuration = mergeIfSameDurationWith (,)++mergeIfSameDurationWith :: (a -> b -> c) -> Voice a -> Voice b -> Maybe (Voice c)+mergeIfSameDurationWith f a b+  | sameDurations a b = Just $ zipVoiceWithNoScale f a b+  | otherwise         = Nothing++-- splitAt :: [Duration] -> Voice a -> [Voice a]+-- splitTiesVoiceAt :: Tiable a => [Duration] -> Voice a -> [Voice a]++-- |+-- Split all notes of the latter voice at the onset/offset of the former.+--+-- >>> ["a",(2,"b")^.stretched,"c"]^.voice+-- [(1,"a")^.stretched,(2,"b")^.stretched,(1,"c")^.stretched]^.voice+--+splitLatterToAssureSameDuration :: Voice b -> Voice b -> Voice b+splitLatterToAssureSameDuration = splitLatterToAssureSameDurationWith dup+  where+    dup x = (x,x)++splitLatterToAssureSameDurationWith :: (b -> (b, b)) -> Voice b -> Voice b -> Voice b+splitLatterToAssureSameDurationWith = undefined++polyToHomophonic      :: [Voice a] -> Maybe (Voice [a])+polyToHomophonic = undefined++polyToHomophonicForce :: [Voice a] -> Voice [a]+polyToHomophonicForce = undefined++homoToPolyphonic      :: Voice [a] -> [Voice a]+homoToPolyphonic = undefined++changeCrossing   :: Ord a => Voice a -> Voice a -> (Voice a, Voice a)+changeCrossing = undefined++changeCrossingBy :: Ord b => (a -> b) -> Voice a -> Voice a -> (Voice a, Voice a)+changeCrossingBy = undefined++processExactOverlaps :: (a -> a -> (a, a)) -> Voice a -> Voice a -> (Voice a, Voice a)+processExactOverlaps = undefined++processExactOverlaps' :: (a -> b -> Either (a,b) (b,a)) -> Voice a -> Voice b -> (Voice (Either b a), Voice (Either a b))+processExactOverlaps' = undefined++onsetsRelative    :: Time -> Voice a -> [Time]+onsetsRelative = undefined++offsetsRelative   :: Time -> Voice a -> [Time]+offsetsRelative = undefined++midpointsRelative :: Time -> Voice a -> [Time]+midpointsRelative = undefined++erasRelative      :: Time -> Voice a -> [Span]+erasRelative = undefined++onsetMap  :: Time -> Voice a -> Map Time a+onsetMap = undefined++offsetMap :: Time -> Voice a -> Map Time a+offsetMap = undefined++midpointMap :: Time -> Voice a -> Map Time a+midpointMap = undefined++eraMap :: Time -> Voice a -> Map Span a+eraMap = undefined++durations :: Voice a -> [Duration]+durations = undefined++-- values :: Voice a -> [a] -- Same as Foldable.toList+-- values = undefined++++{-++sameDurations           :: Voice a -> Voice b -> Bool+mergeIfSameDuration     :: Voice a -> Voice b -> Maybe (Voice (a, b))+mergeIfSameDurationWith :: (a -> b -> c) -> Voice a -> Voice b -> Maybe (Voice c)+splitAt :: [Duration] -> Voice a -> [Voice a]+-- splitTiesVoiceAt :: Tiable a => [Duration] -> Voice a -> [Voice a]+splitLatterToAssureSameDuration :: Voice b -> Voice b -> Voice b+splitLatterToAssureSameDurationWith :: (b -> (b, b)) -> Voice b -> Voice b -> Voice b+polyToHomophonic      :: [Voice a] -> Maybe (Voice [a])+polyToHomophonicForce :: [Voice a] -> Voice [a]+homoToPolyphonic      :: Voice [a] -> [Voice a]+joinVoice             :: Voice (Voice a) -> a+changeCrossing   :: Ord a => Voice a -> Voice a -> (Voice a, Voice a)+changeCrossingBy :: Ord b => (a -> b) -> Voice a -> Voice a -> (Voice a, Voice a)+processExactOverlaps :: (a -> a -> (a, a)) -> Voice a -> Voice a -> (Voice a, Voice a)+processExactOverlaps' :: (a -> b -> Either (a,b) (b,a)) -> Voice a -> Voice b -> (Voice (Either b a), Voice (Either a b))+onsetsRelative    :: Time -> Voice a -> [Time]+offsetsRelative   :: Time -> Voice a -> [Time]+midpointsRelative :: Time -> Voice a -> [Time]+erasRelative      :: Time -> Voice a -> [Span]+onsetMap  :: Time -> Voice a -> Map Time a+offsetMap :: Time -> Voice a -> Map Time a+midpointMap :: Time -> Voice a -> Map Time a+eraMap :: Time -> Voice a -> Map Span a+durations :: Voice a -> [Duration]+values    :: Voice a -> [a] -- Same as Foldable.toList+isPossiblyInfinite :: Voice a -> Bool+hasMelodicDissonanceWith :: (a -> a -> Bool) -> Voice a -> Bool+hasIntervalWith :: AffineSpace a => (Diff a -> Bool) -> Voice a -> Bool+hasDurationWith :: (Duration -> Bool) -> Voice a -> Bool+reifyVoice :: Voice a -> Voice (Duration, a)+mapWithIndex :: (Int -> a -> b) -> Voice a -> Voice b+mapWithDuration :: (Duration -> a -> b) -> Voice a -> Voice b+mapWithIndexAndDuration :: (Int -> Duration -> a -> b) -> Voice a -> Voice b+_ :: Iso (Voice ()) [Duration]+asingleton' :: Prism (Voice a) (Duration, a)+asingleton :: Prism (Voice a) a+separateVoicesWith :: (a -> k) -> Voice a -> Map k (Voice a)+freeVoiceR :: (forall a. -> [a] -> a)          -> Voice a -> (a, Duration)+freeVoiceRNoDur :: ([a] -> a)          -> Voice a -> a+freeVoice  :: (forall a. -> [a] -> [a])        -> Voice a -> Voice a+freeVoice2 :: (forall a. -> [a] -> [a] -> [a]) -> Voice a -> Voice a -> Voice a+empty :: Voice a+singleton :: a -> Voice a+cons :: a -> Voice a -> Voice a+snoc :: Voice a -> a -> Voice a+append :: Voice a -> Voice a -> Voice a+ap :: Voice (a -> b) -> Voice a -> Voice b+apDur :: Voice (Duration -> Duration -> a -> b) -> Voice a -> Voice b+intersperse :: Duration -> a -> Voice a -> Voice a+-- intercalate :: Voice a -> Voice (Voice a) -> Voice a+subsequences :: Voice a -> [Voice a]+permutations :: Voice a -> [Voice a]+iterate :: (a -> a) -> a -> Voice a+repeat :: a -> Voice a+replicate :: Int -> a -> Voice a+unfoldr :: (b -> Maybe (a, b)) -> b -> Voice a+Differences between Voice and Chord (except the obviously different composition styles):+  - Voice is a Monoid, Chord just a Semigroup (??)+  - TODO represent spanners using (Voice a, Map (Int,Int) s)+  Arguably this should be part of Voice+  TODO the MVoice/TVoice stuff+newtype MVoice = Voice (Maybe a)+newtype PVoice = [Either Duration (Voice a)]+expandRepeats :: [Voice (Variant a)] -> Voice a++-}