music-score 1.7 → 1.7.1
raw patch · 66 files changed
+1814/−1027 lines, 66 filesdep +aesondep +bifunctorsdep +mtldep ~HCodecsdep ~adjunctionsdep ~lenssetup-changed
Dependencies added: aeson, bifunctors, mtl
Dependency ranges changed: HCodecs, adjunctions, lens, lilypond, music-dynamics-literal, music-pitch-literal, musicxml2, process, transformers, vector-space, vector-space-points
Files
- Setup.hs +0/−10
- music-score.cabal +40/−29
- src/Control/Lens/Cons/Middle.hs +9/−0
- src/Data/Average.hs +127/−0
- src/Data/Clipped.hs +0/−1
- src/Data/Functor/Context.hs +30/−3
- src/Data/Functor/Couple.hs +95/−7
- src/Data/Functor/Rep/Lens.hs +2/−1
- src/Data/Semigroup/Instances.hs +5/−0
- src/Music/Score.hs +4/−2
- src/Music/Score/Articulation.hs +7/−20
- src/Music/Score/Clef.hs +0/−112
- src/Music/Score/Color.hs +5/−2
- src/Music/Score/Convert.hs +4/−23
- src/Music/Score/Dynamics.hs +2/−1
- src/Music/Score/Export/ArticulationNotation.hs +40/−16
- src/Music/Score/Export/Backend.hs +21/−39
- src/Music/Score/Export/DynamicNotation.hs +1/−1
- src/Music/Score/Export/Lilypond.hs +259/−196
- src/Music/Score/Export/Midi.hs +8/−1
- src/Music/Score/Export/MusicXml.hs +13/−56
- src/Music/Score/Export/NoteList.hs +0/−1
- src/Music/Score/Export/SuperCollider.hs +0/−1
- src/Music/Score/Instances.hs +23/−0
- src/Music/Score/Internal/Export.hs +2/−7
- src/Music/Score/Meta.hs +24/−38
- src/Music/Score/Meta/Annotations.hs +3/−4
- src/Music/Score/Meta/Attribution.hs +10/−11
- src/Music/Score/Meta/Barline.hs +5/−6
- src/Music/Score/Meta/Clef.hs +3/−4
- src/Music/Score/Meta/Fermata.hs +3/−4
- src/Music/Score/Meta/Key.hs +4/−5
- src/Music/Score/Meta/RehearsalMark.hs +4/−5
- src/Music/Score/Meta/Tempo.hs +5/−5
- src/Music/Score/Meta/Time.hs +7/−6
- src/Music/Score/Meta/Title.hs +10/−11
- src/Music/Score/Phrases.hs +12/−18
- src/Music/Score/Pitch.hs +22/−1
- src/Music/Score/Slide.hs +41/−47
- src/Music/Score/Text.hs +8/−16
- src/Music/Score/Ties.hs +7/−3
- src/Music/Time.hs +10/−0
- src/Music/Time/Behavior.hs +16/−14
- src/Music/Time/Bound.hs +7/−6
- src/Music/Time/Chord.hs +73/−1
- src/Music/Time/Delayed.hs +7/−6
- src/Music/Time/Duration.hs +25/−0
- src/Music/Time/Future.hs +3/−0
- src/Music/Time/Graces.hs +2/−0
- src/Music/Time/Internal/Quantize.hs +30/−16
- src/Music/Time/Internal/Transform.hs +21/−31
- src/Music/Time/Juxtapose.hs +1/−0
- src/Music/Time/Meta.hs +201/−53
- src/Music/Time/Nominal.hs +2/−0
- src/Music/Time/Note.hs +5/−7
- src/Music/Time/Past.hs +24/−0
- src/Music/Time/Position.hs +10/−3
- src/Music/Time/Reactive.hs +7/−7
- src/Music/Time/Reverse.hs +1/−0
- src/Music/Time/Score.hs +35/−27
- src/Music/Time/Segment.hs +13/−16
- src/Music/Time/Split.hs +3/−0
- src/Music/Time/Stretched.hs +25/−9
- src/Music/Time/Track.hs +12/−3
- src/Music/Time/Types.hs +271/−61
- src/Music/Time/Voice.hs +145/−54
Setup.hs view
@@ -2,13 +2,3 @@ import Distribution.Simple main = defaultMain---- import Data.Monoid--- import System.Process--- import Distribution.Simple--- --- main = defaultMainWithHooks simpleUserHooks { preBuild = preBuild' }--- --- preBuild' _ _ = do--- runCommand "hackette cp Music.Score.Util src/Music/Score/Util.hs"--- return mempty
music-score.cabal view
@@ -1,6 +1,6 @@ name: music-score-version: 1.7+version: 1.7.1 author: Hans Hoglund maintainer: Hans Hoglund license: BSD3@@ -17,45 +17,52 @@ This library is part of the Music Suite, see <http://music-suite.github.io>. source-repository head- type: git- location: git://github.com/music-suite/music-score.git+ type: git+ location: git://github.com/music-suite/music-score.git -library - build-depends: base >= 4 && < 5,- lens >= 4.1.2 && < 4.2,- process,- data-default, - containers, +library+ build-depends: base >= 4 && < 5,+ aeson >= 0.7.0.6 && < 1,+ lens >= 4.3 && < 4.4,+ process >= 1.2 && < 1.3,+ containers,++ void,+ nats, + data-default,+ semigroups >= 0.13.0.1 && < 1,+ semigroupoids,+ contravariant >= 0.4.4 && < 1, comonad,+ bifunctors, profunctors,- transformers, distributive,- adjunctions,- NumInstances,+ adjunctions >= 4.1 && < 5,+ transformers >= 0.3.0.0 && < 0.5,+ mtl >= 2.1.2 && < 2.3, monadplus,- void,- semigroups >= 0.13.0.1 && < 1,- -- monoid-extras,- contravariant >= 0.4.4 && < 1,- nats, - semigroupoids,+ NumInstances,+ colour >= 2.3.3 && < 3.0,- HCodecs >= 0.3 && < 0.4,- vector-space,- vector-space-points == 0.1.3,- musicxml2 == 1.7,- lilypond == 1.7,- music-pitch-literal == 1.7,- music-dynamics-literal == 1.7,+ 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,+ prettify, parsec- exposed-modules: Data.Clipped+ exposed-modules: Data.Clipped Data.PairMonad Data.Functor.Couple Data.Functor.Context Data.Functor.Rep.Lens Data.Semigroup.Instances+ Data.Average Control.Monad.Compose+ Control.Lens.Cons.Middle Music.Time Music.Time.Types Music.Time.Transform@@ -68,6 +75,10 @@ Music.Time.Stretched Music.Time.Delayed Music.Time.Note+ Music.Time.Future+ Music.Time.Past+ Music.Time.Nominal+ Music.Time.Graces Music.Time.Track Music.Time.Voice Music.Time.Chord@@ -94,7 +105,7 @@ Music.Score.Meta.Tempo Music.Score.Meta.Time Music.Score.Meta.Title- Music.Score.Clef+ -- Music.Score.Clef Music.Score.Pitch Music.Score.Articulation Music.Score.Dynamics@@ -123,6 +134,6 @@ Music.Time.Internal.Quantize Music.Score.Internal.Util Music.Score.Internal.Export- hs-source-dirs: src- default-language: Haskell2010+ hs-source-dirs: src+ default-language: Haskell2010 --ghc-options: -fwarn-unused-imports
+ src/Control/Lens/Cons/Middle.hs view
@@ -0,0 +1,9 @@++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
+ src/Data/Average.hs view
@@ -0,0 +1,127 @@++{-# 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)++
src/Data/Clipped.hs view
@@ -34,7 +34,6 @@ import Data.Ratio import Control.Applicative-import Control.Arrow (first, second, (***), (&&&)) import qualified Control.Category import Control.Comonad import Control.Comonad.Env
src/Data/Functor/Context.hs view
@@ -1,17 +1,44 @@ +{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DeriveFunctor #-}+ module Data.Functor.Context ( Ctxt(..), mapCtxt, extractCtxt, ) where +import Control.Comonad+import Control.Applicative+import Control.Lens.Wrapped+import Control.Lens.Iso+ -- TODO use newtype and derivice Functor, Comonad etc-type Ctxt a = (Maybe a, a, Maybe a)+newtype Ctxt a = Ctxt { getCtxt :: (Maybe a, a, Maybe a) }+ deriving (Functor) +instance Wrapped (Ctxt a) where+ type Unwrapped (Ctxt a) = (Maybe a, a, Maybe a)+ _Wrapped' = iso getCtxt Ctxt +instance Rewrapped (Ctxt a) (Ctxt b)++instance Applicative Ctxt where+ pure x = Ctxt (Nothing, x, Nothing)+ Ctxt (b,x,a) <*> Ctxt (b',x',a') = Ctxt (b <*> b', x x', a <*> a')+ +-- instance Comonad Ctxt where+ -- extract (Ctxt (b,x,a)) = x++ -- duplicate (Ctxt (Nothing,x,Nothing)) = Ctxt (Nothing, Ctxt (Nothing, x, Nothing), Nothing)+ -- duplicate (Ctxt (Just b,x,Nothing)) = Ctxt (Ctxt Just b, Ctxt (Just b, x, Nothing), Nothing)+ -- duplicate (Ctxt (Nothing,x,Just a)) = Ctxt (Nothing, Ctxt (Nothing, x, Just a), Just a)+ -- duplicate (Ctxt (Just b,x,Just a)) = Ctxt (b, Ctxt (b, x, Just a), Just a)+ mapCtxt :: (a -> b) -> Ctxt a -> Ctxt b-mapCtxt f (a,b,c) = (fmap f a, f b, fmap f c)+mapCtxt = fmap extractCtxt :: Ctxt a -> a-extractCtxt (_,x,_) = x+extractCtxt (Ctxt (_,x,_)) = x
src/Data/Functor/Couple.hs view
@@ -9,8 +9,22 @@ MultiParamTypeClasses, TypeFamilies #-}-module Data.Functor.Couple where+-- |+-- Defines two variants of @(,)@ with lifted instances for the standard type classes.+--+-- The 'Functor', 'Applicative' and 'Comonad' instances are the standard instances. The+-- 'Monad' instances are not in base (but should argubly be there). All of these instances+-- are equivalent to 'Writer' in transformers.+--+-- 'Applicative' is used to lift 'Monoid' and the standard numeric classes.+--+-- The only difference between 'Twain' and 'Couple' is the handling of 'Eq' and 'Ord':+-- 'Twain' compares only the second value, while 'Couple' compares both. Thus 'Couple' needs+-- an extra @Ord b@ constraint for all sub-classes of 'Ord'.+--+module Data.Functor.Couple (Twain(..), Couple(..)) where +import Data.Bifunctor import Data.Functor.Product import Data.Functor.Identity import Data.Foldable@@ -21,16 +35,89 @@ import Control.Applicative import Control.Comonad import Data.PairMonad ()-import Control.Arrow (first) import Control.Lens (Wrapped(..), Rewrapped(..), iso) -- | -- 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)++instance Wrapped (Twain b a) where+ type Unwrapped (Twain b a) = (b, a)+ _Wrapped' = iso getTwain Twain++instance Rewrapped (Twain c a) (Twain c b)++instance (Monoid b, Num a) => Num (Twain b a) where+ (+) = liftA2 (+)+ (*) = liftA2 (*)+ (-) = liftA2 (-)+ abs = fmap abs+ signum = fmap signum+ fromInteger = pure . fromInteger++instance (Monoid b, Fractional a) => Fractional (Twain b a) where+ recip = fmap recip+ fromRational = pure . fromRational++instance (Monoid b, Floating a) => Floating (Twain b a) where+ pi = pure pi+ sqrt = fmap sqrt+ exp = fmap exp+ log = fmap log+ sin = fmap sin+ cos = fmap cos+ asin = fmap asin+ atan = fmap atan+ acos = fmap acos+ sinh = fmap sinh+ cosh = fmap cosh+ asinh = fmap asinh+ atanh = fmap atanh+ acosh = fmap acos++instance (Monoid b, Enum a) => Enum (Twain b a) where+ toEnum = pure . toEnum+ fromEnum = fromEnum . extract++instance (Monoid b, Bounded a) => Bounded (Twain b a) where+ minBound = pure minBound+ maxBound = pure maxBound++-- +-- Eq, Ord and their subclasses+-- +-- If comparison takes both values into account, we must add and (Ord b)+-- constraint to all of the following instances. Instead, follow the+-- spirit of the Num et al instances to compare just the second argument.+--++instance Eq a => Eq (Twain b a) where+ Twain (b,a) == Twain (b',a') = a == a'++instance Ord a => Ord (Twain b a) where+ Twain (b,a) < Twain (b',a') = a < a'++instance (Monoid b, Real a, Enum a, Integral a) => Integral (Twain b a) where+ quot = liftA2 quot+ rem = liftA2 rem+ quotRem = fmap (fmap unzipR) (liftA2 quotRem)+ toInteger = toInteger . extract ++instance (Monoid b, Real a) => Real (Twain b a) where+ toRational = toRational . extract++instance (Monoid b, RealFrac a) => RealFrac (Twain b a) where+ properFraction = first extract . unzipR . fmap properFraction+++-- |+-- A variant of pair/writer with lifted instances for the numeric classes, using 'Applicative'.+-- newtype Couple b a = Couple { getCouple :: (b, a) }- deriving (Eq, Show, Functor, Foldable, Typeable, Applicative, Monad, Comonad)+ deriving (Show, Functor, Foldable, Typeable, Applicative, Monad, Comonad, Semigroup, Monoid) --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (Couple b a) where type Unwrapped (Couple b a) = (b, a) _Wrapped' = iso getCouple Couple@@ -73,10 +160,11 @@ minBound = pure minBound maxBound = pure maxBound --- The following are more suspect, as they require Ord+instance (Eq b, Eq a) => Eq (Couple b a) where+ Couple ((b,a)) == Couple (b',a') = (b,a) == (b',a') -instance (Monoid b, Ord b, Ord a) => Ord (Couple b a) where- Couple (a,b) < Couple (a',b') = (b,a) < (b',a')+instance (Ord b, Ord a) => Ord (Couple b a) where+ Couple (b,a) < Couple (b',a') = (b,a) < (b',a') instance (Monoid b, Ord b, Real a, Enum a, Integral a) => Integral (Couple b a) where quot = liftA2 quot
src/Data/Functor/Rep/Lens.hs view
@@ -17,6 +17,7 @@ infixl 6 ! +{- -- | -- The isomorpism between a representable functor and its representation. --@@ -26,5 +27,5 @@ -- tabulated :: (Representable f, Representable g) => Iso (Rep f -> a) (Rep g -> b) (f a) (g b) tabulated = iso tabulate index-+-}
src/Data/Semigroup/Instances.hs view
@@ -1,4 +1,5 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveFunctor #-}@@ -15,7 +16,9 @@ -- TODO move these to semigroups and music-pitch-literal +#if (__GLASGOW_HASKELL__ < 781) 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)@@ -30,7 +33,9 @@ Sum p .+^ Sum v = Sum (p .+^ v) +#if (__GLASGOW_HASKELL__ < 781) 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)
src/Music/Score.hs view
@@ -23,6 +23,7 @@ module Data.VectorSpace, module Data.AffineSpace, module Data.AffineSpace.Point,+ module Data.Average, module Music.Time, -- module Music.Score.Combinators,@@ -42,7 +43,7 @@ -- ** Miscellaneous module Music.Score.Ties, module Music.Score.Phrases,- module Music.Score.Clef,+ -- module Music.Score.Clef, -- ** Meta-information module Music.Score.Meta,@@ -90,11 +91,12 @@ import Data.Traversable import Data.Typeable import Data.VectorSpace hiding (Sum, getSum)+import Data.Average import Music.Time hiding (time) import Music.Score.Articulation-import Music.Score.Clef+-- import Music.Score.Clef import Music.Score.Color import Music.Score.Dynamics import Music.Score.Export.Backend
src/Music/Score/Articulation.hs view
@@ -75,6 +75,7 @@ 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@@ -318,7 +319,7 @@ accentuation :: Lens' a (Accentuation a) separation :: Lens' a (Separation a) -+{- -- TODO move instance Num () where _ + _ = ()@@ -344,6 +345,7 @@ instance Articulated () where accentuation = id separation = id+-} instance (AffineSpace a, AffineSpace b, Fractional a, Fractional b) => Articulated (a, b) where accentuation = _1'@@ -358,16 +360,16 @@ accent :: (HasPhrases' s b, HasArticulations' b, Articulation b ~ a, Articulated a) => s -> s-accent = set (phrases . headV . articulations . accentuation) 1+accent = set (phrases . _head . articulations . accentuation) 1 marcato :: (HasPhrases' s b, HasArticulations' b, Articulation b ~ a, Articulated a) => s -> s-marcato = set (phrases . headV . articulations . accentuation) 2+marcato = set (phrases . _head . articulations . accentuation) 2 accentLast :: (HasPhrases' s b, HasArticulations' b, Articulation b ~ a, Articulated a) => s -> s-accentLast = set (phrases . lastV . articulations . accentuation) 1+accentLast = set (phrases . _last . articulations . accentuation) 1 marcatoLast :: (HasPhrases' s b, HasArticulations' b, Articulation b ~ a, Articulated a) => s -> s-marcatoLast = set (phrases . lastV . articulations . accentuation) 2+marcatoLast = set (phrases . _last . articulations . accentuation) 2 accentAll :: (HasArticulations' s, Articulation s ~ a, Articulated a) => s -> s accentAll = set (articulations . accentuation) 1@@ -481,18 +483,3 @@ where (a1,a2) = toTied a (d1,d2) = toTied d---headV :: Traversal' (Voice a) a-headV = (eventsV._head._2)--middleV :: Traversal' (Voice a) a-middleV = (eventsV._middle.traverse._2)--lastV :: Traversal' (Voice a) a-lastV = (eventsV._last._2)---- Traverse writing to all elements *except* first and last-_middle :: (Snoc s s a a, Cons s s b b) => Traversal' s s-_middle = _tail._init-
− src/Music/Score/Clef.hs
@@ -1,112 +0,0 @@--{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}------------------------------------------------------------------------------------------ |--- Copyright : (c) Hans Hoglund 2012-2014------ License : BSD-style------ Maintainer : hans@hanshoglund.se--- Stability : experimental--- Portability : non-portable (TF,GNTD)------ Provides clefs.------ /Warning/ Experimental module.--------------------------------------------------------------------------------------------module Music.Score.Clef (- ClefT(..),- HasClef(..),- ) where--import Control.Arrow-import Control.Lens hiding (transform, parts)-import Control.Monad.Plus-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.Score.Meta.Clef-import Music.Score.Part-import Music.Score.Ties-import Music.Score.Internal.Util-import Music.Time----- Put the given clef in front of the note-newtype ClefT a = ClefT { getClefT :: (Option (Last Clef), a) }- deriving (Functor, Semigroup, Monoid)----- | Unsafe: Do not use 'Wrapped' instances-instance Wrapped (ClefT a) where- type Unwrapped (ClefT a) = (Option (Last Clef), a)- _Wrapped' = iso getClefT ClefT--instance Rewrapped (ClefT a) (ClefT b)---instance Monad ClefT where- return x = ClefT (mempty, x)- (>>=) = error "No ClefT.(>>=)"---type instance Part (ClefT a) = Part a-type instance SetPart b (ClefT a) = ClefT (SetPart b a)---instance (HasParts a b) => HasParts (ClefT a) (ClefT b) where- parts = _Wrapped . parts--instance (HasPart a b) => HasPart (ClefT a) (ClefT b) where- part = _Wrapped . part---instance Transformable a => Transformable (ClefT a) where- transform s = over (_Wrapped . _2) $ transform s- -instance Tiable a => Tiable (ClefT a) where- toTied (ClefT (clef,a)) = (ClefT (clef,b), ClefT (mempty,c)) where (b,c) = toTied a--class HasClef a where- applyClef :: Clef -> a -> a--instance HasClef (ClefT a) where- applyClef c (ClefT (_,a)) = ClefT (Option $ Just $ Last c,a)--instance HasClef a => HasClef (b,a) where- applyClef c = fmap (applyClef c)--instance (HasPart' a, HasClef a) => HasClef (Score a) where- applyClef c = id -- TODO- -- applyClef c = mapFirst (applyClef c) id-
src/Music/Score/Color.hs view
@@ -37,6 +37,8 @@ -- * Manipulating color color,+ colorRed,+ colorBlue, -- * Representation ColorT(..),@@ -92,8 +94,6 @@ deriving instance Floating a => Floating (ColorT a) deriving instance Enum a => Enum (ColorT a) deriving instance Bounded a => Bounded (ColorT a)--- deriving instance (Num a, Ord a, Real a) => Real (ColorT a)--- deriving instance (Real a, Enum a, Integral a) => Integral (ColorT a) -- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (ColorT a) where@@ -122,4 +122,7 @@ -- color :: HasColor a => Colour Double -> a -> a color = setColor++colorRed = color C.red+colorBlue = color C.blue
src/Music/Score/Convert.hs view
@@ -78,14 +78,14 @@ 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 = toRelN' (0 .+^ d) times+ 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 = toRelN' v times+ durs = toRelativeTimeN' v times {-# DEPRECATED reactiveToVoice' "" #-} -- |@@ -138,30 +138,11 @@ -} --- Convert to delta (time to wait before this note)-toRel :: [Time] -> [Duration]-toRel = snd . mapAccumL g 0 where g prev t = (t, t .-. prev)---- Convert to delta (time to wait before next note)-toRelN :: [Time] -> [Duration]-toRelN [] = []-toRelN xs = snd $ mapAccumR g (last xs) xs where g prev t = (t, prev .-. t)---- Convert to delta (time to wait before next note)-toRelN' :: Time -> [Time] -> [Duration]-toRelN' end xs = snd $ mapAccumR g end xs where g prev t = (t, prev .-. t)---- 0 x,1 x,1 x,1 x- -- x 1,x 1,x 1,x 0---- Convert from delta (time to wait before this note)-toAbs :: [Duration] -> [Time]-toAbs = snd . mapAccumL g 0 where g now d = (now .+^ d, now .+^ d)-- -- 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))
src/Music/Score/Dynamics.hs view
@@ -69,7 +69,6 @@ ) where import Control.Applicative-import Control.Arrow import Control.Comonad import Control.Lens hiding (Level, transform) import Control.Monad@@ -471,6 +470,8 @@ where (a1,a2) = toTied a (d1,d2) = toTied d++-- JUNK -- | -- View just the dynamices in a voice.
src/Music/Score/Export/ArticulationNotation.hs view
@@ -39,6 +39,7 @@ import Data.Semigroup import Data.Functor.Context+import Data.Functor.Adjunction (unzipR) import Control.Lens -- () import Music.Score.Articulation import Music.Score.Instances@@ -81,18 +82,34 @@ transform _ = id instance Tiable ArticulationNotation where- toTied (ArticulationNotation (beginEnd, marks)) - = (ArticulationNotation (beginEnd, marks), - ArticulationNotation (mempty, mempty))+ toTied (ArticulationNotation (slur, marks)) + = (ArticulationNotation (slur1, marks1), + ArticulationNotation (slur2, marks2))+ where+ (marks1, marks2) = splitMarks marks+ (slur1, slur2) = splitSlurs slur + splitSlurs = unzipR . fmap splitSlur+ splitMarks = unzipR . fmap splitMark++ splitSlur NoSlur = (mempty, mempty)+ splitSlur BeginSlur = (BeginSlur, mempty)+ splitSlur EndSlur = (mempty, EndSlur)++ splitMark NoMark = (NoMark, mempty)+ splitMark Staccato = (Staccato, mempty)+ splitMark MoltoStaccato = (MoltoStaccato, mempty)+ splitMark Marcato = (Marcato, mempty)+ splitMark Accent = (Accent, mempty)+ splitMark Tenuto = (Tenuto, mempty)++ instance Monoid ArticulationNotation where mempty = ArticulationNotation ([], []) ArticulationNotation ([], []) `mappend` y = y x `mappend` ArticulationNotation ([], []) = x x `mappend` y = x --- TODO add slurs if separation is below some value...- getSeparationMarks :: Double -> [Mark] getSeparationMarks = fst . getSeparationMarks' @@ -114,18 +131,25 @@ | 2 <= x = [Marcato] | otherwise = [] +hasSlur :: (Real (Separation t), Articulated t) => t -> Bool hasSlur y = hasSlur' (realToFrac $ view separation $ y)-allMarks y = getSeparationMarks (realToFrac $ view separation $ y) <> getAccentMarks (realToFrac $ view accentuation $ y) -notateArticulation :: (Ord a, a ~ (Sum Double, Sum Double)) => Ctxt a -> ArticulationNotation-notateArticulation (Nothing, y, Nothing) = ArticulationNotation ([], allMarks y)-notateArticulation (Just x, y, Nothing) = ArticulationNotation (if hasSlur x && hasSlur y then [EndSlur] else [], allMarks y)-notateArticulation (Nothing, y, Just z) = ArticulationNotation (if hasSlur y && hasSlur z then [BeginSlur] else [], allMarks y)-notateArticulation (Just x, y, Just z) = ArticulationNotation (slur3 x y z, allMarks y)+allMarks :: (Real (Separation t), Real (Accentuation t), Articulated t) => t -> [Mark]+allMarks y = mempty+ <> getSeparationMarks (realToFrac $ y^.separation) + <> getAccentMarks (realToFrac $ y^.accentuation)++notateArticulation :: (Ord a, Articulated a, Real (Separation a), Real (Accentuation a)) => Ctxt a -> ArticulationNotation+notateArticulation (getCtxt -> x) = go x where- slur3 x y z = case (hasSlur x, hasSlur y, hasSlur z) of- (True, True, True) -> [{-ContSlur-}]- (False, True, True) -> [BeginSlur]- (True, True, False) -> [EndSlur]- _ -> []+ go (Nothing, y, Nothing) = ArticulationNotation ([], allMarks y)+ go (Just x, y, Nothing) = ArticulationNotation (if hasSlur x && hasSlur y then [EndSlur] else [], allMarks y)+ go (Nothing, y, Just z) = ArticulationNotation (if hasSlur y && hasSlur z then [BeginSlur] else [], allMarks y)+ go (Just x, y, Just z) = ArticulationNotation (slur3 x y z, allMarks y)+ where+ slur3 x y z = case (hasSlur x, hasSlur y, hasSlur z) of+ (True, True, True) -> [{-ContSlur-}]+ (False, True, True) -> [BeginSlur]+ (True, True, False) -> [EndSlur]+ _ -> []
src/Music/Score/Export/Backend.hs view
@@ -32,6 +32,8 @@ HasOrdPart, HasDynamic3, HasDynamicNotation,+ HasArticulation3,+ HasArticulationNotation, HasBackend(..), HasBackendScore(..),@@ -42,7 +44,6 @@ import Music.Dynamics.Literal import Music.Pitch.Literal import qualified Codec.Midi as Midi-import Control.Arrow ((***)) import Control.Comonad (Comonad (..), extract) import Control.Applicative import Data.Colour.Names as Color@@ -61,35 +62,28 @@ import Music.Time.Internal.Quantize import qualified Text.Pretty as Pretty import qualified Data.List-import Music.Score.Convert (reactiveToVoice') -- TODO+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 Music.Time import Music.Score.Dynamics+import Music.Score.Articulation import Music.Score.Part type HasDynamic3 a a' a'' = ( HasDynamic' a,+ HasDynamic' a'', HasDynamic a a', HasDynamic a' a'', HasDynamic a a'' ) --- -- TODO move--- class (--- HasDynamic' a,--- HasDynamic a a',--- HasDynamic a' a'',--- HasDynamic a a''--- ) => HasDynamic3 a a' a'' where--- --- instance (b ~ SetDynamic (Ctxt (Dynamic MyNote)) MyNote, c ~ SetDynamic DynamicNotation MyNote) --- => HasDynamic3 MyNote b c- type HasDynamicNotation a b c = ( HasDynamic3 a b c, Dynamic b ~ Ctxt (Dynamic a),@@ -97,35 +91,23 @@ Real (Dynamic a), Part (SetDynamic (Dynamic a) a) ~ Part (SetDynamic DynamicNotation b) )-type HasOrdPart a = (HasPart' a, Ord (Part a)) ---{---- TODO move-mapWithDur :: (Duration -> a -> b) -> Rhythm a -> Rhythm b-mapWithDur f = go- where- go (Beat d x) = Beat d (f d x)- go (Dotted n (Beat d x)) = Dotted n $ Beat d (f (dotMod n * d) x)- go (Group rs) = Group $ fmap (mapWithDur f) rs- go (Tuplet m r) = Tuplet m (mapWithDur f r) --extractTimeSignatures :: Score a -> ([Maybe TimeSignature], [Duration])-extractTimeSignatures score = (barTimeSignatures, barDurations)- where - defaultTimeSignature = time 4 4- timeSignatures = fmap swap - $ view eventsV . fuse . reactiveToVoice' (0 <-> (score^.offset)) - $ getTimeSignatures defaultTimeSignature score-- -- Despite the fuse above we need retainUpdates here to prevent redundant repetition of time signatures- barTimeSignatures = retainUpdates $ getBarTimeSignatures timeSignatures- barDurations = getBarDurations timeSignatures-+type HasOrdPart a = (HasPart' a, Ord (Part a)) --}+type HasArticulation3 c d e = (+ HasArticulation' c,+ HasArticulation c d,+ HasArticulation d e,+ HasArticulation c e+ ) +type HasArticulationNotation a b c = (+ HasArticulation3 a b c,+ Articulation b ~ Ctxt (Articulation a),+ Articulation c ~ ArticulationNotation,+ -- TODO generalize+ Articulation a ~ (Sum Double, Sum Double)+ )
src/Music/Score/Export/DynamicNotation.hs view
@@ -84,7 +84,7 @@ -- 2) Whether we should display the current dynamic value -- notateDynamic :: (Ord a, Real a) => Ctxt a -> DynamicNotation-notateDynamic x = DynamicNotation $ over _2 (\t -> if t then Just (realToFrac $ extractCtxt x) else Nothing) $ case x of+notateDynamic x = DynamicNotation $ over _2 (\t -> if t then Just (realToFrac $ extractCtxt x) else Nothing) $ case getCtxt x of (Nothing, y, Nothing) -> ([], True) (Nothing, y, Just z ) -> case (y `compare` z) of LT -> ([BeginCresc], True)
src/Music/Score/Export/Lilypond.hs view
@@ -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,11 +34,11 @@ Lilypond, LyContext(..), HasLilypond,- + -- ** Converting to Lilypond toLilypond,- toLilypondString, - + toLilypondString,+ -- ** Lilypond I/O showLilypond, openLilypond,@@ -50,58 +50,56 @@ writeLilypond', ) where -import Music.Dynamics.Literal-import Music.Pitch.Literal-import qualified Codec.Midi as Midi-import Control.Arrow ((***))-import Control.Comonad (Comonad (..), extract) import Control.Applicative-import Data.Colour.Names as Color+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.Default-import Data.Foldable (Foldable)-import qualified Data.Foldable+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 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.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', voiceToScore) -- 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 qualified Text.Pretty as Pretty -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.Time-import Music.Score.Meta-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.Phrases+import Music.Dynamics.Literal+import qualified Music.Lilypond as Lilypond+import Music.Pitch.Literal+import Music.Score.Articulation+import Music.Score.Color+import Music.Score.Dynamics+import Music.Score.Export.ArticulationNotation+import Music.Score.Export.Backend+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, withPrevNext)+import Music.Score.Meta+import Music.Score.Meta.Time+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 @@ -110,7 +108,7 @@ --- | +-- | -- Extract instrument info as per "Music.Part" -- This is really crude, needs rethinking! --@@ -131,11 +129,11 @@ data ScoreInfo = ScoreInfo deriving (Eq, Show) -data StaffInfo = StaffInfo { staffName :: String, - staffClef :: Lilypond.Clef } +data StaffInfo = StaffInfo { staffName :: String,+ staffClef :: Lilypond.Clef } deriving (Eq, Show) -data BarInfo = BarInfo { barTimeSignature :: Maybe TimeSignature } +data BarInfo = BarInfo { barTimeSignature :: Maybe TimeSignature } deriving (Eq, Show) -- | Hierachical representation of a Lilypond score.@@ -148,7 +146,7 @@ deriving (Functor, Eq, Show) -- | A bar is a sequential composition of chords/notes/rests.-data LyBar a = LyBar { getLyBar :: (BarInfo, Rhythm a) } +data LyBar a = LyBar { getLyBar :: (BarInfo, Rhythm a) } deriving (Functor, Eq, Show) -- | Context passed to the note export.@@ -174,21 +172,16 @@ finalizeExport _ = finalizeScore where finalizeScore :: LyScore LyMusic -> Lilypond.Music- finalizeScore (LyScore (info, x)) - = pcatLy - . map finalizeStaff $ x- where- extra = id+ finalizeScore (LyScore (info, x)) = pcatLy . map finalizeStaff $ x -- TODO finalizeStaffGroup finalizeStaff :: LyStaff LyMusic -> LyMusic- finalizeStaff (LyStaff (info, x)) - = addStaff - . addPartName (staffName info) + finalizeStaff (LyStaff (info, x))+ = addStaff+ . addPartName (staffName info) . addClef (staffClef info)- . scatLy - . map finalizeBar $ x+ . scatLy . map finalizeBar $ x where addStaff = Lilypond.New "Staff" Nothing addClef c x = scatLy [Lilypond.Clef c, x]@@ -199,15 +192,16 @@ finalizeBar :: LyBar LyMusic -> LyMusic finalizeBar (LyBar (BarInfo timeSignature, x))- = maybe id setBarTimeSignature timeSignature + = (setTimeSignature `ifJust` timeSignature) . renderBarMusic $ x where+ ifJust = maybe id -- TODO key signatures -- TODO rehearsal marks -- TODO bar number change -- TODO compound time signatures- setBarTimeSignature (getTimeSignature -> (ms, n)) x = scatLy [Lilypond.Time (sum ms) n, x]- + setTimeSignature (getTimeSignature -> (ms, n)) x = scatLy [Lilypond.Time (sum ms) n, x]+ renderBarMusic :: Rhythm LyMusic -> LyMusic renderBarMusic = go where@@ -216,90 +210,75 @@ go (Group rs) = scatLy $ map renderBarMusic rs go (Tuplet m r) = Lilypond.Times (realToFrac m) (renderBarMusic r) where- (a,b) = fromIntegral *** fromIntegral $ unRatio $ realToFrac m---- TODO move-second f (x, y) = (x, f y)--type HasArticulation3 c d e = (- HasArticulation' c,- HasArticulation c d,- HasArticulation d e,- HasArticulation c e- )--type HasArticulationNotation a b c = (- HasArticulation3 a b c,- Articulation b ~ Ctxt (Articulation a),- Articulation c ~ ArticulationNotation,- -- TODO generalize- Articulation a ~ (Sum Double, Sum Double)- )-+ (a,b) = bimap fromIntegral fromIntegral $ unRatio $ realToFrac m -instance ( +instance ( HasDynamicNotation a b c, HasArticulationNotation c d e, Part e ~ Part c,- HasOrdPart a, - Transformable a, + HasOrdPart a,+ Transformable a, Semigroup a, Tiable e, HasOrdPart c, Show (Part c), HasLilypondInstrument (Part c) ) => HasBackendScore Lilypond (Score a) where type BackendScoreEvent Lilypond (Score a) = SetArticulation ArticulationNotation (SetDynamic DynamicNotation a)- exportScore b score = LyScore + exportScore b score = LyScore . (ScoreInfo,) . map (uncurry $ exportPart timeSignatureMarks barDurations)- . map (second (over articulations notateArticulation)) - . map (second (preserveMeta addArtCon))- . map (second (over dynamics notateDynamic)) - . map (second (preserveMeta addDynCon))- . map (second (preserveMeta simultaneous)) ++ . map (second $ over articulations notateArticulation)+ . map (second $ preserveMeta addArtCon)++ . map (second $ removeCloseDynMarks)+ . map (second $ over dynamics notateDynamic)+ . map (second $ preserveMeta addDynCon)++ . map (second $ preserveMeta simultaneous) . extractParts'- $ score+ $ normScore where- (timeSignatureMarks, barDurations) = extractTimeSignatures score -+ (timeSignatureMarks, barDurations) = extractTimeSignatures normScore+ normScore = normalizeScore score -- | Export a score as a single part. Overlapping notes will cause an error. exportPart :: ( Show (Part a), HasLilypondInstrument (Part a), Tiable a- ) - => [Maybe TimeSignature] - -> [Duration] - -> Part a - -> Score a + )+ => [Maybe TimeSignature]+ -> [Duration]+ -> Part a+ -> Score a -> LyStaff (LyContext a) - exportStaff :: Tiable a - => [Maybe TimeSignature] - -> [Duration] + exportStaff :: Tiable a+ => [Maybe TimeSignature]+ -> [Duration] -> String -- ^ name -> Int -- ^ clef, as per Music.Parts- -> MVoice a + -> MVoice a -> LyStaff (LyContext a) - exportBar :: Tiable a - => Maybe TimeSignature - -> MVoice a + exportBar :: Tiable a+ => Maybe TimeSignature+ -> MVoice a -> LyBar (LyContext a) - quantizeBar :: Tiable a - => MVoice a + quantizeBar :: Tiable a+ => MVoice a -> Rhythm (LyContext a) exportPart timeSignatureMarks barDurations part = exportStaff timeSignatureMarks barDurations (show part) (getLilypondClef part) . view singleMVoice - exportStaff timeSignatures barDurations name clefId - = LyStaff + exportStaff timeSignatures barDurations name clefId+ = LyStaff . addStaffInfo- . zipWith exportBar timeSignatures + . zipWith exportBar timeSignatures . splitIntoBars barDurations where clef = case clefId of@@ -310,11 +289,11 @@ splitIntoBars = splitTiesVoiceAt exportBar timeSignature- = LyBar - . addBarInfo + = LyBar+ . addBarInfo . quantizeBar where- addBarInfo = (,) $ BarInfo timeSignature+ addBarInfo = (,) $ BarInfo timeSignature quantizeBar = mapWithDur LyContext . rewrite . handleErrors . quantize . view eventsV where@@ -322,34 +301,13 @@ handleErrors (Left e) = error $ "Quantization failed: " ++ e handleErrors (Right x) = x --- 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)) ---{---- TODO customize and remove extraction-related constraints-instance (- HasDynamicNotation a b c,- HasOrdPart a, Transformable a, Semigroup a,- HasOrdPart c, Show (Part c), HasLilypondInstrument (Part c), Tiable c- )- => HasBackendScore Lilypond (Voice a) where- type BackendScoreEvent Lilypond (Voice a) = SetDynamic DynamicNotation a- exportScore b = exportScore b . voiceToScore--}- -------------------------------------------------------------------------------- {- Note: We want all note transformers to be applicative morphisms, i.e.- + notate (pure x) = pure (notate x) Specifically@@ -361,8 +319,8 @@ exportNote b = uncurry notate . fmap (exportNote b) . getTieT . sequenceA The latter looks a lot like cotraverse. Generalization?- - ++ -} instance HasBackendNote Lilypond a => HasBackendNote Lilypond [a] where@@ -407,11 +365,11 @@ exportChord b = exportChord b . fmap (fmap extract) instance HasBackendNote Lilypond a => HasBackendNote Lilypond (DynamicT DynamicNotation a) where- exportNote b = uncurry notate . fmap (exportNote b) . getDynamicT . sequenceA+ exportNote b = uncurry notate . getDynamicT . fmap (exportNote b) . sequenceA where notate :: DynamicNotation -> LyMusic -> LyMusic- notate (DynamicNotation (crescDims, level)) - = rcomposed (fmap notateCrescDim crescDims) + notate (DynamicNotation (crescDims, level))+ = rcomposed (fmap notateCrescDim crescDims) . notateLevel level notateCrescDim crescDims = case crescDims of@@ -425,7 +383,7 @@ notateLevel showLevel = case showLevel of Nothing -> id Just lvl -> Lilypond.addDynamics (fromDynamics (DynamicsL (Just (fixLevel . realToFrac $ lvl), Nothing)))- + fixLevel :: Double -> Double fixLevel x = fromIntegral (round (x - 0.5)) + 0.5 @@ -433,13 +391,13 @@ rcomposed = composed . reverse instance HasBackendNote Lilypond a => HasBackendNote Lilypond (ArticulationT ArticulationNotation a) where- exportNote b = uncurry notate . fmap (exportNote b) . getArticulationT . sequenceA+ exportNote b = uncurry notate . getArticulationT . fmap (exportNote b) . sequenceA where notate :: ArticulationNotation -> LyMusic -> LyMusic notate (ArticulationNotation (slurs, marks))- = rcomposed (fmap notateMark marks) - . rcomposed (fmap notateSlur slurs) - + = rcomposed (fmap notateMark marks)+ . rcomposed (fmap notateSlur slurs)+ notateMark mark = case mark of NoMark -> id Staccato -> Lilypond.addStaccato@@ -455,15 +413,15 @@ -- Use rcomposed as notateDynamic returns "mark" order, not application order rcomposed = composed . reverse- + instance HasBackendNote Lilypond a => HasBackendNote Lilypond (ColorT a) where- exportNote b = uncurry notate . fmap (exportNote b) . getCouple . getColorT . sequenceA+ exportNote b = uncurry notate . getCouple . getColorT . fmap (exportNote b) . sequenceA where -- TODO This syntax will change in future Lilypond versions -- TODO handle any color notate (Option Nothing) = id notate (Option (Just (Last color))) = \x -> Lilypond.Sequential [- Lilypond.Override "NoteHead#' color" + Lilypond.Override "NoteHead#' color" (Lilypond.toLiteralValue $ "#" ++ colorName color), x, Lilypond.Revert "NoteHead#' color"@@ -486,15 +444,15 @@ scale = 2^n newDur = (d `min` (1/4)) / scale repeats = d / newDur- in (Lilypond.Tremolo (round repeats), newDur) + in (Lilypond.Tremolo (round repeats), newDur) instance HasBackendNote Lilypond a => HasBackendNote Lilypond (TextT a) where- exportNote b = uncurry notate . fmap (exportNote b) . getCouple . getTextT . sequenceA+ exportNote b = uncurry notate . 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 . fmap (exportNote b) . getCouple . getHarmonicT . sequenceA+ exportNote b = uncurry notate . getCouple . getHarmonicT . fmap (exportNote b) . sequenceA where notate (Any isNat, Sum n) = case (isNat, n) of (_, 0) -> id@@ -504,22 +462,40 @@ notateArtificial n = id -- TODO instance HasBackendNote Lilypond a => HasBackendNote Lilypond (SlideT a) where- exportNote b = uncurry notate . fmap (exportNote b) . getCouple . getSlideT . sequenceA- where- notate ((Any eg, Any es),(Any bg, Any bs))- | bg = Lilypond.beginGlissando- | bs = Lilypond.beginGlissando- | otherwise = id+ 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+ + BC (TieT a) sequenceA+ TieT (BC a) fmap (exportNote b)+ TieT BN notate . getTieT+ BN+ + BC [TieT a] fmap sequenceA+ BC (TieT [a]) sequenceA+ TieT (BC [a]) fmap (exportChord b)+ TieT BN notate . getTieT+ BN+-} instance HasBackendNote Lilypond a => HasBackendNote Lilypond (TieT a) where- exportNote b = uncurry notate . fmap (exportNote b) . getTieT . sequenceA- where- notate (Any ta, Any tb)- | ta && tb = Lilypond.beginTie- | tb = Lilypond.beginTie- | ta = id- | otherwise = id+ exportNote b = uncurry notateTie . getTieT . fmap (exportNote b) . sequenceA+ exportChord b = uncurry notateTie . getTieT . fmap (exportChord b) . sequenceA . fmap sequenceA +notateTie (Any ta, Any tb)+ | ta && tb = Lilypond.beginTie+ | tb = Lilypond.beginTie+ | ta = id+ | otherwise = id+ -- | -- Constraint for types that has a Lilypond representation. --@@ -608,28 +584,26 @@ -- |--- Typeset a score using Lilypond and open it.------ (This is simple wrapper around 'writeLilypond' that may not work well on all platforms.)+-- Typeset a score using Lilypond and open it. (This is simple wrapper around+-- 'writeLilypond' that may not work well on all platforms.) -- openLilypond :: HasLilypond a => a -> IO () openLilypond = openLilypond' def -- |--- Typeset a score using Lilypond and open it.------ (This is simple wrapper around 'writeLilypond' that may not work well on all platforms.)+-- Typeset a score using Lilypond and open it. (This is simple wrapper around+-- 'writeLilypond' that may not work well on all platforms.) -- openLilypond' :: HasLilypond a => LilypondOptions -> a -> IO () openLilypond' options sc = do writeLilypond' options "test.ly" sc runLilypond >> cleanLilypond >> runOpen- where - runLilypond = void $ runCommand + where+ runLilypond = void $ runCommand "lilypond -f pdf test.ly" >>= waitForProcess- cleanLilypond = void $ runCommand + cleanLilypond = void $ runCommand "rm -f test-*.tex test-*.texi test-*.count test-*.eps test-*.pdf test.eps"- runOpen = void $ runCommand + runOpen = void $ runCommand $ openCommand ++ " test.pdf" @@ -659,12 +633,101 @@ +-- 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) --- Internal stuff+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@@ -689,4 +752,4 @@ fromIntegral oct ) where (pc,alt,oct) = spellPitch (p + 72)--- End internal+
src/Music/Score/Export/Midi.hs view
@@ -41,7 +41,6 @@ import Music.Dynamics.Literal import Music.Pitch.Literal import qualified Codec.Midi as Midi-import Control.Arrow ((***)) import Control.Comonad (Comonad (..), extract) import Control.Applicative import Data.Colour.Names as Color@@ -72,6 +71,7 @@ import Data.AffineSpace import Control.Lens (over) import Control.Lens.Operators hiding ((|>))+import qualified Data.List as List import Music.Time import Music.Score.Dynamics@@ -171,6 +171,13 @@ fileType = Midi.MultiTrack divisions = 1024 endDelta = 10000++ -- | Convert absolute to relative durations.+ -- TODO replace by something more generic+ toRelative :: [(Time, Duration, b)] -> [(Time, Duration, b)]+ toRelative = snd . List.mapAccumL g 0+ where+ g now (t,d,x) = (t, (0 .+^ (t .-. now),d,x)) instance (HasPart' a, HasMidiProgram (Part a)) => HasBackendScore Midi (Voice a) where
src/Music/Score/Export/MusicXml.hs view
@@ -48,9 +48,9 @@ import Music.Dynamics.Literal import Music.Pitch.Literal import qualified Codec.Midi as Midi-import Control.Arrow ((***)) import Control.Comonad (Comonad (..), extract) import Control.Applicative+import Data.Bifunctor import Data.Colour.Names as Color import Data.Default import Data.Foldable (Foldable)@@ -235,13 +235,11 @@ go (Group rs) = mconcat $ map renderBarMusic rs go (Tuplet m r) = MusicXml.tuplet b a (renderBarMusic r) where- (a,b) = fromIntegral *** fromIntegral $ unRatio $ realToFrac m+ (a,b) = bimap fromIntegral fromIntegral $ unRatio $ realToFrac m setDefaultVoice :: MusicXml.Music -> MusicXml.Music setDefaultVoice = MusicXml.setVoice 1 --- TODO move-second f (x, y) = (x, f y) instance ( HasDynamicNotation a b c,@@ -257,6 +255,7 @@ . map (second (preserveMeta addDynCon)) . map (second (preserveMeta simultaneous)) . extractParts'+ . normalizeScore $ score where title = fromMaybe "" $ flip getTitleAt 0 $ metaAtStart score@@ -495,14 +494,15 @@ nbs = if view _Wrapped' bs then MusicXml.beginSlide else id instance HasBackendNote MusicXml a => HasBackendNote MusicXml (TieT a) where- exportNote b = uncurry notate . fmap (exportNote b) . getTieT . sequenceA- where- notate (Any ta, Any tb)- | ta && tb = MusicXml.beginTie . MusicXml.endTie -- TODO flip order?- | tb = MusicXml.beginTie- | ta = MusicXml.endTie- | otherwise = id+ exportNote b = uncurry notateTie . getTieT . fmap (exportNote b) . sequenceA+ exportChord b = uncurry notateTie . getTieT . fmap (exportChord b) . sequenceA . fmap sequenceA +notateTie (Any ta, Any tb)+ | ta && tb = MusicXml.beginTie . MusicXml.endTie -- TODO flip order?+ | tb = MusicXml.beginTie+ | ta = MusicXml.endTie+ | otherwise = id+ -- | -- Constraint for types that has a MusicXML representation. --@@ -533,9 +533,8 @@ writeMusicXml path = writeFile path . toMusicXmlString -- |--- Typeset a score using MusicXML and open it.------ (This is simple wrapper around 'writeMusicXml' that may not work well on all platforms.)+-- Typeset a score using MusicXML and open it. (This is simple wrapper around+-- 'writeMusicXml' that may not work well on all platforms.) -- openMusicXml :: HasMusicXml a => a -> IO () openMusicXml sc = do@@ -559,46 +558,4 @@ preserveMeta f x = let m = view meta x in set meta m (f x) -- End internal ---- -- main = putStrLn $ show $ view notes $ simultaneous--- main = do--- openLilypond music--- openMusicXml music--- music =--- -- over pitches' (+ 2) $--- -- text "Hello" $--- compress 1 $ sj </> sj^*2 </> sj^*4--- where--- sj = timesPadding 2 1 $ harmonic 1 (scat [--- color Color.blue $ level _f $ c <> d,--- cs,--- level _f ds,--- level ff fs,--- level _f a_,--- text "pizz" $ level pp gs_,--- tremolo 2 d,--- tremolo 3 e--- ::Score MyNote])^*(1+3/5) --- --- timesPadding n d x = mcatMaybes $ times n (fmap Just x |> rest^*d)--- --- type MyNote = --- (PartT Int --- (TieT --- (ColorT --- (TextT --- (TremoloT --- (HarmonicT --- (SlideT --- (ArticulationT () --- (DynamicT --- (Sum (Double)) --- [Behavior Double])))))))))--- --- --- open :: Score MyNote -> IO ()--- open = do--- -- showLilypond--- openLilypond---
src/Music/Score/Export/NoteList.hs view
@@ -39,7 +39,6 @@ import Music.Dynamics.Literal import Music.Pitch.Literal import qualified Codec.Midi as Midi-import Control.Arrow ((***)) import Control.Comonad (Comonad (..), extract) import Control.Applicative import Data.Colour.Names as Color
src/Music/Score/Export/SuperCollider.hs view
@@ -47,7 +47,6 @@ import Music.Dynamics.Literal import Music.Pitch.Literal import qualified Codec.Midi as Midi-import Control.Arrow ((***)) import Control.Comonad (Comonad (..), extract) import Control.Applicative import Data.Colour.Names as Color
src/Music/Score/Instances.hs view
@@ -34,6 +34,7 @@ import Control.Monad import Data.AffineSpace import Data.Default+import Data.Average import Data.Foldable import Data.Functor.Adjunction (unzipR) import Data.Functor.Couple@@ -338,4 +339,26 @@ transform s = fmap (transform s) instance (Transformable a, Transformable b, Transformable c) => Transformable (a,b,c) where transform s (a,b,c) = (transform s a,transform s b,transform s c)++-- TODO place for this?+-- For use with single-note scores etc+instance Tiable a => Tiable (Score a) where+ beginTie = fmap beginTie+ endTie = fmap endTie++instance Transformable a => Transformable (Ctxt a) where+ transform s = fmap (transform s)++instance Transformable a => Transformable (Average a) where+ transform s = fmap (transform s)++instance IsPitch a => IsPitch (Average a) where+ fromPitch = pure . fromPitch++instance IsInterval a => IsInterval (Average a) where+ fromInterval = pure . fromInterval++instance IsDynamics a => IsDynamics (Average a) where+ fromDynamics = pure . fromDynamics+
src/Music/Score/Internal/Export.hs view
@@ -21,7 +21,6 @@ voiceToBars', -- separateBars, spellPitch,- toRelative, MVoice, toMVoice, unvoice,@@ -92,12 +91,6 @@ voiceToBars' barDurs = fmap (map (^. from stretched) . (^. stretcheds)) . splitTiesVoiceAt barDurs -- TODO remove prime from name --- | Convert absolute to relative durations.-toRelative :: [(Time, Duration, b)] -> [(Time, Duration, b)]-toRelative = snd . mapAccumL g 0- where- g now (t,d,x) = (t, (0 .+^ (t .-. now),d,x))- -- | Basic spelling for integral types. spellPitch :: Integral a => a -> (a, a, a) spellPitch p = (@@ -152,3 +145,5 @@ assumed = flip const -}++-- JUNK
src/Music/Score/Meta.hs view
@@ -37,22 +37,19 @@ -- * Meta-events addMetaNote,- addGlobalMetaNote, fromMetaReactive, metaAt, metaAtStart, withMeta,- withGlobalMeta, withMetaAtStart,- withGlobalMetaAtStart, ) where import Control.Applicative-import Control.Arrow import Control.Lens hiding (parts, perform) import Control.Monad import Control.Monad.Plus+import Data.Bifunctor import Data.AffineSpace import Data.AffineSpace.Point import Data.Foldable (Foldable (..))@@ -118,14 +115,11 @@ -addMetaNote :: forall a b . (IsAttribute a, HasMeta b{-, HasPart' b-}) => Note a -> b -> b-addMetaNote x y = (applyMeta $ toMeta (Just y) $ noteToReactive x) y--addGlobalMetaNote :: forall a b . (IsAttribute a, HasMeta b) => Note a -> b -> b-addGlobalMetaNote x = applyMeta $ toMeta (Nothing::Maybe Int) $ noteToReactive x+addMetaNote :: forall a b . (AttributeClass a, HasMeta b) => Note a -> b -> b+addMetaNote x = applyMeta $ wrapTMeta $ noteToReactive x -fromMetaReactive :: forall a b . ({-HasPart' a, -}IsAttribute b) => Maybe a -> Meta -> Reactive b-fromMetaReactive part = fromMaybe mempty . fromMeta part+fromMetaReactive :: forall a b . AttributeClass b => Meta -> Reactive b+fromMetaReactive = fromMaybe mempty . unwrapMeta @@ -139,33 +133,31 @@ mapBefore :: Time -> (Score a -> Score a) -> Score a -> Score a mapDuring :: Span -> (Score a -> Score a) -> Score a -> Score a mapAfter :: Time -> (Score a -> Score a) -> Score a -> Score a-mapBefore t f x = let (y,n) = (fmap snd *** fmap snd) $ mpartition (\(t2,x) -> t2 < t) (withTime x) in (f y <> n)-mapDuring s f x = let (y,n) = (fmap snd *** fmap snd) $ mpartition (\(t,x) -> t `inSpan` s) (withTime x) in (f y <> n)-mapAfter t f x = let (y,n) = (fmap snd *** fmap snd) $ mpartition (\(t2,x) -> t2 >= t) (withTime x) in (f y <> n)+mapBefore t f x = let (y,n) = (fmap snd `bimap` fmap snd) $ mpartition (\(t2,x) -> t2 < t) (withTime x) in (f y <> n)+mapDuring s f x = let (y,n) = (fmap snd `bimap` fmap snd) $ mpartition (\(t,x) -> t `inSpan` s) (withTime x) in (f y <> n)+mapAfter t f x = let (y,n) = (fmap snd `bimap` fmap snd) $ mpartition (\(t2,x) -> t2 >= t) (withTime x) in (f y <> n) -- Transform the score with the current value of some meta-information -- Each "update chunk" of the meta-info is processed separately -runScoreMeta :: forall a b . ({-HasPart' a, -}IsAttribute b) => Score a -> Reactive b-runScoreMeta = fromMetaReactive (Nothing :: Maybe a) . (view meta) -metaAt :: ({-HasPart' a, -}IsAttribute b) => Time -> Score a -> b+-- INTERNAL+runScoreMeta :: forall a b . AttributeClass b => Score a -> Reactive b+runScoreMeta = fromMetaReactive . (view meta)++-- EXT+metaAt :: AttributeClass b => Time -> Score a -> b metaAt x = (`atTime` x) . runScoreMeta -metaAtStart :: ({-HasPart' a, -}IsAttribute b) => Score a -> b+-- EXT+metaAtStart :: AttributeClass b => Score a -> b metaAtStart x = _onset x `metaAt` x -withGlobalMeta :: IsAttribute a => (a -> Score b -> Score b) -> Score b -> Score b-withGlobalMeta = withMeta' (Nothing :: Maybe Int)--withMeta :: (IsAttribute a{-, HasPart' b-}) => (a -> Score b -> Score b) -> Score b -> Score b-withMeta f x = withMeta' (Just x) f x--withMeta' :: ({-HasPart' c, -}IsAttribute a) => Maybe c -> (a -> Score b -> Score b) -> Score b -> Score b-withMeta' part f x = let+withMeta :: AttributeClass a => (a -> Score b -> Score b) -> Score b -> Score b+withMeta f x = let m = (view meta) x- r = fromMetaReactive part m+ r = fromMetaReactive m in case splitReactive r of Left a -> f a x Right ((a, t), bs, (u, c)) ->@@ -175,20 +167,14 @@ $ mapAfter u (f c) $ x -withGlobalMetaAtStart :: IsAttribute a => (a -> Score b -> Score b) -> Score b -> Score b-withGlobalMetaAtStart = withMetaAtStart' (Nothing :: Maybe Int)--withMetaAtStart :: (IsAttribute a{-, HasPart' b-}) => (a -> Score b -> Score b) -> Score b -> Score b-withMetaAtStart f x = withMetaAtStart' (Just x) f x--withMetaAtStart' :: (IsAttribute b{-, HasPart' p-}) =>- Maybe p -> (b -> Score a -> Score a) -> Score a -> Score a-withMetaAtStart' partId f x = let- m = (view meta) x- in f (fromMetaReactive partId m `atTime` _onset x) x+withMetaAtStart :: AttributeClass a => (a -> Score b -> Score b) -> Score b -> Score b+withMetaAtStart f x = let+ m = view meta x+ in f (fromMetaReactive m `atTime` _onset x) x + -- JUNK -- TODO move noteToReactive :: Monoid a => Note a -> Reactive a noteToReactive n = (pure <$> n) `activate` pure mempty
src/Music/Score/Meta/Annotations.hs view
@@ -35,7 +35,6 @@ withAnnotations, ) where -import Control.Arrow import Control.Monad.Plus import qualified Data.List import Data.Semigroup@@ -66,7 +65,7 @@ -- | Annotate a part of the score. annotateSpan :: Span -> String -> Score a -> Score a-annotateSpan span str x = addGlobalMetaNote (transform span $ return $ Annotation [str]) x+annotateSpan span str x = addMetaNote (transform span $ return $ Annotation [str]) x -- | Show all annotations in the score. showAnnotations :: (HasPart' a, Ord (Part a), HasText a) => Score a -> Score a@@ -77,6 +76,6 @@ showAnnotations' prefix = withAnnotations (flip $ \s -> foldr (text . (prefix ++ )) s) -- | Handle the annotations in a score.-withAnnotations :: (HasParts' a, HasText a) => ([String] -> Score a -> Score a) -> Score a -> Score a-withAnnotations f = withGlobalMeta (f . getAnnotation)+withAnnotations :: HasText a => ([String] -> Score a -> Score a) -> Score a -> Score a+withAnnotations f = withMeta (f . getAnnotation)
src/Music/Score/Meta/Attribution.hs view
@@ -49,7 +49,6 @@ withAttribution', ) where -import Control.Arrow import Control.Lens (view) import Control.Monad.Plus import Data.Foldable (Foldable)@@ -118,35 +117,35 @@ -- | Set the given attribution in the given score.-attribute :: (HasMeta a, {-HasPart' a, -}HasPosition a) => Attribution -> a -> a+attribute :: (HasMeta a, HasPosition a) => Attribution -> a -> a attribute a x = attributeDuring (_getEra x) a x -- | Set the given attribution in the given part of a score.-attributeDuring :: (HasMeta a{-, HasPart' a-}) => Span -> Attribution -> a -> a-attributeDuring s a = addGlobalMetaNote (view note (s, a))+attributeDuring :: (HasMeta a) => Span -> Attribution -> a -> a+attributeDuring s a = addMetaNote (view note (s, a)) -- | Set composer of the given score.-composer :: (HasMeta a, {-HasPart' a, -}HasPosition a) => String -> a -> a+composer :: (HasMeta a, HasPosition a) => String -> a -> a composer t x = composerDuring (_getEra x) t x -- | Set composer of the given part of a score.-composerDuring :: (HasMeta a{-, HasPart' a-}) => Span -> String -> a -> a+composerDuring :: HasMeta a => Span -> String -> a -> a composerDuring s x = attributeDuring s ("composer" `attribution` x) -- | Set lyricist of the given score.-lyricist :: (HasMeta a, {-HasPart' a, -}HasPosition a) => String -> a -> a+lyricist :: (HasMeta a, HasPosition a) => String -> a -> a lyricist t x = lyricistDuring (_getEra x) t x -- | Set lyricist of the given part of a score.-lyricistDuring :: (HasMeta a{-, HasPart' a-}) => Span -> String -> a -> a+lyricistDuring :: HasMeta a => Span -> String -> a -> a lyricistDuring s x = attributeDuring s ("lyricist" `attribution` x) -- | Set arranger of the given score.-arranger :: (HasMeta a, {-HasPart' a, -}HasPosition a) => String -> a -> a+arranger :: (HasMeta a, HasPosition a) => String -> a -> a arranger t x = arrangerDuring (_getEra x) t x -- | Set arranger of the given part of a score.-arrangerDuring :: (HasMeta a{-, HasPart' a-}) => Span -> String -> a -> a+arrangerDuring :: HasMeta a => Span -> String -> a -> a arrangerDuring s x = attributeDuring s ("arranger" `attribution` x) -- | Extract attribution values of the given category from a score.@@ -155,5 +154,5 @@ -- | Extract all attribution values from a score. withAttribution' :: (Attribution -> Score a -> Score a) -> Score a -> Score a-withAttribution' = withGlobalMetaAtStart+withAttribution' = withMetaAtStart
src/Music/Score/Meta/Barline.hs view
@@ -44,7 +44,6 @@ ) where -import Control.Arrow import Control.Lens (view) import Control.Monad.Plus import Data.Default@@ -81,21 +80,21 @@ deriving (Eq, Ord, Show, Typeable) -- | Add a barline over the whole score.-barline :: (HasMeta a, {-HasPart' a, -}HasPosition a) => Barline -> a -> a+barline :: (HasMeta a, HasPosition a) => Barline -> a -> a barline c x = barlineDuring (_getEra x) c x -- | Add a barline over the whole score.-doubleBarline :: (HasMeta a, {-HasPart' a, -}HasPosition a) => Barline -> a -> a+doubleBarline :: (HasMeta a, HasPosition a) => Barline -> a -> a doubleBarline = undefined -- | Add a barline over the whole score.-finalBarline :: (HasMeta a, {-HasPart' a, -}HasPosition a) => Barline -> a -> a+finalBarline :: (HasMeta a, HasPosition a) => Barline -> a -> a finalBarline = undefined -- | Add a barline to the given score.-barlineDuring :: (HasMeta a{-, HasPart' a-}) => Span -> Barline -> a -> a+barlineDuring :: HasMeta a => Span -> Barline -> a -> a barlineDuring s c = addMetaNote $ view note (s, (Option $ Just $ Last c)) -- | Extract barlines in from the given score, using the given default barline. withBarline :: (Barline -> Score a -> Score a) -> Score a -> Score a-withBarline f = withGlobalMeta (maybe id f . fmap getLast . getOption)+withBarline f = withMeta (maybe id f . fmap getLast . getOption)
src/Music/Score/Meta/Clef.hs view
@@ -40,7 +40,6 @@ withClef, ) where -import Control.Arrow import Control.Lens (view) import Control.Monad.Plus import Data.Foldable (Foldable)@@ -70,14 +69,14 @@ deriving (Eq, Ord, Show, Typeable) -- | Set clef of the given score.-clef :: (HasMeta a, {-HasPart' a,-} HasPosition a) => Clef -> a -> a+clef :: (HasMeta a, HasPosition a) => Clef -> a -> a clef c x = clefDuring (_getEra x) c x -- | Set clef of the given part of a score.-clefDuring :: (HasMeta a{-, HasPart' a-}) => Span -> Clef -> a -> a+clefDuring :: HasMeta a => Span -> Clef -> a -> a clefDuring s c = addMetaNote $ view note (s, (Option $ Just $ Last c)) -- | Extract the clef in from the given score, using the given default clef.-withClef :: {-HasPart' a =>-} Clef -> (Clef -> Score a -> Score a) -> Score a -> Score a+withClef :: Clef -> (Clef -> Score a -> Score a) -> Score a -> Score a withClef def f = withMeta (f . fromMaybe def . fmap getLast . getOption)
src/Music/Score/Meta/Fermata.hs view
@@ -40,7 +40,6 @@ ) where -import Control.Arrow import Control.Lens (view) import Control.Monad.Plus import Data.Default@@ -77,13 +76,13 @@ deriving (Eq, Ord, Show, Typeable) -- | Add a fermata over the whole score.-fermata :: (HasMeta a, {-HasPart' a, -}HasPosition a) => Fermata -> a -> a+fermata :: (HasMeta a, HasPosition a) => Fermata -> a -> a fermata c x = fermataDuring (_getEra x) c x -- | Add a fermata to the given score.-fermataDuring :: (HasMeta a{-, HasPart' a-}) => Span -> Fermata -> a -> a+fermataDuring :: HasMeta a => Span -> Fermata -> a -> a fermataDuring s c = addMetaNote $ view note (s, (Option $ Just $ Last c)) -- | Extract fermatas in from the given score, using the given default fermata. withFermata :: (Fermata -> Score a -> Score a) -> Score a -> Score a-withFermata f = withGlobalMeta (maybe id f . fmap getLast . getOption)+withFermata f = withMeta (maybe id f . fmap getLast . getOption)
src/Music/Score/Meta/Key.hs view
@@ -43,7 +43,6 @@ withKeySignature, ) where -import Control.Arrow import Control.Lens (view) import Control.Monad.Plus import Data.Foldable (Foldable)@@ -119,14 +118,14 @@ isMinorKey = not . isMajorKey -- | Set the key signature of the given score.-keySignature :: (HasMeta a, {-HasPart' a, -}HasPosition a) => KeySignature -> a -> a+keySignature :: (HasMeta a, HasPosition a) => KeySignature -> a -> a keySignature c x = keySignatureDuring (_getEra x) c x -- | Set the key signature of the given part of a score.-keySignatureDuring :: (HasMeta a{-, HasPart' a-}) => Span -> KeySignature -> a -> a-keySignatureDuring s c = addGlobalMetaNote $ view note (s, (Option $ Just $ Last c))+keySignatureDuring :: HasMeta a => Span -> KeySignature -> a -> a+keySignatureDuring s c = addMetaNote $ view note (s, (Option $ Just $ Last c)) -- | Extract all key signatures from the given score, using the given default key signature. withKeySignature :: KeySignature -> (KeySignature -> Score a -> Score a) -> Score a -> Score a-withKeySignature def f = withGlobalMeta (f . fromMaybe def . fmap getLast . getOption)+withKeySignature def f = withMeta (f . fromMaybe def . fmap getLast . getOption)
src/Music/Score/Meta/RehearsalMark.hs view
@@ -41,7 +41,6 @@ ) where -import Control.Arrow import Control.Lens (view) import Control.Monad.Plus import Data.Default@@ -92,12 +91,12 @@ -- metronome :: Duration -> Bpm -> Tempo -- metronome noteVal bpm = Tempo Nothing (Just noteVal) $ 60 / (bpm * noteVal) -rehearsalMark :: (HasMeta a, {-HasPart' a, -}HasPosition a) => RehearsalMark -> a -> a+rehearsalMark :: (HasMeta a, HasPosition a) => RehearsalMark -> a -> a rehearsalMark c x = rehearsalMarkDuring (_getEra x) c x -rehearsalMarkDuring :: (HasMeta a{-, HasPart' a-}) => Span -> RehearsalMark -> a -> a-rehearsalMarkDuring s x = addGlobalMetaNote $ view note (s, x)+rehearsalMarkDuring :: HasMeta a => Span -> RehearsalMark -> a -> a+rehearsalMarkDuring s x = addMetaNote $ view note (s, x) withRehearsalMark :: (RehearsalMark -> Score a -> Score a) -> Score a -> Score a-withRehearsalMark = withGlobalMeta+withRehearsalMark = withMeta
src/Music/Score/Meta/Tempo.hs view
@@ -47,7 +47,6 @@ ) where -import Control.Arrow import Control.Lens import Control.Monad.Plus import Data.AffineSpace@@ -166,12 +165,12 @@ tempoToDuration (Tempo _ _ x) = x -- | Set the tempo of the given score.-tempo :: (HasMeta a, {-HasPart' a, -}HasPosition a) => Tempo -> a -> a+tempo :: (HasMeta a, HasPosition a) => Tempo -> a -> a tempo c x = tempoDuring (_getEra x) c x -- | Set the tempo of the given part of a score.-tempoDuring :: (HasMeta a{-, HasPart' a-}) => Span -> Tempo -> a -> a-tempoDuring s c = addGlobalMetaNote $ view note (s, c)+tempoDuring :: HasMeta a => Span -> Tempo -> a -> a+tempoDuring s c = addMetaNote $ view note (s, c) -- TODO move@@ -186,7 +185,7 @@ -- | Extract all tempi from the given score, using the given default tempo. -- withTempo :: (Tempo -> Score a -> Score a) -> Score a -> Score a--- withTempo f = withGlobalMeta (f . fromMaybe def . fmap getFirst . getOption)+-- withTempo f = withMeta (f . fromMaybe def . fmap getFirst . getOption) renderTempo :: Score a -> Score a renderTempo = error "renderTempo: Not implemented"@@ -320,3 +319,4 @@ frl [x] = error "frl: Just one value" frl xs = (head xs, (tail.init) xs, last xs) +-- JUNK
src/Music/Score/Meta/Time.hs view
@@ -53,9 +53,9 @@ standardTimeSignature, ) where -import Control.Arrow import Control.Lens (view) import Control.Monad.Plus+import Data.Bifunctor import Data.Foldable (Foldable) import qualified Data.Foldable as F import qualified Data.List as List@@ -163,25 +163,25 @@ getTimeSignature (TimeSignature x) = x -- | Set the time signature of the given score.-timeSignature :: (HasMeta a, {-HasPart' a,-} HasPosition a) => TimeSignature -> a -> a+timeSignature :: (HasMeta a, HasPosition a) => TimeSignature -> a -> a timeSignature c x = timeSignatureDuring (0 <-> _offset x) c x -- use (_onset x <-> _offset x) instead of (0 <-> _offset x) -- timeSignature' c x = timeSignatureDuring (era x) c x -- | Set the time signature of the given part of a score.-timeSignatureDuring :: (HasMeta a{-, HasPart' a-}) => Span -> TimeSignature -> a -> a-timeSignatureDuring s c = addGlobalMetaNote $ view note (s, optionFirst c)+timeSignatureDuring :: HasMeta a => Span -> TimeSignature -> a -> a+timeSignatureDuring s c = addMetaNote $ view note (s, optionFirst c) getTimeSignatures :: TimeSignature -> Score a -> Reactive TimeSignature-getTimeSignatures def = fmap (fromMaybe def . unOptionFirst) . fromMetaReactive (Nothing::Maybe Int) . (view meta)+getTimeSignatures def = fmap (fromMaybe def . unOptionFirst) . fromMetaReactive . (view meta) getTimeSignatureChanges :: TimeSignature -> Score a -> [(Time, TimeSignature)] getTimeSignatureChanges def = updates . getTimeSignatures def -- | Extract the time signature from the given score, using the given default time signature. withTimeSignature :: TimeSignature -> (TimeSignature -> Score a -> Score a) -> Score a -> Score a-withTimeSignature def f = withGlobalMeta (f . fromMaybe def . unOptionFirst)+withTimeSignature def f = withMeta (f . fromMaybe def . unOptionFirst) -- | Given a list of time signatures and the duration between them (TODO use voice), return a list of appropriate -- bar durations.@@ -243,3 +243,4 @@ unOptionFirst = fmap getFirst . getOption +-- JUNK
src/Music/Score/Meta/Title.hs view
@@ -49,7 +49,6 @@ withTitle, ) where -import Control.Arrow import Control.Lens (view) import Control.Monad.Plus import Data.Foldable (Foldable)@@ -120,30 +119,30 @@ getTitleAt (Title t) n = fmap getLast . getOption . t $ n -- | Set title of the given score.-title :: (HasMeta a, {-HasPart' a, -}HasPosition a) => Title -> a -> a+title :: (HasMeta a, HasPosition a) => Title -> a -> a title t x = titleDuring (_getEra x) t x -- | Set title of the given part of a score.-titleDuring :: (HasMeta a{-, HasPart' a-}) => Span -> Title -> a -> a-titleDuring s t = addGlobalMetaNote $ view note (s, t)+titleDuring :: HasMeta a => Span -> Title -> a -> a+titleDuring s t = addMetaNote $ view note (s, t) -- | Set subtitle of the given score.-subtitle :: (HasMeta a, {-HasPart' a, -}HasPosition a) => Title -> a -> a+subtitle :: (HasMeta a, HasPosition a) => Title -> a -> a subtitle t x = subtitleDuring (_getEra x) t x -- | Set subtitle of the given part of a score.-subtitleDuring :: (HasMeta a{-, HasPart' a-}) => Span -> Title -> a -> a-subtitleDuring s t = addGlobalMetaNote $ view note (s, denoteTitle t)+subtitleDuring :: HasMeta a => Span -> Title -> a -> a+subtitleDuring s t = addMetaNote $ view note (s, denoteTitle t) -- | Set subsubtitle of the given score.-subsubtitle :: (HasMeta a, {-HasPart' a, -}HasPosition a) => Title -> a -> a+subsubtitle :: (HasMeta a, HasPosition a) => Title -> a -> a subsubtitle t x = subsubtitleDuring (_getEra x) t x -- | Set subsubtitle of the given part of a score.-subsubtitleDuring :: (HasMeta a{-, HasPart' a-}) => Span -> Title -> a -> a-subsubtitleDuring s t = addGlobalMetaNote $ view note (s, denoteTitle (denoteTitle t))+subsubtitleDuring :: HasMeta a => Span -> Title -> a -> a+subsubtitleDuring s t = addMetaNote $ view note (s, denoteTitle (denoteTitle t)) -- | Extract the title in from the given score. withTitle :: (Title -> Score a -> Score a) -> Score a -> Score a-withTitle = withGlobalMetaAtStart+withTitle = withMetaAtStart
src/Music/Score/Phrases.hs view
@@ -76,7 +76,7 @@ -- A sequence of phrases or rests, represented as notes or rests. -- -- Each consecutive sequence of non-rest elements is considered to be a phrase.--- For an explicit representation of the phrase structure, see 'mvoicePVoice'.+-- For a more explicit representation of the phrase structure, see 'PVoice'. -- type MVoice a = Voice (Maybe a) @@ -85,22 +85,14 @@ -- type PVoice a = [Either Duration (Phrase a)] +-- |+-- A sequence of phrases or rests, represented as phrases with an explicit onset.+--+-- This is only isomorphic to 'MVoice' (and 'PVoice') up to onset equivalence.+--+type TVoice a = Track (Phrase a) -{--class HasPhrases a b | a -> b where- mvoices :: Traversal' a (MVoice b) -instance HasPhrases (MVoice a) a where- mvoices = id--instance HasPhrases (PVoice a) a where- -- Note: This is actually OK in 'phrases', as that just becomes (id . each . _Right)- mvoices = from unsafeMvoicePVoice--instance (HasPart' a, Transformable a, Ord (Part a)) => HasPhrases (Score a) a where- mvoices = extracted . each . singleMVoice--}- -- | -- Classes that provide a phrase traversal. --@@ -149,6 +141,7 @@ -- mvoicePVoice :: Lens (MVoice a) (MVoice b) (PVoice a) (PVoice b) mvoicePVoice = unsafeMvoicePVoice+-- TODO rename mVoicePVoice! -- TODO meta -- |@@ -158,6 +151,7 @@ -- unsafeMvoicePVoice :: Iso (MVoice a) (MVoice b) (PVoice a) (PVoice b) unsafeMvoicePVoice = iso mvoiceToPVoice pVoiceToMVoice+-- TODO rename unsafeMVoicePVoice! where mvoiceToPVoice :: MVoice a -> PVoice a mvoiceToPVoice =@@ -213,8 +207,8 @@ voiceToScore' = mcatMaybes . voiceToScore -instance (Transformable a, Transformable b) => Cons (Phrase a) (Phrase b) a b where- _Cons = undefined+-- 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) @@ -240,4 +234,4 @@ | p x = Right (x : List.takeWhile p xs) : groupDiff' p (List.dropWhile p xs) -+-- JUNK
src/Music/Score/Pitch.hs view
@@ -68,6 +68,11 @@ fifthsDown, fifthsAbove, fifthsBelow,+ -- ** Utility+ _15va,+ _8va,+ _8vb,+ _15vb, -- * Inspecting pitch highestPitch,@@ -405,7 +410,8 @@ type Transposable a = (HasPitches a a, VectorSpace (Interval a), AffineSpace (Pitch a),- IsInterval (Interval a), IsPitch (Pitch a))+ IsInterval (Interval a), IsPitch (Pitch a),+ Num (Scalar (Interval a))) -- | -- Transpose up.@@ -489,6 +495,21 @@ fifthsBelow :: (Semigroup a, Transposable a) => Scalar (Interval a) -> a -> a fifthsBelow n = below (_P8^*n) +-- | Shorthand for @'octavesUp' 2@.+_15va :: Transposable a => a -> a+_15va = octavesUp 2++-- | Shorthand for @'octavesUp' 1@.+_8va :: Transposable a => a -> a+_8va = octavesUp 1++-- | Shorthand for @'octavesDown' 1@.+_8vb :: Transposable a => a -> a+_8vb = octavesDown 1++-- | Shorthand for @'octavesDown' 2@.+_15vb :: Transposable a => a -> a+_15vb = octavesDown 2
src/Music/Score/Slide.hs view
@@ -29,20 +29,18 @@ -- ------------------------------------------------------------------------------------- - module Music.Score.Slide (- -- * Slides and glissando HasSlide(..), SlideT(..), slide, glissando,- ) where 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@@ -61,39 +59,50 @@ class HasSlide a where- setBeginGliss :: Bool -> a -> a- setBeginSlide :: Bool -> a -> a- setEndGliss :: Bool -> a -> a- setEndSlide :: Bool -> a -> a+ setBeginGliss :: Bool -> a -> a+ setBeginSlide :: Bool -> a -> a+ setEndGliss :: Bool -> a -> a+ setEndSlide :: Bool -> a -> a instance HasSlide a => HasSlide (b, a) where- setBeginGliss n = fmap (setBeginGliss n)- setBeginSlide n = fmap (setBeginSlide n)- setEndGliss n = fmap (setEndGliss n)- setEndSlide n = fmap (setEndSlide n)+ setBeginGliss n = fmap (setBeginGliss n)+ setBeginSlide n = fmap (setBeginSlide n)+ setEndGliss n = fmap (setEndGliss n)+ setEndSlide n = fmap (setEndSlide n) instance HasSlide a => HasSlide (Couple b a) where- setBeginGliss n = fmap (setBeginGliss n)- setBeginSlide n = fmap (setBeginSlide n)- setEndGliss n = fmap (setEndGliss n)- setEndSlide n = fmap (setEndSlide n)+ setBeginGliss n = fmap (setBeginGliss n)+ setBeginSlide n = fmap (setBeginSlide n)+ setEndGliss n = fmap (setEndGliss n)+ setEndSlide n = fmap (setEndSlide n) instance HasSlide a => HasSlide [a] where- setBeginGliss n = fmap (setBeginGliss n)- setBeginSlide n = fmap (setBeginSlide n)- setEndGliss n = fmap (setEndGliss n)- setEndSlide n = fmap (setEndSlide n)+ setBeginGliss n = fmap (setBeginGliss n)+ setBeginSlide n = fmap (setBeginSlide n)+ setEndGliss n = fmap (setEndGliss n)+ setEndSlide n = fmap (setEndSlide n) instance HasSlide a => HasSlide (Score a) where- setBeginGliss n = fmap (setBeginGliss n)- setBeginSlide n = fmap (setBeginSlide n)- setEndGliss n = fmap (setEndGliss n)- setEndSlide n = fmap (setEndSlide n)+ setBeginGliss n = fmap (setBeginGliss n)+ setBeginSlide n = fmap (setBeginSlide n)+ setEndGliss n = fmap (setEndGliss n)+ setEndSlide n = fmap (setEndSlide n) +instance HasSlide a => HasSlide (Voice a) where+ setBeginGliss n = fmap (setBeginGliss n)+ setBeginSlide n = fmap (setBeginSlide n)+ setEndGliss n = fmap (setEndGliss n)+ setEndSlide n = fmap (setEndSlide n) +instance HasSlide a => HasSlide (Stretched a) where+ setBeginGliss n = fmap (setBeginGliss n)+ setBeginSlide n = fmap (setBeginSlide n)+ setEndGliss n = fmap (setEndGliss n)+ setEndSlide n = fmap (setEndSlide n)+ -- (eg,es,a,bg,bs) newtype SlideT a = SlideT { getSlideT :: Couple ((Any, Any), (Any, Any)) a }- deriving (Eq, Show, Ord, Functor, Foldable, Typeable, Applicative, Monad, Comonad)+ deriving (Eq, Show, Ord, Functor, Foldable, Typeable, Applicative, Monad, Comonad) -- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (SlideT a) where@@ -109,10 +118,10 @@ _es = (_Wrapped'._Wrapped') . _1 . _1 . _2 instance HasSlide (SlideT a) where- setBeginGliss x = _bg .~ Any x- setBeginSlide x = _bs .~ Any x- setEndGliss x = _eg .~ Any x- setEndSlide x = _es .~ Any x+ setBeginGliss x = _bg .~ Any x+ setBeginSlide x = _bs .~ Any x+ setEndGliss x = _eg .~ Any x+ setEndSlide x = _es .~ Any x -- Lifted instances deriving instance Num a => Num (SlideT a)@@ -127,29 +136,14 @@ -- Add a slide between the first and the last note. -- slide :: (HasPhrases' s a, HasSlide a) => s -> s-slide = mapPhraseWise3 (setBeginSlide True) id (setEndSlide True)+slide = mapPhraseWise3 (setBeginSlide True) (setBeginSlide True . setEndSlide True) (setEndSlide True) where- mapPhraseWise3 f g h = over phrases' (over headV f . over middleV g . over lastV h)+ mapPhraseWise3 f g h = over phrases' (over _head f . over _middle g . over _last h) -- | -- Add a glissando between the first and the last note. -- glissando :: (HasPhrases' s a, HasSlide a) => s -> s-glissando = mapPhraseWise3 (setBeginGliss True) id (setEndGliss True)+glissando = mapPhraseWise3 (setBeginGliss True) (setBeginGliss True . setEndGliss True) (setEndGliss True) where- mapPhraseWise3 f g h = over phrases' (over headV f . over middleV g . over lastV h)---headV :: Traversal' (Voice a) a-headV = (eventsV._head._2)--middleV :: Traversal' (Voice a) a-middleV = (eventsV._middle.traverse._2)--lastV :: Traversal' (Voice a) a-lastV = (eventsV._last._2)---- Traverse writing to all elements *except* first and last-_middle :: (Snoc s s a a, Cons s s b b) => Traversal' s s-_middle = _tail._init-+ mapPhraseWise3 f g h = over phrases' (over _head f . over _middle g . over _last h)
src/Music/Score/Text.hs view
@@ -75,10 +75,15 @@ instance HasText a => HasText [a] where addText s = fmap (addText s) -instance HasText a => HasText (Score a) where+instance HasText a => HasText (Stretched a) where addText s = fmap (addText s) +instance HasText a => HasText (Voice a) where+ addText s = fmap (addText s) +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@@ -87,7 +92,7 @@ instance Rewrapped (TextT a) (TextT b) instance HasText (TextT a) where- addText s (TextT (Couple (t,x))) = TextT (Couple (t ++ [s],x))+ addText s (TextT (Couple (t,x))) = TextT (Couple (t ++ [s],x)) -- Lifted instances deriving instance Num a => Num (TextT a)@@ -102,19 +107,6 @@ -- Attach the given text to the first note in the score. -- text :: (HasPhrases' s a, HasText a) => String -> s -> s-text s = over (phrases'.headV) (addText s)---headV :: Traversal' (Voice a) a-headV = (eventsV._head._2)--middleV :: Traversal' (Voice a) a-middleV = (eventsV._middle.traverse._2)--lastV :: Traversal' (Voice a) a-lastV = (eventsV._last._2)+text s = over (phrases'._head) (addText s) --- Traverse writing to all elements *except* first and last-_middle :: (Snoc s s a a, Cons s s b b) => Traversal' s s-_middle = _tail._init
src/Music/Score/Ties.hs view
@@ -33,13 +33,13 @@ TieT(..), -- * Splitting tied notes in scores- splitTiesVoice,+ -- splitTiesVoice, splitTiesVoiceAt, ) where import Control.Applicative-import Control.Arrow+import Data.Bifunctor import Control.Comonad import Control.Lens hiding (transform) import Control.Monad@@ -91,6 +91,8 @@ toTied :: a -> (a, a) toTied a = (beginTie a, endTie a) ++ newtype TieT a = TieT { getTieT :: ((Any, Any), a) } deriving (Eq, Ord, Show, Functor, Foldable, Typeable, Applicative, Monad, Comonad) @@ -193,6 +195,7 @@ rem = liftA2 rem toInteger = toInteger . extract +{- -- | -- Split all notes that cross a barlines into a pair of tied notes. --@@ -206,6 +209,7 @@ (_, barTime) = properFraction t remBarTime = 1 - barTime occs = splitDurThen remBarTime 1 (d,x)+-} -- | -- Split all voice into bars, using the given bar durations. Music that does not@@ -254,7 +258,7 @@ splitDurFor :: Tiable a => Duration -> [(Duration, a)] -> ([(Duration, a)], [(Duration, a)]) splitDurFor remDur [] = ([], []) splitDurFor remDur (x : xs) = case splitDur remDur x of- (x@(d,_), Nothing) ->+ (x@(d,_), Nothing) -> if d < remDur then first (x:) $ splitDurFor (remDur - d) xs else -- d == remDur
src/Music/Time.hs view
@@ -34,10 +34,16 @@ module Music.Time.Stretched, module Music.Time.Delayed, module Music.Time.Note,+ module Music.Time.Future,+ 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, module Music.Time.Score,+ -- ** Continous time module Music.Time.Segment, module Music.Time.Behavior,@@ -60,6 +66,10 @@ import Music.Time.Chord import Music.Time.Delayed import Music.Time.Note+import Music.Time.Future+import Music.Time.Past+import Music.Time.Nominal+import Music.Time.Graces import Music.Time.Reactive import Music.Time.Score import Music.Time.Segment
src/Music/Time/Behavior.hs view
@@ -69,16 +69,15 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.VectorSpace-import Prelude hiding (trimAfter)+import Prelude import Control.Applicative-import Control.Arrow (first, second, (&&&), (***)) import Control.Lens hiding (Indexable, Level, above, below, index, inside, parts, reversed, transform, (<|), (|>)) import Data.Distributive-import Data.Functor.Rep+import Data.Functor.Rep as R import Data.Functor.Rep.Lens import Data.Typeable import Music.Time.Bound@@ -106,14 +105,15 @@ -- -- Use 'focusing' to view a particular 'Segment'. ----- The semantics are given by+newtype Behavior a = Behavior { getBehavior :: Time -> a }+ deriving (Functor, Applicative, Monad, Typeable)++-- $semantics Behavior -- -- @ -- type Behavior a = 'Time' -> a -- @ ---newtype Behavior a = Behavior { getBehavior :: Time -> a }- deriving (Functor, Applicative, Monad, Typeable) -- -- $musicTimeBehaviorExamples@@ -143,7 +143,8 @@ instance Show (Behavior a) where show _ = "<<Behavior>>" -deriving instance Distributive Behavior+instance Distributive Behavior where+ distribute = Behavior . distribute . fmap getBehavior instance Transformable (Behavior a) where transform s (Behavior a) = Behavior (a `whilst` s)@@ -184,12 +185,12 @@ fromDynamics = pure . fromDynamics instance Alterable a => Alterable (Behavior a) where- sharpen = fmap sharpen- flatten = fmap flatten+ sharpen = fmap sharpen+ flatten = fmap flatten instance Augmentable a => Augmentable (Behavior a) where- augment = fmap augment- diminish = fmap diminish+ augment = fmap augment+ diminish = fmap diminish instance Eq a => Eq (Behavior a) where (==) = error "No fun"@@ -224,7 +225,7 @@ -- @ -- behavior :: Iso (Time -> a) (Time -> b) (Behavior a) (Behavior b)-behavior = tabulated+behavior = R.tabulated -- | -- View a time function as a behavior.@@ -249,7 +250,7 @@ -- A behavior that -- line' :: Behavior Time-line' = id ^. tabulated+line' = id ^. R.tabulated -- | -- A behavior that gives the current time, i.e. the identity function@@ -258,7 +259,7 @@ -- for convenience. -- line :: Fractional a => Behavior a-line = realToFrac ^. tabulated+line = realToFrac ^. R.tabulated -- -- > f t = t --@@ -377,3 +378,4 @@ floor' :: RealFrac a => a -> a floor' = fromIntegral . floor +-- JUNK
src/Music/Time/Bound.hs view
@@ -43,6 +43,7 @@ import Data.AffineSpace import Data.AffineSpace.Point+import Data.Bifunctor import Data.Map (Map) import qualified Data.Map as Map import Data.Ratio@@ -55,7 +56,6 @@ import Music.Time.Split import Control.Applicative-import Control.Arrow (first, second, (&&&), (***)) import Control.Lens hiding (Indexable, Level, above, below, index, inside, parts, reversed, transform, (<|), (|>))@@ -74,14 +74,15 @@ -- outside the bounds. However, we can still access values of a 'Bound' 'Behavior' in a -- safe manner using 'trim' or 'splice'. ----- The semantics are given by+newtype Bound a = Bound { getBound :: (Span, a) }+ deriving (Functor, Semigroup, Typeable, Eq, Show)++-- $semantics Bound -- -- @ -- type Bound a = (Time, Time, a) -- @ ---newtype Bound a = Bound { getBound :: (Span, a) }- deriving (Functor, Semigroup, Typeable, Eq, Show) -- -- These are both unsafe, as they allow us to define 'unBound'@@ -111,7 +112,7 @@ instance Reversible a => Reversible (Bound a) where -- rev = over (_Wrapped . each) rev- rev = over _Wrapped $ (rev *** rev)+ rev = over _Wrapped $ (bimap rev rev) instance (HasPosition a, Splittable a) => Splittable (Bound a) where -- TODO@@ -121,7 +122,7 @@ -- the bounds. -- instance Transformable a => Transformable (Bound a) where- transform t = over _Wrapped (transform t *** transform t)+ transform t = over _Wrapped (transform t `bimap` transform t) instance (HasPosition a, HasDuration a) => HasDuration (Bound a) where _duration x = _offset x .-. _onset x
src/Music/Time/Chord.hs view
@@ -34,10 +34,24 @@ -- * Chord type Chord,+ -- * Construction chord, unsafeChord, + -- invertC,+ -- inversions,+ -- chordToScore,+ -- arpUp3,+ -- arpDown3,+ -- arpUpDown3,+ -- arpDownUp3,+ -- alberti3,+ -- triad,+ -- mtriad,+ -- sixthChord,+ -- sixthFourthChord,+ -- fromBass, ) where @@ -56,7 +70,6 @@ import Music.Time.Split import Control.Applicative-import Control.Arrow (first, second, (&&&), (***)) import Control.Lens hiding (Indexable, Level, above, below, index, inside, parts, reversed, transform, (<|), (|>))@@ -134,3 +147,62 @@ deriving instance IsInterval a => IsInterval (Chord a) deriving instance IsDynamics a => IsDynamics (Chord a) ++{-+-- |+-- Invert a chord, i.e. transpose its lowest pitch up one octave.+--+-- To access higher-numbered inversions, iterate this function, i.e.+--+-- @+-- 'iterate' 'invertC' ('triad' c) !! 2+-- @+--+invertC :: Transposable a => Chord a -> Chord a+invertC = over chord (rotlAnd $ up _P8)++-- TODO include transp+inversions :: Transposable a => Chord a -> [Chord a]+inversions = iterate invertC++chordToScore :: Chord a -> Score a+chordToScore = pcat . map pure . toListOf traverse++-- TODO+unchord = toListOf traverse+++arpUp3 :: Chord a -> Score a+arpUp3 x = scat $ map ((^/16) . pure) [a,b,c]+ where+ [a,b,c] = unchord x++arpDown3 :: Chord a -> Score a+arpDown3 x = scat $ map ((^/16) . pure) [c,b,a]+ where+ [a,b,c] = unchord x++arpUpDown3 x = arpUp3 x |> arpDown3 x+arpDownUp3 x = arpDown3 x |> arpUp3 x++alberti3 :: Chord a -> Score a+alberti3 x = scat $ map ((^/16) . pure) [a,c,b,c]+ where+ [a,b,c] = unchord x++++triad :: Transposable a => a -> Chord a+triad x = mconcat $ map pure [x, up _M3 x, up _P5 x]++mtriad :: Transposable a => a -> Chord a+mtriad x = mconcat $ map pure [x, up m3 x, up _P5 x]++sixthChord = down m3 . invertC . mtriad+sixthFourthChord = down _P5 . invertC . invertC . triad+++-- TODO better parsing+fromBass :: Transposable a => String -> a -> Chord a+fromBass "" x = triad x+-}
src/Music/Time/Delayed.hs view
@@ -42,6 +42,7 @@ import Data.AffineSpace import Data.AffineSpace.Point+import Data.Bifunctor import Data.Map (Map) import qualified Data.Map as Map import Data.Ratio@@ -54,7 +55,6 @@ import Music.Time.Split import Control.Applicative-import Control.Arrow (first, second, (&&&), (***)) import Control.Comonad import Control.Comonad.Env import Control.Lens hiding (Indexable, Level, above, below,@@ -78,16 +78,17 @@ -- offset of a delayed value may be stretched with respect to the origin. However, in -- contrast to a note the /duration/ is not stretched. ----- The semantics are given by+newtype Delayed a = Delayed { _delayedValue :: (Time, a) }+ deriving (Eq, {-Ord, -}{-Show, -}+ Applicative, Monad, {-Comonad, -}+ Functor, Foldable, Traversable, Typeable)++-- $semantics Delayed -- -- @ -- type Delayed a = (Time, a) -- @ ---newtype Delayed a = Delayed { _delayedValue :: (Time, a) }- deriving (Eq, {-Ord, -}{-Show, -}- Applicative, Monad, {-Comonad, -}- Functor, Foldable, Traversable, Typeable) deriving instance Show a => Show (Delayed a)
src/Music/Time/Duration.hs view
@@ -41,6 +41,7 @@ import Data.NumInstances () import Data.Semigroup hiding () import Data.VectorSpace hiding (Sum (..))+import Data.Functor.Contravariant -- | -- Class of values that have a duration.@@ -89,7 +90,13 @@ instance HasDuration a => HasDuration (Max a) where _duration (Max x) = _duration x +-- For HasDuration [a] we assume parallel composition and+-- use the HasPosition instance, see Music.Time.Position. +instance (HasDuration a, HasDuration b) => HasDuration (Either a b) where+ _duration (Left x) = _duration x+ _duration (Right x) = _duration x+ -- | -- Access the duration. --@@ -103,4 +110,22 @@ stretchTo :: (Transformable a, HasDuration a) => Duration -> a -> a stretchTo d x = (d ^/ _duration x) `stretch` x {-# INLINE stretchTo #-}++{-++-- TODO more general pattern here+withDurationR :: (Functor f, HasDuration a) => f a -> f (Duration, a)+withDurationR = fmap $ \x -> (_duration x, x)++withDurationL :: (Contravariant f, HasDuration a) => f (Duration, a) -> f a+withDurationL = contramap $ \x -> (_duration x, x)++mapWithDuration :: HasDuration a => (Duration -> a -> b) -> a -> b+mapWithDuration = over dual withDurationL . uncurry+ where+ dual :: Iso (a -> b) (c -> d) (Op b a) (Op d c)+ dual = iso Op getOp++-}+
+ src/Music/Time/Future.hs view
@@ -0,0 +1,3 @@++module Music.Time.Future where+
+ src/Music/Time/Graces.hs view
@@ -0,0 +1,2 @@++module Music.Time.Graces where
src/Music/Time/Internal/Quantize.hs view
@@ -44,7 +44,6 @@ mapM, maximum, minimum, sum) import Control.Applicative-import Control.Arrow hiding (left) import Control.Lens (over, (^.), _Left) import Control.Monad (MonadPlus (..), ap, join) import Data.Either@@ -178,7 +177,7 @@ go (Dotted n r) = Dotted n ((rewriteR . rewrite1) r) go (Tuplet n r) = Tuplet n ((rewriteR . rewrite1) r) -rewrite1 = tupletDot . splitTuplet . singleGroup+rewrite1 = tupletDot . splitTupletIfLongEnough . singleGroup singleGroup :: Rhythm a -> Rhythm a@@ -190,30 +189,45 @@ tupletDot orig@(Tuplet ((unRatio.realToFrac) -> (2,3)) (Dotted 1 x)) = x tupletDot orig = orig --- | Splits a tuplet iff it contans a group which can be split into two halves of exactly the same size.--- TODO this should only happen if the tuplet lenght is longer than a beat+splitTupletIfLongEnough :: Rhythm a -> Rhythm a+splitTupletIfLongEnough r = if _duration r > (1/4) then splitTuplet r else r+-- TODO should compare against beat duration, not just (1/4)++-- | Splits a tuplet iff it contans a group which can be split into two halves whose+-- duration have the ratio 1/2, 1 or 1/2. splitTuplet :: Rhythm a -> Rhythm a splitTuplet orig@(Tuplet n (Group xs)) = case trySplit xs of Nothing -> orig Just (as, bs) -> Tuplet n (Group as) <> Tuplet n (Group bs) splitTuplet orig = orig -{---- TODO bad instance-instance HasDuration a => HasDuration [a] where- _duration = sum . fmap _duration--}- trySplit :: [Rhythm a] -> Maybe ([Rhythm a], [Rhythm a]) trySplit = firstJust . fmap g . splits where- g (part1, part2)- | (sum . fmap _duration) part1 == (sum . fmap _duration) part2 = Just (part1, part2)- | otherwise = Nothing- splits xs = List.inits xs `zip` List.tails xs- firstJust = listToMaybe . fmap fromJust . List.dropWhile isNothing+ g (part1, part2)+ | (sum . fmap _duration) part1 `rel` (sum . fmap _duration) part2 = Just (part1, part2)+ | otherwise = Nothing+ rel x y+ | x == y = True+ | x == y*2 = True+ | x*2 == y = True+ | otherwise = False +-- |+-- Given a list, return a list of all possible splits.+--+-- >>> splits [1,2,3]+-- [([],[1,2,3]),([1],[2,3]),([1,2],[3]),([1,2,3],[])]+--+splits :: [a] -> [([a],[a])]+splits xs = List.inits xs `zip` List.tails xs ++-- | Return the first @Just@ value, if any.+firstJust :: [Maybe a] -> Maybe a+firstJust = listToMaybe . fmap fromJust . List.dropWhile isNothing++ quantize :: Tiable a => [(Duration, a)] -> Either String (Rhythm a) quantize = quantize' (atEnd rhythm) @@ -224,7 +238,7 @@ konstNumDotsAllowed :: [Int]-konstNumDotsAllowed = [1..4]+konstNumDotsAllowed = [1..2] konstBounds :: [Duration] konstBounds = [ 1/2, 1/4, 1/8, 1/16 ]
src/Music/Time/Internal/Transform.hs view
@@ -88,7 +88,7 @@ -- @ -- transform mempty = id -- transform (s \<> t) = transform s . transform t--- transform (s \<> negateV t) = id+-- transform (s \<> negateV s) = id -- @ -- -- Law@@ -162,7 +162,27 @@ instance Transformable a => Transformable (Product a) where transform s = fmap (transform s) +instance Transformable a => Transformable (b, a) where+ transform t = fmap (transform t)++instance Transformable a => Transformable [a] where+ transform t = fmap (transform t)++instance Transformable a => Transformable (Seq a) where+ transform t = fmap (transform t)++instance (Ord k, Transformable a) => Transformable (Map k a) where+ transform t = Map.map (transform t)+ -- |+-- Functions transform by conjugation, i.e. we reverse-transform the argument+-- and transform the result.+--+instance (Transformable a, Transformable b) => Transformable (a -> b) where+ transform t = (`whilst` negateV t)+++-- | -- Apply the inverse of the given transformation. -- -- @@@ -182,37 +202,7 @@ transformed :: Transformable a => Span -> Iso' a a transformed s = iso (transform s) (itransform s) ------ TODO------ Should really transform the /second/ element, but this is incompatible with Note/SCcore------ 1) Change this to transform both components--- Then Note could be defined as type Note a = (Span, TransfInv a)------ 2) Redefine note as type Note a = (a, Span)----instance Transformable a => Transformable (b, a) where- transform t (s,a) = (s, transform t a) --- |--- Lists transform by transforming each element.----instance Transformable a => Transformable [a] where- transform t = map (transform t)--instance Transformable a => Transformable (Seq a) where- transform t = fmap (transform t)--instance (Ord k, Transformable a) => Transformable (Map k a) where- transform t = Map.map (transform t)---- |--- Functions transform by conjugation, i.e. we reverse-transform the argument--- and transform the result.----instance (Transformable a, Transformable b) => Transformable (a -> b) where- transform t = (`whilst` negateV t) -- | -- A transformation that moves a value forward in time.
src/Music/Time/Juxtapose.hs view
@@ -218,3 +218,4 @@ group n = times n . (fromIntegral n `compress`) -} +-- JUNK
src/Music/Time/Meta.hs view
@@ -8,13 +8,14 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} ------------------------------------------------------------------------------------- -- |--- Copyright : (c) Hans Hoglund 2012+-- Copyright : (c) Hans Hoglund 2012–2014 -- -- License : BSD-style --@@ -22,90 +23,109 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) ----- Provides meta-information.+-- Provides a way to annotate data-types with 'Transformable' meta-data. See+-- "Music.Score.Meta" for more specific applications. ----- Each score supports an unlimited number of 'Reactive' meta-values.+-- Inspired by Clojure and Diagram's styles, in turn based on xmonad's @Message@ type,+-- in turn based on ideas in: ----- This is more or less based on Diagrams styles, which is in turn based--- on XMonad.+-- 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>. -- ------------------------------------------------------------------------------------- module Music.Time.Meta ( -- * Attributes- IsAttribute,+ AttributeClass,+ TAttributeClass,+ Attribute, -- ** Creating attributes wrapAttr, wrapTAttr, unwrapAttr,- unwrapTAttr,+ -- unwrapTAttr, -- * Meta-data Meta, -- ** Creating meta-data- toMeta,- fromMeta,+ wrapMeta,+ wrapTMeta,+ unwrapMeta, -- ** The HasMeta class HasMeta(..),+ setMeta,+ setMetaAttr,+ setMetaTAttr, applyMeta,++ -- ** Add meta-data to arbitrary types+ AddMeta,+ annotated,+ unannotated,+ unsafeAnnotated ) where --- import Control.Applicative--- import Control.Arrow+import Control.Applicative+import Control.Comonad import Control.Lens hiding (transform) import Control.Monad.Plus+import Data.Functor.Rep -- TODO experimental import Data.Foldable (Foldable) import qualified Data.Foldable as F import qualified Data.List as List+import Data.Functor.Adjunction (unzipR) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe--- import Data.Monoid.WithSemigroup 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 Data.Functor.Couple --- import Music.Score.Part import Music.Time.Internal.Util import Music.Time.Reverse import Music.Time.Split import Music.Time.Transform -type IsAttribute a = (Typeable a, Monoid a, Semigroup a)+-- | Class of values that can be wrapped.+type AttributeClass a = (Typeable a, Monoid a, Semigroup a) +-- | Class of values that can be wrapped and transformed.+type TAttributeClass a = (Transformable a, AttributeClass a)+ -- | An existential wrapper type to hold attributes. data Attribute :: * where- Attribute :: IsAttribute a => a -> Attribute- TAttribute :: (Transformable a, IsAttribute a) => a -> Attribute+ Attribute :: AttributeClass a => a -> Attribute+ TAttribute :: TAttributeClass a => a -> Attribute -wrapAttr :: IsAttribute a => a -> Attribute+-- | Wrap up an attribute.+wrapAttr :: AttributeClass a => a -> Attribute wrapAttr = Attribute -unwrapAttr :: IsAttribute a => Attribute -> Maybe a-unwrapAttr (Attribute a) = cast a--wrapTAttr :: (Transformable a, IsAttribute a) => a -> Attribute+-- | Wrap up a transformable attribute.+wrapTAttr :: TAttributeClass a => a -> Attribute wrapTAttr = TAttribute -unwrapTAttr :: (Transformable a, IsAttribute a) => Attribute -> Maybe a-unwrapTAttr (TAttribute a) = cast a+-- | Convert something from an attribute.+-- Also works with transformable attributes+unwrapAttr :: AttributeClass a => Attribute -> Maybe a+unwrapAttr (Attribute a) = cast a+unwrapAttr (TAttribute a) = cast a instance Semigroup Attribute where (Attribute a1) <> a2 = case unwrapAttr a2 of- -- Nothing -> a2 Nothing -> error "Attribute.(<>) mismatch" Just a2' -> Attribute (a1 <> a2')- (TAttribute a1) <> a2 = case unwrapTAttr a2 of- -- Nothing -> a2+ (TAttribute a1) <> a2 = case unwrapAttr a2 of Nothing -> error "Attribute.(<>) mismatch" Just a2' -> TAttribute (a1 <> a2') @@ -134,39 +154,167 @@ mempty = Meta Map.empty mappend = (<>) -instance HasMeta Meta where- meta = ($)------- TODO--- Temporarily disabling part specific meta-events--- The API still works, but all parts are merged together-----toMeta :: forall a b . ({-HasPart' a, -}IsAttribute b, Transformable b) => Maybe a -> b -> Meta-toMeta partId a = Meta $ Map.singleton key $ wrapTAttr a+-- | Convert something to meta-data.+wrapTMeta :: forall a. TAttributeClass a => a -> Meta+wrapTMeta a = Meta $ Map.singleton key $ wrapTAttr a where- key = ty ++ pt- pt = ""- -- pt = show $ fmap getPart partId- ty = show $ typeOf (undefined :: b)+ key = show $ typeOf (undefined :: a) -fromMeta :: forall a b . ({-HasPart' a, -}IsAttribute b, Transformable b) => Maybe a -> Meta -> Maybe b-fromMeta partId (Meta s) = (unwrapTAttr =<<) $ Map.lookup key s+-- | Convert something from meta-data.+unwrapMeta :: forall a. AttributeClass a => Meta -> Maybe a+unwrapMeta (Meta s) = (unwrapAttr =<<) $ Map.lookup key s -- Note: unwrapAttr should never fail where- key = ty ++ pt- pt = ""- -- pt = show $ fmap getPart partId- ty = show . typeOf $ (undefined :: b)+ key = show . typeOf $ (undefined :: a) +-- | Convert something from meta-data.+-- Also works with transformable attributes+wrapMeta :: forall a. AttributeClass a => a -> Meta+wrapMeta a = Meta $ Map.singleton key $ wrapAttr a+ where+ key = show $ typeOf (undefined :: a) --- | Type class for things which have meta-information.++-- | Type class for things which have meta-data. class HasMeta a where- -- | Apply meta-information by combining it (on the left) with the- -- existing meta-information.+ -- | Access the meta-data. meta :: Lens' a Meta +instance Show Meta where+ show _ = "{ meta }"++instance HasMeta Meta where+ meta = ($)++instance HasMeta a => HasMeta (Maybe a) where+ meta = lens viewM $ flip setM+ where+ viewM Nothing = mempty+ viewM (Just x) = view meta x+ setM m = fmap (set meta m)++instance HasMeta a => HasMeta (b, a) where+ meta = _2 . meta++instance HasMeta a => HasMeta (Twain b a) where+ meta = _Wrapped . meta++-- TODO call withMeta a la Clojure?+setMeta :: HasMeta a => Meta -> a -> a+setMeta m = set meta m++-- | Apply meta-information by combining it (on the left) with the+-- existing meta-information. applyMeta :: HasMeta a => Meta -> a -> a-applyMeta m = (meta <>~ m)+applyMeta m = over meta (<> m)++-- | Update a meta attribute.+setMetaAttr :: (AttributeClass b, HasMeta a) => b -> a -> a+setMetaAttr a = applyMeta (wrapMeta a)++-- | Update a meta attribute.+setMetaTAttr :: (TAttributeClass b, HasMeta a) => b -> a -> a+setMetaTAttr a = applyMeta (wrapTMeta a)++-- |+-- Annotate an arbitrary type with meta-data, preserving instances of+-- all common type classes. In particular 'Functor' and 'Applicative' is lifted and+-- @'Compose' 'AddMeta'@ is semantically equivalent to 'Identity'. ++-- Meta-data is carried along with the annotated value. It defaults to 'mempty'+-- in 'pure'. When composing values using '<*>', 'liftA2' etc, meta-data is composed+-- using 'mappend'.+--+-- Similar to the approach taken in Clojure, meta-data does not contribute to ordering,+-- so both 'Eq' and 'Ord' ignore the meta-data.+--+-- You can access the meta-data using 'meta', and the annotated value using 'annotated'.+--+newtype AddMeta a = AddMeta { getAddMeta :: Twain Meta a }+ deriving (+ Show, Functor, Foldable, Typeable, Applicative, Monad, Comonad,+ Semigroup, Monoid, Num, Fractional, Floating, Enum, Bounded,+ Integral, Real, RealFrac,+ Eq, Ord+ )++instance Wrapped (AddMeta a) where+ type Unwrapped (AddMeta a) = Twain Meta a+ _Wrapped' = iso getAddMeta AddMeta++instance Rewrapped (AddMeta a) (AddMeta b)++instance HasMeta (AddMeta a) where+ -- twain, pair, element+ meta = _Wrapped . _Wrapped . _1+++-- instance FunctorWithIndex i AddMeta where+ -- imap f = over annotated $ imap f+-- +-- instance FoldableWithIndex Span Score where+-- ifoldMap f (Score (m,x)) = ifoldMap f x+-- +-- instance TraversableWithIndex Span Score where+-- itraverse f (Score (m,x)) = fmap (\x -> Score (m,x)) $ itraverse f x++instance Transformable a => Transformable (AddMeta a) where+ transform t = over meta (transform t) . over annotated (transform t)++instance Reversible a => Reversible (AddMeta a) where+ rev = over meta rev . over annotated rev++instance Splittable a => Splittable (AddMeta a) where+ split t = unzipR . fmap (split t)++instance HasPosition a => HasPosition (AddMeta a) where+ _onset = _onset . extract+ _offset = _offset . extract+ _position = _position . extract++instance HasDuration a => HasDuration (AddMeta a) where+ _duration = _duration . extract++-- |+-- Access the annotated value.+--+-- @+-- over annotated = fmap+-- @+--+annotated :: Lens (AddMeta a) (AddMeta b) a b+annotated = unsafeAnnotated++-- |+-- Access the annotated value.+--+-- @+-- view fromAnnotated = pure+-- @+--+unannotated :: Getter a (AddMeta a)+unannotated = from unsafeAnnotated++-- |+-- Access the annotated value. This is only an isomorphism up to meta-data+-- equivalence. In particular @under unsafeAnnotated@ leads to meta-data being+-- thrown away. See 'annotated' and 'unannotated' for safe (but less general)+-- definitions.+--+-- @+-- over annotated = fmap+-- @+-- +unsafeAnnotated :: Iso (AddMeta a) (AddMeta b) a b+unsafeAnnotated = _Wrapped . extracted+++-- Nice generalizations+-- TODO move++extracted :: (Applicative m, Comonad m) => Iso (m a) (m b) a b+extracted = iso extract pure++extractedRep :: (Representable m, w ~ Rep m, Monoid w) => Iso (m a) (m b) a b+extractedRep = iso extractRep pureRep
+ src/Music/Time/Nominal.hs view
@@ -0,0 +1,2 @@++module Music.Time.Nominal where
src/Music/Time/Note.hs view
@@ -53,7 +53,6 @@ import Music.Time.Split import Control.Applicative-import Control.Arrow (first, second, (&&&), (***)) import Control.Comonad import Control.Comonad.Env import Control.Lens hiding (Indexable, Level, above, below,@@ -80,14 +79,13 @@ -- ('view' 'value') . 'transform' s = 'transform' s . ('view' 'value') -- @ ----- The semantics are given by+newtype Note a = Note { _noteValue :: (Span, a) }+ deriving (Typeable)++-- $semantics ----- @ -- type Note a = (Span, a)--- @ ---newtype Note a = Note { _noteValue :: (Span, a) }- deriving (Typeable) deriving instance Eq a => Eq (Note a) deriving instance Functor Note@@ -115,7 +113,7 @@ instance Rewrapped (Note a) (Note b) instance Transformable (Note a) where- transform t = over _Wrapped $ first (transform t)+ transform t = over (_Wrapped . _1) $ transform t instance HasDuration (Note a) where _duration = _duration . ask . view _Wrapped
+ src/Music/Time/Past.hs view
@@ -0,0 +1,24 @@++module Music.Time.Past where++import Music.Time.Split+import Music.Time.Reverse+import Music.Time.Segment+import Music.Time.Behavior++-- |+-- Past represents a value occuring /up to/ some point in time.+--+-- It may be seen as a note whose era is a left-open time interval.+--+newtype Past a = Past { getPast :: (a, Time) }++-- | Query a past value.+past :: Past a -> Time -> Maybe a+past (Past (x, t)) t'+ | t' <= t = Just x+ | otherwise = Nothing++-- | Project a segment (backwards) up to the given point.+pastSeg :: Past (Segment a) -> Behavior (Maybe a)+pastSeg = undefined
src/Music/Time/Position.hs view
@@ -43,11 +43,14 @@ -- * Specific positions onset,+ midpoint, offset, preOnset,- postOnset, postOffset, + -- ** Deprecated+ postOnset,+ -- * Moving to absolute positions startAt, stopAt,@@ -160,11 +163,15 @@ {-# INLINE preOnset #-} -- |--- Post-onset of the given value, or the value between the decay and sustain phases.+-- Midpoint of the given value, or the value between the decay and sustain phases. --+midpoint :: (HasPosition a, Transformable a) => Lens' a Time+midpoint = position 0.5+{-# INLINE midpoint #-}+ postOnset :: (HasPosition a, Transformable a) => Lens' a Time postOnset = position 0.5-{-# INLINE postOnset #-}+{-# DEPRECATED postOnset "Use midpoint" #-} -- | -- Post-offset of the given value, or the value right after the release phase.
src/Music/Time/Reactive.hs view
@@ -76,7 +76,6 @@ import Control.Applicative-import Control.Arrow (first, second, (&&&), (***)) import Control.Lens hiding (Indexable, Level, above, below, index, inside, parts, reversed, transform, (<|), (|>))@@ -94,14 +93,14 @@ -- | -- Forms an applicative as per 'Behavior', but only switches at discrete points. ----- The semantics are given by+newtype Reactive a = Reactive { getReactive :: ([Time], Behavior a) }+ deriving (Functor, Semigroup, Monoid, Typeable)++-- $semantics ----- @ -- type Reactive a = (a, Time, Voice a)--- @ ---newtype Reactive a = Reactive { getReactive :: ([Time], Behavior a) }- deriving (Functor, Semigroup, Monoid, Typeable)+ -- -- TODO Define a more compact representation and reimplement Behavior as (Reactive Segment). --@@ -162,7 +161,7 @@ updates r = (\t -> (t, r `atTime` t)) <$> (List.sort . List.nub) (occs r) renderR :: Reactive a -> (a, [(Time, a)])-renderR = initial &&& updates+renderR x = (initial x, updates x) occs :: Reactive a -> [Time] occs = fst . (^. _Wrapped')@@ -294,4 +293,5 @@ newtype Search a = Search { getSearch :: forall r . (a -> Tree r) -> Tree r } -} +-- JUNK
src/Music/Time/Reverse.hs view
@@ -265,6 +265,7 @@ instance Reversible a => Reversible (WithRev a) where rev (WithRev (r,x)) = WithRev (x,r) +-- JUNK -}
src/Music/Time/Score.hs view
@@ -53,6 +53,10 @@ simult, simultaneous, + -- * Normalize+ normalizeScore,+ printEras,+ -- * Traversing mapWithSpan, filterWithSpan,@@ -84,7 +88,6 @@ import Music.Time.Voice import Control.Applicative-import Control.Arrow (first, second, (&&&), (***)) import Control.Comonad import Control.Lens hiding (Indexable, Level, above, below, index, inside, parts, reversed,@@ -134,16 +137,15 @@ -- To inspect or deconstruct a score, see 'notes', 'voices', and 'phrases', as -- well as 'singleNote', 'singleVoice', and 'singlePhrase' ----- The semantics are given by+newtype Score a = Score { getScore' :: (Meta, NScore a) }+ deriving (Functor, Semigroup, Monoid, Foldable, Traversable, Typeable{-, Show, Eq, Ord-})+ ----- @+-- $semantics Score+-- -- type Score a = [Note a]--- @ -- -newtype Score a = Score { getScore' :: (Meta, NScore a) }- deriving (Functor, Semigroup, Monoid, Foldable, Traversable, Typeable{-, Show, Eq, Ord-})- instance Wrapped (Score a) where type Unwrapped (Score a) = (Meta, NScore a) _Wrapped' = iso getScore' Score@@ -435,7 +437,22 @@ -- unsafeEvents :: Iso (Score a) (Score b) [(Time, Duration, a)] [(Time, Duration, b)] unsafeEvents = iso _getScore _score+ where+ _score :: [(Time, Duration, a)] -> Score a+ _score = mconcat . fmap (uncurry3 event)+ where+ event t d x = (delay (t .-. 0) . stretch d) (return x) + _getScore :: {-Transformable a => -}Score a -> [(Time, Duration, a)]+ _getScore =+ fmap (\(view delta -> (t,d),x) -> (t,d,x)) .+ List.sortBy (Ord.comparing fst) .+ Foldable.toList .+ fmap (view $ from note) .+ reifyScore+ ++ -- | -- View a score as a single note. --@@ -467,20 +484,8 @@ events :: {-Transformable a => -}Lens (Score a) (Score b) [(Time, Duration, a)] [(Time, Duration, b)] events = notes . through event event -_score :: [(Time, Duration, a)] -> Score a-_score = mconcat . fmap (uncurry3 event)- where- event t d x = (delay (t .-. 0) . stretch d) (return x) -_getScore :: {-Transformable a => -}Score a -> [(Time, Duration, a)]-_getScore =- fmap (\(view delta -> (t,d),x) -> (t,d,x)) .- List.sortBy (Ord.comparing fst) .- Foldable.toList .- fmap (view $ from note) .- reifyScore - -- | Map over the values in a score. mapWithSpan :: (Span -> a -> b) -> Score a -> Score b mapWithSpan f = mapScore (uncurry f . view (from note))@@ -505,22 +510,24 @@ mapFilterEvents :: (Time -> Duration -> a -> Maybe b) -> Score a -> Score b mapFilterEvents f = mcatMaybes . mapEvents f -+-- | Mainly useful for backends.+normalizeScore :: Score a -> Score a+normalizeScore = reset . absDurations+ where+ reset x = set onset (view onset x `max` 0) x+ absDurations = over (notes.each.era.delta._2) abs +printEras :: Score a -> IO ()+printEras = mapM_ print . toListOf (notes.each.era) eras :: Transformable a => Score a -> [Span]-eras sc = fmap getSpan . (^. events) $ sc+eras = toListOf (notes . each . era) chordEvents :: Transformable a => Span -> Score a -> [a]-chordEvents era sc = fmap getValue . filter (\ev -> getSpan ev == era) . (^. events) $ sc+chordEvents s = fmap extract . filter ((== s) . view era) . view notes -getValue :: (Time, Duration, a) -> a-getValue (t,d,a) = a -getSpan :: (Time, Duration, a) -> Span-getSpan (t,d,a) = t >-> d - simultaneous' :: Transformable a => Score a -> Score [a] simultaneous' sc = (^. from unsafeEvents) vs where@@ -548,3 +555,4 @@ -- TODO identical to: lens simultaneous' (flip $ mapSimultaneous . const) -- wrap in something to preserve meta +-- JUNK
src/Music/Time/Segment.hs view
@@ -83,7 +83,6 @@ import Data.AffineSpace import Data.AffineSpace.Point import Data.Clipped-import Data.Functor.Rep.Lens import Data.Map (Map) import qualified Data.Map as Map import Data.Ratio@@ -102,12 +101,11 @@ import Music.Time.Voice import Control.Applicative-import Control.Arrow (first, second, (&&&), (***)) import Control.Lens hiding (Indexable, Level, above, below, index, inside, parts, reversed, transform, (<|), (|>)) import Data.Distributive-import Data.Functor.Rep+import Data.Functor.Rep as R import Data.Functor.Rep.Lens import Data.Maybe import Data.Typeable@@ -119,25 +117,23 @@ -- | ----- A 'Segment' is a value varying over some unknown time span.+-- A 'Segment' is a value varying over some unknown time span. +-- Intuitively, a 'Segment' is to a 'Behavior' what a /ray/ is to a /line/. -- -- To give a segment an explicit duration, use 'Stretched' 'Segment'. -- -- To place a segment in a particular time span, use 'Note' 'Segment'. ----- The semantics are given by+newtype Segment a = Segment { getSegment :: Clipped Duration -> a }+ deriving (Functor, Applicative, Monad{-, Comonad-}, Typeable)++-- $semantics Segment -- -- @ -- type Segment a = 'Duration' -> a -- @ ---newtype Segment a = Segment { getSegment :: Clipped Duration -> a }- deriving (Functor, Applicative, Monad{-, Comonad-}) ------ TODO constant-optimize a la Conal---- -- $musicTimeSegmentExamples -- -- > foldr1 apSegments' $ map (view stretched) $ [(0.5,0::Segment Float), (1, timeS), (2,rev timeS), (3,-1)]@@ -148,8 +144,8 @@ instance Show (Segment a) where show _ = "<<Segment>>" -deriving instance Typeable1 Segment-deriving instance Distributive Segment+instance Distributive Segment where+ distribute = Segment . distribute . fmap getSegment instance Representable Segment where type Rep Segment = Duration@@ -238,7 +234,7 @@ -- View a segment as a time function and vice versa. -- segment :: Iso (Duration -> a) (Duration -> b) (Segment a) (Segment b)-segment = tabulated+segment = R.tabulated apSegments' :: Stretched (Segment a) -> Stretched (Segment a) -> Stretched (Segment a) apSegments' (view (from stretched) -> (d1,s1)) (view (from stretched) -> (d2,s2))@@ -287,8 +283,8 @@ where bb2ns (Bound (s, x)) = view note (s, b2s $ transform (negateV s) $ x) ns2bb (view (from note) -> (s, x)) = Bound (s, transform s $ s2b $ x)- s2b = under tabulated (. realToFrac)- b2s = under tabulated (. realToFrac)+ s2b = under R.tabulated (. realToFrac)+ b2s = under R.tabulated (. realToFrac) -- -- Note that the isomorhism only works because of 'Bound' being abstract.@@ -368,4 +364,5 @@ get = view (from bounded . noteValue) . {-pure-}bounding mempty set x = splice x . (view bounded) . pure +-- JUNK
src/Music/Time/Split.hs view
@@ -88,6 +88,9 @@ ending d = snd . split d -- TODO rename beginning/ending to fstSplit/sndSplit or similar +instance Splittable () where+ split _ x = (x, x)+ instance Splittable Duration where -- Directly from the laws -- Guard against t < 0
src/Music/Time/Stretched.hs view
@@ -41,6 +41,7 @@ import Data.AffineSpace import Data.AffineSpace.Point+import Data.Bifunctor import Data.Map (Map) import qualified Data.Map as Map import Data.Ratio@@ -48,12 +49,12 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.VectorSpace+import Data.Functor.Couple import Music.Time.Reverse import Music.Time.Split import Control.Applicative-import Control.Arrow (first, second, (&&&), (***)) import Control.Comonad import Control.Comonad.Env import Control.Lens hiding (Indexable, Level, above, below,@@ -67,19 +68,23 @@ -- | -- A 'Stretched' value has a known 'duration', but no 'position'. ----- Placing a value inside 'Stretched' makes it invariante under 'delay'.+-- Placing a value inside 'Stretched' makes it invariant under 'delay', however the inner+-- value can still be delayed using @'fmap' 'delay'@. ----- The semantics are given by+newtype Stretched a = Stretched { _stretchedValue :: Couple Duration a }+ deriving (Applicative, Monad, {-Comonad, -}+ Functor, Foldable, Traversable)++-- $semantics Stretched -- -- @ -- type Stretched = (Duration, a) -- @ ---newtype Stretched a = Stretched { _stretchedValue :: (Duration, a) }- deriving (Eq, {-Ord, -}{-Show, -}- Applicative, Monad, {-Comonad, -}- Functor, Foldable, Traversable) +-- TODO move+deriving instance Traversable (Couple a)+ -- >>> stretch 2 $ (5,1)^.stretched -- (10,1)^.stretched --@@ -87,12 +92,21 @@ -- (5,1)^.stretched -- +deriving instance Eq a => Eq (Stretched a)+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 _stretchedValue Stretched+ _Wrapped' = iso (getCouple . _stretchedValue) (Stretched . Couple) instance Rewrapped (Stretched a) (Stretched b) @@ -124,8 +138,10 @@ stretchedValue :: (Transformable a, Transformable b) => Lens (Stretched a) (Stretched b) a b stretchedValue = lens runStretched (flip $ _stretched . const) where- _stretched f (Stretched (d,x)) = Stretched (d, f `whilst` stretching d $ x)+ _stretched f (Stretched (Couple (d, x))) = Stretched (Couple (d, f `whilst` stretching d $ x)) {-# INLINE stretchedValue #-} runStretched :: Transformable a => Stretched a -> a runStretched = uncurry stretch . view _Wrapped++-- JUNK
src/Music/Time/Track.hs view
@@ -57,7 +57,6 @@ import Music.Time.Split import Control.Applicative-import Control.Arrow (first, second, (&&&), (***)) import Control.Lens hiding (Indexable, Level, above, below, index, inside, parts, reversed, transform, (<|), (|>))@@ -80,6 +79,7 @@ -- newtype Track a = Track { getTrack :: TrackList (TrackEv a) } deriving (Functor, Foldable, Traversable, Semigroup, Monoid, Typeable, Show, Eq)+{-# DEPRECATED Track "Use 'Chord'" #-} -- A track is a list of events with explicit onset. --@@ -123,14 +123,22 @@ instance Transformable (Track a) where transform s = over _Wrapped' (transform s) +instance HasPosition (Track a) where+ _onset = safeMinimum . fmap _onset . view _Wrapped'+ _offset = safeMaximum . fmap _offset . view _Wrapped'++-- TODO move+safeMinimum xs = if null xs then 0 else minimum xs+safeMaximum xs = if null xs then 0 else maximum xs+ instance HasDuration (Track a) where- _duration = Foldable.sum . fmap _duration . view _Wrapped'+ _duration x = _offset x .-. _onset x instance Splittable a => Splittable (Track a) where -- TODO instance Reversible a => Reversible (Track a) where- rev = over _Wrapped' (fmap rev) -- TODO OK?+ -- TODO -- |@@ -144,6 +152,7 @@ delayeds :: Lens (Track a) (Track b) [Delayed a] [Delayed b] delayeds = unsafeTrack+{-# INLINE delayeds #-} singleDelayed :: Prism' (Track a) (Delayed a) singleDelayed = unsafeTrack . single
src/Music/Time/Types.hs view
@@ -1,4 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-}@@ -31,17 +32,24 @@ module Music.Time.Types ( - -- * Duration- Duration,- toDuration,- fromDuration,-- -- * Time points+ -- * Basic types+ -- ** Time points Time, toTime, fromTime, + -- ** Duration+ Duration,+ toDuration,+ fromDuration,++ -- ** Convert between time and duration -- $convert+ offsetPoints,+ toAbsoluteTime,+ toRelativeTime,+ toRelativeTimeN,+ toRelativeTimeN', -- * Time spans Span,@@ -52,39 +60,63 @@ -- *** Accessing spans range, delta,- showRange,- showDelta,+ codelta, + -- ** Properties+ -- $forwardBackWardEmpty+ isForwardSpan,+ isBackwardSpan,+ isEmptySpan,++ -- ** Transformations+ reverseSpan,+ reflectSpan,+ normalizeSpan,+ + -- ** Delay and stretch component+ delayComponent,+ stretchComponent,+ fixedOnsetSpan,+ fixedDurationSpan,+ -- ** Points in spans- -- TODO move+ inside,++ -- ** Partial orders isProper, isBefore,- inside, encloses, overlaps, -- union -- intersection (alt name 'overlap') -- difference (would actually become a split) - -- TODO Abjad terminology: contains/curtails/delays/intersects/isCongruentTo-- -- ** Properties- delayOnly,- stretchOnly,- -- Proper spans are always bounded and closed+ -- ** Read/Show+ showRange,+ showDelta,+ showCodelta, ) where import Control.Lens hiding (Indexable, Level, above, below, index, inside, parts, reversed, transform, (<|), (|>))+--+import Control.Applicative.Backwards+import Control.Monad.State.Lazy+--+import Data.Aeson (ToJSON(..))+import qualified Data.Aeson as JSON+ import Data.AffineSpace import Data.AffineSpace.Point import Data.Semigroup import Data.Typeable import Data.VectorSpace+import Data.List (mapAccumL, mapAccumR)+import Data.Ratio import Music.Time.Internal.Util (showRatio)-+-- import Data.Fixed -- $convert --@@ -98,16 +130,19 @@ -- for 'Fractional' and 'RealFrac'. -- type TimeBase = Rational--- type TimeBase = Fixed E12+{-+type TimeBase = Fixed E12 --- instance HasResolution a => AdditiveGroup (Fixed a) where--- zeroV = 0--- negateV = negate--- (^+^) = (+)+instance HasResolution a => AdditiveGroup (Fixed a) where+ zeroV = 0+ negateV = negate+ (^+^) = (+) -- Can be enabled for experimental time representation--- deriving instance Floating Time--- deriving instance Floating Duration+instance Floating TimeBase where+deriving instance Floating Time+deriving instance Floating Duration+-} -- |@@ -119,18 +154,20 @@ -- -- 'Duration' is invariant under translation so 'delay' has no effect on it. ----- The semantics are given by+newtype Duration = Duration { getDuration :: TimeBase }+ deriving (Eq, Ord, Num, Enum, Fractional, Real, RealFrac, Typeable)++-- $semantics Duration ----- @ -- type Duration = R--- @ ---newtype Duration = Duration { getDuration :: TimeBase }- deriving (Eq, Ord, Num, Enum, Fractional, Real, RealFrac, Typeable) instance Show Duration where show = showRatio . realToFrac +instance ToJSON Duration where+ toJSON = JSON.Number . realToFrac+ instance InnerSpace Duration where (<.>) = (*) @@ -174,18 +211,20 @@ -- times to get a duration using '.-.'. 'Time' forms an 'AffineSpace' with 'Duration' as -- difference space. ----- The semantics are given by+newtype Time = Time { getTime :: TimeBase }+ deriving (Eq, Ord, Num, Enum, Fractional, Real, RealFrac, Typeable)++-- $semantics Time ----- @ -- type Time = R--- @ ---newtype Time = Time { getTime :: TimeBase }- deriving (Eq, Ord, Num, Enum, Fractional, Real, RealFrac, Typeable) instance Show Time where show = showRatio . realToFrac +instance ToJSON Time where+ toJSON = JSON.Number . realToFrac+ deriving instance AdditiveGroup Time instance VectorSpace Time where@@ -219,35 +258,106 @@ +-- TODO terminology+-- Return the "accumulative sum" of the given vecors -- |+-- @length (offsetPoints x xs) = length xs + 1@+--+-- >>> offsetPoints 0 [1,2,1]+-- [0,1,2,1]+--+-- @+-- offsetPoints :: 'AffineSpace' a => 'Time' -> ['Duration'] -> ['Time']+-- @+--+offsetPoints :: AffineSpace a => a -> [Diff a] -> [a]+offsetPoints = scanl (.+^)++-- | Convert to delta (time to wait before this note)+toRelativeTime :: [Time] -> [Duration]+toRelativeTime = snd . mapAccumL g 0 where g prev t = (t, t .-. prev)+-- toRelativeTime xs = fst $ mapAccumL2 g xs 0 where g t prev = (t .-. prev, t)++-- | Convert to delta (time to wait before next note)+toRelativeTimeN :: [Time] -> [Duration]+toRelativeTimeN [] = []+toRelativeTimeN xs = toRelativeTimeN' (last xs) xs++-- | Convert to delta (time to wait before next note)+toRelativeTimeN' :: Time -> [Time] -> [Duration]+toRelativeTimeN' end xs = snd $ mapAccumR g end xs where g prev t = (t, prev .-. t)++{-+TODO consolidate with this beat (used in Midi export)++toRelative = snd . List.mapAccumL g 0+ where+ g now (t,d,x) = (t, (0 .+^ (t .-. now),d,x))++-}+-- 0 x,1 x,1 x,1 x+ -- x 1,x 1,x 1,x 0++-- | Convert from delta (time to wait before this note)+toAbsoluteTime :: [Duration] -> [Time]+toAbsoluteTime = tail . offsetPoints 0+++++-- TODO use State instead++-- mapAccumL :: (s -> a -> (s, b)) -> s -> [a] -> (s, [b])+-- \f -> mapM (runState . f) :: MonadState s m => (a -> s -> (b, s)) -> [a] -> s -> ([b], s)++-- mapAccumL :: (s -> a -> (s, b)) -> s -> [a] -> (s, [b])+mapAccumL2 :: (a -> s -> (b, s)) -> [a] -> s -> ([b], s)+mapAccumL2 f = runState . mapM (state . f)++++++++-- | -- A 'Span' represents an onset and offset in time (or equivalently: an onset and a -- duration, /or/ a duration and an offset, /or/ a duration and a middle point). -- -- Pattern matching over span is possible (with @ViewPatterns@): -- -- @--- foo ('view' 'range' -> (t1, t2)) = ...--- foo ('view' 'delta' -> (t, d)) = ...+-- foo ('view' 'range' -> (t1, t2)) = ...+-- foo ('view' 'delta' -> (t1, d)) = ...+-- foo ('view' 'codelta' -> (d, t2)) = ... -- @ -- -- Another way of looking at 'Span' is that it represents a time transformation where--- onset is translation and duration is scaling. TODO see 'transform' and 'whilst'+-- onset is translation and duration is scaling. ----- The semantics are given by+-- TODO How to use with 'transform', 'whilst' etc. -- -- @--- type Span = Time x Time+-- a '<->' b = (a, b)^.'from' 'range'+-- a '>->' b = (a, b)^.'from' 'delta'+-- a '<-<' b = (a, b)^.'from' 'codelta' -- @ -- newtype Span = Delta { _delta :: (Time, Duration) } deriving (Eq, Ord, Typeable) --- You can create a span using the '<->' and '>->' constructors. Note that:+-- $semantics ----- > t <-> u = t >-> (u .-. t)--- > t >-> d = t <-> t .+^ d+-- type Span = Time x Time --++-- You can create a span using the constructors '<->', '<-<' and '>->'. Note that:+--+-- > a >-> b = a <-> (a .+^ b)+-- > a <-< b = (b .-^ a) <-> b+-- > a <-> b = a >-> (b .-. a)+-- -- To create and destruct a span (in any of its incarnations), use the provided isomorphisms: -- -- 'Span' is a 'Semigroup', 'Monoid' and 'AdditiveGroup':@@ -278,6 +388,10 @@ show = showRange -- Which form should we use? +instance ToJSON Span where+ toJSON (view range -> (a,b)) = JSON.object [ ("onset", toJSON a), ("offset", toJSON b) ]++ -- | -- 'zeroV' or 'mempty' represents the /unit interval/ @0 \<-\> 1@, which also happens to -- be the identity transformation.@@ -327,9 +441,6 @@ a <-< b = (b .-^ a) <-> b --- > (<->) = curry $ view $ from range--- > (>->) = curry $ view $ from delta- -- | -- View a span as pair of onset and offset. --@@ -345,49 +456,120 @@ delta = iso _delta Delta -- |+-- View a span as a pair of duration and offset.+--+codelta :: Iso' Span (Duration, Time)+codelta = iso _codelta $ uncurry (<-<)+ where+ _codelta x = let (t, d) = _delta x in (d, t .+^ d)++-- | -- Show a span in range notation, i.e. @t1 \<-\> t2@. -- showRange :: Span -> String showRange (view range -> (t,u)) = show t ++ " <-> " ++ show u -- |--- Show a span in range notation, i.e. @t >-> d@.+-- Show a span in delta notation, i.e. @t >-> d@. -- showDelta :: Span -> String showDelta (view delta -> (t,d)) = show t ++ " >-> " ++ show d -- |--- A prism to the subset of 'Span' that performs a delay but no stretch.+-- Show a span in codelta notation, i.e. @t <-< d@. ----- To access the delay component in any span, use @'view' ('delta' . e'_1')@+showCodelta :: Span -> String+showCodelta (view codelta -> (d,u)) = show d ++ " <-< " ++ show u++-- |+-- Access the delay component in a span. ---delayOnly :: Prism' Span Time-delayOnly = prism' (\t -> view (from delta) (t, 1)) $ \x -> case view delta x of+delayComponent :: Span -> Time+delayComponent x = x ^. delta . _1++-- |+-- Access the stretch component in a span.+--+stretchComponent :: Span -> Duration+stretchComponent x = x ^. delta . _2++-- |+-- A prism to the subset of 'Span' that performs a delay but no stretch.+--+fixedDurationSpan :: Prism' Span Time+fixedDurationSpan = prism' (\t -> view (from delta) (t, 1)) $ \x -> case view delta x of (t, 1) -> Just t _ -> Nothing - -- | -- A prism to the subset of 'Span' that performs a stretch but no delay. ----- To access the stretch component in any span, use @'view' ('delta' . '_2')@----stretchOnly :: Prism' Span Duration-stretchOnly = prism' (\d -> view (from delta) (0, d)) $ \x -> case view delta x of+fixedOnsetSpan :: Prism' Span Duration+fixedOnsetSpan = prism' (\d -> view (from delta) (0, d)) $ \x -> case view delta x of (0, d) -> Just d _ -> Nothing +--+-- $forwardBackWardEmpty+--+-- 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+-- --- Same as (onset, offset), defined here for bootstrapping reasons-startTime (view range -> (t1, t2)) = t1-stopTime (view range -> (t1, t2)) = t2+-- |+-- Whether the given span has a positive duration, i.e. whether its 'onset' is before its 'offset'.+--+isForwardSpan :: Span -> Bool+isForwardSpan = (> 0) . signum . _durationS +-- |+-- Whether the given span has a negative duration, i.e. whether its 'offset' is before its 'onset'.+--+isBackwardSpan :: Span -> Bool+isBackwardSpan = (< 0) . signum . _durationS -- |--- Whether this is a proper span, i.e. whether @'_onset' x '<' 'stopTime' x@.+-- Whether the given span is empty, i.e. whether its 'onset' and 'offset' are equivalent. --+isEmptySpan :: Span -> Bool+isEmptySpan = (== 0) . signum . _durationS+++-- |+-- Reflect a span through its midpoint.+--+reverseSpan :: Span -> Span+reverseSpan s = reflectSpan (_midpointS s) s++-- |+-- Reflect a span through an arbitrary point.+--+reflectSpan :: Time -> Span -> Span+reflectSpan p = over (range . both) (reflectThrough p)++-- |+-- Normalize a span, i.e. reverse it if negative, and do nothing otherwise.+--+-- @+-- _duration s = _duration (normalizeSpan s)+-- _midpoint s = _midpoint (normalizeSpan s)+-- @+--+normalizeSpan :: Span -> Span+normalizeSpan s = if isForwardSpan s then s else reverseSpan s+-- TODO Duplicate as normalizeNoteSpan++-- |+-- Whether this is a proper span, i.e. whether @'_onset' x '<' '_offset' x@.+-- isProper :: Span -> Bool isProper (view range -> (t, u)) = t < u+{-# DEPRECATED isProper "Use 'isForwardSpan'" #-} -- | -- Whether the given point falls inside the given span (inclusively).@@ -405,7 +587,7 @@ -- Whether the first given span encloses the second span. -- encloses :: Span -> Span -> Bool-a `encloses` b = startTime b `inside` a && stopTime b `inside` a+a `encloses` b = _onsetS b `inside` a && _offsetS b `inside` a -- | -- Whether the given span overlaps.@@ -417,5 +599,33 @@ -- Whether the first given span occurs before the second span. -- isBefore :: Span -> Span -> Bool-a `isBefore` b = (startTime a `max` stopTime a) <= (startTime b `min` stopTime b)+a `isBefore` b = (_onsetS a `max` _offsetS a) <= (_onsetS b `min` _offsetS b)+++-- TODO resolve this so we can use actual onset/offset etc in the above definitions+-- Same as (onset, offset), defined here for bootstrapping reasons+_onsetS (view range -> (t1, t2)) = t1+_offsetS (view range -> (t1, t2)) = t2+_midpointS s = _onsetS s .+^ _durationS s / 2+_durationS s = _offsetS s .-. _onsetS s++{-+Two alternative definitions for midpoint:++midpoint x = onset x + duration x / 2+midpoint x = (onset x + offset x) / 2++Both equivalent. Proof:++ let d = b - a+ (a + b)/2 = a + d/2+ (a + b)/2 = a + (b - a)/2+ a + b = 2a + (b - a)+ a + b = a + b+-}++-- TODO move+fraction :: (RealFrac a, Integral b) => Iso' a (b, b) +fraction = iso (\(toRational -> a) -> (fromIntegral $ numerator a, fromIntegral $ denominator a)) (\(a,b) -> fromIntegral a / fromIntegral b)+
src/Music/Time/Voice.hs view
@@ -40,19 +40,16 @@ -- ** Extracting values stretcheds, eventsV,-- -- ** Pattern matching singleStretched, - -- *** Unsafe versions- unsafeStretcheds,- unsafeEventsV,-- -- * Fusion fuse, fuseBy, + -- ** Special cases+ fuseRests,+ coverRests,+ -- * Traversing -- ** Separating rhythms and values withValues,@@ -65,47 +62,58 @@ -- ** Zips unzipVoice, zipVoice,+ zipVoice3,+ zipVoice4,+ zipVoiceNoScale,+ zipVoiceNoScale3,+ zipVoiceNoScale4, zipVoiceWith, zipVoiceWith', zipVoiceWithNoScale, -- * Context withContext,+ voiceLens,+ -- voiceL,+ voiceAsList,+ listAsVoice, - -- headV,- -- middleV,- -- lastV, + -- * Unsafe versions+ unsafeStretcheds,+ unsafeEventsV, ) where import Data.AffineSpace import Data.AffineSpace.Point-import Data.Map (Map)-import qualified Data.Map as Map+import Data.Functor.Adjunction (unzipR)+import Data.Functor.Context+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe import Data.Ratio import Data.Semigroup-import Data.Set (Set)-import qualified Data.Set as Set+import Data.Set (Set)+import qualified Data.Set as Set import Data.VectorSpace-import Data.Functor.Adjunction (unzipR) import Music.Time.Reverse import Music.Time.Split import Music.Time.Stretched import Control.Applicative-import Control.Lens hiding (Indexable, Level, above, below,- index, inside, parts, reversed,- transform, (<|), (|>))+import Control.Lens hiding (Indexable, Level, above,+ below, index, inside, parts,+ reversed, transform, (<|), (|>)) import Control.Monad import Control.Monad.Compose import Control.Monad.Plus-import Data.Foldable (Foldable)-import qualified Data.Foldable as Foldable+import Data.Foldable (Foldable)+import qualified Data.Foldable as Foldable import qualified Data.List-import Data.List.NonEmpty (NonEmpty)-import Data.Traversable (Traversable)-import qualified Data.Traversable as T+import Data.List.NonEmpty (NonEmpty)+import Data.Traversable (Traversable)+import qualified Data.Traversable as T import Data.Typeable import Music.Dynamics.Literal import Music.Pitch.Literal@@ -114,13 +122,14 @@ -- | -- A 'Voice' is a sequential composition of values. Events may not overlap. ----- @--- type Voice a = [Stretched a]--- @--- newtype Voice a = Voice { getVoice :: VoiceList (VoiceEv a) } deriving (Functor, Foldable, Traversable, Semigroup, Monoid, Typeable, Show, Eq) +--+-- $semantics Voice+-- type Voice a = [Stretched a]+--+ -- A voice is a list of events with explicit duration. Events can not overlap. -- -- Voice is a 'Monoid' under sequential composition. 'mempty' is the empty part and 'mappend'@@ -153,6 +162,10 @@ return = view _Unwrapped . return . return xs >>= f = view _Unwrapped $ (view _Wrapped . f) `mbind` view _Wrapped xs +instance MonadPlus Voice where+ mzero = mempty+ mplus = mappend+ -- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (Voice a) where type Unwrapped (Voice a) = (VoiceList (VoiceEv a))@@ -160,21 +173,27 @@ instance Rewrapped (Voice a) (Voice b) +instance Cons (Voice a) (Voice b) (Stretched a) (Stretched b) where+ _Cons = prism (\(s,v) -> (view voice.return $ s) <> v) $ \v -> case view stretcheds v of+ [] -> Left mempty+ (x:xs) -> Right (x, view voice xs)++instance Snoc (Voice a) (Voice b) (Stretched a) (Stretched b) where+ _Snoc = prism (\(v,s) -> v <> (view voice.return $ s)) $ \v -> case unsnoc (view stretcheds v) of+ Nothing -> Left mempty+ Just (xs, x) -> Right (view voice xs, x)+ instance Transformable (Voice a) where transform s = over _Wrapped' (transform s) instance HasDuration (Voice a) where _duration = Foldable.sum . fmap _duration . view _Wrapped' --- TODO move-instance Splittable () where- split _ x = (x,x)- instance Splittable a => Splittable (Voice a) where split t x | t <= 0 = (mempty, x) | t >= _duration x = (x, mempty)- | otherwise = let (a,b) = split' t {-split-} (x^._Wrapped) in (a^._Unwrapped, b^._Unwrapped)+ | otherwise = let (a,b) = split' t {-split-} (x^._Wrapped) in (a^._Unwrapped, b^._Unwrapped) where split' = error "TODO" @@ -182,15 +201,15 @@ -- 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)) + -- 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 + -- 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) + -- in (currentOnset .+^ d, theSplit) instance Reversible a => Reversible (Voice a) where rev = over _Wrapped' (fmap rev) -- TODO OK?@@ -313,7 +332,7 @@ -- |--- Unzip the given voice. This is specialization of 'unzipR'. +-- Unzip the given voice. This is specialization of 'unzipR'. -- unzipVoice :: Voice (a, b) -> (Voice a, Voice b) unzipVoice = unzipR@@ -325,6 +344,49 @@ zipVoice = zipVoiceWith (,) -- |+-- Join the given voices by multiplying durations and pairing values.+--+zipVoice3 :: Voice a -> Voice b -> Voice c -> Voice (a, (b, c))+zipVoice3 a b c = zipVoice a (zipVoice b c)++-- |+-- Join the given voices by multiplying durations and pairing values.+--+zipVoice4 :: Voice a -> Voice b -> Voice c -> Voice d -> Voice (a, (b, (c, d)))+zipVoice4 a b c d = zipVoice a (zipVoice b (zipVoice c d))++-- |+-- Join the given voices by multiplying durations and pairing values.+--+zipVoice5 :: Voice a -> Voice b -> Voice c -> Voice d -> Voice e -> Voice (a, (b, (c, (d, e))))+zipVoice5 a b c d e = zipVoice a (zipVoice b (zipVoice c (zipVoice d e)))++-- |+-- Join the given voices by pairing values and selecting the first duration.+--+zipVoiceNoScale :: Voice a -> Voice b -> Voice (a, b)+zipVoiceNoScale = zipVoiceWithNoScale (,)++-- |+-- Join the given voices by pairing values and selecting the first duration.+--+zipVoiceNoScale3 :: Voice a -> Voice b -> Voice c -> Voice (a, (b, c))+zipVoiceNoScale3 a b c = zipVoiceNoScale a (zipVoiceNoScale b c)++-- |+-- Join the given voices by pairing values and selecting the first duration.+--+zipVoiceNoScale4 :: Voice a -> Voice b -> Voice c -> Voice d -> Voice (a, (b, (c, d)))+zipVoiceNoScale4 a b c d = zipVoiceNoScale a (zipVoiceNoScale b (zipVoiceNoScale c d))++-- |+-- Join the given voices by pairing values and selecting the first duration.+--+zipVoiceNoScale5 :: Voice a -> Voice b -> Voice c -> Voice d -> Voice e -> Voice (a, (b, (c, (d, e))))+zipVoiceNoScale5 a b c d e = zipVoiceNoScale a (zipVoiceNoScale b (zipVoiceNoScale c (zipVoiceNoScale d e)))+++-- | -- Join the given voices by multiplying durations and combining values using the given function. -- zipVoiceWith :: (a -> b -> c) -> Voice a -> Voice b -> Voice c@@ -366,14 +428,41 @@ fuseBy' p g = over unsafeEventsV $ fmap foldNotes . Data.List.groupBy (inspectingBy snd p) where -- Add up durations and use a custom function to combine notes+ -- -- Typically, the combination function us just 'head', as we know that group returns -- non-empty lists of equal elements. foldNotes (unzip -> (ds, as)) = (sum ds, g as) +-- | +-- Fuse all rests in the given voice. The resulting voice will have no consecutive rests.+--+fuseRests :: Voice (Maybe a) -> Voice (Maybe a)+fuseRests = fuseBy (\x y -> isNothing x && isNothing y) -withContext :: Voice a -> Voice (Maybe a, a, Maybe a)-withContext = over valuesV withPrevNext+-- | +-- Remove all rests in the given voice by prolonging the previous note. Returns 'Nothing'+-- if and only if the given voice contains rests only.+--+coverRests :: Voice (Maybe a) -> Maybe (Voice a)+coverRests x = if hasOnlyRests then Nothing else Just (fmap fromJust $ fuseBy merge x)+ where+ norm = fuseRests x+ merge Nothing Nothing = error "Voice normalized, so consecutive rests are impossible"+ merge (Just x) Nothing = True+ merge Nothing (Just x) = True+ merge (Just x) (Just y) = False+ hasOnlyRests = all isNothing $ toListOf traverse x -- norm ++withContext :: Voice a -> Voice (Ctxt a)+withContext = over valuesV (fmap Ctxt . withPrevNext)++-- TODO expose?+voiceFromRhythm :: [Duration] -> Voice ()+voiceFromRhythm = mkVoice . fmap (, ())++mkVoice = view voice . fmap (view stretched)+ -- -- TODO more elegant definition of durationsV and valuesV using indexed traversal or similar? --@@ -434,27 +523,29 @@ reverseValues :: Voice a -> Voice a reverseValues = over valuesV reverse +-- Lens "filtered" throuygh 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) ------ TODO--- Implement meta-data---+-- TODO generalize to any zippable thing+-- voiceL :: ALens s t a b -> Lens (Voice s) (Voice t) (Voice a) (Voice b)+voiceL l = voiceLens (view $ cloneLens l) (set $ cloneLens l) ------ TODO make Voice/Voice an instance of Cons/Snoc and remove these--- -headV :: Traversal' (Voice a) a-headV = (eventsV._head._2)+-- TODO not meta-safe+voiceAsList :: Iso (Voice a) (Voice b) [a] [b]+voiceAsList = iso voiceToList listToVoice+ where+ voiceToList = map snd . view eventsV+ listToVoice = mconcat . fmap pure -middleV :: Traversal' (Voice a) a-middleV = (eventsV._middle.traverse._2)+listAsVoice :: Iso [a] [b] (Voice a) (Voice b)+listAsVoice = from voiceAsList -lastV :: Traversal' (Voice a) a-lastV = (eventsV._last._2) --- Traverse writing to all elements *except* first and last-_middle :: (Snoc s s a a, Cons s s b b) => Traversal' s s-_middle = _tail._init+--+-- TODO+-- Implement meta-data+--