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.1 +version: 1.7.2 author: Hans Hoglund maintainer: Hans Hoglund license: BSD3 @@ -21,36 +21,35 @@ location: git://github.com/music-suite/music-score.git library - build-depends: base >= 4 && < 5, + build-depends: base >= 4 && < 5, aeson >= 0.7.0.6 && < 1, - lens >= 4.3 && < 4.4, + lens >= 4.3.3 && < 4.4, process >= 1.2 && < 1.3, containers, - void, nats, data-default, + average >= 0.6 && < 1, semigroups >= 0.13.0.1 && < 1, semigroupoids, - contravariant >= 0.4.4 && < 1, - comonad, - bifunctors, - profunctors, - distributive, - adjunctions >= 4.1 && < 5, + contravariant >= 1.2 && < 2, + comonad >= 4.2.2 && < 5, + bifunctors >= 4.1.1.1 && < 5, + profunctors >= 4.2.0.1 && < 5, + distributive >= 0.4.4 && < 5, + adjunctions >= 4.2 && < 5, transformers >= 0.3.0.0 && < 0.5, mtl >= 2.1.2 && < 2.3, monadplus, NumInstances, - colour >= 2.3.3 && < 3.0, HCodecs >= 0.5 && < 0.6, vector-space >= 0.8.7 && < 0.9, vector-space-points >= 0.2 && < 0.3, - musicxml2 == 1.7.1, - lilypond == 1.7.1, - music-pitch-literal == 1.7.1, - music-dynamics-literal == 1.7.1, + musicxml2 == 1.7.2, + lilypond == 1.7.2, + music-pitch-literal == 1.7.2, + music-dynamics-literal == 1.7.2, prettify, parsec @@ -59,10 +58,9 @@ Data.Functor.Couple Data.Functor.Context Data.Functor.Rep.Lens + Data.List.Ordered Data.Semigroup.Instances - Data.Average Control.Monad.Compose - Control.Lens.Cons.Middle Music.Time Music.Time.Types Music.Time.Transform @@ -105,6 +103,8 @@ Music.Score.Meta.Tempo Music.Score.Meta.Time Music.Score.Meta.Title + Music.Score.Meta.Pickup + Music.Score.Meta.Extract -- Music.Score.Clef Music.Score.Pitch Music.Score.Articulation @@ -126,9 +126,9 @@ Music.Score.Import.Abc Music.Score.Import.Lilypond Music.Score.Import.Midi - Music.Score.Convert Music.Score.Instances -- We expose these to allow GHCI development + Music.Time.Internal.Convert Music.Time.Internal.Util Music.Time.Internal.Transform Music.Time.Internal.Quantize diff --git a/src/Control/Lens/Cons/Middle.hs b/src/Control/Lens/Cons/Middle.hs deleted file mode 100644 --- a/src/Control/Lens/Cons/Middle.hs +++ /dev/null @@ -1,9 +0,0 @@ - -module Control.Lens.Cons.Middle ( - _middle - ) where - -import Control.Lens - -_middle :: (Snoc s s a a, Cons s s b b) => Traversal' s s -_middle = _tail._init diff --git a/src/Data/Average.hs b/src/Data/Average.hs deleted file mode 100644 --- a/src/Data/Average.hs +++ /dev/null @@ -1,127 +0,0 @@ - -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Data.Average ( - Average(..), - average, - maybeAverage - ) where - -import Prelude hiding ((**)) - --- import Test.QuickCheck(Arbitrary(..)) - -import Data.Typeable -import Data.Maybe -import Data.Semigroup -import Data.AdditiveGroup -import Data.VectorSpace -import Data.AffineSpace -import Control.Monad -import Control.Applicative - --- | --- A monoid for 'Average' values. --- --- This is actually just the free monoid with an extra function 'average' for --- extracing the (arithmetic) mean. This function is used to implement 'Real', --- so you can use 'Average' whenever a ('Monoid', 'Real') is required. --- --- >>> toRational $ mconcat [1,2::Average Rational] --- 3 % 2 --- >>> toRational $ mconcat [1,2::Sum Rational] --- 3 % 1 --- >>> toRational $ mconcat [1,2::Product Rational] --- 2 % 1 --- -newtype Average a = Average { getAverage :: [a] } - deriving (Show, {-Enum, Bounded,-} Semigroup, Monoid, - Typeable, Functor, Applicative) - -instance (Fractional a, Eq a) => Eq (Average a) where - a == b = average a == average b - -instance (Fractional a, Ord a) => Ord (Average a) where - a `compare` b = average a `compare` average b - --- What should (+) and (*) do for Average values? --- --- The important thing is to preserve scalar addition and multiplication (for example --- scaling all components of) an average value by some constant factor, so we can just as --- well use the standard list instance. What about averages with more components? I *think* --- 'average' is a linear map, so they would work as expected: --- --- >>> average (2<>2<>3)+average (3<>3) --- 16 % 3 --- >>> average $ (2<>2<>3)+(3<>3) --- 16 % 3 --- >>> average (mconcat [5,6,9])*average (mconcat[-1,0]) --- (-10) % 3 --- >>> average $ (mconcat [5,6,9])*(mconcat[-1,0]) --- (-10) % 3 --- - -instance Num a => Num (Average a) where - (+) = liftA2 (+) - (*) = liftA2 (*) - negate = fmap negate - abs = fmap abs - signum = fmap signum - fromInteger = pure . fromInteger - -instance (Fractional a, Num a) => Fractional (Average a) where - (/) = liftA2 (/) - fromRational = pure . fromRational - -instance (Real a, Fractional a) => Real (Average a) where - toRational = toRational . average - -instance Floating a => Floating (Average a) where - pi = pure pi - exp = fmap exp - sqrt = fmap sqrt - log = fmap log - sin = fmap sin - tan = fmap tan - cos = fmap cos - asin = fmap asin - atan = fmap atan - acos = fmap acos - sinh = fmap sinh - tanh = fmap tanh - cosh = fmap cosh - asinh = fmap asinh - atanh = fmap atanh - acosh = fmap acosh - -instance AdditiveGroup a => AdditiveGroup (Average a) where - zeroV = pure zeroV - (^+^) = liftA2 (^+^) - negateV = fmap negateV - -instance VectorSpace a => VectorSpace (Average a) where - type Scalar (Average a) = Scalar a - s *^ v = liftA2 (*^) (pure s) v - -instance AffineSpace a => AffineSpace (Average a) where - type Diff (Average a) = Average (Diff a) - p1 .-. p2 = liftA2 (.-.) p1 p2 - p .+^ v = liftA2 (.+^) p v - -{- -instance Arbitrary a => Arbitrary (Average a) where - arbitrary = fmap Average arbitrary --} - --- | Return the average of all monoidal components. If given 'mempty', return zero. -average :: Fractional a => Average a -> a -average = fromMaybe 0 . maybeAverage - --- | Return the average of all monoidal components. If given 'mempty', return 'Nothing'. -maybeAverage :: Fractional a => Average a -> Maybe a -maybeAverage (Average []) = Nothing -maybeAverage (Average xs) = Just $ sum xs / fromIntegral (length xs) - - 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 @@ -41,7 +41,7 @@ -- A variant of pair/writer with lifted instances for the numeric classes, using 'Applicative'. -- newtype Twain b a = Twain { getTwain :: (b, a) } - deriving (Show, Functor, Foldable, Typeable, Applicative, Monad, Comonad, Semigroup, Monoid) + deriving (Show, Functor, Traversable, Foldable, Typeable, Applicative, Monad, Comonad, Semigroup, Monoid) instance Wrapped (Twain b a) where type Unwrapped (Twain b a) = (b, a) @@ -116,7 +116,7 @@ -- A variant of pair/writer with lifted instances for the numeric classes, using 'Applicative'. -- newtype Couple b a = Couple { getCouple :: (b, a) } - deriving (Show, Functor, Foldable, Typeable, Applicative, Monad, Comonad, Semigroup, Monoid) + deriving (Show, Functor, Foldable, Traversable, Typeable, Applicative, Monad, Comonad, Semigroup, Monoid) instance Wrapped (Couple b a) where type Unwrapped (Couple b a) = (b, a) diff --git a/src/Data/List/Ordered.hs b/src/Data/List/Ordered.hs new file mode 100644 --- /dev/null +++ b/src/Data/List/Ordered.hs @@ -0,0 +1,96 @@ + +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} + +module Data.List.Ordered where + +import Control.Lens (Iso', iso, Prism', prism') +import Control.Applicative +import Control.Comonad +import Data.Functor.Couple +import Data.Ord (comparing) +import Data.List (takeWhile, sort, sortBy, group) +import Data.Maybe +import Data.Semigroup +import Control.Monad + +import qualified Data.Set as Set +import qualified Data.Map as Map +import Numeric.Natural + + +-- TODO full definition +type Positive = Natural + + +-- TODO move +#ifndef GHCI +instance Comonad Min where + extract (Min x) = x + duplicate (Min x) = Min (Min x) +instance Comonad Max where + extract (Max x) = x + duplicate (Max x) = Max (Max x) +#endif + +-- TODO move +-- TODO use positive +-- newtype Ordered a = Ordered { getOrdered :: Set.Set (a, Positive) } +-- OR +newtype Ordered a = Ordered { getOrdered :: {-Ord a =>-} Map.Map a Positive } + deriving ({-, Foldable, Traversable-}) + +instance (Ord a) => Eq (Ordered a) where + Ordered a == Ordered b = a == b + +instance Ord a => Ord (Ordered a) where + Ordered a < Ordered b = a < b + +-- | Alas, not a functor +map :: (Ord a, Ord b) => (a -> b) -> Ordered a -> Ordered b +map f (Ordered m) = Ordered (Map.mapKeys f m) + +toList :: Ordered a -> [a] +toList (Ordered xs) = concatMap (uncurry $ flip $ replicate . fromIntegral) $ Map.toList xs + +unsafeFromList :: Ord a => [a] -> Ordered a +unsafeFromList = fromMaybe (error "unsafeFromList: Not sorted") . fromList + +-- Safe (but slow) conversion from lists to ordered lists +fromList :: Ord a => [a] -> Maybe (Ordered a) +fromList xs + | xs /= sort xs = Nothing + | otherwise = Just $ Ordered $ Map.fromList $ + Prelude.map (\x -> (head x, fromIntegral $ Prelude.length x)) $ group xs + +-- Safe (but slow) prism from lists to ordered lists +ordered :: Ord a => Prism' [a] (Ordered a) +ordered = prism' toList fromList +{- + where + prism' bs sma = prism bs (\s -> maybe (Left s) Right (sma s)) + prism bt seta = dimap seta (either pure (fmap bt)) . right' +-} + +unsafeOrdered :: Ord a => Iso' [a] (Ordered a) +unsafeOrdered = iso unsafeFromList toList +{- + where + iso sa bt = dimap sa (fmap bt) +-} + +elem :: Ord a => a -> Ordered a -> Bool +elem k = (> 0) . occs k + +occs :: Ord a => a -> Ordered a -> Int +occs k = maybe 0 fromIntegral . Map.lookup k . getOrdered + +null :: Ordered k -> Bool +null = Map.null . getOrdered + +length :: Ordered a -> Int +length = Prelude.length . toList +-- elem x (Ordered xs) = x 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 @@ -16,9 +16,10 @@ -- TODO move these to semigroups and music-pitch-literal -#if (__GLASGOW_HASKELL__ < 781) +#if !MIN_VERSION_base(4,7,0) deriving instance Num a => Num (Sum a) #endif + deriving instance Real a => Real (Sum a) deriving instance Fractional a => Fractional (Sum a) deriving instance AdditiveGroup a => AdditiveGroup (Sum a) @@ -33,9 +34,10 @@ Sum p .+^ Sum v = Sum (p .+^ v) -#if (__GLASGOW_HASKELL__ < 781) +#if !MIN_VERSION_base(4,7,0) deriving instance Num a => Num (Product a) #endif + deriving instance Real a => Real (Product a) deriving instance Fractional a => Fractional (Product a) deriving instance AdditiveGroup a => AdditiveGroup (Product a) @@ -48,6 +50,7 @@ type Diff (Product a) = Product (Diff a) Product p .-. Product q = Product (p .-. q) Product p .+^ Product v = Product (p .+^ v) + deriving instance IsDynamics a => IsDynamics (Sum a) diff --git a/src/Music/Score.hs b/src/Music/Score.hs --- a/src/Music/Score.hs +++ b/src/Music/Score.hs @@ -9,8 +9,6 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) -- --- Provides a musical score representation. --- ------------------------------------------------------------------------------------- module Music.Score ( @@ -23,7 +21,6 @@ module Data.VectorSpace, module Data.AffineSpace, module Data.AffineSpace.Point, - module Data.Average, module Music.Time, -- module Music.Score.Combinators, @@ -91,7 +88,6 @@ import Data.Traversable import Data.Typeable import Data.VectorSpace hiding (Sum, getSum) -import Data.Average import Music.Time hiding (time) 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 @@ -70,18 +70,22 @@ -- * Articulation transformer ArticulationT(..), + + -- * Context + varticulation, + addArtCon, ) where import Control.Applicative import Control.Comonad import Control.Lens hiding (above, below, transform) -import Control.Lens.Cons.Middle import Data.AffineSpace import Data.Foldable import Data.Functor.Couple import Data.Semigroup import Data.Typeable import Data.VectorSpace hiding (Sum) +import Data.Functor.Context import Music.Score.Part import Music.Time @@ -95,7 +99,6 @@ import Music.Score.Slide import Music.Score.Text import Music.Score.Ties -import Music.Score.Tremolo @@ -256,8 +259,6 @@ type instance Articulation (Couple c a) = Articulation a type instance SetArticulation g (Couple c a) = Couple c (SetArticulation g a) -type instance Articulation (TremoloT a) = Articulation a -type instance SetArticulation g (TremoloT a) = TremoloT (SetArticulation g a) type instance Articulation (TextT a) = Articulation a type instance SetArticulation g (TextT a) = TextT (SetArticulation g a) type instance Articulation (HarmonicT a) = Articulation a @@ -272,11 +273,6 @@ instance (HasArticulation a b) => HasArticulation (Couple c a) (Couple c b) where articulation = _Wrapped . articulation -instance (HasArticulations a b) => HasArticulations (TremoloT a) (TremoloT b) where - articulations = _Wrapped . articulations -instance (HasArticulation a b) => HasArticulation (TremoloT a) (TremoloT b) where - articulation = _Wrapped . articulation - instance (HasArticulations a b) => HasArticulations (TextT a) (TextT b) where articulations = _Wrapped . articulations instance (HasArticulation a b) => HasArticulation (TextT a) (TextT b) where @@ -319,44 +315,9 @@ accentuation :: Lens' a (Accentuation a) separation :: Lens' a (Separation a) -{- --- TODO move -instance Num () where - _ + _ = () - _ - _ = () - _ * _ = () - signum _ = () - abs _ = () - fromInteger _ = () - -instance Fractional () where - _ / _ = () - fromRational _ = () - -instance VectorSpace () where - type Scalar () = () - _ *^ _ = () - -instance AffineSpace () where - type Diff () = () - _ .-. _ = () - _ .+^ _ = () - -instance Articulated () where - accentuation = id - separation = id --} - instance (AffineSpace a, AffineSpace b, Fractional a, Fractional b) => Articulated (a, b) where - accentuation = _1' - separation = _2' - -_1' :: Lens' (a, b) a -_1' = _1 - -_2' :: Lens' (a, b) b -_2' = _2 - + accentuation = _1 + separation = _2 accent :: (HasPhrases' s b, HasArticulations' b, Articulation b ~ a, Articulated a) => s -> s @@ -456,7 +417,6 @@ -- rem = liftA2 rem -- toInteger = toInteger . extract --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (ArticulationT p a) where type Unwrapped (ArticulationT p a) = (p, a) _Wrapped' = iso getArticulationT ArticulationT @@ -483,3 +443,12 @@ where (a1,a2) = toTied a (d1,d2) = toTied d + + +-- TODO move +addArtCon :: ( + HasPhrases s t a b, HasArticulation' a, HasArticulation a b, Articulation a ~ d, Articulation b ~ Ctxt d + ) => s -> t +addArtCon = over (phrases.varticulation) withContext +varticulation = lens (fmap $ view articulation) (flip $ zipVoiceWithNoScale (set articulation)) + 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 @@ -39,6 +39,7 @@ color, colorRed, colorBlue, + colorBlack, -- * Representation ColorT(..), @@ -95,7 +96,6 @@ deriving instance Enum a => Enum (ColorT a) deriving instance Bounded a => Bounded (ColorT a) --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (ColorT a) where type Unwrapped (ColorT a) = Couple (Option (Last (Colour Double))) a _Wrapped' = iso getColorT ColorT @@ -118,11 +118,27 @@ -- | --- Set the number of tremolo divisions for all notes in the score. +-- Set color of all notes in the score. -- color :: HasColor a => Colour Double -> a -> a color = setColor +-- | +-- Color all notes in the score red. +-- +colorRed :: HasColor a => a -> a colorRed = color C.red + +-- | +-- Color all notes in the score blue. +-- +colorBlue :: HasColor a => a -> a colorBlue = color C.blue + +-- | +-- Color all notes in the score black. +-- +colorBlack :: HasColor a => a -> a +colorBlack = color C.black + diff --git a/src/Music/Score/Convert.hs b/src/Music/Score/Convert.hs deleted file mode 100644 --- a/src/Music/Score/Convert.hs +++ /dev/null @@ -1,179 +0,0 @@ - -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -------------------------------------------------------------------------------------- --- | --- Copyright : (c) Hans Hoglund 2012-2014 --- --- License : BSD-style --- --- Maintainer : hans@hanshoglund.se --- Stability : experimental --- Portability : non-portable (TF,GNTD) --- --- Provides conversion betwen temporal container. --- --- /Warning/ This module will be removed soon. --- -------------------------------------------------------------------------------------- - -module Music.Score.Convert ( - voiceToScore, - voiceToScore', - scoreToVoice, - reactiveToVoice', - ) where - -import Control.Applicative -import Control.Lens hiding (transform, time) -import Control.Monad -import Control.Monad.Plus -import Data.AffineSpace -import Data.AffineSpace.Point -import Data.Foldable (Foldable (..)) -import Data.Ord -import Data.Ratio -import Data.Semigroup -import Data.String -import Data.Traversable -import Data.VectorSpace - -import Music.Score.Part -import Music.Time -import Music.Time.Reactive - -import qualified Data.Foldable as Foldable -import qualified Data.List as List - - -{- --- | Convert a note to an _onset and a voice. -noteToVoice :: Note a -> (Time, Voice a) -noteToVoice (view (from note) -> (s,x)) = (_onset s, stretchTo (_duration s) $ return x) --} - -{- --- | Convert a note to a score. -noteToScore :: Note a -> Score a -noteToScore (view (from note) -> (s,x)) = s `transform` return x --} - --- scoreToNotes :: Score a -> [Note a] --- scoreToNotes = Foldable.toList . reifyScore - --- notesToScore :: [Note a] -> Score a --- notesToScore = pcat . fmap noteToScore - -{- -reactiveToVoice :: Duration -> Reactive a -> Voice a -reactiveToVoice d r = (^. voice) $ fmap (^. stretched) $ durs `zip` (fmap (r `atTime`) times) - where - times = 0 : filter (\t -> 0 < t && t < 0 .+^ d) (occs r) - durs = toRelativeTimeN' (0 .+^ d) times --} - -reactiveToVoice' :: Span -> Reactive a -> Voice a -reactiveToVoice' (view range -> (u,v)) r = (^. voice) $ fmap (^. stretched) $ durs `zip` (fmap (r `atTime`) times) - where - times = 0 : filter (\t -> u < t && t < v) (occs r) - durs = toRelativeTimeN' v times -{-# DEPRECATED reactiveToVoice' "" #-} - --- | --- Convert a score to a voice. Fails if the score contain overlapping events. --- -scoreToVoice :: Transformable a => Score a -> Voice (Maybe a) -scoreToVoice = (^. voice) . fmap (^. stretched) . fmap throwTime . addRests . (^. events) - where - throwTime (t,d,x) = (d,x) - addRests = concat . snd . mapAccumL g 0 - where - g u (t, d, x) - | u == t = (t .+^ d, [(t, d, Just x)]) - | u < t = (t .+^ d, [(u, t .-. u, Nothing), (t, d, Just x)]) - | otherwise = error "scoreToVoice: Strange prevTime" -{-# DEPRECATED scoreToVoice "" #-} - --- | --- Convert a voice to a score. --- -voiceToScore :: Voice a -> Score a -voiceToScore = scat . fmap g . (^. stretcheds) where g = (^. stretchedValue) . fmap return -{-# DEPRECATED voiceToScore "" #-} - -{- --- | Join voices in a given part into a score. -voicesToScore :: HasPart a => [(Part a, Voice a)] -> Score a -voicesToScore = pcat . fmap (voiceToScore . uncurry (\n -> fmap (setPart n))) --} - --- | --- Convert a voice which may contain rests to a score. --- -voiceToScore' :: Voice (Maybe a) -> Score a -voiceToScore' = mcatMaybes . voiceToScore -{-# DEPRECATED voiceToScore' "" #-} - -{- --- | --- Convert a track to a score where each event is given a fixed duration. --- -trackToScore :: Transformable a => Duration -> Track a -> Score a -trackToScore x = trackToScore' (const x) - --- | --- Convert a track to a score, using durations determined by the values. --- -trackToScore' :: Transformable a => (a -> Duration) -> Track a -> Score a -trackToScore' f = (^. from events) . fmap (\(t,x) -> (t,f x,x)) . map (^. from delayed) . (^. delayeds) --} - - --- TODO rename during -noteToReactive :: Monoid a => Note a -> Reactive a -noteToReactive n = (pure <$> n) `activate` pure mempty - --- JUNK - --- | Split a reactive into mkNotes, as well as the values before and after the first/last update -splitReactive :: Reactive a -> Either a ((a, Time), [Note a], (Time, a)) -splitReactive r = case updates r of - [] -> Left (initial r) - (t,x):[] -> Right ((initial r, t), [], (t, x)) - (t,x):xs -> Right ((initial r, t), fmap mkNote $ mrights (res $ (t,x):xs), head $ mlefts (res $ (t,x):xs)) - - where - - mkNote (t,u,x) = (t <-> u, x)^.note - - -- Always returns a 0 or more Right followed by one left - res :: [(Time, a)] -> [Either (Time, a) (Time, Time, a)] - res rs = let (ts,xs) = unzip rs in - flip fmap (withNext ts `zip` xs) $ - \ ((t, mu), x) -> case mu of - Nothing -> Left (t, x) - Just u -> Right (t, u, x) - - -- lenght xs == length (withNext xs) - withNext :: [a] -> [(a, Maybe a)] - withNext = go - where - go [] = [] - go [x] = [(x, Nothing)] - go (x:y:rs) = (x, Just y) : withNext (y : rs) - -activate :: Note (Reactive a) -> Reactive a -> Reactive a -activate (view (from note) -> (view range -> (start,stop), x)) y = y `turnOn` (x `turnOff` y) - where - turnOn = switchR start - turnOff = switchR stop - 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 @@ -61,8 +61,6 @@ DynamicT(..), -- * Context - -- TODO move - Ctxt, vdynamic, addDynCon, @@ -91,7 +89,6 @@ import Music.Score.Slide import Music.Score.Text import Music.Score.Ties -import Music.Score.Tremolo import Music.Score.Internal.Util (through) import Music.Time import Music.Time.Internal.Transform @@ -266,8 +263,6 @@ type instance Dynamic (Couple c a) = Dynamic a type instance SetDynamic g (Couple c a) = Couple c (SetDynamic g a) -type instance Dynamic (TremoloT a) = Dynamic a -type instance SetDynamic g (TremoloT a) = TremoloT (SetDynamic g a) type instance Dynamic (TextT a) = Dynamic a type instance SetDynamic g (TextT a) = TextT (SetDynamic g a) type instance Dynamic (HarmonicT a) = Dynamic a @@ -285,13 +280,7 @@ dynamic = _Wrapped . dynamic -instance (HasDynamics a b) => HasDynamics (TremoloT a) (TremoloT b) where - dynamics = _Wrapped . dynamics -instance (HasDynamic a b) => HasDynamic (TremoloT a) (TremoloT b) where - dynamic = _Wrapped . dynamic - - instance (HasDynamics a b) => HasDynamics (TextT a) (TextT b) where dynamics = _Wrapped . dynamics @@ -376,7 +365,7 @@ HasPosition a, HasDynamics a a, Dynamic a ~ Behavior c, Fractional c ) => Duration -> a -> a -fadeIn d x = x & dynamics *~ (_onset x >-> d `transform` unit) +fadeIn d x = x & dynamics *~ ((_onset x >-> d) `transform` unit) -- | -- Fade in. @@ -385,7 +374,7 @@ HasPosition a, HasDynamics a a, Dynamic a ~ Behavior c, Fractional c ) => Duration -> a -> a -fadeOut d x = x & dynamics *~ (d <-< _offset x `transform` rev unit) +fadeOut d x = x & dynamics *~ ((d <-< _offset x) `transform` rev unit) @@ -437,7 +426,6 @@ -- rem = liftA2 rem -- toInteger = toInteger . extract --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (DynamicT p a) where type Unwrapped (DynamicT p a) = (p, a) _Wrapped' = iso getDynamicT DynamicT 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 @@ -52,23 +52,22 @@ import qualified Data.Foldable import Data.Functor.Couple import Data.Maybe +import Data.Monoid.Average import Data.Ratio import Data.Traversable (Traversable, sequenceA) import qualified Music.Lilypond as Lilypond import qualified Music.MusicXml.Simple as MusicXml import Music.Score.Internal.Export hiding (MVoice) -import Music.Time.Internal.Transform (whilstLD) import System.Process import Music.Time.Internal.Quantize import qualified Text.Pretty as Pretty import qualified Data.List -import Music.Score.Convert (reactiveToVoice') -- TODO import Music.Score.Internal.Util (composed, unRatio, swap, retainUpdates) import Music.Score.Export.DynamicNotation import Music.Score.Export.ArticulationNotation import Data.Semigroup import Data.Semigroup.Instances - +import Data.Functor.Context import Music.Time import Music.Score.Dynamics @@ -106,7 +105,8 @@ Articulation b ~ Ctxt (Articulation a), Articulation c ~ ArticulationNotation, -- TODO generalize - Articulation a ~ (Sum Double, Sum Double) + -- Articulated (Articulation a), Real (Separation (Articulation a)), Real (Accentuation (Articulation a)) + Articulation a ~ (Average Double, Average Double) ) @@ -214,7 +214,5 @@ -- Backend developers are encouraged to provide wrappers on the form 'toX', 'writeX' etc. -- export :: (HasBackendScore b s, HasBackendNote b (BackendScoreEvent b s)) => b -> s -> BackendMusic b -export b = finalizeExport b . export' - where - export' = fmap (exportNote b) . exportScore b +export b = finalizeExport b . fmap (exportNote b) . exportScore b 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 @@ -34,13 +34,19 @@ CrescDim(..), DynamicNotation(..), notateDynamic, + + -- * Utility + removeCloseDynMarks, + removeDynMark, ) where import Data.Semigroup import Data.Functor.Context +import Data.AffineSpace import Control.Lens -- () import Music.Score.Dynamics import Music.Score.Ties +import Music.Score.Phrases import Music.Time @@ -102,9 +108,17 @@ (EQ,EQ) -> ([], False) (LT,GT) -> ([EndCresc, BeginDim], True) (GT,LT) -> ([EndDim, BeginCresc], True) - - (Just x, y, Nothing) -> case (x `compare` y) of LT -> ([EndCresc], True) EQ -> ([], False) GT -> ([EndDim], True) + + +removeCloseDynMarks :: (HasPhrases' s a, HasDynamics' a, Dynamic a ~ DynamicNotation, a ~ SetDynamic (Dynamic a) a) => s -> s +removeCloseDynMarks = mapPhrasesWithPrevAndCurrentOnset f + where + f Nothing t = id + f (Just t1) t2 = if (t2 .-. t1) > 1.5 then id else over (_head.mapped) removeDynMark + +removeDynMark :: (HasDynamics' a, Dynamic a ~ DynamicNotation, a ~ SetDynamic (Dynamic a) a) => a -> a +removeDynMark x = set (dynamics' . _Wrapped' . _2) Nothing x 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,4 +1,5 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveFoldable #-} @@ -74,9 +75,7 @@ import System.Process import qualified Text.Pretty as Pretty - import Music.Dynamics.Literal -import qualified Music.Lilypond as Lilypond import Music.Pitch.Literal import Music.Score.Articulation import Music.Score.Color @@ -101,6 +100,7 @@ import Music.Time import Music.Time.Internal.Quantize +import qualified Music.Lilypond as Lilypond @@ -108,6 +108,12 @@ +#define COMPLEX_POLY_STUFF 1 + + + + + -- | -- Extract instrument info as per "Music.Part" -- This is really crude, needs rethinking! @@ -156,9 +162,9 @@ {- TODO move -instance Monoid Lilypond.Music where - mempty = pcatLy [] - mappend x y = pcatLy [x,y] +instance Monoid LyMusic where + mempty = pcatL [] + mappend x y = pcatL [x,y] -} type LyMusic = Lilypond.Music @@ -171,8 +177,8 @@ finalizeExport _ = finalizeScore where - finalizeScore :: LyScore LyMusic -> Lilypond.Music - finalizeScore (LyScore (info, x)) = pcatLy . map finalizeStaff $ x + finalizeScore :: LyScore LyMusic -> LyMusic + finalizeScore (LyScore (info, x)) = pcatL . map finalizeStaff $ x -- TODO finalizeStaffGroup @@ -181,11 +187,11 @@ = addStaff . addPartName (staffName info) . addClef (staffClef info) - . scatLy . map finalizeBar $ x + . scatL . map finalizeBar $ x where addStaff = Lilypond.New "Staff" Nothing - addClef c x = scatLy [Lilypond.Clef c, x] - addPartName partName xs = scatLy [longName, shortName, xs] + addClef c x = scatL [Lilypond.Clef c, x] + addPartName partName xs = scatL [longName, shortName, xs] where longName = Lilypond.Set "Staff.instrumentName" (Lilypond.toValue partName) shortName = Lilypond.Set "Staff.shortInstrumentName" (Lilypond.toValue partName) @@ -200,18 +206,19 @@ -- TODO rehearsal marks -- TODO bar number change -- TODO compound time signatures - setTimeSignature (getTimeSignature -> (ms, n)) x = scatLy [Lilypond.Time (sum ms) n, x] + setTimeSignature (getTimeSignature -> (ms, n)) x = scatL [Lilypond.Time (sum ms) n, x] renderBarMusic :: Rhythm LyMusic -> LyMusic renderBarMusic = go where go (Beat d x) = Lilypond.removeSingleChords x go (Dotted n (Beat d x)) = Lilypond.removeSingleChords x - go (Group rs) = scatLy $ map renderBarMusic rs + go (Group rs) = scatL $ map renderBarMusic rs go (Tuplet m r) = Lilypond.Times (realToFrac m) (renderBarMusic r) where (a,b) = bimap fromIntegral fromIntegral $ unRatio $ realToFrac m +#ifdef COMPLEX_POLY_STUFF instance ( HasDynamicNotation a b c, HasArticulationNotation c d e, @@ -219,24 +226,46 @@ HasOrdPart a, Transformable a, Semigroup a, - Tiable e, - HasOrdPart c, Show (Part c), HasLilypondInstrument (Part c) + Tiable e, HasOrdPart c, Show (Part c), + HasLilypondInstrument (Part c), + Satisfied ) => HasBackendScore Lilypond (Score a) where +#else +instance ( + Tiable a, HasOrdPart a, Show (Part a), + HasLilypondInstrument (Part a), + Satisfied + ) + => HasBackendScore Lilypond (Score a) where +#endif + +#ifdef COMPLEX_POLY_STUFF type BackendScoreEvent Lilypond (Score a) = SetArticulation ArticulationNotation (SetDynamic DynamicNotation a) +#else + type BackendScoreEvent Lilypond (Score a) = a +#endif + exportScore b score = LyScore . (ScoreInfo,) + -- Store time signatures etc for later use by finalizeScore . map (uncurry $ exportPart timeSignatureMarks barDurations) +#ifdef COMPLEX_POLY_STUFF + -- Notate articulation . map (second $ over articulations notateArticulation) . map (second $ preserveMeta addArtCon) + -- Notate dynamics . map (second $ removeCloseDynMarks) . map (second $ over dynamics notateDynamic) . map (second $ preserveMeta addDynCon) + -- Merge simultaneous chords . map (second $ preserveMeta simultaneous) - . extractParts' +#endif + + . extractPartsWithInfo $ normScore where (timeSignatureMarks, barDurations) = extractTimeSignatures normScore @@ -329,10 +358,10 @@ instance HasBackendNote Lilypond Integer where -- TODO can we get rid of exportChord alltogether and just use LyContext? exportNote _ (LyContext d Nothing) = (^*realToFrac (4*d)) Lilypond.rest - exportNote _ (LyContext d (Just x)) = (^*realToFrac (4*d)) $ Lilypond.note $ spellLy x + exportNote _ (LyContext d (Just x)) = (^*realToFrac (4*d)) $ Lilypond.note $ spellL x exportChord _ (LyContext d Nothing) = (^*realToFrac (4*d)) Lilypond.rest - exportChord _ (LyContext d (Just xs)) = (^*realToFrac (4*d)) $ Lilypond.chord $ fmap spellLy xs + exportChord _ (LyContext d (Just xs)) = (^*realToFrac (4*d)) $ Lilypond.chord $ fmap spellL xs instance HasBackendNote Lilypond Int where exportNote b = exportNote b . fmap toInteger @@ -364,6 +393,8 @@ exportNote b = exportNote b . fmap extract exportChord b = exportChord b . fmap (fmap extract) + +#ifdef COMPLEX_POLY_STUFF instance HasBackendNote Lilypond a => HasBackendNote Lilypond (DynamicT DynamicNotation a) where exportNote b = uncurry notate . getDynamicT . fmap (exportNote b) . sequenceA where @@ -389,7 +420,12 @@ -- Use rcomposed as notateDynamic returns "mark" order, not application order rcomposed = composed . reverse +#else +instance HasBackendNote Lilypond a => HasBackendNote Lilypond (DynamicT b a) where + exportNote b = exportNote b . fmap extract +#endif +#ifdef COMPLEX_POLY_STUFF instance HasBackendNote Lilypond a => HasBackendNote Lilypond (ArticulationT ArticulationNotation a) where exportNote b = uncurry notate . getArticulationT . fmap (exportNote b) . sequenceA where @@ -413,6 +449,10 @@ -- Use rcomposed as notateDynamic returns "mark" order, not application order rcomposed = composed . reverse +#else +instance HasBackendNote Lilypond a => HasBackendNote Lilypond (ArticulationT {-ArticulationNotation-}b a) where + exportNote b = exportNote b . fmap extract +#endif instance HasBackendNote Lilypond a => HasBackendNote Lilypond (ColorT a) where exportNote b = uncurry notate . getCouple . getColorT . fmap (exportNote b) . sequenceA @@ -436,44 +476,26 @@ instance HasBackendNote Lilypond a => HasBackendNote Lilypond (TremoloT a) where -- TODO can this instance use the new shorter idiom? exportNote b (LyContext d x) = - fst (notate x d) $ exportNote b $ LyContext (snd $ notate x d) (fmap extract x) - where - notate Nothing d = (id, d) - notate (Just (TremoloT (Couple (Max 0, _)))) d = (id, d) - notate (Just (TremoloT (Couple (Max n, _)))) d = let - scale = 2^n - newDur = (d `min` (1/4)) / scale - repeats = d / newDur - in (Lilypond.Tremolo (round repeats), newDur) + fst (notateTremolo x d) $ exportNote b $ LyContext (snd $ notateTremolo x d) (fmap extract x) + instance HasBackendNote Lilypond a => HasBackendNote Lilypond (TextT a) where - exportNote b = uncurry notate . getCouple . getTextT . fmap (exportNote b) . sequenceA + exportNote b = uncurry notateText . getCouple . getTextT . fmap (exportNote b) . sequenceA where - notate texts = composed (fmap Lilypond.addText texts) + instance HasBackendNote Lilypond a => HasBackendNote Lilypond (HarmonicT a) where - exportNote b = uncurry notate . getCouple . getHarmonicT . fmap (exportNote b) . sequenceA - where - notate (Any isNat, Sum n) = case (isNat, n) of - (_, 0) -> id - (True, n) -> notateNatural n - (False, n) -> notateArtificial n - notateNatural n = Lilypond.addFlageolet -- addOpen? - notateArtificial n = id -- TODO + exportNote b = uncurry notateHarmonic . getCouple . getHarmonicT . fmap (exportNote b) . sequenceA instance HasBackendNote Lilypond a => HasBackendNote Lilypond (SlideT a) where exportNote b = uncurry notateGliss . getCouple . getSlideT . fmap (exportNote b) . sequenceA exportChord b = uncurry notateGliss . getCouple . getSlideT . fmap (exportChord b) . sequenceA . fmap sequenceA -notateGliss ((Any eg, Any es),(Any bg, Any bs)) - | bg = Lilypond.beginGlissando - | bs = Lilypond.beginGlissando - | otherwise = id {- exportNote :: b -> BC a -> BN exportChord :: b -> BC [a] -> BN - uncurry notateTie :: ((Any, Any), Lilypond.Music) -> Lilypond.Music + uncurry notateTie :: ((Any, Any), LyMusic) -> LyMusic BC (TieT a) sequenceA TieT (BC a) fmap (exportNote b) @@ -490,6 +512,35 @@ exportNote b = uncurry notateTie . getTieT . fmap (exportNote b) . sequenceA exportChord b = uncurry notateTie . getTieT . fmap (exportChord b) . sequenceA . fmap sequenceA + +notateTremolo :: RealFrac b => Maybe (TremoloT a) -> b -> (LyMusic -> LyMusic, b) +notateTremolo Nothing d = (id, d) +notateTremolo (Just (runTremoloT -> (0, _))) d = (id, d) +notateTremolo (Just (runTremoloT -> (n, _))) d = let + scale = 2^n + newDur = (d `min` (1/4)) / scale + repeats = d / newDur + in (Lilypond.Tremolo (round repeats), newDur) + +notateText :: [String] -> LyMusic -> LyMusic +notateText texts = composed (fmap Lilypond.addText texts) + +notateHarmonic :: (Eq t, Num t) => (Any, Sum t) -> LyMusic -> LyMusic +notateHarmonic (Any isNat, Sum n) = case (isNat, n) of + (_, 0) -> id + (True, n) -> notateNatural n + (False, n) -> notateArtificial n + where + notateNatural n = Lilypond.addFlageolet -- addOpen? + notateArtificial n = id -- TODO + +notateGliss :: ((Any, Any), (Any, Any)) -> LyMusic -> LyMusic +notateGliss ((Any eg, Any es),(Any bg, Any bs)) + | bg = Lilypond.beginGlissando + | bs = Lilypond.beginGlissando + | otherwise = id + +notateTie :: (Any, Any) -> LyMusic -> LyMusic notateTie (Any ta, Any tb) | ta && tb = Lilypond.beginTie | tb = Lilypond.beginTie @@ -502,17 +553,16 @@ type HasLilypond a = (HasBackendNote Lilypond (BackendScoreEvent Lilypond a), HasBackendScore Lilypond a) -- | --- Convert a score to a Lilypond string. --- -toLilypondString :: HasLilypond a => a -> String -toLilypondString = show . Pretty.pretty . toLilypond - --- | -- Convert a score to a Lilypond representation. -- -toLilypond :: HasLilypond a => a -> Lilypond.Music +toLilypond :: HasLilypond a => a -> LyMusic toLilypond = export (undefined::Lilypond) +-- | +-- Convert a score to a Lilypond string. +-- +toLilypondString :: HasLilypond a => a -> String +toLilypondString = show . Pretty.pretty . toLilypond -- | -- Convert a score to a Lilypond representaiton and print it on the standard output. @@ -600,7 +650,8 @@ runLilypond >> cleanLilypond >> runOpen where runLilypond = void $ runCommand - "lilypond -f pdf test.ly" >>= waitForProcess + -- "lilypond -f pdf test.ly" >>= waitForProcess + "lilypond -f pdf test.ly 2>/dev/null" >>= waitForProcess cleanLilypond = void $ runCommand "rm -f test-*.tex test-*.texi test-*.count test-*.eps test-*.pdf test.eps" runOpen = void $ runCommand @@ -633,123 +684,38 @@ --- TODO move -addArtCon :: ( - HasPhrases s t a b, HasArticulation a a, HasArticulation a b, - Articulation a ~ d, Articulation b ~ Ctxt d - ) => s -> t -addArtCon = over (phrases.varticulation) withContext -varticulation = lens (fmap $ view articulation) (flip $ zipVoiceWithNoScale (set articulation)) -removeCloseDynMarks :: (HasPhrases' s a, HasDynamics' a, Dynamic a ~ DynamicNotation, a ~ SetDynamic (Dynamic a) a) => s -> s -removeCloseDynMarks = mapPhrasesWithPrevAndCurrentOnset f - where - f Nothing t = id - f (Just t1) t2 = if (t2 .-. t1) > 1.5 then id else over (_head.mapped) removeDynMark -removeDynMark :: (HasDynamics' a, Dynamic a ~ DynamicNotation, a ~ SetDynamic (Dynamic a) a) => a -> a -removeDynMark x = set (dynamics' . _Wrapped' . _2) Nothing x --- type PVoice a = [Either Duration (Phrase a)] -type TVoice a = Track (Phrase a) --- foo :: HasPhrases' s a => s -> [TVoice a] -mapPhrasesWithPrevAndCurrentOnset :: HasPhrases s t a b => (Maybe Time -> Time -> Phrase a -> Phrase b) -> s -> t -mapPhrasesWithPrevAndCurrentOnset f = over (mvoices . mVoiceTVoice) (withPrevAndCurrentOnset f) -withPrevAndCurrentOnset :: (Maybe Time -> Time -> a -> b) -> Track a -> Track b -withPrevAndCurrentOnset f = over delayeds (fmap (\(x,y,z) -> fmap (f (fmap _onset x) (_onset y)) y) . withPrevNext) - -mVoiceTVoice :: Lens (MVoice a) (MVoice b) (TVoice a) (TVoice b) -mVoiceTVoice = mvoicePVoice . pVoiceTVoice - -pVoiceTVoice :: Lens (PVoice a) (PVoice b) (TVoice a) (TVoice b) -pVoiceTVoice = lens pVoiceToTVoice (flip tVoiceToPVoice) - where - pVoiceToTVoice :: PVoice a -> TVoice a - pVoiceToTVoice x = mkTrack $ rights $ map (sequenceA) $ mapZip (offsetPoints (0::Time)) (withDurationR x) - - -- TODO assert no overlapping - tVoiceToPVoice :: TVoice a -> PVoice b -> PVoice a - tVoiceToPVoice tv pv = set _rights newPhrases pv - where - newPhrases = toListOf traverse tv - - -_rights :: Lens [Either a b] [Either a c] [b] [c] -_rights = lens _rightsGet (flip _rightsSet) - -_rightsGet :: [Either a b] -> [b] -_rightsGet = rights - -_rightsSet :: [c] -> [Either a b] -> [Either a c] -_rightsSet cs = sndMapAccumL f cs - where - f cs (Left a) = (cs, Left a) - f (c:cs) (Right b) = (cs, Right c) - f [] (Right _) = error "No more cs" - -sndMapAccumL f z = snd . Data.List.mapAccumL f z - --- unsafePVoiceTVoice :: Iso (PVoice a) (PVoice b) (TVoice a) (TVoice b) --- unsafePVoiceTVoice = iso pVoiceToTVoice tVoiceToPVoice --- where --- pVoiceToTVoice :: PVoice a -> TVoice a --- pVoiceToTVoice x = mkTrack $ rights $ map (sequenceA) $ mapZip (offsetPoints (0::Time)) (withDurationR x) --- --- -- TODO assert no overlapping --- tVoiceToPVoice :: TVoice a -> PVoice a --- tVoiceToPVoice = undefined - - -mapZip :: ([a] -> [b]) -> [(a,c)] -> [(b,c)] -mapZip f = uncurry zip . first f . unzipR - -mkTrack :: [(Time, a)] -> Track a -mkTrack = view track . map (view delayed) - -withDurationR :: (Functor f, HasDuration a) => f a -> f (Duration, a) -withDurationR = fmap $ \x -> (_duration x, x) - --- TODO generalize and move -mapWithDuration :: HasDuration a => (Duration -> a -> b) -> a -> b -mapWithDuration = over dual withDurationL . uncurry - where - withDurationL :: (Contravariant f, HasDuration a) => f (Duration, a) -> f a - withDurationL = contramap $ \x -> (_duration x, x) - - dual :: Iso (a -> b) (c -> d) (Op b a) (Op d c) - dual = iso Op getOp - -dursToVoice :: [Duration] -> Voice () -dursToVoice = mconcat . map (\d -> stretch d $ return ()) - --- *Music.Score.Export.Lilypond> print $ view (mVoiceTVoice) $ (fmap Just (dursToVoice [1,2,1]) <> return Nothing <> return (Just ())) --- TODO This function is a workaround --- Whenever it is used, we should make the original function preserve meta instead -preserveMeta :: (HasMeta a, HasMeta b) => (a -> b) -> a -> b -preserveMeta f x = let m = view meta x in set meta m (f x) - -pcatLy :: [Lilypond.Music] -> Lilypond.Music -pcatLy = pcatLy' False +pcatL :: [LyMusic] -> LyMusic +pcatL = pcatL' False -pcatLy' :: Bool -> [Lilypond.Music] -> Lilypond.Music -pcatLy' p = foldr Lilypond.simultaneous (Lilypond.Simultaneous p []) +pcatL' :: Bool -> [LyMusic] -> LyMusic +pcatL' p = foldr Lilypond.simultaneous (Lilypond.Simultaneous p []) -scatLy :: [Lilypond.Music] -> Lilypond.Music -scatLy = foldr Lilypond.sequential (Lilypond.Sequential []) +scatL :: [LyMusic] -> LyMusic +scatL = foldr Lilypond.sequential (Lilypond.Sequential []) -spellLy :: Integer -> Lilypond.Note -spellLy a = Lilypond.NotePitch (spellLy' a) Nothing +spellL :: Integer -> Lilypond.Note +spellL a = Lilypond.NotePitch (spellL' a) Nothing -spellLy' :: Integer -> Lilypond.Pitch -spellLy' p = Lilypond.Pitch ( +spellL' :: Integer -> Lilypond.Pitch +spellL' p = Lilypond.Pitch ( toEnum $ fromIntegral pc, fromIntegral alt, fromIntegral oct ) where (pc,alt,oct) = spellPitch (p + 72) + +-- | A constraint that is always satisfied. +type Satisfied = (() ~ ()) + +-- | A constraint that is never satisfied. +type Unsatisfied = (() ~ Bool) + 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 @@ -1,3 +1,4 @@ + {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ConstraintKinds #-} @@ -54,12 +55,10 @@ import qualified Music.Lilypond as Lilypond import qualified Music.MusicXml.Simple as MusicXml import Music.Score.Internal.Export hiding (MVoice) -import Music.Time.Internal.Transform (whilstLD) import System.Process import Music.Time.Internal.Quantize import qualified Text.Pretty as Pretty import qualified Data.List -import Music.Score.Convert (reactiveToVoice') -- TODO import Music.Score.Internal.Util (composed, unRatio, swap, retainUpdates) import Music.Score.Export.DynamicNotation import Data.Semigroup.Instances @@ -190,7 +189,7 @@ instance (HasPart' a, Ord (Part a), HasMidiProgram (Part a)) => HasBackendScore Midi (Score a) where type BackendScoreEvent Midi (Score a) = a - exportScore _ xs = MidiScore (map (\(p,sc) -> ((getMidiChannel p, getMidiProgram p), fmap Identity sc)) $ extractParts' $ fixTempo xs) + exportScore _ xs = MidiScore (map (\(p,sc) -> ((getMidiChannel p, getMidiProgram p), fmap Identity sc)) $ extractPartsWithInfo $ fixTempo xs) where -- We actually want to extract *all* tempo changes and transform the score appropriately -- For the time being, we assume the whole score has the same tempo @@ -218,11 +217,11 @@ exportChord b = exportChord b . fmap (fmap (! 0)) -instance HasBackendNote Midi a => HasBackendNote Midi (DynamicT (Sum Double) a) where +instance (Real d, HasBackendNote Midi a) => HasBackendNote Midi (DynamicT d a) where -- TODO -- We have not standarized dynamic levels -- Assume for now -6.5 to 6.5 where (-3.5 is ppp, -0.5 is mp, 0.5 is mf, 3.5 is fff etc) - exportNote b (Identity (DynamicT (Sum d, x))) = setV (dynLevel d) <$> exportNote b (Identity x) + exportNote b (Identity (DynamicT (realToFrac -> d, x))) = setV (dynLevel d) <$> exportNote b (Identity x) dynLevel :: Double -> Midi.Velocity 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 @@ -1,20 +1,20 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} ------------------------------------------------------------------------------------- -- | @@ -34,75 +34,74 @@ MusicXml, XmlContext(..), HasMusicXml, - + -- ** Converting to MusicXml toMusicXml, - toMusicXmlString, - + toMusicXmlString, + -- ** MusicXml I/O showMusicXml, openMusicXml, writeMusicXml, ) where -import Music.Dynamics.Literal -import Music.Pitch.Literal -import qualified Codec.Midi as Midi -import Control.Comonad (Comonad (..), extract) +import qualified Codec.Midi as Midi import Control.Applicative +import Control.Comonad (Comonad (..), extract) +import Control.Lens hiding (rewrite) +import Control.Monad +import Data.AffineSpace import Data.Bifunctor -import Data.Colour.Names as Color +import Data.Colour.Names as Color import Data.Default -import Data.Foldable (Foldable) +import Data.Foldable (Foldable) import qualified Data.Foldable import Data.Functor.Couple +import Data.Functor.Identity +import qualified Data.List import Data.Maybe import Data.Ratio -import Data.Traversable (Traversable, sequenceA) -import qualified Music.Lilypond as Lilypond -import qualified Music.MusicXml.Simple as MusicXml -import Music.Score.Internal.Export hiding (MVoice) -import Music.Time.Internal.Transform (whilstLD) +import Data.Semigroup +import Data.Semigroup.Instances +import Data.Traversable (Traversable, + sequenceA) +import Data.VectorSpace hiding (Sum (..)) import System.Process -import Music.Time.Internal.Quantize -import qualified Text.Pretty as Pretty -import qualified Data.List -import Music.Score.Convert (reactiveToVoice') -- TODO -import Music.Score.Internal.Util (composed, unRatio, swap, retainUpdates) -import Music.Score.Export.DynamicNotation -import Music.Score.Export.ArticulationNotation -import Data.Semigroup.Instances -import Music.Score.Export.Backend -import Data.Functor.Identity -import Data.Semigroup -import Control.Monad -import Data.VectorSpace hiding (Sum(..)) -import Data.AffineSpace -import Control.Lens hiding (rewrite) --- import Control.Lens.Operators hiding ((|>)) +import Music.Dynamics.Literal +import Music.Pitch.Literal +import Music.Score.Articulation +import Music.Score.Color +import Music.Time.Internal.Convert (reactiveToVoice') +import Music.Score.Dynamics +import Music.Score.Export.ArticulationNotation +import Music.Score.Export.Backend +import Music.Score.Export.DynamicNotation +import Music.Score.Harmonics +import Music.Score.Internal.Export hiding (MVoice) +import Music.Score.Internal.Util (composed, + retainUpdates, swap, + unRatio) +import Music.Score.Meta +import Music.Score.Meta.Attribution +import Music.Score.Meta.Tempo +import Music.Score.Meta.Time +import Music.Score.Meta.Title +import Music.Score.Part +import Music.Score.Phrases +import Music.Score.Slide +import Music.Score.Text +import Music.Score.Ties +import Music.Score.Tremolo +import Music.Time +import Music.Time.Internal.Quantize -import Music.Time -import Music.Score.Meta -import Music.Score.Meta.Title -import Music.Score.Meta.Attribution -import Music.Score.Dynamics -import Music.Score.Articulation -import Music.Score.Part -import Music.Score.Tremolo -import Music.Score.Text -import Music.Score.Harmonics -import Music.Score.Slide -import Music.Score.Color -import Music.Score.Ties -import Music.Score.Export.Backend -import Music.Score.Meta.Time -import Music.Score.Meta.Tempo -import Music.Score.Phrases +import qualified Text.Pretty as Pretty +import qualified Music.MusicXml.Simple as MusicXml --- | +-- | -- Extract instrument info as per "Music.Part" -- This is really crude, needs rethinking! -- @@ -112,7 +111,7 @@ --- TODO move +-- TODO move deriving instance Show MusicXml.Line deriving instance Show MusicXml.ClefSign -- deriving instance Eq MusicXml.PartList @@ -129,7 +128,7 @@ -- | A token to represent the MusicXml backend. data MusicXml -data ScoreInfo = ScoreInfo { scoreTitle :: String, +data ScoreInfo = ScoreInfo { scoreTitle :: String, scoreComposer :: String, scorePartList :: MusicXml.PartList, scoreTempo :: Tempo @@ -137,10 +136,10 @@ deriving (Eq, Show) -data StaffInfo = StaffInfo { staffClef :: (MusicXml.ClefSign, MusicXml.Line) } +data StaffInfo = StaffInfo { staffClef :: (MusicXml.ClefSign, MusicXml.Line) } deriving (Eq, Show) -data BarInfo = BarInfo { x_barTimeSignature :: Maybe TimeSignature } +data BarInfo = BarInfo { x_barTimeSignature :: Maybe TimeSignature } deriving (Eq, Show) -- | Hierachical representation of a MusicXml score. @@ -153,7 +152,7 @@ deriving (Functor, Eq, Show) -- | A bar is a sequential composition of chords/notes/rests. -data XmlBar a = XmlBar { getXmlBar :: (BarInfo, Rhythm a) } +data XmlBar a = XmlBar { getXmlBar :: (BarInfo, Rhythm a) } deriving (Functor, Eq, Show) -- | Context passed to the note export. @@ -175,8 +174,8 @@ where finalizeScore :: XmlScore MusicXml.Music -> MusicXml.Score -finalizeScore (XmlScore (info, x)) - = MusicXml.fromParts title composer partList +finalizeScore (XmlScore (info, x)) + = MusicXml.fromParts title composer partList . map (finalizeStaff tempo) $ x where title = scoreTitle info @@ -187,8 +186,8 @@ -- TODO finalizeStaffGroup finalizeStaff :: Tempo -> XmlStaff MusicXml.Music -> [MusicXml.Music] -finalizeStaff tempo (XmlStaff (info, x)) - = id +finalizeStaff tempo (XmlStaff (info, x)) + = id -- Staff name is not added here as MusicXML uses a separate part list . addStartInfo . addClef (staffClef info) @@ -218,15 +217,15 @@ finalizeBar :: XmlBar MusicXml.Music -> MusicXml.Music finalizeBar (XmlBar (BarInfo timeSignature, x)) - = maybe id setBarTimeSignature timeSignature + = maybe id setBarTimeSignature timeSignature . renderBarMusic $ x where -- TODO key signatures -- TODO rehearsal marks -- TODO bar number change -- TODO compound time signatures - setBarTimeSignature (getTimeSignature -> (ms, n)) x = mconcat [MusicXml.time (fromIntegral $ sum ms) (fromIntegral n), x] - + setBarTimeSignature (getTimeSignature -> (ms, n)) x = mconcat [MusicXml.time (fromIntegral $ sum ms) (fromIntegral n), x] + renderBarMusic :: Rhythm MusicXml.Music -> MusicXml.Music renderBarMusic = go where @@ -248,13 +247,13 @@ ) => HasBackendScore MusicXml (Score a) where type BackendScoreEvent MusicXml (Score a) = SetDynamic DynamicNotation a - exportScore b score = XmlScore + exportScore b score = XmlScore . (ScoreInfo title composer partList tempo,) . map (uncurry $ exportPart timeSignatureMarks barDurations) - . map (second (over dynamics notateDynamic)) + . map (second (over dynamics notateDynamic)) . map (second (preserveMeta addDynCon)) - . map (second (preserveMeta simultaneous)) - . extractParts' + . map (second (preserveMeta simultaneous)) + . extractPartsWithInfo . normalizeScore $ score where @@ -262,46 +261,46 @@ composer = fromMaybe "" $ flip getAttribution "composer" $ metaAtStart score partList = MusicXml.partList (fmap show $ allParts score) tempo = (metaAtStart score :: Tempo) - (timeSignatureMarks, barDurations) = extractTimeSignatures score + (timeSignatureMarks, barDurations) = extractTimeSignatures score -- | Export a score as a single part. Overlapping notes will cause an error. exportPart :: ( Tiable a, HasMusicXmlInstrument (Part a) - ) - => [Maybe TimeSignature] - -> [Duration] - -> Part a - -> Score a + ) + => [Maybe TimeSignature] + -> [Duration] + -> Part a + -> Score a -> XmlStaff (XmlContext a) - exportStaff :: Tiable a - => [Maybe TimeSignature] - -> [Duration] + exportStaff :: Tiable a + => [Maybe TimeSignature] + -> [Duration] -> Int -- ^ clef, as per Music.Parts - -> MVoice a + -> MVoice a -> XmlStaff (XmlContext a) - exportBar :: Tiable a - => Maybe TimeSignature - -> MVoice a + exportBar :: Tiable a + => Maybe TimeSignature + -> MVoice a -> XmlBar (XmlContext a) - quantizeBar :: Tiable a - => MVoice a + quantizeBar :: Tiable a + => MVoice a -> Rhythm (XmlContext a) exportPart timeSignatureMarks barDurations part = exportStaff timeSignatureMarks barDurations (getMusicXmlClef part) . view singleMVoice - exportStaff timeSignatures barDurations clefId - = XmlStaff + exportStaff timeSignatures barDurations clefId + = XmlStaff . addStaffInfo - . zipWith exportBar timeSignatures + . zipWith exportBar timeSignatures . splitIntoBars barDurations - where + where clef = case clefId of 0 -> (MusicXml.GClef, 2) 1 -> (MusicXml.CClef, 3) @@ -310,11 +309,11 @@ splitIntoBars = splitTiesVoiceAt exportBar timeSignature - = XmlBar - . addBarInfo + = XmlBar + . addBarInfo . quantizeBar where - addBarInfo = (,) $ BarInfo timeSignature + addBarInfo = (,) $ BarInfo timeSignature quantizeBar = mapWithDur XmlContext . rewrite . handleErrors . quantize . view eventsV where @@ -327,7 +326,7 @@ {- Note: We want all note transformers to be applicative morphisms, i.e. - + notate (pure x) = pure (notate x) Specifically @@ -339,8 +338,8 @@ exportNote b = uncurry notate . fmap (exportNote b) . getTieT . sequenceA The latter looks a lot like cotraverse. Generalization? - - + + -} instance HasBackendNote MusicXml a => HasBackendNote MusicXml [a] where @@ -349,7 +348,7 @@ instance HasBackendNote MusicXml Integer where -- TODO can we get rid of exportChord alltogether and just use XmlContext? exportNote _ (XmlContext d Nothing) = MusicXml.rest (realToFrac d) - exportNote _ (XmlContext d (Just x)) = (`MusicXml.note` realToFrac d) . spellMusicXml . fromIntegral $ x + exportNote _ (XmlContext d (Just x)) = (`MusicXml.note` realToFrac d) . spellMusicXml . fromIntegral $ x exportChord _ (XmlContext d Nothing) = MusicXml.rest (realToFrac d) exportChord _ (XmlContext d (Just xs)) = (`MusicXml.chord` realToFrac d) . fmap (spellMusicXml . fromIntegral) $ xs @@ -390,8 +389,8 @@ instance HasBackendNote MusicXml a => HasBackendNote MusicXml (DynamicT DynamicNotation a) where exportNote b = uncurry notate . fmap (exportNote b) . getDynamicT . sequenceA where - notate (DynamicNotation (crescDims, level)) - = composed (fmap notateCrescDim crescDims) + notate (DynamicNotation (crescDims, level)) + = composed (fmap notateCrescDim crescDims) . notateLevel level notateCrescDim crescDims = case crescDims of @@ -405,7 +404,7 @@ notateLevel showLevel = case showLevel of Nothing -> id Just lvl -> (<>) $ MusicXml.dynamic (fromDynamics (DynamicsL (Just (fixLevel . realToFrac $ lvl), Nothing))) - + fixLevel :: Double -> Double fixLevel x = fromIntegral (round (x - 0.5)) + 0.5 @@ -419,7 +418,7 @@ -- notate (ArticulationNotation (slurs, marks)) -- = composed (fmap notateMark marks) -- . composed (fmap notateSlur slurs) - -- + -- -- notateMark mark = case mark of -- NoMark -> id -- Staccato -> MusicXml.staccato @@ -427,7 +426,7 @@ -- Marcato -> MusicXml.strongAccent -- Accent -> MusicXml.accent -- Tenuto -> MusicXml.tenuto - -- + -- -- notateSlur slurs = case slurs of -- NoSlur -> id -- BeginSlur -> MusicXml.beginSlur @@ -442,7 +441,7 @@ -- TODO handle any color notate (Option Nothing) = id notate (Option (Just (Last color))) = \x -> MusicXml.Sequential [ - MusicXml.Override "NoteHead#' color" + MusicXml.Override "NoteHead#' color" (MusicXml.toLiteralValue $ "#" ++ colorName color), x, MusicXml.Revert "NoteHead#' color" @@ -455,12 +454,12 @@ | otherwise = error "MusicXml backend: Unkown color" -} instance HasBackendNote MusicXml a => HasBackendNote MusicXml (TremoloT a) where - exportNote b = uncurry notate . fmap (exportNote b) . getCouple . getTremoloT . sequenceA + exportNote b = uncurry notate . fmap (exportNote b) . runTremoloT . sequenceA where - notate (Max n) = case n of + notate n = case n of 0 -> id n -> MusicXml.tremolo (fromIntegral n) - + instance HasBackendNote MusicXml a => HasBackendNote MusicXml (TextT a) where exportNote b = uncurry notate . fmap (exportNote b) . getCouple . getTextT . sequenceA where @@ -480,8 +479,8 @@ -- Most programs do not recognize the harmonic tag -- We set a single diamond notehead instead, which can be manually replaced notateArtificial n = id -- TODO - + instance HasBackendNote MusicXml a => HasBackendNote MusicXml (SlideT a) where exportNote b = uncurry notateX . fmap (exportNote b) . getCouple . getSlideT . sequenceA where @@ -551,11 +550,5 @@ fromIntegral oct ) where (pc,alt,oct) = spellPitch (p + 60) - --- TODO This function is a workaround --- Whenever it is used, we should make the original function preserve meta instead -preserveMeta :: (HasMeta a, HasMeta b) => (a -> b) -> a -> b -preserveMeta f x = let m = view meta x in set meta m (f x) -- End internal - 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 @@ -52,12 +52,10 @@ import qualified Music.Lilypond as Lilypond import qualified Music.MusicXml.Simple as MusicXml import Music.Score.Internal.Export hiding (MVoice) -import Music.Time.Internal.Transform (whilstLD) import System.Process import Music.Time.Internal.Quantize import qualified Text.Pretty as Pretty import qualified Data.List -import Music.Score.Convert (reactiveToVoice') -- TODO import Music.Score.Internal.Util (composed, unRatio, swap, retainUpdates) import Music.Score.Export.DynamicNotation import Data.Semigroup.Instances 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 @@ -60,12 +60,10 @@ import qualified Music.Lilypond as Lilypond import qualified Music.MusicXml.Simple as MusicXml import Music.Score.Internal.Export hiding (MVoice) -import Music.Time.Internal.Transform (whilstLD) import System.Process import Music.Time.Internal.Quantize import qualified Text.Pretty as Pretty import qualified Data.List -import Music.Score.Convert (reactiveToVoice') -- TODO import Music.Score.Internal.Util (composed, unRatio, swap, retainUpdates) import Music.Score.Export.DynamicNotation import Data.Semigroup.Instances diff --git a/src/Music/Score/Harmonics.hs b/src/Music/Score/Harmonics.hs --- a/src/Music/Score/Harmonics.hs +++ b/src/Music/Score/Harmonics.hs @@ -24,8 +24,6 @@ -- -- Provides a representation of harmonics. -- --- /Warning/ This module is experimental. --- ------------------------------------------------------------------------------------- module Music.Score.Harmonics ( @@ -84,8 +82,6 @@ setNatural b = fmap (setNatural b) setHarmonic n = fmap (setHarmonic n) - --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (HarmonicT a) where type Unwrapped (HarmonicT a) = Couple (Any, Sum Int) a _Wrapped' = iso getHarmonicT HarmonicT 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 @@ -21,8 +21,7 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) -- --- Instances for note transformers. This module should be imported as part --- of "Music.Score". +-- Provides miscellaneous instances. -- ------------------------------------------------------------------------------------- @@ -34,7 +33,7 @@ import Control.Monad import Data.AffineSpace import Data.Default -import Data.Average +import Data.Monoid.Average import Data.Foldable import Data.Functor.Adjunction (unzipR) import Data.Functor.Couple @@ -45,6 +44,7 @@ import Data.Typeable import Data.VectorSpace hiding (Sum) import Data.Semigroup.Instances +import Data.Functor.Context import Music.Dynamics.Literal import Music.Pitch.Alterable @@ -78,8 +78,6 @@ (<>) = liftA2 (<>) instance Semigroup a => Semigroup (TextT a) where (<>) = liftA2 (<>) -instance Semigroup a => Semigroup (TremoloT a) where - (<>) = liftA2 (<>) instance Semigroup a => Semigroup (PartT n a) where PartT (v1,x1) <> PartT (v2,x2) = PartT (v1, x1 <> x2) @@ -179,15 +177,8 @@ deriving instance HasSlide a => HasSlide (TieT a) deriving instance HasText a => HasText (TieT a) -instance Tiable a => Tiable (TremoloT a) where - toTied = unzipR . fmap toTied -type instance Part (TremoloT a) = Part a -deriving instance HasHarmonic a => HasHarmonic (TremoloT a) -deriving instance HasSlide a => HasSlide (TremoloT a) -deriving instance HasText a => HasText (TremoloT a) - -- TextT instance Tiable a => Tiable (TextT a) where @@ -218,15 +209,7 @@ -deriving instance (Monoid b, IsPitch a) => IsPitch (Couple b a) -deriving instance (Monoid b, IsDynamics a) => IsDynamics (Couple b a) -deriving instance (Monoid b, Transformable a) => Transformable (Couple b a) -deriving instance (Monoid b, Reversible a) => Reversible (Couple b a) -deriving instance (Monoid b, Alterable a) => Alterable (Couple b a) -deriving instance (Monoid b, Augmentable a) => Augmentable (Couple b a) -deriving instance IsPitch a => IsPitch (TremoloT a) -deriving instance IsDynamics a => IsDynamics (TremoloT a) deriving instance IsPitch a => IsPitch (TextT a) deriving instance IsDynamics a => IsDynamics (TextT a) deriving instance IsPitch a => IsPitch (HarmonicT a) @@ -248,22 +231,18 @@ deriving instance Transformable a => Transformable (SlideT a) deriving instance Transformable a => Transformable (HarmonicT a) deriving instance Transformable a => Transformable (TextT a) -deriving instance Transformable a => Transformable (TremoloT a) deriving instance Reversible a => Reversible (SlideT a) deriving instance Reversible a => Reversible (HarmonicT a) deriving instance Reversible a => Reversible (TextT a) -deriving instance Reversible a => Reversible (TremoloT a) deriving instance Alterable a => Alterable (SlideT a) deriving instance Alterable a => Alterable (HarmonicT a) deriving instance Alterable a => Alterable (TextT a) -deriving instance Alterable a => Alterable (TremoloT a) deriving instance Augmentable a => Augmentable (SlideT a) deriving instance Augmentable a => Augmentable (HarmonicT a) deriving instance Augmentable a => Augmentable (TextT a) -deriving instance Augmentable a => Augmentable (TremoloT a) 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 @@ -50,7 +50,7 @@ import Data.VectorSpace import Music.Score.Articulation -import Music.Score.Convert (reactiveToVoice', scoreToVoice) +import Music.Time.Internal.Convert import Music.Score.Dynamics import Music.Score.Part import Music.Score.Pitch 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 @@ -22,10 +22,6 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) -- --- Combinators for manipulating scores and related structures. --- --- /Warning/ This module is experimental. --- ------------------------------------------------------------------------------------- module Music.Score.Meta ( diff --git a/src/Music/Score/Meta/Extract.hs b/src/Music/Score/Meta/Extract.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Meta/Extract.hs @@ -0,0 +1,63 @@ + +{-# LANGUAGE FlexibleContexts #-} + +-- Utility to extract meta-data at a specific point in time. +module Music.Score.Meta.Extract where + +import Control.Lens +import Control.Monad + +import Music.Score.Meta.Attribution +import Music.Score.Meta.Title +import Music.Score.Meta.Time +import Music.Score.Meta.Key +-- import Music.Score.Meta.Pickup +import Music.Score.Meta.Tempo +import Music.Score.Part + +import Music.Time +import Music.Time.Meta + +attributionAt :: HasMeta a => Time -> String -> a -> Maybe String +attributionAt t n x = join + $ fmap (`getAttribution` n) + $ fmap (`atTime` t) + $ unwrapMeta + $ x^.meta + +-- TODO get all *set* attributions +attributionsAt :: HasMeta a => Time -> a -> [(String, Maybe String)] +attributionsAt t x = [ + ("composer", attributionAt t "composer" x), + ("lyricist", attributionAt t "lyricist" x) + -- TODO etc + ] + +-- TODO rename getTitleAt etc in Meta.Title to prevent confunsion +titleAt :: HasMeta a => Time -> a -> Maybe Title +titleAt _ _ = Nothing + +-- TODO key + +-- TODO time + +-- TODO tempo + +partNames :: (HasParts' a, Show (Part a)) => a -> [String] +partNames = fmap show . toListOf parts' + +commonMetaAt :: HasMeta a => Time -> a -> [(String, Maybe String)] +commonMetaAt t x = + ("title", join $ fmap getTitle1 $ titleAt t x) + : ("subtitle", join $ fmap getTitle2 $ titleAt t x) + : ("subsubtitle", join $ fmap getTitle3 $ titleAt t x) + : attributionsAt t x + where + getTitle1 = (`getTitleAt` 0) + getTitle2 = (`getTitleAt` 1) + getTitle3 = (`getTitleAt` 2) + +-- >>> commonMetaAt 0 $ asScore $ composer "Hans" $ lyricist "Sondheim" c +-- [("title",Nothing),("subtitle",Nothing),("subsubtitle",Nothing),("composer",Just "Hans"),("lyricist",Just "Sondheim")] + + diff --git a/src/Music/Score/Meta/Pickup.hs b/src/Music/Score/Meta/Pickup.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Meta/Pickup.hs @@ -0,0 +1,98 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012-2014 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Provides tempo meta-data. +-- +-- /Warning/ This is not supported by any backends yet. +-- +------------------------------------------------------------------------------------- + +module Music.Score.Meta.Pickup ( + -- * Pickup type + Pickup, + + -- TODO + + ) where + + +import Control.Lens (view) +import Control.Monad.Plus +import Data.Default +import Data.Foldable (Foldable) +import qualified Data.Foldable as F +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Data.Semigroup +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String +import Data.Traversable (Traversable) +import qualified Data.Traversable as T +import Data.Typeable +import Data.Void + +import Music.Pitch.Literal +import Music.Score.Meta +import Music.Score.Part +import Music.Score.Pitch +import Music.Score.Internal.Util +import Music.Time +import Music.Time.Reactive + +-- | Represents a rehearsal mark. +-- +-- TODO this needs zero-duration spans to work properly. +data Pickup = Pickup (Maybe String) Int + deriving (Eq, Ord, Typeable) +-- name level(0=standard) + +instance Default Pickup where + def = Pickup Nothing 0 + +instance Semigroup Pickup where + Pickup n1 l1 <> Pickup n2 l2 = Pickup (n1 <> n2) (l1 `max` l2) + +instance Monoid Pickup where + mempty = def + mappend = (<>) + +instance Show Pickup where + show (Pickup name level) = "A" -- TODo + + +-- metronome :: Duration -> Bpm -> Tempo +-- metronome noteVal bpm = Tempo Nothing (Just noteVal) $ 60 / (bpm * noteVal) + +rehearsalMark :: (HasMeta a, HasPosition a) => Pickup -> a -> a +rehearsalMark c x = rehearsalMarkDuring (_getEra x) c x + +rehearsalMarkDuring :: HasMeta a => Span -> Pickup -> a -> a +rehearsalMarkDuring s x = addMetaNote $ view note (s, x) + +withPickup :: (Pickup -> Score a -> Score a) -> Score a -> Score a +withPickup = withMeta + 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 @@ -42,6 +42,16 @@ tempo, tempoDuring, + -- ** Common tempi + presto, + allegro, + allegretto, + moderato, + andante, + adagio, + largo, + lento, + -- * Extracting tempo renderTempo, ) where @@ -308,6 +318,16 @@ -} + +presto = metronome (1/4) 125 +allegro = metronome (1/4) 115 +allegretto = metronome (1/4) 105 +moderato = metronome (1/4) 95 +andante = metronome (1/4) 85 +adagio = metronome (1/4) 65 +largo = metronome (1/4) 55 +lento = metronome (1/4) 45 + -- TODO consolidate diff --git a/src/Music/Score/Part.hs b/src/Music/Score/Part.hs --- a/src/Music/Score/Part.hs +++ b/src/Music/Score/Part.hs @@ -49,10 +49,10 @@ -- * Extracting parts extracted, - extracted', + extractedWithInfo, extractPart, extractParts, - extractParts', + extractPartsWithInfo, -- * Manipulating parts @@ -240,14 +240,14 @@ filterPart :: (MonadPlus f, HasPart a a) => (Part a -> Bool) -> f a -> f a filterPart p = mfilter (\x -> p (x ^. part)) -extractParts' :: (Ord (Part a), HasPart' a) => Score a -> [(Part a, Score a)] -extractParts' x = zip (allParts x) (extractParts x) +extractPartsWithInfo :: (Ord (Part a), HasPart' a) => Score a -> [(Part a, Score a)] +extractPartsWithInfo x = zip (allParts x) (extractParts x) extracted :: (Ord (Part a), HasPart' a{-, HasPart a b-}) => Iso (Score a) (Score b) [Score a] [Score b] extracted = iso extractParts mconcat -extracted' :: (Ord (Part a), Ord (Part b), HasPart' a, HasPart' b) => Iso (Score a) (Score b) [(Part a, Score a)] [(Part b, Score b)] -extracted' = iso extractParts' $ mconcat . fmap (uncurry $ set parts') +extractedWithInfo :: (Ord (Part a), Ord (Part b), HasPart' a, HasPart' b) => Iso (Score a) (Score b) [(Part a, Score a)] [(Part b, Score b)] +extractedWithInfo = iso extractPartsWithInfo $ mconcat . fmap (uncurry $ set parts') @@ -255,7 +255,6 @@ deriving (Eq, Ord, Show, Typeable, Functor, Applicative, Comonad, Monad, Transformable) --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (PartT p a) where type Unwrapped (PartT p a) = (p, a) _Wrapped' = iso getPartT PartT 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 @@ -24,8 +24,6 @@ -- -- This module provides phrase-wise traversal. -- --- /Warning/ This module is experimental. --- ------------------------------------------------------------------------------------- module Music.Score.Phrases ( @@ -39,26 +37,54 @@ Phrase, MVoice, PVoice, + TVoice, -- ** Utility - mvoicePVoice, - unsafeMvoicePVoice, + mVoicePVoice, + mVoiceTVoice, + pVoiceTVoice, + unsafeMVoicePVoice, singleMVoice, + mapPhrasesWithPrevAndCurrentOnset, ) where import Control.Applicative -import Control.Exception (assert) +import Control.Applicative +import Control.Comonad (Comonad (..), extract) +import Control.Exception (assert) import Control.Lens +import Control.Lens hiding (rewrite) +import Control.Monad import Control.Monad.Plus import Data.AffineSpace -import qualified Data.List as List +import Data.AffineSpace +import Data.Bifunctor +import Data.Colour.Names as Color +import Data.Default +import Data.Either +import Data.Either +import Data.Foldable (Foldable) +import Data.Functor.Adjunction (unzipR) +import Data.Functor.Context +import Data.Functor.Contravariant +import Data.Functor.Couple +import qualified Data.List as List +import qualified Data.List import Data.Maybe +import Data.Maybe import Data.Ord +import Data.Ratio import Data.Semigroup +import Data.Semigroup +import Data.Traversable +import Data.Traversable (Traversable, sequenceA) +import Data.VectorSpace hiding (Sum (..)) +import System.Process import Music.Score.Part -import Music.Score.Convert import Music.Time +import Music.Time.Internal.Convert +import Music.Time.Internal.Util -- | @@ -106,7 +132,7 @@ -- | Traverses all phrases in a voice. instance HasPhrases (PVoice a) (PVoice b) a b where -- Note: This is actually OK in 'phr', as that just becomes (id . each . _Right) - mvoices = from unsafeMvoicePVoice + mvoices = from unsafeMVoicePVoice -- | Traverses all phrases in each voice, using 'extracted'. instance (HasPart' a, {-HasPart a b, -}{-Transformable a,-} Ord (Part a)) => @@ -119,7 +145,7 @@ Phrase traversal for score: phrasesS :: (Ord (Part a), HasPart' a, Transformable a) => Traversal' (Score a) (Phrase a) -phrasesS = extracted . each . singleMVoice . mvoicePVoice . each . _Right +phrasesS = extracted . each . singleMVoice . mVoicePVoice . each . _Right More generally: -} @@ -134,14 +160,13 @@ -- A generic phrase-traversal. -- phrases :: HasPhrases s t a b => Traversal s t (Phrase a) (Phrase b) -phrases = mvoices . mvoicePVoice . each . _Right +phrases = mvoices . mVoicePVoice . each . _Right -- | -- View an 'MVoice' as a 'PVoice'. -- -mvoicePVoice :: Lens (MVoice a) (MVoice b) (PVoice a) (PVoice b) -mvoicePVoice = unsafeMvoicePVoice --- TODO rename mVoicePVoice! +mVoicePVoice :: Lens (MVoice a) (MVoice b) (PVoice a) (PVoice b) +mVoicePVoice = unsafeMVoicePVoice -- TODO meta -- | @@ -149,9 +174,8 @@ -- -- This a valid 'Iso' up to meta-data equivalence. -- -unsafeMvoicePVoice :: Iso (MVoice a) (MVoice b) (PVoice a) (PVoice b) -unsafeMvoicePVoice = iso mvoiceToPVoice pVoiceToMVoice --- TODO rename unsafeMVoicePVoice! +unsafeMVoicePVoice :: Iso (MVoice a) (MVoice b) (PVoice a) (PVoice b) +unsafeMVoicePVoice = iso mvoiceToPVoice pVoiceToMVoice where mvoiceToPVoice :: MVoice a -> PVoice a mvoiceToPVoice = @@ -177,12 +201,8 @@ phraseToVoice = fmap Just - - - -- TODO failure --- TODO why Transformable? -singleMVoice :: {-Transformable a =>-} Prism (Score a) (Score b) (MVoice a) (MVoice b) +singleMVoice :: Prism (Score a) (Score b) (MVoice a) (MVoice b) singleMVoice = iso scoreToVoice voiceToScore' where scoreToVoice :: {-Transformable a =>-} Score a -> MVoice a @@ -207,13 +227,71 @@ voiceToScore' = mcatMaybes . voiceToScore --- instance (Transformable a, Transformable b) => Cons (Phrase a) (Phrase b) a b where - -- _Cons = undefined --- instance (Transformable a, Transformable b) => Snoc (Phrase a) (Phrase b) a b where - -- _Snoc = prism' pure (preview lastV) +-- foo :: HasPhrases' s a => s -> [TVoice a] +mapPhrasesWithPrevAndCurrentOnset :: HasPhrases s t a b => (Maybe Time -> Time -> Phrase a -> Phrase b) -> s -> t +mapPhrasesWithPrevAndCurrentOnset f = over (mvoices . mVoiceTVoice) (withPrevAndCurrentOnset f) +withPrevAndCurrentOnset :: (Maybe Time -> Time -> a -> b) -> Track a -> Track b +withPrevAndCurrentOnset f = over delayeds (fmap (\(x,y,z) -> fmap (f (fmap _onset x) (_onset y)) y) . withPrevNext) --- TODO move +mVoiceTVoice :: Lens (MVoice a) (MVoice b) (TVoice a) (TVoice b) +mVoiceTVoice = mVoicePVoice . pVoiceTVoice + +pVoiceTVoice :: Lens (PVoice a) (PVoice b) (TVoice a) (TVoice b) +pVoiceTVoice = lens pVoiceToTVoice (flip tVoiceToPVoice) + where + pVoiceToTVoice :: PVoice a -> TVoice a + pVoiceToTVoice x = mkTrack $ rights $ map (sequenceA) $ firsts (offsetPoints (0::Time)) (withDurationR x) + + -- TODO assert no overlapping + tVoiceToPVoice :: TVoice a -> PVoice b -> PVoice a + tVoiceToPVoice tv pv = set _rights newPhrases pv + where + newPhrases = toListOf traverse tv + + +_rights :: Lens [Either a b] [Either a c] [b] [c] +_rights = lens _rightsGet (flip _rightsSet) + where + _rightsGet :: [Either a b] -> [b] + _rightsGet = rights + + _rightsSet :: [c] -> [Either a b] -> [Either a c] + _rightsSet cs = sndMapAccumL f cs + where + f cs (Left a) = (cs, Left a) + f (c:cs) (Right b) = (cs, Right c) + f [] (Right _) = error "No more cs" + + sndMapAccumL f z = snd . List.mapAccumL f z + +firsts :: ([a] -> [b]) -> [(a,c)] -> [(b,c)] +firsts f = uncurry zip . first f . unzipR + +mkTrack :: [(Time, a)] -> Track a +mkTrack = view track . map (view delayed) + +withDurationR :: (Functor f, HasDuration a) => f a -> f (Duration, a) +withDurationR = fmap $ \x -> (_duration x, x) + +-- TODO generalize and move +mapWithDuration :: HasDuration a => (Duration -> a -> b) -> a -> b +mapWithDuration = over dual withDurationL . uncurry + where + withDurationL :: (Contravariant f, HasDuration a) => f (Duration, a) -> f a + withDurationL = contramap $ \x -> (_duration x, x) + + dual :: Iso (a -> b) (c -> d) (Op b a) (Op d c) + dual = iso Op getOp + +dursToVoice :: [Duration] -> Voice () +dursToVoice = mconcat . map (\d -> stretch d $ return ()) + +{- +>>> print $ view (mVoiceTVoice) $ (fmap Just (dursToVoice [1,2,1]) <> return Nothing <> return (Just ())) + + +-} -- | -- Group contigous sequences matching/not-matching the predicate. 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 @@ -35,31 +35,27 @@ module Music.Score.Pitch ( - -- * Pitch type functions + -- * Pitch type Pitch, SetPitch, Interval, - -- * Accessing pitch - HasPitches(..), + -- * HasPitch classes HasPitch(..), + HasPitches(..), + fromPitch', + -- ** Simple versions - HasPitches', HasPitch', + HasPitches', pitch', pitches', - -- * Converting pitch to container - fromPitch', - - -- * Manipulating pitch - Transposable, + -- * Transposition up, down, above, below, - inv, - invertPitches, octavesUp, octavesDown, octavesAbove, @@ -68,23 +64,30 @@ fifthsDown, fifthsAbove, fifthsBelow, - -- ** Utility _15va, _8va, _8vb, _15vb, - -- * Inspecting pitch - highestPitch, - lowestPitch, + -- * Inversion + inv, + invertPitches, + + -- * Folds + highest, + lowest, meanPitch, - -- * Intervals - augmentIntervals, + -- -- * Intervals + -- augmentIntervals, -- TODO pitchIs, to write filter pitchIs ... etc -- TODO gliss etc + PitchPair, + AffinePair, + Transposable, + ) where import Control.Applicative @@ -109,64 +112,59 @@ import Music.Score.Slide import Music.Score.Text import Music.Score.Ties -import Music.Score.Tremolo +-- import Music.Score.Tremolo import Music.Score.Phrases import Music.Time import Music.Time.Internal.Transform -- | --- This type fuction is used to retrive the /pitch type/ for a given concrete type. --- --- For types representing pitch, it is generally 'Identity', i.e --- --- @ --- Pitch Integer ~ Integer --- Pitch Double ~ Double --- @ --- --- and so on. +-- This type fuction is used to access the pitch type for a given type. -- --- For containers, 'Pitch' provides a morphism: +type family Pitch (s :: *) :: * -- -- @ -- 'Pitch' (c,a) ~ 'Pitch' a -- 'Pitch' [a] ~ 'Pitch' a -- 'Pitch' ('Note' a) ~ 'Pitch' a --- 'Pitch' ('Delayed' a) ~ 'Pitch' a --- 'Pitch' ('Stretched' a) ~ 'Pitch' a -- 'Pitch' ('Voice' a) ~ 'Pitch' a --- 'Pitch' ('Chord' a) ~ 'Pitch' a --- 'Pitch' ('Track' a) ~ 'Pitch' a -- 'Pitch' ('Score' a) ~ 'Pitch' a -- @ -- -type family Pitch (s :: *) :: * - --- | --- This type fuction is used to retrive the /pitch type/ for a given concrete type. --- --- For types representing pitch, it is generally 'Constant', i.e +-- For types representing pitch, it is generally 'Identity', i.e -- -- @ --- SetPitch a Double ~ a --- SetPitch a Integer ~ a +-- Pitch Integer ~ Integer +-- Pitch Double ~ Double -- @ -- +-- and so on. +-- -- For containers, 'Pitch' provides a morphism: -- + +-- | +-- This type fuction is used to update the pitch type for a given type. +-- The first argument is the new type. +-- +type family SetPitch (b :: *) (s :: *) :: * +-- -- @ -- 'SetPitch' b (c,a) ~ (c, 'SetPitch' b a) -- 'SetPitch' b [a] ~ ['SetPitch' b a] -- 'SetPitch' g ('Note' a) ~ Note ('SetPitch' g a) --- 'SetPitch' g ('Delayed' a) ~ Delayed ('SetPitch' g a) --- 'SetPitch' g ('Stretched' a) ~ Stretched ('SetPitch' g a) -- 'SetPitch' g ('Voice' a) ~ 'Voice' ('SetPitch' g a) --- 'SetPitch' g ('Chord' a) ~ 'Chord' ('SetPitch' g a) --- 'SetPitch' g ('Track' a) ~ 'Track' ('SetPitch' g a) -- 'SetPitch' g ('Score' a) ~ 'Score' ('SetPitch' g a) -- @ -- -type family SetPitch (b :: *) (s :: *) :: * +-- For types representing pitch, it is generally 'Constant', i.e +-- +-- @ +-- SetPitch a Double ~ a +-- SetPitch a Integer ~ a +-- @ +-- +-- For containers, 'SetPitch' provides a morphism: +-- -- | -- Class of types that provide a single pitch. @@ -179,20 +177,18 @@ -- for example: -- -- @ - -- 'view' 'pitch' :: HasPitch a a - -- @ - -- - -- @ - -- 'over' 'pitch' :: HasPitch' a => a -> Pitch a - -- 'pitch' %~ 'succ' :: HasPitch' a => a -> a - -- 'pitch' +~ 2 :: (HasPitch' a, Num (Pitch a)) => a -> a - -- 'pitch' .~ c :: (HasPitch' a, IsPitch a) => a -> a + -- 'pitch' .~ c :: ('HasPitch'' a, 'IsPitch' a) => a -> a + -- 'pitch' +~ 2 :: ('HasPitch'' a, 'Num' ('Pitch' a)) => a -> a + -- 'pitch' %~ 'succ' :: ('HasPitch'' a, 'Enum' ('Pitch' a)) => a -> a + -- 'view' 'pitch' :: 'HasPitches'' a => a -> 'Pitch' a + -- 'set' 'pitch' :: 'HasPitches' a b => 'Pitch' b -> a -> b + -- 'over' 'pitch' :: 'HasPitches' a b => ('Pitch' a -> 'Pitch' b) -> a -> b -- @ -- pitch :: Lens s t (Pitch s) (Pitch t) -- | --- Class of types that provide a pitch traversal. +-- Class of types that provide zero or more pitches. -- class (Transformable (Pitch s), Transformable (Pitch t), @@ -204,15 +200,11 @@ -- for example: -- -- @ - -- 'lengthOf' 'pitches' :: HasPitches a a => a -> Int - -- @ - -- - -- @ - -- 'toListOf' 'pitches' :: HasPitches' a => a -> Pitch a - -- @ - -- - -- @ - -- 'over' 'pitches' :: HasPitches a b => a -> b + -- 'toListOf' 'pitches' :: 'HasPitches'' a => a -> ['Pitch' a] + -- 'allOf' 'pitches' :: ('HasPitches'' a) => ('Pitch' a -> 'Bool') -> a -> 'Bool' + -- 'maximumOf' 'pitches' :: ('HasPitches'' a, 'Ord' ('Pitch' a)) => a -> 'Maybe' ('Pitch' a) + -- 'set' 'pitches' :: 'HasPitches' a b => 'Pitch' b -> a -> b + -- 'over' 'pitches' :: 'HasPitches' a b => ('Pitch' a -> 'Pitch' b) -> a -> b -- @ -- pitches :: Traversal s t (Pitch s) (Pitch t) @@ -222,25 +214,31 @@ type HasPitches' a = HasPitches a a --- | --- Pitch type. +-- | +-- Access the pitch. -- +-- Same as 'pitch', but without polymorphic update. +-- pitch' :: (HasPitch s t, s ~ t) => Lens' s (Pitch s) pitch' = pitch {-# INLINE pitch' #-} --- | --- Pitch type. +-- | +-- Access all pitches. +-- +-- Same as 'pitches', but without polymorphic update. -- pitches' :: (HasPitches s t, s ~ t) => Traversal' s (Pitch s) pitches' = pitches {-# INLINE pitches' #-} - --- TODO flip name of this and Literal.fromPitch (or call that fromPitchL) +-- | +-- Inject a pitch into some larger type. +-- fromPitch' :: (HasPitches' a, IsPitch a) => Pitch a -> a fromPitch' x = c & pitches' .~ x {-# INLINE fromPitch' #-} +-- TODO swap name of this and Music.Pitch.Literal.fromPitch (or call that something else, i.e. fromPitchL) #define PRIM_PITCH_INSTANCE(TYPE) \ @@ -357,8 +355,7 @@ type instance Pitch (Couple c a) = Pitch a type instance SetPitch g (Couple c a) = Couple c (SetPitch g a) -type instance Pitch (TremoloT a) = Pitch a -type instance SetPitch g (TremoloT a) = TremoloT (SetPitch g a) + type instance Pitch (TextT a) = Pitch a type instance SetPitch g (TextT a) = TextT (SetPitch g a) type instance Pitch (HarmonicT a) = Pitch a @@ -372,12 +369,7 @@ pitches = _Wrapped . pitches instance (HasPitch a b) => HasPitch (Couple c a) (Couple c b) where pitch = _Wrapped . pitch - -instance (HasPitches a b) => HasPitches (TremoloT a) (TremoloT b) where - pitches = _Wrapped . pitches -instance (HasPitch a b) => HasPitch (TremoloT a) (TremoloT b) where - pitch = _Wrapped . pitch - + instance (HasPitches a b) => HasPitches (TextT a) (TextT b) where pitches = _Wrapped . pitches instance (HasPitch a b) => HasPitch (TextT a) (TextT b) where @@ -404,38 +396,70 @@ -- type Interval a = Diff (Pitch a) +type PitchPair v w = (Num (Scalar v), IsInterval v, IsPitch w) +type AffinePair v w = (VectorSpace v, AffineSpace w) + -- | -- Class of types that can be transposed, inverted and so on. -- -type Transposable a - = (HasPitches a a, - VectorSpace (Interval a), AffineSpace (Pitch a), - IsInterval (Interval a), IsPitch (Pitch a), - Num (Scalar (Interval a))) +type Transposable a = ( + HasPitches' a, + AffinePair (Interval a) (Pitch a), + PitchPair (Interval a) (Pitch a) + ) -- | --- Transpose up. +-- Transpose pitch upwards. -- +-- Not to be confused with matrix transposition. +-- +-- >>> up m3 c +-- eb +-- +-- >>> up _P5 [c,d,e :: Pitch] +-- [g,a,b] +-- +-- >>> up _P5 [440 :: Hertz, 442, 810] +-- [g,a,b] +-- up :: Transposable a => Interval a -> a -> a up v = pitches %~ (.+^ v) +{-# INLINE up #-} -- | --- Transpose down. +-- Transpose pitch downwards. -- +-- Not to be confused with matrix transposition. +-- +-- >>> down m3 c +-- a +-- +-- >>> down _P5 [c,d,e] +-- [f_,g_,a_] +-- down :: Transposable a => Interval a -> a -> a down v = pitches %~ (.-^ v) +{-# INLINE down #-} -- | -- Add the given interval above. -- +-- >>> above _P8 [c] +-- [c,c'] +-- above :: (Semigroup a, Transposable a) => Interval a -> a -> a above v x = x <> up v x +{-# INLINE above #-} -- | -- Add the given interval below. -- +-- >>> below _P8 [c] +-- [c,c_] +-- below :: (Semigroup a, Transposable a) => Interval a -> a -> a below v x = x <> down v x +{-# INLINE below #-} inv :: Transposable a => Pitch a -> a -> a inv = invertPitches @@ -450,80 +474,109 @@ -- | -- Transpose up by the given number of octaves. -- +-- >>> octavesUp 2 c +-- c'' +-- +-- >>> octavesUp 1 [c,d,e] +-- [c',d',e'] +-- +-- >>> octavesUp (-1) [c,d,e] +-- [c_,d_,e_] +-- octavesUp :: Transposable a => Scalar (Interval a) -> a -> a octavesUp n = up (_P8^*n) +{-# INLINE octavesUp #-} -- | -- Transpose down by the given number of octaves. -- +-- >>> octavesDown 2 c +-- c__ +-- +-- >>> octavesDown 1 [c,d,e] +-- [c_,d_,e_] +-- +-- >>> octavesDown (-1) [c,d,e] +-- [c',d',e'] +-- octavesDown :: Transposable a => Scalar (Interval a) -> a -> a octavesDown n = down (_P8^*n) +{-# INLINE octavesDown #-} -- | -- Add the given octave above. -- octavesAbove :: (Semigroup a, Transposable a) => Scalar (Interval a) -> a -> a octavesAbove n = above (_P8^*n) +{-# INLINE octavesAbove #-} -- | -- Add the given octave below. -- octavesBelow :: (Semigroup a, Transposable a) => Scalar (Interval a) -> a -> a octavesBelow n = below (_P8^*n) +{-# INLINE octavesBelow #-} -- | -- Transpose up by the given number of fifths. -- fifthsUp :: Transposable a => Scalar (Interval a) -> a -> a fifthsUp n = up (_P8^*n) +{-# INLINE fifthsUp #-} -- | -- Transpose down by the given number of fifths. -- fifthsDown :: Transposable a => Scalar (Interval a) -> a -> a fifthsDown n = down (_P8^*n) +{-# INLINE fifthsDown #-} -- | -- Add the given octave above. -- fifthsAbove :: (Semigroup a, Transposable a) => Scalar (Interval a) -> a -> a fifthsAbove n = above (_P8^*n) +{-# INLINE fifthsAbove #-} -- | -- Add the given octave below. -- fifthsBelow :: (Semigroup a, Transposable a) => Scalar (Interval a) -> a -> a fifthsBelow n = below (_P8^*n) +{-# INLINE fifthsBelow #-} -- | Shorthand for @'octavesUp' 2@. _15va :: Transposable a => a -> a _15va = octavesUp 2 +{-# INLINE _15va #-} -- | Shorthand for @'octavesUp' 1@. _8va :: Transposable a => a -> a _8va = octavesUp 1 +{-# INLINE _8va #-} -- | Shorthand for @'octavesDown' 1@. _8vb :: Transposable a => a -> a _8vb = octavesDown 1 +{-# INLINE _8vb #-} -- | Shorthand for @'octavesDown' 2@. _15vb :: Transposable a => a -> a _15vb = octavesDown 2 - +{-# INLINE _15vb #-} -- | -- Return the highest pitch in the given music. -- -highestPitch :: (HasPitches' a, Ord (Pitch a)) => a -> Pitch a -highestPitch = maximum . toListOf pitches' +highest :: (HasPitches' a, Ord (Pitch a)) => a -> Maybe (Pitch a) +highest = maximumOf pitches' -- | -- Return the lowest pitch in the given music. -- -lowestPitch :: (HasPitches' a, Ord (Pitch a)) => a -> Pitch a -lowestPitch = maximum . toListOf pitches' +lowest :: (HasPitches' a, Ord (Pitch a)) => a -> Maybe (Pitch a) +lowest = minimumOf pitches' -- | -- Return the mean pitch in the given music. 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 @@ -25,8 +25,6 @@ -- Provides a representation of musical /slides/, commonly known as /glissando/ or -- /portamento/. -- --- /Warning/ This module is experimental. --- ------------------------------------------------------------------------------------- module Music.Score.Slide ( @@ -40,7 +38,6 @@ import Control.Applicative import Control.Comonad import Control.Lens hiding (transform) -import Control.Lens.Cons.Middle import Data.Foldable import Data.Foldable import Data.Functor.Couple @@ -104,7 +101,6 @@ newtype SlideT a = SlideT { getSlideT :: Couple ((Any, Any), (Any, Any)) a } deriving (Eq, Show, Ord, Functor, Foldable, Typeable, Applicative, Monad, Comonad) --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (SlideT a) where type Unwrapped (SlideT a) = Couple ((Any, Any), (Any, Any)) a _Wrapped' = iso getSlideT SlideT @@ -138,7 +134,7 @@ slide :: (HasPhrases' s a, HasSlide a) => s -> s slide = mapPhraseWise3 (setBeginSlide True) (setBeginSlide True . setEndSlide True) (setEndSlide True) where - mapPhraseWise3 f g h = over phrases' (over _head f . over _middle g . over _last h) + mapPhraseWise3 f g h = over phrases' (over _head f . over (_tail . _init) g . over _last h) -- | -- Add a glissando between the first and the last note. @@ -146,4 +142,4 @@ glissando :: (HasPhrases' s a, HasSlide a) => s -> s glissando = mapPhraseWise3 (setBeginGliss True) (setBeginGliss True . setEndGliss True) (setEndGliss True) where - mapPhraseWise3 f g h = over phrases' (over _head f . over _middle g . over _last h) + mapPhraseWise3 f g h = over phrases' (over _head f . over (_tail . _init) g . over _last h) 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 @@ -28,12 +28,11 @@ module Music.Score.Text ( - -- * Text HasText(..), TextT(..), text, - + textLast, ) where import Control.Applicative @@ -84,7 +83,6 @@ instance HasText a => HasText (Score a) where addText s = fmap (addText s) --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (TextT a) where type Unwrapped (TextT a) = Couple [String] a _Wrapped' = iso getTextT TextT @@ -104,9 +102,17 @@ deriving instance (Real a, Enum a, Integral a) => Integral (TextT a) -- | --- Attach the given text to the first note in the score. +-- Attach the given text to the first note. -- text :: (HasPhrases' s a, HasText a) => String -> s -> s -text s = over (phrases'._head) (addText s) +text s = over (phrases' . _head) (addText s) + +-- | +-- Attach the given text to the last note. +-- +textLast :: (HasPhrases' s a, HasText a) => String -> s -> s +textLast s = over (phrases' . _last) (addText s) + + 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 @@ -53,6 +53,7 @@ import Data.Ratio import Data.Semigroup import Data.Typeable +import Data.Monoid.Average import Data.VectorSpace hiding (Sum) import Music.Dynamics.Literal @@ -96,7 +97,6 @@ newtype TieT a = TieT { getTieT :: ((Any, Any), a) } deriving (Eq, Ord, Show, Functor, Foldable, Typeable, Applicative, Monad, Comonad) --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (TieT a) where type Unwrapped (TieT a) = ((Any, Any), a) _Wrapped' = iso getTieT TieT @@ -129,6 +129,9 @@ toTied = unzipR . fmap toTied instance Tiable a => Tiable (Maybe a) where + toTied = unzipR . fmap toTied + +instance Tiable a => Tiable (Average a) where toTied = unzipR . fmap toTied instance Tiable a => Tiable (Sum a) where diff --git a/src/Music/Score/Tremolo.hs b/src/Music/Score/Tremolo.hs --- a/src/Music/Score/Tremolo.hs +++ b/src/Music/Score/Tremolo.hs @@ -28,12 +28,13 @@ module Music.Score.Tremolo ( - -- * Tremolo HasTremolo(..), - TremoloT(..), tremolo, + -- ** Tremolo note transformer + TremoloT, + runTremoloT, ) where import Control.Applicative @@ -46,6 +47,7 @@ import Data.Semigroup import Data.Typeable import Data.Word +import Data.Functor.Adjunction (unzipR) import Music.Dynamics.Literal import Music.Pitch.Alterable @@ -53,6 +55,20 @@ import Music.Pitch.Literal import Music.Score.Part import Music.Score.Phrases +import Music.Dynamics.Literal +import Music.Pitch.Alterable +import Music.Pitch.Augmentable +import Music.Pitch.Literal +import Music.Score.Articulation +-- import Music.Score.Color +import Music.Score.Dynamics +import Music.Score.Harmonics +import Music.Score.Meta +import Music.Score.Part +import Music.Score.Pitch +import Music.Score.Slide +import Music.Score.Text +import Music.Score.Ties import Music.Time class HasTremolo a where @@ -70,8 +86,27 @@ instance HasTremolo a => HasTremolo (Score a) where setTrem n = fmap (setTrem n) +-- | +-- Set the number of tremolo divisions for all notes in the score. +-- +tremolo :: HasTremolo a => Int -> a -> a +tremolo = setTrem + + +-- TODO these must be moved upwards +deriving instance (Monoid b, IsPitch a) => IsPitch (Couple b a) +deriving instance (Monoid b, IsDynamics a) => IsDynamics (Couple b a) +deriving instance (Monoid b, Transformable a) => Transformable (Couple b a) +deriving instance (Monoid b, Reversible a) => Reversible (Couple b a) +deriving instance (Monoid b, Alterable a) => Alterable (Couple b a) +deriving instance (Monoid b, Augmentable a) => Augmentable (Couple b a) +instance Tiable a => Tiable (Couple b a) where + toTied = unzipR . fmap toTied + + + newtype TremoloT a = TremoloT { getTremoloT :: Couple (Max Word) a } deriving (Eq, Show, Ord, Functor, Foldable, Typeable, Applicative, Monad, Comonad) -- @@ -79,7 +114,6 @@ -- Preferably we would use Natural but unfortunately this is not an instance of Bounded -- --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (TremoloT a) where type Unwrapped (TremoloT a) = Couple (Max Word) a _Wrapped' = iso getTremoloT TremoloT @@ -98,9 +132,44 @@ deriving instance (Num a, Ord a, Real a) => Real (TremoloT a) deriving instance (Real a, Enum a, Integral a) => Integral (TremoloT a) +deriving instance IsPitch a => IsPitch (TremoloT a) +deriving instance IsDynamics a => IsDynamics (TremoloT a) +deriving instance Semigroup a => Semigroup (TremoloT a) +deriving instance Tiable a => Tiable (TremoloT a) + +deriving instance HasHarmonic a => HasHarmonic (TremoloT a) +deriving instance HasSlide a => HasSlide (TremoloT a) +deriving instance HasText a => HasText (TremoloT a) +deriving instance Transformable a => Transformable (TremoloT a) +deriving instance Reversible a => Reversible (TremoloT a) +deriving instance Alterable a => Alterable (TremoloT a) +deriving instance Augmentable a => Augmentable (TremoloT a) + +type instance Pitch (TremoloT a) = Pitch a +type instance SetPitch g (TremoloT a) = TremoloT (SetPitch g a) +type instance Dynamic (TremoloT a) = Dynamic a +type instance SetDynamic g (TremoloT a) = TremoloT (SetDynamic g a) +type instance Articulation (TremoloT a) = Articulation a +type instance SetArticulation g (TremoloT a) = TremoloT (SetArticulation g a) + +instance (HasPitches a b) => HasPitches (TremoloT a) (TremoloT b) where + pitches = _Wrapped . pitches +instance (HasPitch a b) => HasPitch (TremoloT a) (TremoloT b) where + pitch = _Wrapped . pitch + +instance (HasDynamics a b) => HasDynamics (TremoloT a) (TremoloT b) where + dynamics = _Wrapped . dynamics +instance (HasDynamic a b) => HasDynamic (TremoloT a) (TremoloT b) where + dynamic = _Wrapped . dynamic + +instance (HasArticulations a b) => HasArticulations (TremoloT a) (TremoloT b) where + articulations = _Wrapped . articulations +instance (HasArticulation a b) => HasArticulation (TremoloT a) (TremoloT b) where + articulation = _Wrapped . articulation + -- | --- Set the number of tremolo divisions for all notes in the score. +-- Get the number of tremolo divisions. -- -tremolo :: HasTremolo a => Int -> a -> a -tremolo = setTrem +runTremoloT :: TremoloT a -> (Int, a) +runTremoloT (TremoloT (Couple (Max n, a))) = (fromIntegral n, a) diff --git a/src/Music/Time.hs b/src/Music/Time.hs --- a/src/Music/Time.hs +++ b/src/Music/Time.hs @@ -9,8 +9,6 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) -- --- Provides generic functions for manipulating time-based structures. --- ------------------------------------------------------------------------------------- module Music.Time ( @@ -38,7 +36,6 @@ module Music.Time.Past, module Music.Time.Nominal, module Music.Time.Graces, - module Music.Time.Note, module Music.Time.Voice, module Music.Time.Chord, module Music.Time.Track, @@ -76,3 +73,4 @@ import Music.Time.Stretched import Music.Time.Track import Music.Time.Voice + 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 @@ -24,8 +24,6 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) -- --- Behaviors, or time-varying values. --- ------------------------------------------------------------------------------------- module Music.Time.Behavior ( @@ -69,6 +67,7 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.VectorSpace +import Data.String import Prelude import Control.Applicative @@ -175,6 +174,9 @@ -- #ifdef INCLUDE_LIFTED deriving instance AdditiveGroup a => AdditiveGroup (Behavior a) +instance IsString a => IsString (Behavior a) where + fromString = pure . fromString + instance IsPitch a => IsPitch (Behavior a) where fromPitch = pure . fromPitch @@ -337,7 +339,7 @@ -- This can be used to modify a behavior in a specific range, as in -- -- @ --- 'line' & 'focusing' ``on`` (2 '<->' 3) '+a~' 1 +-- 'line' & 'focusing' `on` (2 '<->' 3) '+a~' 1 -- 'line' & 'focusingOn' (2 '<->' 3) '+~' 1 -- @ -- @@ -347,7 +349,7 @@ -} -- focusing `on` s == focusingOn s -f `on` s = flip whilstM (negateV s) . f +f `on` s = transformed (negateV s) . f -- | -- Instantly switch from one behavior to another. 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 @@ -24,8 +24,6 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) -- --- /Warning/ This module is experimental. --- ------------------------------------------------------------------------------------- module Music.Time.Bound ( @@ -103,7 +101,6 @@ -- set (namely [(t, t)^.from range | t <- {Time} ]). -- --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (Bound a) where type Unwrapped (Bound a) = (Span, a) _Wrapped' = iso getBound Bound 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 @@ -26,8 +26,6 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) -- --- /Warning/ This module is experimental. --- ------------------------------------------------------------------------------------- module Music.Time.Chord ( @@ -37,9 +35,10 @@ -- * Construction chord, + unchord, unsafeChord, - -- invertC, + -- invertChord, -- inversions, -- chordToScore, -- arpUp3, @@ -64,6 +63,7 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.VectorSpace +import Data.String import Music.Time.Delayed import Music.Time.Reverse @@ -113,7 +113,6 @@ return = view _Unwrapped . return . return xs >>= f = view _Unwrapped $ (view _Wrapped . f) `mbind` view _Wrapped xs --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (Chord a) where type Unwrapped (Chord a) = (ChordList (ChordEv a)) _Wrapped' = iso getChord Chord @@ -136,12 +135,18 @@ -- instance HasMeta (Chord a) where -- meta = error "Not implemented: meta" -chord :: Lens (Chord a) (Chord b) [Delayed a] [Delayed b] -chord = _Wrapped +chord :: Getter [Delayed a] (Chord a) +chord = from unsafeChord +unchord :: Lens (Chord a) (Chord b) [Delayed a] [Delayed b] +unchord = _Wrapped + -- TODO names are not consistent with other types unsafeChord :: Iso (Chord a) (Chord b) [Delayed a] [Delayed b] unsafeChord = _Wrapped + +instance IsString a => IsString (Chord a) where + fromString = pure . fromString deriving instance IsPitch a => IsPitch (Chord a) deriving instance IsInterval a => IsInterval (Chord a) 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 @@ -30,14 +30,12 @@ ------------------------------------------------------------------------------------- module Music.Time.Delayed ( - -- * Delayed type - Delayed, - - -- * Construction - delayed, + -- * Delayed type + Delayed, - -- ** Inspecting delayed values - delayedValue, + -- * Construction + delayed, + delayedValue, ) where import Data.AffineSpace @@ -50,9 +48,8 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.VectorSpace - -import Music.Time.Reverse -import Music.Time.Split +import Data.String +import Data.Functor.Adjunction (unzipR) import Control.Applicative import Control.Comonad @@ -67,6 +64,8 @@ import Music.Dynamics.Literal import Music.Pitch.Literal +import Music.Time.Reverse +import Music.Time.Split -- | @@ -90,9 +89,9 @@ -- @ -- -deriving instance Show a => Show (Delayed a) +instance (Show a, Transformable a) => Show (Delayed a) where + show x = show (x^.from delayed) ++ "^.delayed" --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (Delayed a) where type Unwrapped (Delayed a) = (Time, a) _Wrapped' = iso _delayedValue Delayed @@ -112,8 +111,23 @@ rev = revDefault instance Splittable a => Splittable (Delayed a) where - -- FIXME + -- TODO is this right? + split t = unzipR . fmap (split t) +-- Lifted instances + +instance IsString a => IsString (Delayed a) where + fromString = pure . fromString + +instance IsPitch a => IsPitch (Delayed a) where + fromPitch = pure . fromPitch + +instance IsInterval a => IsInterval (Delayed a) where + fromInterval = pure . fromInterval + +instance IsDynamics a => IsDynamics (Delayed a) where + fromDynamics = pure . fromDynamics + -- | -- View a delayed value as a pair of a the original value and a delay time. -- @@ -136,9 +150,7 @@ runDelayed :: Transformable a => Delayed a -> a runDelayed = uncurry delayTime . view _Wrapped - + where + delayTime t = delay (t .-. 0) -deriving instance IsPitch a => IsPitch (Delayed a) -deriving instance IsInterval a => IsInterval (Delayed a) -deriving instance IsDynamics a => IsDynamics (Delayed a) diff --git a/src/Music/Time/Future.hs b/src/Music/Time/Future.hs --- a/src/Music/Time/Future.hs +++ b/src/Music/Time/Future.hs @@ -1,3 +1,6 @@ -module Music.Time.Future where +module Music.Time.Future ( + module Music.Time.Past +) where +import Music.Time.Past diff --git a/src/Music/Time/Graces.hs b/src/Music/Time/Graces.hs --- a/src/Music/Time/Graces.hs +++ b/src/Music/Time/Graces.hs @@ -1,2 +1,59 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012–2014 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +------------------------------------------------------------------------------------- + module Music.Time.Graces where + +import Control.Applicative +import Control.Monad +import Control.Monad.Compose +import Control.Monad.Plus +import Data.Foldable (Foldable) +import qualified Data.Foldable as Foldable +import Data.Traversable (Traversable) +import qualified Data.Traversable as T +import Data.Typeable + +import Music.Time.Split +import Music.Time.Reverse +import Music.Time.Nominal +import Music.Time.Voice + +newtype Graces f a = Graces { getGraces :: (Nominal f a, f a, Nominal f a) } + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- TODO move +instance Alternative f => Alternative (Nominal f) where + empty = Nominal empty + Nominal a <|> Nominal b = Nominal (a <|> b) + +instance (Applicative f, Alternative f) => Applicative (Graces f) where + pure x = Graces (empty, pure x, empty) + +-- deriving instance Transformable a => Transformable (Graces a) where +-- deriving instance Splittable a => Splittable (Graces a) where +-- deriving instance Reversible a => Reversible (Graces a) where + diff --git a/src/Music/Time/Internal/Convert.hs b/src/Music/Time/Internal/Convert.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Internal/Convert.hs @@ -0,0 +1,175 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012-2014 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Provides miscellaneous conversions. +-- +------------------------------------------------------------------------------------- + +module Music.Time.Internal.Convert ( + voiceToScore, + voiceToScore', + scoreToVoice, + reactiveToVoice', + ) where + +import Control.Applicative +import Control.Lens hiding (transform, time) +import Control.Monad +import Control.Monad.Plus +import Data.AffineSpace +import Data.AffineSpace.Point +import Data.Foldable (Foldable (..)) +import Data.Ord +import Data.Ratio +import Data.Semigroup +import Data.String +import Data.Traversable +import Data.VectorSpace + +import Music.Time + +import qualified Data.Foldable as Foldable +import qualified Data.List as List + + +{- +-- | Convert a note to an _onset and a voice. +noteToVoice :: Note a -> (Time, Voice a) +noteToVoice (view (from note) -> (s,x)) = (_onset s, stretchTo (_duration s) $ return x) +-} + +{- +-- | Convert a note to a score. +noteToScore :: Note a -> Score a +noteToScore (view (from note) -> (s,x)) = s `transform` return x +-} + +-- scoreToNotes :: Score a -> [Note a] +-- scoreToNotes = Foldable.toList . reifyScore + +-- notesToScore :: [Note a] -> Score a +-- notesToScore = pcat . fmap noteToScore + +{- +reactiveToVoice :: Duration -> Reactive a -> Voice a +reactiveToVoice d r = (^. voice) $ fmap (^. stretched) $ durs `zip` (fmap (r `atTime`) times) + where + times = 0 : filter (\t -> 0 < t && t < 0 .+^ d) (occs r) + durs = toRelativeTimeN' (0 .+^ d) times +-} + +reactiveToVoice' :: Span -> Reactive a -> Voice a +reactiveToVoice' (view range -> (u,v)) r = (^. voice) $ fmap (^. stretched) $ durs `zip` (fmap (r `atTime`) times) + where + times = 0 : filter (\t -> u < t && t < v) (occs r) + durs = toRelativeTimeN' v times +{-# DEPRECATED reactiveToVoice' "" #-} + +-- | +-- Convert a score to a voice. Fails if the score contain overlapping events. +-- +scoreToVoice :: Transformable a => Score a -> Voice (Maybe a) +scoreToVoice = (^. voice) . fmap (^. stretched) . fmap throwTime . addRests . (^. events) + where + throwTime (t,d,x) = (d,x) + addRests = concat . snd . mapAccumL g 0 + where + g u (t, d, x) + | u == t = (t .+^ d, [(t, d, Just x)]) + | u < t = (t .+^ d, [(u, t .-. u, Nothing), (t, d, Just x)]) + | otherwise = error "scoreToVoice: Strange prevTime" +{-# DEPRECATED scoreToVoice "" #-} + +-- | +-- Convert a voice to a score. +-- +voiceToScore :: Voice a -> Score a +voiceToScore = scat . fmap g . (^. stretcheds) where g = (^. stretchedValue) . fmap return +{-# DEPRECATED voiceToScore "" #-} + +{- +-- | Join voices in a given part into a score. +voicesToScore :: HasPart a => [(Part a, Voice a)] -> Score a +voicesToScore = pcat . fmap (voiceToScore . uncurry (\n -> fmap (setPart n))) +-} + +-- | +-- Convert a voice which may contain rests to a score. +-- +voiceToScore' :: Voice (Maybe a) -> Score a +voiceToScore' = mcatMaybes . voiceToScore +{-# DEPRECATED voiceToScore' "" #-} + +{- +-- | +-- Convert a track to a score where each event is given a fixed duration. +-- +trackToScore :: Transformable a => Duration -> Track a -> Score a +trackToScore x = trackToScore' (const x) + +-- | +-- Convert a track to a score, using durations determined by the values. +-- +trackToScore' :: Transformable a => (a -> Duration) -> Track a -> Score a +trackToScore' f = (^. from events) . fmap (\(t,x) -> (t,f x,x)) . map (^. from delayed) . (^. delayeds) +-} + + +-- TODO rename during +noteToReactive :: Monoid a => Note a -> Reactive a +noteToReactive n = (pure <$> n) `activate` pure mempty + +-- JUNK + +-- | Split a reactive into mkNotes, as well as the values before and after the first/last update +splitReactive :: Reactive a -> Either a ((a, Time), [Note a], (Time, a)) +splitReactive r = case updates r of + [] -> Left (initial r) + (t,x):[] -> Right ((initial r, t), [], (t, x)) + (t,x):xs -> Right ((initial r, t), fmap mkNote $ mrights (res $ (t,x):xs), head $ mlefts (res $ (t,x):xs)) + + where + + mkNote (t,u,x) = (t <-> u, x)^.note + + -- Always returns a 0 or more Right followed by one left + res :: [(Time, a)] -> [Either (Time, a) (Time, Time, a)] + res rs = let (ts,xs) = unzip rs in + flip fmap (withNext ts `zip` xs) $ + \ ((t, mu), x) -> case mu of + Nothing -> Left (t, x) + Just u -> Right (t, u, x) + + -- lenght xs == length (withNext xs) + withNext :: [a] -> [(a, Maybe a)] + withNext = go + where + go [] = [] + go [x] = [(x, Nothing)] + go (x:y:rs) = (x, Just y) : withNext (y : rs) + +activate :: Note (Reactive a) -> Reactive a -> Reactive a +activate (view (from note) -> (view range -> (start,stop), x)) y = y `turnOn` (x `turnOff` y) + where + turnOn = switchR start + turnOff = switchR stop + 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 @@ -16,13 +16,7 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) -- --- Provides rhythmical quantization. --- --- You generally need not worry about this module, as quantization is handled --- automatically by 'HasBackendScore' instances. --- --- /Warning/ This modules is poorly named and will probably be split or moved --- soon. +-- Rhythmical quantization. -- ------------------------------------------------------------------------------------- @@ -309,14 +303,14 @@ -- beat = do -- RhythmContext tm ts _ <- getState -- (\d -> (d^/tm) `subDur` ts) <$> match (\d _ -> --- d - ts > 0 && isDivisibleBy 2 (d / tm - ts)) +-- d - ts > 0 && isPowerOf 2 (d / tm - ts)) beat :: Tiable a => RhythmParser a (Rhythm a) beat = do RhythmContext tm ts _ <- getState match' $ \d x -> let d2 = d / tm - ts - in (d2, x) `assuming` (d - ts > 0 && isDivisibleBy 2 d2) + in (d2, x) `assuming` (d - ts > 0 && isPowerOf2 d2) -- | Matches a dotted rhythm @@ -422,17 +416,29 @@ assuming :: a -> Bool -> Maybe a assuming x b = if b then Just x else Nothing + +{- +isDivisibleBy2 :: RealFrac a => a -> Bool +isDivisibleBy2 x = isInt x && even (round x) + +isInt :: RealFrac a => a -> Bool +isInt x = x == fromInteger (round x) +-} + logBaseR :: forall a . (RealFloat a, Floating a) => Rational -> Rational -> a logBaseR k n | isInfinite (fromRational n :: a) = logBaseR k (n/k) + 1 logBaseR k n | isDenormalized (fromRational n :: a) = logBaseR k (n*k) - 1 logBaseR k n | otherwise = logBase (fromRational k) (fromRational n) -divides = isDivisibleBy -divisibleBy = flip isDivisibleBy +-- divides = isDivisibleBy +-- divisibleBy = flip isDivisibleBy -- As it sounds, do NOT use infix -- Only works for simple n such as 2 or 3, TODO determine -isDivisibleBy :: Duration -> Duration -> Bool -isDivisibleBy n = (== 0.0) . snd . properFraction . logBaseR (toRational n) . toRational +isPowerOf :: Duration -> Duration -> Bool +isPowerOf n = (== 0.0) . snd . properFraction . logBaseR (toRational n) . toRational + +isPowerOf2 :: Duration -> Bool +isPowerOf2 = isPowerOf 2 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 @@ -30,15 +30,18 @@ module Music.Time.Internal.Transform ( + module Music.Time.Types, + -- * The Transformable class Transformable(..), itransform, transformed, + itransformed, -- * Apply under a transformation whilst, - whilstM, whilstL, + whilstL2, whilstLT, whilstLD, whilstStretch, @@ -48,18 +51,18 @@ conjugateS, -- * Specific transformations - delay, - undelay, - stretch, - compress, - -- ** Applied transformations + -- ** Transformations delaying, undelaying, stretching, compressing, - -- ** Utility - delayTime, + -- ** Transforming values + delay, + undelay, + stretch, + compress, + delayTime, ) where @@ -76,8 +79,11 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Semigroup +import Data.Semigroup.Instances () import Data.Sequence (Seq) import qualified Data.Sequence as Seq +import Data.Set (Set) +import qualified Data.Set as Set import Data.VectorSpace hiding (Sum (..)) -- | @@ -171,6 +177,9 @@ instance Transformable a => Transformable (Seq a) where transform t = fmap (transform t) +instance (Ord a, Transformable a) => Transformable (Set a) where + transform t = Set.map (transform t) + instance (Ord k, Transformable a) => Transformable (Map k a) where transform t = Map.map (transform t) @@ -195,20 +204,45 @@ -- | -- View the given value in the context of the given transformation. -- +transformed :: (Transformable a, Transformable b) => Span -> Iso a b a b +transformed s = iso (transform s) (itransform s) + + +-- | +-- Transforms a lens of to a 'Transformable' type to act inside a transformation. +-- +itransformed :: (Transformable a, Transformable b) => Span -> Iso a b a b +itransformed s = transformed (negateV s) + +spanned = itransformed +{-# DEPRECATED spanned "Use itransformed" #-} + +-- | +-- Apply a function under transformation. +-- +-- Designed to be used infix, as in +-- -- @ --- 'over' ('transformed' s) = (``whilst`` s) +-- 'stretch' 2 `whilst` 'delaying' 2 -- @ -- -transformed :: Transformable a => Span -> Iso' a a -transformed s = iso (transform s) (itransform s) +whilst :: (Transformable a, Transformable b) => (a -> b) -> Span -> a -> b +-- f `whilst` t = transform (negateV t) . f . transform t +f `whilst` t = over (transformed t) f +delayed :: (Transformable a, Transformable b) => Time -> Iso a b a b +delayed = transformed . delayingTime +stretched :: (Transformable a, Transformable b) => Duration -> Iso a b a b +stretched = transformed . stretching + -- | -- A transformation that moves a value forward in time. -- delaying :: Duration -> Span delaying x = (0 .+^ x) >-> 1 +delayingTime x = x >-> 1 -- | -- A transformation that stretches (augments) a value by the given factor. @@ -261,8 +295,7 @@ -- the value is starting at time zero. -- delayTime :: Transformable a => Time -> a -> a -delayTime t = delay (t .-. 0) - +delayTime = transform . delayingTime -- @@ -287,47 +320,90 @@ -- -- Perhaps we should call the inline version `whilst`, as in @f `whilst` delaying 2@? +{- --- | --- Apply a function under transformation. --- --- Designed to be used infix, as in --- --- @ --- 'stretch' 2 ``whilst`` 'delaying' 2 --- @ --- -whilst :: (Transformable a, Transformable b) => (a -> b) -> Span -> a -> b -f `whilst` t = transform (negateV t) . f . transform t +-- flip whilstM is a lens +flip whilstM :: (Functor f, Transformable a, Transformable b) => (a -> f b) -> Span -> a -> f b +s `flip whilstM` f = fmap (transform (negateV t)) . f . transform t --- | --- Apply a morphism under transformation (monadic version). --- +-- is this the same as transformed? -whilstM :: (Functor f, Transformable a, Transformable b) => (a -> f b) -> Span -> a -> f b -f `whilstM` t = fmap (transform (negateV t)) . f . transform t -{- --- | --- Apply a morphism under transformation (co-monadic version). --- -whilstW :: (Functor f, Transformable a, Transformable b) => (f a -> b) -> Span -> f a -> b -f `whilstW` t = transform (negateV t) . f . fmap (transform t) +From lens: + iso sa bt = dimap sa (fmap bt) +From profunctor: + dimap ab cd bc = cd . bc . ab + dimap ab cd = \f -> cd . f . ab + + +flip whilstM = transformed +flip whilstM = \s -> iso (transform s) (itransform s) +flip whilstM = \s -> dimap (transform s) (fmap $ itransform s) +flip whilstM = \s f -> (fmap $ itransform s) . f . transform s +flip (\f t -> fmap (transform (negateV t)) . f . transform t) = \s f -> (fmap $ itransform s) . f . transform s + +\t f -> fmap (transform (negateV t)) . f . transform t += +\t f -> (fmap $ itransform t) . f . transform t + +\t f -> fmap (itransform t) . f . transform t += +\t f -> fmap (itransform t) . f . transform t + + + + +Something similar to whilstL* is being used in Note/Delayed/Stretched +Are they the same? + +whilstL l f (s,a) = (s,) <$> (l $ transformed s f) a +whilstL id f (s,a) = (s,) <$> (transformed s f) a +whilstL id = \f (s,a) -> (s,) <$> (transformed s f) a + +whilstL id + :: (Transformable a, Transformable b, Functor f) => + (a -> f b) -> (Span, a) -> f (Span, b) + -} + +-- dofoo + -- :: Functor f => (t -> t2) -> (a1 -> a) -> (t2 -> f a1) -> (t1, t) -> f (t1, a) +dofoo v w = \f (s,a) -> (s,) <$> w s <$> f ((v s) a) + + + +dobar :: (Functor f) + + => + (sp -> (s -> f t) -> (s -> f t)) + -> ((s -> f t) -> a -> f b) + -> (s -> f t) -> ((sp, a) -> f (sp, b)) + +dobar q l = \f (s,a) -> (s,) <$> (l (q s f)) a + +-- whilstL2 :: (Transformable a, Transformable b) => Lens (Span, a) (Span, b) a b +whilstL2 = dofoo (transform) (transform . negateV) + whilstL :: (Functor f, Transformable a, Transformable b) => LensLike f s t a b -> LensLike f (Span,s) (Span,t) a b -whilstL l f (s,a) = (s,) <$> (l $ f `whilstM` s) a + -- whilstL l = whilstL2 . l +whilstL l = dobar transformed l +{- +If we could rewrite (whilstL l) as (whilstLXX . l) + +-} + whilstLT :: (Functor f, Transformable a, Transformable b) => LensLike f s t a b -> LensLike f (Time,s) (Time,t) a b -whilstLT l f (t,a) = (t,) <$> (l $ f `whilstM` (t >-> 1)) a +whilstLT = dobar delayed whilstLD :: (Functor f, Transformable a, Transformable b) => LensLike f s t a b -> LensLike f (Duration,s) (Duration,t) a b -whilstLD l f (d,a) = (d,) <$> (l $ f `whilstM` (0 >-> d)) a +whilstLD = dobar stretched -- | @@ -352,23 +428,16 @@ -- | -- Transforms a lens of to a 'Transformable' type to act inside a transformation. -- -spanned :: (Transformable a, Transformable b) => Span -> Lens a b a b -spanned s = flip whilstM (negateV s) - --- | --- Transforms a lens of to a 'Transformable' type to act inside a transformation. --- -- Designed to be used infix, as in -- -- @ --- l ``onSpan`` (2 \<-> 3) +-- l `onSpan` (2 \<-> 3) -- @ -- -onSpan :: (Transformable a, Functor f) => LensLike' f a b -> Span -> LensLike' f a b +onSpan :: (Transformable s, Transformable t, Functor f) + => LensLike f s t a b -> Span -> LensLike f s t a b f `onSpan` s = spanned s . f -- TODO name --- TODO move! -deriving instance Functor Sum -deriving instance Functor Product - +-- deriving instance Functor Sum +-- deriving instance Functor Product diff --git a/src/Music/Time/Internal/Util.hs b/src/Music/Time/Internal/Util.hs --- a/src/Music/Time/Internal/Util.hs +++ b/src/Music/Time/Internal/Util.hs @@ -15,7 +15,21 @@ -- ------------------------------------------------------------------------------------- -module Music.Time.Internal.Util where +module Music.Time.Internal.Util ( + showRatio, + list, + single, + inspecting, + inspectingBy, + withPrevNext, + rotate, + tripped, + through, + uncurry3, + partial, + partial2, + partial3, + ) where {- Rules: 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 @@ -66,7 +66,7 @@ -- Move a value so that -- -- @ --- '_offset' (a ``lead`` b) = '_onset' b +-- '_offset' (a `lead` b) = '_onset' b -- @ -- -- @@ -77,7 +77,7 @@ -- Move a value so that -- -- @ --- '_offset' a = '_onset' (a ``follow`` b) +-- '_offset' a = '_onset' (a `follow` b) -- @ -- follow :: (HasPosition a, HasPosition b, Transformable b) => a -> b -> b @@ -167,55 +167,3 @@ times :: (Semigroup a, Monoid a, HasPosition a, Transformable a) => Int -> a -> a times n = scat . replicate n -{- - --- | --- Like '<>', but scaling the second agument to the duration of the first. --- --- > Score a -> Score a -> Score a --- -sustain :: (Semigroup a, Stretchable a, HasDuration a, Fractional d, d ~ Duration) => - a -> a -> a - --- | --- Like '|>' but with a negative delay on the second element. --- --- > Duration -> Score a -> Score a -> Score a --- -anticipate :: (Semigroup a, Transformable a, HasOnset a, HasOffset a, Ord d, d ~ Duration) => - d -> a -> a -> a - -x `sustain` y = x <> duration x `stretchTo` y -anticipate t a b = a <> startAt (offset a .-^ t) b - --- Like '<>', but truncating the second agument to the duration of the first. --- prolong x y = x <> before (duration x) y - --- | --- Repeat once for each element in the list. --- --- Example: --- --- > repeated [1,2,1] (c^*) --- --- Simple type: --- --- > [a] -> (a -> Score Note) -> Score Note --- -repeated :: (Monoid' b, Transformable b, HasOnset b, HasOffset b) => - [a] -> (a -> b) -> b - --- | --- Repeat a number of times and scale down by the same amount. --- --- > Duration -> Score a -> Score a --- -group :: (Monoid' a, Transformable a, Fractional d, d ~ Duration, HasOnset a, HasOffset a) => - Int -> a -> a - -times n = scat . replicate n -repeated = flip (\f -> scat . fmap f) -group n = times n . (fromIntegral n `compress`) --} - --- JUNK 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 @@ -23,16 +23,8 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) -- --- Provides a way to annotate data-types with 'Transformable' meta-data. See --- "Music.Score.Meta" for more specific applications. --- --- Inspired by Clojure and Diagram's styles, in turn based on xmonad's @Message@ type, --- in turn based on ideas in: --- --- Simon Marlow. --- /An Extensible Dynamically-Typed Hierarchy of Exceptions/. --- Proceedings of the 2006 ACM SIGPLAN workshop on --- Haskell. . +-- Provides a way to annotate data-types with 'Transformable' meta-data. +-- Inspired by Clojure meta-data and Diagrams styles. -- ------------------------------------------------------------------------------------- @@ -59,10 +51,13 @@ -- ** The HasMeta class HasMeta(..), + getMeta, + mapMeta, setMeta, + applyMeta, setMetaAttr, setMetaTAttr, - applyMeta, + preserveMeta, -- ** Add meta-data to arbitrary types AddMeta, @@ -199,12 +194,19 @@ instance HasMeta a => HasMeta (Twain b a) where meta = _Wrapped . meta --- TODO call withMeta a la Clojure? +-- | Extract meta-data. +getMeta :: HasMeta a => a -> Meta +getMeta = view meta + +-- | Update meta-data. setMeta :: HasMeta a => Meta -> a -> a -setMeta m = set meta m +setMeta = set meta --- | Apply meta-information by combining it (on the left) with the --- existing meta-information. +-- | Map over meta-data. +mapMeta :: HasMeta a => (Meta -> Meta) -> a -> a +mapMeta = over meta + +-- | Apply meta-information by combining it with existing meta-information. applyMeta :: HasMeta a => Meta -> a -> a applyMeta m = over meta (<> m) @@ -215,6 +217,10 @@ -- | Update a meta attribute. setMetaTAttr :: (TAttributeClass b, HasMeta a) => b -> a -> a setMetaTAttr a = applyMeta (wrapTMeta a) + +-- | Apply a function without affecting meta-data. +preserveMeta :: (HasMeta a, HasMeta b) => (a -> b) -> a -> b +preserveMeta f x = let m = view meta x in set meta m (f x) -- | -- Annotate an arbitrary type with meta-data, preserving instances of diff --git a/src/Music/Time/Nominal.hs b/src/Music/Time/Nominal.hs --- a/src/Music/Time/Nominal.hs +++ b/src/Music/Time/Nominal.hs @@ -1,2 +1,58 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012–2014 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +------------------------------------------------------------------------------------- + module Music.Time.Nominal where + +import Control.Applicative +import Control.Monad +import Control.Monad.Compose +import Control.Monad.Plus +import Data.Foldable (Foldable) +import qualified Data.Foldable as Foldable +import Data.Traversable (Traversable) +import qualified Data.Traversable as T +import Data.Typeable + +import Music.Time.Split +import Music.Time.Reverse + +newtype Nominal f a = Nominal { getNominal :: f a } + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Monad) + +instance Applicative f => Applicative (Nominal f) where + pure = Nominal . pure + Nominal f <*> Nominal x = Nominal (f <*> x) + +instance Transformable (Nominal f a) where + transform _ = id + +instance Splittable (Nominal f a) where + split _ x = (x,x) + +instance Reversible (f a) => Reversible (Nominal f a) where + rev (Nominal x) = Nominal (rev x) + 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 @@ -47,11 +47,9 @@ import Data.Semigroup import Data.Set (Set) import qualified Data.Set as Set +import Data.String import Data.VectorSpace -import Music.Time.Reverse -import Music.Time.Split - import Control.Applicative import Control.Comonad import Control.Comonad.Env @@ -62,8 +60,15 @@ import qualified Data.Foldable as Foldable import Data.PairMonad import Data.Typeable + +import Music.Pitch.Literal +import Music.Dynamics.Literal import Music.Time.Internal.Util (through, tripped) +import Music.Time.Reverse +import Music.Time.Split + + -- | -- A 'Note' is a value with an 'onset' and and 'offset' in time. It is an instance -- of 'Transformable'. @@ -105,7 +110,6 @@ -- instance ComonadEnv Span Note where -- ask = noteValueSpan --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (Note a) where type Unwrapped (Note a) = (Span, a) _Wrapped' = iso _noteValue Note @@ -124,10 +128,24 @@ instance Splittable a => Splittable (Note a) where -- beginning d = over _Wrapped $ \(s, v) -> (beginning d s, beginning (transform (negateV s) d) v) beginning d = over _Wrapped $ \(s, v) -> (beginning d s, beginning (d / _duration s) v) - ending d = over _Wrapped $ \(s, v) -> (ending d s, ending (1 - (d / _duration s)) v) + ending d = over _Wrapped $ \(s, v) -> (ending d s, ending (d / _duration s) v) instance Reversible (Note a) where rev = revDefault + +-- Lifted instances + +instance IsString a => IsString (Note a) where + fromString = pure . fromString + +instance IsPitch a => IsPitch (Note a) where + fromPitch = pure . fromPitch + +instance IsInterval a => IsInterval (Note a) where + fromInterval = pure . fromInterval + +instance IsDynamics a => IsDynamics (Note a) where + fromDynamics = pure . fromDynamics -- | -- View a note as a pair of the original value and the transformation (and vice versa). diff --git a/src/Music/Time/Past.hs b/src/Music/Time/Past.hs --- a/src/Music/Time/Past.hs +++ b/src/Music/Time/Past.hs @@ -1,24 +1,83 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} + module Music.Time.Past where -import Music.Time.Split -import Music.Time.Reverse -import Music.Time.Segment -import Music.Time.Behavior +import Control.Lens -- DEBUG +import Control.Applicative +import Control.Comonad +import Data.Functor.Couple +import Data.Ord (comparing) +import Data.List (takeWhile, sort, sortBy, group) +import Data.List.Ordered +import Data.Maybe +import Data.Semigroup +import Control.Monad +import Music.Time.Behavior +import Music.Time.Reverse +import Music.Time.Segment +import Music.Time.Split + -- | --- Past represents a value occuring /up to/ some point in time. +-- 'Past' represents a value occuring /before and at/ some point in time. -- --- It may be seen as a note whose era is a left-open time interval. +-- It may be seen as a note whose era is a left-open, right-inclusive time interval. -- -newtype Past a = Past { getPast :: (a, Time) } +newtype Past a = Past { getPast :: (Min Time, a) } + deriving (Eq, Ord, Functor) --- | Query a past value. +-- | +-- 'Future' represents a value occuring /at and after/ some point in time. +-- +-- It may be seen as a note whose era is a left-open, right-inclusive time interval. +-- +newtype Future a = Future { getFuture :: (Max Time, a) } + deriving (Eq, Ord, Functor) + +instance HasDuration (Past a) where + _duration _ = 0 + +instance HasDuration (Future a) where + _duration _ = 0 + +instance HasPosition (Past a) where + _position (Past (extract -> t,_)) _ = t + +instance HasPosition (Future a) where + _position (Future (extract -> t,_)) _ = t + +-- | Query a past value. Semantic function. past :: Past a -> Time -> Maybe a -past (Past (x, t)) t' +past (Past (extract -> t, x)) t' | t' <= t = Just x | otherwise = Nothing +-- | Query a future value. Semantic function. +future :: Future a -> Time -> Maybe a +future (Future (extract -> t, x)) t' + | t' >= t = Just x + | otherwise = Nothing + +-- TODO more elegant +indexPast :: [Past a] -> Time -> Maybe a +indexPast ps t = firstTrue $ fmap (\p -> past p t) $ sortBy (comparing _onset) ps + +firstTrue :: [Maybe a] -> Maybe a +firstTrue = listToMaybe . join . fmap maybeToList +-- firstTrue = join . listToMaybe . dropWhile isNothing + -- | Project a segment (backwards) up to the given point. pastSeg :: Past (Segment a) -> Behavior (Maybe a) pastSeg = undefined + +-- | Project a segment starting from the given point. +futureSeg :: Future (Segment a) -> Behavior (Maybe a) +futureSeg = undefined + + + 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 @@ -37,21 +37,22 @@ -- * The HasPosition class HasPosition(..), - -- * Inspecting position + + -- * Era era, + + -- * Position position, - -- * Specific positions + -- ** Specific positions onset, midpoint, offset, preOnset, postOffset, - - -- ** Deprecated postOnset, - -- * Moving to absolute positions + -- * Moving startAt, stopAt, placeAt, 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 @@ -29,8 +29,8 @@ module Music.Time.Reactive ( -- * Reactive type Reactive, - - -- * Construction + + -- * Query initial, final, intermediate, @@ -38,19 +38,24 @@ updates, occs, atTime, - splitReactive, + + -- * Construction - -- * Combinators + -- * Combine switchR, trimR, - -- * Sampling and discretization + -- * Split + splitReactive, + + -- * Sampling continous, continousWith, sample, -- TODO -- window, -- windowed, + ) where -- Reactive values, or piecewise functions of time. 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 @@ -36,7 +36,7 @@ -- * The Reversible class Reversible(..), - -- * Reversed values + -- * Reversing reversed, revDefault, @@ -90,7 +90,7 @@ -- @ -- -- @ --- 'rev' s ``transform`` a = 'rev' (s ``transform`` a) +-- 'rev' s `transform` a = 'rev' (s `transform` a) -- @ -- -- or equivalently, @@ -168,6 +168,7 @@ -- revDefault x = (stretch (-1) `whilst` undelaying (_position x 0.5 .-. 0)) x revDefault x = stretch (-1) x + newtype NoReverse a = NoReverse { getNoReverse :: a } deriving (Typeable, Eq, Ord, Show) @@ -180,8 +181,8 @@ -- | -- View the reverse of a value. -- --- >>> [1,2,3] & reversed %~ sort --- > [3,2,1] +-- >>> [1,2,3] & reversed %~ Data.List.sort +-- [3,2,1] -- reversed :: Reversible a => Iso' a a reversed = iso rev rev 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 @@ -33,22 +33,24 @@ -- * Score type Score, + -- * Query + -- * Construction score, - - -- ** Extracting values notes, + eras, events, - - -- ** Pattern matching singleNote, - -- ** Unsafe versions - unsafeNotes, - unsafeEvents, - + -- * Traversal + mapWithSpan, + filterWithSpan, + mapFilterWithSpan, + mapEvents, + filterEvents, + mapFilterEvents, - -- * Simultaneous values + -- * Simultaneous -- TODO check for overlapping values etc simult, simultaneous, @@ -56,15 +58,11 @@ -- * Normalize normalizeScore, printEras, - - -- * Traversing - mapWithSpan, - filterWithSpan, - mapFilterWithSpan, - mapEvents, - filterEvents, - mapFilterEvents, + -- * Unsafe versions + unsafeNotes, + unsafeEvents, + ) where import Data.AffineSpace @@ -77,6 +75,7 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.VectorSpace +import Data.String import Data.Functor.Adjunction (unzipR) import Music.Time.Juxtapose (scat) @@ -168,6 +167,7 @@ mzero = mempty mplus = mappend +{- instance FunctorWithIndex Span Score where imap f = over (_Wrapped._2) $ imap f @@ -176,6 +176,7 @@ instance TraversableWithIndex Span Score where itraverse f (Score (m,x)) = fmap (\x -> Score (m,x)) $ itraverse f x +-} instance Transformable (Score a) where transform t (Score (m,x)) = Score (transform t m, transform t x) @@ -189,18 +190,21 @@ (m1, m2) = split t m (x1, x2) = split t x +-- TODO move these two "implementations" to NScore instance HasPosition (Score a) where - _onset (Score (_,x)) = _onset x - _offset (Score (_,x)) = _offset x - _position (Score (_,x)) = _position x + _position = _position . snd . view _Wrapped' . normalizeScore' + -- TODO clean up in terms of AddMeta and optimize instance HasDuration (Score a) where - _duration (Score (_,x)) = _duration x + _duration x = _offset x .-. _onset x -- Lifted instances +instance IsString a => IsString (Score a) where + fromString = pure . fromString + instance IsPitch a => IsPitch (Score a) where fromPitch = pure . fromPitch @@ -246,7 +250,9 @@ newtype NScore a = NScore { getNScore :: [ScoreNote a] } deriving ({-Eq, -}{-Ord, -}{-Show, -}Functor, Foldable, Traversable, Semigroup, Monoid, Typeable, Show, Eq) --- | Unsafe: Do not use 'Wrapped' instances +instance (Show a, Transformable a) => Show (Score a) where + show x = show (x^.notes) ++ "^.score" + instance Wrapped (NScore a) where type Unwrapped (NScore a) = [ScoreNote a] _Wrapped' = iso getNScore NScore @@ -269,6 +275,7 @@ mzero = mempty mplus = mappend +{- instance FunctorWithIndex Span NScore where imap = undefined -- TODO @@ -280,6 +287,7 @@ instance TraversableWithIndex Span NScore where itraverse = undefined -- TODO +-} instance Transformable (NScore a) where transform t (NScore xs) = NScore (fmap (transform t) xs) @@ -459,6 +467,7 @@ singleNote :: Prism' (Score a) (Note a) singleNote = unsafeNotes . single {-# INLINE singleNote #-} +{-# DEPRECATED singleNote "Use 'unsafeNotes . single'" #-} -- TODO make prism fail if score contains meta-data -- (or else second prism law is not satisfied) @@ -512,16 +521,38 @@ -- | Mainly useful for backends. normalizeScore :: Score a -> Score a -normalizeScore = reset . absDurations +normalizeScore = reset . normalizeScore' where reset x = set onset (view onset x `max` 0) x - absDurations = over (notes.each.era.delta._2) abs +normalizeScore' = over (notes . each . era) normalizeSpan +-- TODO version that reverses the values where appropriate +-- Use over (notes . each) normalizeNote or similar + +-- normalizeScore = reset . absDurations +-- where +-- reset x = set onset (view onset x `max` 0) x +-- absDurations = over (notes.each.era.delta._2) abs + +-- | +-- Extract all eras of the given score. +-- +-- >>> printEras $ scat [c,d,e :: Score Integer] +-- 0 <-> 1 +-- 1 <-> 2 +-- 2 <-> 3 +-- printEras :: Score a -> IO () -printEras = mapM_ print . toListOf (notes.each.era) +printEras = mapM_ print . toListOf eras -eras :: Transformable a => Score a -> [Span] -eras = toListOf (notes . each . era) +-- | +-- Print all eras of the given score. +-- +-- >>> toListOf eras $ scat [c,d,e :: Score Integer] +-- [0 <-> 1,1 <-> 2,2 <-> 3] +-- +eras :: Traversal' (Score a) Span +eras = notes . each . era chordEvents :: Transformable a => Span -> Score a -> [a] chordEvents s = fmap extract . filter ((== s) . view era) . view notes @@ -534,7 +565,7 @@ -- es :: [Era] -- evs :: [[a]] -- vs :: [(Time, Duration, [a])] - es = List.nub $ eras sc + es = List.nub $ toListOf eras sc evs = fmap (`chordEvents` sc) es vs = zipWith (\(view delta -> (t,d)) a -> (t,d,a)) es evs 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 @@ -37,18 +37,11 @@ -- $musicTimeBehaviorExamples -- (!^), -- behavior', - behavior, - -- ** Combinators - switch, - switch', - splice, - trim, - trimBefore, - trimAfter, - concatB, + -- * Construction + behavior, - -- * Common behaviors + -- ** Common versions line, unit, impulse, @@ -58,21 +51,35 @@ sine, cosine, + -- ** Combine + switch, + switch', + splice, + trim, + trimBefore, + trimAfter, + concatB, + -- * Segment type Segment, -- ** Examples -- $XXmusicTimeSegmentExamples + + -- * Construction segment, - -- ** Combinators + -- * Combine focusing, apSegments', apSegments, -- concatS, + -- * Bound type Bound, + -- * Query bounds, bounding, + -- * Combine trim, splice, bounded', @@ -355,7 +362,7 @@ -- View part of a 'Behavior' as a 'Segment'. -- -- @ --- 'line' & 'focusing' ``onSpan`` (2 '<->' 3) '*~' 0 +-- 'line' & 'focusing' `onSpan` (2 '<->' 3) '*~' 0 -- @ -- focusing :: Lens' (Behavior a) (Segment a) 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 @@ -35,8 +35,9 @@ -- * The Splittable class Splittable(..), + + -- * Miscellaneous splitAbs, - chunks, ) where @@ -72,12 +73,18 @@ -- -- @ -- '_duration' ('beginning' t x) + '_duration' ('ending' t x) = '_duration' x --- '_duration' ('beginning' t x) = t ``min`` '_duration' x iff t >= 0 --- '_duration' ('ending' t x) = '_duration' x - (t ``min`` '_duration' x) iff t >= 0 +-- '_duration' ('beginning' t x) = t `min` '_duration' x iff t >= 0 +-- '_duration' ('ending' t x) = '_duration' x - (t `min` '_duration' x) iff t >= 0 -- @ -- -- (Note that any of these three laws can be derived from the other two, so it is -- sufficient to prove two!). +-- +-- >>> (\x -> fmap (flip split x) [-2,-1,0,0.5,1,2]) $ (1::Duration) +-- [(0,1),(0,1),(0,1),((1/2),(1/2)),(1,0),(1,0)] +-- +-- >>> (\x -> fmap (flip split x) [-2,-1,0,0.5,1,2]) $ (0<->1) +-- [(0 <-> 0,0 <-> 1),(0 <-> 0,0 <-> 1),(0 <-> 0,0 <-> 1),(0 <-> (1/2),(1/2) <-> 1),(0 <-> 1,1 <-> 1),(0 <-> 1,1 <-> 1)] -- class Splittable a where split :: Duration -> a -> (a, a) 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 @@ -29,14 +29,12 @@ ------------------------------------------------------------------------------------- module Music.Time.Stretched ( - - -- * Stretched values + -- * Stretched type Stretched, -- * Construction stretched, stretchedValue, - ) where import Data.AffineSpace @@ -49,11 +47,9 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.VectorSpace +import Data.String import Data.Functor.Couple -import Music.Time.Reverse -import Music.Time.Split - import Control.Applicative import Control.Comonad import Control.Comonad.Env @@ -65,6 +61,12 @@ import Data.PairMonad import Data.Typeable +import Music.Dynamics.Literal +import Music.Pitch.Literal +import Music.Time.Reverse +import Music.Time.Split + + -- | -- A 'Stretched' value has a known 'duration', but no 'position'. -- @@ -82,9 +84,6 @@ -- @ -- --- TODO move -deriving instance Traversable (Couple a) - -- >>> stretch 2 $ (5,1)^.stretched -- (10,1)^.stretched -- @@ -96,14 +95,12 @@ deriving instance Num a => Num (Stretched a) deriving instance Fractional a => Fractional (Stretched a) deriving instance Floating a => Floating (Stretched a) - deriving instance Ord a => Ord (Stretched a) deriving instance Real a => Real (Stretched a) deriving instance RealFrac a => RealFrac (Stretched a) deriving instance Typeable1 Stretched --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (Stretched a) where type Unwrapped (Stretched a) = (Duration, a) _Wrapped' = iso (getCouple . _stretchedValue) (Stretched . Couple) @@ -123,8 +120,23 @@ beginning d = over _Wrapped $ \(s, v) -> (beginning d s, beginning d v) ending d = over _Wrapped $ \(s, v) -> (ending d s, ending d v) -deriving instance Show a => Show (Stretched a) +instance (Show a, Transformable a) => Show (Stretched a) where + show x = show (x^.from stretched) ++ "^.stretched" +-- Lifted instances + +instance IsString a => IsString (Stretched a) where + fromString = pure . fromString + +instance IsPitch a => IsPitch (Stretched a) where + fromPitch = pure . fromPitch + +instance IsInterval a => IsInterval (Stretched a) where + fromInterval = pure . fromInterval + +instance IsDynamics a => IsDynamics (Stretched a) where + fromDynamics = pure . fromDynamics + -- | -- View a stretched value as a pair of the original value and a stretch factor. -- @@ -139,9 +151,6 @@ stretchedValue = lens runStretched (flip $ _stretched . const) where _stretched f (Stretched (Couple (d, x))) = Stretched (Couple (d, f `whilst` stretching d $ x)) + runStretched = uncurry stretch . view _Wrapped {-# INLINE stretchedValue #-} -runStretched :: Transformable a => Stretched a -> a -runStretched = uncurry stretch . view _Wrapped - --- JUNK 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 @@ -79,7 +79,7 @@ -- newtype Track a = Track { getTrack :: TrackList (TrackEv a) } deriving (Functor, Foldable, Traversable, Semigroup, Monoid, Typeable, Show, Eq) -{-# DEPRECATED Track "Use 'Chord'" #-} +-- {-# DEPRECATED Track "Use 'Chord'" #-} -- A track is a list of events with explicit onset. -- @@ -113,7 +113,6 @@ return = view _Unwrapped . return . return xs >>= f = view _Unwrapped $ (view _Wrapped . f) `mbind` view _Wrapped xs --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (Track a) where type Unwrapped (Track a) = (TrackList (TrackEv a)) _Wrapped' = iso getTrack Track diff --git a/src/Music/Time/Transform.hs b/src/Music/Time/Transform.hs --- a/src/Music/Time/Transform.hs +++ b/src/Music/Time/Transform.hs @@ -36,27 +36,23 @@ Transformable(..), itransform, transformed, - - -- * Apply under a transformation whilst, spanned, onSpan, - -- conjugateS, + conjugateS, -- * Specific transformations -- ** Transformations - delay, - undelay, - stretch, - compress, - - -- ** Transforming values delaying, undelaying, stretching, compressing, - -- * Utility + -- ** Transforming values + delay, + undelay, + stretch, + compress, delayTime, ) where 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 @@ -86,7 +86,29 @@ isProper, isBefore, encloses, + properlyEncloses, overlaps, + + afterOnset, + strictlyAfterOnset, + beforeOnset, + strictlyBeforeOnset, + afterOffset, + strictlyAfterOffset, + beforeOffset, + strictlyBeforeOffset, + + startsWhenStarts, + startsWhenStops, + stopsWhenStops, + stopsWhenStarts, + + startsBefore, + startsLater, + stopsAtTheSameTime, + stopsBefore, + stopsLater, + -- union -- intersection (alt name 'overlap') -- difference (would actually become a split) @@ -130,6 +152,7 @@ -- for 'Fractional' and 'RealFrac'. -- type TimeBase = Rational +-- type TimeBase = Fixed E12 {- type TimeBase = Fixed E12 @@ -264,8 +287,8 @@ -- | -- @length (offsetPoints x xs) = length xs + 1@ -- --- >>> offsetPoints 0 [1,2,1] --- [0,1,2,1] +-- >>> offsetPoints (0 ::Double) [1,2,1] +-- [0.0,1.0,3.0,4.0] -- -- @ -- offsetPoints :: 'AffineSpace' a => 'Time' -> ['Duration'] -> ['Time'] @@ -371,17 +394,17 @@ -- $musicTimeSpanIsos -- -- >>> (2 <-> 3)^.range --- > (2, 3) --- > --- >>> hs> (2 <-> 3)^.delta --- > (2, 1) --- > --- >>> hs> (10 >-> 5)^.range --- > (10, 15) --- > --- >>> hs> (10 >-> 5)^.delta --- > (10, 5) +-- (2,3) -- +-- >>> (2 <-> 3)^.delta +-- (2,1) +-- +-- >>> (10 >-> 5)^.range +-- (10,15) +-- +-- >>> (10 >-> 5)^.delta +-- (10,5) +-- instance Show Span where -- show = showDelta @@ -422,6 +445,10 @@ -- (b .-^ a) <-> b = a <-< b -- +infixl 6 <-> +infixl 6 >-> +infixl 6 <-< + -- | -- @t \<-\> u@ represents the span between @t@ and @u@. -- @@ -514,11 +541,8 @@ -- -- A span is either /forward/, /backward/ or /empty/. -- --- >>> any id [isForwardSpan x, isBackwardSpan x, isEmptySpan x] --- True --- --- >>> all not [isForwardSpan x, isBackwardSpan x, isEmptySpan x] --- False +-- @any id [isForwardSpan x, isBackwardSpan x, isEmptySpan x] == True@ +-- @all not [isForwardSpan x, isBackwardSpan x, isEmptySpan x] == False@ -- -- | @@ -571,23 +595,161 @@ isProper (view range -> (t, u)) = t < u {-# DEPRECATED isProper "Use 'isForwardSpan'" #-} +infixl 5 `inside` +infixl 5 `encloses` +infixl 5 `properlyEncloses` +infixl 5 `overlaps` +-- infixl 5 `encloses` +-- infixl 5 `encloses` +-- infixl 5 `encloses` + -- | -- Whether the given point falls inside the given span (inclusively). -- -- Designed to be used infix, for example -- --- @ --- 0.5 ``inside`` (1 '<->' 2) --- @ +-- >>> 0.5 `inside` 1 <-> 2 +-- False -- +-- >>> 1.5 `inside` 1 <-> 2 +-- True +-- +-- >>> 1 `inside` 1 <-> 2 +-- True +-- inside :: Time -> Span -> Bool inside x (view range -> (t, u)) = t <= x && x <= u -- | -- Whether the first given span encloses the second span. -- +-- >>> 0 <-> 3 `encloses` 1 <-> 2 +-- True +-- +-- >>> 0 <-> 2 `encloses` 1 <-> 2 +-- True +-- +-- >>> 1 <-> 3 `encloses` 1 <-> 2 +-- True +-- +-- >>> 1 <-> 2 `encloses` 1 <-> 2 +-- True +-- encloses :: Span -> Span -> Bool a `encloses` b = _onsetS b `inside` a && _offsetS b `inside` a + +-- | +-- Whether the first given span encloses the second span. +-- +-- >>> 0 <-> 3 `properlyEncloses` 1 <-> 2 +-- True +-- +-- >>> 0 <-> 2 `properlyEncloses` 1 <-> 2 +-- True +-- +-- >>> 1 <-> 3 `properlyEncloses` 1 <-> 2 +-- True +-- +-- >>> 1 <-> 2 `properlyEncloses` 1 <-> 2 +-- False +-- +properlyEncloses :: Span -> Span -> Bool +a `properlyEncloses` b = a `encloses` b && a /= b + + + +-- TODO more intuitive param order + +afterOnset :: Time -> Span -> Bool +t `afterOnset` s = t >= _onsetS s + +strictlyAfterOnset :: Time -> Span -> Bool +t `strictlyAfterOnset` s = t > _onsetS s + +beforeOnset :: Time -> Span -> Bool +t `beforeOnset` s = t <= _onsetS s + +strictlyBeforeOnset :: Time -> Span -> Bool +t `strictlyBeforeOnset` s = t < _onsetS s + +afterOffset :: Time -> Span -> Bool +t `afterOffset` s = t >= _offsetS s + +strictlyAfterOffset :: Time -> Span -> Bool +t `strictlyAfterOffset` s = t > _offsetS s + +beforeOffset :: Time -> Span -> Bool +t `beforeOffset` s = t <= _offsetS s + +strictlyBeforeOffset :: Time -> Span -> Bool +t `strictlyBeforeOffset` s = t < _offsetS s + + +-- Param order OK + +-- Name? +startsWhenStarts :: Span -> Span -> Bool +a `startsWhenStarts` b = _onsetS a == _onsetS b + +-- Name? +startsWhenStops :: Span -> Span -> Bool +a `startsWhenStops` b = _onsetS a == _offsetS b + +-- Name? +stopsWhenStops :: Span -> Span -> Bool +a `stopsWhenStops` b = _offsetS a == _offsetS b + +-- Name? +stopsWhenStarts :: Span -> Span -> Bool +a `stopsWhenStarts` b = _offsetS a == _onsetS b + + +startsBefore :: Span -> Span -> Bool +a `startsBefore` b = _onsetS a < _onsetS b + +startsLater :: Span -> Span -> Bool +a `startsLater` b = _onsetS a > _onsetS b + +stopsAtTheSameTime :: Span -> Span -> Bool +a `stopsAtTheSameTime` b = _offsetS a == _offsetS b + +stopsBefore :: Span -> Span -> Bool +a `stopsBefore` b = _offsetS a < _offsetS b + +stopsLater :: Span -> Span -> Bool +a `stopsLater` b = _offsetS a > _offsetS b + +{- +contains +curtails +delays +happensDuring +intersects +trisects +isCongruentTo +overlapsAllOf +overlapsOnlyOnsetOf +overlapsOnlyOffsetOf +overlapsOnsetOf +overlapsOffsetOf + + + +-} + +-- timespantools.timespan_2_starts_during_timespan_1 +-- timespantools.timespan_2_starts_when_timespan_1_starts +-- timespantools.timespan_2_starts_when_timespan_1_stops +-- timespantools.timespan_2_stops_after_timespan_1_starts +-- timespantools.timespan_2_stops_after_timespan_1_stops +-- timespantools.timespan_2_stops_before_timespan_1_starts +-- timespantools.timespan_2_stops_before_timespan_1_stops +-- timespantools.timespan_2_stops_during_timespan_1 +-- timespantools.timespan_2_stops_when_timespan_1_starts +-- timespantools.timespan_2_stops_when_timespan_1_stops +-- timespantools.timespan_2_trisects_timespan_1 + + -- | -- Whether the given span overlaps. 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 @@ -46,12 +46,14 @@ fuse, fuseBy, - -- ** Special cases + -- ** Fuse rests fuseRests, coverRests, - -- * Traversing + -- * Traversal -- ** Separating rhythms and values + valuesV, + durationsV, withValues, withDurations, rotateValues, @@ -65,6 +67,7 @@ zipVoice3, zipVoice4, zipVoiceNoScale, + -- FIXME compose with (lens assoc unassoc) for the 3 and 4 versions zipVoiceNoScale3, zipVoiceNoScale4, zipVoiceWith, @@ -95,6 +98,9 @@ import Data.Semigroup import Data.Set (Set) import qualified Data.Set as Set +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.String import Data.VectorSpace import Music.Time.Reverse @@ -123,8 +129,11 @@ -- A 'Voice' is a sequential composition of values. Events may not overlap. -- newtype Voice a = Voice { getVoice :: VoiceList (VoiceEv a) } - deriving (Functor, Foldable, Traversable, Semigroup, Monoid, Typeable, Show, Eq) + deriving (Functor, Foldable, Traversable, Semigroup, Monoid, Typeable, Eq) +instance (Show a, Transformable a) => Show (Voice a) where + show x = show (x^.stretcheds) ++ "^.voice" + -- -- $semantics Voice -- type Voice a = [Stretched a] @@ -146,9 +155,14 @@ -- Can use any type as long as voiceEv provides an Iso type VoiceEv a = Stretched a +-- type VoiceEv a = ((),Stretched a) voiceEv :: Iso (Stretched a) (Stretched b) (VoiceEv a) (VoiceEv b) voiceEv = id +-- voiceEv = iso add remove +-- where +-- add x = ((),x) +-- remove ((),x) = x instance Applicative Voice where pure = return @@ -166,7 +180,6 @@ mzero = mempty mplus = mappend --- | Unsafe: Do not use 'Wrapped' instances instance Wrapped (Voice a) where type Unwrapped (Voice a) = (VoiceList (VoiceEv a)) _Wrapped' = iso getVoice Voice @@ -197,26 +210,15 @@ where split' = error "TODO" - -- split' :: Time -> (Duration -> a -> (a,a)) -> [Stretched a] -> ([Stretched a], [Stretched a]) - -- split' t f = over both mcatMaybes . unzipR . snd . Data.List.mapAccumL go (0::Time) - -- where - -- go :: Time -> Stretched a -> (Time, (Maybe (Stretched a), Maybe (Stretched a))) - -- go currentOnset (view (from stretched) -> (d,x)) - -- = let currentOffset = currentOnset .+^ d - -- theSplit = if t <= currentOnset then (Nothing, Just (view stretched (d,x))) else - -- if currentOnset < t && t < currentOffset then - -- let x1 = x - -- x2 = x in - -- (Just (view stretched (t .-^ currentOnset,x1)), Just (view stretched (d ^-^ (t .-^ currentOnset),x2))) else - -- if currentOffset <= t then (Just (view stretched (d,x)), Nothing) else error "Impossible" - -- in (currentOnset .+^ d, theSplit) - instance Reversible a => Reversible (Voice a) where rev = over _Wrapped' (fmap rev) -- TODO OK? -- Lifted instances +instance IsString a => IsString (Voice a) where + fromString = pure . fromString + instance IsPitch a => IsPitch (Voice a) where fromPitch = pure . fromPitch @@ -329,6 +331,7 @@ singleStretched :: Prism' (Voice a) (Stretched a) singleStretched = unsafeStretcheds . single {-# INLINE singleStretched #-} +{-# DEPRECATED singleStretched "Use 'unsafeStretcheds . single'" #-} -- | @@ -396,7 +399,7 @@ -- Join the given voices without combining durations. -- zipVoiceWithNoScale :: (a -> b -> c) -> Voice a -> Voice b -> Voice c -zipVoiceWithNoScale f a b = zipVoiceWith' (\x y -> x) f a b +zipVoiceWithNoScale = zipVoiceWith' const -- | -- Join the given voices by combining durations and values using the given function. @@ -451,7 +454,7 @@ merge (Just x) Nothing = True merge Nothing (Just x) = True merge (Just x) (Just y) = False - hasOnlyRests = all isNothing $ toListOf traverse x -- norm + hasOnlyRests = all isNothing $ toListOf traverse x -- norm withContext :: Voice a -> Voice (Ctxt a) @@ -523,7 +526,7 @@ reverseValues :: Voice a -> Voice a reverseValues = over valuesV reverse --- Lens "filtered" throuygh a voice +-- Lens "filtered" through a voice voiceLens :: (s -> a) -> (b -> s -> t) -> Lens (Voice s) (Voice t) (Voice a) (Voice b) voiceLens getter setter = lens (fmap getter) (flip $ zipVoiceWithNoScale setter) @@ -548,4 +551,184 @@ -- Implement meta-data -- +-- List functions +headV, lastV :: Voice a -> Maybe (Stretched a) +headV = preview _head +lastV = preview _head + +tailV, initV :: Voice a -> Maybe (Voice a) +tailV = preview _tail +initV = preview _init + +consV :: Stretched a -> Voice a -> Voice a +unconsV :: Voice a -> Maybe (Stretched a, Voice a) +consV = cons +unconsV = uncons + +snocV :: Voice a -> Stretched a -> Voice a +unsnocV :: Voice a -> Maybe (Voice a, Stretched a) +snocV = snoc +unsnocV = unsnoc + +nullV :: Voice a -> Bool +nullV = nullOf eventsV + +lengthV :: Voice a -> Int +lengthV = lengthOf eventsV + +mapV :: (a -> b) -> Voice a -> Voice b +mapV = fmap + + +-- Voice-specific + +sameDurations :: Voice a -> Voice b -> Bool +sameDurations a b = view durationsV a == view durationsV b + +mergeIfSameDuration :: Voice a -> Voice b -> Maybe (Voice (a, b)) +mergeIfSameDuration = mergeIfSameDurationWith (,) + +mergeIfSameDurationWith :: (a -> b -> c) -> Voice a -> Voice b -> Maybe (Voice c) +mergeIfSameDurationWith f a b + | sameDurations a b = Just $ zipVoiceWithNoScale f a b + | otherwise = Nothing + +-- splitAt :: [Duration] -> Voice a -> [Voice a] +-- splitTiesVoiceAt :: Tiable a => [Duration] -> Voice a -> [Voice a] + +-- | +-- Split all notes of the latter voice at the onset/offset of the former. +-- +-- >>> ["a",(2,"b")^.stretched,"c"]^.voice +-- [(1,"a")^.stretched,(2,"b")^.stretched,(1,"c")^.stretched]^.voice +-- +splitLatterToAssureSameDuration :: Voice b -> Voice b -> Voice b +splitLatterToAssureSameDuration = splitLatterToAssureSameDurationWith dup + where + dup x = (x,x) + +splitLatterToAssureSameDurationWith :: (b -> (b, b)) -> Voice b -> Voice b -> Voice b +splitLatterToAssureSameDurationWith = undefined + +polyToHomophonic :: [Voice a] -> Maybe (Voice [a]) +polyToHomophonic = undefined + +polyToHomophonicForce :: [Voice a] -> Voice [a] +polyToHomophonicForce = undefined + +homoToPolyphonic :: Voice [a] -> [Voice a] +homoToPolyphonic = undefined + +changeCrossing :: Ord a => Voice a -> Voice a -> (Voice a, Voice a) +changeCrossing = undefined + +changeCrossingBy :: Ord b => (a -> b) -> Voice a -> Voice a -> (Voice a, Voice a) +changeCrossingBy = undefined + +processExactOverlaps :: (a -> a -> (a, a)) -> Voice a -> Voice a -> (Voice a, Voice a) +processExactOverlaps = undefined + +processExactOverlaps' :: (a -> b -> Either (a,b) (b,a)) -> Voice a -> Voice b -> (Voice (Either b a), Voice (Either a b)) +processExactOverlaps' = undefined + +onsetsRelative :: Time -> Voice a -> [Time] +onsetsRelative = undefined + +offsetsRelative :: Time -> Voice a -> [Time] +offsetsRelative = undefined + +midpointsRelative :: Time -> Voice a -> [Time] +midpointsRelative = undefined + +erasRelative :: Time -> Voice a -> [Span] +erasRelative = undefined + +onsetMap :: Time -> Voice a -> Map Time a +onsetMap = undefined + +offsetMap :: Time -> Voice a -> Map Time a +offsetMap = undefined + +midpointMap :: Time -> Voice a -> Map Time a +midpointMap = undefined + +eraMap :: Time -> Voice a -> Map Span a +eraMap = undefined + +durations :: Voice a -> [Duration] +durations = undefined + +-- values :: Voice a -> [a] -- Same as Foldable.toList +-- values = undefined + + + +{- + +sameDurations :: Voice a -> Voice b -> Bool +mergeIfSameDuration :: Voice a -> Voice b -> Maybe (Voice (a, b)) +mergeIfSameDurationWith :: (a -> b -> c) -> Voice a -> Voice b -> Maybe (Voice c) +splitAt :: [Duration] -> Voice a -> [Voice a] +-- splitTiesVoiceAt :: Tiable a => [Duration] -> Voice a -> [Voice a] +splitLatterToAssureSameDuration :: Voice b -> Voice b -> Voice b +splitLatterToAssureSameDurationWith :: (b -> (b, b)) -> Voice b -> Voice b -> Voice b +polyToHomophonic :: [Voice a] -> Maybe (Voice [a]) +polyToHomophonicForce :: [Voice a] -> Voice [a] +homoToPolyphonic :: Voice [a] -> [Voice a] +joinVoice :: Voice (Voice a) -> a +changeCrossing :: Ord a => Voice a -> Voice a -> (Voice a, Voice a) +changeCrossingBy :: Ord b => (a -> b) -> Voice a -> Voice a -> (Voice a, Voice a) +processExactOverlaps :: (a -> a -> (a, a)) -> Voice a -> Voice a -> (Voice a, Voice a) +processExactOverlaps' :: (a -> b -> Either (a,b) (b,a)) -> Voice a -> Voice b -> (Voice (Either b a), Voice (Either a b)) +onsetsRelative :: Time -> Voice a -> [Time] +offsetsRelative :: Time -> Voice a -> [Time] +midpointsRelative :: Time -> Voice a -> [Time] +erasRelative :: Time -> Voice a -> [Span] +onsetMap :: Time -> Voice a -> Map Time a +offsetMap :: Time -> Voice a -> Map Time a +midpointMap :: Time -> Voice a -> Map Time a +eraMap :: Time -> Voice a -> Map Span a +durations :: Voice a -> [Duration] +values :: Voice a -> [a] -- Same as Foldable.toList +isPossiblyInfinite :: Voice a -> Bool +hasMelodicDissonanceWith :: (a -> a -> Bool) -> Voice a -> Bool +hasIntervalWith :: AffineSpace a => (Diff a -> Bool) -> Voice a -> Bool +hasDurationWith :: (Duration -> Bool) -> Voice a -> Bool +reifyVoice :: Voice a -> Voice (Duration, a) +mapWithIndex :: (Int -> a -> b) -> Voice a -> Voice b +mapWithDuration :: (Duration -> a -> b) -> Voice a -> Voice b +mapWithIndexAndDuration :: (Int -> Duration -> a -> b) -> Voice a -> Voice b +_ :: Iso (Voice ()) [Duration] +asingleton' :: Prism (Voice a) (Duration, a) +asingleton :: Prism (Voice a) a +separateVoicesWith :: (a -> k) -> Voice a -> Map k (Voice a) +freeVoiceR :: (forall a. -> [a] -> a) -> Voice a -> (a, Duration) +freeVoiceRNoDur :: ([a] -> a) -> Voice a -> a +freeVoice :: (forall a. -> [a] -> [a]) -> Voice a -> Voice a +freeVoice2 :: (forall a. -> [a] -> [a] -> [a]) -> Voice a -> Voice a -> Voice a +empty :: Voice a +singleton :: a -> Voice a +cons :: a -> Voice a -> Voice a +snoc :: Voice a -> a -> Voice a +append :: Voice a -> Voice a -> Voice a +ap :: Voice (a -> b) -> Voice a -> Voice b +apDur :: Voice (Duration -> Duration -> a -> b) -> Voice a -> Voice b +intersperse :: Duration -> a -> Voice a -> Voice a +-- intercalate :: Voice a -> Voice (Voice a) -> Voice a +subsequences :: Voice a -> [Voice a] +permutations :: Voice a -> [Voice a] +iterate :: (a -> a) -> a -> Voice a +repeat :: a -> Voice a +replicate :: Int -> a -> Voice a +unfoldr :: (b -> Maybe (a, b)) -> b -> Voice a +Differences between Voice and Chord (except the obviously different composition styles): + - Voice is a Monoid, Chord just a Semigroup (??) + - TODO represent spanners using (Voice a, Map (Int,Int) s) + Arguably this should be part of Voice + TODO the MVoice/TVoice stuff +newtype MVoice = Voice (Maybe a) +newtype PVoice = [Either Duration (Voice a)] +expandRepeats :: [Voice (Variant a)] -> Voice a + +-}