diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 diff --git a/music-score.cabal b/music-score.cabal --- a/music-score.cabal +++ b/music-score.cabal @@ -1,6 +1,6 @@ name: music-score -version: 1.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 . 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 diff --git a/src/Control/Lens/Cons/Middle.hs b/src/Control/Lens/Cons/Middle.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Cons/Middle.hs @@ -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 diff --git a/src/Data/Average.hs b/src/Data/Average.hs new file mode 100644 --- /dev/null +++ b/src/Data/Average.hs @@ -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) + + diff --git a/src/Data/Clipped.hs b/src/Data/Clipped.hs --- a/src/Data/Clipped.hs +++ b/src/Data/Clipped.hs @@ -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 diff --git a/src/Data/Functor/Context.hs b/src/Data/Functor/Context.hs --- a/src/Data/Functor/Context.hs +++ b/src/Data/Functor/Context.hs @@ -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 diff --git a/src/Data/Functor/Couple.hs b/src/Data/Functor/Couple.hs --- a/src/Data/Functor/Couple.hs +++ b/src/Data/Functor/Couple.hs @@ -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 diff --git a/src/Data/Functor/Rep/Lens.hs b/src/Data/Functor/Rep/Lens.hs --- a/src/Data/Functor/Rep/Lens.hs +++ b/src/Data/Functor/Rep/Lens.hs @@ -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 - +-} diff --git a/src/Data/Semigroup/Instances.hs b/src/Data/Semigroup/Instances.hs --- a/src/Data/Semigroup/Instances.hs +++ b/src/Data/Semigroup/Instances.hs @@ -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) diff --git a/src/Music/Score.hs b/src/Music/Score.hs --- a/src/Music/Score.hs +++ b/src/Music/Score.hs @@ -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 diff --git a/src/Music/Score/Articulation.hs b/src/Music/Score/Articulation.hs --- a/src/Music/Score/Articulation.hs +++ b/src/Music/Score/Articulation.hs @@ -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 - diff --git a/src/Music/Score/Clef.hs b/src/Music/Score/Clef.hs deleted file mode 100644 --- a/src/Music/Score/Clef.hs +++ /dev/null @@ -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 - diff --git a/src/Music/Score/Color.hs b/src/Music/Score/Color.hs --- a/src/Music/Score/Color.hs +++ b/src/Music/Score/Color.hs @@ -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 diff --git a/src/Music/Score/Convert.hs b/src/Music/Score/Convert.hs --- a/src/Music/Score/Convert.hs +++ b/src/Music/Score/Convert.hs @@ -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)) diff --git a/src/Music/Score/Dynamics.hs b/src/Music/Score/Dynamics.hs --- a/src/Music/Score/Dynamics.hs +++ b/src/Music/Score/Dynamics.hs @@ -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. diff --git a/src/Music/Score/Export/ArticulationNotation.hs b/src/Music/Score/Export/ArticulationNotation.hs --- a/src/Music/Score/Export/ArticulationNotation.hs +++ b/src/Music/Score/Export/ArticulationNotation.hs @@ -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] + _ -> [] diff --git a/src/Music/Score/Export/Backend.hs b/src/Music/Score/Export/Backend.hs --- a/src/Music/Score/Export/Backend.hs +++ b/src/Music/Score/Export/Backend.hs @@ -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) + ) diff --git a/src/Music/Score/Export/DynamicNotation.hs b/src/Music/Score/Export/DynamicNotation.hs --- a/src/Music/Score/Export/DynamicNotation.hs +++ b/src/Music/Score/Export/DynamicNotation.hs @@ -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) diff --git a/src/Music/Score/Export/Lilypond.hs b/src/Music/Score/Export/Lilypond.hs --- a/src/Music/Score/Export/Lilypond.hs +++ b/src/Music/Score/Export/Lilypond.hs @@ -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 + diff --git a/src/Music/Score/Export/Midi.hs b/src/Music/Score/Export/Midi.hs --- a/src/Music/Score/Export/Midi.hs +++ b/src/Music/Score/Export/Midi.hs @@ -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 diff --git a/src/Music/Score/Export/MusicXml.hs b/src/Music/Score/Export/MusicXml.hs --- a/src/Music/Score/Export/MusicXml.hs +++ b/src/Music/Score/Export/MusicXml.hs @@ -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 --- diff --git a/src/Music/Score/Export/NoteList.hs b/src/Music/Score/Export/NoteList.hs --- a/src/Music/Score/Export/NoteList.hs +++ b/src/Music/Score/Export/NoteList.hs @@ -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 diff --git a/src/Music/Score/Export/SuperCollider.hs b/src/Music/Score/Export/SuperCollider.hs --- a/src/Music/Score/Export/SuperCollider.hs +++ b/src/Music/Score/Export/SuperCollider.hs @@ -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 diff --git a/src/Music/Score/Instances.hs b/src/Music/Score/Instances.hs --- a/src/Music/Score/Instances.hs +++ b/src/Music/Score/Instances.hs @@ -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 + diff --git a/src/Music/Score/Internal/Export.hs b/src/Music/Score/Internal/Export.hs --- a/src/Music/Score/Internal/Export.hs +++ b/src/Music/Score/Internal/Export.hs @@ -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 diff --git a/src/Music/Score/Meta.hs b/src/Music/Score/Meta.hs --- a/src/Music/Score/Meta.hs +++ b/src/Music/Score/Meta.hs @@ -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 diff --git a/src/Music/Score/Meta/Annotations.hs b/src/Music/Score/Meta/Annotations.hs --- a/src/Music/Score/Meta/Annotations.hs +++ b/src/Music/Score/Meta/Annotations.hs @@ -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) diff --git a/src/Music/Score/Meta/Attribution.hs b/src/Music/Score/Meta/Attribution.hs --- a/src/Music/Score/Meta/Attribution.hs +++ b/src/Music/Score/Meta/Attribution.hs @@ -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 diff --git a/src/Music/Score/Meta/Barline.hs b/src/Music/Score/Meta/Barline.hs --- a/src/Music/Score/Meta/Barline.hs +++ b/src/Music/Score/Meta/Barline.hs @@ -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) diff --git a/src/Music/Score/Meta/Clef.hs b/src/Music/Score/Meta/Clef.hs --- a/src/Music/Score/Meta/Clef.hs +++ b/src/Music/Score/Meta/Clef.hs @@ -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) diff --git a/src/Music/Score/Meta/Fermata.hs b/src/Music/Score/Meta/Fermata.hs --- a/src/Music/Score/Meta/Fermata.hs +++ b/src/Music/Score/Meta/Fermata.hs @@ -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) diff --git a/src/Music/Score/Meta/Key.hs b/src/Music/Score/Meta/Key.hs --- a/src/Music/Score/Meta/Key.hs +++ b/src/Music/Score/Meta/Key.hs @@ -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) diff --git a/src/Music/Score/Meta/RehearsalMark.hs b/src/Music/Score/Meta/RehearsalMark.hs --- a/src/Music/Score/Meta/RehearsalMark.hs +++ b/src/Music/Score/Meta/RehearsalMark.hs @@ -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 diff --git a/src/Music/Score/Meta/Tempo.hs b/src/Music/Score/Meta/Tempo.hs --- a/src/Music/Score/Meta/Tempo.hs +++ b/src/Music/Score/Meta/Tempo.hs @@ -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 diff --git a/src/Music/Score/Meta/Time.hs b/src/Music/Score/Meta/Time.hs --- a/src/Music/Score/Meta/Time.hs +++ b/src/Music/Score/Meta/Time.hs @@ -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 diff --git a/src/Music/Score/Meta/Title.hs b/src/Music/Score/Meta/Title.hs --- a/src/Music/Score/Meta/Title.hs +++ b/src/Music/Score/Meta/Title.hs @@ -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 diff --git a/src/Music/Score/Phrases.hs b/src/Music/Score/Phrases.hs --- a/src/Music/Score/Phrases.hs +++ b/src/Music/Score/Phrases.hs @@ -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 diff --git a/src/Music/Score/Pitch.hs b/src/Music/Score/Pitch.hs --- a/src/Music/Score/Pitch.hs +++ b/src/Music/Score/Pitch.hs @@ -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 diff --git a/src/Music/Score/Slide.hs b/src/Music/Score/Slide.hs --- a/src/Music/Score/Slide.hs +++ b/src/Music/Score/Slide.hs @@ -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) diff --git a/src/Music/Score/Text.hs b/src/Music/Score/Text.hs --- a/src/Music/Score/Text.hs +++ b/src/Music/Score/Text.hs @@ -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 diff --git a/src/Music/Score/Ties.hs b/src/Music/Score/Ties.hs --- a/src/Music/Score/Ties.hs +++ b/src/Music/Score/Ties.hs @@ -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 diff --git a/src/Music/Time.hs b/src/Music/Time.hs --- a/src/Music/Time.hs +++ b/src/Music/Time.hs @@ -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 diff --git a/src/Music/Time/Behavior.hs b/src/Music/Time/Behavior.hs --- a/src/Music/Time/Behavior.hs +++ b/src/Music/Time/Behavior.hs @@ -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 _ = "<>" -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 diff --git a/src/Music/Time/Bound.hs b/src/Music/Time/Bound.hs --- a/src/Music/Time/Bound.hs +++ b/src/Music/Time/Bound.hs @@ -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 diff --git a/src/Music/Time/Chord.hs b/src/Music/Time/Chord.hs --- a/src/Music/Time/Chord.hs +++ b/src/Music/Time/Chord.hs @@ -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 +-} diff --git a/src/Music/Time/Delayed.hs b/src/Music/Time/Delayed.hs --- a/src/Music/Time/Delayed.hs +++ b/src/Music/Time/Delayed.hs @@ -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) diff --git a/src/Music/Time/Duration.hs b/src/Music/Time/Duration.hs --- a/src/Music/Time/Duration.hs +++ b/src/Music/Time/Duration.hs @@ -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 + +-} + diff --git a/src/Music/Time/Future.hs b/src/Music/Time/Future.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Future.hs @@ -0,0 +1,3 @@ + +module Music.Time.Future where + diff --git a/src/Music/Time/Graces.hs b/src/Music/Time/Graces.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Graces.hs @@ -0,0 +1,2 @@ + +module Music.Time.Graces where diff --git a/src/Music/Time/Internal/Quantize.hs b/src/Music/Time/Internal/Quantize.hs --- a/src/Music/Time/Internal/Quantize.hs +++ b/src/Music/Time/Internal/Quantize.hs @@ -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 ] diff --git a/src/Music/Time/Internal/Transform.hs b/src/Music/Time/Internal/Transform.hs --- a/src/Music/Time/Internal/Transform.hs +++ b/src/Music/Time/Internal/Transform.hs @@ -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. diff --git a/src/Music/Time/Juxtapose.hs b/src/Music/Time/Juxtapose.hs --- a/src/Music/Time/Juxtapose.hs +++ b/src/Music/Time/Juxtapose.hs @@ -218,3 +218,4 @@ group n = times n . (fromIntegral n `compress`) -} +-- JUNK diff --git a/src/Music/Time/Meta.hs b/src/Music/Time/Meta.hs --- a/src/Music/Time/Meta.hs +++ b/src/Music/Time/Meta.hs @@ -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. . -- ------------------------------------------------------------------------------------- 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 diff --git a/src/Music/Time/Nominal.hs b/src/Music/Time/Nominal.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Nominal.hs @@ -0,0 +1,2 @@ + +module Music.Time.Nominal where diff --git a/src/Music/Time/Note.hs b/src/Music/Time/Note.hs --- a/src/Music/Time/Note.hs +++ b/src/Music/Time/Note.hs @@ -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 diff --git a/src/Music/Time/Past.hs b/src/Music/Time/Past.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Past.hs @@ -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 diff --git a/src/Music/Time/Position.hs b/src/Music/Time/Position.hs --- a/src/Music/Time/Position.hs +++ b/src/Music/Time/Position.hs @@ -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. diff --git a/src/Music/Time/Reactive.hs b/src/Music/Time/Reactive.hs --- a/src/Music/Time/Reactive.hs +++ b/src/Music/Time/Reactive.hs @@ -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 diff --git a/src/Music/Time/Reverse.hs b/src/Music/Time/Reverse.hs --- a/src/Music/Time/Reverse.hs +++ b/src/Music/Time/Reverse.hs @@ -265,6 +265,7 @@ instance Reversible a => Reversible (WithRev a) where rev (WithRev (r,x)) = WithRev (x,r) +-- JUNK -} diff --git a/src/Music/Time/Score.hs b/src/Music/Time/Score.hs --- a/src/Music/Time/Score.hs +++ b/src/Music/Time/Score.hs @@ -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 diff --git a/src/Music/Time/Segment.hs b/src/Music/Time/Segment.hs --- a/src/Music/Time/Segment.hs +++ b/src/Music/Time/Segment.hs @@ -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 _ = "<>" -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 diff --git a/src/Music/Time/Split.hs b/src/Music/Time/Split.hs --- a/src/Music/Time/Split.hs +++ b/src/Music/Time/Split.hs @@ -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 diff --git a/src/Music/Time/Stretched.hs b/src/Music/Time/Stretched.hs --- a/src/Music/Time/Stretched.hs +++ b/src/Music/Time/Stretched.hs @@ -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 diff --git a/src/Music/Time/Track.hs b/src/Music/Time/Track.hs --- a/src/Music/Time/Track.hs +++ b/src/Music/Time/Track.hs @@ -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 diff --git a/src/Music/Time/Types.hs b/src/Music/Time/Types.hs --- a/src/Music/Time/Types.hs +++ b/src/Music/Time/Types.hs @@ -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) + diff --git a/src/Music/Time/Voice.hs b/src/Music/Time/Voice.hs --- a/src/Music/Time/Voice.hs +++ b/src/Music/Time/Voice.hs @@ -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 +--