packages feed

music-score 1.6.2 → 1.7

raw patch · 85 files changed

+11672/−6178 lines, 85 filesdep +adjunctionsdep +colourdep +contravariantdep −monoid-extrasdep ~lensdep ~lilyponddep ~music-dynamics-literal

Dependencies added: adjunctions, colour, contravariant, distributive

Dependencies removed: monoid-extras

Dependency ranges changed: lens, lilypond, music-dynamics-literal, music-pitch-literal, musicxml2

Files

music-score.cabal view
@@ -1,6 +1,6 @@  name:                   music-score-version:                1.6.2+version:                1.7 author:                 Hans Hoglund maintainer:             Hans Hoglund license:                BSD3@@ -21,53 +21,68 @@   location:         	git://github.com/music-suite/music-score.git    library                    -    build-depends: 		base				>= 4 && < 5,-                        lens				>= 4.0 && < 4.1,+    build-depends:      base				            >= 4   && < 5,+                        lens				            >= 4.1.2 && < 4.2,                         process,                         data-default,                                    containers,                                comonad,-                        NumInstances,                         profunctors,                         transformers,+                        distributive,+                        adjunctions,+                        NumInstances,                         monadplus,                         void,                         semigroups              >= 0.13.0.1 && < 1,-                        monoid-extras,+                        -- monoid-extras,+                        contravariant           >= 0.4.4 && < 1,                         nats,                                   semigroupoids,+                        colour                  >= 2.3.3 && < 3.0,                         HCodecs                 >= 0.3 && < 0.4,                         vector-space,                         vector-space-points     == 0.1.3,-                        musicxml2               == 1.6.2,-                        lilypond                == 1.6.2,-                        music-pitch-literal     == 1.6.2,-                        music-dynamics-literal  == 1.6.2,+                        musicxml2               == 1.7,+                        lilypond                == 1.7,+                        music-pitch-literal     == 1.7,+                        music-dynamics-literal  == 1.7,                         prettify,                         parsec-    exposed-modules:	Data.PairMonad+    exposed-modules:	  Data.Clipped+                        Data.PairMonad+                        Data.Functor.Couple+                        Data.Functor.Context+                        Data.Functor.Rep.Lens+                        Data.Semigroup.Instances                         Control.Monad.Compose                         Music.Time-                        Music.Time.Delayable-                        Music.Time.Stretchable-                        Music.Time.Onset-                        Music.Time.Juxtapose+                        Music.Time.Types+                        Music.Time.Transform+                        Music.Time.Duration+                        Music.Time.Position+                        Music.Time.Split                         Music.Time.Reverse-                        Music.Time.Time-                        Music.Time.Span-                        Music.Time.Reactive+                        Music.Time.Juxtapose+                        Music.Time.Rest+                        Music.Time.Stretched+                        Music.Time.Delayed+                        Music.Time.Note+                        Music.Time.Track+                        Music.Time.Voice+                        Music.Time.Chord+                        Music.Time.Score+                        -- Music.Time.Linear   ?+                        -- Music.Time.Spline   ?+                        Music.Time.Segment                         Music.Time.Behavior-                        Music.Score.Rhythm+                        Music.Time.Reactive+                        Music.Time.Bound+                        Music.Time.Meta                         Music.Score-                        Music.Score.Note-                        Music.Score.Track-                        Music.Score.Voice-                        Music.Score.Score-                        Music.Score.Combinators-                        Music.Score.Convert                         Music.Score.Ties                         Music.Score.Part-                        Music.Score.Chord+                        Music.Score.Phrases                         Music.Score.Meta                         Music.Score.Meta.Annotations                         Music.Score.Meta.Attribution@@ -83,17 +98,31 @@                         Music.Score.Pitch                         Music.Score.Articulation                         Music.Score.Dynamics-                        Music.Score.Ornaments+                        Music.Score.Slide+                        Music.Score.Tremolo+                        Music.Score.Text+                        Music.Score.Harmonics+                        Music.Score.Color                         Music.Score.Export.Abc+                        Music.Score.Export.Backend+                        Music.Score.Export.NoteList+                        Music.Score.Export.Midi+                        Music.Score.Export.SuperCollider                         Music.Score.Export.Lilypond                         Music.Score.Export.MusicXml-                        Music.Score.Export.Midi+                        Music.Score.Export.ArticulationNotation+                        Music.Score.Export.DynamicNotation                         Music.Score.Import.Abc                         Music.Score.Import.Lilypond                         Music.Score.Import.Midi-                        -- Need to expose these to allow GHCI development-                        Music.Score.Util-                        Music.Score.Export.Common-    other-modules:      Music.Score.Instances-    hs-source-dirs: 	src+                        Music.Score.Convert+                        Music.Score.Instances+                        -- We expose these to allow GHCI development+                        Music.Time.Internal.Util+                        Music.Time.Internal.Transform+                        Music.Time.Internal.Quantize+                        Music.Score.Internal.Util+                        Music.Score.Internal.Export+    hs-source-dirs: 	  src     default-language: 	Haskell2010+    --ghc-options:        -fwarn-unused-imports
+ src/Data/Clipped.hs view
@@ -0,0 +1,116 @@++{-# LANGUAGE CPP                        #-}+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE ViewPatterns               #-}++module Data.Clipped (+    -- * Data.Clipped+    Clipped,+    clipped,+    fromClipped,+    -- ** Unsafe operations+    unsafeToClipped,+    -- unclipped,    +  ) where++-----+import Data.Fixed+import           Data.Default+import           Data.Ratio++import           Control.Applicative+import           Control.Arrow                (first, second, (***), (&&&))+import qualified Control.Category+import           Control.Comonad+import           Control.Comonad.Env+import           Control.Lens                 hiding (Indexable, Level, above,+                                               below, index, inside, parts,+                                               reversed, transform, (|>), (<|))+import           Control.Monad+import           Control.Monad.Plus+import           Data.AffineSpace+import           Data.AffineSpace.Point+import           Data.Distributive+import           Data.Foldable                (Foldable)+import qualified Data.Foldable                as Foldable+import           Data.Functor.Rep+import qualified Data.List+import           Data.List.NonEmpty           (NonEmpty)+import           Data.Maybe+import           Data.NumInstances+import           Data.Semigroup               hiding ()+import           Data.Sequence                (Seq)+import qualified Data.Sequence                as Seq+import           Data.Traversable             (Traversable)+import qualified Data.Traversable             as T+import           Data.Typeable+import           Data.VectorSpace hiding (Sum(..))+import           Music.Dynamics.Literal+import           Music.Pitch.Literal++import qualified Data.Ratio                   as Util_Ratio+import qualified Data.List as List+import qualified Data.Foldable as Foldable+import qualified Data.Ord as Ord+-----++-- | A value in the unit interval /(0,1)/.+newtype Clipped a = UnsafeClip { unsafeGetClipped :: a }+  deriving (Eq, Ord, Show)++instance Num a => Bounded (Clipped a) where+  minBound = UnsafeClip 0+  maxBound = UnsafeClip 1++instance (Num a, Ord a) => Num (Clipped a) where+  a + b = unsafeToClipped (fromClipped a + fromClipped b)+  a - b = unsafeToClipped (fromClipped a - fromClipped b)+  a * b = unsafeToClipped (fromClipped a * fromClipped b)+  abs   = id+  signum 0 = 0+  signum _ = 1+  negate = error "negate: No instance for Clipped"+  fromInteger = unsafeToClipped . fromInteger++instance (Num a, Ord a, Fractional a) => Fractional (Clipped a) where+  a / b = unsafeToClipped (fromClipped a / fromClipped b)+  recip 1 = 1+  recip _ = error "Can not take reciprocal of a clipped value other than 1"+  fromRational = unsafeToClipped . fromRational++unsafeToClipped   = fromMaybe (error "Outside 0-1") . (^? clipped)+fromClipped = (^. unclipped)++clipped :: (Num a, Ord a) => Prism' a (Clipped a)+clipped = prism unsafeGetClipped $+  \x -> if 0 <= x && x <= 1+      then Right (UnsafeClip x)+      else Left x++unclipped :: (Num a, Ord a) => Getter (Clipped a) a+unclipped = re clipped++zipClippedWith+  :: (Num a, Ord a,+      Num b, Ord b,+      Num c, Ord c)+  => (a -> b -> c)+  -> Clipped a -> Clipped b -> Maybe (Clipped c)+zipClippedWith f a b = ((a^.unclipped) `f` (b^.unclipped))^? clipped++addLim = zipClippedWith (+)
+ src/Data/Functor/Context.hs view
@@ -0,0 +1,17 @@++module Data.Functor.Context (+        Ctxt(..),+        mapCtxt,+        extractCtxt,+  ) where++-- TODO use newtype and derivice Functor, Comonad etc+type Ctxt a = (Maybe a, a, Maybe a)+++mapCtxt :: (a -> b) -> Ctxt a -> Ctxt b+mapCtxt f (a,b,c) = (fmap f a, f b, fmap f c)++extractCtxt :: Ctxt a -> a+extractCtxt (_,x,_) = x+
+ src/Data/Functor/Couple.hs view
@@ -0,0 +1,92 @@+++{-# LANGUAGE CPP,+             GeneralizedNewtypeDeriving,+             DeriveDataTypeable,+             DeriveFunctor,+             DeriveTraversable,+             DeriveFoldable,+             MultiParamTypeClasses,+             TypeFamilies+             #-}+module Data.Functor.Couple where++import Data.Functor.Product+import Data.Functor.Identity+import Data.Foldable+import Data.Traversable+import Data.Functor.Adjunction (unzipR)+import Data.Semigroup+import Data.Typeable+import Control.Applicative+import Control.Comonad+import Data.PairMonad ()+import Control.Arrow (first)+import Control.Lens (Wrapped(..), Rewrapped(..), iso)++-- |+-- A variant of pair/writer with lifted instances for the numeric classes, using 'Applicative'.+--+newtype Couple b a = Couple { getCouple :: (b, a) }+  deriving (Eq, Show, Functor, Foldable, Typeable, Applicative, Monad, Comonad)++-- | Unsafe: Do not use 'Wrapped' instances+instance Wrapped (Couple b a) where+  type Unwrapped (Couple b a) = (b, a)+  _Wrapped' = iso getCouple Couple++instance Rewrapped (Couple c a) (Couple c b)++instance (Monoid b, Num a) => Num (Couple b a) where+  (+) = liftA2 (+)+  (*) = liftA2 (*)+  (-) = liftA2 (-)+  abs = fmap abs+  signum = fmap signum+  fromInteger = pure . fromInteger++instance (Monoid b, Fractional a) => Fractional (Couple b a) where+  recip        = fmap recip+  fromRational = pure . fromRational++instance (Monoid b, Floating a) => Floating (Couple b a) where+  pi    = pure pi+  sqrt  = fmap sqrt+  exp   = fmap exp+  log   = fmap log+  sin   = fmap sin+  cos   = fmap cos+  asin  = fmap asin+  atan  = fmap atan+  acos  = fmap acos+  sinh  = fmap sinh+  cosh  = fmap cosh+  asinh = fmap asinh+  atanh = fmap atanh+  acosh = fmap acos++instance (Monoid b, Enum a) => Enum (Couple b a) where+  toEnum = pure . toEnum+  fromEnum = fromEnum . extract++instance (Monoid b, Bounded a) => Bounded (Couple b a) where+  minBound = pure minBound+  maxBound = pure maxBound++-- The following are more suspect, as they require Ord++instance (Monoid b, Ord b, Ord a) => Ord (Couple b a) where+  Couple (a,b) < Couple (a',b') = (b,a) < (b',a')++instance (Monoid b, Ord b, Real a, Enum a, Integral a) => Integral (Couple b a) where+  quot = liftA2 quot+  rem  = liftA2 rem+  quotRem = fmap (fmap unzipR) (liftA2 quotRem)+  toInteger = toInteger . extract  ++instance (Monoid b, Ord b, Real a) => Real (Couple b a) where+  toRational = toRational . extract++instance (Monoid b, Ord b, RealFrac a) => RealFrac (Couple b a) where+  properFraction = first extract . unzipR . fmap properFraction+
+ src/Data/Functor/Rep/Lens.hs view
@@ -0,0 +1,30 @@++module Data.Functor.Rep.Lens where++import Control.Lens hiding (index)+import Data.Functor.Rep++-- $dataFunctorRepLens+-- Provides access to the definition in "Data.Functor.Rep" in terms of "Control.Lens".++-- |+-- Index a representable functor.+--+-- This is an infix alias for 'index'.+--+(!) :: Representable f => f a -> Rep f -> a+(!) = index++infixl 6 !++-- |+-- The isomorpism between a representable functor and its representation.+--+-- @+-- 'tabulated' = 'iso' 'tabulate' 'index'+-- @+--+tabulated :: (Representable f, Representable g) => Iso (Rep f -> a) (Rep g -> b) (f a) (g b)+tabulated = iso tabulate index++
+ src/Data/Semigroup/Instances.hs view
@@ -0,0 +1,78 @@++{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Data.Semigroup.Instances () where++import Data.Semigroup+import Data.VectorSpace hiding (Sum)+import Data.AffineSpace+import Control.Applicative+import Music.Pitch.Literal+import Music.Dynamics.Literal++-- TODO move these to semigroups and music-pitch-literal++deriving instance Num a => Num (Sum a)+deriving instance Real a => Real (Sum a)+deriving instance Fractional a => Fractional (Sum a)+deriving instance AdditiveGroup a => AdditiveGroup (Sum a)++instance VectorSpace a => VectorSpace (Sum a) where+  type Scalar (Sum a) = Scalar a+  s *^ Sum v = Sum (s *^ v)++instance AffineSpace a => AffineSpace (Sum a) where+  type Diff (Sum a) = Sum (Diff a)+  Sum p .-. Sum q = Sum (p .-. q)+  Sum p .+^ Sum v = Sum (p .+^ v)+++deriving instance Num a => Num (Product a)+deriving instance Real a => Real (Product a)+deriving instance Fractional a => Fractional (Product a)+deriving instance AdditiveGroup a => AdditiveGroup (Product a)++instance VectorSpace a => VectorSpace (Product a) where+  type Scalar (Product a) = Scalar a+  x *^ Product y = Product (x *^ y)++instance AffineSpace a => AffineSpace (Product a) where+  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)+deriving instance IsDynamics a => IsDynamics (Product a)+deriving instance IsPitch a => IsPitch (Sum a)+deriving instance IsPitch a => IsPitch (Product a)++deriving instance Functor Product+instance Applicative Product where+  pure = Product+  Product f <*> Product x = Product (f x)++deriving instance Functor Sum+instance Applicative Sum where+  pure = Sum+  Sum f <*> Sum x = Sum (f x)+++{-+deriving instance Floating a => Floating (Product a)+instance Num a => Num (Product a) where+  fromInteger = pure . fromInteger+  abs    = fmap abs+  signum = fmap signum+  (+)    = liftA2 (+)+  (-)    = liftA2 (-)+  (*)    = liftA2 (*)+instance Fractional a => Fractional (Product a) where+  fromRational = pure . fromRational+  (/) = liftA2 (/)+instance Real a => Real (Product a) where+  toRational (Product x) = toRational x+-}
src/Music/Score.hs view
@@ -1,7 +1,7 @@  ------------------------------------------------------------------------------------- -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund 2012-2014 -- -- License     : BSD-style --@@ -15,6 +15,8 @@  module Music.Score (         -- * Prerequisites+        module Control.Lens,+        module Control.Applicative,         module Control.Monad,         module Control.Monad.Plus,         module Data.Semigroup,@@ -22,23 +24,25 @@         module Data.AffineSpace,         module Data.AffineSpace.Point, -        -- * Basic types         module Music.Time,--        -- * Musical container types-        module Music.Score.Note,-        module Music.Score.Track,-        module Music.Score.Voice,-        module Music.Score.Score,-        module Music.Score.Convert,+        -- module Music.Score.Combinators, -        -- * Manipulation-        -- ** Combinators-        module Music.Score.Combinators,+        -- * Music representation+        -- ** Musical elements+        module Music.Score.Part,+        module Music.Score.Pitch,+        module Music.Score.Dynamics,+        module Music.Score.Articulation,+        module Music.Score.Slide,+        module Music.Score.Tremolo,+        module Music.Score.Text,+        module Music.Score.Harmonics,+        module Music.Score.Color, -        -- ** Structure+        -- ** Miscellaneous         module Music.Score.Ties,-        module Music.Score.Chord,+        module Music.Score.Phrases,+        module Music.Score.Clef,          -- ** Meta-information         module Music.Score.Meta,@@ -52,28 +56,27 @@         module Music.Score.Meta.Time,         module Music.Score.Meta.Tempo,         module Music.Score.Meta.Annotations,-        module Music.Score.Clef, -        -- ** Musical elements-        module Music.Score.Part,-        module Music.Score.Pitch,-        module Music.Score.Dynamics,-        module Music.Score.Articulation,-        module Music.Score.Ornaments,-         -- * Import and export         module Music.Score.Import.Abc,         module Music.Score.Import.Lilypond,         module Music.Score.Import.Midi, -        module Music.Score.Export.Abc,+        -- module Music.Score.Export.Abc,+        module Music.Score.Export.Backend,+        module Music.Score.Export.NoteList,         module Music.Score.Export.Midi,+        module Music.Score.Export.SuperCollider,         module Music.Score.Export.Lilypond,         module Music.Score.Export.MusicXml, ) where  import           Control.Applicative+import           Control.Lens                   hiding (Level, above, below,+                                                 inside, parts, reversed,+                                                 rewrite, simple, transform,+                                                 (<.>), (<|), (|>)) import           Control.Monad                  hiding (mapM) import           Control.Monad.Plus import           Data.AffineSpace@@ -88,22 +91,25 @@ import           Data.Typeable import           Data.VectorSpace               hiding (Sum, getSum) -import           Music.Time+import           Music.Time                     hiding (time)  import           Music.Score.Articulation-import           Music.Score.Chord import           Music.Score.Clef-import           Music.Score.Combinators-import           Music.Score.Convert+import           Music.Score.Color import           Music.Score.Dynamics+import           Music.Score.Export.Backend+import           Music.Score.Export.NoteList+import           Music.Score.Export.Midi+import           Music.Score.Export.SuperCollider import           Music.Score.Export.Abc import           Music.Score.Export.Lilypond import           Music.Score.Export.Midi import           Music.Score.Export.MusicXml+import           Music.Score.Harmonics import           Music.Score.Import.Abc import           Music.Score.Import.Lilypond import           Music.Score.Import.Midi-import           Music.Score.Instances          ()+import           Music.Score.Instances import           Music.Score.Meta import           Music.Score.Meta.Annotations import           Music.Score.Meta.Attribution@@ -115,13 +121,10 @@ import           Music.Score.Meta.Tempo import           Music.Score.Meta.Time import           Music.Score.Meta.Title-import           Music.Score.Note-import           Music.Score.Ornaments import           Music.Score.Part+import           Music.Score.Phrases import           Music.Score.Pitch-import           Music.Score.Rhythm-import           Music.Score.Score+import           Music.Score.Slide+import           Music.Score.Text import           Music.Score.Ties-import           Music.Score.Track-import           Music.Score.Voice-+import           Music.Score.Tremolo
src/Music/Score/Articulation.hs view
@@ -1,19 +1,25 @@ +{-# LANGUAGE CPP                        #-} {-# LANGUAGE ConstraintKinds            #-} {-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE DeriveFoldable             #-} {-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TupleSections              #-} {-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeOperators              #-}-{-# LANGUAGE ViewPatterns               #-}+{-# LANGUAGE UndecidableInstances       #-}  ------------------------------------------------------------------------------------- -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund 2012-2014 -- -- License     : BSD-style --@@ -25,13 +31,24 @@ -- ------------------------------------------------------------------------------------- - module Music.Score.Articulation (-        -- * Representation++        -- ** Articulation type functions+        Articulation,+        SetArticulation,+        Accentuation,+        Separation,+        Articulated(..),++        -- ** Accessing articulation+        HasArticulations(..),         HasArticulation(..),-        ArticulationT(..),+        HasArticulations',+        HasArticulation',+        articulation',+        articulations', -        -- * Transformations+        -- * Manipulating articulation         -- ** Accents         accent,         marcato,@@ -40,133 +57,442 @@         accentAll,         marcatoAll, -        -- ** Phrasing-        tenuto,-        separated,+        -- ** Phrasing and separation+        staccatissimo,         staccato,+        separated,         portato,         legato,-        spiccato,+        legatissimo, -        -- ** Miscellaneous-        resetArticulation,+        tenuto,+        spiccato, +        -- * Articulation transformer+        ArticulationT(..),   ) where  import           Control.Applicative+import           Control.Comonad+import           Control.Lens                  hiding (above, below, transform)+import           Data.AffineSpace import           Data.Foldable+import           Data.Functor.Couple import           Data.Semigroup import           Data.Typeable+import           Data.VectorSpace              hiding (Sum) +import           Music.Score.Part+import           Music.Time+import           Music.Time.Internal.Transform+ import           Music.Dynamics.Literal import           Music.Pitch.Literal-import           Music.Score.Combinators+import           Music.Score.Harmonics import           Music.Score.Part-import           Music.Score.Score+import           Music.Score.Phrases+import           Music.Score.Slide+import           Music.Score.Text+import           Music.Score.Ties+import           Music.Score.Tremolo -class HasArticulation a where-    setBeginSlur :: Bool -> a -> a-    setContSlur :: Bool -> a -> a-    setEndSlur :: Bool -> a -> a-    setAccLevel :: Int -> a -> a-    setStaccLevel :: Int -> a -> a -newtype ArticulationT a = ArticulationT { getArticulationT :: (((Any, Any, Any), (Sum Int, Sum Int)), a) }-    deriving (Eq, Show, Ord, Functor, Foldable, Typeable, Applicative, Monad) --- instance Monad ArticulationT where-    -- return = undefined-    -- return x = ArticulationT (Any False,Any False,0,0,x,False)-    -- (>>=) = error "No ArticulationT.(>>=)" -instance Semigroup a => Semigroup (ArticulationT a) where-    ArticulationT (((es,us,bs),(al,sl)),a) <> ArticulationT (_,b) = ArticulationT (((es,us,bs),(al,sl)), a <> b)+-- |+-- Articulations type.+--+type family Articulation (s :: *) :: * -instance (Semigroup a, Monoid a) => Monoid (ArticulationT a) where-    mempty = return mempty-    mappend = (<>)+-- |+-- Articulation type.+--+type family SetArticulation (b :: *) (s :: *) :: * -instance IsPitch a => IsPitch (ArticulationT a) where-    fromPitch l = return (fromPitch l)+type ArticulationLensLaws' s t a b = (+  Articulation (SetArticulation a s) ~ a,+  SetArticulation (Articulation t) s ~ t,+  SetArticulation a (SetArticulation b s) ~ SetArticulation a s+  ) -instance IsDynamics a => IsDynamics (ArticulationT a) where-    fromDynamics l = return (fromDynamics l)+type ArticulationLensLaws s t = ArticulationLensLaws' s t (Articulation s) (Articulation t) -instance HasArticulation (ArticulationT a) where-    setEndSlur    (Any -> es) (ArticulationT (((_ ,us,bs),(al,sl)),a)) = ArticulationT (((es,us,bs),(al,sl)),a)-    setContSlur   (Any -> us) (ArticulationT (((es,_ ,bs),(al,sl)),a)) = ArticulationT (((es,us,bs),(al,sl)),a)-    setBeginSlur  (Any -> bs) (ArticulationT (((es,us,_ ),(al,sl)),a)) = ArticulationT (((es,us,bs),(al,sl)),a)-    setAccLevel   (Sum -> al) (ArticulationT (((es,us,bs),(_ ,sl)),a)) = ArticulationT (((es,us,bs),(al,sl)),a)-    setStaccLevel (Sum -> sl) (ArticulationT (((es,us,bs),(al,_ )),a)) = ArticulationT (((es,us,bs),(al,sl)),a)+-- |+-- Class of types that provide a single articulation.+--+class (HasArticulations s t) => HasArticulation s t where -instance HasArticulation b => HasArticulation (a,b) where-    setEndSlur    n = fmap (setEndSlur n)-    setContSlur   n = fmap (setContSlur n)-    setBeginSlur  n = fmap (setBeginSlur n)-    setAccLevel   n = fmap (setAccLevel n)-    setStaccLevel n = fmap (setStaccLevel n)+  -- | Articulation type.+  articulation :: Lens s t (Articulation s) (Articulation t) ------------------------------------------------------------------------------------ Articulation---------------------------------------------------------------------------------+-- |+-- Class of types that provide a articulation traversal.+--+class (Transformable (Articulation s),+       Transformable (Articulation t),+       ArticulationLensLaws s t) => HasArticulations s t where --- Accents+  -- | Articulation type.+  articulations :: Traversal s t (Articulation s) (Articulation t) --- | Add a normal accent at the beginning of each phrase in each part in the given score.-accent      :: (HasPart' a, HasArticulation a) => Score a -> Score a-accent      = mapPhrase (setAccLevel 1) id id+type HasArticulation'  a = HasArticulation  a a+type HasArticulations' a = HasArticulations a a --- | Add a marcato accent at the beginning of each phrase in each part in the given score.-marcato     :: (HasPart' a, HasArticulation a) => Score a -> Score a-marcato     = mapPhrase (setAccLevel 2) id id+-- |+-- Articulation type.+--+articulation' :: (HasArticulation s t, s ~ t) => Lens' s (Articulation s)+articulation' = articulation --- | Add a normal accent to all notes in the given score.-accentAll   :: (HasPart' a, HasArticulation a) => Score a -> Score a-accentAll   = mapPhrase (setAccLevel 1) (setAccLevel 1) (setAccLevel 1)+-- |+-- Articulation type.+--+articulations' :: (HasArticulations s t, s ~ t) => Traversal' s (Articulation s)+articulations' = articulations --- | Add a marcato accent to all notes in the given score.-marcatoAll  :: (HasPart' a, HasArticulation a) => Score a -> Score a-marcatoAll  = mapPhrase (setAccLevel 2) (setAccLevel 2) (setAccLevel 2)+#define PRIM_ARTICULATION_INSTANCE(TYPE)       \+                                               \+type instance Articulation TYPE = TYPE;        \+type instance SetArticulation a TYPE = a;      \+                                               \+instance (Transformable a, a ~ Articulation a, SetArticulation TYPE a ~ TYPE) \+  => HasArticulation TYPE a where {            \+  articulation = ($)              } ;          \+                                               \+instance (Transformable a, a ~ Articulation a, SetArticulation TYPE a ~ TYPE) \+  => HasArticulations TYPE a where {           \+  articulations = ($)               } ;        \ --- | Add a normal accent at the end of each phrase in each part in the given score.-accentLast  :: (HasPart' a, HasArticulation a) => Score a -> Score a-accentLast  = mapPhrase id id (setAccLevel 1)+PRIM_ARTICULATION_INSTANCE(())+PRIM_ARTICULATION_INSTANCE(Bool)+PRIM_ARTICULATION_INSTANCE(Ordering)+PRIM_ARTICULATION_INSTANCE(Char)+PRIM_ARTICULATION_INSTANCE(Int)+PRIM_ARTICULATION_INSTANCE(Integer)+PRIM_ARTICULATION_INSTANCE(Float)+PRIM_ARTICULATION_INSTANCE(Double) --- | Add a marcato accent at the end of each phrase in each part in the given score.-marcatoLast :: (HasPart' a, HasArticulation a) => Score a -> Score a-marcatoLast = mapPhrase id id (setAccLevel 2) +type instance Articulation (c,a)              = Articulation a+type instance SetArticulation b (c,a)         = (c,SetArticulation b a)+type instance Articulation [a]                = Articulation a+type instance SetArticulation b [a]           = [SetArticulation b a] --- Phrasing+type instance Articulation (Maybe a)          = Articulation a+type instance SetArticulation b (Maybe a)     = Maybe (SetArticulation b a)+type instance Articulation (Either c a)       = Articulation a+type instance SetArticulation b (Either c a)  = Either c (SetArticulation b a) --- | Add tenuto marks to each phrase in each part in the given score.-tenuto      :: (HasPart' a, HasArticulation a) => Score a -> Score a-tenuto      = mapPhrase (setStaccLevel (-2)) (setStaccLevel (-2)) (setStaccLevel (-2))+type instance Articulation (Note a) = Articulation a+type instance SetArticulation g (Note a) = Note (SetArticulation g a)+type instance Articulation (Delayed a) = Articulation a+type instance SetArticulation g (Delayed a) = Delayed (SetArticulation g a)+type instance Articulation (Stretched a) = Articulation a+type instance SetArticulation g (Stretched a) = Stretched (SetArticulation g a) --- | Add combined staccato and tenuto marks to each phrase in each part in the given score.-separated   :: (HasPart' a, HasArticulation a) => Score a -> Score a-separated   = mapPhrase (setStaccLevel (-1)) (setStaccLevel (-1)) (setStaccLevel (-1))+type instance Articulation (Voice a) = Articulation a+type instance SetArticulation b (Voice a) = Voice (SetArticulation b a)+type instance Articulation (Chord a) = Articulation a+type instance SetArticulation b (Chord a) = Chord (SetArticulation b a)+type instance Articulation (Track a) = Articulation a+type instance SetArticulation b (Track a) = Track (SetArticulation b a)+type instance Articulation (Score a) = Articulation a+type instance SetArticulation b (Score a) = Score (SetArticulation b a) --- | Add staccato marks to each phrase in each part in the given score.-staccato    :: (HasPart' a, HasArticulation a) => Score a -> Score a-staccato    = mapPhrase (setStaccLevel 1) (setStaccLevel 1) (setStaccLevel 1) --- | Add portato marks to each phrase in each part in the given score.-portato     :: (HasPart' a, HasArticulation a) => Score a -> Score a-portato     = staccato . legato+instance HasArticulation a b => HasArticulation (c, a) (c, b) where+  articulation = _2 . articulation --- | Add legato marks to each phrase in each part in the given score.-legato      :: (HasPart' a, HasArticulation a) => Score a -> Score a-legato      = mapPhrase (setBeginSlur True) id (setEndSlur True)+instance HasArticulations a b => HasArticulations (c, a) (c, b) where+  articulations = traverse . articulations --- | Add spiccatto marks to the given score.-spiccato    :: (HasPart' a, HasArticulation a) => Score a -> Score a-spiccato    = mapPhrase (setStaccLevel 2) (setStaccLevel 2) (setStaccLevel 2)+instance HasArticulations a b => HasArticulations [a] [b] where+  articulations = traverse . articulations --- | Remove all articulation from the given note or notes.-resetArticulation :: HasArticulation c => c -> c-resetArticulation = setBeginSlur False . setContSlur False . setEndSlur False . setAccLevel 0 . setStaccLevel 0+instance HasArticulations a b => HasArticulations (Maybe a) (Maybe b) where+  articulations = traverse . articulations --- Safe for tuple-like types-get1 = head . toList+instance HasArticulations a b => HasArticulations (Either c a) (Either c b) where+  articulations = traverse . articulations++++instance (HasArticulations a b) => HasArticulations (Note a) (Note b) where+  articulations = _Wrapped . whilstL articulations++instance (HasArticulation a b) => HasArticulation (Note a) (Note b) where+  articulation = _Wrapped . whilstL articulation++instance (HasArticulations a b) => HasArticulations (Delayed a) (Delayed b) where+  articulations = _Wrapped . whilstLT articulations++instance (HasArticulation a b) => HasArticulation (Delayed a) (Delayed b) where+  articulation = _Wrapped . whilstLT articulation++instance (HasArticulations a b) => HasArticulations (Stretched a) (Stretched b) where+  articulations = _Wrapped . whilstLD articulations++instance (HasArticulation a b) => HasArticulation (Stretched a) (Stretched b) where+  articulation = _Wrapped . whilstLD articulation+++instance HasArticulations a b => HasArticulations (Voice a) (Voice b) where+  articulations = traverse . articulations++instance HasArticulations a b => HasArticulations (Chord a) (Chord b) where+  articulations = traverse . articulations++instance HasArticulations a b => HasArticulations (Track a) (Track b) where+  articulations = traverse . articulations++instance HasArticulations a b => HasArticulations (Score a) (Score b) where+  articulations =+    _Wrapped . _2   -- into NScore+    . _Wrapped+    . traverse+    . _Wrapped      -- this needed?+    . whilstL articulations++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+type instance SetArticulation g (HarmonicT a)  = HarmonicT (SetArticulation g a)+type instance Articulation (TieT a)            = Articulation a+type instance SetArticulation g (TieT a)       = TieT (SetArticulation g a)+type instance Articulation (SlideT a)          = Articulation a+type instance SetArticulation g (SlideT a)     = SlideT (SetArticulation g a)++instance (HasArticulations a b) => HasArticulations (Couple c a) (Couple c b) where+  articulations = _Wrapped . articulations+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+  articulation = _Wrapped . articulation++instance (HasArticulations a b) => HasArticulations (HarmonicT a) (HarmonicT b) where+  articulations = _Wrapped . articulations+instance (HasArticulation a b) => HasArticulation (HarmonicT a) (HarmonicT b) where+  articulation = _Wrapped . articulation++instance (HasArticulations a b) => HasArticulations (TieT a) (TieT b) where+  articulations = _Wrapped . articulations+instance (HasArticulation a b) => HasArticulation (TieT a) (TieT b) where+  articulation = _Wrapped . articulation++instance (HasArticulations a b) => HasArticulations (SlideT a) (SlideT b) where+  articulations = _Wrapped . articulations+instance (HasArticulation a b) => HasArticulation (SlideT a) (SlideT b) where+  articulation = _Wrapped . articulation+++type family Accentuation (a :: *) :: *+type family Separation (a :: *) :: *++type instance Accentuation () = ()+type instance Separation   () = ()+type instance Accentuation (a, b) = a+type instance Separation   (a, b) = b+++-- |+-- Class of types that can be transposed, inverted and so on.+--+class (+  Fractional (Accentuation a),+  Fractional (Separation a),+  AffineSpace (Accentuation a),+  AffineSpace (Separation a)+  ) => Articulated a where+    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+  +++accent :: (HasPhrases' s b, HasArticulations' b, Articulation b ~ a, Articulated a) => s -> s+accent = set (phrases . headV . articulations . accentuation) 1++marcato :: (HasPhrases' s b, HasArticulations' b, Articulation b ~ a, Articulated a) => s -> s+marcato = set (phrases . headV . articulations . accentuation) 2++accentLast :: (HasPhrases' s b, HasArticulations' b, Articulation b ~ a, Articulated a) => s -> s+accentLast = set (phrases . lastV . articulations . accentuation) 1++marcatoLast :: (HasPhrases' s b, HasArticulations' b, Articulation b ~ a, Articulated a) => s -> s+marcatoLast = set (phrases . lastV . articulations . accentuation) 2++accentAll :: (HasArticulations' s, Articulation s ~ a, Articulated a) => s -> s+accentAll = set (articulations . accentuation) 1++marcatoAll :: (HasArticulations' s, Articulation s ~ a, Articulated a) => s -> s+marcatoAll = set (articulations . accentuation) 2++++tenuto :: (HasArticulations' s, Articulation s ~ a, Articulated a) => s -> s+tenuto = id++spiccato :: (HasArticulations' s, Articulation s ~ a, Articulated a) => s -> s+spiccato = id++legatissimo :: (HasArticulations' s, Articulation s ~ a, Articulated a) => s -> s+legatissimo = set (articulations . separation) (-2)++legato :: (HasArticulations' s, Articulation s ~ a, Articulated a) => s -> s+legato = set (articulations . separation) (-1)++separated :: (HasArticulations' s, Articulation s ~ a, Articulated a) => s -> s+separated = set (articulations . separation) 0++portato :: (HasArticulations' s, Articulation s ~ a, Articulated a) => s -> s+portato = set (articulations . separation) 0.5++staccato :: (HasArticulations' s, Articulation s ~ a, Articulated a) => s -> s+staccato = set (articulations . separation) 1++staccatissimo :: (HasArticulations' s, Articulation s ~ a, Articulated a) => s -> s+staccatissimo = set (articulations . separation) 2+++++newtype ArticulationT n a = ArticulationT { getArticulationT :: (n, a) }+  deriving (+    Eq, Ord, Show, Typeable, Functor, Applicative, Monad, +    Comonad, Transformable, Monoid, Semigroup+    )++instance (Monoid n, Num a) => Num (ArticulationT n a) where+  (+) = liftA2 (+)+  (*) = liftA2 (*)+  (-) = liftA2 (-)+  abs = fmap abs+  signum = fmap signum+  fromInteger = pure . fromInteger++instance (Monoid n, Fractional a) => Fractional (ArticulationT n a) where+  recip        = fmap recip+  fromRational = pure . fromRational++instance (Monoid n, Floating a) => Floating (ArticulationT n a) where+  pi    = pure pi+  sqrt  = fmap sqrt+  exp   = fmap exp+  log   = fmap log+  sin   = fmap sin+  cos   = fmap cos+  asin  = fmap asin+  atan  = fmap atan+  acos  = fmap acos+  sinh  = fmap sinh+  cosh  = fmap cosh+  asinh = fmap asinh+  atanh = fmap atanh+  acosh = fmap acos++instance (Monoid n, Enum a) => Enum (ArticulationT n a) where+  toEnum = pure . toEnum+  fromEnum = fromEnum . extract++instance (Monoid n, Bounded a) => Bounded (ArticulationT n a) where+  minBound = pure minBound+  maxBound = pure maxBound++-- instance (Monoid n, Num a, Ord a, Real a) => Real (ArticulationT n a) where+--     toRational = toRational . extract+--+-- instance (Monoid n, Real a, Enum a, Integral a) => Integral (ArticulationT n a) where+--     quot = liftA2 quot+--     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++instance Rewrapped (ArticulationT p a) (ArticulationT p' b)++type instance Articulation (ArticulationT p a) = p+type instance SetArticulation p' (ArticulationT p a) = ArticulationT p' a++instance (Transformable p, Transformable p') +    => HasArticulation (ArticulationT p a) (ArticulationT p' a) where+  articulation = _Wrapped . _1++instance (Transformable p, Transformable p') +    => HasArticulations (ArticulationT p a) (ArticulationT p' a) where+  articulations = _Wrapped . _1++deriving instance (IsPitch a, Monoid n) => IsPitch (ArticulationT n a)+deriving instance (IsInterval a, Monoid n) => IsInterval (ArticulationT n a)+deriving instance Reversible a => Reversible (ArticulationT p a)++instance (Tiable n, Tiable a) => Tiable (ArticulationT n a) where+  toTied (ArticulationT (d,a)) = (ArticulationT (d1,a1), ArticulationT (d2,a2))+    where+      (a1,a2) = toTied a+      (d1,d2) = toTied d+++headV :: Traversal' (Voice a) a+headV = (eventsV._head._2)++middleV :: Traversal' (Voice a) a+middleV = (eventsV._middle.traverse._2)++lastV :: Traversal' (Voice a) a+lastV = (eventsV._last._2)++-- Traverse writing to all elements *except* first and last+_middle :: (Snoc s s a a, Cons s s b b) => Traversal' s s+_middle = _tail._init
− src/Music/Score/Chord.hs 
@@ -1,240 +0,0 @@--{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoMonomorphismRestriction  #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeOperators              #-}-{-# LANGUAGE ViewPatterns               #-}------------------------------------------------------------------------------------------ |--- Copyright   : (c) Hans Hoglund 2012------ License     : BSD-style------ Maintainer  : hans@hanshoglund.se--- Stability   : experimental--- Portability : non-portable (TF,GNTD)------ Provides a representation for chords.--------------------------------------------------------------------------------------------module Music.Score.Chord (-        -- * Chord representation-        HasChord(..),-        ChordT(..),--        -- * Voice separation-        separateVoices,-        mergePossible,--        -- * Chord transformations-        takeNoteInChord,-        dropNoteInChord,-        takeNotesInChord,-        dropNotesInChord,-        mapSimultaneous,-        simultaneous,-        simultaneous',-  ) where--import           Prelude                 hiding (any, mapM_)--import           Control.Lens            hiding (perform)-import           Control.Monad.Plus      hiding (mapM_)-import           Data.Foldable-import qualified Data.List               as List-import qualified Data.List.NonEmpty      as NonEmpty-import           Data.Ord-import           Data.Semigroup-import           Data.Typeable--import           Music.Score.Combinators-import           Music.Score.Convert-import           Music.Score.Note-import           Music.Score.Part-import           Music.Score.Score-import           Music.Score.Voice-import           Music.Score.Meta-import           Music.Time--class HasChord a where-    type ChordNote a :: *-    -- TODO use NonEmpty-    getChord :: a -> [ChordNote a]--instance HasChord [a] where-    type ChordNote [a] = a-    getChord = id--instance HasChord (ChordT a) where-    type ChordNote (ChordT a) = a-    getChord (ChordT as)      = as---- TODO Use NonEmpty-newtype ChordT a = ChordT { getChordT :: [a] }-    deriving (Eq, Show, Ord, Monad, Functor, Monoid, Semigroup, Foldable, Typeable)--overlaps :: (HasOnset a, HasOffset a, HasOnset b, HasOffset b) => a -> b -> Bool-overlaps t u = not $ offset t <= onset u || offset u <= onset t--overlapsAny :: (Foldable t, HasOnset a, HasOffset a, HasOnset b, HasOffset b) => a -> t b -> Bool-overlapsAny x = any (overlaps x)--notOverlaps :: (HasOnset a, HasOnset b, HasOffset a, HasOffset b) => a -> b -> Bool-x `notOverlaps` y = not (x `overlaps` y)--hasOverlapping :: Score a -> Bool-hasOverlapping x = let ns = (^. notes) x in not $ null [(x,y) | x <- ns, y <- ns, x `overlaps` y, era x /= era y]---- | Heuristically merge voices if possible-mergePossible :: [Score a] -> [Score a]-mergePossible []  = []-mergePossible (x:xs) = let-    pick = x-    (res, rest) = List.foldr mergeMaybe' (x, []) xs-    in res : mergePossible rest--mergeMaybe' x (y,rest) = if hasOverlapping (x <> y) then (x, y:rest) else (x <> y, rest)--mergeMaybe x y = if hasOverlapping (x <> y) then (x, Just y) else (x <> y, Nothing)----notOverlapsHead :: (HasOnset a, HasOnset b, HasOffset a, HasOffset b) => a -> [b] -> Bool-x `notOverlapsHead` [] = True-x `notOverlapsHead` xs = x `notOverlaps` head xs--class Null a where-    isNull :: a -> Bool--- > isNull mempty-instance Null [a] where-    isNull = null-nonNull = not . isNull-class Divisible a where-    divide :: a -> (a, a)----data Tower a = Tower [a] a [a]-    deriving (Functor, Eq, Show)--tower x = Tower (repeat mempty) x (repeat mempty)-moveUp   (Tower (a:as) x (b:bs)) = Tower (x:a:as) b bs-moveDown (Tower (a:as) x (b:bs)) = Tower as a (x:b:bs)--top :: (Monoid a, Null a) => Tower a -> [a]-top (Tower as x sa) = List.takeWhile nonNull sa--middle :: Tower a -> a-middle (Tower as x sa) = x--bottom :: (Monoid a, Null a) => Tower a -> [a]-bottom (Tower as x sa) = reverse (List.takeWhile nonNull as)---- semantic function-floors :: (Monoid a, Null a) => Tower a -> ([a], a, [a])-floors t = (bottom t, middle t, top t)---compareHead x []    = EQ-compareHead x (y:_) = x `compare` y-comparingHead p x y = compareHead (p x) (fmap p y)-compareHeadVal = comparingHead getNoteValue--pushNote :: Ord a => Note a -> Tower [Note a] -> Tower [Note a]-pushNote n t = if n `notOverlapsHead` middle t then pushMiddle n t else-        case n `compareHeadVal` middle t of-            GT -> moveUp   $ pushNote n (moveDown t)-            _  -> moveDown $ pushNote n (moveUp t)--pushMiddle :: a -> Tower [a] -> Tower [a]-pushMiddle x (Tower as a sa) = Tower as (x:a) sa--separateVoices :: Ord a => Score a -> [Score ( a)]-separateVoices = fmap (^. from notes) . f . (^. notes)-    where-        f = (\(as,x,bs) -> as++[x]++bs) . floors . List.foldr pushNote (tower [])  . List.sortBy (comparing getNoteSpan)---- Note:------ The HasChord instance (for other transformer types) takes care to transform strucuture *above* the chord representation---      In particular, getChord will extract the chord from below and transform each note (or only the first etc)---      as appropriate for the given type.--- The ChordT instances (of other transformer classes) transforms structure *below* the chord representation---      For example, it allow us to use functions such as up, down, legato etc on chords.---- TODO rewrite, generalize?--takeNotesInChord n = mapSimultaneous (fmap $ take n)-dropNotesInChord n = mapSimultaneous (fmap $ drop n)--takeNoteInChord n = mapSimultaneous $ (fmap $ take 1) . (fmap $ drop (n - 1))-dropNoteInChord n = mapSimultaneous $ (fmap $ drop1 n)--drop1 n xs = take (n - 1) xs <> drop n xs----- |--- Process all simultaneous events.------ Two events /a/ and /b/ are considered simultaneous if and only if they have the same--- era, that is if @`era` a == `era` b@----mapSimultaneous :: (Score [a] -> Score [b]) -> Score a -> Score b-mapSimultaneous f = mscatter . f . simultaneous'---- |--- Merge all simultaneous events using their 'Semigroup' instance.------ Two events /a/ and /b/ are considered simultaneous if and only if they have the same--- era, that is if @`era` a == `era` b@----simultaneous :: Semigroup a => Score a -> Score a-simultaneous = fmap (sconcat . NonEmpty.fromList) . simultaneous'---- |--- Group simultaneous events as lists.------ Two events /a/ and /b/ are considered simultaneous if and only if they have the same--- era, that is if @`era` a == `era` b@------ Note that 'simultaneous' is identical to 'simultaneous' @.@ 'fmap' 'return'----simultaneous' :: Score a -> Score [a]-simultaneous' sc = (meta .~) m $ (^. from events) vs-    where-        m = (view meta) sc-        -- es :: [Era]-        -- evs :: [[a]]-        -- vs :: [(Time, Duration, [a])]-        es  = List.nub $ eras sc-        evs = fmap (`chordEvents` sc) es-        vs  = zipWith (\(view delta -> (t,d)) a -> (t,d,a)) es evs----- TODO (re)move these--eras :: Score a -> [Span]-eras sc = fmap getSpan . (^. events) $ sc--chordEvents :: Span -> Score a -> [a]-chordEvents era sc = fmap getValue . filter (\ev -> getSpan ev == era) . (^. events) $ sc--getValue :: (Time, Duration, a) -> a-getValue (t,d,a) = a--getSpan :: (Time, Duration, a) -> Span-getSpan (t,d,a) = t >-> d-----
src/Music/Score/Clef.hs view
@@ -1,4 +1,5 @@ +{-# LANGUAGE StandaloneDeriving         #-} {-# LANGUAGE ConstraintKinds            #-} {-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE DeriveFoldable             #-}@@ -16,7 +17,7 @@  ------------------------------------------------------------------------------------- -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund 2012-2014 -- -- License     : BSD-style --@@ -26,6 +27,8 @@ -- -- Provides clefs. --+-- /Warning/ Experimental module.+-- -------------------------------------------------------------------------------------  @@ -35,6 +38,7 @@   ) where  import           Control.Arrow+import           Control.Lens hiding (transform, parts) import           Control.Monad.Plus import           Data.Foldable           (Foldable) import qualified Data.Foldable           as F@@ -51,45 +55,58 @@ import           Data.Typeable import           Data.Void -import           Music.Score.Combinators (mapFirst)-import           Music.Score.Meta import           Music.Score.Meta.Clef-import           Music.Score.Note-import           Music.Score.Ornaments   (HasText, text) import           Music.Score.Part-import           Music.Score.Score import           Music.Score.Ties-import           Music.Score.Util+import           Music.Score.Internal.Util import           Music.Time-import           Music.Time.Reactive   -- Put the given clef in front of the note newtype ClefT a = ClefT { getClefT :: (Option (Last Clef), a) }-    deriving (Functor, Semigroup, Monoid)+  deriving (Functor, Semigroup, Monoid) -type instance Part (ClefT a) = Part a-instance HasPart a => HasPart (ClefT a) where-    getPart (ClefT (_,a)) = getPart a-    modifyPart f (ClefT (a,b)) = ClefT (a, modifyPart f b) +-- | Unsafe: Do not use 'Wrapped' instances+instance Wrapped (ClefT a) where+  type Unwrapped (ClefT a) = (Option (Last Clef), a)+  _Wrapped' = iso getClefT ClefT++instance Rewrapped (ClefT a) (ClefT b)++ instance Monad ClefT where-    return x = ClefT (mempty, x)-    (>>=) = error "No ClefT.(>>=)"+  return x = ClefT (mempty, x)+  (>>=) = error "No ClefT.(>>=)"  +type instance Part (ClefT a) = Part a+type instance SetPart b (ClefT a) = ClefT (SetPart b a)+++instance (HasParts a b) => HasParts (ClefT a) (ClefT b) where+  parts = _Wrapped . parts++instance (HasPart a b) => HasPart (ClefT a) (ClefT b) where+  part = _Wrapped . part+++instance Transformable a => Transformable (ClefT a) where+  transform s = over (_Wrapped . _2) $ transform s+   instance Tiable a => Tiable (ClefT a) where-    toTied (ClefT (clef,a)) = (ClefT (clef,b), ClefT (mempty,c)) where (b,c) = toTied a+  toTied (ClefT (clef,a)) = (ClefT (clef,b), ClefT (mempty,c)) where (b,c) = toTied a  class HasClef a where-    applyClef :: Clef -> a -> a+  applyClef :: Clef -> a -> a  instance HasClef (ClefT a) where-    applyClef c (ClefT (_,a)) = ClefT (Option $ Just $ Last c,a)+  applyClef c (ClefT (_,a)) = ClefT (Option $ Just $ Last c,a)  instance HasClef a => HasClef (b,a) where-    applyClef c = fmap (applyClef c)+  applyClef c = fmap (applyClef c)  instance (HasPart' a, HasClef a) => HasClef (Score a) where-    applyClef c = mapFirst (applyClef c) id+  applyClef c = id -- TODO+  -- applyClef c = mapFirst (applyClef c) id
+ src/Music/Score/Color.hs view
@@ -0,0 +1,125 @@++{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE UndecidableInstances       #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-- Provides colored note heads.+--+-------------------------------------------------------------------------------------++module Music.Score.Color (+        -- ** HasColor class+        HasColor(..),++        -- * Manipulating color+        color,++        -- * Representation+        ColorT(..),+  ) where++import           Control.Applicative+import           Control.Lens                  hiding (above, below, transform)+import           Data.AffineSpace+import           Data.Colour+import qualified Data.Colour.Names             as C+import           Data.Foldable+import           Data.Functor.Couple+import           Data.Semigroup+import           Data.Typeable+import           Control.Comonad++import           Music.Score.Part+import           Music.Time+import           Music.Time.Internal.Transform++import           Music.Dynamics.Literal+import           Music.Pitch.Alterable+import           Music.Pitch.Augmentable+import           Music.Pitch.Literal+import           Music.Score.Harmonics+import           Music.Score.Part+import           Music.Score.Phrases+import           Music.Score.Slide+import           Music.Score.Text+import           Music.Score.Ties+import           Music.Score.Tremolo++class HasColor a where+  setColor :: Colour Double -> a -> a++instance HasColor a => HasColor (b, a) where+  setColor s = fmap (setColor s)+instance HasColor a => HasColor [a] where+  setColor s = fmap (setColor s)+instance HasColor a => HasColor (Score a) where+  setColor s = fmap (setColor s)+instance HasColor a => HasColor (PartT n a) where+  setColor s = fmap (setColor s)+instance HasColor a => HasColor (TieT a) where+  setColor s = fmap (setColor s)++newtype ColorT a = ColorT { getColorT :: Couple (Option (Last (Colour Double))) a }+  deriving (Eq, {-Ord,-} Show, Functor, Foldable, {-Typeable,-} Applicative, Monad, Comonad)++-- Lifted instances+deriving instance Num a => Num (ColorT a)+deriving instance Fractional a => Fractional (ColorT a)+deriving instance Floating a => Floating (ColorT a)+deriving instance Enum a => Enum (ColorT a)+deriving instance Bounded a => Bounded (ColorT a)+-- deriving instance (Num a, Ord a, Real a) => Real (ColorT a)+-- deriving instance (Real a, Enum a, Integral a) => Integral (ColorT a)++-- | Unsafe: Do not use 'Wrapped' instances+instance Wrapped (ColorT a) where+  type Unwrapped (ColorT a) = Couple (Option (Last (Colour Double))) a+  _Wrapped' = iso getColorT ColorT++instance Rewrapped (ColorT a) (ColorT b)+++instance HasColor (ColorT a) where+  setColor s (ColorT (Couple (t,x))) = ColorT $ Couple (t <> wrap s,x)+    where+      wrap = Option . Just . Last++instance Semigroup a => Semigroup (ColorT a) where+  (<>) = liftA2 (<>)++instance Tiable a => Tiable (ColorT a) where+  toTied (ColorT (Couple (n,a))) = (ColorT $ Couple (n,b), ColorT $ Couple (n,c)) +    where +      (b,c) = toTied a+++-- |+-- Set the number of tremolo divisions for all notes in the score.+--+color :: HasColor a => Colour Double -> a -> a+color = setColor+
− src/Music/Score/Combinators.hs 
@@ -1,457 +0,0 @@--{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE DeriveTraversable          #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE ViewPatterns               #-}------------------------------------------------------------------------------------------ |--- Copyright   : (c) Hans Hoglund 2012------ License     : BSD-style------ Maintainer  : hans@hanshoglund.se--- Stability   : experimental--- Portability : non-portable (TF,GNTD)------ Combinators for manipulating scores and related structures.-------------------------------------------------------------------------------------------module Music.Score.Combinators (-        -- * Basic-        note,-        rest,-        noteRest,-        removeRests,--        -- * Mapping over events-        mapEvents,--        -- * Filtering events--        -- ** Editing-        filterEvents,-        mapFilterEvents,--        -- * Editing-        before,-        after,-        split,-        slice,-        splice,--        -- * Meta-events-        metaAt,-        metaAtStart,-        withMeta,-        withGlobalMeta,-        withMetaAtStart,-        withGlobalMetaAtStart,-----        -- ** Map over phrases-        mapFirst,-        mapLast,-        mapPhrase,-        mapPhraseSingle,--        -- * Parts-        -- ** Extracting parts-        filterPart,-        extractParts,-        extractParts',--        -- ** Map over parts-        -- mapPart,-        mapParts,-        mapAllParts,-        -- modifyParts,--        -- ** Part composition-        (</>),-        rcat,-        -- moveParts,-        -- moveToPart,--        -- * Zippers-        -- apply,-        -- snapshot,-        -- snapshotWith,--        -- ** Single-part versions-        applySingle,-        -- snapshotSingle,-        -- snapshotWithSingle,-  ) where--import           Control.Applicative-import           Control.Arrow-import           Control.Lens           hiding (perform)-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.Convert-import           Music.Score.Meta-import           Music.Score.Note-import           Music.Score.Part-import           Music.Score.Score-import           Music.Score.Track-import           Music.Score.Util-import           Music.Score.Voice-import           Music.Time-import           Music.Time.Reactive--import qualified Data.Foldable          as Foldable-import qualified Data.List              as List---- | Create a score containing a note at time zero and duration one. This is an alias for 'return'.-note :: Monad m => a -> m a-note = return---- | Create a score containing a rest at time zero and duration one. This is an alias for @'return' 'Nothing'@.-rest :: MonadPlus m => m (Maybe a)-rest = return Nothing---- | Create a note or a rest at time zero and duration one. This is an alias for 'mfromMaybe'.-noteRest :: MonadPlus m => Maybe a -> m a-noteRest = mfromMaybe---- | Remove all rests from a score. This is an alias for 'mcatMaybes'.-removeRests :: MonadPlus m => m (Maybe a) -> m a-removeRests = mcatMaybes---- | Retain only the notes whose /offset/ does not fall after the given time.-before :: Time -> Score a -> Score a-before u = filterEvents (\t d _ -> t .+^ d <= u)---- | Retain only the notes whose /onset/ does not fall before the given time.-after :: Time -> Score a -> Score a-after u = filterEvents (\t d _ -> u <= t)---- | Returns notes whose /onset/ and /offset/ fall between the given times.-slice :: Time -> Time -> Score a -> Score a-slice u v = filterEvents (\t d _ -> u <= t && t .+^ d <= v)---- | Split a score into events whose onsets-split :: Time -> Score a -> (Score a, Score a)-split t a = (before t a, after t a)---- | Split a score into three parts-splice :: Time -> Duration -> Score a -> (Score a, Score a, Score a)-splice t d a = tripr (before t a, split (t .+^ d) a)-------- |--- Map over the first, and remaining notes in each part.------ If a part has only one notes, the first function is applied.--- If a part has no notes, it is returned unchanged.----mapFirst :: HasPart' a => (a -> b) -> (a -> b) -> Score a -> Score b-mapFirst f g = mapPhrase f g g---- |--- Map over the last, and preceding notes in each part.------ If a part has only one notes, the first function is applied.--- If a part has no notes, it is returned unchanged.----mapLast :: HasPart' a => (a -> b) -> (a -> b) -> Score a -> Score b-mapLast f g = mapPhrase g g f---- |--- Map over the first, middle and last note in each part.------ If a part has fewer than three notes the first takes precedence over the last,--- and last takes precedence over the middle.----mapPhrase :: HasPart' a => (a -> b) -> (a -> b) -> (a -> b) -> Score a -> Score b-mapPhrase f g h = mapAllParts (fmap $ mapPhraseSingle f g h)---- |--- Equivalent to 'mapPhrase' for single-part scores.------ Fails if the score contains overlapping events.------ > (a -> b) -> (a -> b) -> (a -> b) -> Score a -> Score b----mapPhraseSingle :: (a -> b) -> (a -> b) -> (a -> b) -> Score a -> Score b-mapPhraseSingle f g h = mapAll (mapFTL (_3 %~ f) (_3 %~ g) (_3 %~ h))------ |--- Map over all events in a score.----mapAll :: ([(Time, Duration, a)] -> [(Time, Duration, b)]) -> Score a -> Score b-mapAll f = saveMeta $ over events f-    where-        saveMeta f x = (meta .~) ((view meta) x) $ f x--------------------------------------------------------------------------------------- Parts------------------------------------------------------------------------------------- |--- Filter a score to include only those events whose parts match a given predicate.----filterPart :: HasPart' a => (Part a -> Bool) -> Score a -> Score a-filterPart p = mfilter (p . getPart)--filterPartIs :: HasPart' a => Part a -> Score a -> Score a-filterPartIs = filterPart <$> (==)---- |--- Extract parts from the a score.------ The parts are returned in the order defined the associated 'Ord' instance part type.----extractParts :: HasPart' a => Score a -> [Score a]-extractParts x = filterPartIs <$> getParts x <*> return x---- |--- Extract parts from the a score and include the part name.------ The parts are returned in the order defined the associated 'Ord' instance part type.----extractParts' :: HasPart' a => Score a -> [(Part a, Score a)]-extractParts' x = getParts x `zip` extractParts x----- |--- Map over a specific part in the given score.----mapPart         :: (Enum (Part a), HasPart' a) => Part a -> (Score a -> Score a) -> Score a -> Score a---- |--- Map over all parts in the given score.------ > (Score a -> Score a) -> Score a -> Score a----mapParts        :: HasPart' a => (Score a -> Score b) -> Score a -> Score b---- |--- Map over all parts in the given score.------ > ([Score a] -> [Score a]) -> Score a -> Score a----mapAllParts     :: HasPart' a => ([Score a] -> [Score b]) -> Score a -> Score b--{-# DEPRECATED mapParts "" #-}-{-# DEPRECATED mapAllParts "" #-}-{-# DEPRECATED filterPart "" #-}-{-# DEPRECATED extractParts "" #-}-{-# DEPRECATED extractParts' "" #-}---mapPart n f     = mapAllParts (zipWith ($) (replicate (fromEnum n) id ++ [f] ++ repeat id))-mapParts f      = mapAllParts (fmap f)-mapAllParts f   = mconcat . f . extractParts---- |--- Modify all parts in the given score.------ > (Part -> Part) -> Score a -> Score a----modifyParts :: HasPart' a => (Part a -> Part a) -> Score a -> Score a-modifyParts n = fmap (modifyPart n)--------------------------------------------------------------------------------------- Part composition-----------------------------------------------------------------------------------infixr 6 </>---- |--- Similar to '<>', but increases parts in the second part to prevent collision.----(</>) :: (HasPart' a, Enum (Part a)) => Score a -> Score a -> Score a-a </> b = a <> moveParts offset b-    where-        -- max voice in a + 1-        offset = succ $ maximum' 0 $ fmap fromEnum $ getParts a---- |--- Concatenate parts.----rcat :: (HasPart' a, Enum (Part a)) => [Score a] -> Score a-rcat = List.foldr (</>) mempty---- |--- Move down one voice (all parts).----moveParts :: (Integral b, HasPart' a, Enum (Part a)) => b -> Score a -> Score a-moveParts x = modifyParts (successor x)---- |--- Move top-part to the specific voice (other parts follow).----moveToPart :: (Enum b, HasPart' a, Enum (Part a)) => b -> Score a -> Score a-moveToPart v = moveParts (fromEnum v)-------------------------------------------------------------------------------------------- Zippers---- |--- Apply a time-varying function to all events in score.----apply :: HasPart' a => Voice (Score a -> Score b) -> Score a -> Score b-apply x = mapAllParts (fmap $ applySingle x)---- |--- Apply a time-varying function to all events in score.----applySingle :: Voice (Score a -> Score b) -> Score a -> Score b-applySingle fs = notJoin . fmap (uncurry ($)) . sample fs-    where-        notJoin   = mconcat . Foldable.toList-        sample fs = snapshotSingle (voiceToScore fs)-{-# DEPRECATED applySingle "" #-}---- |--- Get all notes that start during a given note.----snapshot :: HasPart' b => Score a -> Score b -> Score (a, Score b)-snapshot x = mapAllParts (fmap $ snapshotSingle x)--snapshotWith :: HasPart' b => (a -> Score b -> c) -> Score a -> Score b -> Score c-snapshotWith f x = mapAllParts (fmap $ snapshotWithSingle f x)---- |--- Get all notes that start during a given note.----snapshotSingle :: Score a -> Score b -> Score (a, Score b)-snapshotSingle = snapshotWithSingle (,)--snapshotWithSingle :: (a -> Score b -> c) -> Score a -> Score b -> Score c-snapshotWithSingle g as bs = mapEvents ( \t d a -> g a (onsetIn t d bs) ) as---- |--- Filter out events that has its onset in the given time interval (inclusive start).--- For example, onset in 1 2 filters events such that (1 <= onset x < 3)----onsetIn :: Time -> Duration -> Score a -> Score a-onsetIn a b = mapAll $ filterOnce (\(t,d,x) -> a <= t && t < a .+^ b)--- We could also have used mfilter. filterOnce is more lazy,--- but depends on the events being sorted--------withSpan :: Score a -> Score (Span, a)-withSpan = mapEvents (\t d x -> (t >-> d,x))-withTime = mapEvents (\t d x -> (t, x))--inSpan t' (view range -> (t,u)) = t <= t' && t' < u---- TODO clean-mapBefore :: Time -> (Score a -> Score a) -> Score a -> Score a-mapDuring :: Span -> (Score a -> Score a) -> Score a -> Score a-mapAfter :: Time -> (Score a -> Score a) -> Score a -> Score a-mapBefore t f x = let (y,n) = (fmap snd *** fmap snd) $ mpartition (\(t2,x) -> t2 < t) (withTime x) in (f y <> n)-mapDuring s f x = let (y,n) = (fmap snd *** fmap snd) $ mpartition (\(t,x) -> t `inSpan` s) (withTime x) in (f y <> n)-mapAfter t f x = let (y,n) = (fmap snd *** fmap snd) $ mpartition (\(t2,x) -> t2 >= t) (withTime x) in (f y <> n)----- Transform the score with the current value of some meta-information--- Each "update chunk" of the meta-info is processed separately--runScoreMeta :: forall a b . (HasPart' a, IsAttribute b) => Score a -> Reactive b-runScoreMeta = runMeta (Nothing :: Maybe a) . (view meta)--metaAt :: (HasPart' a, IsAttribute b) => Time -> Score a -> b-metaAt x = (? x) . runScoreMeta--metaAtStart :: (HasPart' a, IsAttribute b) => Score a -> b-metaAtStart x = onset x `metaAt` x--withGlobalMeta :: IsAttribute a => (a -> Score b -> Score b) -> Score b -> Score b-withGlobalMeta = withMeta' (Nothing :: Maybe Int)--withMeta :: (IsAttribute a, HasPart' b) => (a -> Score b -> Score b) -> Score b -> Score b-withMeta f x = withMeta' (Just x) f x--withMeta' :: (HasPart' c, IsAttribute a) => Maybe c -> (a -> Score b -> Score b) -> Score b -> Score b-withMeta' part f x = let-    m = (view meta) x-    r = runMeta part m-    in case splitReactive r of-        Left  a -> f a x-        Right ((a, t), bs, (u, c)) ->-            (meta .~) m-                $ mapBefore t (f a)-                $ (composed $ fmap (\(getNote -> (s, a)) -> mapDuring s $ f a) $ bs)-                $ mapAfter u (f c)-                $ x--withGlobalMetaAtStart :: IsAttribute a => (a -> Score b -> Score b) -> Score b -> Score b-withGlobalMetaAtStart = withMetaAtStart' (Nothing :: Maybe Int)--withMetaAtStart :: (IsAttribute a, HasPart' b) => (a -> Score b -> Score b) -> Score b -> Score b-withMetaAtStart f x = withMetaAtStart' (Just x) f x--withMetaAtStart' :: (IsAttribute b, HasPart' p) =>-    Maybe p -> (b -> Score a -> Score a) -> Score a -> Score a-withMetaAtStart' part f x = let-    m = (view meta) x-    in f (runMeta part m ? onset x) x------------------------------------------------------------------------------------------------ partial2 :: (a -> b -> Bool)      -> a -> b -> Maybe b--- partial3 :: (a -> b -> c -> Bool) -> a -> b -> c -> Maybe c--- partial2 f = curry  (fmap snd  . partial (uncurry f))--- partial3 f = curry3 (fmap (^. _3) . partial (uncurry3 f))--iterating :: (a -> a) -> (a -> a) -> Int -> a -> a-iterating f g n-    | n <  0 = f . iterating f g (n + 1)-    | n == 0 = id-    | n >  0 = g . iterating f g (n - 1)--successor :: (Integral b, Enum a) => b -> a -> a-successor n = iterating pred succ (fromIntegral n)--maximum' :: (Ord a, Foldable t) => a -> t a -> a-maximum' z = option z getMax . foldMap (Option . Just . Max)--minimum' :: (Ord a, Foldable t) => a -> t a -> a-minimum' z = option z getMin . foldMap (Option . Just . Min)-
src/Music/Score/Convert.hs view
@@ -12,7 +12,7 @@  ------------------------------------------------------------------------------------- -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund 2012-2014 -- -- License     : BSD-style --@@ -20,31 +20,21 @@ -- Stability   : experimental -- Portability : non-portable (TF,GNTD) ----- Provides conversion betwen temporal container types.+-- Provides conversion betwen temporal container. --+-- /Warning/ This module will be removed soon.+-- ------------------------------------------------------------------------------------- - module Music.Score.Convert (-        -- * Conversion-        noteToVoice,-        noteToScore,-        -- scoreToNotes,-        -- notesToScore,         voiceToScore,-        voicesToScore,-        trackToScore,-        trackToScore',+        voiceToScore',         scoreToVoice,-        reactiveToVoice,         reactiveToVoice',-        noteToReactive,-        splitReactive,-        activate,   ) where  import           Control.Applicative-import           Control.Lens+import           Control.Lens hiding (transform, time) import           Control.Monad import           Control.Monad.Plus import           Data.AffineSpace@@ -57,11 +47,7 @@ import           Data.Traversable import           Data.VectorSpace -import           Music.Score.Note import           Music.Score.Part-import           Music.Score.Score-import           Music.Score.Track-import           Music.Score.Voice import           Music.Time import           Music.Time.Reactive @@ -69,13 +55,17 @@ import qualified Data.List              as List  --- | Convert a note to an onset and a voice.+{-+-- | Convert a note to an _onset and a voice. noteToVoice :: Note a -> (Time, Voice a)-noteToVoice (getNote -> (s,x)) = (onset s, stretchTo (duration s) $ return x)+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 (getNote -> (s,x)) = s `sapp` return x+noteToScore (view (from note) -> (s,x)) = s `transform` return x+-}  -- scoreToNotes :: Score a -> [Note a] -- scoreToNotes = Foldable.toList . reifyScore@@ -83,67 +73,74 @@ -- notesToScore :: [Note a] -> Score a -- notesToScore = pcat . fmap noteToScore +{- reactiveToVoice :: Duration -> Reactive a -> Voice a-reactiveToVoice d r = (^. voice) $ durs `zip` (fmap (r ?) times)+reactiveToVoice d r = (^. voice) $ fmap (^. stretched) $ durs `zip` (fmap (r `atTime`) times)     where-        times = origin : filter (\t -> origin < t && t < origin .+^ d) (occs r)-        durs  = toRelN' (origin .+^ d) times+        times = 0 : filter (\t -> 0 < t && t < 0 .+^ d) (occs r)+        durs  = toRelN' (0 .+^ d) times+-}  reactiveToVoice' :: Span -> Reactive a -> Voice a-reactiveToVoice' (view range -> (u,v)) r = (^. voice) $ durs `zip` (fmap (r ?) times)+reactiveToVoice' (view range -> (u,v)) r = (^. voice) $ fmap (^. stretched) $ durs `zip` (fmap (r `atTime`) times)     where-        times = origin : filter (\t -> u < t && t < v) (occs r)+        times = 0 : filter (\t -> u < t && t < v) (occs r)         durs  = toRelN' v times+{-# DEPRECATED reactiveToVoice' "" #-}  -- | -- Convert a score to a voice. Fails if the score contain overlapping events. ---scoreToVoice :: Score a -> Voice (Maybe a)-scoreToVoice = (^. voice) . fmap throwTime . addRests . (^. 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 origin+       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 "addRests: Strange prevTime"-+                   | otherwise = error "scoreToVoice: Strange prevTime"+{-# DEPRECATED scoreToVoice "" #-}  -- | -- Convert a voice to a score. -- voiceToScore :: Voice a -> Score a-voiceToScore = scat . fmap g . (^. from voice)-    where-        g (d,x) = stretch d (return x)+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 :: Duration -> Track a -> Score a+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' :: (a -> Duration) -> Track a -> Score a-trackToScore' f = (^. from events) . fmap (\(t,x) -> (t,f x,x)) . (^. from track)+trackToScore' :: Transformable a => (a -> Duration) -> Track a -> Score a+trackToScore' f = (^. from events) . fmap (\(t,x) -> (t,f x,x)) . map (^. from delayed) . (^. delayeds)+-}   -- Convert to delta (time to wait before this note) toRel :: [Time] -> [Duration]-toRel = snd . mapAccumL g origin where g prev t = (t, t .-. prev)+toRel = snd . mapAccumL g 0 where g prev t = (t, t .-. prev)  -- Convert to delta (time to wait before next note) toRelN :: [Time] -> [Duration]@@ -159,23 +156,23 @@  -- Convert from delta (time to wait before this note) toAbs :: [Duration] -> [Time]-toAbs = snd . mapAccumL g origin where g now d = (now .+^ d, now .+^ d)+toAbs = snd . mapAccumL g 0 where g now d = (now .+^ d, now .+^ d)   -- TODO rename during noteToReactive :: Monoid a => Note a -> Reactive a noteToReactive n = (pure <$> n) `activate` pure mempty --- | Split a reactive into notes, as well as the values before and after the first/last update+-- | 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 note $ mrights (res $ (t,x):xs), head $ mlefts (res $ (t,x):xs))+    (t,x):xs    -> Right ((initial r, t), fmap mkNote $ mrights (res $ (t,x):xs), head $ mlefts (res $ (t,x):xs))      where -        note (t,u,x) = t <-> u =: x+        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)]@@ -194,8 +191,8 @@                 go (x:y:rs) = (x, Just y) : withNext (y : rs)  activate :: Note (Reactive a) -> Reactive a -> Reactive a-activate (getNote -> (view range -> (start,stop), x)) y = y `turnOn` (x `turnOff` y)-    where-        turnOn  = switch start-        turnOff = switch stop+activate (view (from note) -> (view range -> (start,stop), x)) y = y `turnOn` (x `turnOff` y)+  where+    turnOn  = switchR start+    turnOff = switchR stop
src/Music/Score/Dynamics.hs view
@@ -1,18 +1,26 @@ +{-# LANGUAGE CPP                        #-} {-# LANGUAGE ConstraintKinds            #-} {-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE DeriveFoldable             #-} {-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TupleSections              #-} {-# LANGUAGE TypeFamilies               #-} {-# LANGUAGE TypeOperators              #-}-{-# LANGUAGE ViewPatterns               #-}+{-# LANGUAGE UndecidableInstances       #-}  ------------------------------------------------------------------------------------- -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund 2012-2014 -- -- License     : BSD-style --@@ -24,162 +32,458 @@ -- ------------------------------------------------------------------------------------- - module Music.Score.Dynamics (-        -- * Dynamics representation++        -- * Dynamic type functions+        Dynamic,+        SetDynamic,+        DynamicLensLaws',+        DynamicLensLaws,++        -- * Accessing dynamics+        HasDynamics(..),         HasDynamic(..),+        HasDynamics',+        HasDynamic',+        dynamic',+        dynamics',++        -- * Manipulating dynamics+        Level,+        Attenuable,+        louder,+        softer,+        level,+        compressor,+        fadeIn,+        fadeOut,+         DynamicT(..),-        dynamics,-        dynamicVoice,-        dynamicSingle, -        -- * Dynamic transformations-        -- ** Crescendo and diminuendo-        Level(..),-        cresc,-        dim,+        -- * Context+        -- TODO move+        Ctxt,+        vdynamic,+        addDynCon, -        -- ** Miscellaneous-        resetDynamics,   ) where  import           Control.Applicative import           Control.Arrow-import           Control.Lens            hiding (Level)+import           Control.Comonad+import           Control.Lens                  hiding (Level, transform) import           Control.Monad import           Data.AffineSpace import           Data.Foldable-import qualified Data.List               as List+import           Data.Functor.Couple+import           Data.Functor.Context+import qualified Data.List                     as List import           Data.Maybe import           Data.Ratio import           Data.Semigroup import           Data.Typeable-import           Data.VectorSpace        hiding (Sum)+import           Data.VectorSpace              hiding (Sum) -import           Music.Score.Combinators-import           Music.Score.Convert+import           Music.Dynamics.Literal+import           Music.Pitch.Literal+import           Music.Score.Harmonics import           Music.Score.Part-import           Music.Score.Score-import           Music.Score.Voice+import           Music.Score.Phrases+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 -import           Music.Dynamics.Literal -class HasDynamic a where-    setBeginCresc   :: Bool -> a -> a-    setEndCresc     :: Bool -> a -> a-    setBeginDim     :: Bool -> a -> a-    setEndDim       :: Bool -> a -> a-    setLevel        :: Double -> a -> a+-- |+-- Dynamics type.+--+type family Dynamic (s :: *) :: * --- end cresc/dim, level, begin cresc/dim-newtype DynamicT a = DynamicT { getDynamicT :: (((Any, Any), Option (First Double), (Any, Any)), a) }-    deriving (Eq, Show, Ord, Functor, Foldable, Typeable, Applicative, Monad)+-- |+-- Dynamic type.+--+type family SetDynamic (b :: *) (s :: *) :: * -instance HasDynamic (DynamicT a) where-    setBeginCresc (Any -> bc) (DynamicT (((ec,ed),l,(_ ,bd)),a))   = DynamicT (((ec,ed),l,(bc,bd)),a)-    setEndCresc   (Any -> ec) (DynamicT (((_ ,ed),l,(bc,bd)),a))   = DynamicT (((ec,ed),l,(bc,bd)),a)-    setBeginDim   (Any -> bd) (DynamicT (((ec,ed),l,(bc,_ )),a))   = DynamicT (((ec,ed),l,(bc,bd)),a)-    setEndDim     (Any -> ed) (DynamicT (((ec,_ ),l,(bc,bd)),a))   = DynamicT (((ec,ed),l,(bc,bd)),a)-    setLevel      ((Option . Just . First) -> l ) (DynamicT (((ec,ed),_,(bc,bd)),a))   = DynamicT (((ec,ed),l,(bc,bd)),a)+-- |+-- Class of types that provide a single dynamic.+--+class (HasDynamics s t) => HasDynamic s t where -instance HasDynamic b => HasDynamic (a, b) where-    setBeginCresc n = fmap (setBeginCresc n)-    setEndCresc   n = fmap (setEndCresc n)-    setBeginDim   n = fmap (setBeginDim n)-    setEndDim     n = fmap (setEndDim n)-    setLevel      n = fmap (setLevel n)+  -- | Access a single dynamic.+  dynamic :: Lens s t (Dynamic s) (Dynamic t)  +type DynamicLensLaws' s t a b = (+  Dynamic (SetDynamic a s) ~ a,+  SetDynamic (Dynamic t) s ~ t,+  SetDynamic a (SetDynamic b s) ~ SetDynamic a s+  ) ------------------------------------------------------------------------------------ Dynamics---------------------------------------------------------------------------------+type DynamicLensLaws s t = DynamicLensLaws' s t (Dynamic s) (Dynamic t)  -- |--- Represents dynamics over a duration.+-- Class of types that provide a dynamic traversal. ---data Level a-    = Level  a-    | Change a a-    deriving (Eq, Show)+class (+  Transformable (Dynamic s),+  Transformable (Dynamic t), +  -- SetDynamic (Dynamic t) s ~ t+  DynamicLensLaws s t+  ) => HasDynamics s t where -instance Fractional a => IsDynamics (Level a) where-    fromDynamics (DynamicsL (Just a, Nothing)) = Level (realToFrac a)-    fromDynamics (DynamicsL (Just a, Just b)) = Change (realToFrac a) (realToFrac b)-    fromDynamics x = error $ "fromDynamics: Invalid dynamics literal " ++ show x+  -- | Access all dynamics.+  dynamics :: Traversal s t (Dynamic s) (Dynamic t) +type HasDynamic'  a = HasDynamic  a a+type HasDynamics' a = HasDynamics a a +-- | Access a single dynamic.+dynamic' :: (HasDynamic s t, s ~ t) => Lens' s (Dynamic s)+dynamic' = dynamic++-- | Access all dynamics.+dynamics' :: (HasDynamics s t, s ~ t) => Traversal' s (Dynamic s)+dynamics' = dynamics++#define PRIM_DYNAMIC_INSTANCE(TYPE)       \+                                          \+type instance Dynamic TYPE = TYPE;        \+type instance SetDynamic a TYPE = a;      \+                                          \+instance (Transformable a, a ~ Dynamic a, SetDynamic TYPE a ~ TYPE) \+  => HasDynamic TYPE a where {            \+  dynamic = ($)              } ;          \+                                          \+instance (Transformable a, a ~ Dynamic a, SetDynamic TYPE a ~ TYPE) \+  => HasDynamics TYPE a where {           \+  dynamics = ($)               } ;        \++PRIM_DYNAMIC_INSTANCE(())+PRIM_DYNAMIC_INSTANCE(Bool)+PRIM_DYNAMIC_INSTANCE(Ordering)+PRIM_DYNAMIC_INSTANCE(Char)+PRIM_DYNAMIC_INSTANCE(Int)+PRIM_DYNAMIC_INSTANCE(Integer)+PRIM_DYNAMIC_INSTANCE(Float)+PRIM_DYNAMIC_INSTANCE(Double)++type instance Dynamic (c,a)               = Dynamic a+type instance SetDynamic b (c,a)          = (c,SetDynamic b a)+type instance Dynamic [a]                 = Dynamic a+type instance SetDynamic b [a]            = [SetDynamic b a]++type instance Dynamic (Maybe a)           = Dynamic a+type instance SetDynamic b (Maybe a)      = Maybe (SetDynamic b a)+type instance Dynamic (Either c a)        = Dynamic a+type instance SetDynamic b (Either c a)   = Either c (SetDynamic b a)++type instance Dynamic (Note a)            = Dynamic a+type instance SetDynamic b (Note a)       = Note (SetDynamic b a)+type instance Dynamic (Delayed a)         = Dynamic a+type instance SetDynamic b (Delayed a)    = Delayed (SetDynamic b a)+type instance Dynamic (Stretched a)       = Dynamic a+type instance SetDynamic b (Stretched a)  = Stretched (SetDynamic b a)++type instance Dynamic (Voice a)       = Dynamic a+type instance SetDynamic b (Voice a)  = Voice (SetDynamic b a)+type instance Dynamic (Chord a)       = Dynamic a+type instance SetDynamic b (Chord a)  = Chord (SetDynamic b a)+type instance Dynamic (Track a)       = Dynamic a+type instance SetDynamic b (Track a)  = Track (SetDynamic b a)+type instance Dynamic (Score a)       = Dynamic a+type instance SetDynamic b (Score a)  = Score (SetDynamic b a)++instance HasDynamic a b => HasDynamic (c, a) (c, b) where+  dynamic = _2 . dynamic++instance HasDynamics a b => HasDynamics (c, a) (c, b) where+  dynamics = traverse . dynamics++instance HasDynamics a b => HasDynamics [a] [b] where+  dynamics = traverse . dynamics++instance HasDynamics a b => HasDynamics (Maybe a) (Maybe b) where+  dynamics = traverse . dynamics++instance HasDynamics a b => HasDynamics (Either c a) (Either c b) where+  dynamics = traverse . dynamics++++instance (HasDynamics a b) => HasDynamics (Note a) (Note b) where+  dynamics = _Wrapped . whilstL dynamics++instance (HasDynamic a b) => HasDynamic (Note a) (Note b) where+  dynamic = _Wrapped . whilstL dynamic+++instance (HasDynamics a b) => HasDynamics (Delayed a) (Delayed b) where+  dynamics = _Wrapped . whilstLT dynamics++instance (HasDynamic a b) => HasDynamic (Delayed a) (Delayed b) where+  dynamic = _Wrapped . whilstLT dynamic+++instance (HasDynamics a b) => HasDynamics (Stretched a) (Stretched b) where+  dynamics = _Wrapped . whilstLD dynamics++instance (HasDynamic a b) => HasDynamic (Stretched a) (Stretched b) where+  dynamic = _Wrapped . whilstLD dynamic+++instance HasDynamics a b => HasDynamics (Voice a) (Voice b) where+  dynamics = traverse . dynamics++instance HasDynamics a b => HasDynamics (Track a) (Track b) where+  dynamics = traverse . dynamics++instance HasDynamics a b => HasDynamics (Chord a) (Chord b) where+  dynamics = traverse . dynamics++instance (HasDynamics a b) => HasDynamics (Score a) (Score b) where+  dynamics =+    _Wrapped . _2   -- into NScore+    . _Wrapped+    . traverse+    . _Wrapped      -- this needed?+    . whilstL dynamics++type instance Dynamic      (Behavior a) = Behavior a+type instance SetDynamic b (Behavior a) = b++instance (+  Transformable a, Transformable b, b ~ Dynamic b, SetDynamic (Behavior a) b ~ Behavior a+  ) => HasDynamics (Behavior a) b where+  dynamics = ($)++instance (+  Transformable a, Transformable b, b ~ Dynamic b, SetDynamic (Behavior a) b ~ Behavior a+  ) => HasDynamic (Behavior a) b where+  dynamic = ($)++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+type instance SetDynamic g (HarmonicT a)  = HarmonicT (SetDynamic g a)+type instance Dynamic (TieT a)            = Dynamic a+type instance SetDynamic g (TieT a)       = TieT (SetDynamic g a)+type instance Dynamic (SlideT a)          = Dynamic a+type instance SetDynamic g (SlideT a)     = SlideT (SetDynamic g a)+++instance (HasDynamics a b) => HasDynamics (Couple c a) (Couple c b) where+  dynamics = _Wrapped . dynamics++instance (HasDynamic a b) => HasDynamic (Couple c a) (Couple c b) where+  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++instance (HasDynamic a b) => HasDynamic (TextT a) (TextT b) where+  dynamic = _Wrapped . dynamic+++instance (HasDynamics a b) => HasDynamics (HarmonicT a) (HarmonicT b) where+  dynamics = _Wrapped . dynamics++instance (HasDynamic a b) => HasDynamic (HarmonicT a) (HarmonicT b) where+  dynamic = _Wrapped . dynamic+++instance (HasDynamics a b) => HasDynamics (TieT a) (TieT b) where+  dynamics = _Wrapped . dynamics++instance (HasDynamic a b) => HasDynamic (TieT a) (TieT b) where+  dynamic = _Wrapped . dynamic+++instance (HasDynamics a b) => HasDynamics (SlideT a) (SlideT b) where+  dynamics = _Wrapped . dynamics++instance (HasDynamic a b) => HasDynamic (SlideT a) (SlideT b) where+  dynamic = _Wrapped . dynamic+++ -- |--- Apply a dynamic level over the score.+-- Associated interval type. ---dynamics :: (HasDynamic a, HasPart' a) => Score (Level Double) -> Score a -> Score a-dynamics d a = (duration a `stretchTo` d) `dynamics'` a+type Level a = Diff (Dynamic a) -dynamicSingle :: HasDynamic a => Score (Level Double) -> Score a -> Score a-dynamicSingle d a  = (duration a `stretchTo` d) `dynamicsSingle'` a+-- |+-- Class of types that can be transposed.+--+type Attenuable a+  = (HasDynamics a a,+     VectorSpace (Level a), AffineSpace (Dynamic a),+     {-IsLevel (Level a), -} IsDynamics (Dynamic a))  -- |--- Apply a dynamic level over a voice.+-- Transpose up. ---dynamicVoice :: HasDynamic a => Score (Level Double) -> Voice (Maybe a) -> Voice (Maybe a)-dynamicVoice d = scoreToVoice . dynamicSingle d . removeRests . voiceToScore+louder :: Attenuable a => Level a -> a -> a+louder a = dynamics %~ (.+^ a) +-- |+-- Transpose down.+--+softer :: Attenuable a => Level a -> a -> a+softer a = dynamics %~ (.-^ a) -dynamics' :: (HasDynamic a, HasPart' a) => Score (Level Double) -> Score a -> Score a-dynamics' ds = mapAllParts (fmap $ dynamicsSingle' ds)+-- |+-- Transpose down.+--+volume :: (Num (Dynamic t), HasDynamics s t, Dynamic s ~ Dynamic t) => Dynamic t -> s -> t+volume a = dynamics *~ a -dynamicsSingle' :: HasDynamic a => Score (Level Double) -> Score a -> Score a-dynamicsSingle' ds = applyDynSingle (fmap fromJust $ scoreToVoice ds)+-- |+-- Transpose down.+--+level :: Attenuable a => Dynamic a -> a -> a+level a = dynamics .~ a +compressor :: Attenuable a =>+  Dynamic a           -- ^ Threshold+  -> Scalar (Level a) -- ^ Ratio+  -> a+  -> a+compressor = error "Not implemented: compressor" -applyDynSingle :: HasDynamic a => Voice (Level Double) -> Score a -> Score a-applyDynSingle ds = applySingle ds3-    where-        -- ds2 :: Voice (Dyn2 Double)-        ds2 = mapValuesVoice dyn2 ds-        -- ds3 :: Voice (Score a -> Score a)-        ds3 = fmap g ds2+--+-- TODO non-linear fades etc+-- -        g (ec,ed,l,bc,bd) = id-                . (if ec then mapFirstSingle (setEndCresc     True) else id)-                . (if ed then mapFirstSingle (setEndDim       True) else id)-                . (if bc then mapFirstSingle (setBeginCresc   True) else id)-                . (if bd then mapFirstSingle (setBeginDim     True) else id)-                . maybe id (mapFirstSingle . setLevel) l-        mapFirstSingle f = mapPhraseSingle f id id+-- |+-- Fade in.+--+fadeIn :: (+  HasPosition a, HasDynamics a a, +  Dynamic a ~ Behavior c, Fractional c+  ) => Duration -> a -> a+fadeIn d x = x & dynamics *~ (_onset x >-> d `transform` unit) --- end cresc, end dim, level, begin cresc, begin dim-type LevelDiff a = (Bool, Bool, Maybe a, Bool, Bool)+-- |+-- Fade in.+--+fadeOut :: (+  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) -dyn2 :: Ord a => [Level a] -> [LevelDiff a]-dyn2 = snd . List.mapAccumL g (Nothing, False, False) -- level, cresc, dim-    where-        g (Nothing, False, False) (Level b)     = ((Just b,  False, False), (False, False, Just b,  False, False))-        g (Nothing, False, False) (Change b c)  = ((Just b,  b < c, b > c), (False, False, Just b,  b < c, b > c)) -        g (Just a , cr, dm) (Level b)-            | a == b                            = ((Just b,  False, False), (cr,    dm,    Nothing, False, False))-            | a /= b                            = ((Just b,  False, False), (cr,    dm,    Just b,  False, False))-        g (Just a , cr, dm) (Change b c)-            | a == b                            = ((Just b,  b < c, b > c), (cr,    dm,    Nothing, b < c, b > c))-            | a /= b                            = ((Just b,  b < c, b > c), (cr,    dm,    Just b,  b < c, b > c)) +newtype DynamicT n a = DynamicT { getDynamicT :: (n, a) }+  deriving (Eq, Ord, Show, Typeable, Functor,+    Applicative, Monad, Comonad, Transformable, Monoid, Semigroup) +instance (Monoid n, Num a) => Num (DynamicT n a) where+  (+) = liftA2 (+)+  (*) = liftA2 (*)+  (-) = liftA2 (-)+  abs = fmap abs+  signum = fmap signum+  fromInteger = pure . fromInteger -mapValuesVoice :: ([a] -> [b]) -> Voice a -> Voice b-mapValuesVoice f = (^. voice) . uncurry zip . second f . unzip . (^. from voice)+instance (Monoid n, Fractional a) => Fractional (DynamicT n a) where+  recip        = fmap recip+  fromRational = pure . fromRational +instance (Monoid n, Floating a) => Floating (DynamicT n a) where+  pi    = pure pi+  sqrt  = fmap sqrt+  exp   = fmap exp+  log   = fmap log+  sin   = fmap sin+  cos   = fmap cos+  asin  = fmap asin+  atan  = fmap atan+  acos  = fmap acos+  sinh  = fmap sinh+  cosh  = fmap cosh+  asinh = fmap asinh+  atanh = fmap atanh+  acosh = fmap acos +instance (Monoid n, Enum a) => Enum (DynamicT n a) where+  toEnum = pure . toEnum+  fromEnum = fromEnum . extract +instance (Monoid n, Bounded a) => Bounded (DynamicT n a) where+  minBound = pure minBound+  maxBound = pure maxBound -cresc :: IsDynamics a => Double -> Double -> a-cresc a b = fromDynamics $ DynamicsL (Just a, Just b)+-- instance (Monoid n, Num a, Ord a, Real a) => Real (DynamicT n a) where+--     toRational = toRational . extract+--+-- instance (Monoid n, Real a, Enum a, Integral a) => Integral (DynamicT n a) where+--     quot = liftA2 quot+--     rem = liftA2 rem+--     toInteger = toInteger . extract -dim :: IsDynamics a => Double -> Double -> a-dim a b = fromDynamics $ DynamicsL (Just a, Just b)+-- | Unsafe: Do not use 'Wrapped' instances+instance Wrapped (DynamicT p a) where+  type Unwrapped (DynamicT p a) = (p, a)+  _Wrapped' = iso getDynamicT DynamicT +instance Rewrapped (DynamicT p a) (DynamicT p' b) -resetDynamics :: HasDynamic c => c -> c-resetDynamics = setBeginCresc False . setEndCresc False . setBeginDim False . setEndDim False++type instance Dynamic (DynamicT p a) = p+type instance SetDynamic p' (DynamicT p a) = DynamicT p' a++instance (Transformable p, Transformable p') +  => HasDynamic (DynamicT p a) (DynamicT p' a) where+  dynamic = _Wrapped . _1++instance (Transformable p, Transformable p') +  => HasDynamics (DynamicT p a) (DynamicT p' a) where+  dynamics = _Wrapped . _1+++deriving instance (IsPitch a, Monoid n) => IsPitch (DynamicT n a)+deriving instance (IsInterval a, Monoid n) => IsInterval (DynamicT n a)++instance (IsDynamics n, Monoid a) => IsDynamics (DynamicT n a) where+    fromDynamics l = DynamicT (fromDynamics l, mempty)++deriving instance Reversible a => Reversible (DynamicT p a)++instance (Tiable n, Tiable a) => Tiable (DynamicT n a) where+  toTied (DynamicT (d,a)) = (DynamicT (d1,a1), DynamicT (d2,a2))+    where+      (a1,a2) = toTied a+      (d1,d2) = toTied d++-- |+-- View just the dynamices in a voice.+--+vdynamic :: ({-SetDynamic (Dynamic t) s ~ t,-} HasDynamic a a, HasDynamic a b) +  => Lens (Voice a) (Voice b) (Voice (Dynamic a)) (Voice (Dynamic b))++vdynamic = lens (fmap $ view dynamic) (flip $ zipVoiceWithNoScale (set dynamic))+-- vdynamic = through dynamic dynamic++addDynCon :: (+  HasPhrases s t a b, HasDynamic a a, HasDynamic a b, +  Dynamic a ~ d, Dynamic b ~ Ctxt d+  ) => s -> t+addDynCon = over (phrases.vdynamic) withContext
src/Music/Score/Export/Abc.hs view
@@ -1,2 +1,18 @@ +-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-- Provides ABC notation export.+--+-- /Warning/ Experimental module.+--+-------------------------------------------------------------------------------------+ module Music.Score.Export.Abc where
+ src/Music/Score/Export/ArticulationNotation.hs view
@@ -0,0 +1,131 @@++{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE ViewPatterns               #-}+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DefaultSignatures          #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FunctionalDependencies     #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------++module Music.Score.Export.ArticulationNotation (+    Slur(..),+    Mark(..),+    ArticulationNotation(..),+    notateArticulation,+  ) where++import Data.Semigroup+import Data.Functor.Context+import Control.Lens -- ()+import Music.Score.Articulation+import Music.Score.Instances+import Music.Score.Ties+import Music.Time++-- TODO need NoSlur etc?++data Slur = NoSlur | BeginSlur | EndSlur+  deriving (Eq, Ord, Show)++-- data CrescDim = NoCrescDim | BeginCresc | EndCresc | BeginDim | EndDim+data Mark = NoMark | Staccato | MoltoStaccato | Marcato | Accent | Tenuto+  deriving (Eq, Ord, Show)++instance Monoid Slur where+  mempty = NoSlur+  mappend NoSlur a = a+  mappend a NoSlur = a+  mappend a _ = a++instance Monoid Mark where+  mempty = NoMark+  mappend NoMark a = a+  mappend a NoMark = a+  mappend a _ = a++newtype ArticulationNotation +  = ArticulationNotation { getArticulationNotation :: ([Slur], [Mark]) }++instance Wrapped ArticulationNotation where+  type Unwrapped ArticulationNotation = ([Slur], [Mark])+  _Wrapped' = iso getArticulationNotation ArticulationNotation++instance Rewrapped ArticulationNotation ArticulationNotation++type instance Articulation ArticulationNotation = ArticulationNotation++instance Transformable ArticulationNotation where+  transform _ = id++instance Tiable ArticulationNotation where+  toTied (ArticulationNotation (beginEnd, marks)) +    = (ArticulationNotation (beginEnd, marks), +       ArticulationNotation (mempty, mempty))++instance Monoid ArticulationNotation where+  mempty = ArticulationNotation ([], [])+  ArticulationNotation ([], []) `mappend` y = y+  x `mappend` ArticulationNotation ([], []) = x+  x `mappend` y = x++-- TODO add slurs if separation is below some value...++getSeparationMarks :: Double -> [Mark]+getSeparationMarks = fst . getSeparationMarks'++hasSlur' :: Double -> Bool+hasSlur' = snd . getSeparationMarks'++getSeparationMarks' :: Double -> ([Mark], Bool)+getSeparationMarks' x+  |              x <= (-1) = ([], True)+  | (-1) <  x && x <  1    = ([], False)+  | 1    <= x && x <  2    = ([Staccato], False)+  | 2    <= x              = ([MoltoStaccato], False)++getAccentMarks :: Double -> [Mark]+getAccentMarks x+  |              x <= (-1) = []+  | (-1) <  x && x <  1    = []+  | 1    <= x && x <  2    = [Accent]+  | 2    <= x              = [Marcato]+  | otherwise           = []++hasSlur y = hasSlur' (realToFrac $ view separation $ y)+allMarks y = getSeparationMarks (realToFrac $ view separation $ y) <> getAccentMarks (realToFrac $ view accentuation $ y)++notateArticulation :: (Ord a, a ~ (Sum Double, Sum Double)) => Ctxt a -> ArticulationNotation+notateArticulation (Nothing, y, Nothing) = ArticulationNotation ([], allMarks y)+notateArticulation (Just x,  y, Nothing) = ArticulationNotation (if hasSlur x && hasSlur y then [EndSlur] else [], allMarks y)+notateArticulation (Nothing, y, Just z)  = ArticulationNotation (if hasSlur y && hasSlur z then [BeginSlur] else [], allMarks y)+notateArticulation (Just x,  y, Just z)  = ArticulationNotation (slur3 x y z, allMarks y)+  where+    slur3 x y z = case (hasSlur x, hasSlur y, hasSlur z) of+      (True, True, True)  -> [{-ContSlur-}]+      (False, True, True) -> [BeginSlur]+      (True, True, False) -> [EndSlur]+      _                   -> []+
+ src/Music/Score/Export/Backend.hs view
@@ -0,0 +1,238 @@++{-# 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       #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------++module Music.Score.Export.Backend (+    HasOrdPart,+    HasDynamic3,+    HasDynamicNotation,++    HasBackend(..),+    HasBackendScore(..),+    HasBackendNote(..),+    export+  ) where++import           Music.Dynamics.Literal+import           Music.Pitch.Literal+import qualified Codec.Midi                    as Midi+import           Control.Arrow                 ((***))+import           Control.Comonad               (Comonad (..), extract)+import           Control.Applicative+import           Data.Colour.Names             as Color+import           Data.Default+import           Data.Foldable                 (Foldable)+import qualified Data.Foldable+import           Data.Functor.Couple+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           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+++import Music.Time+import Music.Score.Dynamics+import Music.Score.Part+++type HasDynamic3 a a' a'' = (+  HasDynamic' a,+  HasDynamic a  a',+  HasDynamic a' a'',+  HasDynamic a  a''+  )++-- -- TODO move+-- class (+--   HasDynamic' a,+--   HasDynamic a  a',+--   HasDynamic a' a'',+--   HasDynamic a  a''+--   ) => HasDynamic3 a a' a'' where+-- +-- instance (b ~  SetDynamic (Ctxt (Dynamic MyNote)) MyNote, c ~ SetDynamic DynamicNotation MyNote) +--   => HasDynamic3 MyNote b c++type HasDynamicNotation a b c = (+  HasDynamic3 a b c,+  Dynamic b  ~ Ctxt (Dynamic a),+  Dynamic c ~ DynamicNotation,+  Real (Dynamic a),+  Part (SetDynamic (Dynamic a) a) ~ Part (SetDynamic DynamicNotation b)+ )+type HasOrdPart a = (HasPart' a, Ord (Part a))++++{-+-- TODO move+mapWithDur :: (Duration -> a -> b) -> Rhythm a -> Rhythm b+mapWithDur f = go+  where+    go (Beat d x)            = Beat d (f d x)+    go (Dotted n (Beat d x)) = Dotted n $ Beat d (f (dotMod n * d) x)+    go (Group rs)            = Group $ fmap (mapWithDur f) rs+    go (Tuplet m r)          = Tuplet m (mapWithDur f r)        ++extractTimeSignatures :: Score a -> ([Maybe TimeSignature], [Duration])+extractTimeSignatures score = (barTimeSignatures, barDurations)+  where                                          +    defaultTimeSignature = time 4 4+    timeSignatures = fmap swap +      $ view eventsV . fuse . reactiveToVoice' (0 <-> (score^.offset)) +      $ getTimeSignatures defaultTimeSignature score++    -- Despite the fuse above we need retainUpdates here to prevent redundant repetition of time signatures+    barTimeSignatures = retainUpdates $ getBarTimeSignatures timeSignatures+    barDurations = getBarDurations timeSignatures+++-}+++++-- |+-- This class defines types and functions for exporting music. It provides the+-- primitive types and methods used to implement 'export'.+--+-- The backend type @b@ is just a type level tag to identify a specific backend.+-- It is typically defined as an empty data declaration.+--+-- The actual conversion is handled by the subclasses 'HasBackendScore' and+-- 'HasBackendNote', which converts the time structure, and the contained music+-- respectively. Thus structure and content are handled separately.+--+-- It is often necessary to alter the events based on their surrounding context: for+-- examples the beginning and end of spanners and beams depend on surrounding notes.+-- The 'BackendContext' type allow 'HasBackendScore' instances to provide context for+-- 'HasBackendNote' instances.+--+-- @+-- data NoteList+--+-- instance HasBackend NoteList where+--   type BackendScore NoteList     = []+--   type BackendContext NoteList   = Identity+--   type BackendNote NoteList      = [(Sum Int, Int)]+--   type BackendMusic NoteList     = [(Sum Int, Int)]+--   finalizeExport _ = concat+--+-- instance HasBackendScore NoteList [a] a where+--   exportScore _ = fmap Identity+--+-- instance HasBackendNote NoteList a => HasBackendNote NoteList [a] where+--   exportNote b ps = mconcat $ map (exportNote b) $ sequenceA ps+--+-- instance HasBackendNote NoteList Int where+--   exportNote _ (Identity p) = [(mempty ,p)]+--+-- instance HasBackendNote NoteList a => HasBackendNote NoteList (DynamicT (Sum Int) a) where+--   exportNote b (Identity (DynamicT (d,ps))) = set (mapped._1) d $ exportNote b (Identity ps)+-- -- @+--+--+class Functor (BackendScore b) => HasBackend b where+  -- | External music representation+  type BackendMusic b :: *++  -- | Notes, chords and rests, with output handled by 'HasBackendNote'+  type BackendNote b :: *++  -- | Score, voice and time structure, with output handled by 'HasBackendScore'+  type BackendScore b :: * -> *++  -- | This type may be used to pass context from 'exportScore' to 'exportNote'.+  --   If the note export is not context-sensitive, 'Identity' can be used.+  type BackendContext b :: * -> *++  finalizeExport :: b -> BackendScore b (BackendNote b) -> BackendMusic b++-- |+-- A class for musical container types with an external representation.+--+-- The first type parameter is simply a token representing the external format,+-- and the second parameter is the type being represented. In a sense, the first+-- parameter saves us from defining a separate class for each external representation,+-- so rather than having `HasMidiScore`, `HasMusicXmlScore` and so on, we have +-- 'HasBackendScore' 'Midi', 'HasBackendScore' 'MusicXml' and so on.+--+class (HasBackend b) => HasBackendScore b s where++  -- | Type of events in this score type.+  --   This is generally just the parameterized type in a container, so we have+  --   +  --   @+  --   BackendScoreEvent (Score a) ~ a+  --   BackendScoreEvent (Voice a) ~ a+  --   @+  --+  --   and so on.+  --+  --   It is defined as a type function so that instances can put constraints on the+  --   saturated type, rather than being parametric over all note types.+  --+  type BackendScoreEvent b s :: *+  exportScore :: b -> s -> BackendScore b (BackendContext b (BackendScoreEvent b s))++-- |+-- A class for musical event types with an external representation.+--+-- The first type parameter is simply a token representing the external format,+-- and the second parameter is the type being represented. In a sense, the first+-- parameter saves us from defining a separate class for each external representation,+-- so rather than having `HasMidiNote`, `HasMusicXmlNote` and so on, we have +-- 'HasBackendNote' 'Midi', 'HasBackendNote' 'MusicXml' and so on.+--+class (HasBackend b) => HasBackendNote b a where+  exportNote  :: b -> BackendContext b a   -> BackendNote b+  exportChord :: b -> BackendContext b [a] -> BackendNote b+  exportChord = error "Not implemented: exportChord"++-- |+-- This is the primitive music export function.+--+-- 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+
− src/Music/Score/Export/Common.hs 
@@ -1,105 +0,0 @@--{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies               #-}------------------------------------------------------------------------------------------ |--- Copyright   : (c) Hans Hoglund 2012------ License     : BSD-style------ Maintainer  : hans@hanshoglund.se--- Stability   : experimental--- Portability : non-portable (TF,GNTD)-------------------------------------------------------------------------------------------module Music.Score.Export.Common (-        voiceToBars',-        -- separateBars,-        spellPitch,-        toRelative,-  ) where--import           Prelude                  hiding (concat, concatMap, foldl,-                                           foldr, mapM, maximum, minimum, sum)--import           Control.Applicative-import           Control.Lens-import           Control.Monad            hiding (mapM)-import           Control.Monad.Plus-import           Data.AffineSpace-import           Data.AffineSpace.Point-import           Data.Basis-import           Data.Either-import           Data.Foldable-import           Data.Function            (on)-import           Data.Maybe-import           Data.Ord                 (comparing)-import           Data.Ratio-import           Data.Semigroup-import           Data.String-import           Data.Traversable-import           Data.Typeable-import           Data.VectorSpace--import           Music.Score.Articulation-import           Music.Score.Combinators-import           Music.Score.Convert-import           Music.Score.Dynamics-import           Music.Score.Ornaments-import           Music.Score.Part-import           Music.Score.Pitch-import           Music.Score.Rhythm-import           Music.Score.Score-import           Music.Score.Ties-import           Music.Score.Track-import           Music.Score.Voice-import           Music.Time--import qualified Codec.Midi               as Midi-import qualified Data.List                as List-import qualified Data.Map                 as Map-import qualified Music.Lilypond           as Lilypond-import qualified Music.MusicXml.Simple    as Xml-import qualified Text.Pretty              as Pretty--import           Music.Dynamics.Literal-import           Music.Pitch.Literal-import           Music.Score.Util-import           System.IO.Unsafe-import           System.Process---- | Convert a voice to a list of bars using the given bar durations.-voiceToBars' :: Tiable a => [Duration] -> Voice (Maybe a) -> [[(Duration, Maybe a)]]-voiceToBars' barDurs = fmap (^. from voice) . splitTiesVoiceAt barDurs--- TODO remove prime from name---- | Convert absolute to relative durations.-toRelative :: [(Time, Duration, b)] -> [(Time, Duration, b)]-toRelative = snd . mapAccumL g origin-    where-        g now (t,d,x) = (t, (origin .+^ (t .-. now),d,x))---- | Basic spelling for integral types.-spellPitch :: Integral a => a -> (a, a, a)-spellPitch p = (-    pitchClass,-    alteration,-    octave-    )-    where-        octave     = (p `div` 12) - 1-        semitone   = p `mod` 12-        pitchClass = fromStep major semitone-        alteration = semitone - step major pitchClass--        step xs p = xs !! (fromIntegral p `mod` length xs)-        fromStep xs p = fromIntegral $ fromMaybe (length xs - 1) $ List.findIndex (>= p) xs-        scaleFromSteps = snd . List.mapAccumL add 0-            where-                add a x = (a + x, a + x)-        major = scaleFromSteps [0,2,2,1,2,2,2,1]-
+ src/Music/Score/Export/DynamicNotation.hs view
@@ -0,0 +1,110 @@++{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE ViewPatterns               #-}+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DefaultSignatures          #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FunctionalDependencies     #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------++module Music.Score.Export.DynamicNotation (+    CrescDim(..),+    DynamicNotation(..),+    notateDynamic,+  ) where++import Data.Semigroup+import Data.Functor.Context+import Control.Lens -- ()+import Music.Score.Dynamics+import Music.Score.Ties+import Music.Time+++data CrescDim = NoCrescDim | BeginCresc | EndCresc | BeginDim | EndDim+  deriving (Eq, Ord, Show)++instance Monoid CrescDim where+  mempty = NoCrescDim+  mappend NoCrescDim a = a+  mappend a NoCrescDim = a+  mappend a _ = a++newtype DynamicNotation +  = DynamicNotation { getDynamicNotation :: ([CrescDim], Maybe Double) }++instance Wrapped DynamicNotation where+  type Unwrapped DynamicNotation = ([CrescDim], Maybe Double)+  _Wrapped' = iso getDynamicNotation DynamicNotation++instance Rewrapped DynamicNotation DynamicNotation++type instance Dynamic DynamicNotation = DynamicNotation++instance Transformable DynamicNotation where+  transform _ = id++instance Tiable DynamicNotation where+  toTied (DynamicNotation (beginEnd, marks)) +    = (DynamicNotation (beginEnd, marks), +       DynamicNotation (mempty, Nothing))++instance Monoid DynamicNotation where+  mempty = DynamicNotation ([], Nothing)+  DynamicNotation ([], Nothing) `mappend` y = y+  x `mappend` DynamicNotation ([], Nothing) = x+  x `mappend` y = x++-- Given a dynamic value and its context, decide:+--+--   1) Whether we should begin or end a crescendo or diminuendo+--   2) Whether we should display the current dynamic value+--+notateDynamic :: (Ord a, Real a) => Ctxt a -> DynamicNotation+notateDynamic x = DynamicNotation $ over _2 (\t -> if t then Just (realToFrac $ extractCtxt x) else Nothing) $ case x of+  (Nothing, y, Nothing) -> ([], True)+  (Nothing, y, Just z ) -> case (y `compare` z) of+    LT      -> ([BeginCresc], True)+    EQ      -> ([],           True)+    GT      -> ([BeginDim],   True)+  (Just x,  y, Just z ) -> case (x `compare` y, y `compare` z) of+    (LT,LT) -> ([NoCrescDim], False)+    (LT,EQ) -> ([EndCresc],   True)+    (EQ,LT) -> ([BeginCresc], False{-True-})++    (GT,GT) -> ([NoCrescDim], False)+    (GT,EQ) -> ([EndDim],     True)+    (EQ,GT) -> ([BeginDim],   False{-True-})++    (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)
src/Music/Score/Export/Lilypond.hs view
@@ -1,19 +1,24 @@ +{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE ViewPatterns               #-} {-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DefaultSignatures          #-} {-# LANGUAGE DeriveFoldable             #-} {-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE NoMonomorphismRestriction  #-} {-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE StandaloneDeriving         #-} {-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeOperators              #-}-{-# LANGUAGE ViewPatterns               #-}+{-# LANGUAGE UndecidableInstances       #-}  ------------------------------------------------------------------------------------- -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund 2012-2014 -- -- License     : BSD-style --@@ -24,415 +29,664 @@ -------------------------------------------------------------------------------------  module Music.Score.Export.Lilypond (-        Lilypond,-        HasLilypond(..),--        toLilypond,-        toLilypondString,--        showLilypond,-        openLilypond,-        writeLilypond,+    -- * Lilypond backend+    HasLilypondInstrument(..),+    Lilypond,+    LyContext(..),+    HasLilypond,+    +    -- ** Converting to Lilypond+    toLilypond,+    toLilypondString,    +    +    -- ** Lilypond I/O+    showLilypond,+    openLilypond,+    writeLilypond, -        -- * Options-        LilypondOptions(..),-        writeLilypond',-        openLilypond',+    -- ** Customize Lilypond backend+    LilypondOptions(..),+    openLilypond',+    writeLilypond',   ) where -import           Prelude                      hiding (concat, concatMap, foldl,-                                               foldr, mapM, maximum, minimum,-                                               sum)-+import           Music.Dynamics.Literal+import           Music.Pitch.Literal+import qualified Codec.Midi                    as Midi+import           Control.Arrow                 ((***))+import           Control.Comonad               (Comonad (..), extract) import           Control.Applicative-import           Control.Arrow-import           Control.Lens                 hiding (rewrite)-import           Control.Monad                hiding (mapM)-import           Data.AffineSpace+import           Data.Colour.Names             as Color import           Data.Default-import           Data.Foldable-import           Data.Function                (on)-import           Data.Maybe                   (fromMaybe)-import           Data.Ord                     (comparing)+import           Data.Foldable                 (Foldable)+import qualified Data.Foldable+import           Data.Functor.Couple+import           Data.Maybe import           Data.Ratio-import           Data.Semigroup-import           Data.String-import           Data.Traversable-import           Data.Typeable-import           Data.VectorSpace             hiding (Sum)+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', voiceToScore) -- TODO+import           Music.Score.Internal.Util (composed, unRatio, swap, retainUpdates)+import Music.Score.Export.DynamicNotation+import Music.Score.Export.ArticulationNotation+import Data.Semigroup.Instances -import           Music.Dynamics.Literal-import           Music.Pitch.Literal-import           Music.Score.Articulation-import           Music.Score.Chord-import           Music.Score.Clef-import           Music.Score.Combinators-import           Music.Score.Convert-import           Music.Score.Dynamics-import           Music.Score.Export.Common-import           Music.Score.Instances-import           Music.Score.Meta-import           Music.Score.Meta.Attribution-import           Music.Score.Meta.Clef-import           Music.Score.Meta.Time-import           Music.Score.Meta.Title-import           Music.Score.Ornaments-import           Music.Score.Part-import           Music.Score.Pitch-import           Music.Score.Rhythm-import           Music.Score.Score-import           Music.Score.Ties-import           Music.Score.Track-import           Music.Score.Util-import           Music.Score.Voice-import           Music.Time-import           Music.Time.Reactive          (initial)+import Music.Score.Export.Backend -import qualified Codec.Midi                   as Midi-import qualified Data.List                    as List-import qualified Data.Map                     as Map-import qualified Music.Lilypond               as Lilypond-import qualified Music.MusicXml.Simple        as Xml-import qualified Text.Pretty                  as Pretty+import Data.Functor.Identity+import Data.Semigroup+import Control.Monad+import Data.VectorSpace hiding (Sum(..))+import Data.AffineSpace+import Control.Lens hiding (rewrite)+-- import Control.Lens.Operators hiding ((|>)) +import Music.Time+import Music.Score.Meta+import Music.Score.Dynamics+import Music.Score.Articulation+import Music.Score.Part+import Music.Score.Tremolo+import Music.Score.Text+import Music.Score.Harmonics+import Music.Score.Slide+import Music.Score.Color+import Music.Score.Ties+import Music.Score.Export.Backend+import Music.Score.Meta.Time+import Music.Score.Phrases -type Lilypond = Lilypond.Music --- |--- Class of types that can be converted to Lilypond.+++++++-- | +-- Extract instrument info as per "Music.Part"+-- This is really crude, needs rethinking! ---class Tiable a => HasLilypond a where+class HasLilypondInstrument a where+  getLilypondClef :: a -> Int -    -- |-    -- Convert a value to a Lilypond music expression.-    ---    getLilypond      :: Duration -> a -> Lilypond -    getLilypondChord :: Duration -> [a] -> Lilypond-    getLilypondChord d = pcatLilypond . fmap (getLilypond d)+{-+  TODO rewrite so that:+    - Each bar may include voices/layers (a la Sibelius)+    - Each part may generate more than one staff (for piano etc)+-} -    getLilypondWithPrefix      :: Duration -> a -> (Lilypond -> Lilypond,Lilypond)-    getLilypondWithPrefix d x = (id, getLilypond d x) -    getLilypondChordWithPrefix :: Duration -> [a] -> (Lilypond -> Lilypond,Lilypond)-    getLilypondChordWithPrefix d x = (id, getLilypondChord d x)+-- | A token to represent the Lilypond backend.+data Lilypond -instance HasLilypond Int                        where   getLilypond d = getLilypond d . toInteger-instance HasLilypond Float                      where   getLilypond d = getLilypond d . toInteger . round-instance HasLilypond Double                     where   getLilypond d = getLilypond d . toInteger . round-instance Integral a => HasLilypond (Ratio a)    where   getLilypond d = getLilypond d . toInteger . round+data ScoreInfo = ScoreInfo+  deriving (Eq, Show) -instance HasLilypond Integer where-    getLilypond      d = (^*realToFrac (d*4)) . Lilypond.note  . spellLilypond-    getLilypondChord d = (^*realToFrac (d*4)) . Lilypond.chord . fmap spellLilypond+data StaffInfo = StaffInfo { staffName :: String, +                             staffClef :: Lilypond.Clef } +  deriving (Eq, Show) -instance HasLilypond a => HasLilypond (ChordT a) where-    getLilypond d = getLilypondChord d . getChordT+data BarInfo = BarInfo { barTimeSignature :: Maybe TimeSignature } +  deriving (Eq, Show) -instance HasLilypond a => HasLilypond (PartT n a) where-    getLilypond d (PartT (_,x))                     = getLilypond d x+-- | Hierachical representation of a Lilypond score.+--   A score is a parallel composition of staves.+data LyScore a = LyScore { getLyScore :: (ScoreInfo, [LyStaff a]) }+  deriving (Functor, Eq, Show) -instance HasLilypond a => HasLilypond (TieT a) where-    getLilypond d (TieT ((Any ta, Any tb),x)) = addTies $ getLilypond d x-        where-            addTies | ta && tb                      = id . Lilypond.beginTie-                    | tb                            = Lilypond.beginTie-                    | ta                            = id-                    | otherwise                     = id+-- | A staff is a sequential composition of bars.+data LyStaff a = LyStaff { getLyStaff :: (StaffInfo, [LyBar a]) }+  deriving (Functor, Eq, Show) -instance HasLilypond a => HasLilypond (DynamicT a) where-    getLilypond d (DynamicT (((Any ec,Any ed),Option l,(Any bc,Any bd)), a)) = notate $ getLilypond d a-        where-            notate x = nec . ned . nl . nbc . nbd $ x-            nec    = if ec then Lilypond.endCresc    else id-            ned    = if ed then Lilypond.endDim      else id-            nbc    = if bc then Lilypond.beginCresc  else id-            nbd    = if bd then Lilypond.beginDim    else id-            nl     = case l of-                Nothing          -> id-                Just (First lvl) -> Lilypond.addDynamics (fromDynamics (DynamicsL (Just lvl, Nothing)))+-- | A bar is a sequential composition of chords/notes/rests.+data LyBar a = LyBar { getLyBar :: (BarInfo, Rhythm a) } +  deriving (Functor, Eq, Show) -instance HasLilypond a => HasLilypond (ArticulationT a) where-    getLilypond d (ArticulationT (((Any es, Any us, Any bs), (Sum al, Sum sl)), a)) = notate $ getLilypond d a-        where-            notate = nes . nal . nsl . nbs-            nes    = if es then Lilypond.endSlur else id-            nal    = case al of-                0    -> id-                1    -> Lilypond.addAccent-                2    -> Lilypond.addMarcato-            nsl    = case sl of-                (-2) -> Lilypond.addTenuto-                (-1) -> Lilypond.addPortato-                0    -> id-                1    -> Lilypond.addStaccato-                2    -> Lilypond.addStaccatissimo-            nbs    = if bs then Lilypond.beginSlur else id+-- | Context passed to the note export.+--   Includes duration and note/rest distinction.+data LyContext a = LyContext Duration (Maybe a)+  deriving (Functor, Foldable, Traversable, Eq, Show) -instance HasLilypond a => HasLilypond (TremoloT a) where-    getLilypond d (TremoloT (Sum 0, x)) = getLilypond d x-    getLilypond d (TremoloT (Sum n, x)) = notate $ getLilypond newDur x+{-+TODO move+instance Monoid Lilypond.Music where+  mempty      = pcatLy []+  mappend x y = pcatLy [x,y]+-}++type LyMusic = Lilypond.Music++instance HasBackend Lilypond where+  type BackendScore Lilypond   = LyScore+  type BackendContext Lilypond = LyContext+  type BackendNote Lilypond    = LyMusic+  type BackendMusic Lilypond   = LyMusic++  finalizeExport _ = finalizeScore+    where+      finalizeScore :: LyScore LyMusic -> Lilypond.Music+      finalizeScore (LyScore (info, x)) +        = pcatLy +        . map finalizeStaff $ x         where-            scale   = 2^n-            newDur  = (d `min` (1/4)) / scale-            repeats = d / newDur-            notate = Lilypond.Tremolo (round repeats)+          extra = id -instance HasLilypond a => HasLilypond (TextT a) where-    getLilypond d (TextT (s,x)) = notate s $ getLilypond d x+      -- TODO finalizeStaffGroup++      finalizeStaff :: LyStaff LyMusic -> LyMusic+      finalizeStaff (LyStaff (info, x)) +        = addStaff +        . addPartName (staffName info) +        . addClef (staffClef info)+        . scatLy +        . map finalizeBar $ x         where-            notate ts = foldr (.) id (fmap Lilypond.addText ts)+          addStaff                = Lilypond.New "Staff" Nothing+          addClef c x             = scatLy [Lilypond.Clef c, x]+          addPartName partName xs = scatLy [longName, shortName, xs]+            where+              longName  = Lilypond.Set "Staff.instrumentName" (Lilypond.toValue partName)+              shortName = Lilypond.Set "Staff.shortInstrumentName" (Lilypond.toValue partName) -instance HasLilypond a => HasLilypond (HarmonicT a) where-    getLilypond d (HarmonicT ((view _Wrapped' -> isNat, view _Wrapped' -> n),x)) = notate isNat n $ getLilypond d x+      finalizeBar :: LyBar LyMusic -> LyMusic+      finalizeBar (LyBar (BarInfo timeSignature, x))+        = maybe id setBarTimeSignature timeSignature +        . renderBarMusic $ x         where-            notate _     0 = id-            notate True  n = notateNatural n-            notate False n = notateArtificial n+          -- TODO key signatures+          -- TODO rehearsal marks+          -- TODO bar number change+          -- TODO compound time signatures+          setBarTimeSignature (getTimeSignature -> (ms, n)) x = scatLy [Lilypond.Time (sum ms) n, x]+          +      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 (Tuplet m r)          = Lilypond.Times (realToFrac m) (renderBarMusic r)+            where+              (a,b) = fromIntegral *** fromIntegral $ unRatio $ realToFrac m -            notateNatural n = Lilypond.addFlageolet -- addOpen?+-- TODO move+second f (x, y) = (x, f y) -            notateArtificial n = id -- TODO+type HasArticulation3 c d e = (+  HasArticulation' c,+  HasArticulation c d,+  HasArticulation d e,+  HasArticulation c e+  ) -instance HasLilypond a => HasLilypond (SlideT a) where-    getLilypond d (SlideT (((eg,es),(bg,bs)),a)) = notate $ getLilypond d a-        where-            notate = if view _Wrapped' bg || view _Wrapped' bs then Lilypond.beginGlissando else id+type HasArticulationNotation a b c = (+  HasArticulation3 a b c,+  Articulation b  ~ Ctxt (Articulation a),+  Articulation c ~ ArticulationNotation,+  -- TODO generalize+  Articulation a ~ (Sum Double, Sum Double)+ ) -instance HasLilypond a => HasLilypond (ClefT a) where-    -- TODO consolidate-    getLilypondWithPrefix d (ClefT (c, a)) = (notate c, getLilypond d a)++instance (                  +  HasDynamicNotation a b c,+  HasArticulationNotation c d e,+  Part e ~ Part c,+  HasOrdPart a, +  Transformable a, +  Semigroup a,+  Tiable e,+  HasOrdPart c, Show (Part c), HasLilypondInstrument (Part c)+  )+  => HasBackendScore Lilypond (Score a) where+  type BackendScoreEvent Lilypond (Score a) = SetArticulation ArticulationNotation (SetDynamic DynamicNotation a)+  exportScore b score = LyScore +    . (ScoreInfo,)+    . map (uncurry $ exportPart timeSignatureMarks barDurations)+    . map (second (over articulations notateArticulation)) +    . map (second (preserveMeta addArtCon))+    . map (second (over dynamics notateDynamic)) +    . map (second (preserveMeta addDynCon))+    . map (second (preserveMeta simultaneous)) +    . extractParts'+    $ score+    where+      (timeSignatureMarks, barDurations) = extractTimeSignatures score +++      -- | Export a score as a single part. Overlapping notes will cause an error.+      exportPart :: (+        Show (Part a),+        HasLilypondInstrument (Part a),+        Tiable a+        ) +        => [Maybe TimeSignature] +        -> [Duration] +        -> Part a +        -> Score a +        -> LyStaff (LyContext a)++      exportStaff :: Tiable a +        => [Maybe TimeSignature] +        -> [Duration] +        -> String -- ^ name+        -> Int    -- ^ clef, as per Music.Parts+        -> MVoice a +        -> LyStaff (LyContext a)++      exportBar :: Tiable a +        => Maybe TimeSignature +        -> MVoice a +        -> LyBar (LyContext a)++      quantizeBar :: Tiable a +        => MVoice a +        -> Rhythm (LyContext a)++      exportPart timeSignatureMarks barDurations part+        = exportStaff timeSignatureMarks barDurations (show part) (getLilypondClef part)+        . view singleMVoice++      exportStaff timeSignatures barDurations name clefId +        = LyStaff +        . addStaffInfo+        . zipWith exportBar timeSignatures +        . splitIntoBars barDurations         where-            notate c = case fmap getLast $ getOption c of-                Nothing -> id-                Just c -> \x -> Lilypond.Sequential [addClef c, x]-    getLilypond d           (ClefT (c, a)) = notate c $ getLilypond d a+          clef = case clefId of+            0 -> Lilypond.Treble+            1 -> Lilypond.Alto+            2 -> Lilypond.Bass+          addStaffInfo  = (,) $ StaffInfo { staffName = name, staffClef = clef }+          splitIntoBars = splitTiesVoiceAt++      exportBar timeSignature+        = LyBar +        . addBarInfo +        . quantizeBar+       where+         addBarInfo = (,) $ BarInfo timeSignature++      quantizeBar = mapWithDur LyContext . rewrite . handleErrors . quantize . view eventsV         where-            notate c = case fmap getLast $ getOption c of-                Nothing -> id-                Just c -> \x -> Lilypond.Sequential [addClef c, x]+          -- FIXME propagate quantization errors+          handleErrors (Left e)  = error $ "Quantization failed: " ++ e+          handleErrors (Right x) = x -instance HasLilypond a => HasLilypond (Behavior a) where-    getLilypond d = getLilypond d . (? 0)+-- TODO move+addArtCon :: (+  HasPhrases s t a b, HasArticulation a a, HasArticulation a b, +  Articulation a ~ d, Articulation b ~ Ctxt d+  ) => s -> t+addArtCon = over (phrases.varticulation) withContext+varticulation = lens (fmap $ view articulation) (flip $ zipVoiceWithNoScale (set articulation))  --- TODO-addClef GClef = Lilypond.Clef Lilypond.Treble-addClef CClef = Lilypond.Clef Lilypond.Alto-addClef FClef = Lilypond.Clef Lilypond.Bass +{-+-- TODO customize and remove extraction-related constraints+instance (+  HasDynamicNotation a b c,+  HasOrdPart a, Transformable a, Semigroup a,+  HasOrdPart c, Show (Part c), HasLilypondInstrument (Part c), Tiable c+  )+  => HasBackendScore Lilypond (Voice a) where+  type BackendScoreEvent Lilypond (Voice a) = SetDynamic DynamicNotation a+  exportScore b = exportScore b . voiceToScore+-} -pcatLilypond :: [Lilypond] -> Lilypond-pcatLilypond = pcatLilypond' False+-------------------------------------------------------------------------------- -pcatLilypond' :: Bool -> [Lilypond] -> Lilypond-pcatLilypond' p = foldr Lilypond.simultaneous e+{-+  Note:+    We want all note transformers to be applicative morphisms, i.e.+      +      notate (pure x)   = pure (notate x)++    Specifically+      notate (mempty,x) = id . notate x++  Note:+    We use these idioms:+      exportNote b = exportNote b . fmap extract+      exportNote b = uncurry notate . fmap (exportNote b) . getTieT . sequenceA++   The latter looks a lot like cotraverse. Generalization?+   +      +-}++instance HasBackendNote Lilypond a => HasBackendNote Lilypond [a] where+  exportNote = exportChord++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++  exportChord _ (LyContext d Nothing)    = (^*realToFrac (4*d)) Lilypond.rest+  exportChord _ (LyContext d (Just xs))  = (^*realToFrac (4*d)) $ Lilypond.chord $ fmap spellLy xs++instance HasBackendNote Lilypond Int where+  exportNote b = exportNote b . fmap toInteger+  exportChord b = exportChord b . fmap (fmap toInteger)++instance HasBackendNote Lilypond Float where+  exportNote b = exportNote b . fmap (toInteger . round)+  exportChord b = exportChord b . fmap (fmap (toInteger . round))++instance HasBackendNote Lilypond Double where+  exportNote b = exportNote b . fmap (toInteger . round)+  exportChord b = exportChord b . fmap (fmap (toInteger . round))++instance Integral a => HasBackendNote Lilypond (Ratio a) where+  exportNote b = exportNote b . fmap (toInteger . round)++instance HasBackendNote Lilypond a => HasBackendNote Lilypond (Behavior a) where+  exportNote b = exportNote b . fmap (! 0)+  exportChord b = exportChord b . fmap (fmap (! 0))++instance HasBackendNote Lilypond a => HasBackendNote Lilypond (Sum a) where+  exportNote b = exportNote b . fmap getSum++instance HasBackendNote Lilypond a => HasBackendNote Lilypond (Product a) where+  exportNote b = exportNote b . fmap getProduct++instance HasBackendNote Lilypond a => HasBackendNote Lilypond (PartT n a) where+  -- Part structure is handled by HasMidiBackendScore instances, so this is just an identity+  exportNote b = exportNote b . fmap extract+  exportChord b = exportChord b . fmap (fmap extract)++instance HasBackendNote Lilypond a => HasBackendNote Lilypond (DynamicT DynamicNotation a) where+  exportNote b = uncurry notate . fmap (exportNote b) . getDynamicT . sequenceA     where-        e = Lilypond.Simultaneous p []+      notate :: DynamicNotation -> LyMusic -> LyMusic+      notate (DynamicNotation (crescDims, level)) +        = rcomposed (fmap notateCrescDim crescDims) +        . notateLevel level -scatLilypond :: [Lilypond] -> Lilypond-scatLilypond = foldr Lilypond.sequential e+      notateCrescDim crescDims = case crescDims of+        NoCrescDim -> id+        BeginCresc -> Lilypond.beginCresc+        EndCresc   -> Lilypond.endCresc+        BeginDim   -> Lilypond.beginDim+        EndDim     -> Lilypond.endDim++      -- TODO these literals are not so nice...+      notateLevel showLevel = case showLevel of+         Nothing -> id+         Just lvl -> Lilypond.addDynamics (fromDynamics (DynamicsL (Just (fixLevel . realToFrac $ lvl), Nothing)))+      +      fixLevel :: Double -> Double+      fixLevel x = fromIntegral (round (x - 0.5)) + 0.5++      -- Use rcomposed as notateDynamic returns "mark" order, not application order+      rcomposed = composed . reverse++instance HasBackendNote Lilypond a => HasBackendNote Lilypond (ArticulationT ArticulationNotation a) where+  exportNote b = uncurry notate . fmap (exportNote b) . getArticulationT . sequenceA     where-        e = Lilypond.Sequential []+      notate :: ArticulationNotation -> LyMusic -> LyMusic+      notate (ArticulationNotation (slurs, marks))+        = rcomposed (fmap notateMark marks) +        . rcomposed (fmap notateSlur slurs) +        +      notateMark mark = case mark of+        NoMark         -> id+        Staccato       -> Lilypond.addStaccato+        MoltoStaccato  -> Lilypond.addStaccatissimo+        Marcato        -> Lilypond.addMarcato+        Accent         -> Lilypond.addAccent+        Tenuto         -> Lilypond.addTenuto +      notateSlur slurs = case slurs of+        NoSlur    -> id+        BeginSlur -> Lilypond.beginSlur+        EndSlur   -> Lilypond.endSlur +      -- Use rcomposed as notateDynamic returns "mark" order, not application order+      rcomposed = composed . reverse+    +instance HasBackendNote Lilypond a => HasBackendNote Lilypond (ColorT a) where+  exportNote b = uncurry notate . fmap (exportNote b) . getCouple . getColorT . sequenceA+    where+      -- TODO This syntax will change in future Lilypond versions+      -- TODO handle any color+      notate (Option Nothing)             = id+      notate (Option (Just (Last color))) = \x -> Lilypond.Sequential [+        Lilypond.Override "NoteHead#' color" +          (Lilypond.toLiteralValue $ "#" ++ colorName color),+        x,+        Lilypond.Revert "NoteHead#' color"+        ]++      colorName c+        | c == Color.black = "black"+        | c == Color.red   = "red"+        | c == Color.blue  = "blue"+        | otherwise        = error "Lilypond backend: Unkown color"++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)     ++instance HasBackendNote Lilypond a => HasBackendNote Lilypond (TextT a) where+  exportNote b = uncurry notate . fmap (exportNote b) . getCouple . getTextT . sequenceA+    where+      notate texts = composed (fmap Lilypond.addText texts)++instance HasBackendNote Lilypond a => HasBackendNote Lilypond (HarmonicT a) where+  exportNote b = uncurry notate . fmap (exportNote b) . getCouple . getHarmonicT . sequenceA+    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++instance HasBackendNote Lilypond a => HasBackendNote Lilypond (SlideT a) where+  exportNote b = uncurry notate . fmap (exportNote b) . getCouple . getSlideT . sequenceA+    where+      notate ((Any eg, Any es),(Any bg, Any bs))+        | bg  = Lilypond.beginGlissando+        | bs  = Lilypond.beginGlissando+        | otherwise = id++instance HasBackendNote Lilypond a => HasBackendNote Lilypond (TieT a) where+  exportNote b = uncurry notate . fmap (exportNote b) . getTieT . sequenceA+    where+      notate (Any ta, Any tb)+        | ta && tb  = Lilypond.beginTie+        | tb        = Lilypond.beginTie+        | ta        = id+        | otherwise = id+ -- |+-- Constraint for types that has a Lilypond representation.+--+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 = export (undefined::Lilypond)+++-- | -- Convert a score to a Lilypond representaiton and print it on the standard output. ---showLilypond :: (HasLilypond a, HasPart' a, Semigroup a) => Score a -> IO ()+showLilypond :: HasLilypond a => a -> IO () showLilypond = putStrLn . toLilypondString  -- | -- Convert a score to a Lilypond representation and write to a file. ---writeLilypond :: (HasLilypond a, HasPart' a, Semigroup a) => FilePath -> Score a -> IO ()+writeLilypond :: HasLilypond a => FilePath -> a -> IO () writeLilypond = writeLilypond' def  data LilypondOptions-    = Inline-    | Score+  = LyInlineFormat+  | LyScoreFormat+ instance Default LilypondOptions where-    def = Inline+  def = LyInlineFormat  -- | -- Convert a score to a Lilypond representation and write to a file. ---writeLilypond' :: (HasLilypond a, HasPart' a, Semigroup a) => LilypondOptions -> FilePath -> Score a -> IO ()+writeLilypond' :: HasLilypond a => LilypondOptions -> FilePath -> a -> IO () writeLilypond' options path sc = writeFile path $ (lyFilePrefix ++) $ toLilypondString sc-    where-        title    = fromMaybe "" $ flip getTitleAt 0                  $ metaAtStart sc-        composer = fromMaybe "" $ flip getAttribution "composer"     $ metaAtStart sc+  where+    -- title    = fromMaybe "" $ flip getTitleAt 0                  $ metaAtStart sc+    -- composer = fromMaybe "" $ flip getAttribution "composer"     $ metaAtStart sc+    title = ""+    composer = ""+    -- TODO generalize metaAtStart! -        lyFilePrefix = case options of-            Inline -> lyInlinePrefix-            Score  -> lyScorePrefix+    lyFilePrefix = case options of+        LyInlineFormat -> lyInlinePrefix+        LyScoreFormat  -> lyScorePrefix -        lyInlinePrefix = mempty                                        ++-            "%%% Generated by music-score %%%\n"                       ++-            "\\include \"lilypond-book-preamble.ly\"\n"                ++-            "\\paper {\n"                                              ++-            "  #(define dump-extents #t)\n"                            ++-            "\n"                                                       ++-            "  indent = 0\\mm\n"                                       ++-            "  line-width = 210\\mm - 2.0 * 0.4\\in\n"                 ++-            "  ragged-right = ##t\n"                                   ++-            "  force-assignment = #\"\"\n"                             ++-            "  line-width = #(- line-width (* mm  3.000000))\n"        ++-            "}\n"                                                      ++-            "\\header {\n"                                             ++-            "  title = \"" ++ title ++ "\"\n"                          ++-            "  composer = \"" ++ composer ++ "\"\n"                    ++-            "}\n"                                                      ++-            "\\layout {\n"                                             ++-            "}"                                                        ++-            "\n\n"+    lyInlinePrefix = mempty                                        +++        "%%% Generated by music-score %%%\n"                       +++        "\\include \"lilypond-book-preamble.ly\"\n"                +++        "\\paper {\n"                                              +++        "  #(define dump-extents #t)\n"                            +++        "\n"                                                       +++        "  indent = 0\\mm\n"                                       +++        "  line-width = 210\\mm - 2.0 * 0.4\\in\n"                 +++        "  ragged-right = ##t\n"                                   +++        "  force-assignment = #\"\"\n"                             +++        "  line-width = #(- line-width (* mm  3.000000))\n"        +++        "}\n"                                                      +++        "\\header {\n"                                             +++        "  title = \"" ++ title ++ "\"\n"                          +++        "  composer = \"" ++ composer ++ "\"\n"                    +++        "}\n"                                                      +++        "\\layout {\n"                                             +++        "}"                                                        +++        "\n\n" -        lyScorePrefix = mempty                                         ++-            "\\paper {"                                                ++-            "  indent = 0\\mm"                                         ++-            "  line-width = 210\\mm - 2.0 * 0.4\\in"                   ++-            "}"                                                        ++-            "\\header {\n"                                             ++-            "  title = \"" ++ title ++ "\"\n"                          ++-            "  composer = \"" ++ composer ++ "\"\n"                    ++-            "}\n"                                                      ++-            "\\layout {"                                               ++-            "}" ++-            "\n\n"+    lyScorePrefix = mempty                                         +++        "\\paper {"                                                +++        "  indent = 0\\mm"                                         +++        "  line-width = 210\\mm - 2.0 * 0.4\\in"                   +++        "}"                                                        +++        "\\header {\n"                                             +++        "  title = \"" ++ title ++ "\"\n"                          +++        "  composer = \"" ++ composer ++ "\"\n"                    +++        "}\n"                                                      +++        "\\layout {"                                               +++        "}" +++        "\n\n"   -- | -- Typeset a score using Lilypond and open it. ---openLilypond :: (HasLilypond a, HasPart' a, Semigroup a) => Score a -> IO ()+-- (This is simple wrapper around 'writeLilypond' that may not work well on all platforms.)+--+openLilypond :: HasLilypond a => a -> IO () openLilypond = openLilypond' def -openLilypond' :: (HasLilypond a, HasPart' a, Semigroup a) => LilypondOptions -> Score a -> IO ()+-- |+-- Typeset a score using Lilypond and open it.+--+-- (This is simple wrapper around 'writeLilypond' that may not work well on all platforms.)+--+openLilypond' :: HasLilypond a => LilypondOptions -> a -> IO () openLilypond' options sc = do-    writeLilypond' options "test.ly" sc-    runLilypond-    cleanLilypond-    openLilypond''+  writeLilypond' options "test.ly" sc+  runLilypond >> cleanLilypond >> runOpen+    where    +      runLilypond = void $ runCommand +        "lilypond -f pdf test.ly"  >>= waitForProcess+      cleanLilypond = void $ runCommand +        "rm -f test-*.tex test-*.texi test-*.count test-*.eps test-*.pdf test.eps"+      runOpen = void $ runCommand +        $ openCommand ++ " test.pdf" -runLilypond    = void $ runCommand "lilypond -f pdf test.ly" >>= waitForProcess-cleanLilypond  = void $ runCommand "rm -f test-*.tex test-*.texi test-*.count test-*.eps test-*.pdf test.eps"-openLilypond'' = void $ runCommand "open test.pdf" --- |--- Convert a score to a Lilypond string.----toLilypondString :: (HasLilypond a, HasPart' a, Semigroup a) => Score a -> String-toLilypondString = show . Pretty.pretty . toLilypond --- |--- Convert a score to a Lilypond representation.----toLilypond :: (HasLilypond a, HasPart' a, Semigroup a) => Score a -> Lilypond-toLilypond sc =-          -- Score structure-          pcatLilypond . fmap (-                addStaff . scatLilypond . uncurry addPartName -                -- Main notation pipeline-                . second (voiceToLilypond barTimeSigs barDurations . scoreToVoice . simultaneous) -                -- Meta-event expansion-                . uncurry addClefs-                ) -        . extractParts' $ sc -    where-        addClefT :: a -> ClefT a-        addClefT = return -        addClefs p = (,) p . setClef . fmap addClefT-        setClef = withClef def $ \c x -> applyClef c x where def = GClef -- TODO use part default -        timeSigs = getTimeSignatures (time 4 4) sc -- 4/4 is default-        timeSigsV = fmap swap $ (^. from voice) $ mergeEqual $ reactiveToVoice' (start <-> offset sc) timeSigs -        -- Despite mergeEqual above we need retainUpdates here to prevent redundant repetition of time signatures-        barTimeSigs  = retainUpdates $ getBarTimeSignatures $ timeSigsV-        barDurations =                 getBarDurations      $ timeSigsV  -        -- getTimeSignatures def       =           fmap (fromMaybe def . unOptionFirst) . runMeta (Nothing::Maybe Int) . getScoreMeta-        -- getTimeSignatureChanges def = updates . fmap (fromMaybe def . unOptionFirst) . runMeta (Nothing::Maybe Int) . getScoreMeta -        addStaff = Lilypond.New "Staff" Nothing-        addPartName partName x = Lilypond.Set "Staff.instrumentName" (Lilypond.toValue $ show partName)-            : Lilypond.Set "Staff.shortInstrumentName" (Lilypond.toValue $ show partName)-            : x -mergeBars :: [Lilypond] -> Lilypond-mergeBars [x] = x-mergeBars _   = error "mergeBars: Not supported" --- |--- Convert a voice score to a list of bars.----voiceToLilypond :: HasLilypond a => [Maybe TimeSignature] -> [Duration] -> Voice (Maybe a) -> [Lilypond]-voiceToLilypond barTimeSigs barDurations = zipWith setBarTimeSig barTimeSigs . fmap barToLilypond . voiceToBars' barDurations------ This is where notation of a single voice takes place---      * voiceToBars is generic for most notations outputs: it handles bar splitting and ties---      * barToLilypond is specific: it handles quantization and notation----    where-        -- FIXME compounds-        setBarTimeSig Nothing x = x-        setBarTimeSig (Just (getTimeSignature -> (m:_, n))) x = scatLilypond [Lilypond.Time m n, x]  -barToLilypond :: HasLilypond a => [(Duration, Maybe a)] -> Lilypond-barToLilypond bar = case (fmap rewrite . quantize) bar of-    Left e   -> error $ "barToLilypond: Could not quantize this bar: " ++ show e-    Right rh -> rhythmToLilypond rh -rhythmToLilypond = uncurry ($) . rhythmToLilypond2 --- rhythmToLilypond :: HasLilypond a => Rhythm (Maybe a) -> Lilypond--- rhythmToLilypond (Beat d x)            = noteRestToLilypond d x--- rhythmToLilypond (Dotted n (Beat d x)) = noteRestToLilypond (dotMod n * d) x--- rhythmToLilypond (Group rs)            = scatLilypond $ map rhythmToLilypond rs--- rhythmToLilypond (Tuplet m r)          = Lilypond.Times (realToFrac m) (rhythmToLilypond r)---     where (a,b) = fromIntegral *** fromIntegral $ unRatio $ realToFrac m------ noteRestToLilypond :: HasLilypond a => Duration -> Maybe a -> Lilypond--- noteRestToLilypond d Nothing  = Lilypond.rest^*(realToFrac d*4)--- noteRestToLilypond d (Just p) = Lilypond.removeSingleChords $ getLilypond d p   -rhythmToLilypond2 :: HasLilypond a => Rhythm (Maybe a) -> (Lilypond -> Lilypond, Lilypond)-rhythmToLilypond2 (Beat d x)            = noteRestToLilypond2 d x-rhythmToLilypond2 (Dotted n (Beat d x)) = noteRestToLilypond2 (dotMod n * d) x --- TODO propagate-rhythmToLilypond2 (Group rs)            = first (maybe id id) $ second scatLilypond $ extract1 $ map rhythmToLilypond2 $ rs -rhythmToLilypond2 (Tuplet m r)          = second (Lilypond.Times (realToFrac m)) $ (rhythmToLilypond2 r)-    where (a,b) = fromIntegral *** fromIntegral $ unRatio $ realToFrac m -noteRestToLilypond2 :: HasLilypond a => Duration -> Maybe a -> (Lilypond -> Lilypond, Lilypond)-noteRestToLilypond2 d Nothing  = ( id, Lilypond.rest^*(realToFrac d*4) )-noteRestToLilypond2 d (Just p) = second Lilypond.removeSingleChords $ getLilypondWithPrefix d p --- extract first value of type b-extract1 :: [(b, a)] -> (Maybe b, [a])-extract1 []         = (Nothing, [])-extract1 ((p,x):xs) = (Just p, x : fmap snd xs) -spellLilypond :: Integer -> Lilypond.Note-spellLilypond a = Lilypond.NotePitch (spellLilypond' a) Nothing -spellLilypond' :: Integer -> Lilypond.Pitch-spellLilypond' p = Lilypond.Pitch (-    toEnum $ fromIntegral pc,-    fromIntegral alt,-    fromIntegral oct-    )-    where (pc,alt,oct) = spellPitch (p + 72) +++++-- Internal stuff+-- 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++pcatLy' :: Bool -> [Lilypond.Music] -> Lilypond.Music+pcatLy' p = foldr Lilypond.simultaneous (Lilypond.Simultaneous p [])++scatLy :: [Lilypond.Music] -> Lilypond.Music+scatLy = foldr Lilypond.sequential (Lilypond.Sequential [])++spellLy :: Integer -> Lilypond.Note+spellLy a = Lilypond.NotePitch (spellLy' a) Nothing++spellLy' :: Integer -> Lilypond.Pitch+spellLy' p = Lilypond.Pitch (+  toEnum $ fromIntegral pc,+  fromIntegral alt,+  fromIntegral oct+  )+  where (pc,alt,oct) = spellPitch (p + 72)+-- End internal
src/Music/Score/Export/Midi.hs view
@@ -1,20 +1,23 @@-+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE ViewPatterns               #-} {-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DefaultSignatures          #-} {-# LANGUAGE DeriveFoldable             #-} {-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE NoMonomorphismRestriction  #-} {-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE StandaloneDeriving         #-} {-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE UndecidableInstances       #-}  ------------------------------------------------------------------------------------- -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund 2012-2014 -- -- License     : BSD-style --@@ -25,221 +28,281 @@ -------------------------------------------------------------------------------------  module Music.Score.Export.Midi (-        HasMidi(..),-        HasMidiPart,-        HasMidiProgram(..),-        toMidi,-        toMidiTrack,-        writeMidi,-        -- playMidi,-        playMidiIO,+    -- * Midi backend+    HasMidiProgram(..),+    Midi,+    HasMidi,+    toMidi,+    writeMidi,+    showMidi,+    openMidi,   ) where -import           Prelude                   hiding (concat, concatMap, foldl,-                                            foldr, mapM, maximum, minimum, sum)-+import           Music.Dynamics.Literal+import           Music.Pitch.Literal+import qualified Codec.Midi                    as Midi+import           Control.Arrow                 ((***))+import           Control.Comonad               (Comonad (..), extract) import           Control.Applicative-import           Control.Arrow-import           Control.Lens              hiding ((|>))-import           Control.Monad             hiding (mapM)-import           Control.Monad.Plus-import           Data.AffineSpace-import           Data.AffineSpace.Point-import           Data.Basis-import           Data.Either-import           Data.Foldable-import           Data.Function             (on)+import           Data.Colour.Names             as Color+import           Data.Default+import           Data.Foldable                 (Foldable)+import qualified Data.Foldable+import           Data.Functor.Couple import           Data.Maybe-import           Data.Ord                  (comparing) import           Data.Ratio-import           Data.Semigroup-import           Data.String-import           Data.Traversable-import           Data.Typeable-import           Data.VectorSpace+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 Data.Semigroup.Instances -import Codec.Midi hiding (Track)--- import           Control.Reactive          hiding (Event)--- import qualified Control.Reactive          as R--- import           Control.Reactive.Midi+import Data.Functor.Identity+import Data.Semigroup+import Control.Monad+import Data.VectorSpace hiding (Sum(..))+import Data.AffineSpace+import Control.Lens (over)+import Control.Lens.Operators hiding ((|>)) -import           Music.Dynamics.Literal-import           Music.Pitch.Literal-import           Music.Score.Articulation-import           Music.Score.Chord-import           Music.Score.Combinators-import           Music.Score.Dynamics-import           Music.Score.Export.Common-import           Music.Score.Ornaments-import           Music.Score.Part-import           Music.Score.Pitch-import           Music.Score.Rhythm-import           Music.Score.Score-import           Music.Score.Ties-import           Music.Score.Track-import           Music.Score.Voice-import           Music.Time+import Music.Time+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.Meta+import Music.Score.Meta.Tempo+import Music.Score.Export.Backend -import qualified Codec.Midi                as Midi-import qualified Data.List                 as List-import qualified Data.Map                  as Map-import qualified Music.Lilypond            as Lilypond-import qualified Music.MusicXml.Simple     as Xml-import qualified Text.Pretty               as Pretty  --- | Class of types with MIDI-compatible parts.-type HasMidiPart a = (HasPart' a, HasMidiProgram (Part a)) + -- | Class of part types with an associated MIDI program number. class HasMidiProgram a where-    getMidiChannel :: a -> Midi.Channel-    getMidiProgram :: a -> Midi.Preset-    getMidiChannel _ = 0+  getMidiChannel :: a -> Midi.Channel+  getMidiProgram :: a -> Midi.Preset+  getMidiChannel _ = 0  instance HasMidiProgram () where-    getMidiProgram _ = 0+  getMidiProgram _ = 0+ instance HasMidiProgram Double where-    getMidiProgram = fromIntegral . floor+  getMidiProgram = fromIntegral . floor+ instance HasMidiProgram Float where-    getMidiProgram = fromIntegral . floor+  getMidiProgram = fromIntegral . floor+ instance HasMidiProgram Int where-    getMidiProgram = id+  getMidiProgram = id+ instance HasMidiProgram Integer where-    getMidiProgram = fromIntegral+  getMidiProgram = fromIntegral+ instance (Integral a, HasMidiProgram a) => HasMidiProgram (Ratio a) where-    getMidiProgram = fromIntegral . floor+  getMidiProgram = fromIntegral . floor --- |--- Class of types that can be converted to MIDI.------ Numeric types are interpreted as notes with a default velocity, pairs are--- interpreted as @(pitch, velocity)@ pairs.++-- | A token to represent the Midi backend.+data Midi++-- | We do not need to pass any context to the note export.+type MidiContext = Identity++-- | Every note may give rise to a number of messages. We represent this as a score of messages.+type MidiEvent = Score Midi.Message++-- | The MIDI channel allocation is somewhat simplistic.+--   We use a dedicated channel and program number for each instrument (there *will* be colissions).+type MidiInstr = (Midi.Channel, Midi.Preset)++-- | A Midi file consist of a number of tracks.+--   Channel and preset info is passed on from exportScore to finalizeExport using this type. ----- Minimal definition: 'getMidi'. Given 'getMidiScore', 'getMidi' can be implemented--- as @getMidiScore . return@.+--   TODO also pass meta-info etc. ---class HasMidi a where+data MidiScore a = MidiScore [(MidiInstr, Score a)]+  deriving Functor -    -- | Convert a value to a MIDI score.-    --   Typically, generates an /on/ event using 'note' followed by an optional /off/ event.-    getMidi :: a -> Score Midi.Message+instance HasBackend Midi where+  type BackendScore   Midi    = MidiScore+  type BackendContext Midi    = MidiContext+  type BackendNote    Midi    = MidiEvent+  type BackendMusic   Midi    = Midi.Midi -    -- | Convert a score to a MIDI score.-    --   The default definition can be overriden for efficiency.-    getMidiScore :: Score a -> Score Midi.Message-    getMidiScore = (>>= getMidi)+  finalizeExport _ (MidiScore trs) = let+    controlTrack  = [(0, Midi.TempoChange 1000000), (endDelta, Midi.TrackEnd)]+    mainTracks    = fmap (uncurry translMidiTrack . fmap join) trs+    in+    Midi.Midi fileType (Midi.TicksPerBeat divisions) (controlTrack : mainTracks) +    where+      translMidiTrack :: MidiInstr -> Score Midi.Message -> [(Int, Midi.Message)]+      translMidiTrack (ch, p) = addTrackEnd+        . setProgramChannel ch p+        . scoreToMidiTrack -instance HasMidi (Integer, Integer) where-    getMidi (p,v) = mempty-        |> return (Midi.NoteOn 0 (fromIntegral $ p + 60) (fromIntegral v))-        |> return (Midi.NoteOff 0 (fromIntegral $ p + 60) (fromIntegral v))+      -- Each track needs TrackEnd+      -- We place it a long time after last event just in case (necessary?)+      addTrackEnd :: [(Int, Midi.Message)] -> [(Int, Midi.Message)]+      addTrackEnd = (<> [(endDelta, Midi.TrackEnd)]) -instance HasMidi Midi.Message               where   getMidi = return-instance HasMidi Int                        where   getMidi = getMidi . toInteger-instance HasMidi Float                      where   getMidi = getMidi . toInteger . round-instance HasMidi Double                     where   getMidi = getMidi . toInteger . round-instance Integral a => HasMidi (Ratio a)    where   getMidi = getMidi . toInteger . round-instance HasMidi a => HasMidi (Maybe a)     where   getMidi = getMidiScore . mfromMaybe-instance HasMidi Integer                    where   getMidi x = getMidi (x,100::Integer)+      setProgramChannel :: Midi.Channel -> Midi.Preset -> Midi.Track Midi.Ticks -> Midi.Track Midi.Ticks+      setProgramChannel ch prg = ([(0, Midi.ProgramChange ch prg)] <>) . fmap (fmap $ setC ch) -instance HasMidi a => HasMidi (PartT n a) where-    getMidi (PartT (_,a))                           = getMidi a-instance HasMidi a => HasMidi (ChordT a) where-    getMidi = pcat . fmap getMidi . getChordT-instance HasMidi a => HasMidi (TieT a) where-    getMidi (TieT (_,a))                            = getMidi a-instance HasMidi a => HasMidi (DynamicT a) where-    getMidi (DynamicT (_,a))                        = getMidi a-instance HasMidi a => HasMidi (ArticulationT a) where-    getMidi (ArticulationT (_,a))                   = getMidi a-instance HasMidi a => HasMidi (TremoloT a) where-    getMidi (TremoloT (_,a))                        = getMidi a-instance HasMidi a => HasMidi (TextT a) where-    getMidi (TextT (_,a))                           = getMidi a-instance HasMidi a => HasMidi (HarmonicT a) where-    getMidi (HarmonicT (_,a))                       = getMidi a-instance HasMidi a => HasMidi (SlideT a) where-    getMidi (SlideT (_,a))                          = getMidi a+      scoreToMidiTrack :: Score Midi.Message -> Midi.Track Midi.Ticks+      scoreToMidiTrack = fmap (\(t,_,x) -> (round ((t .-. 0) ^* divisions), x)) . toRelative . (^. events) -instance HasMidi a => HasMidi (Behavior a) where-    getMidi = getMidi . (? 0)+      -- Hardcoded values for Midi export+      -- We always generate MultiTrack (type 1) files with division 1024+      fileType    = Midi.MultiTrack+      divisions   = 1024+      endDelta    = 10000  --- |--- Convert a score to a MIDI file representation.----toMidi :: forall a . (HasMidiPart a, HasMidi a) => Score a -> Midi.Midi-toMidi score = Midi.Midi fileType divisions' (controlTrack : eventTracks)+instance (HasPart' a, HasMidiProgram (Part a)) => HasBackendScore Midi (Voice a) where+  type BackendScoreEvent Midi (Voice a) = a+  -- exportScore _ xs = MidiScore [((getMidiChannel (xs^?!parts), getMidiProgram (xs^?!parts)), fmap <$> voiceToScore xs)]+  exportScore _ xs = MidiScore [((getMidiChannel (xs^?!parts), getMidiProgram (xs^?!parts)), fmap Identity $ voiceToScore xs)]     where-        -- Each track needs TrackEnd-        -- We place it long after last event just in case (necessary?)-        endDelta        = 10000-        fileType        = Midi.MultiTrack-        divisions       = 1024-        divisions'      = Midi.TicksPerBeat divisions-        controlTrack    = [(0, Midi.TempoChange 1000000), (endDelta, Midi.TrackEnd)]-        eventTracks     = fmap ((<> [(endDelta, Midi.TrackEnd)]) . uncurry setProgramChannel . second scoreToMTrack)-                                $ extractParts' score+      voiceToScore :: Voice a -> Score a+      voiceToScore = error "FIXME" -        setProgramChannel :: Part a -> Midi.Track Midi.Ticks -> Midi.Track Midi.Ticks-        setProgramChannel p = ([(0, Midi.ProgramChange ch prg)] <>) . fmap (fmap (setChannel ch))-            where-                ch = getMidiChannel p-                prg = getMidiProgram p+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)+    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+      fixTempo = stretch (tempoToDuration (metaAtStart xs)) -        scoreToMTrack :: Score a -> Midi.Track Midi.Ticks-        scoreToMTrack = fmap (\(t,_,x) -> (round ((t.-. origin) ^* divisions), x)) . toRelative . (^. events) . getMidiScore+instance HasBackendNote Midi a => HasBackendNote Midi [a] where+  exportNote b ps = mconcat $ map (exportNote b) $ sequenceA ps -        -- TODO render voices separately+instance HasBackendNote Midi Int where+  exportNote _ (Identity pv) = mkMidiNote pv --- |--- Convert a score to a track of MIDI messages.----toMidiTrack :: HasMidi a => Score a -> Track Message-toMidiTrack = (^. track) . fmap (\(t,_,m) -> (t, m)) . (^. events) . getMidiScore+instance HasBackendNote Midi Integer where+  exportNote _ (Identity pv) = mkMidiNote (fromIntegral pv) --- |--- Convert a score MIDI and write to a file.----writeMidi :: (HasMidiPart a, HasMidi a) => FilePath -> Score a -> IO ()-writeMidi path sc = Midi.exportFile path (toMidi sc)+instance HasBackendNote Midi Float where+  exportNote b = exportNote b . fmap (toInteger . round)+  exportChord b = exportChord b . fmap (fmap (toInteger . round)) -playMidiIO :: HasMidi a => String -> Score a -> IO ()-playMidiIO = error "playMidiIO: Not implemented"+instance HasBackendNote Midi Double where+  exportNote b = exportNote b . fmap (toInteger . round)+  exportChord b = exportChord b . fmap (fmap (toInteger . round)) -{---- |--- Convert a score to a MIDI event.----playMidi :: HasMidi a => String -> Score a -> R.Event MidiMessage-playMidi dest x = midiOut midiDest $ playback trig (pure $ toTrack $ startAt 0.2 x)-    where-        -- trig        = accumR 0 ((+ 0.005) <$ pulse 0.005)-        trig        = time-        toTrack     = fmap (\(t,_,m) -> (t .-. origin, m)) . (^. events) . getMidiScore-        midiDest    = fromJust $ unsafeGetReactive (findDestination  $ pure dest)+instance HasBackendNote Midi a => HasBackendNote Midi (Behavior a) where+  exportNote b = exportNote b . fmap (! 0)+  exportChord b = exportChord b . fmap (fmap (! 0)) ++instance HasBackendNote Midi a => HasBackendNote Midi (DynamicT (Sum Double) 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)+++dynLevel :: Double -> Midi.Velocity+dynLevel x = round $ (\x -> x * 58.5 + 64) $ f $ inRange (-1,1) (x/3.5)+  where+    f = id+    -- f x = (x^3)+    inRange (m,n) x = (m `max` x) `min` n+  ++-- instance (Transformable d, HasBackendNote Midi (DynamicT d a)) => HasBackendNote Midi (DynamicT (Product d) a) where+--   exportNote b = exportNote b . fmap (over dynamic getProduct)+-- +-- instance (Transformable d, HasBackendNote Midi (DynamicT d a)) => HasBackendNote Midi (DynamicT (Sum d) a) where+--   exportNote b = exportNote b . fmap (over dynamic getSum)+++instance HasBackendNote Midi a => HasBackendNote Midi (ArticulationT b a) where+  exportNote b (Identity (ArticulationT (_, x))) = exportNote b (Identity x)++instance HasBackendNote Midi a => HasBackendNote Midi (PartT n a) where+  -- Part structure is handled by HasMidiBackendScore instances, so this is just an identity+  exportNote b = exportNote b . fmap extract++instance HasBackendNote Midi a => HasBackendNote Midi (TremoloT a) where+  exportNote b = exportNote b . fmap extract++instance HasBackendNote Midi a => HasBackendNote Midi (TextT a) where+  exportNote b = exportNote b . fmap extract++instance HasBackendNote Midi a => HasBackendNote Midi (HarmonicT a) where+  exportNote b = exportNote b . fmap extract++instance HasBackendNote Midi a => HasBackendNote Midi (SlideT a) where+  exportNote b = exportNote b . fmap extract++instance HasBackendNote Midi a => HasBackendNote Midi (TieT a) where+  exportNote b = exportNote b . fmap extract++instance HasBackendNote Midi a => HasBackendNote Midi (ColorT a) where+  exportNote b = exportNote b . fmap extract++mkMidiNote :: Int -> Score Midi.Message+mkMidiNote p = mempty+    |> pure (Midi.NoteOn 0 (fromIntegral $ p + 60) 64)+    |> pure (Midi.NoteOff 0 (fromIntegral $ p + 60) 64)++setV :: Midi.Velocity -> Midi.Message -> Midi.Message+setV v = go+  where+    go (Midi.NoteOff c k _)       = Midi.NoteOff c k v+    go (Midi.NoteOn c k _)        = Midi.NoteOn c k v+    go (Midi.KeyPressure c k _)   = Midi.KeyPressure c k v+    go (Midi.ControlChange c n v) = Midi.ControlChange c n v+    go (Midi.ProgramChange c p)   = Midi.ProgramChange c p+    go (Midi.ChannelPressure c p) = Midi.ChannelPressure c p+    go (Midi.PitchWheel c w)      = Midi.PitchWheel c w+    go (Midi.ChannelPrefix c)     = Midi.ChannelPrefix c++setC :: Midi.Channel -> Midi.Message -> Midi.Message+setC c = go+  where+    go (Midi.NoteOff _ k v)       = Midi.NoteOff c k v+    go (Midi.NoteOn _ k v)        = Midi.NoteOn c k v+    go (Midi.KeyPressure _ k v)   = Midi.KeyPressure c k v+    go (Midi.ControlChange _ n v) = Midi.ControlChange c n v+    go (Midi.ProgramChange _ p)   = Midi.ProgramChange c p+    go (Midi.ChannelPressure _ p) = Midi.ChannelPressure c p+    go (Midi.PitchWheel _ w)      = Midi.PitchWheel c w+    go (Midi.ChannelPrefix _)     = Midi.ChannelPrefix c+ -- |--- Convert a score to a MIDI event and run it.+-- Constraint for types that has a MIDI representation. ---playMidiIO :: HasMidi a => String -> Score a -> IO ()-playMidiIO dest = runLoop . playMidi dest--}+type HasMidi a = (HasBackendNote Midi (BackendScoreEvent Midi a), HasBackendScore Midi a) +toMidi :: HasMidi a => a -> Midi.Midi+toMidi = export (undefined::Midi) +writeMidi :: HasMidi a => FilePath -> a -> IO ()+writeMidi path sc = Midi.exportFile path (toMidi sc) -setChannel :: Midi.Channel -> Midi.Message -> Midi.Message-setChannel c = go-    where-        go (NoteOff _ k v)       = NoteOff c k v-        go (NoteOn _ k v)        = NoteOn c k v-        go (KeyPressure _ k v)   = KeyPressure c k v-        go (ControlChange _ n v) = ControlChange c n v-        go (ProgramChange _ p)   = ProgramChange c p-        go (ChannelPressure _ p) = ChannelPressure c p-        go (PitchWheel _ w)      = PitchWheel c w-        go (ChannelPrefix _)     = ChannelPrefix c+showMidi :: HasMidi a => a -> IO ()+showMidi = print . toMidi +openMidi :: HasMidi a => a -> IO ()+openMidi score = do+    writeMidi "test.mid" score+    void $ runCommand "timidity test.mid" >>= waitForProcess
src/Music/Score/Export/MusicXml.hs view
@@ -1,19 +1,24 @@ +{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE ViewPatterns               #-} {-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DefaultSignatures          #-} {-# LANGUAGE DeriveFoldable             #-} {-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE NoMonomorphismRestriction  #-} {-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE StandaloneDeriving         #-} {-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeOperators              #-}-{-# LANGUAGE ViewPatterns               #-}+{-# LANGUAGE UndecidableInstances       #-}  ------------------------------------------------------------------------------------- -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund 2012-2014 -- -- License     : BSD-style --@@ -24,325 +29,576 @@ -------------------------------------------------------------------------------------  module Music.Score.Export.MusicXml (-        XmlScore,-        XmlMusic,-        HasMusicXml(..),--        toMusicXml,-        toMusicXmlString,--        showMusicXml,-        openMusicXml,-        writeMusicXml,-) where--import           Prelude                      hiding (concat, concatMap, foldl,-                                               foldr, mapM, maximum, minimum,-                                               sum)+    -- * MusicXml backend+    HasMusicXmlInstrument(..),+    MusicXml,+    XmlContext(..),+    HasMusicXml,+    +    -- ** Converting to MusicXml+    toMusicXml,+    toMusicXmlString,    +    +    -- ** MusicXml I/O+    showMusicXml,+    openMusicXml,+    writeMusicXml,+  ) where +import           Music.Dynamics.Literal+import           Music.Pitch.Literal+import qualified Codec.Midi                    as Midi+import           Control.Arrow                 ((***))+import           Control.Comonad               (Comonad (..), extract) import           Control.Applicative-import           Control.Arrow-import           Control.Lens                 hiding (rewrite)-import           Control.Monad                hiding (mapM)-import           Data.Function                (on)+import           Data.Colour.Names             as Color+import           Data.Default+import           Data.Foldable                 (Foldable)+import qualified Data.Foldable+import           Data.Functor.Couple import           Data.Maybe-import           Data.Monoid.WithSemigroup-import           Data.Ord                     (comparing) import           Data.Ratio-import           Data.Semigroup-import           Data.String+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.Instances -import           Music.Dynamics.Literal-import           Music.Pitch.Literal-import           Music.Score.Articulation-import           Music.Score.Chord-import           Music.Score.Clef-import           Music.Score.Combinators-import           Music.Score.Convert-import           Music.Score.Convert-import           Music.Score.Dynamics-import           Music.Score.Export.Common-import           Music.Score.Instances-import           Music.Score.Meta-import           Music.Score.Meta.Attribution-import           Music.Score.Meta.Clef-import           Music.Score.Meta.Time-import           Music.Score.Meta.Title-import           Music.Score.Ornaments-import           Music.Score.Part-import           Music.Score.Pitch-import           Music.Score.Rhythm-import           Music.Score.Score-import           Music.Score.Ties-import           Music.Score.Track-import           Music.Score.Util-import           Music.Score.Voice-import           Music.Time-import           Music.Time.Reactive          (Reactive, initial)+import Music.Score.Export.Backend -import qualified Codec.Midi                   as Midi-import qualified Data.List                    as List-import qualified Data.Map                     as Map-import qualified Music.Lilypond               as Lilypond-import qualified Music.MusicXml.Simple        as Xml-import qualified Text.Pretty                  as Pretty+import Data.Functor.Identity+import Data.Semigroup+import Control.Monad+import Data.VectorSpace hiding (Sum(..))+import Data.AffineSpace+import Control.Lens hiding (rewrite)+-- import Control.Lens.Operators hiding ((|>)) +import Music.Time+import Music.Score.Meta+import Music.Score.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 -type XmlScore = Xml.Score-type XmlMusic = Xml.Music --- |--- Class of types that can be converted to MusicXML.+-- | +-- Extract instrument info as per "Music.Part"+-- This is really crude, needs rethinking! ---class Tiable a => HasMusicXml a where-    -- |-    -- Convert a value to MusicXML.-    ---    -- Typically, generates a 'XmlMusic' value using 'Xml.note' or 'Xml.chord', and transforms it-    -- to add beams, slurs, dynamics, articulation etc.-    ---    getMusicXml      :: Duration -> a -> XmlMusic+class HasMusicXmlInstrument a where+  getMusicXmlClef :: a -> Int -    getMusicXmlChord :: Duration -> [a] -> XmlMusic-    getMusicXmlChord d = error "getMusicXmlChord: Not implemented" -instance HasMusicXml Int                        where   getMusicXml d = getMusicXml d . toInteger-instance HasMusicXml Float                      where   getMusicXml d = getMusicXml d . toInteger . round-instance HasMusicXml Double                     where   getMusicXml d = getMusicXml d . toInteger . round-instance Integral a => HasMusicXml (Ratio a)    where   getMusicXml d = getMusicXml d . toInteger . round -instance HasMusicXml Integer where-    getMusicXml      d = (`Xml.note` realToFrac d)  . spellMusicXml . fromIntegral-    getMusicXmlChord d = (`Xml.chord` realToFrac d) . fmap (spellMusicXml . fromIntegral) -instance HasMusicXml a => HasMusicXml (ChordT a) where-    getMusicXml d = getMusicXmlChord d . getChordT+-- TODO move +deriving instance Show MusicXml.Line+deriving instance Show MusicXml.ClefSign+-- deriving instance Eq MusicXml.PartList+-- deriving instance Show MusicXml.PartList+-- deriving instance Eq MusicXml.PartListElem+-- deriving instance Show MusicXml.PartListElem+-- deriving instance Show MusicXml.GroupBarLines+-- FIXME bogus+instance Eq MusicXml.PartList where+instance Show MusicXml.PartList where -instance HasMusicXml a => HasMusicXml (PartT n a) where-    getMusicXml d (PartT (_,x))                     = getMusicXml d x -instance HasMusicXml a => HasMusicXml (TieT a) where-    getMusicXml d (TieT ((Any ta,Any tb),x)) = addTies $ getMusicXml d x-        where-            addTies | ta && tb                      = Xml.endTie . Xml.beginTie-                    | tb                            = Xml.beginTie-                    | ta                            = Xml.endTie-                    | otherwise                     = id -instance HasMusicXml a => HasMusicXml (DynamicT a) where-    getMusicXml d (DynamicT (((Any ec,Any ed),Option l,(Any bc,Any bd)), a)) = notate $ getMusicXml d a-        where-            notate x = nec <> ned <> nl <> nbc <> nbd <> x-            nec    = if ec then Xml.endCresc    else mempty-            ned    = if ed then Xml.endDim      else mempty-            nbc    = if bc then Xml.beginCresc  else mempty-            nbd    = if bd then Xml.beginDim    else mempty-            nl     = case l of-                Nothing          -> mempty-                Just (First lvl) -> Xml.dynamic (fromDynamics (DynamicsL (Just lvl, Nothing)))+-- | A token to represent the MusicXml backend.+data MusicXml -instance HasMusicXml a => HasMusicXml (ArticulationT a) where-    getMusicXml d (ArticulationT (((Any es, Any us, Any bs), (Sum al, Sum sl)), a)) = notate $ getMusicXml d a-        where-            notate = nes . nal . nsl . nbs-            nes    = if es then Xml.endSlur else id-            nal    = case al of-                0    -> id-                1    -> Xml.accent-                2    -> Xml.strongAccent-            nsl    = case sl of-                (-2) -> Xml.tenuto-                (-1) -> Xml.tenuto . Xml.staccato-                0    -> id-                1    -> Xml.staccato-                2    -> Xml.staccatissimo-            nbs    = if bs then Xml.beginSlur else id+data ScoreInfo = ScoreInfo { scoreTitle :: String,+                             scoreComposer :: String,+                             scorePartList :: MusicXml.PartList,+                             scoreTempo    :: Tempo+                             }+  deriving (Eq, Show) -instance HasMusicXml a => HasMusicXml (TremoloT a) where-    getMusicXml d (TremoloT (Sum n,x))      = notate $ getMusicXml d x-        where-            notate = case n of-                0 -> id-                _ -> Xml.tremolo n -instance HasMusicXml a => HasMusicXml (TextT a) where-    getMusicXml d (TextT (s,x))                     = notate s $ getMusicXml d x-        where-            notate ts a = mconcat (fmap Xml.text ts) <> a+data StaffInfo = StaffInfo { staffClef :: (MusicXml.ClefSign, MusicXml.Line) } +  deriving (Eq, Show) -instance HasMusicXml a => HasMusicXml (HarmonicT a) where-    getMusicXml d (HarmonicT ((view _Wrapped' -> isNat, view _Wrapped' -> n),x)) = notate isNat n $ getMusicXml d x-        where-            notate _     0 = id-            notate True  n = notateNatural n-            notate False n = notateArtificial n+data BarInfo = BarInfo { x_barTimeSignature :: Maybe TimeSignature } +  deriving (Eq, Show) -            -- notateNatural n = Xml.harmonic -- openString?-            notateNatural n = Xml.setNoteHead Xml.DiamondNoteHead-            -- Most programs do not recognize the harmonic tag-            -- We set a single diamond notehead instead, which can be manually replaced+-- | Hierachical representation of a MusicXml score.+--   A score is a parallel composition of staves.+data XmlScore a = XmlScore { getXmlScore :: (ScoreInfo, [XmlStaff a]) }+  deriving (Functor, Eq, Show) -            notateArtificial n = id -- TODO+-- | A staff is a sequential composition of bars.+data XmlStaff a = XmlStaff { getXmlStaff :: (StaffInfo, [XmlBar a]) }+  deriving (Functor, Eq, Show) +-- | A bar is a sequential composition of chords/notes/rests.+data XmlBar a = XmlBar { getXmlBar :: (BarInfo, Rhythm a) } +  deriving (Functor, Eq, Show) -            -- notate | n /= 0     = Xml.setNoteHead Xml.DiamondNoteHead-    -- TODO adjust pitch etc+-- | Context passed to the note export.+--   Includes duration and note/rest distinction.+data XmlContext a = XmlContext Duration (Maybe a)+  deriving (Functor, Foldable, Traversable, Eq, Show) -instance HasMusicXml a => HasMusicXml (SlideT a) where-    getMusicXml d (SlideT (((eg,es),(bg,bs)),a))    = notate $ getMusicXml d a-        where-            notate = neg . nes . nbg . nbs-            neg    = if view _Wrapped' eg then Xml.endGliss else id-            nes    = if view _Wrapped' es then Xml.endSlide else id-            nbg    = if view _Wrapped' bg then Xml.beginGliss else id-            nbs    = if view _Wrapped' bs then Xml.beginSlide else id+-- instance Monoid Lilypond.Music where+  -- mempty      = pcatXml []+  -- mappend x y = pcatXml [x,y] -instance HasMusicXml a => HasMusicXml (ClefT a) where-    getMusicXml d (ClefT (c, a)) = notate $ getMusicXml d a+instance HasBackend MusicXml where+  type BackendScore MusicXml   = XmlScore+  type BackendContext MusicXml = XmlContext+  type BackendNote MusicXml    = MusicXml.Music+  type BackendMusic MusicXml   = MusicXml.Score++  finalizeExport _ = finalizeScore+    where++finalizeScore :: XmlScore MusicXml.Music -> MusicXml.Score+finalizeScore (XmlScore (info, x)) +  = MusicXml.fromParts title composer partList +  . map (finalizeStaff tempo) $ x+  where+    title    = scoreTitle info+    composer = scoreComposer info+    partList = scorePartList info+    tempo    = scoreTempo info++-- TODO finalizeStaffGroup++finalizeStaff :: Tempo -> XmlStaff MusicXml.Music -> [MusicXml.Music]+finalizeStaff tempo (XmlStaff (info, x)) +  = id +  -- Staff name is not added here as MusicXML uses a separate part list+  . addStartInfo+  . addClef (staffClef info)+  . map finalizeBar $ x+  where+    -- TODO name+    -- TODO clef++    -- Both of these stick to the first bar+    -- TODO clean+    addClef :: (MusicXml.ClefSign, MusicXml.Line) -> [MusicXml.Music] -> [MusicXml.Music]+    addClef _                []     = []+    addClef (clefSign, line) (x:xs) = (MusicXml.clef clefSign line <> x):xs++    addStartInfo :: [MusicXml.Music] -> [MusicXml.Music]+    addStartInfo []     = []+    addStartInfo (x:xs) = (startInfo <> x):xs++    startInfo :: MusicXml.Music+    startInfo = mempty+        <> MusicXml.defaultDivisions+        <> MusicXml.defaultKey+        <> MusicXml.metronome (realToFrac nv) (realToFrac bpm)+        -- <> Xml.commonTime+    (nv, bpm) = getTempo tempo+++finalizeBar :: XmlBar MusicXml.Music -> MusicXml.Music+finalizeBar (XmlBar (BarInfo timeSignature, x))+  = 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]    +          +renderBarMusic :: Rhythm MusicXml.Music -> MusicXml.Music+renderBarMusic = go+  where+    go (Beat d x)            = setDefaultVoice x+    go (Dotted n (Beat d x)) = setDefaultVoice x+    go (Group rs)            = mconcat $ map renderBarMusic rs+    go (Tuplet m r)          = MusicXml.tuplet b a (renderBarMusic r)+      where+        (a,b) = fromIntegral *** fromIntegral $ unRatio $ realToFrac m++setDefaultVoice :: MusicXml.Music -> MusicXml.Music+setDefaultVoice = MusicXml.setVoice 1++-- TODO move+second f (x, y) = (x, f y)++instance (+  HasDynamicNotation a b c,+  HasOrdPart a, Transformable a, Semigroup a,+  HasOrdPart c, Tiable c, Show (Part a), HasMusicXmlInstrument (Part a)+  )+  => HasBackendScore MusicXml (Score a) where+  type BackendScoreEvent MusicXml (Score a) = SetDynamic DynamicNotation a+  exportScore b score = XmlScore +    . (ScoreInfo title composer partList tempo,)+    . map (uncurry $ exportPart timeSignatureMarks barDurations)+    . map (second (over dynamics notateDynamic)) +    . map (second (preserveMeta addDynCon))+    . map (second (preserveMeta simultaneous)) +    . extractParts'+    $ score+    where+      title    = fromMaybe "" $ flip getTitleAt 0              $ metaAtStart score+      composer = fromMaybe "" $ flip getAttribution "composer" $ metaAtStart score+      partList = MusicXml.partList (fmap show $ allParts score)+      tempo    = (metaAtStart score :: Tempo)+      (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 +        -> XmlStaff (XmlContext a)++      exportStaff :: Tiable a +        => [Maybe TimeSignature] +        -> [Duration] +        -> Int    -- ^ clef, as per Music.Parts+        -> MVoice a +        -> XmlStaff (XmlContext a)++      exportBar :: Tiable a +        => Maybe TimeSignature +        -> MVoice a +        -> XmlBar (XmlContext 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 +        . addStaffInfo+        . zipWith exportBar timeSignatures +        . splitIntoBars barDurations+        where         +          clef = case clefId of+            0 -> (MusicXml.GClef, 2)+            1 -> (MusicXml.CClef, 3)+            2 -> (MusicXml.FClef, 4)+          addStaffInfo  = (,) $ StaffInfo { staffClef = clef }+          splitIntoBars = splitTiesVoiceAt++      exportBar timeSignature+        = XmlBar +        . addBarInfo +        . quantizeBar+       where+         addBarInfo = (,) $ BarInfo timeSignature++      quantizeBar = mapWithDur XmlContext . rewrite . handleErrors . quantize . view eventsV         where-            notate = case fmap getLast $ getOption c of-                Nothing -> id-                Just GClef -> (Xml.trebleClef <>)-                Just CClef -> (Xml.altoClef <>)-                Just FClef -> (Xml.bassClef <>)+          -- FIXME propagate quantization errors+          handleErrors (Left e)  = error $ "Quantization failed: " ++ e+          handleErrors (Right x) = x -instance HasMusicXml a => HasMusicXml (Behavior a) where-    getMusicXml d = getMusicXml d . (? 0)+-------------------------------------------------------------------------------- +{-+  Note:+    We want all note transformers to be applicative morphisms, i.e.+      +      notate (pure x)   = pure (notate x) --- |--- Convert a score to MusicXML and write to a file.----writeMusicXml :: (HasMusicXml a, HasPart' a, Semigroup a) => FilePath -> Score a -> IO ()-writeMusicXml path sc = writeFile path (Xml.showXml $ toMusicXml sc)+    Specifically+      notate (mempty,x) = id . notate x --- |--- Convert a score to MusicXML and open it.----openMusicXml :: (HasMusicXml a, HasPart' a, Semigroup a) => Score a -> IO ()-openMusicXml sc = do-    writeMusicXml "test.xml" sc-    -- FIXME find out which program to use...-    void $ rawSystem "open" ["-a", "Sibelius 7", "test.xml"]+  Note:+    We use these idioms:+      exportNote b = exportNote b . fmap extract+      exportNote b = uncurry notate . fmap (exportNote b) . getTieT . sequenceA --- -- |--- -- Convert a score to MusicXML and write to a file.--- ----- writeXmlSingle :: HasMusicXml a => FilePath -> Score a -> IO ()--- writeXmlSingle path sc = writeFile path (Xml.showXml $ toXmlSingle sc)+   The latter looks a lot like cotraverse. Generalization?+   +      +-} --- -- |--- -- Convert a score to MusicXML and open it.--- ----- openXmlSingle :: HasMusicXml a => Score a -> IO ()--- openXmlSingle sc = do---     writeXmlSingle "test.xml" sc---     void $ rawSystem "open" ["-a", "/Applications/Sibelius 6.app/Contents/MacOS/Sibelius 6", "test.xml"]+instance HasBackendNote MusicXml a => HasBackendNote MusicXml [a] where+  exportNote = exportChord --- |--- Convert a score to MusicXML and print it on the standard output.----showMusicXml :: (HasMusicXml a, HasPart' a, Semigroup a) => Score a -> IO ()-showMusicXml = putStrLn . toMusicXmlString+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 --- |--- Convert a score to a MusicXML string.----toMusicXmlString :: (HasMusicXml a, HasPart' a, Semigroup a) => Score a -> String-toMusicXmlString = Xml.showXml . toMusicXml+  exportChord _ (XmlContext d Nothing)    = MusicXml.rest (realToFrac d)+  exportChord _ (XmlContext d (Just xs))  = (`MusicXml.chord` realToFrac d) . fmap (spellMusicXml . fromIntegral) $ xs+  -- getMusicXml      d = (`Xml.note` realToFrac d)  . spellMusicXml . fromIntegral+  -- getMusicXmlChord d = (`Xml.chord` realToFrac d) . fmap (spellMusicXml . fromIntegral) --- |--- Convert a score to a MusicXML representation.----toMusicXml :: (HasMusicXml a, HasPart' a, Semigroup a) => Score a -> XmlScore-toMusicXml sc =-           -- Score structure-           Xml.fromParts title composer pl -                -- Main notation pipeline-                . fmap (voiceToMusicXml' barTimeSigs barDurations . scoreToVoice . simultaneous+instance HasBackendNote MusicXml Int where+  exportNote b = exportNote b . fmap toInteger+  exportChord b = exportChord b . fmap (fmap toInteger) -                -- Meta-event expansion-                . addClefs-                )+instance HasBackendNote MusicXml Float where+  exportNote b = exportNote b . fmap (toInteger . round)+  exportChord b = exportChord b . fmap (fmap (toInteger . round)) -        . extractParts $ sc+instance HasBackendNote MusicXml Double where+  exportNote b = exportNote b . fmap (toInteger . round)+  exportChord b = exportChord b . fmap (fmap (toInteger . round)) +instance Integral a => HasBackendNote MusicXml (Ratio a) where+  exportNote b = exportNote b . fmap (toInteger . round)++instance HasBackendNote MusicXml a => HasBackendNote MusicXml (Behavior a) where+  exportNote b = exportNote b . fmap (! 0)+  exportChord b = exportChord b . fmap (fmap (! 0))++instance HasBackendNote MusicXml a => HasBackendNote MusicXml (Sum a) where+  exportNote b = exportNote b . fmap getSum++instance HasBackendNote MusicXml a => HasBackendNote MusicXml (Product a) where+  exportNote b = exportNote b . fmap getProduct++instance HasBackendNote MusicXml a => HasBackendNote MusicXml (PartT n a) where+  -- Part structure is handled by HasMidiBackendScore instances, so this is just an identity+  exportNote b = exportNote b . fmap extract+  exportChord b = exportChord b . fmap (fmap extract)++instance HasBackendNote MusicXml a => HasBackendNote MusicXml (DynamicT DynamicNotation a) where+  exportNote b = uncurry notate . fmap (exportNote b) . getDynamicT . sequenceA     where-        addClefT :: a -> ClefT a-        addClefT = return+      notate (DynamicNotation (crescDims, level)) +        = composed (fmap notateCrescDim crescDims) +        . notateLevel level -        addClefs = setClef . fmap addClefT-        setClef  = withClef def $ \c x -> applyClef c x where def = GClef -- TODO use part default+      notateCrescDim crescDims = case crescDims of+        NoCrescDim -> id+        BeginCresc -> (<>) MusicXml.beginCresc+        EndCresc   -> (<>) MusicXml.endCresc+        BeginDim   -> (<>) MusicXml.beginDim+        EndDim     -> (<>) MusicXml.endDim -        timeSigs = getTimeSignatures (time 4 4) sc -- 4/4 is default-        timeSigsV = fmap swap $ (^. from voice) $ mergeEqual $ reactiveToVoice' (start <-> offset sc) timeSigs+      -- TODO these literals are not so nice...+      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 -        -- Despite mergeEqual above we need retainUpdates here to prevent redundant repetition of time signatures-        barTimeSigs  = retainUpdates $ getBarTimeSignatures $ timeSigsV-        barDurations =                 getBarDurations      $ timeSigsV+      -- DO NOT use rcomposed as notateDynamic returns "mark" order, not application order+      -- rcomposed = composed . reverse -        title    = fromMaybe "" $ flip getTitleAt 0              $ metaAtStart sc-        composer = fromMaybe "" $ flip getAttribution "composer" $ metaAtStart sc+instance HasBackendNote MusicXml a => HasBackendNote MusicXml (ArticulationT b{-ArticulationNotation-} a) where+  exportNote b = exportNote b . fmap extract+  -- exportNote b = uncurry notate . fmap (exportNote b) . getArticulationT . sequenceA+  --   where+  --     notate (ArticulationNotation (slurs, marks))+  --       = composed (fmap notateMark marks)+  --       . composed (fmap notateSlur slurs)+  -- +  --     notateMark mark = case mark of+  --       NoMark         -> id+  --       Staccato       -> MusicXml.staccato+  --       MoltoStaccato  -> MusicXml.staccatissimo+  --       Marcato        -> MusicXml.strongAccent+  --       Accent         -> MusicXml.accent+  --       Tenuto         -> MusicXml.tenuto+  -- +  --     notateSlur slurs = case slurs of+  --       NoSlur    -> id+  --       BeginSlur -> MusicXml.beginSlur+  --       EndSlur   -> MusicXml.endSlur -        pl = Xml.partList (fmap show $ getParts sc)+instance HasBackendNote MusicXml a => HasBackendNote MusicXml (ColorT a) where+  exportNote b = exportNote b . fmap extract+{-+  exportNote b = uncurry notate . fmap (exportNote b) . getCouple . getColorT . sequenceA+    where+      -- TODO This syntax will change in future MusicXml versions+      -- TODO handle any color+      notate (Option Nothing)             = id+      notate (Option (Just (Last color))) = \x -> MusicXml.Sequential [+        MusicXml.Override "NoteHead#' color" +          (MusicXml.toLiteralValue $ "#" ++ colorName color),+        x,+        MusicXml.Revert "NoteHead#' color"+        ] -mergeBars :: [XmlMusic] -> XmlMusic-mergeBars [x] = x-mergeBars _   = error "mergeBars: Not supported"+      colorName c+        | c == Color.black = "black"+        | c == Color.red   = "red"+        | c == Color.blue  = "blue"+        | 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+    where+      notate (Max 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+      notate texts a = mconcat (fmap MusicXml.text texts) <> a +instance HasBackendNote MusicXml a => HasBackendNote MusicXml (HarmonicT a) where+  exportNote b = uncurry notateX . fmap (exportNote b) . getCouple . getHarmonicT . sequenceA+    where+      notateX (Any isNat, Sum n) = notate isNat n++      notate _     0 = id+      notate True  n = notateNatural n+      notate False n = notateArtificial n++      -- notateNatural n = Xml.harmonic -- openString?+      notateNatural n = MusicXml.setNoteHead MusicXml.DiamondNoteHead+      -- 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+      notateX ((eg,es),(bg,bs)) = notate+          where+              notate = neg . nes . nbg . nbs+              neg    = if view _Wrapped' eg then MusicXml.endGliss else id+              nes    = if view _Wrapped' es then MusicXml.endSlide else id+              nbg    = if view _Wrapped' bg then MusicXml.beginGliss else id+              nbs    = if view _Wrapped' bs then MusicXml.beginSlide else id++instance HasBackendNote MusicXml a => HasBackendNote MusicXml (TieT a) where+  exportNote b = uncurry notate . fmap (exportNote b) . getTieT . sequenceA+    where+      notate (Any ta, Any tb)+        | ta && tb  = MusicXml.beginTie . MusicXml.endTie -- TODO flip order?+        | tb        = MusicXml.beginTie+        | ta        = MusicXml.endTie+        | otherwise = id+ -- |--- Convert a voice score to a list of bars.+-- Constraint for types that has a MusicXML representation. ---voiceToMusicXml' :: HasMusicXml a => [Maybe TimeSignature] -> [Duration] -> Voice (Maybe a) -> [XmlMusic]-voiceToMusicXml' barTimeSigs barDurations = addStartInfo . zipWith setBarTimeSig barTimeSigs . fmap barToMusicXml . voiceToBars' barDurations--- TODO attach key signatures in each bar (basically zip)+type HasMusicXml a = (HasBackendNote MusicXml (BackendScoreEvent MusicXml a), HasBackendScore MusicXml a) +-- |+-- Convert a score to a MusicXML score. ----- This is where notation of a single voice takes place---      * voiceToBars is generic for most notations outputs: it handles bar splitting and ties---      * barToMusicXml is specific: it handles quantization and notation+toMusicXml :: HasMusicXml a => a -> MusicXml.Score+toMusicXml = export (undefined::MusicXml)++-- |+-- Convert a score to a MusicXML string. ---    where-        -- FIXME compounds-        setBarTimeSig Nothing x = x-        setBarTimeSig (Just (getTimeSignature -> (m:_, n))) x = Xml.time (fromInteger m) (fromInteger n) <> x+toMusicXmlString :: HasMusicXml a => a -> String+toMusicXmlString = MusicXml.showXml . toMusicXml -        addStartInfo []     = []-        addStartInfo (x:xs) = (startInfo <> x):xs-        startInfo = mempty-            <> Xml.defaultKey-            <> Xml.defaultDivisions-            <> Xml.metronome (1/4) 60-            -- <> Xml.commonTime-            -- TODO explicit time sig+-- |+-- Convert a score to MusicXML string and print it on the standard output.+--+showMusicXml :: HasMusicXml a => a -> IO ()+showMusicXml = putStrLn . toMusicXmlString +-- |+-- Convert a score to MusicXML and write to a file.+--+writeMusicXml :: HasMusicXml a => FilePath -> a -> IO ()+writeMusicXml path = writeFile path . toMusicXmlString -barToMusicXml :: HasMusicXml a => [(Duration, Maybe a)] -> XmlMusic-barToMusicXml bar = case (fmap rewrite . quantize) bar of-    Left e   -> error $ "barToMusicXml: Could not quantize this bar: " ++ show e-    Right rh -> rhythmToMusicXml rh+-- |+-- Typeset a score using MusicXML and open it.+--+-- (This is simple wrapper around 'writeMusicXml' that may not work well on all platforms.)+--+openMusicXml :: HasMusicXml a => a -> IO ()+openMusicXml sc = do+    writeMusicXml "test.xml" sc+    -- TODO find out which program to use etc...+    void $ rawSystem "open" ["-a", "Sibelius 7", "test.xml"] -rhythmToMusicXml :: HasMusicXml a => Rhythm (Maybe a) -> XmlMusic-rhythmToMusicXml (Beat d x)            = noteRestToMusicXml d x-rhythmToMusicXml (Group rs)            = mconcat $ map rhythmToMusicXml rs-rhythmToMusicXml (Dotted n (Beat d x)) = noteRestToMusicXml (dotMod n * d) x-rhythmToMusicXml (Tuplet m r)          = Xml.tuplet b a (rhythmToMusicXml r)-    where (a,b) = fromIntegral *** fromIntegral $ unRatio $ realToFrac m -noteRestToMusicXml :: HasMusicXml a => Duration -> Maybe a -> XmlMusic-noteRestToMusicXml d Nothing  = setDefaultVoice $ Xml.rest $ realToFrac d-noteRestToMusicXml d (Just p) = setDefaultVoice $ getMusicXml d p--setDefaultVoice :: XmlMusic -> XmlMusic-setDefaultVoice = Xml.setVoice 1--spellMusicXml :: Integer -> Xml.Pitch+-- Internal+spellMusicXml :: Integer -> MusicXml.Pitch spellMusicXml p = (     toEnum $ fromIntegral pc,     if alt == 0 then Nothing else Just (fromIntegral alt),     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+++-- -- main = putStrLn $ show $ view notes $ simultaneous+-- main = do+--   openLilypond music+--   openMusicXml music+-- music =+--   --  over pitches' (+ 2) $+--   --  text "Hello" $+--   compress 1 $ sj </> sj^*2 </> sj^*4+--   where+--     sj = timesPadding 2 1 $ harmonic 1 (scat [+--       color Color.blue $ level _f $ c <> d,+--       cs,+--       level _f ds,+--       level ff fs,+--       level _f a_,+--       text "pizz" $ level pp gs_,+--       tremolo 2 d,+--       tremolo 3 e+--       ::Score MyNote])^*(1+3/5)   +-- +-- timesPadding n d x = mcatMaybes $ times n (fmap Just x |> rest^*d)+-- +-- type MyNote = +--   (PartT Int +--     (TieT +--       (ColorT +--         (TextT +--           (TremoloT +--             (HarmonicT +--               (SlideT +--                 (ArticulationT () +--                   (DynamicT +--                     (Sum (Double)) +--                       [Behavior Double])))))))))+-- +-- +-- open :: Score MyNote -> IO ()+-- open = do+--   -- showLilypond+--   openLilypond+--
+ src/Music/Score/Export/NoteList.hs view
@@ -0,0 +1,162 @@++{-# 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       #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-- A simple backend that supports rendering scores to lists of pitch and velocity.+--+-- This exists as a sanity check for the 'Backend' classes, and as an example.+--+module Music.Score.Export.NoteList (+    -- * Note list backend+    NoteList,+    toNoteList,+  ) where++import           Music.Dynamics.Literal+import           Music.Pitch.Literal+import qualified Codec.Midi                    as Midi+import           Control.Arrow                 ((***))+import           Control.Comonad               (Comonad (..), extract)+import           Control.Applicative+import           Data.Colour.Names             as Color+import           Data.Default+import           Data.Foldable                 (Foldable)+import qualified Data.Foldable+import           Data.Functor.Couple+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           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++import Music.Score.Export.Backend+import Music.Time+import Music.Score.Dynamics+import Music.Score.Part++import Music.Score.Export.Backend++import Data.Functor.Identity+import Data.Semigroup+import Control.Monad+import Data.VectorSpace hiding (Sum(..))+import Data.AffineSpace+import Control.Lens hiding (rewrite)+-- import Control.Lens.Operators hiding ((|>))++import Music.Time+import Music.Score.Meta+import Music.Score.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.Phrases+++-- |+-- A token to represent the note list backend.+--+data NoteList++instance HasBackend NoteList where+  type BackendScore NoteList     = []+  type BackendContext NoteList   = Identity+  type BackendNote NoteList      = [(Sum Int, Int)]+  type BackendMusic NoteList     = [(Sum Int, Int)]+  finalizeExport _ = concat++instance HasBackendScore NoteList [a] where+  type BackendScoreEvent NoteList [a] = a+  exportScore _ = fmap Identity++instance HasBackendScore NoteList (Score a) where+  type BackendScoreEvent NoteList (Score a) = a+  exportScore _ = fmap Identity . toListOf traverse++instance HasBackendNote NoteList a => HasBackendNote NoteList [a] where+  exportNote b ps = mconcat $ map (exportNote b) $ sequenceA ps++instance HasBackendNote NoteList Int where+  exportNote _ (Identity p) = [(mempty, p)]++instance HasBackendNote NoteList Double where+  exportNote _ (Identity p) = [(mempty, round p)]++-- TODO prettier+instance HasBackendNote NoteList a => HasBackendNote NoteList (DynamicT b a) where+  exportNote b = exportNote b . fmap extract ++instance HasBackendNote NoteList a => HasBackendNote NoteList (ArticulationT b a) where+  exportNote b = exportNote b . fmap extract ++instance HasBackendNote NoteList a => HasBackendNote NoteList (PartT n a) where+  exportNote b = exportNote b . fmap extract++instance HasBackendNote NoteList a => HasBackendNote NoteList (TremoloT a) where+  exportNote b = exportNote b . fmap extract++instance HasBackendNote NoteList a => HasBackendNote NoteList (TextT a) where+  exportNote b = exportNote b . fmap extract++instance HasBackendNote NoteList a => HasBackendNote NoteList (HarmonicT a) where+  exportNote b = exportNote b . fmap extract++instance HasBackendNote NoteList a => HasBackendNote NoteList (SlideT a) where+  exportNote b = exportNote b . fmap extract++instance HasBackendNote NoteList a => HasBackendNote NoteList (TieT a) where+  exportNote b = exportNote b . fmap extract++instance HasBackendNote NoteList a => HasBackendNote NoteList (ColorT a) where+  exportNote b = exportNote b . fmap extract ++-- |+-- Export music as a note list.+--  +toNoteList :: (HasBackendNote NoteList (BackendScoreEvent NoteList s), HasBackendScore NoteList s) => s -> [(Int, Int)]+toNoteList = over (mapped._1) getSum . export (undefined::NoteList)++
+ src/Music/Score/Export/SuperCollider.hs view
@@ -0,0 +1,234 @@++{-# 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       #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-- A backend to generate SuperCollider code.+--+-- This is a very simple thing that generates /patterns/ (which are basically lazy event +-- lists) in the SuperCollider language.+--+-- It would of course also be nice to have a backend based the Haskell bindings (see+-- <http://hackage.haskell.org/package/hsc3>). In that case we could bypass the+-- SuperCollider language and just use /scsynth/.+--+module Music.Score.Export.SuperCollider (+    -- * SuperCollider patterns backend+    SuperCollider,+    HasSuperCollider,+    toSuperCollider,+    writeSuperCollider,+    openSuperCollider,+  ) where++import           Music.Dynamics.Literal+import           Music.Pitch.Literal+import qualified Codec.Midi                    as Midi+import           Control.Arrow                 ((***))+import           Control.Comonad               (Comonad (..), extract)+import           Control.Applicative+import           Data.Colour.Names             as Color+import           Data.Default+import           Data.Foldable                 (Foldable)+import qualified Data.Foldable+import           Data.Functor.Couple+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           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++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 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.Phrases+++-- | A token to represent the SuperCollider backend.+data SuperCollider++-- | Pass duration to the note export.+type ScContext = Identity--ScContext Duration a deriving (Functor, Foldable, Traversable)++-- | Just \dur, \midinote, \db for now+type ScEvent = (Double, Double)++-- | Score is just a list of parallel voices.+data ScScore a = ScScore [[(Duration, Maybe a)]]+  deriving (Functor)++instance Monoid (ScScore a) where+  mempty = ScScore mempty+  ScScore a `mappend` ScScore b = ScScore (a `mappend` b)++instance HasBackend SuperCollider where+  type BackendContext SuperCollider    = ScContext+  type BackendScore   SuperCollider    = ScScore+  type BackendNote    SuperCollider    = ScEvent+  type BackendMusic   SuperCollider    = String++  finalizeExport _ (ScScore trs) = composeTracksInParallel $ map exportTrack trs+    where        +      composeTracksInParallel :: [String] -> String+      composeTracksInParallel = (\x -> "Ppar([" ++ x ++ "])") . Data.List.intercalate ", "+      +      exportTrack :: [(Duration, Maybe ScEvent)] -> String+      exportTrack events = "Pbind("+        ++ "\\dur, Pseq(" ++ show durs ++ ")"+        ++ ", "+        ++ "\\midinote, Pseq(" ++ showRestList pitches ++ ")"+        ++ ")"+        where+          showRestList = (\x -> "[" ++ x ++ "]") +            . Data.List.intercalate ", " +            . map (maybe "\\rest" show) +  +          -- events :: ScEvent+          durs    :: [Double]+          pitches :: [Maybe Double]+          ampls   :: [Maybe Double]+          durs    = map (realToFrac . fst) events+          pitches = map (fmap fst . snd) events+          ampls   = map (fmap snd . snd) events+          ++instance () => HasBackendScore SuperCollider (Voice (Maybe a)) where+  type BackendScoreEvent SuperCollider (Voice (Maybe a)) = a+  exportScore _ xs = Identity <$> ScScore [view eventsV xs]++instance (HasPart' a, Ord (Part a)) => HasBackendScore SuperCollider (Score a) where+  type BackendScoreEvent SuperCollider (Score a) = a+  exportScore b = mconcat+    . map (exportScore b . view singleMVoice)+    . extractParts+  +instance HasBackendNote SuperCollider a => HasBackendNote SuperCollider [a] where+  exportNote b ps = head $ map (exportNote b) $ sequenceA ps++instance HasBackendNote SuperCollider Double where+  exportNote _ (Identity x) = (x + 60, 1)++instance HasBackendNote SuperCollider Int where+  exportNote _ (Identity x) = (fromIntegral x + 60, 1)++instance HasBackendNote SuperCollider Integer where+  exportNote _ (Identity x) = (fromIntegral x + 60, 1)++instance HasBackendNote SuperCollider a => HasBackendNote SuperCollider (Behavior a) where+  exportNote b = exportNote b . fmap (! 0)+  exportChord b = exportChord b . fmap (fmap (! 0))++instance HasBackendNote SuperCollider a => HasBackendNote SuperCollider (DynamicT b a) where+  exportNote b = exportNote b . fmap extract+  -- exportNote b (Identity (DynamicT (Sum v, x))) = fmap (setV v) $ exportNote b (Identity x)++instance HasBackendNote SuperCollider a => HasBackendNote SuperCollider (ArticulationT b a) where+  exportNote b = exportNote b . fmap extract++instance HasBackendNote SuperCollider a => HasBackendNote SuperCollider (PartT n a) where+  -- Part structure is handled by HasSuperColliderBackendScore instances, so this is just an identity+  exportNote b = exportNote b . fmap extract++instance HasBackendNote SuperCollider a => HasBackendNote SuperCollider (TremoloT a) where+  exportNote b = exportNote b . fmap extract++instance HasBackendNote SuperCollider a => HasBackendNote SuperCollider (TextT a) where+  exportNote b = exportNote b . fmap extract++instance HasBackendNote SuperCollider a => HasBackendNote SuperCollider (HarmonicT a) where+  exportNote b = exportNote b . fmap extract++instance HasBackendNote SuperCollider a => HasBackendNote SuperCollider (SlideT a) where+  exportNote b = exportNote b . fmap extract++instance HasBackendNote SuperCollider a => HasBackendNote SuperCollider (TieT a) where+  exportNote b = exportNote b . fmap extract++instance HasBackendNote SuperCollider a => HasBackendNote SuperCollider (ColorT a) where+  exportNote b = exportNote b . fmap extract+++-- |+-- Constraint for types that has a SuperCollider representation.+--+type HasSuperCollider a = (HasBackendNote SuperCollider (BackendScoreEvent SuperCollider a), HasBackendScore SuperCollider a)++-- |+-- Convert music to a SuperCollider code string.+--+toSuperCollider :: HasSuperCollider a => a -> String+toSuperCollider = export (undefined::SuperCollider)++-- |+-- Write music as a SuperCollider code string to the given path.+--+-- @+-- writeSuperCollider \"test.sc\" $ scat [c,d,e]+-- @+--+writeSuperCollider :: HasSuperCollider a => FilePath -> a -> IO ()+writeSuperCollider path score =+  writeFile path ("(" ++ toSuperCollider score ++ ").play")++-- |+-- Write music as a SuperCollider code string and open it.+--+-- (This is simple wrapper around 'writeSuperCollider' that may not work well on all platforms.)+--+openSuperCollider :: HasSuperCollider a => a -> IO ()+openSuperCollider = writeSuperCollider "test.sc"+
+ src/Music/Score/Harmonics.hs view
@@ -0,0 +1,124 @@++{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeOperators              #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-- Provides a representation of harmonics. +--+-- /Warning/ This module is experimental.+--+-------------------------------------------------------------------------------------++module Music.Score.Harmonics (+        -- * Harmonics+        HasHarmonic(..),+        HarmonicT(..),+        harmonic,+        artificial,+  ) where++import           Control.Applicative+import           Control.Comonad+import           Control.Lens            hiding (transform)+import           Data.Foldable+import           Data.Foldable+import           Data.Functor.Couple+import           Data.Ratio+import           Data.Semigroup+import           Data.Typeable+import           Data.Word++import           Music.Dynamics.Literal+import           Music.Pitch.Alterable+import           Music.Pitch.Augmentable+import           Music.Pitch.Literal+import           Music.Score.Part+import           Music.Score.Phrases+import           Music.Time+++-- 0 for none, positive for natural, negative for artificial+class HasHarmonic a where+  setNatural :: Bool -> a -> a+  setHarmonic :: Int -> a -> a++-- (isNatural, overtone series index where 0 is fundamental)+newtype HarmonicT a = HarmonicT { getHarmonicT :: Couple (Any, Sum Int) a }+  deriving (+    Eq, Show, Ord, Functor, Foldable, Typeable, +    Applicative, Monad, Comonad+    )++instance HasHarmonic a => HasHarmonic (b, a) where+  setNatural b = fmap (setNatural b)+  setHarmonic n = fmap (setHarmonic n)++instance HasHarmonic a => HasHarmonic (Couple b a) where+  setNatural b = fmap (setNatural b)+  setHarmonic n = fmap (setHarmonic n)++instance HasHarmonic a => HasHarmonic [a] where+  setNatural b = fmap (setNatural b)+  setHarmonic n = fmap (setHarmonic n)++instance HasHarmonic a => HasHarmonic (Score a) where+  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++instance Rewrapped (HarmonicT a) (HarmonicT b)++instance HasHarmonic (HarmonicT a) where+  setNatural  b = over (_Wrapped'._Wrapped') $ \((_,n),x)   -> ((Any b,n),x)+  setHarmonic n = over (_Wrapped'._Wrapped') $ \((nat,_),x) -> ((nat,Sum n),x)++-- Lifted instances+deriving instance Num a => Num (HarmonicT a)+deriving instance Fractional a => Fractional (HarmonicT a)+deriving instance Floating a => Floating (HarmonicT a)+deriving instance Enum a => Enum (HarmonicT a)+deriving instance Bounded a => Bounded (HarmonicT a)+deriving instance (Num a, Ord a, Real a) => Real (HarmonicT a)+deriving instance (Real a, Enum a, Integral a) => Integral (HarmonicT a)++-- |+-- Make all notes natural harmonics on the given overtone (1 for octave, 2 for fifth etc).+-- Sounding pitch is unaffected, but notated output is transposed automatically.+--+harmonic :: HasHarmonic a => Int -> a -> a+harmonic n = setNatural True . setHarmonic n+-- TODO verify this can actually be played++-- |+-- Make all notes natural harmonics on the given overtone (1 for octave, 2 for fifth etc).+-- Sounding pitch is unaffected, but notated output is transposed automatically.+--+artificial :: HasHarmonic a => a -> a+artificial =  setNatural False . setHarmonic 3+++
src/Music/Score/Import/Abc.hs view
@@ -1,3 +1,18 @@ +-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-- Provides ABC notation import.+--+-- /Warning/ Experimental module.+--+------------------------------------------------------------------------------------- module Music.Score.Import.Abc where
src/Music/Score/Import/Lilypond.hs view
@@ -1,2 +1,17 @@ +-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-- Provides Lilypond import.+--+-- /Warning/ Experimental module.+--+------------------------------------------------------------------------------------- module Music.Score.Import.Lilypond where
src/Music/Score/Import/Midi.hs view
@@ -5,6 +5,21 @@ {-# LANGUAGE NoMonomorphismRestriction  #-} {-# LANGUAGE OverloadedStrings          #-} +-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-- Provides MIDI import.+--+-- /Warning/ Experimental module.+--+------------------------------------------------------------------------------------- module Music.Score.Import.Midi (         IsMidi(..),         fromMidi,@@ -14,11 +29,10 @@   ) where  import           Music.Pitch.Literal       (IsPitch)-import           Music.Score.Score +import           Codec.Midi                hiding (Track) import           Control.Applicative import           Control.Lens-import Codec.Midi hiding (Track) -- import           Control.Reactive          hiding (Event) -- import qualified Control.Reactive          as R -- import           Control.Reactive.Midi@@ -26,18 +40,15 @@ import           Music.Dynamics.Literal import           Music.Pitch.Literal import           Music.Score.Articulation-import           Music.Score.Chord-import           Music.Score.Combinators import           Music.Score.Dynamics-import           Music.Score.Export.Common-import           Music.Score.Ornaments+import           Music.Score.Internal.Export+import           Music.Score.Harmonics import           Music.Score.Part import           Music.Score.Pitch-import           Music.Score.Rhythm-import           Music.Score.Score+import           Music.Score.Slide+import           Music.Score.Text import           Music.Score.Ties-import           Music.Score.Track-import           Music.Score.Voice+import           Music.Score.Tremolo import           Music.Time  import qualified Codec.Midi                as Midi@@ -57,11 +68,12 @@     -- TODO     IsPitch a,     HasPart' a,+    Ord (Part a),     Enum (Part a),     -- HasPitch a,     Num (Pitch a),     HasTremolo a,-    HasArticulation a,+    HasArticulation a a,     Tiable a     )
src/Music/Score/Instances.hs view
@@ -13,7 +13,7 @@  ------------------------------------------------------------------------------------- -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund 2012-2014 -- -- License     : BSD-style --@@ -30,131 +30,48 @@  import           Control.Applicative import           Control.Comonad+import           Control.Lens             hiding (part, transform) import           Control.Monad import           Data.AffineSpace import           Data.Default import           Data.Foldable+import           Data.Functor.Adjunction  (unzipR)+import           Data.Functor.Couple import qualified Data.List                as List import           Data.Maybe import           Data.Ratio import           Data.Semigroup import           Data.Typeable-import           Data.VectorSpace+import           Data.VectorSpace hiding (Sum)+import           Data.Semigroup.Instances  import           Music.Dynamics.Literal-import           Music.Pitch.Literal-import           Music.Pitch.Augmentable import           Music.Pitch.Alterable+import           Music.Pitch.Augmentable+import           Music.Pitch.Literal import           Music.Score.Articulation-import           Music.Score.Chord-import           Music.Score.Combinators+import           Music.Score.Color import           Music.Score.Dynamics-import           Music.Score.Ornaments+import           Music.Score.Harmonics+import           Music.Score.Meta import           Music.Score.Part import           Music.Score.Pitch-import           Music.Score.Rhythm-import           Music.Score.Score+import           Music.Score.Slide+import           Music.Score.Text import           Music.Score.Ties-import           Music.Score.Track-import           Music.Score.Util-import           Music.Score.Voice+import           Music.Score.Tremolo import           Music.Time ----------------------------------------------------------------------------------------{--    Rewrite pairs:--    CANNOT DO-        ChordT-    TODO-        PartT--    DONE-        DynamicT-        TieT-        ArticulationT-        TremoloT-        HarmonicT-        TextT-        SlideT----}---instance (IsPitch a, Enum n) => IsPitch (PartT n a) where-    fromPitch l                                     = PartT (toEnum 0, fromPitch l)-instance (IsDynamics a, Enum n) => IsDynamics (PartT n a) where-    fromDynamics l                                  = PartT (toEnum 0, fromDynamics l)--instance IsPitch a => IsPitch (ChordT a) where-    fromPitch = return . fromPitch-instance IsDynamics a => IsDynamics (ChordT a) where-    fromDynamics = return . fromDynamics--instance IsPitch a => IsPitch (TieT a) where-    fromPitch = pure . fromPitch-instance IsDynamics a => IsDynamics (TieT a) where-    fromDynamics = return . fromDynamics--instance IsPitch a => IsPitch (DynamicT a) where-    fromPitch = pure . fromPitch-instance IsDynamics a => IsDynamics (DynamicT a) where-    fromDynamics = return . fromDynamics--instance IsPitch a => IsPitch (TremoloT a) where-    fromPitch = pure . fromPitch-instance IsDynamics a => IsDynamics (TremoloT a) where-    fromDynamics = pure . fromDynamics--instance IsPitch a => IsPitch (TextT a) where-    fromPitch = pure . fromPitch-instance IsDynamics a => IsDynamics (TextT a) where-    fromDynamics = pure . fromDynamics--instance IsPitch a => IsPitch (HarmonicT a) where-    fromPitch = pure . fromPitch-instance IsDynamics a => IsDynamics (HarmonicT a) where-    fromDynamics = pure . fromDynamics--instance IsPitch a => IsPitch (SlideT a) where-    fromPitch = pure . fromPitch-instance IsDynamics a => IsDynamics (SlideT a) where-    fromDynamics = pure . fromDynamics-----------------------------------------------------------------------------------------instance Reversible (ChordT a) where-    rev = id-instance Reversible a => Reversible (DynamicT a) where-    rev = fmap rev-instance Reversible a => Reversible (SlideT a) where-    rev = fmap rev-instance Reversible a => Reversible (TieT a) where-    rev = fmap rev-instance Reversible a => Reversible (HarmonicT a) where-    rev = fmap rev-instance Reversible a => Reversible (ArticulationT a) where-    rev = fmap rev-instance Reversible a => Reversible (TextT a) where-    rev = fmap rev-instance Reversible a => Reversible (TremoloT a) where-    rev = fmap rev-instance Reversible a => Reversible (PartT p a) where-    rev = fmap rev------------------------------------------------------------------------------------------instance Semigroup a => Semigroup (DynamicT a) where-    DynamicT (d1, x1) <> DynamicT (d2, x2) = DynamicT (d1 <> d2, x1 <> x2)+-- -------------------------------------------------------------------------------------+--+-- instance Semigroup a => Semigroup (DynamicT a) where+--     DynamicT (d1, x1) <> DynamicT (d2, x2) = DynamicT (d1 <> d2, x1 <> x2) instance Semigroup a => Semigroup (SlideT a) where     (<>) = liftA2 (<>) instance Semigroup a => Semigroup (TieT a) where     TieT (t1, x1) <> TieT (t2, x2) = TieT (t1 <> t2, x1 <> x2)     -- This instance is suspect: in general chord notes are not required to share ties,-    -- so this instance may be removed (provided that TieT is moved inside ChordT for+    -- so this instance may be removed (provided that TieT is moved inside Chord for     -- all Preludes). See #134 instance Semigroup a => Semigroup (HarmonicT a) where     (<>) = liftA2 (<>)@@ -166,196 +83,105 @@     PartT (v1,x1) <> PartT (v2,x2) = PartT (v1, x1 <> x2)  --------------------------------------------------------------------------------------+-- ------------------------------------------------------------------------------------- --- Maybe+--+-- Aspect instaces (Pitch, Dynamics and Articulation) for PartT needs to go here,+-- as the other aspects depends on partwise traversals etc+-- --- TODO this instance may be problematic with mapPhrase-instance HasArticulation a => HasArticulation (Maybe a) where-    setEndSlur    n = fmap (setEndSlur n)-    setContSlur   n = fmap (setContSlur n)-    setBeginSlur  n = fmap (setBeginSlur n)-    setAccLevel   n = fmap (setAccLevel n)-    setStaccLevel n = fmap (setStaccLevel n)-type instance Part (Maybe a)                             = Part a-instance HasPart a => HasPart (Maybe a) where-    getPart Nothing                                 = error "Nothing: no part"-    getPart (Just a)                                = getPart a-    modifyPart f = fmap (modifyPart f)-type instance Pitch (Maybe a) = Pitch a-instance HasSetPitch a b => HasSetPitch (Maybe a) (Maybe b) where-    type SetPitch g (Maybe a) = Maybe (SetPitch g a)-    __mapPitch f (Nothing)                          = Nothing-    __mapPitch f (Just a)                           = Just (__mapPitch f a)+type instance Pitch (PartT p a) = Pitch a+type instance SetPitch b (PartT p a) = PartT p (SetPitch b a) +instance HasPitch a b => HasPitch (PartT p a) (PartT p b) where+  pitch = _Wrapped . _2 . pitch+instance HasPitches a b => HasPitches (PartT p a) (PartT p b) where+  pitches = _Wrapped . _2 . pitches --- PartT+type instance Pitch (DynamicT p a) = Pitch a+type instance SetPitch b (DynamicT p a) = DynamicT p (SetPitch b a) -instance HasChord a => HasChord (PartT n a) where-    type ChordNote (PartT n a)                           = PartT n (ChordNote a)-    getChord (PartT (v,x))                          = fmap (\x -> PartT (v,x)) (getChord x)+instance HasPitch a b => HasPitch (DynamicT p a) (DynamicT p b) where+  pitch = _Wrapped . _2 . pitch+instance HasPitches a b => HasPitches (DynamicT p a) (DynamicT p b) where+  pitches = _Wrapped . _2 . pitches -type instance Pitch (PartT n a) = Pitch a-instance HasGetPitch a => HasGetPitch (PartT n a) where-    __getPitch = __getPitch . extract-instance HasSetPitch a b => HasSetPitch (PartT n a) (PartT n b) where-    type SetPitch g (PartT n a) = PartT n (SetPitch g a)-    __mapPitch f = fmap (__mapPitch f)+type instance Pitch (ArticulationT p a) = Pitch a+type instance SetPitch b (ArticulationT p a) = ArticulationT p (SetPitch b a) -instance Tiable a => Tiable (PartT n a) where-    toTied (PartT (v,a)) = (PartT (v,b), PartT (v,c)) where (b,c) = toTied a-deriving instance HasDynamic a => HasDynamic (PartT n a)-deriving instance HasArticulation a => HasArticulation (PartT n a)-deriving instance HasTremolo a => HasTremolo (PartT n a)-deriving instance HasHarmonic a => HasHarmonic (PartT n a)-deriving instance HasSlide a => HasSlide (PartT n a)-deriving instance HasText a => HasText (PartT n a)+instance HasPitch a b => HasPitch (ArticulationT p a) (ArticulationT p b) where+  pitch = _Wrapped . _2 . pitch+instance HasPitches a b => HasPitches (ArticulationT p a) (ArticulationT p b) where+  pitches = _Wrapped . _2 . pitches  --- ChordT -instance Tiable a => Tiable (ChordT a) where-    toTied (ChordT as)                              = (ChordT bs, ChordT cs) where (bs,cs) = (unzip . fmap toTied) as--- There is no (HasPart ChordT) instance, so PartT must be outside ChordT in the stack--- This restriction assures all chord notes are in the same part+type instance Dynamic (PartT p a) = Dynamic a+type instance SetDynamic b (PartT p a) = PartT p (SetDynamic b a) -type instance Pitch (ChordT a) = Pitch a+instance HasDynamic a b => HasDynamic (PartT p a) (PartT p b) where+  dynamic = _Wrapped . _2 . dynamic+instance HasDynamics a b => HasDynamics (PartT p a) (PartT p b) where+  dynamics = _Wrapped . _2 . dynamics -instance HasSetPitch a b => HasSetPitch (ChordT a) (ChordT b) where-    type SetPitch g (ChordT a) = ChordT (SetPitch g a)-    __mapPitch f = fmap (__mapPitch f)+type instance Dynamic (ArticulationT p a) = Dynamic a+type instance SetDynamic b (ArticulationT p a) = ArticulationT p (SetDynamic b a) -instance HasDynamic a => HasDynamic (ChordT a) where-    setEndDim     n = fmap (setEndDim n)-    setLevel      n = fmap (setLevel n)-instance HasArticulation a => HasArticulation (ChordT a) where-    setEndSlur    n = fmap (setEndSlur n)-    setContSlur   n = fmap (setContSlur n)-    setBeginSlur  n = fmap (setBeginSlur n)-    setAccLevel   n = fmap (setAccLevel n)-    setStaccLevel n = fmap (setStaccLevel n)-instance HasTremolo a => HasTremolo (ChordT a) where-    setTrem       n = fmap (setTrem n)-instance HasHarmonic a => HasHarmonic (ChordT a) where-    setNatural    n = fmap (setNatural n)-    setHarmonic   n = fmap (setHarmonic n)-instance HasSlide a => HasSlide (ChordT a) where-    setBeginGliss n = fmap (setBeginGliss n)-    setBeginSlide n = fmap (setBeginSlide n)-    setEndGliss   n = fmap (setEndGliss n)-    setEndSlide   n = fmap (setEndSlide n)-instance HasText a => HasText (ChordT a) where-    addText       s (ChordT as) = ChordT (mapF (addText s) as)+instance HasDynamic a b => HasDynamic (ArticulationT p a) (ArticulationT p b) where+  dynamic = _Wrapped . _2 . dynamic+instance HasDynamics a b => HasDynamics (ArticulationT p a) (ArticulationT p b) where+  dynamics = _Wrapped . _2 . dynamics  --- TieT -type instance Part (TieT a) = Part a-instance HasPart a => HasPart (TieT a) where-    getPart (TieT (_,x)) = getPart x-    modifyPart f = fmap (modifyPart f)-instance HasChord a => HasChord (TieT a) where-    type ChordNote (TieT a) = TieT (ChordNote a)-    getChord (TieT (t,x))   = fmap (\x -> TieT (t,x)) (getChord x)--type instance Pitch (TieT a) = Pitch a-instance HasGetPitch a => HasGetPitch (TieT a) where-    __getPitch = __getPitch . get1-instance HasSetPitch a b => HasSetPitch (TieT a) (TieT b) where-    type SetPitch g (TieT a) = TieT (SetPitch g a)-    __mapPitch f = fmap (__mapPitch f)---deriving instance HasDynamic a => HasDynamic (TieT a)-deriving instance HasArticulation a => HasArticulation (TieT a)-deriving instance HasTremolo a => HasTremolo (TieT a)-deriving instance HasHarmonic a => HasHarmonic (TieT a)-deriving instance HasSlide a => HasSlide (TieT a)-deriving instance HasText a => HasText (TieT a)----- DynamicT---- end cresc/dim, level, begin cresc/dim--- newtype DynamicT a = DynamicT { getDynamicT :: (Bool, Bool, Maybe Double, a, Bool, Bool) }--instance Tiable a => Tiable (DynamicT a) where-    toTied (DynamicT (l, a)) = (DynamicT (l, b), DynamicT (mempty, c)) where (b,c) = toTied a+type instance Articulation (PartT p a) = Articulation a+type instance SetArticulation b (PartT p a) = PartT p (SetArticulation b a) -type instance Part (DynamicT a) = Part a-instance HasPart a => HasPart (DynamicT a) where-    getPart (DynamicT (_,x)) = getPart x-    modifyPart f = fmap (modifyPart f)-instance HasChord a => HasChord (DynamicT a) where-    type ChordNote (DynamicT a) = DynamicT (ChordNote a)-    getChord (DynamicT (d,as)) = fmap (\x -> DynamicT (d,x)) (getChord as)+instance HasArticulation a b => HasArticulation (PartT p a) (PartT p b) where+  articulation = _Wrapped . _2 . articulation+instance HasArticulations a b => HasArticulations (PartT p a) (PartT p b) where+  articulations = _Wrapped . _2 . articulations -type instance Pitch (DynamicT a) = Pitch a-instance HasGetPitch a => HasGetPitch (DynamicT a) where-    __getPitch (DynamicT (_,x)) = __getPitch x-instance HasSetPitch a b => HasSetPitch (DynamicT a) (DynamicT b) where-    type SetPitch g (DynamicT a) = DynamicT (SetPitch g a)-    __mapPitch f = fmap (__mapPitch f)+-- TODO move up?+type instance Pitch (ColorT a)        = Pitch a+type instance SetPitch g (ColorT a)   = ColorT (SetPitch g a)+instance (HasPitches a b) => HasPitches (ColorT a) (ColorT b) where+  pitches = _Wrapped . pitches+instance (HasPitch a b) => HasPitch (ColorT a) (ColorT b) where+  pitch = _Wrapped . pitch +type instance Dynamic (ColorT a)        = Dynamic a+type instance SetDynamic g (ColorT a)   = ColorT (SetDynamic g a)+instance (HasDynamics a b) => HasDynamics (ColorT a) (ColorT b) where+  dynamics = _Wrapped . dynamics+instance (HasDynamic a b) => HasDynamic (ColorT a) (ColorT b) where+  dynamic = _Wrapped . dynamic -deriving instance HasArticulation a => HasArticulation (DynamicT a)-deriving instance HasTremolo a => HasTremolo (DynamicT a)-deriving instance HasHarmonic a => HasHarmonic (DynamicT a)-deriving instance HasSlide a => HasSlide (DynamicT a)-deriving instance HasText a => HasText (DynamicT a)+type instance Articulation (ColorT a)        = Articulation a+type instance SetArticulation g (ColorT a)   = ColorT (SetArticulation g a)+instance (HasArticulations a b) => HasArticulations (ColorT a) (ColorT b) where+  articulations = _Wrapped . articulations+instance (HasArticulation a b) => HasArticulation (ColorT a) (ColorT b) where+  articulation = _Wrapped . articulation  --- ArticulationT+-- ------------------------------------------------------------------------------------- --- end slur, cont slur, acc level, stacc level, begin slur--- newtype ArticulationT a = ArticulationT { getArticulationT :: (Bool, Bool, Int, Int, a, Bool) }+deriving instance HasTremolo a => HasTremolo (PartT n a)+deriving instance HasHarmonic a => HasHarmonic (PartT n a)+deriving instance HasSlide a => HasSlide (PartT n a)+deriving instance HasText a => HasText (PartT n a)  -instance Tiable a => Tiable (ArticulationT a) where-    toTied (ArticulationT (v,a)) = (ArticulationT (v,b), ArticulationT (v,c)) where (b,c) = toTied a--type instance Part (ArticulationT a)                         = Part a-instance HasPart a => HasPart (ArticulationT a) where-    getPart = getPart . get1-    modifyPart   f                                      = fmap (modifyPart f)-instance HasChord a => HasChord (ArticulationT a) where-    type ChordNote (ArticulationT a)                         = ArticulationT (ChordNote a)-    getChord (ArticulationT (v,x))                          = fmap (\x -> ArticulationT (v,x)) (getChord x)--type instance Pitch (ArticulationT a) = Pitch a-instance HasGetPitch a => HasGetPitch (ArticulationT a) where-    __getPitch (ArticulationT (_,a)) = __getPitch a-instance HasSetPitch a b => HasSetPitch (ArticulationT a) (ArticulationT b) where-    type SetPitch g (ArticulationT a) = ArticulationT (SetPitch g a)-    __mapPitch f (ArticulationT (v,x)) = (ArticulationT (v,__mapPitch f x))--deriving instance HasDynamic a => HasDynamic (ArticulationT a)-deriving instance HasTremolo a => HasTremolo (ArticulationT a)-deriving instance HasHarmonic a => HasHarmonic (ArticulationT a)-deriving instance HasSlide a => HasSlide (ArticulationT a)-deriving instance HasText a => HasText (ArticulationT a)---- TremoloT+deriving instance HasTremolo a => HasTremolo (TieT a)+deriving instance HasHarmonic a => HasHarmonic (TieT a)+deriving instance HasSlide a => HasSlide (TieT a)+deriving instance HasText a => HasText (TieT a)  instance Tiable a => Tiable (TremoloT a) where-    toTied (TremoloT (n,a))                         = (TremoloT (n,b), TremoloT (n,c)) where (b,c) = toTied a-type instance Part (TremoloT a)                          = Part a-instance HasPart a => HasPart (TremoloT a) where-    getPart (TremoloT (_,a))                        = getPart a-    modifyPart f (TremoloT (n,x))                   = TremoloT (n, modifyPart f x)-instance HasChord a => HasChord (TremoloT a) where-    type ChordNote (TremoloT a)                          = TremoloT (ChordNote a)-    getChord (TremoloT (n,x))                       = fmap (\x -> TremoloT (n,x)) (getChord x)--type instance Pitch (TremoloT a) = Pitch a-instance HasGetPitch a => HasGetPitch (TremoloT a) where-    __getPitch = __getPitch . get1-instance HasSetPitch a b => HasSetPitch (TremoloT a) (TremoloT b) where-    type SetPitch g (TremoloT a) = TremoloT (SetPitch g a)-    __mapPitch f = fmap (__mapPitch f)+    toTied = unzipR . fmap toTied -deriving instance HasDynamic a => HasDynamic (TremoloT a)-deriving instance HasArticulation a => HasArticulation (TremoloT a)+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)@@ -364,24 +190,7 @@ -- TextT  instance Tiable a => Tiable (TextT a) where-    toTied (TextT (n,a))                            = (TextT (n,b), TextT (mempty,c)) where (b,c) = toTied a-type instance Part (TextT a)                             = Part a-instance HasPart a => HasPart (TextT a) where-    getPart (TextT (_,a))                           = getPart a-    modifyPart f = fmap (modifyPart f)-instance HasChord a => HasChord (TextT a) where-    type ChordNote (TextT a)                             = TextT (ChordNote a)-    getChord (TextT (n,x))                          = fmap (\x -> TextT (n,x)) (getChord x)--type instance Pitch (TextT a) = Pitch a-instance HasGetPitch a => HasGetPitch (TextT a) where-    __getPitch = __getPitch . get1-instance HasSetPitch a b => HasSetPitch (TextT a) (TextT b) where-    type SetPitch g (TextT a) = TextT (SetPitch g a)-    __mapPitch f = fmap (__mapPitch f)--deriving instance HasDynamic a => HasDynamic (TextT a)-deriving instance HasArticulation a => HasArticulation (TextT a)+  toTied (TextT (Couple (n,a))) = (TextT (Couple (n,b)), TextT (Couple (mempty,c))) where (b,c) = toTied a deriving instance HasTremolo a => HasTremolo (TextT a) deriving instance HasHarmonic a => HasHarmonic (TextT a) deriving instance HasSlide a => HasSlide (TextT a)@@ -390,24 +199,8 @@ -- HarmonicT  instance Tiable a => Tiable (HarmonicT a) where-    toTied (HarmonicT (n,a))                        = (HarmonicT (n,b), HarmonicT (n,c)) where (b,c) = toTied a-type instance Part (HarmonicT a)                         = Part a-instance HasPart a => HasPart (HarmonicT a) where-    getPart (HarmonicT (_,a))                       = getPart a-    modifyPart f (HarmonicT (n,x))                  = HarmonicT (n, modifyPart f x)-instance HasChord a => HasChord (HarmonicT a) where-    type ChordNote (HarmonicT a)                         = HarmonicT (ChordNote a)-    getChord (HarmonicT (n,x))                      = fmap (\x -> HarmonicT (n,x)) (getChord x)--type instance Pitch (HarmonicT a) = Pitch a-instance HasGetPitch a => HasGetPitch (HarmonicT a) where-    __getPitch = __getPitch . get1-instance HasSetPitch a b => HasSetPitch (HarmonicT a) (HarmonicT b) where-    type SetPitch g (HarmonicT a) = HarmonicT (SetPitch g a)-    __mapPitch f = fmap (__mapPitch f)--deriving instance HasDynamic a => HasDynamic (HarmonicT a)-deriving instance HasArticulation a => HasArticulation (HarmonicT a)+  -- toTied = unzipR . fmap toTied+  toTied (HarmonicT (Couple (n,a))) = (HarmonicT (Couple (n,b)), HarmonicT (Couple (mempty,c))) where (b,c) = toTied a deriving instance HasTremolo a => HasTremolo (HarmonicT a) deriving instance HasSlide a => HasSlide (HarmonicT a) deriving instance HasText a => HasText (HarmonicT a)@@ -417,121 +210,88 @@   instance Tiable a => Tiable (SlideT a) where-    toTied (SlideT (v,x)) = (SlideT (v,a), SlideT (v,b)) where (a,b) = toTied x--type instance Part (SlideT a) = Part a-instance HasPart a => HasPart (SlideT a) where-    getPart = getPart . get1-    modifyPart f = fmap (modifyPart f)-instance HasChord a => HasChord (SlideT a) where-    type ChordNote (SlideT a) = SlideT (ChordNote a)-    getChord (SlideT (x,as)) = fmap (\a -> SlideT (x,a)) (getChord as)--type instance Pitch (SlideT a) = Pitch a-instance HasGetPitch a => HasGetPitch (SlideT a) where-    __getPitch = __getPitch . get1-instance HasSetPitch a b => HasSetPitch (SlideT a) (SlideT b) where-    type SetPitch g (SlideT a) = SlideT (SetPitch g a)-    __mapPitch f = fmap (__mapPitch f)--deriving instance HasDynamic a => HasDynamic (SlideT a)-deriving instance HasArticulation a => HasArticulation (SlideT a)+  toTied = unzipR . fmap toTied deriving instance HasTremolo a => HasTremolo (SlideT a) deriving instance HasHarmonic a => HasHarmonic (SlideT a) deriving instance HasText a => HasText (SlideT a)   ----------------------------------------------------------------------------------------- Literal instances--------------------------------------------------------------------------------------+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 Alterable a => Alterable (Score a) where-    sharpen = fmap sharpen-    flatten = fmap flatten+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)+deriving instance IsDynamics a => IsDynamics (HarmonicT a)+deriving instance IsPitch a => IsPitch (SlideT a)+deriving instance IsDynamics a => IsDynamics (SlideT a) -instance Alterable a => Alterable (ChordT a) where-    sharpen = fmap sharpen-    flatten = fmap flatten+deriving instance IsPitch a => IsPitch (ColorT a)+deriving instance IsDynamics a => IsDynamics (ColorT a)+deriving instance Transformable a => Transformable (ColorT a)+deriving instance Reversible a => Reversible (ColorT a)+deriving instance Alterable a => Alterable (ColorT a)+deriving instance Augmentable a => Augmentable (ColorT a)+deriving instance HasTremolo a => HasTremolo (ColorT a)+deriving instance HasHarmonic a => HasHarmonic (ColorT a)+deriving instance HasSlide a => HasSlide (ColorT a)+deriving instance HasText a => HasText (ColorT a) -instance Alterable a => Alterable (DynamicT a) where-    sharpen = fmap sharpen-    flatten = fmap flatten+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) -instance Alterable a => Alterable (SlideT a) where-    sharpen = fmap sharpen-    flatten = fmap flatten+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) -instance Alterable a => Alterable (TieT a) where-    sharpen = fmap sharpen-    flatten = fmap flatten+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) -instance Alterable a => Alterable (HarmonicT a) where-    sharpen = fmap sharpen-    flatten = fmap flatten+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) -instance Alterable a => Alterable (ArticulationT a) where-    sharpen = fmap sharpen-    flatten = fmap flatten -instance Alterable a => Alterable (TextT a) where-    sharpen = fmap sharpen-    flatten = fmap flatten -instance Alterable a => Alterable (TremoloT a) where-    sharpen = fmap sharpen-    flatten = fmap flatten+-------------------------------------------------------------------------------------+-- Literal instances+------------------------------------------------------------------------------------- -instance Alterable a => Alterable (PartT n a) where++instance Alterable a => Alterable (Score a) where     sharpen = fmap sharpen     flatten = fmap flatten+deriving instance Alterable a => Alterable (TieT a)+deriving instance Alterable a => Alterable (PartT n a)+deriving instance Alterable a => Alterable (DynamicT n a)+deriving instance Alterable a => Alterable (ArticulationT n a)  instance Augmentable a => Augmentable (Score a) where     augment = fmap augment     diminish = fmap diminish--instance Augmentable a => Augmentable (ChordT a) where-    augment = fmap augment-    diminish = fmap diminish--instance Augmentable a => Augmentable (DynamicT a) where-    augment = fmap augment-    diminish = fmap diminish--instance Augmentable a => Augmentable (SlideT a) where-    augment = fmap augment-    diminish = fmap diminish--instance Augmentable a => Augmentable (TieT a) where-    augment = fmap augment-    diminish = fmap diminish--instance Augmentable a => Augmentable (HarmonicT a) where-    augment = fmap augment-    diminish = fmap diminish--instance Augmentable a => Augmentable (ArticulationT a) where-    augment = fmap augment-    diminish = fmap diminish--instance Augmentable a => Augmentable (TextT a) where-    augment = fmap augment-    diminish = fmap diminish--instance Augmentable a => Augmentable (TremoloT a) where-    augment = fmap augment-    diminish = fmap diminish--instance Augmentable a => Augmentable (PartT n a) where-    augment = fmap augment-    diminish = fmap diminish-+deriving instance Augmentable a => Augmentable (TieT a)+deriving instance Augmentable a => Augmentable (PartT n a)+deriving instance Augmentable a => Augmentable (DynamicT n a)+deriving instance Augmentable a => Augmentable (ArticulationT n a)  ----------------------------------------------------------------------------------------- Num, Integral, Enum and Bounded---------------------------------------------------------------------------------------+-- -------------------------------------------------------------------------------------+-- -- Num, Integral, Enum and Bounded+-- -------------------------------------------------------------------------------------+-- -- PartT  instance (Enum v, Eq v, Num a) => Num (PartT v a) where@@ -557,376 +317,25 @@     PartT (v,a) `quotRem` PartT (_,b) = (PartT (v,q), PartT (v,r)) where (q,r) = a `quotRem` b     toInteger (PartT (v,a)) = toInteger a ---- ChordT---- instance Num a => Num (ChordT a) where---     ChordT [a] + ChordT [b]   = ChordT [a+b]---     ChordT [a] * ChordT [b]   = ChordT [a*b]---     ChordT [a] - ChordT [b]   = ChordT [a-b]---     abs (ChordT [a])          = ChordT [abs a]---     signum (ChordT [a])       = ChordT [signum a]---     fromInteger a             = ChordT [fromInteger a]--instance Enum a => Enum (ChordT a) where-    toEnum a                  = ChordT [toEnum a]-    fromEnum (ChordT [a])     = fromEnum a--instance Bounded a => Bounded (ChordT a) where-    minBound = ChordT [minBound]-    maxBound = ChordT [maxBound]---- instance (Num a, Ord a, Real a) => Real (ChordT a) where---     toRational (ChordT [a]) = toRational a---- instance (Real a, Enum a, Integral a) => Integral (ChordT a) where---     ChordT [a] `quotRem` ChordT [b] = (ChordT [q], ChordT [r]) where (q,r) = a `quotRem` b---     toInteger (ChordT [a]) = toInteger a----- TieT--instance Num a => Num (TieT a) where-    (+) = liftA2 (+)-    (*) = liftA2 (*)-    (-) = liftA2 (-)-    abs = fmap abs-    signum = fmap signum-    fromInteger = pure . fromInteger--instance Fractional a => Fractional (TieT a) where-    recip        = fmap recip-    fromRational = pure . fromRational--instance Floating a => Floating (TieT a) where-    pi    = pure pi-    sqrt  = fmap sqrt-    exp   = fmap exp-    log   = fmap log-    sin   = fmap sin-    cos   = fmap cos-    asin  = fmap asin-    atan  = fmap atan-    acos  = fmap acos-    sinh  = fmap sinh-    cosh  = fmap cosh-    asinh = fmap asinh-    atanh = fmap atanh-    acosh = fmap acos--instance Enum a => Enum (TieT a) where-    toEnum = pure . toEnum-    fromEnum = fromEnum . get1--instance Bounded a => Bounded (TieT a) where-    minBound = pure minBound-    maxBound = pure maxBound--instance (Num a, Ord a, Real a) => Real (TieT a) where-    toRational = toRational . get1--instance (Real a, Enum a, Integral a) => Integral (TieT a) where-    quot = liftA2 quot-    rem = liftA2 rem-    toInteger = toInteger . get1----- DynamicT--instance Num a => Num (DynamicT a) where-    (+) = liftA2 (+)-    (*) = liftA2 (*)-    (-) = liftA2 (-)-    abs = fmap abs-    signum = fmap signum-    fromInteger = pure . fromInteger--instance Fractional a => Fractional (DynamicT a) where-    recip        = fmap recip-    fromRational = pure . fromRational--instance Floating a => Floating (DynamicT a) where-    pi    = pure pi-    sqrt  = fmap sqrt-    exp   = fmap exp-    log   = fmap log-    sin   = fmap sin-    cos   = fmap cos-    asin  = fmap asin-    atan  = fmap atan-    acos  = fmap acos-    sinh  = fmap sinh-    cosh  = fmap cosh-    asinh = fmap asinh-    atanh = fmap atanh-    acosh = fmap acos--instance Enum a => Enum (DynamicT a) where-    toEnum = pure . toEnum-    fromEnum = fromEnum . get1--instance Bounded a => Bounded (DynamicT a) where-    minBound = pure minBound-    maxBound = pure maxBound--instance (Num a, Ord a, Real a) => Real (DynamicT a) where-    toRational = toRational . get1--instance (Real a, Enum a, Integral a) => Integral (DynamicT a) where-    quot = liftA2 quot-    rem = liftA2 rem-    toInteger = toInteger . get1----- ArticulationT--instance Num a => Num (ArticulationT a) where-    (+) = liftA2 (+)-    (*) = liftA2 (*)-    (-) = liftA2 (-)-    abs = fmap abs-    signum = fmap signum-    fromInteger = pure . fromInteger--instance Fractional a => Fractional (ArticulationT a) where-    recip        = fmap recip-    fromRational = pure . fromRational--instance Floating a => Floating (ArticulationT a) where-    pi    = pure pi-    sqrt  = fmap sqrt-    exp   = fmap exp-    log   = fmap log-    sin   = fmap sin-    cos   = fmap cos-    asin  = fmap asin-    atan  = fmap atan-    acos  = fmap acos-    sinh  = fmap sinh-    cosh  = fmap cosh-    asinh = fmap asinh-    atanh = fmap atanh-    acosh = fmap acos--instance Enum a => Enum (ArticulationT a) where-    toEnum = pure . toEnum-    fromEnum = fromEnum . get1--instance Bounded a => Bounded (ArticulationT a) where-    minBound = pure minBound-    maxBound = pure maxBound--instance (Num a, Ord a, Real a) => Real (ArticulationT a) where-    toRational = toRational . get1--instance (Real a, Enum a, Integral a) => Integral (ArticulationT a) where-    quot = liftA2 quot-    rem = liftA2 rem-    toInteger = toInteger . get1---- TremoloT--instance Num a => Num (TremoloT a) where-    (+) = liftA2 (+)-    (*) = liftA2 (*)-    (-) = liftA2 (-)-    abs = fmap abs-    signum = fmap signum-    fromInteger = pure . fromInteger--instance Fractional a => Fractional (TremoloT a) where-    recip        = fmap recip-    fromRational = pure . fromRational--instance Floating a => Floating (TremoloT a) where-    pi    = pure pi-    sqrt  = fmap sqrt-    exp   = fmap exp-    log   = fmap log-    sin   = fmap sin-    cos   = fmap cos-    asin  = fmap asin-    atan  = fmap atan-    acos  = fmap acos-    sinh  = fmap sinh-    cosh  = fmap cosh-    asinh = fmap asinh-    atanh = fmap atanh-    acosh = fmap acos--instance Enum a => Enum (TremoloT a) where-    toEnum = pure . toEnum-    fromEnum = fromEnum . get1--instance Bounded a => Bounded (TremoloT a) where-    minBound = pure minBound-    maxBound = pure maxBound--instance (Num a, Ord a, Real a) => Real (TremoloT a) where-    toRational = toRational . get1--instance (Real a, Enum a, Integral a) => Integral (TremoloT a) where-    quot = liftA2 quot-    rem = liftA2 rem-    toInteger = toInteger . get1---- TextT--instance Num a => Num (TextT a) where-    (+) = liftA2 (+)-    (*) = liftA2 (*)-    (-) = liftA2 (-)-    abs = fmap abs-    signum = fmap signum-    fromInteger = pure . fromInteger--instance Fractional a => Fractional (TextT a) where-    recip        = fmap recip-    fromRational = pure . fromRational--instance Floating a => Floating (TextT a) where-    pi    = pure pi-    sqrt  = fmap sqrt-    exp   = fmap exp-    log   = fmap log-    sin   = fmap sin-    cos   = fmap cos-    asin  = fmap asin-    atan  = fmap atan-    acos  = fmap acos-    sinh  = fmap sinh-    cosh  = fmap cosh-    asinh = fmap asinh-    atanh = fmap atanh-    acosh = fmap acos--instance Enum a => Enum (TextT a) where-    toEnum = pure . toEnum-    fromEnum = fromEnum . get1--instance Bounded a => Bounded (TextT a) where-    minBound = pure minBound-    maxBound = pure maxBound--instance (Num a, Ord a, Real a) => Real (TextT a) where-    toRational = toRational . get1--instance (Real a, Enum a, Integral a) => Integral (TextT a) where-    quot = liftA2 quot-    rem = liftA2 rem-    toInteger = toInteger . get1----- HarmonicT--instance Num a => Num (HarmonicT a) where-    (+) = liftA2 (+)-    (*) = liftA2 (*)-    (-) = liftA2 (-)-    abs = fmap abs-    signum = fmap signum-    fromInteger = pure . fromInteger--instance Fractional a => Fractional (HarmonicT a) where-    recip        = fmap recip-    fromRational = pure . fromRational--instance Floating a => Floating (HarmonicT a) where-    pi    = pure pi-    sqrt  = fmap sqrt-    exp   = fmap exp-    log   = fmap log-    sin   = fmap sin-    cos   = fmap cos-    asin  = fmap asin-    atan  = fmap atan-    acos  = fmap acos-    sinh  = fmap sinh-    cosh  = fmap cosh-    asinh = fmap asinh-    atanh = fmap atanh-    acosh = fmap acos--instance Enum a => Enum (HarmonicT a) where-    toEnum = pure . toEnum-    fromEnum = fromEnum . get1--instance Bounded a => Bounded (HarmonicT a) where-    minBound = pure minBound-    maxBound = pure maxBound--instance (Num a, Ord a, Real a) => Real (HarmonicT a) where-    toRational = toRational . get1--instance (Real a, Enum a, Integral a) => Integral (HarmonicT a) where-    quot = liftA2 quot-    rem = liftA2 rem-    toInteger = toInteger . get1---- SlideT--instance Num a => Num (SlideT a) where-    (+) = liftA2 (+)-    (*) = liftA2 (*)-    (-) = liftA2 (-)-    abs = fmap abs-    signum = fmap signum-    fromInteger = pure . fromInteger--instance Fractional a => Fractional (SlideT a) where-    recip        = fmap recip-    fromRational = pure . fromRational--instance Floating a => Floating (SlideT a) where-    pi    = pure pi-    sqrt  = fmap sqrt-    exp   = fmap exp-    log   = fmap log-    sin   = fmap sin-    cos   = fmap cos-    asin  = fmap asin-    atan  = fmap atan-    acos  = fmap acos-    sinh  = fmap sinh-    cosh  = fmap cosh-    asinh = fmap asinh-    atanh = fmap atanh-    acosh = fmap acos--instance Enum a => Enum (SlideT a) where-    toEnum = pure . toEnum-    fromEnum = fromEnum . get1--instance Bounded a => Bounded (SlideT a) where-    minBound = pure minBound-    maxBound = pure maxBound--instance (Num a, Ord a, Real a) => Real (SlideT a) where-    toRational = toRational . get1--instance (Real a, Enum a, Integral a) => Integral (SlideT a) where-    quot = liftA2 quot-    rem = liftA2 rem-    toInteger = toInteger . get1---type instance Pitch (Behavior a) = Behavior (Pitch a)---- TODO undecidable-instance (HasGetPitch a, HasSetPitch a b) => HasSetPitch (Behavior a) (Behavior b) where-    type SetPitch (Behavior p) (Behavior a) = Behavior (SetPitch p a)-    __mapPitch f a = liftA2 (__setPitch) (f $ (__getPitch) <$> a) a--instance Tiable a => Tiable (Behavior a) where toTied x = (x,x)+--+-- TODO suspect instances+-- We should remove both these after replacing [] by Chord in Preludes+--+instance Enum a => Enum [a] where+    toEnum a       = [toEnum a]+    fromEnum ([a]) = fromEnum a +instance Bounded a => Bounded [a] where+    minBound = [minBound]+    maxBound = [maxBound]  --- Safe for tuple-like types-get1 = head . toList--- TODO replace with extract+-- TODO use wrapper type and replace withContext+type instance Dynamic (a,b,c) = (a,b,c)+type instance SetDynamic g (a,b,c) = g -fmaps :: Functor f => (a -> (b, c)) -> f a -> (f b, f c)-fmaps f x = ((fst . f) <$> x, (snd . f) <$> x)+instance Transformable a => Transformable (Maybe a) where+  transform s = fmap (transform s)+instance (Transformable a, Transformable b, Transformable c) => Transformable (a,b,c) where+  transform s (a,b,c) = (transform s a,transform s b,transform s c) -liftsA2 :: Applicative f => (a -> b -> (c, d)) -> f a -> f b -> (f a, f b)-liftsA2 f x y = (fst <$> ((,) <$> x <*> y), snd <$> ((,) <$> x <*> y))
+ src/Music/Score/Internal/Export.hs view
@@ -0,0 +1,154 @@++{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies               #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------++module Music.Score.Internal.Export (+        extractTimeSignatures,+        voiceToBars',+        -- separateBars,+        spellPitch,+        toRelative,+        MVoice,+        toMVoice,+        unvoice,+        openCommand+          ) where++import           Prelude                  hiding (concat, concatMap, foldl,+                                           foldr, mapM, maximum, minimum, sum)++import           Control.Applicative+import           Control.Lens+import           Control.Monad            hiding (mapM)+import           Control.Monad.Plus+import           Data.AffineSpace+import           Data.AffineSpace.Point+import           Data.Basis+import           Data.Either+import           Data.Foldable+import           Data.Function            (on)+import           Data.Maybe+import           Data.Ord                 (comparing)+import           Data.Ratio+import           Data.Semigroup+import           Data.String+import           Data.Traversable+import           Data.Typeable+import           Data.VectorSpace++import           Music.Score.Articulation+import           Music.Score.Convert      (reactiveToVoice', scoreToVoice)+import           Music.Score.Dynamics+import           Music.Score.Part+import           Music.Score.Pitch+import           Music.Time.Internal.Quantize+import           Music.Score.Ties+import           Music.Score.Meta.Time+import           Music.Time++import qualified Codec.Midi               as Midi+import qualified Data.List                as List+import qualified Data.Map                 as Map+import qualified Music.Lilypond           as Lilypond+import qualified Music.MusicXml.Simple    as Xml+import qualified System.Info              as Info+import qualified Text.Pretty              as Pretty++import           Control.Exception+import           Music.Dynamics.Literal+import           Music.Pitch.Literal+import           Music.Score.Internal.Util+import           System.IO.Unsafe+import           System.Process++extractTimeSignatures :: Score a -> ([Maybe TimeSignature], [Duration])+extractTimeSignatures score = (barTimeSignatures, barDurations)+  where                                          +    defaultTimeSignature = time 4 4+    timeSignatures = fmap swap +      $ view eventsV . fuse . reactiveToVoice' (0 <-> (score^.offset)) +      $ getTimeSignatures defaultTimeSignature score++    -- Despite the fuse above we need retainUpdates here to prevent redundant repetition of time signatures+    barTimeSignatures = retainUpdates $ getBarTimeSignatures timeSignatures+    barDurations = getBarDurations timeSignatures++-- | Convert a voice to a list of bars using the given bar durations.+voiceToBars' :: Tiable a => [Duration] -> Voice (Maybe a) -> [[(Duration, Maybe a)]]+voiceToBars' barDurs = fmap (map (^. from stretched) . (^. stretcheds)) . splitTiesVoiceAt barDurs+-- TODO remove prime from name++-- | Convert absolute to relative durations.+toRelative :: [(Time, Duration, b)] -> [(Time, Duration, b)]+toRelative = snd . mapAccumL g 0+    where+        g now (t,d,x) = (t, (0 .+^ (t .-. now),d,x))++-- | Basic spelling for integral types.+spellPitch :: Integral a => a -> (a, a, a)+spellPitch p = (+    pitchClass,+    alteration,+    octave+    )+    where+        octave     = (p `div` 12) - 1+        semitone   = p `mod` 12+        pitchClass = fromStep major semitone+        alteration = semitone - step major pitchClass++        step xs p = xs !! (fromIntegral p `mod` length xs)+        fromStep xs p = fromIntegral $ fromMaybe (length xs - 1) $ List.findIndex (>= p) xs+        scaleFromSteps = snd . List.mapAccumL add 0+            where+                add a x = (a + x, a + x)+        major = scaleFromSteps [0,2,2,1,2,2,2,1]+++type MVoice a = Voice (Maybe a)++toMVoice :: (Semigroup a, Transformable a) => Score a -> MVoice a+toMVoice = scoreToVoice . simultaneous++unvoice :: Voice b -> [(Duration, b)]+unvoice = toListOf (stretcheds . traverse . from stretched)+-- unvoice = fmap (^. from stretched) . (^. stretcheds)+{-# DEPRECATED unvoice "Use 'unsafeEventsV'" #-}+++openCommand :: String+openCommand = case Info.os of+  "darwin" -> "open"+  "linux"  -> "xdg-open"++{-+-- TODO any version and/or OS+hasMuseScore = do+  result <- try (readProcess "ls" ["/Applications/MuseScore.app"] "")+  return $ case result of+    Left e   -> (e::SomeException) `assumed` False+    Right _ ->  True++hasSibelius = do+  result <- try (readProcess "ls" ["/Applications/Sibelius 7.app"] "")+  return $ case result of+    Left e   -> (e::SomeException) `assumed` False+    Right _ ->  True+++assumed = flip const+-}
+ src/Music/Score/Internal/Util.hs view
@@ -0,0 +1,348 @@+++{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ViewPatterns #-}++module Music.Score.Internal.Util where++{-+    Rules:+    +        * Functions may depend on any module in the lastest Haskell Platform release+        * All functions but those in Prelude must be referred to with their full,+          qualified names (i.e. Data.List.unfoldr).+        * Each function must have a unique name (so the whole file is a loadable module).+        * Each function should have a synopisis, like:++            -- | Ordinary Haddock commentary ...+            -- > category: Categories (please use the common Hackage names)+            -- > depends : base (all packages in HP that the function depends on)+            +-}++import Control.Lens+import Control.Monad.Plus+import Control.Applicative+import qualified Data.Char+import qualified Data.Monoid+import qualified Data.List+import qualified Data.Ratio+++-- | Divide a list into parts of maximum length n.+-- > category : List+-- > depends : base+divideList :: Int -> [a] -> [[a]]+divideList n xs+    | length xs <= n = [xs]+    | otherwise = [take n xs] ++ (divideList n $ drop n xs)++-- | Group a list into sublists whereever a predicate holds. The matched element+--   is the first in the sublist.+--+--   > splitWhile isSpace "foo bar baz"+--   >    ===> ["foo"," bar"," baz"]+--   >+--   > splitWhile (> 3) [1,5,4,7,0,1,2]+--   >    ===> [[1],[5],[4],[7,0,1,2]]+--+-- > category : List+-- > depends : base+splitWhile :: (a -> Bool) -> [a] -> [[a]]+splitWhile p xs = case splitWhile' p xs of+    []:xss -> xss+    xss    -> xss+    where+        splitWhile' p []     = [[]]+        splitWhile' p (x:xs) = case splitWhile' p xs of+            (xs:xss) -> if p x then []:(x:xs):xss else (x:xs):xss+++-- | Break up a list into parts of maximum length n, inserting the given list as separator.+--   Useful for breaking up strings, as in @breakList 80 "\n" str@.+--+-- > category : List+-- > depends : base+breakList :: Int -> [a] -> [a] -> [a]+breakList n z = Data.Monoid.mconcat . Data.List.intersperse z . divideList n++-- | Map over the indices and elements of list.+-- > category : List+-- > depends : base+mapIndexed :: (Int -> a -> b) -> [a] -> [b]+mapIndexed f as = map (uncurry f) (zip is as)+    where+        n  = length as - 1+        is = [0..n]+        +-- test++-- | Duplicate an element.+-- > category: Combinator, Tuple+-- > depends: base+dup :: a -> (a,a)+dup x = (x,x)++-- | Unfold a partial function. This is a simpler version of 'Data.List.unfoldr'. +-- > category: Function, List+-- > depends: base+unf :: (a -> Maybe a) -> a -> [a]+unf f = Data.List.unfoldr (fmap dup . f)++-- |+-- Map over first elements of a list.+-- Biased on first element for shorter lists.+-- > category: List+-- > depends: base+mapF f = mapFTL f id id++-- |+-- Map over all but the first and last elements of a list.+-- Biased on middle elements for shorter lists.+-- > category: List+-- > depends: base+mapT f = mapFTL id f id++-- |+-- Map over last elements of a list.+-- Biased on last element for shorter lists.+-- > category: List+-- > depends: base+mapL f = mapFTL id id f++-- |+-- Map over first, middle and last elements of list.+-- Biased on first, then on first and last for short lists.+--+-- > category: List+-- > depends: base+mapFTL :: (a -> b) -> (a -> b) -> (a -> b) -> [a] -> [b]+mapFTL f g h = go+    where+        go []    = []+        go [a]   = [f a]+        go [a,b] = [f a, h b]+        go xs    = [f $ head xs]          ++ +                   map g (tail $ init xs) ++ +                   [h $ last xs]++-- |+-- Extract the first consecutive sublist for which the predicate returns true, or+-- the empty list if no such sublist exists.+-- > category: List+-- > depends: base+filterOnce :: (a -> Bool) -> [a] -> [a]+filterOnce p = Data.List.takeWhile p . Data.List.dropWhile (not . p)+++-- | Returns all rotations of the given list. Given an infinite list, returns an infinite+-- list of rotated infinite lists.+-- > category: List+-- > depends: base+rots :: [a] -> [[a]]+rots xs = init (zipWith (++) (Data.List.tails xs) (Data.List.inits xs))++-- |+-- > category: List+-- > depends: base+rotl :: [a] -> [a]+rotl []     = []+rotl (x:xs) = xs ++ [x]++-- |+-- > category: List+-- > depends: base+rotr :: [a] -> [a]+rotr [] = []+rotr xs = last xs : init xs++-- |+-- > category: List+-- > depends: base+rotated :: Int -> [a] -> [a]+rotated = go+    where+        go n as +            | n >= 0 = iterate rotr as !! n+            | n <  0 = iterate rotl as !! abs n+++curry3 :: ((a, b, c) -> d) -> a -> b -> c -> d+curry3 = curry . curry . (. tripl)++uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d+uncurry3 = (. untripl) . uncurry . uncurry++untripl :: (a,b,c) -> ((a,b),c)+untripl (a,b,c) = ((a,b),c)++tripl :: ((a,b),c) -> (a,b,c)+tripl ((a,b),c) = (a,b,c)++tripr :: (a,(b,c)) -> (a,b,c)+tripr (a,(b,c)) = (a,b,c)+++-- TODO mo+partial2 :: (a -> b      -> Bool) -> a -> b      -> Maybe b+partial3 :: (a -> b -> c -> Bool) -> a -> b -> c -> Maybe c+partial2 f = curry  (fmap snd  . partial (uncurry f))+partial3 f = curry3 (fmap (view _3) . partial (uncurry3 f))++-- | Case matching on lists.+-- > category: List+-- > depends: base+list :: r -> ([a] -> r) -> [a] -> r+list z f [] = z+list z f xs = f xs++-- | Merge lists.+-- > category: List+-- > depends: base+merge :: Ord a => [a] -> [a] -> [a]+merge = mergeBy compare++-- | Merge lists.+-- > category: List+-- > depends: base+mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a]+mergeBy f = mergeBy' $ (fmap.fmap) orderingToBool f+    where+        orderingToBool LT = True+        orderingToBool EQ = True+        orderingToBool GT = False++mergeBy' :: (a -> a -> Bool) -> [a] -> [a] -> [a]+mergeBy' pred xs []         = xs+mergeBy' pred [] ys         = ys+mergeBy' pred (x:xs) (y:ys) =+    case pred x y of+        True  -> x: mergeBy' pred xs (y:ys)+        False -> y: mergeBy' pred (x:xs) ys++-- | Compose all functions.+-- > category: Function+-- > depends: base+composed :: [b -> b] -> b -> b+composed = Prelude.foldr (.) id++-- | Separate a ratio.+-- > category: Math+-- > depends: base+unRatio :: Integral a => Data.Ratio.Ratio a -> (a, a)+unRatio x = (Data.Ratio.numerator x, Data.Ratio.denominator x)++-- | Nicer printing of ratio as ordinary fractions.+-- > category: Math+-- > depends: base+showRatio :: (Integral a, Show a) => Data.Ratio.Ratio a -> String+showRatio (realToFrac -> (unRatio -> (x, 1))) = show x+showRatio (realToFrac -> (unRatio -> (x, y))) = "(" ++ show x ++ "/" ++ show y ++ ")"+++-- Replace all contigous ranges of equal values with [Just x, Nothing, Nothing ...]+-- > category: List+-- > depends: base+retainUpdates :: Eq a => [a] -> [Maybe a]+retainUpdates = snd . Data.List.mapAccumL g Nothing where+    g Nothing  x = (Just x, Just x)+    g (Just p) x = (Just x, if p == x then Nothing else Just x)+++-- Generic version of 'replicate'.+-- > category: List+-- > depends: base+replic :: Integral a => a -> b -> [b]+replic n = replicate (fromIntegral n)++-- Swap components.+-- > category: Tuple+-- > depends: base+swap :: (a, b) -> (b, a)+swap (x, y) = (y, x)++-- Interleave a list with the next consecutive element.+--+-- For any xs+--+-- > lenght xs == length (withNext xs)+--+-- If @xs@ is a finite list+--+-- > isNothing  $ snd $ last $ withNext xs == True+-- > all isJust $ snd $ init $ withNext xs == True+--+-- If @xs@ is an infinite list+--+-- > all isJust $ snd $ withNext xs == True+--+-- > category: List+-- > depends: base+withNext :: [a] -> [(a, Maybe a)]+withNext = fmap (\(p,c,n) -> (c,n)) . withPrevNext++withPrev :: [a] -> [(Maybe a, a)]+withPrev = fmap (\(p,c,n) -> (p,c)) . withPrevNext++-- withNext = go+--     where+--         go []       = []+--         go [x]      = [(x, Nothing)]+--         go (x:y:rs) = (x, Just y) : withNext (y : rs)++withPrevNext :: [a] -> [(Maybe a, a, Maybe a)]+withPrevNext xs = zip3 (pure Nothing ++ fmap Just xs) xs (fmap Just (tail xs) ++ repeat Nothing)++-- Map over a list with the next consecutive element.+--+-- > category: List+-- > depends: base+mapWithNext :: (a -> Maybe a -> b) -> [a] -> [b]+mapWithNext f = map (uncurry f) . withNext++mapWithPrev :: (Maybe a -> a -> b) -> [a] -> [b]+mapWithPrev f = map (uncurry f) . withPrev++mapWithPrevNext :: (Maybe a -> a -> Maybe a -> b) -> [a] -> [b]+mapWithPrevNext f = map (uncurry3 f) . withPrevNext+++++--------++++++++toDouble :: Real a => a -> Double+toDouble = realToFrac++through :: Applicative f => +  Lens' s a +  -> Lens s t a b +  -> Lens (f s) (f t) (f a) (f b)+through lens1 lens2 = lens getter (flip setter)+  where+    getter = fmap (view lens1)+    setter = liftA2 (over lens2 . const)+{-# INLINE through #-}++single :: Prism' [a] a+single = prism' return $ \xs -> case xs of+  [x] -> Just x+  _   -> Nothing+{-# INLINE single #-}+++floor' :: RealFrac a => a -> a+floor' = fromIntegral . floor++-- Like Data.Ord.comparing+-- (Are both variants of contramap?)+inspecting :: Eq a => (b -> a) -> b -> b -> Bool+inspecting p x y = p x == p y+
src/Music/Score/Meta.hs view
@@ -6,7 +6,6 @@ {-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE ScopedTypeVariables        #-}@@ -15,7 +14,7 @@  ------------------------------------------------------------------------------------- -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund 2012-2014 -- -- License     : BSD-style --@@ -23,221 +22,181 @@ -- Stability   : experimental -- Portability : non-portable (TF,GNTD) ----- Provides meta-information.------ Each score supports an unlimited number of 'Reactive' meta-values.+-- Combinators for manipulating scores and related structures. ----- This is more or less based on Diagrams styles, which is in turn based--- on XMonad.+-- /Warning/ This module is experimental. -- -------------------------------------------------------------------------------------  module Music.Score.Meta (-        -- * Attributes-        IsAttribute,-        Attribute,-        wrapAttr,-        unwrapAttr,+        module Music.Time.Meta, -        -- * Meta-values-        Meta,-        -- addMeta,+        -- TODO move+        (</>),+        rcat,++        -- * Meta-events         addMetaNote,         addGlobalMetaNote,-        runMeta,-        HasMeta(..),-  ) where+        fromMetaReactive, +        metaAt,+        metaAtStart,+        withMeta,+        withGlobalMeta,+        withMetaAtStart,+        withGlobalMetaAtStart,+   ) where+ import           Control.Applicative import           Control.Arrow-import           Control.Lens+import           Control.Lens           hiding (parts, perform)+import           Control.Monad import           Control.Monad.Plus-import           Data.Foldable             (Foldable)-import qualified Data.Foldable             as F-import qualified Data.List                 as List-import           Data.Map                  (Map)-import qualified Data.Map                  as Map+import           Data.AffineSpace+import           Data.AffineSpace.Point+import           Data.Foldable          (Foldable (..)) import           Data.Maybe-import           Data.Monoid.WithSemigroup+import           Data.Ord+import           Data.Ratio import           Data.Semigroup-import           Data.Set                  (Set)-import qualified Data.Set                  as Set import           Data.String-import           Data.Traversable          (Traversable)-import qualified Data.Traversable          as T-import           Data.Typeable-import           Data.Void+import           Data.Traversable+import           Data.VectorSpace -import           Music.Pitch.Literal-import           Music.Score.Note import           Music.Score.Part-import           Music.Score.Pitch-import           Music.Score.Util-import           Music.Score.Voice+import           Music.Score.Internal.Util import           Music.Time+import           Music.Time.Meta+import           Music.Time.Reactive +import qualified Data.Foldable          as Foldable+import qualified Data.List              as List -type IsAttribute a = (Typeable a, Monoid' a)+infixr 6 </> --- | An existential wrapper type to hold attributes.-data Attribute :: * where-    Attribute  :: IsAttribute a => a -> Attribute-    -- TAttribute  :: (Transformable a, IsAttribute a) => a -> Attribute --- | Wrap up an attribute.-wrapAttr :: IsAttribute a => a -> Attribute-wrapAttr = Attribute+-- |+-- Concatenate parts.+--+rcat :: (HasParts' a, Enum (Part a)) => [Score a] -> Score a+rcat = List.foldr (</>) mempty -unwrapAttr :: IsAttribute a => Attribute -> Maybe a-unwrapAttr (Attribute a)  = cast a+-- |+-- Similar to '<>', but increases parts in the second part to prevent collision.+--+(</>) :: (HasParts' a, Enum (Part a)) => Score a -> Score a -> Score a+a </> b = a <> moveParts offset b+    where+        -- max voice in a + 1+        offset = succ $ maximum' 0 $ fmap fromEnum $ toListOf parts a -instance Semigroup Attribute where-    (Attribute a1) <> a2 = case unwrapAttr a2 of-        Nothing  -> a2-        Just a2' -> Attribute (a1 <> a2')+        -- |+        -- Move down one voice (all parts).+        --+        moveParts :: (Integral b, HasParts' a, Enum (Part a)) => b -> Score a -> Score a+        moveParts x = parts %~ (successor x) -instance Delayable Attribute where-    delay _ (Attribute  a) = Attribute a-instance Stretchable Attribute where-    stretch _ (Attribute  a) = Attribute a+        -- |+        -- Move top-part to the specific voice (other parts follow).+        --+        moveToPart :: (Enum b, HasParts' a, Enum (Part a)) => b -> Score a -> Score a+        moveToPart v = moveParts (fromEnum v)  --- TODO is Transformable right w.r.t. join?-newtype Meta = Meta (Map String (Reactive Attribute))-    deriving (Delayable, Stretchable)+        iterating :: (a -> a) -> (a -> a) -> Int -> a -> a+        iterating f g n+            | n <  0 = f . iterating f g (n + 1)+            | n == 0 = id+            | n >  0 = g . iterating f g (n - 1) --- instance HasPart Meta where+        successor :: (Integral b, Enum a) => b -> a -> a+        successor n = iterating pred succ (fromIntegral n) -inMeta :: (Map String (Reactive Attribute) -> Map String (Reactive Attribute)) -> Meta -> Meta-inMeta f (Meta s) = Meta (f s)+        maximum' :: (Ord a, Foldable t) => a -> t a -> a+        maximum' z = option z getMax . foldMap (Option . Just . Max)  -addGlobalMetaNote :: forall a b . (IsAttribute a, HasMeta b) => Note a -> b -> b-addGlobalMetaNote x = applyMeta $ addMeta' (Nothing::Maybe Int) $ noteToReactive x --- XXX-addMetaNote :: forall a b . (IsAttribute a, HasMeta b, HasPart' b) => Note a -> b -> b-addMetaNote x y = (applyMeta $ addMeta' (Just y) $ noteToReactive x) y---- Switch at time t to the given value (switch is valid until the end of the music).--- TODO might not work as we think-addMetaChange :: forall a b . (IsAttribute a, HasMeta b, HasPart' b) => Time -> a -> b -> b-addMetaChange t x y = (applyMeta $ addMeta' (Just y) $ switch t mempty (pure x)) y---runMeta :: forall a b . (HasPart' a, IsAttribute b) => Maybe a -> Meta -> Reactive b-runMeta part = fromMaybe mempty . runMeta' part--addMeta' :: forall a b . (HasPart' a, IsAttribute b) => Maybe a -> Reactive b -> Meta-addMeta' part a = Meta $ Map.singleton key $ fmap wrapAttr a-    where-        key = ty ++ pt-        pt = show $ fmap getPart part-        ty = show $ typeOf (undefined :: b)---- runMeta' :: forall a . IsAttribute a => Meta -> Maybe (Reactive a)-runMeta' :: forall a b . (HasPart' a, IsAttribute b) => Maybe a -> Meta -> Maybe (Reactive b)-runMeta' part (Meta s) = fmap (fmap (fromMaybe (error "runMeta'") . unwrapAttr)) $ Map.lookup key s--- Note: unwrapAttr should never fail-    where-        key = ty ++ pt-        pt = show $ fmap getPart part-        ty = show . typeOf $ (undefined :: b)--instance Semigroup Meta where-    Meta s1 <> Meta s2 = Meta $ Map.unionWith (<>) s1 s2---- | The empty meta contains no attributes; composition of metas is---   a union of attributes; if the two metas have attributes of the---   same type they are combined according to their semigroup---   structure.-instance Monoid Meta where-    mempty = Meta Map.empty-    mappend = (<>)---- | Type class for things which have meta-information.-class HasMeta a where-    -- | Apply meta-information by combining it (on the left) with the-    --   existing meta-information.-    meta :: Lens' a Meta--instance HasMeta Meta where-    meta = ($)-    -applyMeta :: HasMeta a => Meta -> a -> a-applyMeta m = (meta <>~ m)+addMetaNote :: forall a b . (IsAttribute a, HasMeta b{-, HasPart' b-}) => Note a -> b -> b+addMetaNote x y = (applyMeta $ toMeta (Just y) $ noteToReactive x) y --- instance (HasMeta a, HasMeta b) => HasMeta (a,b) where---     applyMeta s = applyMeta s *** applyMeta s--- --- instance HasMeta a => HasMeta [a] where---     applyMeta = fmap . applyMeta--- --- instance HasMeta b => HasMeta (a -> b) where---     applyMeta = fmap . applyMeta--- --- instance HasMeta a => HasMeta (Map k a) where---     applyMeta = fmap . applyMeta--- --- instance (HasMeta a, Ord a) => HasMeta (Set a) where---     applyMeta = Set.map . applyMeta--- +addGlobalMetaNote :: forall a b . (IsAttribute a, HasMeta b) => Note a -> b -> b+addGlobalMetaNote x = applyMeta $ toMeta (Nothing::Maybe Int) $ noteToReactive x +fromMetaReactive :: forall a b . ({-HasPart' a, -}IsAttribute b) => Maybe a -> Meta -> Reactive b+fromMetaReactive part = fromMaybe mempty . fromMeta part   +withSpan :: Score a -> Score (Span, a)+withSpan = mapEvents (\t d x -> (t >-> d,x))+withTime = mapEvents (\t d x -> (t, x)) +inSpan t' (view range -> (t,u)) = t <= t' && t' < u +-- TODO clean+mapBefore :: Time -> (Score a -> Score a) -> Score a -> Score a+mapDuring :: Span -> (Score a -> Score a) -> Score a -> Score a+mapAfter :: Time -> (Score a -> Score a) -> Score a -> Score a+mapBefore t f x = let (y,n) = (fmap snd *** fmap snd) $ mpartition (\(t2,x) -> t2 < t) (withTime x) in (f y <> n)+mapDuring s f x = let (y,n) = (fmap snd *** fmap snd) $ mpartition (\(t,x) -> t `inSpan` s) (withTime x) in (f y <> n)+mapAfter t f x = let (y,n) = (fmap snd *** fmap snd) $ mpartition (\(t2,x) -> t2 >= t) (withTime x) in (f y <> n)  +-- Transform the score with the current value of some meta-information+-- Each "update chunk" of the meta-info is processed separately -newtype RehearsalMark = RehearsalMark ()-    deriving (Typeable, Monoid, Semigroup)+runScoreMeta :: forall a b . ({-HasPart' a, -}IsAttribute b) => Score a -> Reactive b+runScoreMeta = fromMetaReactive (Nothing :: Maybe a) . (view meta) +metaAt :: ({-HasPart' a, -}IsAttribute b) => Time -> Score a -> b+metaAt x = (`atTime` x) . runScoreMeta +metaAtStart :: ({-HasPart' a, -}IsAttribute b) => Score a -> b+metaAtStart x = _onset x `metaAt` x +withGlobalMeta :: IsAttribute a => (a -> Score b -> Score b) -> Score b -> Score b+withGlobalMeta = withMeta' (Nothing :: Maybe Int) +withMeta :: (IsAttribute a{-, HasPart' b-}) => (a -> Score b -> Score b) -> Score b -> Score b+withMeta f x = withMeta' (Just x) f x +withMeta' :: ({-HasPart' c, -}IsAttribute a) => Maybe c -> (a -> Score b -> Score b) -> Score b -> Score b+withMeta' part f x = let+    m = (view meta) x+    r = fromMetaReactive part m+    in case splitReactive r of+        Left  a -> f a x+        Right ((a, t), bs, (u, c)) ->+            (meta .~) m+                $ mapBefore t (f a)+                $ (composed $ fmap (\(view (from note) -> (s, a)) -> mapDuring s $ f a) $ bs)+                $ mapAfter u (f c)+                $ x +withGlobalMetaAtStart :: IsAttribute a => (a -> Score b -> Score b) -> Score b -> Score b+withGlobalMetaAtStart = withMetaAtStart' (Nothing :: Maybe Int) +withMetaAtStart :: (IsAttribute a{-, HasPart' b-}) => (a -> Score b -> Score b) -> Score b -> Score b+withMetaAtStart f x = withMetaAtStart' (Just x) f x +withMetaAtStart' :: (IsAttribute b{-, HasPart' p-}) =>+    Maybe p -> (b -> Score a -> Score a) -> Score a -> Score a+withMetaAtStart' partId f x = let+    m = (view meta) x+    in f (fromMetaReactive partId m `atTime` _onset x) x   --- TODO rename during+-- TODO move noteToReactive :: Monoid a => Note a -> Reactive a noteToReactive n = (pure <$> n) `activate` pure mempty --- | Split a reactive into notes, 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 note $ mrights (res $ (t,x):xs), head $ mlefts (res $ (t,x):xs))--    where--        note (t,u,x) = t <-> u =: x--        -- 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 (getNote -> (view range -> (start,stop), x)) y = y `turnOn` (x `turnOff` y)+activate (view (from note) -> (view range -> (start,stop), x)) y = y `turnOn` (x `turnOff` y)     where-        turnOn  = switch start-        turnOff = switch stop+        turnOn  = switchR start+        turnOff = switchR stop+
src/Music/Score/Meta/Annotations.hs view
@@ -14,7 +14,7 @@  ------------------------------------------------------------------------------------- -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund 2012-2014 -- -- License     : BSD-style --@@ -22,11 +22,10 @@ -- Stability   : experimental -- Portability : non-portable (TF,GNTD) ----- Provides annotations+-- Provides a basic way annotating scores. -- ------------------------------------------------------------------------------------- - module Music.Score.Meta.Annotations (         Annotation,         annotate,@@ -44,12 +43,9 @@ import           Data.Typeable import           Data.Void -import           Music.Score.Combinators (withGlobalMeta) import           Music.Score.Meta-import           Music.Score.Note-import           Music.Score.Ornaments   (HasText, text) import           Music.Score.Part-import           Music.Score.Score+import           Music.Score.Text    (HasText, text) import           Music.Time import           Music.Time.Reactive @@ -66,21 +62,21 @@  -- | Annotate the whole score. annotate :: String -> Score a -> Score a-annotate str x = annotateSpan (start >-> duration x) str x+annotate str x = annotateSpan (0 >-> _duration x) str x  -- | Annotate a part of the score. annotateSpan :: Span -> String -> Score a -> Score a-annotateSpan span str x = addGlobalMetaNote (sapp span $ return $ Annotation [str]) x+annotateSpan span str x = addGlobalMetaNote (transform span $ return $ Annotation [str]) x  -- | Show all annotations in the score.-showAnnotations :: (HasPart' a, HasText a) => Score a -> Score a+showAnnotations :: (HasPart' a, Ord (Part a), HasText a) => Score a -> Score a showAnnotations = showAnnotations' ":"  -- | Show all annotations in the score using the given prefix.-showAnnotations' :: (HasPart' a, HasText a) => String -> Score a -> Score a+showAnnotations' :: (HasPart' a, Ord (Part a), HasText a) => String -> Score a -> Score a showAnnotations' prefix = withAnnotations (flip $ \s -> foldr (text . (prefix ++ )) s)  -- | Handle the annotations in a score.-withAnnotations :: (HasPart' a, HasText a) => ([String] -> Score a -> Score a) -> Score a -> Score a+withAnnotations :: (HasParts' a, HasText a) => ([String] -> Score a -> Score a) -> Score a -> Score a withAnnotations f = withGlobalMeta (f . getAnnotation)
src/Music/Score/Meta/Attribution.hs view
@@ -14,7 +14,7 @@  ------------------------------------------------------------------------------------- -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund 2012-2014 -- -- License     : BSD-style --@@ -22,6 +22,8 @@ -- Stability   : experimental -- Portability : non-portable (TF,GNTD) --+-- Provides meta-data attribution for composer, lyricist etc.+-- -------------------------------------------------------------------------------------  module Music.Score.Meta.Attribution (@@ -48,6 +50,7 @@   ) where  import           Control.Arrow+import           Control.Lens              (view) import           Control.Monad.Plus import           Data.Foldable             (Foldable) import qualified Data.Foldable             as F@@ -55,7 +58,6 @@ import           Data.Map                  (Map) import qualified Data.Map                  as Map import           Data.Maybe-import           Data.Monoid.WithSemigroup import           Data.Semigroup import           Data.Set                  (Set) import qualified Data.Set                  as Set@@ -66,14 +68,10 @@ import           Data.Void  import           Music.Pitch.Literal-import           Music.Score.Combinators import           Music.Score.Meta-import           Music.Score.Note import           Music.Score.Part import           Music.Score.Pitch-import           Music.Score.Score-import           Music.Score.Util-import           Music.Score.Voice+import           Music.Score.Internal.Util import           Music.Time import           Music.Time.Reactive @@ -120,35 +118,35 @@   -- | Set the given attribution in the given score.-attribute :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => Attribution -> a -> a-attribute a x = attributeDuring (era x) a x+attribute :: (HasMeta a, {-HasPart' a, -}HasPosition a) => Attribution -> a -> a+attribute a x = attributeDuring (_getEra x) a x  -- | Set the given attribution in the given part of a score.-attributeDuring :: (HasMeta a, HasPart' a) => Span -> Attribution -> a -> a-attributeDuring s a = addGlobalMetaNote (s =: a)+attributeDuring :: (HasMeta a{-, HasPart' a-}) => Span -> Attribution -> a -> a+attributeDuring s a = addGlobalMetaNote (view note (s, a))  -- | Set composer of the given score.-composer :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => String -> a -> a-composer t x = composerDuring (era x) t x+composer :: (HasMeta a, {-HasPart' a, -}HasPosition a) => String -> a -> a+composer t x = composerDuring (_getEra x) t x  -- | Set composer of the given part of a score.-composerDuring :: (HasMeta a, HasPart' a) => Span -> String -> a -> a+composerDuring :: (HasMeta a{-, HasPart' a-}) => Span -> String -> a -> a composerDuring s x = attributeDuring s ("composer" `attribution` x)  -- | Set lyricist of the given score.-lyricist :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => String -> a -> a-lyricist t x = lyricistDuring (era x) t x+lyricist :: (HasMeta a, {-HasPart' a, -}HasPosition a) => String -> a -> a+lyricist t x = lyricistDuring (_getEra x) t x  -- | Set lyricist of the given part of a score.-lyricistDuring :: (HasMeta a, HasPart' a) => Span -> String -> a -> a+lyricistDuring :: (HasMeta a{-, HasPart' a-}) => Span -> String -> a -> a lyricistDuring s x = attributeDuring s ("lyricist" `attribution` x)  -- | Set arranger of the given score.-arranger :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => String -> a -> a-arranger t x = arrangerDuring (era x) t x+arranger :: (HasMeta a, {-HasPart' a, -}HasPosition a) => String -> a -> a+arranger t x = arrangerDuring (_getEra x) t x  -- | Set arranger of the given part of a score.-arrangerDuring :: (HasMeta a, HasPart' a) => Span -> String -> a -> a+arrangerDuring :: (HasMeta a{-, HasPart' a-}) => Span -> String -> a -> a arrangerDuring s x = attributeDuring s ("arranger" `attribution` x)  -- | Extract attribution values of the given category from a score.
src/Music/Score/Meta/Barline.hs view
@@ -14,7 +14,7 @@  ------------------------------------------------------------------------------------- -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund 2012-2014 -- -- License     : BSD-style --@@ -22,6 +22,10 @@ -- Stability   : experimental -- Portability : non-portable (TF,GNTD) --+-- Provides special barlines as meta-data.+--+-- (Ordinary barlines are generated automatically, see also "Music.Score.Meta.Time").+-- -------------------------------------------------------------------------------------  module Music.Score.Meta.Barline (@@ -41,6 +45,7 @@   import           Control.Arrow+import           Control.Lens              (view) import           Control.Monad.Plus import           Data.Default import           Data.Foldable             (Foldable)@@ -49,7 +54,6 @@ import           Data.Map                  (Map) import qualified Data.Map                  as Map import           Data.Maybe-import           Data.Monoid.WithSemigroup import           Data.Semigroup import           Data.Set                  (Set) import qualified Data.Set                  as Set@@ -60,14 +64,10 @@ import           Data.Void  import           Music.Pitch.Literal-import           Music.Score.Combinators import           Music.Score.Meta-import           Music.Score.Note import           Music.Score.Part import           Music.Score.Pitch-import           Music.Score.Score-import           Music.Score.Util-import           Music.Score.Voice+import           Music.Score.Internal.Util import           Music.Time import           Music.Time.Reactive @@ -81,20 +81,20 @@     deriving (Eq, Ord, Show, Typeable)  -- | Add a barline over the whole score.-barline :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => Barline -> a -> a-barline c x = barlineDuring (era x) c x+barline :: (HasMeta a, {-HasPart' a, -}HasPosition a) => Barline -> a -> a+barline c x = barlineDuring (_getEra x) c x  -- | Add a barline over the whole score.-doubleBarline :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => Barline -> a -> a+doubleBarline :: (HasMeta a, {-HasPart' a, -}HasPosition a) => Barline -> a -> a doubleBarline = undefined  -- | Add a barline over the whole score.-finalBarline :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => Barline -> a -> a+finalBarline :: (HasMeta a, {-HasPart' a, -}HasPosition a) => Barline -> a -> a finalBarline = undefined  -- | Add a barline to the given score.-barlineDuring :: (HasMeta a, HasPart' a) => Span -> Barline -> a -> a-barlineDuring s c = addMetaNote (s =: (Option $ Just $ Last c))+barlineDuring :: (HasMeta a{-, HasPart' a-}) => Span -> Barline -> a -> a+barlineDuring s c = addMetaNote $ view note (s, (Option $ Just $ Last c))  -- | Extract barlines in from the given score, using the given default barline. withBarline :: (Barline -> Score a -> Score a) -> Score a -> Score a
src/Music/Score/Meta/Clef.hs view
@@ -14,7 +14,7 @@  ------------------------------------------------------------------------------------- -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund 2012-2014 -- -- License     : BSD-style --@@ -22,6 +22,10 @@ -- Stability   : experimental -- Portability : non-portable (TF,GNTD) --+-- Provides clefs as meta-data.+--+-- /Warning/ Experimental module.+-- -------------------------------------------------------------------------------------  module Music.Score.Meta.Clef (@@ -37,6 +41,7 @@   ) where  import           Control.Arrow+import           Control.Lens              (view) import           Control.Monad.Plus import           Data.Foldable             (Foldable) import qualified Data.Foldable             as F@@ -44,7 +49,6 @@ import           Data.Map                  (Map) import qualified Data.Map                  as Map import           Data.Maybe-import           Data.Monoid.WithSemigroup import           Data.Semigroup import           Data.Set                  (Set) import qualified Data.Set                  as Set@@ -55,14 +59,10 @@ import           Data.Void  import           Music.Pitch.Literal-import           Music.Score.Combinators import           Music.Score.Meta-import           Music.Score.Note import           Music.Score.Part import           Music.Score.Pitch-import           Music.Score.Score-import           Music.Score.Util-import           Music.Score.Voice+import           Music.Score.Internal.Util import           Music.Time import           Music.Time.Reactive @@ -70,13 +70,14 @@     deriving (Eq, Ord, Show, Typeable)  -- | Set clef of the given score.-clef :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => Clef -> a -> a-clef c x = clefDuring (era x) c x+clef :: (HasMeta a, {-HasPart' a,-} HasPosition a) => Clef -> a -> a+clef c x = clefDuring (_getEra x) c x  -- | Set clef of the given part of a score.-clefDuring :: (HasMeta a, HasPart' a) => Span -> Clef -> a -> a-clefDuring s c = addMetaNote (s =: (Option $ Just $ Last c))+clefDuring :: (HasMeta a{-, HasPart' a-}) => Span -> Clef -> a -> a+clefDuring s c = addMetaNote $ view note (s, (Option $ Just $ Last c))  -- | Extract the clef in from the given score, using the given default clef.-withClef :: HasPart' a => Clef -> (Clef -> Score a -> Score a) -> Score a -> Score a+withClef :: {-HasPart' a =>-} Clef -> (Clef -> Score a -> Score a) -> Score a -> Score a withClef def f = withMeta (f . fromMaybe def . fmap getLast . getOption)+
src/Music/Score/Meta/Fermata.hs view
@@ -14,7 +14,7 @@  ------------------------------------------------------------------------------------- -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund 2012-2014 -- -- License     : BSD-style --@@ -22,6 +22,8 @@ -- Stability   : experimental -- Portability : non-portable (TF,GNTD) --+-- Provides fermatas.+-- -------------------------------------------------------------------------------------  module Music.Score.Meta.Fermata (@@ -39,6 +41,7 @@   import           Control.Arrow+import           Control.Lens              (view) import           Control.Monad.Plus import           Data.Default import           Data.Foldable             (Foldable)@@ -47,7 +50,6 @@ import           Data.Map                  (Map) import qualified Data.Map                  as Map import           Data.Maybe-import           Data.Monoid.WithSemigroup import           Data.Semigroup import           Data.Set                  (Set) import qualified Data.Set                  as Set@@ -58,14 +60,10 @@ import           Data.Void  import           Music.Pitch.Literal-import           Music.Score.Combinators import           Music.Score.Meta-import           Music.Score.Note import           Music.Score.Part import           Music.Score.Pitch-import           Music.Score.Score-import           Music.Score.Util-import           Music.Score.Voice+import           Music.Score.Internal.Util import           Music.Time import           Music.Time.Reactive @@ -79,12 +77,12 @@     deriving (Eq, Ord, Show, Typeable)  -- | Add a fermata over the whole score.-fermata :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => Fermata -> a -> a-fermata c x = fermataDuring (era x) c x+fermata :: (HasMeta a, {-HasPart' a, -}HasPosition a) => Fermata -> a -> a+fermata c x = fermataDuring (_getEra x) c x  -- | Add a fermata to the given score.-fermataDuring :: (HasMeta a, HasPart' a) => Span -> Fermata -> a -> a-fermataDuring s c = addMetaNote (s =: (Option $ Just $ Last c))+fermataDuring :: (HasMeta a{-, HasPart' a-}) => Span -> Fermata -> a -> a+fermataDuring s c = addMetaNote $ view note (s, (Option $ Just $ Last c))  -- | Extract fermatas in from the given score, using the given default fermata. withFermata :: (Fermata -> Score a -> Score a) -> Score a -> Score a
src/Music/Score/Meta/Key.hs view
@@ -15,7 +15,7 @@  ------------------------------------------------------------------------------------- -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund 2012-2014 -- -- License     : BSD-style --@@ -23,6 +23,8 @@ -- Stability   : experimental -- Portability : non-portable (TF,GNTD) --+-- Provides key signature meta-data.+-- -------------------------------------------------------------------------------------  module Music.Score.Meta.Key (@@ -42,6 +44,7 @@   ) where  import           Control.Arrow+import           Control.Lens              (view) import           Control.Monad.Plus import           Data.Foldable             (Foldable) import qualified Data.Foldable             as F@@ -49,7 +52,6 @@ import           Data.Map                  (Map) import qualified Data.Map                  as Map import           Data.Maybe-import           Data.Monoid.WithSemigroup import           Data.Semigroup import           Data.Set                  (Set) import qualified Data.Set                  as Set@@ -60,14 +62,10 @@ import           Data.Void  import           Music.Pitch.Literal-import           Music.Score.Combinators import           Music.Score.Meta-import           Music.Score.Note import           Music.Score.Part import           Music.Score.Pitch-import           Music.Score.Score-import           Music.Score.Util-import           Music.Score.Voice+import           Music.Score.Internal.Util import           Music.Time import           Music.Time.Reactive @@ -121,12 +119,12 @@ isMinorKey = not . isMajorKey  -- | Set the key signature of the given score.-keySignature :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => KeySignature -> a -> a-keySignature c x = keySignatureDuring (era x) c x+keySignature :: (HasMeta a, {-HasPart' a, -}HasPosition a) => KeySignature -> a -> a+keySignature c x = keySignatureDuring (_getEra x) c x  -- | Set the key signature of the given part of a score.-keySignatureDuring :: (HasMeta a, HasPart' a) => Span -> KeySignature -> a -> a-keySignatureDuring s c = addGlobalMetaNote (s =: (Option $ Just $ Last c))+keySignatureDuring :: (HasMeta a{-, HasPart' a-}) => Span -> KeySignature -> a -> a+keySignatureDuring s c = addGlobalMetaNote $ view note (s, (Option $ Just $ Last c))  -- | Extract all key signatures from the given score, using the given default key signature. withKeySignature :: KeySignature -> (KeySignature -> Score a -> Score a) -> Score a -> Score a
src/Music/Score/Meta/RehearsalMark.hs view
@@ -14,7 +14,7 @@  ------------------------------------------------------------------------------------- -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund 2012-2014 -- -- License     : BSD-style --@@ -22,6 +22,10 @@ -- Stability   : experimental -- Portability : non-portable (TF,GNTD) --+-- Provides tempo meta-data.+--+-- /Warning/ This is not supported by any backends yet.+-- -------------------------------------------------------------------------------------  module Music.Score.Meta.RehearsalMark (@@ -38,6 +42,7 @@   import           Control.Arrow+import           Control.Lens              (view) import           Control.Monad.Plus import           Data.Default import           Data.Foldable             (Foldable)@@ -46,7 +51,6 @@ import           Data.Map                  (Map) import qualified Data.Map                  as Map import           Data.Maybe-import           Data.Monoid.WithSemigroup import           Data.Semigroup import           Data.Set                  (Set) import qualified Data.Set                  as Set@@ -57,14 +61,10 @@ import           Data.Void  import           Music.Pitch.Literal-import           Music.Score.Combinators import           Music.Score.Meta-import           Music.Score.Note import           Music.Score.Part import           Music.Score.Pitch-import           Music.Score.Score-import           Music.Score.Util-import           Music.Score.Voice+import           Music.Score.Internal.Util import           Music.Time import           Music.Time.Reactive @@ -92,11 +92,11 @@ -- metronome :: Duration -> Bpm -> Tempo -- metronome noteVal bpm = Tempo Nothing (Just noteVal) $ 60 / (bpm * noteVal) -rehearsalMark :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => RehearsalMark -> a -> a-rehearsalMark c x = rehearsalMarkDuring (era x) c x+rehearsalMark :: (HasMeta a, {-HasPart' a, -}HasPosition a) => RehearsalMark -> a -> a+rehearsalMark c x = rehearsalMarkDuring (_getEra x) c x -rehearsalMarkDuring :: (HasMeta a, HasPart' a) => Span -> RehearsalMark -> a -> a-rehearsalMarkDuring s x = addGlobalMetaNote (s =: x)+rehearsalMarkDuring :: (HasMeta a{-, HasPart' a-}) => Span -> RehearsalMark -> a -> a+rehearsalMarkDuring s x = addGlobalMetaNote $ view note (s, x)  withRehearsalMark :: (RehearsalMark -> Score a -> Score a) -> Score a -> Score a withRehearsalMark = withGlobalMeta
src/Music/Score/Meta/Tempo.hs view
@@ -15,7 +15,7 @@  ------------------------------------------------------------------------------------- -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund 2012-2014 -- -- License     : BSD-style --@@ -23,6 +23,8 @@ -- Stability   : experimental -- Portability : non-portable (TF,GNTD) --+-- Provides tempo meta-data.+-- -------------------------------------------------------------------------------------  module Music.Score.Meta.Tempo (@@ -56,7 +58,6 @@ import           Data.Map                  (Map) import qualified Data.Map                  as Map import           Data.Maybe-import           Data.Monoid.WithSemigroup import           Data.Semigroup import           Data.Set                  (Set) import qualified Data.Set                  as Set@@ -68,17 +69,11 @@ import           Data.Void  import           Music.Pitch.Literal-import           Music.Score.Combinators-import           Music.Score.Convert import           Music.Score.Meta-import           Music.Score.Note import           Music.Score.Part import           Music.Score.Pitch-import           Music.Score.Score-import           Music.Score.Util-import           Music.Score.Voice-import           Music.Time-import           Music.Time.Reactive+import           Music.Score.Internal.Util+import           Music.Time                hiding (time)  type Bpm       = Duration type NoteValue = Duration@@ -110,8 +105,18 @@             showR (realToFrac -> (unRatio -> (x, y))) = "(" ++ show x ++ "/" ++ show y ++ ")"  instance Default Tempo where-    def = metronome (1/1) 60+    def = mempty +instance Semigroup Tempo where+    (<>) = mappend++instance Monoid Tempo where+    mempty = metronome (1/4) 120+    a `mappend` b+      | a == mempty = b+      | b == mempty = a+      | otherwise   = a+ -- | Create a tempo from a duration and a number of beats per minute. -- --   For example @metronome (1/2) 48@ means 48 half notes per minute.@@ -161,12 +166,12 @@ tempoToDuration (Tempo _ _ x) = x  -- | Set the tempo of the given score.-tempo :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => Tempo -> a -> a-tempo c x = tempoDuring (era x) c x+tempo :: (HasMeta a, {-HasPart' a, -}HasPosition a) => Tempo -> a -> a+tempo c x = tempoDuring (_getEra x) c x  -- | Set the tempo of the given part of a score.-tempoDuring :: (HasMeta a, HasPart' a) => Span -> Tempo -> a -> a-tempoDuring s c = addGlobalMetaNote (s =: (optionFirst c))+tempoDuring :: (HasMeta a{-, HasPart' a-}) => Span -> Tempo -> a -> a+tempoDuring s c = addGlobalMetaNote $ view note (s, c)   -- TODO move@@ -175,40 +180,44 @@  inSpan' (view range -> (t,u)) x = t <= x && x < u +mkNote s x = view note (s, x)++++-- | Extract all tempi from the given score, using the given default tempo.+-- withTempo :: (Tempo -> Score a -> Score a) -> Score a -> Score a+-- withTempo f = withGlobalMeta (f . fromMaybe def . fmap getFirst . getOption)++renderTempo :: Score a -> Score a+renderTempo = error "renderTempo: Not implemented"+{-+ -- | Split a reactive into notes, as well as the values before and after the first/last update -- TODO fails if not positive--- TODO same as reactiveToVoice+-- TODO consolidate reactiveIn :: Span -> Reactive a -> [Note a] reactiveIn s r-    | duration s <= 0 = error "reactiveIn: Needs positive duration"-    | otherwise       = let r2 = trim s (fmap optionFirst r)+    | _duration s <= 0 = error "reactiveIn: Needs positive duration"+    | otherwise       = let r2 = trimR s (fmap optionFirst r)     in fmap (fmap $ fromJust . unOptionFirst) $ case updates r2 of         -- We have at least 2 value because of trim-        (frl -> ((t,x),[],(u,_))) -> [t <-> u =: x] -- one note+        (frl -> ((t,x),[],(u,_))) -> [view note (t <-> u, x)] -- one note         (frl -> ((t0,x0), unzip -> (tn,xn), (tl,_))) -> let             times  = [t0] ++ tn             spans  = mapWithNext (\t mu -> t <-> fromMaybe tl mu) times             values = [x0] ++ xn-            in zipWith (=:) spans values------- | Extract all tempi from the given score, using the given default tempo.--- withTempo :: (Tempo -> Score a -> Score a) -> Score a -> Score a--- withTempo f = withGlobalMeta (f . fromMaybe def . fmap getFirst . getOption)+            in zipWith mkNote spans values -renderTempo :: Score a -> Score a renderTempo sc =     flip composed sc $ fmap renderTempoScore-        $ tempoRegions (era sc)-        $ tempoRegions0 (era sc)+        $ tempoRegions (_getEra sc)+        $ tempoRegions0 (_getEra sc)         $ getTempoChanges defTempo sc  renderTempoTest :: Score a -> [TempoRegion] renderTempoTest sc = id-    $ tempoRegions (era sc)-    $ tempoRegions0 (era sc)+    $ tempoRegions (_getEra sc)+    $ tempoRegions0 (_getEra sc)     $ getTempoChanges defTempo sc  @@ -219,17 +228,17 @@ defTempo = metronome (1/1) 60  getTempoChanges :: Tempo -> Score a -> Reactive Tempo-getTempoChanges def = fmap (fromMaybe def . unOptionFirst) . runMeta (Nothing::Maybe Int) . (view meta)+getTempoChanges def = fmap (fromMaybe def . unOptionFirst) . fromMetaReactive (Nothing::Maybe Int) . (view meta)   -- | Get all tempo regions for the given span. tempoRegions0 :: Span -> Reactive Tempo -> [TempoRegion0] tempoRegions0 s r = fmap f $ s `reactiveIn` r     where-        f (getNote -> (view delta -> (t,u),x)) = TempoRegion0 t u (tempoToDuration x)+        f (view (from note) -> (view delta -> (t,u),x)) = TempoRegion0 t u (tempoToDuration x)  tempoRegions :: Span -> [TempoRegion0] -> [TempoRegion]-tempoRegions s = snd . List.mapAccumL f (onset s, onset s) -- XXX offset?+tempoRegions s = snd . List.mapAccumL f (_onset s, _onset s) -- XXX offset?     where         f (nt,st) (TempoRegion0 _ d x) = ((nt .+^ d, st .+^ (d*x)),             TempoRegion nt (nt .+^ d) st x@@ -256,7 +265,7 @@  -- TODO use lens renderTempoScore :: TempoRegion -> Score a -> Score a-renderTempoScore tr = over notes $ fmap $ over (note_ . _1) $ renderTempoSpan tr+renderTempoScore tr = over notes $ fmap $ over (from note . _1) $ renderTempoSpan tr   data TempoRegion0 =@@ -277,10 +286,7 @@     deriving (Eq, Ord, Show)  tempoRegionNotated (TempoRegion t u _ _) = t <-> u---- TODO add to Music.Score.Note-note_ :: Iso (Note a) (Note b) (Span, a) (Span, b)-note_ = iso getNote (uncurry (=:))+-}  -- span :: Iso (Note a) (Note b) Span Span @@ -306,10 +312,11 @@   -- TODO consolidate-optionFirst = Option . Just . First-unOptionFirst = fmap getFirst . getOption+-- optionFirst = Option . Just . First+-- unOptionFirst = fmap getFirst . getOption  -- TODO move frl []  = error "frl: No value" frl [x] = error "frl: Just one value" frl xs  = (head xs, (tail.init) xs, last xs)+
src/Music/Score/Meta/Time.hs view
@@ -15,7 +15,7 @@  ------------------------------------------------------------------------------------- -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund 2012-2014 -- -- License     : BSD-style --@@ -23,6 +23,8 @@ -- Stability   : experimental -- Portability : non-portable (TF,GNTD) --+-- Provides time signatures and related meta-data.+-- -------------------------------------------------------------------------------------  module Music.Score.Meta.Time (@@ -52,15 +54,14 @@   ) where  import           Control.Arrow+import           Control.Lens              (view) import           Control.Monad.Plus-import Control.Lens (view) 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.Monoid.WithSemigroup import           Data.Ratio                ((%)) import           Data.Semigroup import           Data.Set                  (Set)@@ -72,16 +73,11 @@ import           Data.Void  import           Music.Pitch.Literal-import           Music.Score.Combinators import           Music.Score.Meta-import           Music.Score.Note import           Music.Score.Part import           Music.Score.Pitch-import           Music.Score.Score-import           Music.Score.Util-import           Music.Score.Voice-import           Music.Time-import           Music.Time.Reactive+import           Music.Score.Internal.Util+import           Music.Time                hiding (time)  -- | -- A time signature is a sequence of beat numbers and a note value (i.e. an expression on the@@ -167,18 +163,18 @@ getTimeSignature (TimeSignature x) = x  -- | Set the time signature of the given score.-timeSignature :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => TimeSignature -> a -> a-timeSignature c x = timeSignatureDuring (start <-> offset x) c x+timeSignature :: (HasMeta a, {-HasPart' a,-} HasPosition a) => TimeSignature -> a -> a+timeSignature c x = timeSignatureDuring (0 <-> _offset x) c x --- use (onset x <-> offset x) instead of (start <-> offset x)+-- use (_onset x <-> _offset x) instead of (0 <-> _offset x) -- timeSignature' c x = timeSignatureDuring (era x) c x  -- | Set the time signature of the given part of a score.-timeSignatureDuring :: (HasMeta a, HasPart' a) => Span -> TimeSignature -> a -> a-timeSignatureDuring s c = addGlobalMetaNote (s =: optionFirst c)+timeSignatureDuring :: (HasMeta a{-, HasPart' a-}) => Span -> TimeSignature -> a -> a+timeSignatureDuring s c = addGlobalMetaNote $ view note (s, optionFirst c)  getTimeSignatures :: TimeSignature -> Score a -> Reactive TimeSignature-getTimeSignatures def = fmap (fromMaybe def . unOptionFirst) . runMeta (Nothing::Maybe Int) . (view meta)+getTimeSignatures def = fmap (fromMaybe def . unOptionFirst) . fromMetaReactive (Nothing::Maybe Int) . (view meta)  getTimeSignatureChanges :: TimeSignature -> Score a -> [(Time, TimeSignature)] getTimeSignatureChanges def = updates . getTimeSignatures def@@ -245,6 +241,5 @@ -- TODO consolidate optionFirst = Option . Just . First unOptionFirst = fmap getFirst . getOption-
src/Music/Score/Meta/Title.hs view
@@ -14,7 +14,7 @@  ------------------------------------------------------------------------------------- -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund 2012-2014 -- -- License     : BSD-style --@@ -22,6 +22,8 @@ -- Stability   : experimental -- Portability : non-portable (TF,GNTD) --+-- Provides various forms of title, subtitle etc. and related meta-data.+-- -------------------------------------------------------------------------------------  module Music.Score.Meta.Title (@@ -48,6 +50,7 @@   ) where  import           Control.Arrow+import           Control.Lens              (view) import           Control.Monad.Plus import           Data.Foldable             (Foldable) import qualified Data.Foldable             as F@@ -55,7 +58,6 @@ import           Data.Map                  (Map) import qualified Data.Map                  as Map import           Data.Maybe-import           Data.Monoid.WithSemigroup import           Data.Semigroup import           Data.Set                  (Set) import qualified Data.Set                  as Set@@ -66,14 +68,10 @@ import           Data.Void  import           Music.Pitch.Literal-import           Music.Score.Combinators import           Music.Score.Meta-import           Music.Score.Note import           Music.Score.Part import           Music.Score.Pitch-import           Music.Score.Score-import           Music.Score.Util-import           Music.Score.Voice+import           Music.Score.Internal.Util import           Music.Time import           Music.Time.Reactive @@ -122,28 +120,28 @@ getTitleAt (Title t) n = fmap getLast . getOption . t $ n  -- | Set title of the given score.-title :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => Title -> a -> a-title t x = titleDuring (era x) t x+title :: (HasMeta a, {-HasPart' a, -}HasPosition a) => Title -> a -> a+title t x = titleDuring (_getEra x) t x  -- | Set title of the given part of a score.-titleDuring :: (HasMeta a, HasPart' a) => Span -> Title -> a -> a-titleDuring s t = addGlobalMetaNote (s =: t)+titleDuring :: (HasMeta a{-, HasPart' a-}) => Span -> Title -> a -> a+titleDuring s t = addGlobalMetaNote $ view note (s, t)  -- | Set subtitle of the given score.-subtitle :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => Title -> a -> a-subtitle t x = subtitleDuring (era x) t x+subtitle :: (HasMeta a, {-HasPart' a, -}HasPosition a) => Title -> a -> a+subtitle t x = subtitleDuring (_getEra x) t x  -- | Set subtitle of the given part of a score.-subtitleDuring :: (HasMeta a, HasPart' a) => Span -> Title -> a -> a-subtitleDuring s t = addGlobalMetaNote (s =: denoteTitle t)+subtitleDuring :: (HasMeta a{-, HasPart' a-}) => Span -> Title -> a -> a+subtitleDuring s t = addGlobalMetaNote $ view note (s, denoteTitle t)  -- | Set subsubtitle of the given score.-subsubtitle :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => Title -> a -> a-subsubtitle t x = subsubtitleDuring (era x) t x+subsubtitle :: (HasMeta a, {-HasPart' a, -}HasPosition a) => Title -> a -> a+subsubtitle t x = subsubtitleDuring (_getEra x) t x  -- | Set subsubtitle of the given part of a score.-subsubtitleDuring :: (HasMeta a, HasPart' a) => Span -> Title -> a -> a-subsubtitleDuring s t = addGlobalMetaNote (s =: denoteTitle (denoteTitle t))+subsubtitleDuring :: (HasMeta a{-, HasPart' a-}) => Span -> Title -> a -> a+subsubtitleDuring s t = addGlobalMetaNote $ view note (s, denoteTitle (denoteTitle t))  -- | Extract the title in from the given score. withTitle :: (Title -> Score a -> Score a) -> Score a -> Score a
− src/Music/Score/Note.hs 
@@ -1,99 +0,0 @@--{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE DeriveTraversable          #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE TypeFamilies               #-}--module Music.Score.Note (-        Note,-        getNote,-        getNoteSpan,-        getNoteValue,-        (=:),-  ) where--import           Control.Applicative-import           Control.Comonad-import           Control.Comonad.Env-import           Control.Monad--import           Data.Foldable          (Foldable)-import qualified Data.Foldable          as F-import           Data.PairMonad         ()-import           Data.Traversable       (Traversable)-import qualified Data.Traversable       as T--import           Music.Dynamics.Literal-import           Music.Pitch.Literal-import           Music.Score.Pitch-import           Music.Time--newtype Note a = Note { getNote_ :: (Span, a) }-    deriving (Eq, Ord, Show, {-Read, -}Functor, Applicative, Monad, Comonad, Foldable, Traversable)---- |--- Deconstruct a note.------ Typically used with the @ViewPatterns@ extension, as in------ > foo (getNote -> (s,x)) = ...----getNote :: Note a -> (Span, a)-getNote (Note x) = x---- | Get the span of the note. Same as 'era' and 'ask'.-getNoteSpan :: Note a -> Span-getNoteSpan = fst . getNote---- | Get the value of the note. Same as 'extract'.-getNoteValue :: Note a -> a-getNoteValue = snd . getNote---- Note that--- extract = getNoteValue--- ask = getNoteSpan--instance ComonadEnv Span Note where-    ask = getNoteSpan--instance Delayable (Note a) where-    delay n (Note (s,x)) = Note (delay n s, x)--instance Stretchable (Note a) where-    stretch n (Note (s,x)) = Note (stretch n s, x)--instance HasOnset (Note a) where-    onset (Note (s,x)) = onset s--instance HasOffset (Note a) where-    offset (Note (s,x)) = offset s--instance IsPitch a => IsPitch (Note a) where-    fromPitch = pure . fromPitch--instance IsDynamics a => IsDynamics (Note a) where-    fromDynamics = pure . fromDynamics--instance IsInterval a => IsInterval (Note a) where-    fromInterval = pure . fromInterval--type instance Pitch (Note a) = Pitch a-instance HasGetPitch a => HasGetPitch (Note a) where-    __getPitch  = __getPitch . getNoteValue-instance HasSetPitch a b => HasSetPitch (Note a) (Note b) where-    type SetPitch g (Note a) = Note (SetPitch g a)-    __mapPitch f = fmap (__mapPitch f)----- | Construct a note from a span and value.------ Typically used with the span constructors as in:------ > 0 <-> 2 =: c--- > 0 >-> 1 =: d----(=:) :: Span -> a -> Note a-s =: x  =  Note (s,x)
− src/Music/Score/Ornaments.hs 
@@ -1,203 +0,0 @@--{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeOperators              #-}------------------------------------------------------------------------------------------ |--- Copyright   : (c) Hans Hoglund 2012------ License     : BSD-style------ Maintainer  : hans@hanshoglund.se--- Stability   : experimental--- Portability : non-portable (TF,GNTD)------ Provides functions for manipulating ornaments (and miscellaneous stuff to be--- given its own module soon...).--------------------------------------------------------------------------------------------module Music.Score.Ornaments (-        -- * Tremolo-        HasTremolo(..),-        TremoloT(..),-        tremolo,--        -- * Text-        HasText(..),-        TextT(..),-        text,--        -- * Harmonics-        HasHarmonic(..),-        HarmonicT(..),-        harmonic,-        artificial,--        -- * Slides and glissando-        HasSlide(..),-        SlideT(..),-        slide,-        glissando,-  ) where--import           Control.Applicative-import           Control.Lens-import           Data.Foldable-import           Data.Foldable-import           Data.Ratio-import           Data.Semigroup-import           Data.Typeable--import           Music.Score.Combinators-import           Music.Score.Part-import           Music.Score.Score-import           Music.Score.Voice-import           Music.Time--class HasTremolo a where-    setTrem :: Int -> a -> a--newtype TremoloT a = TremoloT { getTremoloT :: (Sum Int, a) }-    deriving (Eq, Show, Ord, Functor, Foldable, Typeable, Applicative, Monad)--instance HasTremolo (TremoloT a) where-    setTrem      n (TremoloT (_,x))                 = TremoloT (Sum n,x)--instance HasTremolo b => HasTremolo (a, b) where-    setTrem n = fmap (setTrem n)--instance HasTremolo a => HasTremolo (Score a) where-    setTrem n = fmap (setTrem n)------class HasText a where-    addText :: String -> a -> a--newtype TextT a = TextT { getTextT :: ([String], a) }-    deriving (Eq, Show, Ord, Functor, Foldable, Typeable, Applicative, Monad)--instance HasText (TextT a) where-    addText      s (TextT (t,x))                    = TextT (t ++ [s],x)--instance HasText a => HasText (b, a) where-    addText       s                                 = fmap (addText s)--instance HasText a => HasText (Score a) where-    addText       s                                 = fmap (addText s)------- 0 for none, positive for natural, negative for artificial-class HasHarmonic a where-    setNatural :: Bool -> a -> a-    setHarmonic :: Int -> a -> a---- (isNatural, overtone series index where 0 is fundamental)-newtype HarmonicT a = HarmonicT { getHarmonicT :: ((Any, Sum Int), a) }-    deriving (Eq, Show, Ord, Functor, Foldable, Typeable, Applicative, Monad)--instance HasHarmonic (HarmonicT a) where-    setNatural b (HarmonicT ((_,n),x)) = HarmonicT ((Any b,n),x)-    setHarmonic n (HarmonicT ((nat,_),x)) = HarmonicT ((nat,Sum n),x)--instance HasHarmonic a => HasHarmonic (b, a) where-    setNatural b = fmap (setNatural b)-    setHarmonic n = fmap (setHarmonic n)--instance HasHarmonic a => HasHarmonic (Score a) where-    setNatural b = fmap (setNatural b)-    setHarmonic n = fmap (setHarmonic n)----class HasSlide a where-    setBeginGliss :: Bool -> a -> a-    setBeginSlide :: Bool -> a -> a-    setEndGliss   :: Bool -> a -> a-    setEndSlide   :: Bool -> a -> a---- (eg,es,a,bg,bs)-newtype SlideT a = SlideT { getSlideT :: (((Any, Any), (Any, Any)), a) }-    deriving (Eq, Show, Ord, Functor, Foldable, Typeable, Applicative, Monad)--instance Wrapped (SlideT a) where-    type Unwrapped (SlideT a) = (((Any, Any), (Any, Any)), a)-    _Wrapped' = iso getSlideT SlideT --bg, bs, eg, es :: Lens' (SlideT a) Any-bg = _Wrapped' . _1 . _2 . _1-bs = _Wrapped' . _1 . _2 . _2-eg = _Wrapped' . _1 . _1 . _1-es = _Wrapped' . _1 . _1 . _2--instance HasSlide (SlideT a) where-    setBeginGliss x = bg .~ Any x-    setBeginSlide x = bs .~ Any x-    setEndGliss   x = eg .~ Any x-    setEndSlide   x = es .~ Any x--instance HasSlide a => HasSlide (b, a) where-    setBeginGliss n = fmap (setBeginGliss n)-    setBeginSlide n = fmap (setBeginSlide n)-    setEndGliss   n = fmap (setEndGliss n)-    setEndSlide   n = fmap (setEndSlide n)--instance HasSlide a => HasSlide (Score a) where-    setBeginGliss n = fmap (setBeginGliss n)-    setBeginSlide n = fmap (setBeginSlide n)-    setEndGliss   n = fmap (setEndGliss n)-    setEndSlide   n = fmap (setEndSlide n)---- |--- Set the number of tremolo divisions for all notes in the score.----tremolo :: HasTremolo a => Int -> a -> a-tremolo = setTrem---- |--- Attach the given text to the first note in the score.----text :: (HasPart' a, HasText a) => String -> Score a -> Score a-text s = mapPhrase (addText s) id id---- |--- Add a slide between the first and the last note.----slide :: (HasPart' a, HasSlide a) => Score a -> Score a-slide = mapPhrase (setBeginSlide True) id (setEndSlide True)---- |--- Add a glissando between the first and the last note.----glissando :: (HasPart' a, HasSlide a) => Score a -> Score a-glissando = mapPhrase (setBeginGliss True) id (setEndGliss True)---- |--- Make all notes natural harmonics on the given overtone (1 for octave, 2 for fifth etc).--- Sounding pitch is unaffected, but notated output is transposed automatically.----harmonic :: HasHarmonic a => Int -> a -> a-harmonic n = setNatural True . setHarmonic n--- TODO verify this can actually be played---- |--- Make all notes natural harmonics on the given overtone (1 for octave, 2 for fifth etc).--- Sounding pitch is unaffected, but notated output is transposed automatically.----artificial :: HasHarmonic a => a -> a-artificial =  setNatural False . setHarmonic 3-
src/Music/Score/Part.hs view
@@ -3,16 +3,24 @@ {-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE DeriveFoldable             #-} {-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-} {-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TupleSections              #-} {-# LANGUAGE TypeFamilies               #-} {-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE UndecidableInstances       #-}  ------------------------------------------------------------------------------------- -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund 2012-2014 -- -- License     : BSD-style --@@ -24,94 +32,295 @@ -- ------------------------------------------------------------------------------------- - module Music.Score.Part (-        -- * Part representation+        -- ** Articulation type functions         Part,+        SetPart,+        -- ** Accessing parts+        HasParts(..),         HasPart(..),         HasPart',+        HasParts',+        part',+        parts',++        -- * Listing parts+        allParts,++        -- * Extracting parts+        extracted,+        extracted',+        extractPart,+        extractParts,+        extractParts',++        -- * Manipulating parts++        -- * Part representation         PartT(..),-        getParts,++        -- Part,+        -- HasPart(..),+        -- HasPart',+        -- PartT(..),+        -- getParts,   ) where  import           Control.Applicative import           Control.Comonad+import           Control.Lens                  hiding (parts, transform) import           Control.Monad.Plus import           Data.Default import           Data.Foldable-import qualified Data.List           as List-import           Data.Ord            (comparing)+import           Data.Functor.Couple+import qualified Data.List                     as List+import qualified Data.List                     as List+import           Data.Ord                      (comparing) import           Data.PairMonad import           Data.Ratio import           Data.Semigroup import           Data.Traversable import           Data.Typeable +import           Music.Dynamics.Literal+import           Music.Pitch.Literal+import           Music.Score.Ties+import           Music.Score.Internal.Util     (through) import           Music.Time+import           Music.Time.Internal.Transform --- | Associated part type. Should normally implement 'Ord' and 'Show'.-type family Part a :: * +-- |+-- Parts type.+--+type family Part (s :: *) :: * -- Part s   = a  -- |--- Class of types with an associated part.+-- Part type. ----- The part type can be any ordered type. A 'Show' instance is also--- required from printing the name of the part in output.+type family SetPart (b :: *) (s :: *) :: * -- Part b s = t++-- |+-- Class of types that provide a single part. ---class HasPart a where-    -- | Get the voice of the given note.-    getPart :: a -> Part a+class (HasParts s t) => HasPart s t where -    -- | Set the voice of the given note.-    setPart :: Part a -> a -> a+  -- | Part type.+  part :: Lens s t (Part s) (Part t) -    -- | Modify the voice of the given note.-    modifyPart :: (Part a -> Part a) -> a -> a+-- |+-- Class of types that provide a part traversal.+--+class (Transformable (Part s),+       Transformable (Part t)+       -- , SetPart (Part t) s ~ t+       ) => HasParts s t where -    setPart n      = modifyPart (const n)-    modifyPart f x = x+  -- | Part type.+  parts :: Traversal s t (Part s) (Part t) -newtype PartT n a = PartT { getPartT :: (n, a) }-    deriving (Eq, Ord, Show, Functor, Applicative, Comonad, Monad, Typeable)+type HasPart' a  = HasPart a a+type HasParts' a = HasParts a a -type instance Part () = Integer-type instance Part Double = Integer-type instance Part Float = Integer-type instance Part Int = Integer+-- |+-- Part type.+--+part' :: (HasPart s t, s ~ t) => Lens' s (Part s)+part' = part++-- |+-- Part type.+--+parts' :: (HasParts s t, s ~ t) => Traversal' s (Part s)+parts' = parts++type instance Part Bool = Bool+type instance SetPart a Bool = a+instance (b ~ Part b, Transformable b) => HasPart Bool b where+  part = ($)+instance (b ~ Part b, Transformable b) => HasParts Bool b where+  parts = ($)++type instance Part Ordering = Ordering+type instance SetPart a Ordering = a+instance (b ~ Part b, Transformable b) => HasPart Ordering b where+  part = ($)+instance (b ~ Part b, Transformable b) => HasParts Ordering b where+  parts = ($)++type instance Part () = ()+type instance SetPart a () = a+instance (b ~ Part b, Transformable b) => HasPart () b where+  part = ($)+instance (b ~ Part b, Transformable b) => HasParts () b where+  parts = ($)++type instance Part Int = Int+type instance SetPart a Int = a+instance HasPart Int Int where+  part = ($)+instance HasParts Int Int where+  parts = ($)+ type instance Part Integer = Integer-type instance Part (Ratio a) = Integer+type instance SetPart a Integer = a+instance HasPart Integer Integer where+  part = ($)+instance HasParts Integer Integer where+  parts = ($) -instance HasPart ()                         where { getPart _ = def }-instance HasPart Double                     where { getPart _ = def }-instance HasPart Float                      where { getPart _ = def }-instance HasPart Int                        where { getPart _ = def }-instance HasPart Integer                    where { getPart _ = def }-instance Integral a => HasPart (Ratio a)    where { getPart _ = def }+type instance Part Float = Float+type instance SetPart a Float = a+instance HasPart Float Float where+  part = ($)+instance HasParts Float Float where+  parts = ($) -type instance Part (PartT n a)       = n-instance HasPart (PartT n a) where-    getPart (PartT (v,_))       = v-    modifyPart f (PartT (v,x))  = PartT (f v, x)+type instance Part (c,a) = Part a+type instance SetPart b (c,a) = (c,SetPart b a)+type instance Part [a] = Part a+type instance SetPart b [a] = [SetPart b a]+type instance Part (Maybe a) = Part a+type instance SetPart b (Maybe a) = Maybe (SetPart b a)+type instance Part (Either c a) = Part a+type instance SetPart b (Either c a) = Either c (SetPart b a) -type instance Part (a,b)    = Part b-instance HasPart b => HasPart (a,b) where-    getPart (a,b)      = getPart b-    modifyPart f (a,b) = (a, modifyPart f b)+instance HasPart a b => HasPart (c, a) (c, b) where+  part = _2 . part +instance HasParts a b => HasParts (c, a) (c, b) where+  parts = traverse . parts++instance HasParts a b => HasParts [a] [b] where+  parts = traverse . parts++instance HasParts a b => HasParts (Maybe a) (Maybe b) where+  parts = traverse . parts++instance HasParts a b => HasParts (Either c a) (Either c b) where+  parts = traverse . parts+++type instance Part (Note a) = Part a+type instance SetPart g (Note a) = Note (SetPart g a)++instance (HasPart a b) => HasPart (Note a) (Note b) where+  part = _Wrapped . whilstL part++instance (HasParts a b) => HasParts (Note a) (Note b) where+  parts = _Wrapped . whilstL parts+ -- |--- Like 'HasPart', but enforces the part to be ordered.--- This is usually required for part separation and traversal.+-- List all the parts ---type HasPart' a = (Show (Part a), Ord (Part a), Default (Part a), HasPart a)---- TODO unify with class above as in Pitch?+allParts :: (Ord (Part a), HasParts' a) => a -> [Part a]+allParts = List.nub . List.sort . toListOf parts  -- |--- Get all parts in the given score. Returns a list of parts.+-- List all the parts ----- > Score a -> [Part]+extractPart :: (Eq (Part a), HasPart' a) => Part a -> Score a -> Score a+extractPart = extractPartG++extractPartG :: (Eq (Part a), MonadPlus f, HasPart' a) => Part a -> f a -> f a+extractPartG p x = head $ (\p s -> filterPart (== p) s) <$> [p] <*> return x++-- |+-- List all the parts ---getParts :: (Foldable t, HasPart' a) => t a -> [Part a]-getParts = List.sort . List.nub . fmap getPart . toList+extractParts :: (Ord (Part a), HasPart' a) => Score a -> [Score a]+extractParts = extractPartsG++extractPartsG :: (+  MonadPlus f, HasParts' (f a), HasPart' a, +  Part (f a) ~ Part a, Ord (Part a)+  ) => f a -> [f a]+extractPartsG x = (\p s -> filterPart (== p) s) <$> allParts x <*> return x++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)++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')++++newtype PartT n a = PartT { getPartT :: (n, a) }+  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++instance Rewrapped (PartT p a) (PartT p' b)+++type instance Part (PartT p a) = p+type instance SetPart p' (PartT p a) = PartT p' a++instance (Transformable p, Transformable p') => HasPart (PartT p a) (PartT p' a) where+  part = _Wrapped . _1++instance (Transformable p, Transformable p') => HasParts (PartT p a) (PartT p' a) where+  parts = _Wrapped . _1+++instance (IsPitch a, Enum n) => IsPitch (PartT n a) where+  fromPitch l = PartT (toEnum 0, fromPitch l)++instance (IsDynamics a, Enum n) => IsDynamics (PartT n a) where+  fromDynamics l = PartT (toEnum 0, fromDynamics l)++instance Reversible a => Reversible (PartT p a) where+  rev = fmap rev++instance Tiable a => Tiable (PartT n a) where+  toTied (PartT (v,a)) = (PartT (v,b), PartT (v,c)) where (b,c) = toTied a+++type instance Part                 (Segment a) = Segment (Part a)+type instance SetPart (Segment g) (Segment a) = Segment (SetPart g a)++instance (HasPart a a, HasPart a b) => HasParts (Segment a) (Segment b) where+  parts = through part part+instance (HasPart a a, HasPart a b) => HasPart (Segment a) (Segment b) where+  part = through part part++type instance Part                 (Behavior a) = Behavior (Part a)+type instance SetPart (Behavior g) (Behavior a) = Behavior (SetPart g a)++instance (HasPart a a, HasPart a b) => HasParts (Behavior a) (Behavior b) where+  parts = through part part+instance (HasPart a a, HasPart a b) => HasPart (Behavior a) (Behavior b) where+  part = through part part++type instance Part (Score a) = Part a+type instance SetPart g (Score a) = Score (SetPart g a)++instance (HasParts a b) => HasParts (Score a) (Score b) where+  parts =+    _Wrapped . _2   -- into NScore+    . _Wrapped+    . traverse+    . _Wrapped      -- this needed?+    . whilstL parts++type instance Part (Voice a) = Part a+type instance SetPart g (Voice a) = Voice (SetPart g a)++instance (HasParts a b) => HasParts (Voice a) (Voice b) where+  parts =+    _Wrapped+    . traverse+    . _Wrapped      -- this needed?+    . whilstLD parts+
+ src/Music/Score/Phrases.hs view
@@ -0,0 +1,243 @@++{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FunctionalDependencies     #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeOperators              #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-- This module provides phrase-wise traversal.+--+-- /Warning/ This module is experimental.+--+-------------------------------------------------------------------------------------++module Music.Score.Phrases (+    -- * HasPhrases class+    HasPhrases(..),+    HasPhrases',+    phrases,+    phrases',++    -- * Phrase types etc+    Phrase,+    MVoice,+    PVoice,++    -- ** Utility+    mvoicePVoice,+    unsafeMvoicePVoice,+    singleMVoice,+  ) where++import           Control.Applicative+import           Control.Exception   (assert)+import           Control.Lens+import           Control.Monad.Plus+import           Data.AffineSpace+import qualified Data.List           as List+import           Data.Maybe+import           Data.Ord+import           Data.Semigroup++import           Music.Score.Part+import           Music.Score.Convert+import           Music.Time+++-- |+-- For a phrase, we simply use a voice without rests.+--+-- To represent a sequence of phrases we provide two equivalent representations:+--+-- * 'MVoice' is a sequence of notes/chords or rests. All consecutive non-rests consitute a phrase.+--+-- * 'PVoice' is a sequence of phrases or durations.+--+type Phrase a = Voice a++-- |+-- A sequence of phrases or rests, represented as notes or rests.+--+-- Each consecutive sequence of non-rest elements is considered to be a phrase.+-- For an explicit representation of the phrase structure, see 'mvoicePVoice'.+--+type MVoice a = Voice (Maybe a)++-- |+-- A sequence of phrases or rests, represented with explicit phrase structure.+--+type PVoice a = [Either Duration (Phrase a)]+++{-+class HasPhrases a b | a -> b where+  mvoices :: Traversal' a (MVoice b)++instance HasPhrases (MVoice a) a where+  mvoices = id++instance HasPhrases (PVoice a) a where+  -- Note: This is actually OK in 'phrases', as that just becomes (id . each . _Right)+  mvoices = from unsafeMvoicePVoice++instance (HasPart' a, Transformable a, Ord (Part a)) => HasPhrases (Score a) a where+  mvoices = extracted . each . singleMVoice+-}++-- |+-- Classes that provide a phrase traversal.+--+class HasPhrases s t a b | s -> a, t -> b, s b -> t, t a -> s where+  mvoices :: Traversal s t (MVoice a) (MVoice b)++-- | Traverses all phrases in a voice.+instance HasPhrases (MVoice a) (MVoice b) a b where+  mvoices = id++  -- | 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++-- | Traverses all phrases in each voice, using 'extracted'.+instance (HasPart' a, {-HasPart a b, -}{-Transformable a,-} Ord (Part a)) =>+  HasPhrases (Score a) (Score b) a b where+  mvoices = extracted . each . singleMVoice++type HasPhrases' s a = HasPhrases s s a a++{-+Phrase traversal for score:++phrasesS :: (Ord (Part a), HasPart' a, Transformable a) => Traversal' (Score a) (Phrase a)+phrasesS = extracted . each . singleMVoice . mvoicePVoice . each . _Right++More generally:+-}++-- |+-- A simple generic phrase-traversal.+--+phrases' :: HasPhrases' s a => Traversal' s (Phrase a)+phrases' = phrases++-- |+-- A generic phrase-traversal.+--+phrases :: HasPhrases s t a b => Traversal s t (Phrase a) (Phrase b)+phrases = mvoices . mvoicePVoice . each . _Right++-- |+-- View an 'MVoice' as a 'PVoice'.+--+mvoicePVoice :: Lens (MVoice a) (MVoice b) (PVoice a) (PVoice b)+mvoicePVoice = unsafeMvoicePVoice+-- TODO meta++-- |+-- View an 'MVoice' as a 'PVoice' and vice versa.+--+-- This a valid 'Iso' up to meta-data equivalence.+--+unsafeMvoicePVoice :: Iso (MVoice a) (MVoice b) (PVoice a) (PVoice b)+unsafeMvoicePVoice = iso mvoiceToPVoice pVoiceToMVoice+  where+    mvoiceToPVoice :: MVoice a -> PVoice a+    mvoiceToPVoice =+      map ( bimap voiceToRest voiceToPhrase+          . bimap (^.from unsafeEventsV) (^.from unsafeEventsV) )+       . groupDiff' (isJust . snd)+       . view eventsV++    voiceToRest :: MVoice a -> Duration+    voiceToRest = sumOf (eventsV.each._1) . fmap (\x -> assert (isNothing x) x)+    -- TODO just _duration++    voiceToPhrase :: MVoice a -> Phrase a+    voiceToPhrase = fmap fromJust++    pVoiceToMVoice :: (PVoice a) -> MVoice a+    pVoiceToMVoice = mconcat . fmap (either restToVoice phraseToVoice)++    restToVoice :: Duration -> MVoice a+    restToVoice d = stretch d $ pure Nothing++    phraseToVoice :: Phrase a -> MVoice a+    phraseToVoice = fmap Just++++++-- TODO failure+-- TODO why Transformable?+singleMVoice :: {-Transformable a =>-} Prism (Score a) (Score b) (MVoice a) (MVoice b)+singleMVoice = iso scoreToVoice voiceToScore'+  where+    scoreToVoice :: {-Transformable a =>-} Score a -> MVoice a+    scoreToVoice = (^. voice) . fmap (^. stretched) . fmap throwTime . addRests .+      -- TODO+      List.sortBy (comparing (^._1))+      -- end TODO+      . (^. events)+      where+        throwTime (t,d,x) = (d,x)+        addRests = concat . snd . List.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 "singleMVoice: Strange prevTime"++    voiceToScore :: Voice a -> Score a+    voiceToScore = scat . fmap g . (^. stretcheds) where g = (^. stretchedValue) . fmap return++    voiceToScore' :: MVoice a -> Score a+    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)+++-- TODO move++-- |+-- Group contigous sequences matching/not-matching the predicate.+--+-- >>> groupDiff (== 0) [0,1,2,3,5,0,0,6,7]+-- [[0],[1,2,3,5],[0,0],[6,7]]+--+groupDiff :: (a -> Bool) -> [a] -> [[a]]+groupDiff p []     = []+groupDiff p (x:xs)+  | p x       = (x : List.takeWhile p         xs) : groupDiff p (List.dropWhile p         xs)+  | not (p x) = (x : List.takeWhile (not . p) xs) : groupDiff p (List.dropWhile (not . p) xs)++groupDiff' :: (a -> Bool) -> [a] -> [Either [a] [a]]+groupDiff' p []     = []+groupDiff' p (x:xs)+  | not (p x) = Left  (x : List.takeWhile (not . p) xs) : groupDiff' p (List.dropWhile (not . p) xs)+  | p x       = Right (x : List.takeWhile p         xs) : groupDiff' p (List.dropWhile p         xs)+++
src/Music/Score/Pitch.hs view
@@ -1,25 +1,26 @@ -{-# LANGUAGE-    CPP,-    DeriveFunctor,-    DefaultSignatures,-    DeriveFoldable,-    DeriveDataTypeable,-    FlexibleInstances,-    FlexibleContexts,-    ConstraintKinds,-    TypeFamilies,-    TypeOperators,-    MultiParamTypeClasses,-    NoMonomorphismRestriction,-    UndecidableInstances,-    RankNTypes,-    ScopedTypeVariables,-    GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-} + ------------------------------------------------------------------------------------- -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund 2012-2014 -- -- License     : BSD-style --@@ -32,294 +33,495 @@ -------------------------------------------------------------------------------------  -module Music.Score.Pitch (     -        -- * Accessors+module Music.Score.Pitch (+        +        -- * Pitch type functions+        Pitch,+        SetPitch,+        Interval,+        +        -- * Accessing pitch+        HasPitches(..),+        HasPitch(..),+        -- ** Simple versions+        HasPitches',+        HasPitch',         pitch',-        pitch,-        -- pitch_,-        -- pitches',-        -- pitches,--        -- * Transformations-        -- ** Transformations-        inv,--        -- ** Transformations+        pitches',+        +        -- * Converting pitch to container+        fromPitch',+        +        -- * Manipulating pitch+        Transposable,         up,         down,-        fifthsUp,-        fifthsDown,+        above,+        below,+        inv,+        invertPitches,         octavesUp,         octavesDown,--        -- ** Transformations-        -- above,-        -- below,-        fifthsAbove,-        fifthsBelow,         octavesAbove,         octavesBelow,+        fifthsUp,+        fifthsDown,+        fifthsAbove,+        fifthsBelow, -        -- * Pitch representation-        Pitch,-        Interval,-        HasGetPitch(..),-        HasSetPitch(..),-        HasPitch'(..),-        HasPitch(..),-        HasSetPitch'(..),-        Transposable,-        Transposable1,+        -- * Inspecting pitch+        highestPitch,+        lowestPitch,+        meanPitch, -  ) where+        -- * Intervals+        augmentIntervals, -import Control.Monad (ap, mfilter, join, liftM, MonadPlus(..))-import Control.Applicative-import Control.Lens-import Data.Semigroup-import Data.String-import Data.Typeable-import Data.Foldable (Foldable)-import Data.Traversable (Traversable)-import Data.Ratio-import Data.VectorSpace-import Data.AffineSpace-import Data.AffineSpace.Point-import qualified Data.List as List+        -- TODO pitchIs, to write filter pitchIs ... etc+        -- TODO gliss etc -import Music.Time-import Music.Pitch.Literal+  ) where --- This is outside HasGetPitch etc because HasSetPitch needs it--- (and it allow us to derive more instances, see #95)-type family Pitch a+import           Control.Applicative+import           Control.Lens                  hiding (above, below, transform)+import           Control.Monad                 (MonadPlus (..), ap, join, liftM,+                                                mfilter)+import           Data.AffineSpace+import           Data.AffineSpace.Point+import           Data.Foldable                 (Foldable)+import           Data.Functor.Couple+import qualified Data.List                     as List+import           Data.Ratio+import           Data.Semigroup+import           Data.String+import           Data.Traversable              (Traversable)+import           Data.Typeable+import           Data.VectorSpace              hiding (Sum) -type Interval a = Diff (Pitch a)+import           Music.Pitch.Literal+import           Music.Score.Harmonics+import           Music.Score.Part+import           Music.Score.Slide+import           Music.Score.Text+import           Music.Score.Ties+import           Music.Score.Tremolo+import           Music.Score.Phrases+import           Music.Time+import           Music.Time.Internal.Transform  -- |--- Class of types with readable pitch.+-- This type fuction is used to retrive the /pitch type/ for a given concrete type. ---class HasGetPitch s where-  __getPitch :: (a ~ Pitch s) => s -> a+-- For types representing pitch, it is generally 'Identity', i.e+--+-- @+-- Pitch Integer ~ Integer+-- Pitch Double ~ Double+-- @+--+-- and so on.+--+-- For containers, 'Pitch' provides a morphism:+--+-- @+-- '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 :: *) :: *  -- |--- Class of types with mutable pitch.+-- This type fuction is used to retrive the /pitch type/ for a given concrete type. ----- Either 'setPitch' or 'mapPitch' can be implemented. If both are implemented,--- the following laws should be satisfied:+-- For types representing pitch, it is generally 'Constant', i.e ----- > setPitch x = mapPitch (const x)--- > mapPitch f x = setPitch p x where p = f (__getPitch x)+-- @+-- SetPitch a Double ~ a+-- SetPitch a Integer ~ a+-- @ ----- For types that are 'Functors', the following instance can be used+-- For containers, 'Pitch' provides a morphism: ----- > type instance Pitch (T a) = Pitch a--- > instance HasSetPitch a b => HasSetPitch (T a) (T b) where--- >     type SetPitch g (T a) = T (SetPitch g a)--- >     mapPitch = fmap . mapPitch+-- @+-- '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)+-- @ ---class (SetPitch (Pitch t) s ~ t) => HasSetPitch (s :: *) (t :: *) where-  type SetPitch (b :: *) (s :: *) :: *+type family SetPitch (b :: *) (s :: *) :: * -  __setPitch :: Pitch t -> s -> t-  __setPitch x = __mapPitch (const x)-  -  __mapPitch :: (Pitch s -> Pitch t) -> s -> t-  default __mapPitch :: HasGetPitch s => (Pitch s -> Pitch t) -> s -> t-  __mapPitch f x = __setPitch p x where p = f (__getPitch x)-  -type HasPitch s t = (HasGetPitch s, HasSetPitch s t)+-- |+-- Class of types that provide a single pitch.+--+class HasPitches s t => HasPitch s t where +  -- | Access the pitch.+  --+  --   As this is a 'Traversal', you can use all combinators from the lens package,+  --   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 :: Lens s t (Pitch s) (Pitch t)++-- |+-- Class of types that provide a pitch traversal.+--+class (Transformable (Pitch s),+       Transformable (Pitch t),+       SetPitch (Pitch t) s ~ t) => HasPitches s t where++  -- | Access all pitches.+  --+  --   As this is a 'Traversal', you can use all combinators from the lens package,+  --   for example:+  --+  --   @+  --   'lengthOf' 'pitches' :: HasPitches a a => a -> Int+  --   @+  --+  --   @+  --   'toListOf' 'pitches' :: HasPitches' a => a -> Pitch a+  --   @+  --+  --   @+  --   'over' 'pitches' :: HasPitches a b => a -> b+  --   @+  --+  pitches :: Traversal s t (Pitch s) (Pitch t)+ type HasPitch' a = HasPitch a a-type HasSetPitch' a = HasSetPitch a a --- | A lens to the pitch in a note, score or other structure.  +type HasPitches' a = HasPitches a a+++-- |+-- Pitch type. ---pitch' :: HasPitch' a => Lens' a (Pitch a)+pitch' :: (HasPitch s t, s ~ t) => Lens' s (Pitch s) pitch' = pitch+{-# INLINE pitch' #-} --- | A lens to the pitch in a note, score or other structure.  +-- |+-- Pitch type. ---pitch :: HasPitch a b => Lens a b (Pitch a) (Pitch b)-pitch = lens __getPitch (flip __setPitch)+pitches' :: (HasPitches s t, s ~ t) => Traversal' s (Pitch s)+pitches' = pitches+{-# INLINE pitches' #-} --- | A setter to the pitch in a note, score or other structure.  ----pitch_ :: HasSetPitch a b => Setter a b (Pitch a) (Pitch b)-pitch_ = sets __mapPitch --- | Traverses all pitches in structure.  ----pitches' :: (Traversable t, HasPitch' a) => Traversal' (t a) (Pitch a) -pitches' = traverse . pitch'+-- TODO flip name of this and Literal.fromPitch (or call that fromPitchL)+fromPitch' :: (HasPitches' a, IsPitch a) => Pitch a -> a+fromPitch' x = c & pitches' .~ x+{-# INLINE fromPitch' #-} --- | Traverses all pitches in structure.  ----pitches :: (Traversable t, HasPitch a b) => Traversal (t a) (t b) (Pitch a) (Pitch b) -pitches = traverse . pitch +#define PRIM_PITCH_INSTANCE(TYPE)       \+                                        \+type instance Pitch TYPE = TYPE;        \+type instance SetPitch a TYPE = a;      \+                                        \+instance (Transformable a, a ~ Pitch a) \+  => HasPitch TYPE a where {            \+  pitch = ($)              } ;          \+                                        \+instance (Transformable a, a ~ Pitch a) \+  => HasPitches TYPE a where {          \+  pitches = ($)              } ;        \ -type HasPitchConstr a = (-    HasPitch' a, -    VectorSpace (Interval a), Integer ~ Scalar (Interval a),-    AffineSpace (Pitch a)-    ) -newtype PitchT p a = PitchT { __getPitchT :: (p, a) }-    deriving (Eq, Ord, Show, Functor, Foldable, Traversable)+PRIM_PITCH_INSTANCE(())+PRIM_PITCH_INSTANCE(Bool)+PRIM_PITCH_INSTANCE(Ordering)+PRIM_PITCH_INSTANCE(Char)+PRIM_PITCH_INSTANCE(Int)+PRIM_PITCH_INSTANCE(Integer)+PRIM_PITCH_INSTANCE(Float)+PRIM_PITCH_INSTANCE(Double) -instance (Semigroup p, Monoid p) => Applicative (PitchT p) where-    pure x = PitchT (mempty,x)-    PitchT (pf,vf) <*> PitchT (px,vx) = PitchT (pf <> px, vf $ vx) --- TODO move these-instance Stretchable ()-instance Stretchable Double-instance Stretchable Float-instance Stretchable Int-instance Stretchable Integer-instance Integral a => Stretchable (Ratio a)+type instance Pitch (c,a)               = Pitch a+type instance SetPitch b (c,a)          = (c,SetPitch b a)+type instance Pitch [a]                 = Pitch a+type instance SetPitch b [a]            = [SetPitch b a] -instance Delayable ()-instance Delayable Double-instance Delayable Float-instance Delayable Int-instance Delayable Integer-instance Integral a => Delayable (Ratio a)+type instance Pitch (Maybe a)           = Pitch a+type instance SetPitch b (Maybe a)      = Maybe (SetPitch b a)+type instance Pitch (Either c a)        = Pitch a+type instance SetPitch b (Either c a)   = Either c (SetPitch b a) -type instance Pitch (c,a) = Pitch a-instance HasGetPitch a => HasGetPitch (c,a) where-    __getPitch (c,a) = __getPitch a+type instance Pitch (Note a)            = Pitch a+type instance SetPitch b (Note a)       = Note (SetPitch b a)+type instance Pitch (Delayed a)         = Pitch a+type instance SetPitch b (Delayed a)    = Delayed (SetPitch b a)+type instance Pitch (Stretched a)       = Pitch a+type instance SetPitch b (Stretched a)  = Stretched (SetPitch b a) --- Undecidable ??-instance (HasGetPitch a, HasSetPitch a b) => HasSetPitch (c,a) (c,b) where-  type SetPitch b (c,a) = (c,SetPitch b a)-  __setPitch b = fmap (__setPitch b)+type instance Pitch (Voice a)       = Pitch a+type instance SetPitch b (Voice a)  = Voice (SetPitch b a)+type instance Pitch (Chord a)       = Pitch a+type instance SetPitch b (Chord a)  = Chord (SetPitch b a)+type instance Pitch (Track a)       = Pitch a+type instance SetPitch b (Track a)  = Track (SetPitch b a)+type instance Pitch (Score a)       = Pitch a+type instance SetPitch b (Score a)  = Score (SetPitch b a) -#define HAS_PITCH_PRIM(T)   \-type instance Pitch T = T; \-instance HasGetPitch T where { \-    __getPitch = id }-    -#define HAS_SET_PITCH_PRIM(T)   \-instance (a ~ Pitch a) => HasSetPitch T a where { \-    type SetPitch a T = a; \-    __mapPitch = id }+instance HasPitch a b => HasPitch (c, a) (c, b) where+  pitch = _2 . pitch+instance HasPitches a b => HasPitches (c, a) (c, b) where+  pitches = traverse . pitches -HAS_PITCH_PRIM(())-HAS_PITCH_PRIM(Bool)-HAS_PITCH_PRIM(Double)-HAS_PITCH_PRIM(Float)-HAS_PITCH_PRIM(Int)-HAS_PITCH_PRIM(Integer)+instance (HasPitches a b) => HasPitches (Note a) (Note b) where+  pitches = _Wrapped . whilstL pitches+instance (HasPitch a b) => HasPitch (Note a) (Note b) where+  pitch = _Wrapped . whilstL pitch -HAS_SET_PITCH_PRIM(())-HAS_SET_PITCH_PRIM(Bool)-HAS_SET_PITCH_PRIM(Double)-HAS_SET_PITCH_PRIM(Float)-HAS_SET_PITCH_PRIM(Int)-HAS_SET_PITCH_PRIM(Integer)+instance (HasPitches a b) => HasPitches (Delayed a) (Delayed b) where+  pitches = _Wrapped . whilstLT pitches+instance (HasPitch a b) => HasPitch (Delayed a) (Delayed b) where+  pitch = _Wrapped . whilstLT pitch --- type Transposable p i = (Diff p ~ i, AffineSpace p, VectorSpace i, IsPitch p, IsInterval i)-type Transposable a = -        (-            HasSetPitch' a, -            Transposable1 a-        )-type Transposable1 a =-    (-            Diff (Pitch a) ~ Interval a,-            AffineSpace (Pitch a), -            VectorSpace (Interval a),-            IsPitch (Pitch a), -            IsInterval (Interval a)-    )-    +instance (HasPitches a b) => HasPitches (Stretched a) (Stretched b) where+  pitches = _Wrapped . whilstLD pitches+instance (HasPitch a b) => HasPitch (Stretched a) (Stretched b) where+  pitch = _Wrapped . whilstLD pitch +instance HasPitches a b => HasPitches (Maybe a) (Maybe b) where+  pitches = traverse . pitches++instance HasPitches a b => HasPitches (Either c a) (Either c b) where+  pitches = traverse . pitches++instance HasPitches a b => HasPitches [a] [b] where+  pitches = traverse . pitches++instance HasPitches a b => HasPitches (Voice a) (Voice b) where+  pitches = traverse . pitches++instance HasPitches a b => HasPitches (Track a) (Track b) where+  pitches = traverse . pitches++instance HasPitches a b => HasPitches (Chord a) (Chord b) where+  pitches = traverse . pitches++instance (HasPitches a b) => HasPitches (Score a) (Score b) where+  pitches =+    _Wrapped . _2   -- into NScore+    . _Wrapped+    . traverse+    . _Wrapped      -- this needed?+    . whilstL pitches+++type instance Pitch (Sum a) = Pitch a+type instance SetPitch b (Sum a) = Sum (SetPitch b a)++instance HasPitches a b => HasPitches (Sum a) (Sum b) where+  pitches = _Wrapped . pitches++type instance Pitch      (Behavior a) = Behavior a+type instance SetPitch b (Behavior a) = b++instance (Transformable a, Transformable b, b ~ Pitch b) => HasPitches (Behavior a) b where+  pitches = ($)+instance (Transformable a, Transformable b, b ~ Pitch b) => HasPitch (Behavior a) b where+  pitch = ($)+++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+type instance SetPitch g (HarmonicT a)  = HarmonicT (SetPitch g a)+type instance Pitch (TieT a)            = Pitch a+type instance SetPitch g (TieT a)       = TieT (SetPitch g a)+type instance Pitch (SlideT a)          = Pitch a+type instance SetPitch g (SlideT a)     = SlideT (SetPitch g a)++instance (HasPitches a b) => HasPitches (Couple c a) (Couple c b) where+  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+  pitch = _Wrapped . pitch++instance (HasPitches a b) => HasPitches (HarmonicT a) (HarmonicT b) where+  pitches = _Wrapped . pitches+instance (HasPitch a b) => HasPitch (HarmonicT a) (HarmonicT b) where+  pitch = _Wrapped . pitch++instance (HasPitches a b) => HasPitches (TieT a) (TieT b) where+  pitches = _Wrapped . pitches+instance (HasPitch a b) => HasPitch (TieT a) (TieT b) where+  pitch = _Wrapped . pitch++instance (HasPitches a b) => HasPitches (SlideT a) (SlideT b) where+  pitches = _Wrapped . pitches+instance (HasPitch a b) => HasPitch (SlideT a) (SlideT b) where+  pitch = _Wrapped . pitch++ -- |+-- Associated interval type.+--+type Interval a = Diff (Pitch a)++-- |+-- 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))++-- | -- Transpose up. -- up :: Transposable a => Interval a -> a -> a-up a = pitch_ %~ (.+^ a)+up v = pitches %~ (.+^ v)  -- | -- Transpose down. -- down :: Transposable a => Interval a -> a -> a-down a = pitch_ %~ (.-^ a)+down v = pitches %~ (.-^ v)  -- | -- Add the given interval above. -- above :: (Semigroup a, Transposable a) => Interval a -> a -> a-above a x = x <> up a x+above v x = x <> up v x  -- | -- Add the given interval below. -- below :: (Semigroup a, Transposable a) => Interval a -> a -> a-below a x = x <> down a x+below v x = x <> down v x +inv :: Transposable a => Pitch a -> a -> a+inv = invertPitches+{-# DEPRECATED inv "Use 'invertPitches'" #-}+ -- | -- Invert pitches. ---inv :: Transposable a => Pitch a -> a -> a-inv p = pitch_ %~ (reflectThrough p)+invertPitches :: Transposable a => Pitch a -> a -> a+invertPitches p = pitches %~ reflectThrough p  -- | -- Transpose up by the given number of octaves. -- octavesUp :: Transposable a => Scalar (Interval a) -> a -> a-octavesUp a     = up (_P8^*a)+octavesUp n = up (_P8^*n)  -- | -- Transpose down by the given number of octaves. -- octavesDown :: Transposable a => Scalar (Interval a) -> a -> a-octavesDown a   = down (_P8^*a)+octavesDown n = down (_P8^*n)  -- |--- Add the given interval below.+-- Add the given octave above. --+octavesAbove :: (Semigroup a, Transposable a) => Scalar (Interval a) -> a -> a+octavesAbove n = above (_P8^*n)++-- |+-- Add the given octave below.+--+octavesBelow :: (Semigroup a, Transposable a) => Scalar (Interval a) -> a -> a+octavesBelow n = below (_P8^*n)++-- |+-- Transpose up by the given number of fifths.+-- fifthsUp :: Transposable a => Scalar (Interval a) -> a -> a-fifthsUp a     = up (_P8^*a)+fifthsUp n = up (_P8^*n)  -- |--- Add the given interval below.+-- Transpose down by the given number of fifths. -- fifthsDown :: Transposable a => Scalar (Interval a) -> a -> a-fifthsDown a   = down (_P8^*a)+fifthsDown n = down (_P8^*n) +-- |+-- Add the given octave above.+--+fifthsAbove :: (Semigroup a, Transposable a) => Scalar (Interval a) -> a -> a+fifthsAbove n = above (_P8^*n)  -- |--- Add the given interval below.+-- Add the given octave below. ---octavesAbove :: (Semigroup a, Transposable a) => Scalar (Interval a) -> a -> a-octavesAbove n x = x <> octavesUp n x+fifthsBelow :: (Semigroup a, Transposable a) => Scalar (Interval a) -> a -> a+fifthsBelow n = below (_P8^*n) +++ -- |--- Add the given interval below.+-- Return the highest pitch in the given music. ---octavesBelow :: (Semigroup a, Transposable a) => Scalar (Interval a) -> a -> a-octavesBelow n x = x <> octavesUp n x+highestPitch :: (HasPitches' a, Ord (Pitch a)) => a -> Pitch a+highestPitch = maximum . toListOf pitches'  -- |--- Add the given interval below.+-- Return the lowest pitch in the given music. ---fifthsAbove :: (Semigroup a, Transposable a) => Scalar (Interval a) -> a -> a-fifthsAbove n x = x <> fifthsUp n x+lowestPitch :: (HasPitches' a, Ord (Pitch a)) => a -> Pitch a+lowestPitch = maximum . toListOf pitches'  -- |--- Add the given interval below.+-- Return the mean pitch in the given music. ---fifthsBelow :: (Semigroup a, Transposable a) => Scalar (Interval a) -> a -> a-fifthsBelow n x = x <> fifthsUp n x+meanPitch :: (HasPitches' a, Fractional (Pitch a)) => a -> Pitch a+meanPitch = mean . toListOf pitches'+  where+    mean x = fst $ foldl (\(m, n) x -> (m+(x-m)/(n+1),n+1)) (0,0) x -{- -highestPitch = maximum . __getPitches-lowestPitch = maximum . __getPitches-meanPitch = mean . __getPitches-mean x = fst $ foldl (\(m, n) x -> (m+(x-m)/(n+1),n+1)) (0,0) x +augmentIntervals :: (HasPhrases' s a, Transposable a) => Interval a -> s -> s+augmentIntervals x = over phrases (augmentIntervals' x) --}+augmentIntervals' :: Transposable a => Interval a -> Voice a -> Voice a+augmentIntervals' = error "Not implemented: augmentIntervals"+-- TODO generalize to any type where we can traverse phrases of something that has pitch+++-- TODO augment/diminish intervals (requires phrase traversal)+-- TODO rotatePitch (requires phrase traversal)+-- TODO invert diatonically+
− src/Music/Score/Rhythm.hs 
@@ -1,406 +0,0 @@--{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE ViewPatterns               #-}------------------------------------------------------------------------------------------ |--- Copyright   : (c) Hans Hoglund 2012------ License     : BSD-style------ Maintainer  : hans@hanshoglund.se--- Stability   : experimental--- Portability : non-portable (TF,GNTD)-------------------------------------------------------------------------------------------module Music.Score.Rhythm (-        -- * Rhythm type-        Rhythm(..),--        -- * Quantization-        quantize,-        rewrite,-        dotMod,-  ) where--import           Prelude             hiding (concat, concatMap, foldl, foldr,-                                      mapM, maximum, minimum, sum)--import           Control.Applicative-import           Control.Arrow       hiding (left)-import           Control.Monad       (MonadPlus (..), ap, join)-import           Data.Either-import           Data.Foldable-import           Data.Function       (on)-import qualified Data.List           as List-import           Data.Maybe-import           Data.Ord            (comparing)-import           Data.Ratio-import           Data.Semigroup-import           Data.Traversable-import           Data.Tree-import           Data.VectorSpace--import           Text.Parsec         hiding ((<|>))-import           Text.Parsec.Pos--import           Music.Score.Ties-import           Music.Score.Util-import           Music.Score.Voice-import           Music.Time--data Rhythm a-    = Beat       Duration a                    -- d is divisible by 2-    | Group      [Rhythm a]                    ---    | Dotted     Int (Rhythm a)                -- n > 0.-    | Tuplet     Duration (Rhythm a)           -- d is an emelent of 'konstTuplets'.-    deriving (Eq, Show, Functor, Foldable)-    -- RInvTuplet  Duration (Rhythm a)--getBeatValue :: Rhythm a -> a-getBeatValue (Beat d a) = a-getBeatValue _          = error "getBeatValue: Not a beat"--getBeatDuration :: Rhythm a -> Duration-getBeatDuration (Beat d a) = d-getBeatDuration _          = error "getBeatValue: Not a beat"--realize :: Rhythm a -> [(Duration, a)]-realize (Beat d a)      = [(d, a)]-realize (Group rs)      = rs >>= realize-realize (Dotted n r)    = dotMod n `stretch` realize r-realize (Tuplet n r)    = n `stretch` realize r---- rhythmToTree :: Rhythm a -> Tree (String, Maybe a)--- rhythmToTree = go---     where---         go (Beat d a)     = Node ("beat "  ++ showD d, Just a) []---         go (Group rs)     = Node ("group", Nothing) (fmap rhythmToTree rs)---         go (Dotted n r)   = Node ("dotted " ++ show n, Nothing) [rhythmToTree r]---         go (Tuplet n r)   = Node ("tuplet " ++ showD n, Nothing) [rhythmToTree r]---         showD = show . toRational------ drawRhythm :: Show a => Rhythm a -> String--- drawRhythm = drawTree . fmap (uncurry (++) <<< (++ " ") *** show) . rhythmToTree--rhythmToTree :: Rhythm a -> Tree String-rhythmToTree = go-    where-        go (Beat d a)     = Node ("" ++ showD d) []-        go (Group rs)     = Node ("") (fmap rhythmToTree rs)-        go (Dotted n r)   = Node (replicate n '.') [rhythmToTree r]-        go (Tuplet n r)   = Node ("*^ " ++ showD n) [rhythmToTree r]-        showD = (\x -> show (numerator x) ++ "/" ++ show (denominator x)) . toRational--drawRhythm :: Show a => Rhythm a -> String-drawRhythm = drawTree . rhythmToTree--instance Semigroup (Rhythm a) where-    (<>) = mappend---- Catenates using 'Group'-instance Monoid (Rhythm a) where-    mempty = Group []-    Group as `mappend` Group bs   =  Group (as <> bs)-    r        `mappend` Group bs   =  Group ([r] <> bs)-    Group as `mappend` r          =  Group (as <> [r])-    a        `mappend` b          =  Group [a, b]--instance HasDuration (Rhythm a) where-    duration (Beat d _)        = d-    duration (Dotted n a)      = duration a * dotMod n-    duration (Tuplet c a)      = duration a * c-    duration (Group as)        = sum (fmap duration as)--instance AdditiveGroup (Rhythm a) where-    zeroV   = error "No zeroV for (Rhythm a)"-    (^+^)   = error "No ^+^ for (Rhythm a)"-    negateV = error "No negateV for (Rhythm a)"--instance VectorSpace (Rhythm a) where-    type Scalar (Rhythm a) = Duration-    a *^ Beat d x = Beat (a*d) x-    -- FIXME how does this preserve the invariant?--Beat d x `subDur` d' = Beat (d-d') x---{--    Rhythm rewrite laws (all up to realization equality)--    Note: Just sketching, needs more formal treatment.---    Group [Group xs ...] = Group [xs ...]-        [JoinGroup]--    Tuplet m (Tuplet n x) = Tuplet (m * n) x-        [NestTuplet]--    Tuplet m (Group [a,b ...]) = Group [Tuplet m a, Tuplet m b ...]-        [DistributeTuplet]-        This is only OK in certain contexts! Which?---}--rewrite :: Rhythm a -> Rhythm a--rewrite = rewriteR . rewrite1--rewriteR = go where-    go (Beat d a)     = Beat d a-    go (Group rs)     = Group (fmap (rewriteR . rewrite1) rs)-    go (Dotted n r)   = Dotted n ((rewriteR . rewrite1) r)-    go (Tuplet n r)   = Tuplet n ((rewriteR . rewrite1) r)--rewrite1 = splitTuplet . tupletDot . singleGroup---singleGroup :: Rhythm a -> Rhythm a-singleGroup orig@(Group [x]) = x-singleGroup orig             = orig---- | Removes dotted notes in 2/3 tuplets.-tupletDot :: Rhythm a -> Rhythm a-tupletDot orig@(Tuplet ((unRatio.realToFrac) -> (2,3)) (Dotted 1 x)) = x-tupletDot orig                                                       = orig---- | Splits a tuplet iff it contans a group which can be split into two halves of exactly the same size.-splitTuplet :: Rhythm a -> Rhythm a-splitTuplet orig@(Tuplet n (Group xs)) = case trySplit xs of-    Nothing       -> orig-    Just (as, bs) -> Tuplet n (Group as) <> Tuplet n (Group bs)-splitTuplet orig = orig---- TODO bad instance-instance HasDuration a => HasDuration [a] where-    duration = sum . fmap duration--trySplit :: [Rhythm a] -> Maybe ([Rhythm a], [Rhythm a])-trySplit = firstJust . fmap g . splits-    where-        g (part1, part2)-            | duration part1 == duration part2 = Just (part1, part2)-            | otherwise                        = Nothing-        splits xs = List.inits xs `zip` List.tails xs-        firstJust = listToMaybe . fmap fromJust . List.dropWhile isNothing---quantize :: Tiable a => [(Duration, a)] -> Either String (Rhythm a)-quantize = quantize' (atEnd rhythm)--testQuantize :: [Duration] -> IO ()-testQuantize x = case fmap rewrite $ quantize' (atEnd rhythm) $ fmap (\x -> (x,())) $ x of-    Left e -> error e-    Right x -> putStrLn $ drawRhythm x---konstNumDotsAllowed :: [Int]-konstNumDotsAllowed = [1..2]--konstBounds :: [Duration]-konstBounds = [ 1/2, 1/4, 1/8 ]--konstTuplets :: [Duration]-konstTuplets = [ 2/3, 4/5, 4/7, 8/9, 8/11, 8/13, 8/15, 16/17, 16/18, 16/19, 16/21, 16/23 ]--konstMaxTupletNest :: Int-konstMaxTupletNest = 1---data RhythmContext = RhythmContext {--        -- Time scaling of the current note (from dots and tuplets).-        timeMod    :: Duration,--        -- Time subtracted from the current rhythm (from ties).-        timeSub    :: Duration,--        -- Number of tuplets above the current note (default 0).-        tupleDepth :: Int-    }--instance Monoid RhythmContext where-    mempty = RhythmContext { timeMod = 1, timeSub = 0, tupleDepth = 0 }-    a `mappend` _ = a--modifyTimeMod :: (Duration -> Duration) -> RhythmContext -> RhythmContext-modifyTimeMod f (RhythmContext tm ts td) = RhythmContext (f tm) ts td--modifyTimeSub :: (Duration -> Duration) -> RhythmContext -> RhythmContext-modifyTimeSub f (RhythmContext tm ts td) = RhythmContext tm (f ts) td--modifyTupleDepth :: (Int -> Int) -> RhythmContext -> RhythmContext-modifyTupleDepth f (RhythmContext tm ts td) = RhythmContext tm ts (f td)--------- |--- A @RhytmParser a b@ converts (Voice a) to b.-type RhythmParser a b = Parsec [(Duration, a)] RhythmContext b--quantize' :: Tiable a => RhythmParser a b -> [(Duration, a)] -> Either String b-quantize' p = left show . runParser p mempty ""-------rhythm :: Tiable a => RhythmParser a (Rhythm a)-rhythm = Group <$> many1 (rhythm' <|> bound)--rhythmNoBound :: Tiable a => RhythmParser a (Rhythm a)-rhythmNoBound = Group <$> many1 rhythm'--rhythm' :: Tiable a => RhythmParser a (Rhythm a)-rhythm' = mzero-    <|> beat-    <|> dotted-    <|> tuplet---- Matches a beat divisible by 2 (notated)--- beat :: Tiable a => RhythmParser a (Rhythm a)--- beat = do---     RhythmContext tm ts _ <- getState---     (\d -> (d^/tm) `subDur` ts) <$> match (\d _ ->---         d - ts > 0  &&  isDivisibleBy 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)----- | Matches a dotted rhythm-dotted :: Tiable a => RhythmParser a (Rhythm a)-dotted = msum . fmap dotted' $ konstNumDotsAllowed---- | Matches a bound rhythm-bound :: Tiable a => RhythmParser a (Rhythm a)-bound = msum . fmap bound' $ konstBounds---- | Matches a tuplet-tuplet :: Tiable a => RhythmParser a (Rhythm a)-tuplet = msum . fmap tuplet' $ konstTuplets------dotted' :: Tiable a => Int -> RhythmParser a (Rhythm a)-dotted' n = do-    modifyState $ modifyTimeMod (* dotMod n)-    a <- beat-    modifyState $ modifyTimeMod (/ dotMod n)-    return (Dotted n a)---- | Return the scaling applied to a note with the given number of dots (i.e. 3/2, 7/4 etc).-dotMod :: Int -> Duration-dotMod n = dotMods !! (n-1)---- [3/2, 7/4, 15/8, 31/16 ..]-dotMods :: [Duration]-dotMods = zipWith (/) (fmap pred $ drop 2 times2) (drop 1 times2)-    where-        times2 = iterate (*2) 1--bound' :: Tiable a => Duration -> RhythmParser a (Rhythm a)-bound' d = do-    modifyState $ modifyTimeSub (+ d)-    a <- beat-    modifyState $ modifyTimeSub (subtract d)-    let (b,c) = toTied $ getBeatValue a--    -- FIXME doesn't know order-    return $ Group [Beat (getBeatDuration a) b, Beat d c]---- tuplet' 2/3 for triplet, 4/5 for quintuplet etc-tuplet' :: Tiable a => Duration -> RhythmParser a (Rhythm a)-tuplet' d = do-    RhythmContext _ _ depth <- getState-    onlyIf (depth < konstMaxTupletNest) $ do-        modifyState $ modifyTimeMod (* d)-                    . modifyTupleDepth succ-        a <- rhythmNoBound-        modifyState $ modifyTimeMod (/ d)-                    . modifyTupleDepth pred-        return (Tuplet d a)-------------------------------------------------------------------------------------------- | Similar to 'many1', but tries longer sequences before trying one.--- many1long :: Stream s m t => ParsecT s u m a -> ParsecT s u m [a]--- many1long p = try (many2 p) <|> fmap return p---- | Similar to 'many1', but applies the parser 2 or more times.--- many2 :: Stream s m t => ParsecT s u m a -> ParsecT s u m [a]--- many2 p = do { x <- p; xs <- many1 p; return (x : xs) }---- Matches a (duration, value) pair iff the predicate matches, returns beat-match :: Tiable a => (Duration -> a -> Bool) -> RhythmParser a (Rhythm a)-match p = tokenPrim show next test-    where-        show x        = ""-        next pos _ _  = updatePosChar pos 'x'-        test (d,x)    = if p d x then Just (Beat d x) else Nothing---- Matches a (duration, value) pair iff the predicate matches, returns beat-match' :: Tiable a => (Duration -> a -> Maybe (Duration, b)) -> RhythmParser a (Rhythm b)-match' f = tokenPrim show next test-    where-        show x        = ""-        next pos _ _  = updatePosChar pos 'x'-        test (d,x)    = case f d x of-            Nothing     -> Nothing-            Just (d,x)  -> Just $ Beat d x---- |--- Succeed only if the entire input is consumed.----atEnd :: RhythmParser a b -> RhythmParser a b-atEnd p = do-    x <- p-    notFollowedBy' anyToken' <?> "end of input"-    return x-    where-        notFollowedBy' p = try $ (try p >> unexpected "") <|> return ()-        anyToken'        = tokenPrim (const "") (\pos _ _ -> pos) Just--onlyIf :: MonadPlus m => Bool -> m b -> m b-onlyIf b p = if b then p else mzero---- | Just x or Nothing-assuming :: a -> Bool -> Maybe a-assuming x b = if b then Just x else Nothing--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                         = logBase (fromRational k) (fromRational n)---divides     = isDivisibleBy-divisibleBy = flip isDivisibleBy---- As it sounds, do NOT use infix--- Only works for simple n such as 2 or 3, TODO determine-isDivisibleBy :: Duration -> Duration -> Bool-isDivisibleBy n = (== 0.0) . snd . properFraction . logBaseR (toRational n) . toRational---left f (Left x)  = Left (f x)-left f (Right y) = Right y
− src/Music/Score/Score.hs 
@@ -1,296 +0,0 @@--{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE DeriveTraversable          #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE Rank2Types                 #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeOperators              #-}-{-# LANGUAGE UndecidableInstances       #-}-{-# LANGUAGE ViewPatterns               #-}------------------------------------------------------------------------------------------ |--- Copyright   : (c) Hans Hoglund 2012------ License     : BSD-style------ Maintainer  : hans@hanshoglund.se--- Stability   : experimental--- Portability : non-portable (TF,GNTD)------ Provides the 'Score' type.-------------------------------------------------------------------------------------------module Music.Score.Score (-        -- * Score type-        Score,-        notes,-        events,-        -- mkScore,-        -- getScore,-        mapScore,-        -- reifyScore,--        mapWithSpan,-        filterWithSpan,-        mapFilterWithSpan,-        mapEvents,-        filterEvents,-        mapFilterEvents,--  ) where--import           Control.Applicative-import           Control.Arrow-import           Control.Comonad-import           Control.Lens-import           Control.Monad-import           Control.Monad.Compose-import           Control.Monad.Plus-import           Data.Dynamic-import           Data.Foldable          (foldMap)-import           Data.Maybe-import           Data.Ord-import           Data.Semigroup--import           Data.AffineSpace-import           Data.AffineSpace.Point-import           Data.VectorSpace--- import           Test.QuickCheck        (Arbitrary (..), Gen (..))--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.Set               (Set)-import qualified Data.Set               as Set-import           Data.Traversable       (Traversable)-import qualified Data.Traversable       as T-import           Data.Typeable--import           Music.Dynamics.Literal-import           Music.Pitch.Literal-import           Music.Score.Meta-import           Music.Score.Note-import           Music.Score.Part-import           Music.Score.Pitch-import           Music.Score.Util-import           Music.Time-import           Music.Time.Reactive--newtype Score a = Score { getScore' :: (Meta, NScore a) }-    deriving (Functor, Semigroup, Monoid, Foldable, Traversable, Typeable)---- | TODO not a real iso, must be lens (meta)-notes :: Iso (Score a) (Score b) [Note a] [Note b]-notes = iso (getNScore . snd . getScore') (Score . return . NScore)---- | TODO not a real iso, must be lens (meta)-events :: Iso (Score a) (Score b) [(Time, Duration, a)] [(Time, Duration, b)]-events = iso getScore mkScore--inScore f = Score . f . getScore'--mkScore :: [(Time, Duration, a)] -> Score a-mkScore = mconcat . fmap (uncurry3 event)-    where-        event t d x   = (delay (t .-. origin) . stretch d) (return x)--getScore :: Score a -> [(Time, Duration, a)]-getScore =-    fmap (\(view delta -> (t,d),x) -> (t,d,x)) .-    List.sortBy (comparing fst) .-    F.toList .-    fmap getNote .-    reifyScore---- | Map with the associated time span.-mapScore :: (Note a -> b) -> Score a -> Score b-mapScore f = over _Wrapped (second $ mapNScore f)---- | Group each occurence with its associated time span.------ Note: This may or may not be what you expect. Each note is /not/ repositioned--- to start at 'sunit', so this holds------ > fmap extract . reifyScore = id------ while------ > join . fmap (noteToScore) . reifyScore /= id----reifyScore :: Score a -> Score (Note a)-reifyScore = over _Wrapped (second reifyNScore)---- | Map over the events in a score.-mapWithSpan :: (Span -> a -> b) -> Score a -> Score b-mapWithSpan f = mapScore (uncurry f . getNote)---- | Filter the events in a score.-filterWithSpan :: (Span -> a -> Bool) -> Score a -> Score a-filterWithSpan f = mapFilterWithSpan (partial2 f)---- | Efficient combination of 'mapEvents' and 'filterEvents'.-mapFilterWithSpan :: (Span -> a -> Maybe b) -> Score a -> Score b-mapFilterWithSpan f = mcatMaybes . mapWithSpan f---- | Map over the events in a score.-mapEvents :: (Time -> Duration -> a -> b) -> Score a -> Score b-mapEvents f = mapWithSpan (uncurry f . view delta)---- | Filter the events in a score.-filterEvents   :: (Time -> Duration -> a -> Bool) -> Score a -> Score a-filterEvents f = mapFilterEvents (partial3 f)---- | Efficient combination of 'mapEvents' and 'filterEvents'.-mapFilterEvents :: (Time -> Duration -> a -> Maybe b) -> Score a -> Score b-mapFilterEvents f = mcatMaybes . mapEvents f--instance Wrapped (Score a) where-    type Unwrapped (Score a) = (Meta, NScore a)-    _Wrapped' = iso getScore' Score-instance Rewrapped (Score a) (Score b) where--instance Applicative Score where-    pure = return-    (<*>) = ap--instance Monad Score where-    return = (^. _Unwrapped') . return . return-    xs >>= f = (^. _Unwrapped') $ mbind ((^. _Wrapped') . f) ((^. _Wrapped') xs)--instance Alternative Score where-    empty = mempty-    (<|>) = mappend--instance MonadPlus Score where-    mzero = mempty-    mplus = mappend--instance HasOnset (Score a) where-    onset (Score (m,x)) = onset x--instance HasOffset (Score a) where-    offset (Score (m,x)) = offset x--instance Delayable (Score a) where-    delay n (Score (m,x)) = Score (delay n m, delay n x)--instance Stretchable (Score a) where-    stretch n (Score (m,x)) = Score (stretch n m, stretch n x)--instance HasDuration (Score a) where-    duration = durationDefault--instance Reversible a => Reversible (Score a) where-    rev = fmap rev . withSameOnset (stretch (-1))--instance HasMeta (Score a) where-    meta = _Wrapped' . _1------- |--- Score without meta-events.------ Semantics: a list of 'Note'. The semantics of each instances follow the instances of--- the semantics.----newtype NScore a = NScore { getNScore :: [Note a] } -- sorted-    deriving (Functor, Foldable, Semigroup, Monoid, Traversable, Delayable, Stretchable, HasOnset, HasOffset)--inNScore f = NScore . f . getNScore---- | Map with the associated span.-mapNScore :: (Note a -> b) -> NScore a -> NScore b-mapNScore f = inNScore (fmap $ extend f)---- | Reify the associated span. Use with 'Traversable' to get a fold.-reifyNScore :: NScore a -> NScore (Note a)-reifyNScore = inNScore $ fmap duplicate--instance Wrapped (NScore a) where-    type Unwrapped (NScore a) = [Note a]-    _Wrapped' = iso getNScore NScore --instance Applicative NScore where-    pure = return-    (<*>) = ap--instance Monad NScore where-    return = (^. _Unwrapped') . return . return-    xs >>= f = (^. _Unwrapped') $ mbind ((^. _Wrapped') . f) ((^. _Wrapped') xs)--instance MonadPlus NScore where-    mzero = mempty-    mplus = mappend--instance HasDuration (Note a) where-    duration = durationDefault---- The following instances allow us to write expressions like [c..g]--instance IsPitch a => IsPitch (Score a) where-    fromPitch = pure . fromPitch--instance IsDynamics a => IsDynamics (Score a) where-    fromDynamics = pure . fromDynamics--instance IsInterval a => IsInterval (Score a) where-    fromInterval = pure . fromInterval--instance Enum a => Enum (Score a) where-    toEnum = return . toEnum-    fromEnum = list 0 (fromEnum . head) . F.toList---- TODO-instance Num a => Num (Score a) where-    fromInteger = return . fromInteger------ Bogus VectorSpace instance, so we can use c^*2 etc.--- If you hate this instance, please open an issue.--instance AdditiveGroup (Score a) where-    zeroV   = error "Not impl"-    (^+^)   = error "Not impl"-    negateV = error "Not impl"--instance VectorSpace (Score a) where-    type Scalar (Score a) = Duration-    d *^ s = d `stretch` s--type instance Pitch (Score a) = Pitch a-instance (HasSetPitch a b,-            Transformable (Pitch a),-            Transformable (Pitch b)) =>-                HasSetPitch (Score a) (Score b) where-    type SetPitch g (Score a) = Score (SetPitch g a)-    -- TODO really similar to indexed maps-    -- compare lens, category-extras-    __mapPitch f = mapWithSpan (__mapPitch . (`sunder` f))---type instance Part (Score a) = Part a-instance HasPart a => HasPart (Score a) where-    getPart = error "No Score.getPart"-    modifyPart f    = fmap (modifyPart f)----- TODO mo-partial2 :: (a -> b      -> Bool) -> a -> b      -> Maybe b-partial3 :: (a -> b -> c -> Bool) -> a -> b -> c -> Maybe c-partial2 f = curry  (fmap snd  . partial (uncurry f))-partial3 f = curry3 (fmap (view _3) . partial (uncurry3 f))
+ src/Music/Score/Slide.hs view
@@ -0,0 +1,155 @@++{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeOperators              #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-- Provides a representation of musical /slides/, commonly known as /glissando/ or+-- /portamento/. +--+-- /Warning/ This module is experimental.+--+-------------------------------------------------------------------------------------+++module Music.Score.Slide (++        -- * Slides and glissando+        HasSlide(..),+        SlideT(..),+        slide,+        glissando,++  ) where++import           Control.Applicative+import           Control.Comonad+import           Control.Lens            hiding (transform)+import           Data.Foldable+import           Data.Foldable+import           Data.Functor.Couple+import           Data.Ratio+import           Data.Semigroup+import           Data.Typeable+import           Data.Word++import           Music.Dynamics.Literal+import           Music.Pitch.Alterable+import           Music.Pitch.Augmentable+import           Music.Pitch.Literal+import           Music.Score.Part+import           Music.Score.Phrases+import           Music.Time+++class HasSlide a where+    setBeginGliss :: Bool -> a -> a+    setBeginSlide :: Bool -> a -> a+    setEndGliss   :: Bool -> a -> a+    setEndSlide   :: Bool -> a -> a++instance HasSlide a => HasSlide (b, a) where+    setBeginGliss n = fmap (setBeginGliss n)+    setBeginSlide n = fmap (setBeginSlide n)+    setEndGliss   n = fmap (setEndGliss n)+    setEndSlide   n = fmap (setEndSlide n)++instance HasSlide a => HasSlide (Couple b a) where+    setBeginGliss n = fmap (setBeginGliss n)+    setBeginSlide n = fmap (setBeginSlide n)+    setEndGliss   n = fmap (setEndGliss n)+    setEndSlide   n = fmap (setEndSlide n)++instance HasSlide a => HasSlide [a] where+    setBeginGliss n = fmap (setBeginGliss n)+    setBeginSlide n = fmap (setBeginSlide n)+    setEndGliss   n = fmap (setEndGliss n)+    setEndSlide   n = fmap (setEndSlide n)++instance HasSlide a => HasSlide (Score a) where+    setBeginGliss n = fmap (setBeginGliss n)+    setBeginSlide n = fmap (setBeginSlide n)+    setEndGliss   n = fmap (setEndGliss n)+    setEndSlide   n = fmap (setEndSlide n)+++-- (eg,es,a,bg,bs)+newtype SlideT a = SlideT { getSlideT :: Couple ((Any, Any), (Any, Any)) a }+    deriving (Eq, Show, Ord, Functor, Foldable, Typeable, Applicative, Monad, Comonad)++-- | 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++instance Rewrapped (SlideT a) (SlideT b)++_bg, _bs, _eg, _es :: Lens' (SlideT a) Any+_bg = (_Wrapped'._Wrapped') . _1 . _2 . _1+_bs = (_Wrapped'._Wrapped') . _1 . _2 . _2+_eg = (_Wrapped'._Wrapped') . _1 . _1 . _1+_es = (_Wrapped'._Wrapped') . _1 . _1 . _2++instance HasSlide (SlideT a) where+    setBeginGliss x = _bg .~ Any x+    setBeginSlide x = _bs .~ Any x+    setEndGliss   x = _eg .~ Any x+    setEndSlide   x = _es .~ Any x++-- Lifted instances+deriving instance Num a => Num (SlideT a)+deriving instance Fractional a => Fractional (SlideT a)+deriving instance Floating a => Floating (SlideT a)+deriving instance Enum a => Enum (SlideT a)+deriving instance Bounded a => Bounded (SlideT a)+deriving instance (Num a, Ord a, Real a) => Real (SlideT a)+deriving instance (Real a, Enum a, Integral a) => Integral (SlideT a)++-- |+-- Add a slide between the first and the last note.+--+slide :: (HasPhrases' s a, HasSlide a) => s -> s+slide = mapPhraseWise3 (setBeginSlide True) id (setEndSlide True)+  where+    mapPhraseWise3 f g h = over phrases' (over headV f . over middleV g . over lastV h)++-- |+-- Add a glissando between the first and the last note.+--+glissando :: (HasPhrases' s a, HasSlide a) => s -> s+glissando = mapPhraseWise3 (setBeginGliss True) id (setEndGliss True)+  where+    mapPhraseWise3 f g h = over phrases' (over headV f . over middleV g . over lastV h)+++headV :: Traversal' (Voice a) a+headV = (eventsV._head._2)++middleV :: Traversal' (Voice a) a+middleV = (eventsV._middle.traverse._2)++lastV :: Traversal' (Voice a) a+lastV = (eventsV._last._2)++-- Traverse writing to all elements *except* first and last+_middle :: (Snoc s s a a, Cons s s b b) => Traversal' s s+_middle = _tail._init+
+ src/Music/Score/Text.hs view
@@ -0,0 +1,120 @@++{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeOperators              #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-- Provides a way of adding text to notes.+--+-------------------------------------------------------------------------------------+++module Music.Score.Text (++        -- * Text+        HasText(..),+        TextT(..),+        text,++  ) where++import           Control.Applicative+import           Control.Comonad+import           Control.Lens            hiding (transform)+import           Data.Foldable+import           Data.Foldable+import           Data.Functor.Couple+import           Data.Ratio+import           Data.Semigroup+import           Data.Typeable+import           Data.Word++import           Music.Dynamics.Literal+import           Music.Pitch.Alterable+import           Music.Pitch.Augmentable+import           Music.Pitch.Literal+import           Music.Score.Part+import           Music.Score.Phrases+import           Music.Time++++class HasText a where+  addText :: String -> a -> a++newtype TextT a = TextT { getTextT :: Couple [String] a }+  deriving (+    Eq, Show, Ord, Functor, Foldable, Typeable, +    Applicative, Monad, Comonad+    )++instance HasText a => HasText (b, a) where+  addText s = fmap (addText s)++instance HasText a => HasText (Couple b a) where+  addText s = fmap (addText s)++instance HasText a => HasText [a] where+  addText s = fmap (addText s)++instance HasText a => HasText (Score a) where+  addText s = fmap (addText s)+++-- | Unsafe: Do not use 'Wrapped' instances+instance Wrapped (TextT a) where+  type Unwrapped (TextT a) = Couple [String] a+  _Wrapped' = iso getTextT TextT++instance Rewrapped (TextT a) (TextT b)++instance HasText (TextT a) where+    addText      s (TextT (Couple (t,x)))                    = TextT (Couple (t ++ [s],x))++-- Lifted instances+deriving instance Num a => Num (TextT a)+deriving instance Fractional a => Fractional (TextT a)+deriving instance Floating a => Floating (TextT a)+deriving instance Enum a => Enum (TextT a)+deriving instance Bounded a => Bounded (TextT a)+deriving instance (Num a, Ord a, Real a) => Real (TextT a)+deriving instance (Real a, Enum a, Integral a) => Integral (TextT a)++-- |+-- Attach the given text to the first note in the score.+--+text :: (HasPhrases' s a, HasText a) => String -> s -> s+text s = over (phrases'.headV) (addText s)+++headV :: Traversal' (Voice a) a+headV = (eventsV._head._2)++middleV :: Traversal' (Voice a) a+middleV = (eventsV._middle.traverse._2)++lastV :: Traversal' (Voice a) a+lastV = (eventsV._last._2)++-- Traverse writing to all elements *except* first and last+_middle :: (Snoc s s a a, Cons s s b b) => Traversal' s s+_middle = _tail._init+
src/Music/Score/Ties.hs view
@@ -6,12 +6,14 @@ {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE StandaloneDeriving         #-} {-# LANGUAGE TypeFamilies               #-} {-# LANGUAGE TypeOperators              #-}  ------------------------------------------------------------------------------------- -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund 2012-2014 -- -- License     : BSD-style --@@ -19,12 +21,13 @@ -- Stability   : experimental -- Portability : non-portable (TF,GNTD) ----- Provides a representation for tied notes, and a way to split a single note+-- Provides a representation for tied notes, and a class to split a single note -- into a pair of tied notes. -- -------------------------------------------------------------------------------------  module Music.Score.Ties (+         -- * Tiable class         Tiable(..),         TieT(..),@@ -32,28 +35,28 @@         -- * Splitting tied notes in scores         splitTiesVoice,         splitTiesVoiceAt,+   ) where  import           Control.Applicative import           Control.Arrow-import           Control.Lens+import           Control.Comonad+import           Control.Lens            hiding (transform) import           Control.Monad import           Control.Monad.Plus import           Data.AffineSpace import           Data.Default import           Data.Foldable           hiding (concat)+import           Data.Functor.Adjunction (unzipR) import qualified Data.List               as List import           Data.Maybe import           Data.Ratio import           Data.Semigroup import           Data.Typeable-import           Data.VectorSpace+import           Data.VectorSpace        hiding (Sum) -import           Music.Score.Combinators-import           Music.Score.Convert-import           Music.Score.Part-import           Music.Score.Score-import           Music.Score.Voice+import           Music.Dynamics.Literal+import           Music.Pitch.Literal import           Music.Time  -- |@@ -64,59 +67,145 @@ -- Minimal definition: 'toTied', or both 'beginTie' and 'endTie'. -- class Tiable a where-    -- |-    -- Modify a note to be the first note in a tied note pair.-    ---    beginTie :: a -> a-    beginTie = fst . toTied+  -- |+  -- Modify a note to be the first note in a tied note pair.+  --+  beginTie :: a -> a+  beginTie = fst . toTied -    -- |-    -- Modify a note to be the second note in a tied note pair.-    ---    endTie :: a -> a-    endTie = snd . toTied+  -- |+  -- Modify a note to be the second note in a tied note pair.+  --+  endTie :: a -> a+  endTie = snd . toTied -    -- |-    -- Split a single note into a pair of tied notes.-    ---    -- The first returned element should have the original 'onset' and the second-    -- element should have the original 'offset'. Formally-    ---    -- > (onset . fst . toTied) a = onset a-    -- > (offset . snd . toTied) a = offset a-    ---    toTied    :: a -> (a, a)-    toTied a = (beginTie a, endTie a)+  -- |+  -- Split a single note into a pair of tied notes.+  --+  -- The first returned element should have the original 'onset' and the second+  -- element should have the original 'offset'. Formally+  --+  -- > (onset . fst . toTied) a = onset a+  -- > (offset . snd . toTied) a = offset a+  --+  toTied    :: a -> (a, a)+  toTied a = (beginTie a, endTie a)  newtype TieT a = TieT { getTieT :: ((Any, Any), a) }-    deriving (Eq, Ord, Show, Functor, Foldable, Typeable, Applicative, Monad)+  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++instance Rewrapped (TieT a) (TieT b)+ instance Tiable Double      where { beginTie = id ; endTie = id } instance Tiable Float       where { beginTie = id ; endTie = id }+instance Tiable Char        where { beginTie = id ; endTie = id } instance Tiable Int         where { beginTie = id ; endTie = id } instance Tiable Integer     where { beginTie = id ; endTie = id } instance Tiable ()          where { beginTie = id ; endTie = id } instance Tiable (Ratio a)   where { beginTie = id ; endTie = id } +instance Tiable a => Tiable (TieT a) where+  toTied (TieT ((prevTie, nextTie), a))   = (TieT ((prevTie, Any True), b), TieT ((Any True, nextTie), c))+       where (b,c) = toTied a++instance Tiable a => Tiable [a] where+  toTied = unzip . fmap toTied++instance Tiable a => Tiable (Behavior a) where+  toTied = unzipR . fmap toTied++--+-- There is no (HasPart ChordT) instance, so PartT must be outside ChordT in the stack+-- This restriction assures all chord notes are in the same part+--+instance Tiable a => Tiable (c, a) where+  toTied = unzipR . fmap toTied+ instance Tiable a => Tiable (Maybe a) where-    beginTie = fmap beginTie-    endTie   = fmap endTie+  toTied = unzipR . fmap toTied -instance Tiable a => Tiable (TieT a) where-    toTied (TieT ((prevTie, nextTie), a))   = (TieT ((prevTie, Any True), b), TieT ((Any True, nextTie), c))-         where (b,c) = toTied a+instance Tiable a => Tiable (Sum a) where+  toTied = unzipR . fmap toTied +instance Tiable a => Tiable (Product a) where+  toTied = unzipR . fmap toTied++-- Lifted instances++instance IsPitch a => IsPitch (TieT a) where+  fromPitch = pure . fromPitch++instance IsDynamics a => IsDynamics (TieT a) where+  fromDynamics = return . fromDynamics++instance Transformable a => Transformable (TieT a) where+  transform s = fmap (transform s)++instance Reversible a => Reversible (TieT a) where+  rev = fmap rev++instance Num a => Num (TieT a) where+  (+) = liftA2 (+)+  (*) = liftA2 (*)+  (-) = liftA2 (-)+  abs = fmap abs+  signum = fmap signum+  fromInteger = pure . fromInteger++instance Fractional a => Fractional (TieT a) where+  recip        = fmap recip+  fromRational = pure . fromRational++instance Floating a => Floating (TieT a) where+  pi    = pure pi+  sqrt  = fmap sqrt+  exp   = fmap exp+  log   = fmap log+  sin   = fmap sin+  cos   = fmap cos+  asin  = fmap asin+  atan  = fmap atan+  acos  = fmap acos+  sinh  = fmap sinh+  cosh  = fmap cosh+  asinh = fmap asinh+  atanh = fmap atanh+  acosh = fmap acos++instance Enum a => Enum (TieT a) where+  toEnum = pure . toEnum+  fromEnum = fromEnum . extract++instance Bounded a => Bounded (TieT a) where+  minBound = pure minBound+  maxBound = pure maxBound++instance (Num a, Ord a, Real a) => Real (TieT a) where+  toRational = toRational . extract++instance (Real a, Enum a, Integral a) => Integral (TieT a) where+  quot = liftA2 quot+  rem = liftA2 rem+  toInteger = toInteger . extract+ -- | -- Split all notes that cross a barlines into a pair of tied notes. -- splitTiesVoice :: Tiable a => Voice a -> Voice a-splitTiesVoice = (^. voice) . concat . snd . List.mapAccumL g 0 . (^. from voice)-    where-        g t (d, x) = (t + d, occs)-            where-                (_, barTime) = properFraction t-                remBarTime   = 1 - barTime-                occs         = splitDurThen remBarTime 1 (d,x)+splitTiesVoice = (^. voice) . map (^. stretched)+  . concat . snd . List.mapAccumL g 0+  . map (^. from stretched) . (^. stretcheds)+  where+    g t (d, x) = (t + d, occs)+      where+        (_, barTime) = properFraction t+        remBarTime   = 1 - barTime+        occs         = splitDurThen remBarTime 1 (d,x)  -- | -- Split all voice into bars, using the given bar durations. Music that does not@@ -125,17 +214,17 @@ -- Notes that cross a barlines are split into tied notes. -- splitTiesVoiceAt :: Tiable a => [Duration] -> Voice a -> [Voice a]-splitTiesVoiceAt barDurs x = fmap (^. voice) $ splitTiesVoiceAt' barDurs ((^. from voice) x)+splitTiesVoiceAt barDurs x = fmap ((^. voice) . map (^. stretched)) $ splitTiesVoiceAt' barDurs ((map (^. from stretched) . (^. stretcheds)) x)  splitTiesVoiceAt' :: Tiable a => [Duration] -> [(Duration, a)] -> [[(Duration, a)]] splitTiesVoiceAt' []  _  =  [] splitTiesVoiceAt' _  []  =  [] splitTiesVoiceAt' (barDur : rbarDur) occs = case splitDurFor barDur occs of-    (barOccs, [])       -> barOccs : []-    (barOccs, restOccs) -> barOccs : splitTiesVoiceAt' rbarDur restOccs+  (barOccs, [])       -> barOccs : []+  (barOccs, restOccs) -> barOccs : splitTiesVoiceAt' rbarDur restOccs  tsplitTiesVoiceAt :: [Duration] -> [Duration] -> [[(Duration, Char)]]-tsplitTiesVoiceAt barDurs = fmap (^. from voice) . splitTiesVoiceAt barDurs . (^. voice) . fmap (\x -> (x,'_'))+tsplitTiesVoiceAt barDurs = fmap (map (^. from stretched) . (^. stretcheds)) . splitTiesVoiceAt barDurs . ((^. voice) . map (^. stretched)) . fmap (\x -> (x,'_'))  -- | -- Split an event into one chunk of the duration @s@, followed parts shorter than duration @t@.@@ -146,8 +235,8 @@ -- splitDurThen :: Tiable a => Duration -> Duration -> (Duration, a) -> [(Duration, a)] splitDurThen s t x = case splitDur s x of-    (a, Nothing) -> [a]-    (a, Just b)  -> a : splitDurThen t t b+  (a, Nothing) -> [a]+  (a, Just b)  -> a : splitDurThen t t b   -- |@@ -165,17 +254,17 @@ splitDurFor :: Tiable a => Duration -> [(Duration, a)] -> ([(Duration, a)], [(Duration, a)]) splitDurFor remDur []       = ([], []) splitDurFor remDur (x : xs) = case splitDur remDur x of-    (x@(d,_), Nothing)   ->-        if d < remDur then-            first (x:) $ splitDurFor (remDur - d) xs-        else -- d == remDur-            ([x], xs)-    (x@(d,_), Just rest) -> ([x], rest : xs)+  (x@(d,_), Nothing)   ->+      if d < remDur then+          first (x:) $ splitDurFor (remDur - d) xs+      else -- d == remDur+          ([x], xs)+  (x@(d,_), Just rest) -> ([x], rest : xs)  tsplitDurFor :: Duration -> [Duration] -> ([(Duration,Char)], [(Duration,Char)]) tsplitDurFor maxDur xs = splitDurFor maxDur $ fmap (\x -> (x,'_')) xs-instance Tiable Char where-    toTied _ = ('(',')')+-- instance Tiable Char where+  -- toTied _ = ('(',')')  -- | -- Split a note if it is longer than the given duration. Returns the first part of the@@ -185,10 +274,7 @@ -- splitDur :: Tiable a => Duration -> (Duration, a) -> ((Duration, a), Maybe (Duration, a)) splitDur maxDur (d,a)-    | maxDur <= 0 = error "splitDur: maxDur must be > 0"-    | d <= maxDur =  ((d, a), Nothing)-    | d >  maxDur =  ((maxDur, b), Just (d - maxDur, c)) where (b,c) = toTied a---+  | maxDur <= 0 = error "splitDur: maxDur must be > 0"+  | d <= maxDur =  ((d, a), Nothing)+  | d >  maxDur =  ((maxDur, b), Just (d - maxDur, c)) where (b,c) = toTied a
− src/Music/Score/Track.hs 
@@ -1,168 +0,0 @@--{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE DeriveTraversable          #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeOperators              #-}-{-# LANGUAGE UndecidableInstances       #-}------------------------------------------------------------------------------------------ |--- Copyright   : (c) Hans Hoglund 2012------ License     : BSD-style------ Maintainer  : hans@hanshoglund.se--- Stability   : experimental--- Portability : non-portable (TF,GNTD)------ Provides the 'Track' type.-------------------------------------------------------------------------------------------module Music.Score.Track (-        -- * Track type-        Track,-        track',-        track,-        -- mkTrack,-        -- getTrack,-  ) where--import           Control.Applicative-import           Control.Arrow-import           Control.Lens-import           Control.Monad-import           Control.Monad.Compose-import           Data.AffineSpace.Point-import           Data.Foldable          (Foldable (..), foldMap)-import qualified Data.Foldable          as F-import qualified Data.List              as List-import           Data.PairMonad         ()-import           Data.Semigroup-import           Data.Traversable       (Traversable (..))-import qualified Data.Traversable       as T-import           Data.Typeable-import           Data.VectorSpace       hiding (Sum)--- import           Test.QuickCheck        (Arbitrary (..), Gen (..))--import           Music.Dynamics.Literal-import           Music.Pitch.Literal-import           Music.Score.Pitch-import           Music.Score.Util-import           Music.Time---- |--- A track is a list of events with explicit onset.------ Track is a 'Monoid' under parallel composition. 'mempty' is the empty track--- and 'mappend' interleaves values.------ Track is a 'Monad'. 'return' creates a track containing a single value at time--- zero, and '>>=' transforms the values of a track, allowing the addition and--- removal of values relative to the time of the value. Perhaps more intuitively,--- 'join' delays each inner track to start at the offset of an outer track, then--- removes the intermediate structure.------ > let t = Track [(0, 65),(1, 66)]--- >--- > t >>= \x -> Track [(0, 'a'), (10, toEnum x)]--- >--- >   ==> Track {getTrack = [ (0.0,  'a'),--- >                           (1.0,  'a'),--- >                           (10.0, 'A'),--- >                           (11.0, 'B') ]}------ Track is an instance of 'VectorSpace' using parallel composition as addition,--- and time scaling as scalar multiplication.----newtype Track a = Track { getTrack' :: [Occ a] }-    deriving (Eq, Ord, Show, Functor, Foldable, Typeable, Traversable, Monoid, Semigroup, Delayable, Stretchable)--{--instance Semigroup (Track a) where-    (<>) = mappend---- Equivalent to the derived Monoid, except for the sorted invariant.-instance Monoid (Track a) where-    mempty = Track []-    Track as `mappend` Track bs = Track (as `m` bs)-        where-            m = mergeBy (comparing fst)--}--instance Wrapped (Track a) where-    type Unwrapped (Track a) = [Occ a]-    _Wrapped' = iso getTrack' Track--instance Applicative Track where-    pure  = return-    (<*>) = ap--instance Monad Track where-    return = (^. _Unwrapped') . return . return-    xs >>= f = (^. _Unwrapped') $ mbind ((^. _Wrapped') . f) ((^. _Wrapped') xs)--instance Alternative Track where-    empty = mempty-    (<|>) = mappend--instance MonadPlus Track where-    mzero = mempty-    mplus = mappend--instance HasOnset (Track a) where-    onset (Track a) = list origin (onset . head) a--instance IsPitch a => IsPitch (Track a) where-    fromPitch = pure . fromPitch--instance IsDynamics a => IsDynamics (Track a) where-    fromDynamics = pure . fromDynamics--instance IsInterval a => IsInterval (Track a) where-    fromInterval = pure . fromInterval--type instance Pitch (Track a) = Pitch a-instance (HasSetPitch a b, Transformable (Pitch (Track a)), Transformable (Pitch (Track b))) => HasSetPitch (Track a) (Track b) where-    type SetPitch g (Track a) = Track (SetPitch g a)-    -- FIXME this is wrong, need to behave like __mapPitch'-    __mapPitch f   = fmap (__mapPitch f)----- |--- Create a voice from a list of occurences.----track' :: Iso' [(Time, a)] (Track a)-track' = track---- |--- Create a voice from a list of occurences.----track :: Iso [(Time, a)] [(Time, b)] (Track a) (Track b)-track = iso mkTrack getTrack-    where-        mkTrack = Track . fmap (uncurry occ . first (fmap realToFrac))-        getTrack = fmap (first (fmap realToFrac) . getOcc) . getTrack'----newtype Occ a = Occ (Sum Time, a)-    deriving (Eq, Ord, Show, {-Read, -}Functor, Applicative, Monad, Foldable, Traversable)--occ t x = Occ (Sum t, x)-getOcc (Occ (Sum t, x)) = (t, x)--instance Delayable (Occ a) where-    delay n (Occ (s,x)) = Occ (delay n s, x)-instance Stretchable (Occ a) where-    stretch n (Occ (s,x)) = Occ (stretch n s, x)-instance HasOnset (Occ a) where-    onset (Occ (s,x)) = onset s-
+ src/Music/Score/Tremolo.hs view
@@ -0,0 +1,106 @@++{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeOperators              #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-- Provides a representation for tremolo, i.e. rapid iterations of a note.+--+-------------------------------------------------------------------------------------+++module Music.Score.Tremolo (++        -- * Tremolo+        HasTremolo(..),+        TremoloT(..),+        tremolo,++  ) where++import           Control.Applicative+import           Control.Comonad+import           Control.Lens            hiding (transform)+import           Data.Foldable+import           Data.Foldable+import           Data.Functor.Couple+import           Data.Ratio+import           Data.Semigroup+import           Data.Typeable+import           Data.Word++import           Music.Dynamics.Literal+import           Music.Pitch.Alterable+import           Music.Pitch.Augmentable+import           Music.Pitch.Literal+import           Music.Score.Part+import           Music.Score.Phrases+import           Music.Time++class HasTremolo a where+  setTrem :: Int -> a -> a++instance HasTremolo a => HasTremolo (b, a) where+  setTrem n = fmap (setTrem n)++instance HasTremolo a => HasTremolo (Couple b a) where+  setTrem n = fmap (setTrem n)++instance HasTremolo a => HasTremolo [a] where+  setTrem n = fmap (setTrem n)++instance HasTremolo a => HasTremolo (Score a) where+  setTrem n = fmap (setTrem n)++++newtype TremoloT a = TremoloT { getTremoloT :: Couple (Max Word) a }+    deriving (Eq, Show, Ord, Functor, Foldable, Typeable, Applicative, Monad, Comonad)+--+-- We use Word instead of Int to get (mempty = Max 0), as (Max.mempty = Max minBound)+-- 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++instance Rewrapped (TremoloT a) (TremoloT b)++instance HasTremolo (TremoloT a) where+  setTrem n = set (_Wrapped . _Wrapped . _1) (Max $ fromIntegral n)++-- Lifted instances+deriving instance Num a => Num (TremoloT a)+deriving instance Fractional a => Fractional (TremoloT a)+deriving instance Floating a => Floating (TremoloT a)+deriving instance Enum a => Enum (TremoloT a)+deriving instance Bounded a => Bounded (TremoloT a)+deriving instance (Num a, Ord a, Real a) => Real (TremoloT a)+deriving instance (Real a, Enum a, Integral a) => Integral (TremoloT a)++-- |+-- Set the number of tremolo divisions for all notes in the score.+--+tremolo :: HasTremolo a => Int -> a -> a+tremolo = setTrem+
− src/Music/Score/Util.hs 
@@ -1,384 +0,0 @@---{-# LANGUAGE ViewPatterns #-}--module Music.Score.Util where------------------------------------------------------------------------------ File generated by hackette. Do not edit!------ Fetched by hans on Sön  9 Mar 2014 14:52:14 CET------------------------------------------------------------------------------{-# LANGUAGE ViewPatterns #-}--{--    Rules:-    -        * Functions may depend on any module in the lastest Haskell Platform release-        * All functions but those in Prelude must be referred to with their full,-          qualified names (i.e. Data.List.unfoldr).-        * Each function must have a unique name (so the whole file is a loadable module).-        * Each function should have a synopisis, like:--            -- | Ordinary Haddock commentary ...-            -- > category: Categories (please use the common Hackage names)-            -- > depends : base (all packages in HP that the function depends on)-            --}--import qualified Data.Char-import qualified Data.Monoid-import qualified Data.List-import qualified Data.Ratio---- | Synonym for 'Data.Char.toUpper'--- > category : String--- > depends : base-toUpperChar :: Char -> Char-toUpperChar = Data.Char.toUpper---- | Synonym for 'Data.Char.toLower'--- > category : String--- > depends : base-toLowerChar :: Char -> Char-toLowerChar = Data.Char.toLower---- | Synonym for 'fmap Data.Char.toUpper'--- > category : String--- > depends : base-toUpperString :: String -> String-toUpperString = fmap Data.Char.toUpper---- | Synonym for 'fmap Data.Char.toLower'--- > category : String--- > depends : base-toLowerString :: String -> String-toLowerString = fmap Data.Char.toLower---- | Convert a string to use upper case for the leading letter and lower case for remaining letters.--- > category : String--- > depends : base-toCapitalString :: String -> String-toCapitalString [] = []-toCapitalString (x:xs) = toUpperChar x : toLowerString xs---- | Synonym for '(++)'--- > category : List--- > depends : base-withPrefix :: [a] -> [a] -> [a]-withPrefix x = (x ++)---- | Synonym for 'flip (++)'--- > category : List--- > depends : base-withSuffix :: [a] -> [a] -> [a]-withSuffix x = (++ x)---- | Separate a list by the given element. Equivalent to 'Data.List.intersperse'.--- > category : List--- > depends : base-sep :: a -> [a] -> [a]-sep = Data.List.intersperse---- | Initiate and separate a list by the given element.--- > category : List--- > depends : base-pre :: a -> [a] -> [a]-pre x = (x :) . sep x---- | Separate and terminate a list by the given element.--- > category : List--- > depends : base-post :: a -> [a] -> [a]-post x = withSuffix [x] . sep x---- | Separate and terminate a list by the given element.--- > category : List--- > depends : base-wrap :: a -> a -> [a] -> [a]-wrap x y = (x :) . withSuffix [y] . sep x---- | Combination of 'concat' and 'sep'.  Equivalent to 'Data.List.intercalate'.--- > category : List--- > depends : base-concatSep :: [a] -> [[a]] -> [a]-concatSep x = concat . sep x---- | Combination of 'concat' and 'pre'.--- > category : List--- > depends : base-concatPre :: [a] -> [[a]] -> [a]-concatPre x = concat . pre x---- | Combination of 'concat' and 'post'.--- > category : List--- > depends : base-concatPost :: [a] -> [[a]] -> [a]-concatPost x = concat . post x---- | Combination of 'concat' and 'wrap'.--- > category : List--- > depends : base-concatWrap :: [a] -> [a] -> [[a]] -> [a]-concatWrap x y = concat . wrap x y---- | Divide a list into parts of maximum length n.--- > category : List--- > depends : base-divideList :: Int -> [a] -> [[a]]-divideList n xs-    | length xs <= n = [xs]-    | otherwise = [take n xs] ++ (divideList n $ drop n xs)---- | Group a list into sublists whereever a predicate holds. The matched element---   is the first in the sublist.------   > splitWhile isSpace "foo bar baz"---   >    ===> ["foo"," bar"," baz"]---   >---   > splitWhile (> 3) [1,5,4,7,0,1,2]---   >    ===> [[1],[5],[4],[7,0,1,2]]------ > category : List--- > depends : base-splitWhile :: (a -> Bool) -> [a] -> [[a]]-splitWhile p xs = case splitWhile' p xs of-    []:xss -> xss-    xss    -> xss-    where-        splitWhile' p []     = [[]]-        splitWhile' p (x:xs) = case splitWhile' p xs of-            (xs:xss) -> if p x then []:(x:xs):xss else (x:xs):xss----- | Break up a list into parts of maximum length n, inserting the given list as separator.---   Useful for breaking up strings, as in @breakList 80 "\n" str@.------ > category : List--- > depends : base-breakList :: Int -> [a] -> [a] -> [a]-breakList n z = Data.Monoid.mconcat . Data.List.intersperse z . divideList n---- | Map over the indices and elements of list.--- > category : List--- > depends : base-mapIndexed :: (Int -> a -> b) -> [a] -> [b]-mapIndexed f as = map (uncurry f) (zip is as)-    where-        n  = length as - 1-        is = [0..n]-        --- test---- | Duplicate an element.--- > category: Combinator, Tuple--- > depends: base-dup :: a -> (a,a)-dup x = (x,x)---- | Unfold a partial function. This is a simpler version of 'Data.List.unfoldr'. --- > category: Function, List--- > depends: base-unf :: (a -> Maybe a) -> a -> [a]-unf f = Data.List.unfoldr (fmap dup . f)---- |--- Map over first elements of a list.--- Biased on first element for shorter lists.--- > category: List--- > depends: base-mapF f = mapFTL f id id---- |--- Map over all but the first and last elements of a list.--- Biased on middle elements for shorter lists.--- > category: List--- > depends: base-mapT f = mapFTL id f id---- |--- Map over last elements of a list.--- Biased on last element for shorter lists.--- > category: List--- > depends: base-mapL f = mapFTL id id f---- |--- Map over first, middle and last elements of list.--- Biased on first, then on first and last for short lists.------ > category: List--- > depends: base-mapFTL :: (a -> b) -> (a -> b) -> (a -> b) -> [a] -> [b]-mapFTL f g h = go-    where-        go []    = []-        go [a]   = [f a]-        go [a,b] = [f a, h b]-        go xs    = [f $ head xs]          ++ -                   map g (tail $ init xs) ++ -                   [h $ last xs]---- |--- Extract the first consecutive sublist for which the predicate returns true, or--- the empty list if no such sublist exists.--- > category: List--- > depends: base-filterOnce :: (a -> Bool) -> [a] -> [a]-filterOnce p = Data.List.takeWhile p . Data.List.dropWhile (not . p)----- | Returns all rotations of the given list. Given an infinite list, returns an infinite--- list of rotated infinite lists.--- > category: List--- > depends: base-rots :: [a] -> [[a]]-rots xs = init (zipWith (++) (Data.List.tails xs) (Data.List.inits xs))---- |--- > category: List--- > depends: base-rotl :: [a] -> [a]-rotl []     = []-rotl (x:xs) = xs ++ [x]---- |--- > category: List--- > depends: base-rotr :: [a] -> [a]-rotr [] = []-rotr xs = last xs : init xs---- |--- > category: List--- > depends: base-rotated :: Int -> [a] -> [a]-rotated = go-    where-        go n as -            | n >= 0 = iterate rotr as !! n-            | n <  0 = iterate rotl as !! abs n---curry3 :: ((a, b, c) -> d) -> a -> b -> c -> d-curry3 = curry . curry . (. tripl)--uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d-uncurry3 = (. untripl) . uncurry . uncurry--untripl :: (a,b,c) -> ((a,b),c)-untripl (a,b,c) = ((a,b),c)--tripl :: ((a,b),c) -> (a,b,c)-tripl ((a,b),c) = (a,b,c)--tripr :: (a,(b,c)) -> (a,b,c)-tripr (a,(b,c)) = (a,b,c)---- | Case matching on lists.--- > category: List--- > depends: base-list :: r -> ([a] -> r) -> [a] -> r-list z f [] = z-list z f xs = f xs---- | Merge lists.--- > category: List--- > depends: base-merge :: Ord a => [a] -> [a] -> [a]-merge = mergeBy compare---- | Merge lists.--- > category: List--- > depends: base-mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a]-mergeBy f = mergeBy' $ (fmap.fmap) orderingToBool f-    where-        orderingToBool LT = True-        orderingToBool EQ = True-        orderingToBool GT = False--mergeBy' :: (a -> a -> Bool) -> [a] -> [a] -> [a]-mergeBy' pred xs []         = xs-mergeBy' pred [] ys         = ys-mergeBy' pred (x:xs) (y:ys) =-    case pred x y of-        True  -> x: mergeBy' pred xs (y:ys)-        False -> y: mergeBy' pred (x:xs) ys---- | Compose all functions.--- > category: Function--- > depends: base-composed :: [b -> b] -> b -> b-composed = Prelude.foldr (.) id---- | Separate a ratio.--- > category: Math--- > depends: base-unRatio :: Integral a => Data.Ratio.Ratio a -> (a, a)-unRatio x = (Data.Ratio.numerator x, Data.Ratio.denominator x)---- | Nicer printing of ratio as ordinary fractions.--- > category: Math--- > depends: base-showRatio :: (Integral a, Show a) => Data.Ratio.Ratio a -> String-showRatio (realToFrac -> (unRatio -> (x, 1))) = show x-showRatio (realToFrac -> (unRatio -> (x, y))) = "(" ++ show x ++ "/" ++ show y ++ ")"----- Replace all contigous ranges of equal values with [Just x, Nothing, Nothing ...]--- > category: List--- > depends: base-retainUpdates :: Eq a => [a] -> [Maybe a]-retainUpdates = snd . Data.List.mapAccumL g Nothing where-    g Nothing  x = (Just x, Just x)-    g (Just p) x = (Just x, if p == x then Nothing else Just x)----- Generic version of 'replicate'.--- > category: List--- > depends: base-replic :: Integral a => a -> b -> [b]-replic n = replicate (fromIntegral n)---- Swap components.--- > category: Tuple--- > depends: base-swap :: (a, b) -> (b, a)-swap (x, y) = (y, x)---- Interleave a list with the next consecutive element.------ For any xs------ > lenght xs == length (withNext xs)------ If @xs@ is a finite list------ > isNothing  $ snd $ last $ withNext xs == True--- > all isJust $ snd $ init $ withNext xs == True------ If @xs@ is an infinite list------ > all isJust $ snd $ withNext xs == True------ > category: List--- > depends: base-withNext :: [a] -> [(a, Maybe a)]-withNext = go-    where-        go []       = []-        go [x]      = [(x, Nothing)]-        go (x:y:rs) = (x, Just y) : withNext (y : rs)---- Map over a list with the next consecutive element.------ > category: List--- > depends: base-mapWithNext :: (a -> Maybe a -> b) -> [a] -> [b]-mapWithNext f = fmap (uncurry f) . withNext
− src/Music/Score/Voice.hs 
@@ -1,183 +0,0 @@--{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE DeriveTraversable          #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeOperators              #-}-{-# LANGUAGE UndecidableInstances       #-}------------------------------------------------------------------------------------------ |--- Copyright   : (c) Hans Hoglund 2012------ License     : BSD-style------ Maintainer  : hans@hanshoglund.se--- Stability   : experimental--- Portability : non-portable (TF,GNTD)------ Provides the 'Voice' type.-------------------------------------------------------------------------------------------module Music.Score.Voice (-        -- * Voice type-        Voice,-        voice',-        voice,--        zipVoice,-        zipVoiceWith,-        dzipVoiceWith,-        mergeEqual,-  ) where--import           Control.Applicative-import           Control.Arrow-import           Control.Lens-import           Control.Monad-import           Control.Monad.Compose-import           Data.Semigroup--import           Data.Foldable          (Foldable (..), foldMap)-import qualified Data.Foldable          as F-import qualified Data.List              as List-import           Data.PairMonad         ()-import           Data.Traversable       (Traversable (..))-import qualified Data.Traversable       as T-import           Data.Typeable-import           Data.VectorSpace       hiding (Sum)--import           Music.Dynamics.Literal-import           Music.Pitch.Literal-import           Music.Score.Pitch-import           Music.Score.Util-import           Music.Time----- |--- A voice is a list of events with explicit duration. Events can not overlap.------ Voice is a 'Monoid' under sequential composition. 'mempty' is the empty part and 'mappend'--- appends parts.------ Voice is a 'Monad'. 'return' creates a part containing a single value of duration--- one, and '>>=' transforms the values of a part, allowing the addition and--- removal of values under relative duration. Perhaps more intuitively, 'join' scales--- each inner part to the duration of the outer part, then removes the--- intermediate structure.------ > let p = Voice [(1, Just 0), (2, Just 1)] :: Voice Int--- >--- > p >>= \x -> Voice [ (1, Just $ toEnum $ x+65),--- >                    (3, Just $ toEnum $ x+97) ] :: Voice Char--- >--- >     ===> Voice {getVoice = [ (1 % 1,Just 'A'),--- >                            (3 % 1,Just 'a'),--- >                            (2 % 1,Just 'B'),--- >                            (6 % 1,Just 'b') ]}------ Voice is a 'VectorSpace' using sequential composition as addition, and time scaling--- as scalar multiplication.----newtype Voice a = Voice { getVoice' :: [Ev a] }-    deriving (Eq, Ord, Show, Functor, Foldable, Monoid, Semigroup, Typeable, Traversable, Stretchable)---instance Wrapped (Voice a) where-    type Unwrapped (Voice a) = [Ev a]-    _Wrapped' = iso getVoice' Voice--instance Applicative Voice where-    pure  = return-    (<*>) = ap--instance Monad Voice where-    return = (^. _Unwrapped') . return . return-    xs >>= f = (^. _Unwrapped') $ ((^. _Wrapped') . f) `mbind` ((^. _Wrapped') xs)--instance HasDuration (Voice a) where-    duration = sum . fmap duration . getVoice'--instance IsPitch a => IsPitch (Voice a) where-    fromPitch = pure . fromPitch--instance IsDynamics a => IsDynamics (Voice a) where-    fromDynamics = pure . fromDynamics--instance IsInterval a => IsInterval (Voice a) where-    fromInterval = pure . fromInterval---- TODO-instance Num a => Num (Voice a) where-    fromInteger = pure . fromInteger--type instance Pitch (Voice a) = Pitch a-instance (HasSetPitch a b, Transformable (Pitch a), Transformable (Pitch b)) => HasSetPitch (Voice a) (Voice b) where-    type SetPitch g (Voice a) = Voice (SetPitch g a)-    -- FIXME this is wrong, need to behave like __mapPitch'-    __mapPitch f   = fmap (__mapPitch f)---- |--- Create a voice from a list of events.----voice' :: Iso' [(Duration, a)] (Voice a)-voice' = voice---- |--- Create a voice from a list of events.----voice :: Iso [(Duration, a)] [(Duration, b)] (Voice a) (Voice b)-voice = iso mkVoice getVoice-    where-        mkVoice = Voice . fmap (uncurry ev . first realToFrac)-        getVoice = fmap (first realToFrac . getEv) . getVoice'---- |--- Join the given voices by multiplying durations and pairing values.----zipVoice :: Voice a -> Voice b -> Voice (a, b)-zipVoice = zipVoiceWith (,)---- |--- Join the given voices by multiplying durations and combining values using the given function.----zipVoiceWith :: (a -> b -> c) -> Voice a -> Voice b -> Voice c-zipVoiceWith f (Voice a) (Voice b) = Voice $ zipWith (\(Ev (dx,vx)) (Ev (dy,vy)) -> Ev (dx <> dy, f vx vy)) a b---- |--- Join the given voices by combining durations and values using the given function.----dzipVoiceWith :: (Duration -> Duration -> a -> b -> (Duration, c)) -> Voice a -> Voice b -> Voice c-dzipVoiceWith f (Voice a) (Voice b) = Voice $ zipWith (\(Ev (Product dx,vx)) (Ev (Product dy,vy)) -> Ev (first Product $ f dx dy vx vy)) a b---- |--- Merge consecutive equal note.----mergeEqual :: Eq a => Voice a -> Voice a-mergeEqual = over (from voice) $ fmap f . List.groupBy (inspecting snd)-    where-        f dsAs = let (ds,as) = unzip dsAs in (sum ds, head as)--inspecting :: Eq a => (b -> a) -> b -> b -> Bool-inspecting p x y = p x == p y--newtype Ev a = Ev (Product Duration, a)-    deriving (Eq, Ord, Show, {-Read, -}Functor, Applicative, Monad, Foldable, Traversable)--ev t x = Ev (Product t, x)-getEv (Ev (Product t, x)) = (t, x)--instance Stretchable (Ev a) where-    stretch n (Ev (s,x)) = Ev (stretch n s, x)--instance HasDuration (Ev a) where-    duration (Ev (s,x)) = duration s--
src/Music/Time.hs view
@@ -1,7 +1,7 @@  ------------------------------------------------------------------------------------- -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund 2012-2014 -- -- License     : BSD-style --@@ -14,27 +14,55 @@ -------------------------------------------------------------------------------------  module Music.Time (-        module Music.Time.Time,-        module Music.Time.Span,+        -- * Prerequisites+    module Data.Functor.Rep.Lens, -        module Music.Time.Delayable,-        module Music.Time.Stretchable,-        module Music.Time.Onset,+    -- * Basic types+    module Music.Time.Types, -        module Music.Time.Juxtapose,-        module Music.Time.Reverse,-        module Music.Time.Reactive,-        module Music.Time.Behavior+    -- * Time transformations+    module Music.Time.Transform,+    module Music.Time.Duration,+    module Music.Time.Position,+    module Music.Time.Split,+    module Music.Time.Reverse,+    module Music.Time.Juxtapose,+    module Music.Time.Rest,++    -- * Time types+    -- ** Discrete time+    module Music.Time.Stretched,+    module Music.Time.Delayed,+    module Music.Time.Note,+    module Music.Time.Voice,+    module Music.Time.Chord,+    module Music.Time.Track,+    module Music.Time.Score,+    -- ** Continous time+    module Music.Time.Segment,+    module Music.Time.Behavior,+    module Music.Time.Reactive,   ) where -import           Music.Time.Span-import           Music.Time.Time+import           Data.Functor.Rep+import           Data.Functor.Rep.Lens -import           Music.Time.Delayable-import           Music.Time.Onset-import           Music.Time.Stretchable+import           Music.Time.Duration+import           Music.Time.Juxtapose+import           Music.Time.Position+import           Music.Time.Rest+import           Music.Time.Reverse+import           Music.Time.Split+import           Music.Time.Transform+import           Music.Time.Types  import           Music.Time.Behavior-import           Music.Time.Juxtapose+import           Music.Time.Chord+import           Music.Time.Delayed+import           Music.Time.Note import           Music.Time.Reactive-import           Music.Time.Reverse+import           Music.Time.Score+import           Music.Time.Segment+import           Music.Time.Stretched+import           Music.Time.Track+import           Music.Time.Voice
src/Music/Time/Behavior.hs view
@@ -1,21 +1,22 @@  {-# LANGUAGE ConstraintKinds            #-} {-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE RankNTypes                 #-} {-# LANGUAGE ScopedTypeVariables        #-} {-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TupleSections              #-} {-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE ViewPatterns               #-}+{-# LANGUAGE UndecidableInstances       #-}  ------------------------------------------------------------------------------------- -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund 2012-2014 -- -- License     : BSD-style --@@ -25,136 +26,354 @@ -- -- Behaviors, or time-varying values. ----- TODO integrate better in the library--- -------------------------------------------------------------------------------------  module Music.Time.Behavior (-        Behavior,-        -- constant,-        -- behavior,-        -- varying,-        -- varyingIn,-        -- time,-        -- switchB,-        -- trimBeforeB,-  ) where -import           Prelude                hiding (trimAfter)+    -- * Behavior type+    Behavior, -import           Control.Applicative-import           Control.Arrow-import           Control.Lens-import           Control.Monad-import           Control.Monad.Compose-import           Control.Monad.Plus+    -- ** Examples+    behavior,++    -- * Combinators+    switch,+    switch',+    -- splice,+    -- trim,+    trimBefore,+    trimAfter,+    -- concatB,++    -- * Common behaviors+    -- ** Oscillators+    line,+    sawtooth,+    sine,+    cosine,+    +    -- ** Impulse functions+    unit,+    impulse,+    turnOn,+    turnOff,++  ) where+ import           Data.AffineSpace import           Data.AffineSpace.Point-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.NumInstances      ()-import           Data.Profunctor+import           Data.Map                      (Map)+import qualified Data.Map                      as Map+import           Data.Ratio import           Data.Semigroup-import           Data.Set               (Set)-import qualified Data.Set               as Set-import           Data.Traversable       (Traversable)-import qualified Data.Traversable       as T-import           Data.Typeable+import           Data.Set                      (Set)+import qualified Data.Set                      as Set import           Data.VectorSpace+import           Prelude                       hiding (trimAfter) +import           Control.Applicative+import           Control.Arrow                 (first, second, (&&&), (***))+import           Control.Lens                  hiding (Indexable, Level, above,+                                                below, index, inside, parts,+                                                reversed, transform, (<|), (|>))++import           Data.Distributive+import           Data.Functor.Rep+import           Data.Functor.Rep.Lens+import           Data.Typeable+import           Music.Time.Bound+import           Music.Time.Internal.Transform+import           Music.Time.Note+import           Music.Time.Reverse+import           Music.Time.Score+import           Music.Time.Split+ import           Music.Dynamics.Literal+import           Music.Pitch.Alterable+import           Music.Pitch.Augmentable import           Music.Pitch.Literal-import           Music.Time.Delayable-import           Music.Time.Reactive-import           Music.Time.Span-import           Music.Time.Stretchable-import           Music.Time.Time-import           Music.Time.Time --- Inner TFun focuses on [0..1]-newtype Behavior a = Behavior { getBehavior :: Reactive (Time -> a) }-    deriving (Functor, Semigroup, Monoid) -instance Delayable (Behavior a) where-    delay n (Behavior x) = Behavior (fmap (delay n) $ delay n x) -instance Stretchable (Behavior a) where-    stretch n (Behavior x) = Behavior (fmap (stretch n) $ stretch n x)+-- Behavior is 'Representable':+--+-- > ask = realToFrac <$> time+-- > localRep (- t) = delay t+-- > localRep (/ t) = stretch t -instance Wrapped (Behavior a) where-    type Unwrapped (Behavior a) = (Reactive (Time -> a))-    _Wrapped' = iso getBehavior Behavior+-- |+-- A 'Behavior' is a value varying over time.+--+-- Use 'focusing' to view a particular 'Segment'.+--+-- The semantics are given by+--+-- @+-- type Behavior a = 'Time' -> a+-- @+--+newtype Behavior a  = Behavior { getBehavior :: Time -> a }+  deriving (Functor, Applicative, Monad, Typeable) -instance Applicative Behavior where-    pure    = (^. _Unwrapped') . pure . pure-    ((^. _Wrapped') -> f) <*> ((^. _Wrapped') -> x) = (^. _Unwrapped') $ liftA2 (<*>) f x+--+-- $musicTimeBehaviorExamples+--+-- 'behavior' let us convert any function to a behavior using '^.' or 'view'.+--+-- We can unwrap a behavior using @'from' 'behavior'@ or '!^'.+--+-- A sine function+--+-- @+-- ('sin' . (* 'tau') . 'realToFrac')^.'behavior'+-- @+--+-- A behavior that switches from (-1) to 1 at time 0+--+-- @+-- (\\t -> if t < 0 then (-1) else 1)^.'behavior'+-- @+--+-- A time-varying function applied to a value+--+-- @+-- ('+')^.'behavior' '<*>' 10+-- @+--+instance Show (Behavior a) where+  show _ = "<<Behavior>>" -instance HasBehavior Behavior where-    (?) = behAt+deriving instance Distributive Behavior +instance Transformable (Behavior a) where+  transform s (Behavior a) = Behavior (a `whilst` s)+    where+      f `whilst` s = f . transform (negateV s)++instance Reversible (Behavior a) where+  rev = stretch (-1)+  -- TODO alternative+  -- rev = (stretch (-1) `whilst` undelaying 0.5)+  -- (i.e. revDefault pretending that Behaviors have era (0 <-> 1))++instance Representable Behavior where+  type Rep Behavior = Time+  tabulate = Behavior+  index (Behavior x) = x++deriving instance Semigroup a => Semigroup (Behavior a)+deriving instance Monoid a => Monoid (Behavior a) deriving instance Num a => Num (Behavior a) deriving instance Fractional a => Fractional (Behavior a) deriving instance Floating a => Floating (Behavior a) +-- TODO bad instance+instance Real a => Real (Behavior a) where+  toRational = toRational . (! 0)++-- #ifdef INCLUDE_LIFTED+deriving instance AdditiveGroup a => AdditiveGroup (Behavior a)+ instance IsPitch a => IsPitch (Behavior a) where-    fromPitch = pure . fromPitch+  fromPitch = pure . fromPitch+ instance IsInterval a => IsInterval (Behavior a) where-    fromInterval = pure . fromInterval+  fromInterval = pure . fromInterval+ instance IsDynamics a => IsDynamics (Behavior a) where-    fromDynamics = pure . fromDynamics-instance AdditiveGroup a => AdditiveGroup (Behavior a) where-    zeroV = pure zeroV-    negateV = fmap negateV-    (^+^) = liftA2 (^+^)+  fromDynamics = pure . fromDynamics++instance Alterable a => Alterable (Behavior a) where+    sharpen = fmap sharpen+    flatten = fmap flatten++instance Augmentable a => Augmentable (Behavior a) where+    augment = fmap augment+    diminish = fmap diminish++instance Eq a => Eq (Behavior a) where+  (==) = error "No fun"++instance Ord a => Ord (Behavior a) where+  (<) = error "No fun"+  max = liftA2 max+  min = liftA2 min++instance Enum a => Enum (Behavior a) where+  toEnum = pure . toEnum+  fromEnum = fromEnum . (! 0)++instance VectorSpace a => VectorSpace (Behavior a) where+  type Scalar (Behavior a) = Behavior (Scalar a)+  (*^) = liftA2 (*^)+ instance AffineSpace a => AffineSpace (Behavior a) where-    type Diff (Behavior a) = Behavior (Diff a)-    (.+^) = liftA2 (.+^)-    (.-.) = liftA2 (.-.)+  type Diff (Behavior a) = Behavior (Diff a)+  (.-.) = liftA2 (.-.)+  (.+^) = liftA2 (.+^)+-- #endif +-- |+-- View a behavior as a time function and vice versa.+--+-- Note that this is just an alias defined to make the documentation nicer:+--+--+-- @+-- 'behavior' = 'tabulated'+-- @+--+behavior :: Iso (Time -> a) (Time -> b) (Behavior a) (Behavior b)+behavior = tabulated +-- |+-- View a time function as a behavior.+--+-- @+-- unbehavior    = from behavior+-- x^.unbehavior = (x !)+-- @+--+unbehavior :: Iso (Behavior a) (Behavior b) (Time -> a) (Time -> b)+unbehavior = from behavior +--+-- @+-- ('const' x)^.'behavior' ! t = x   forall t+-- @+--+-- --- | A constant (non-varying) behavior.++-- |+-- A behavior that -----   Identical to @behavior . const@ but creates more efficient behaviors.-constant :: a -> Behavior a-constant = (^. _Unwrapped') . pure . pure+line' :: Behavior Time+line' = id ^. tabulated --- | Create a behavior from function of (absolute) time.+-- |+-- A behavior that gives the current time, i.e. the identity function -----   You should pass a function defined for the whole range, including negative time.-behavior :: (Time -> a) -> Behavior a-behavior = (^. _Unwrapped') . pure+-- Should really have the type 'Behavior' 'Time', but is provided in a more general form+-- for convenience.+--+line :: Fractional a => Behavior a+line = realToFrac ^. tabulated+--+-- > f t = t+-- --- | Create a behaviour from a function of (relative) duration focused on 'sunit'.+-- |+-- A behavior that varies from 0 to 1 during the same time interval and is 0 before and 1 after+-- that interval. -----   You should pass a function defined for the whole range, including negative durations.-varying :: (Duration -> a) -> Behavior a-varying = varyingIn sunit+unit :: Fractional a => Behavior a+unit = switch 0 0 (switch 1 line 1)+-- > f t | t < 0     = 0+-- >     | t > 1     = 1+-- >     | otherwise = t+-- --- | Create a behaviour from a function of (relative) duration focused on the given span.+-- |+-- A behavior that -----   You should pass a function defined for the whole range, including negative durations.-varyingIn :: Span -> (Duration -> a) -> Behavior a-varyingIn s f = behavior $ sapp (sinvert s) (lmap (.-. start) f)+interval :: (Fractional a, Transformable a) => Time -> Time -> Note (Behavior a)+interval t u = (t <-> u, line) ^. note --- | @b ?? t@ returns the value of the behavior at time @t@.---  Semantic function.-behAt :: Behavior a -> Time -> a-b `behAt` t = ((^. _Wrapped') b ? t) t+-- |+-- A behavior that+--+sine :: Floating a => Behavior a+sine = sin (line*tau) -time :: Behavior Time-time = behavior id--- --- trimBeforeB :: Monoid a => Time -> Behavior a -> Behavior a--- trimBeforeB t = _Wrapping' Behavior %~ trimBefore t--- --- switchB :: Time -> Behavior a -> Behavior a -> Behavior a--- switchB t ((^. _Wrapped') -> x) ((^. _Wrapped') -> y) = (^. _Unwrapped') $ switch t x y--- --- --- ---                  +-- |+-- A behavior that+--+cosine :: Floating a => Behavior a+cosine = cos (line*tau)++-- |+-- A behavior that goes from 0 to 1 repeatedly with a period of 1.+--+sawtooth :: RealFrac a => Behavior a+sawtooth = line - fmap floor' line++-- |+-- A behavior that is 1 at time 0, and 0 at all other times.+--+impulse :: Num a => Behavior a+impulse = switch' 0 0 1 0+-- > f t | t == 0    = 1+-- >     | otherwise = 0+--++-- |+-- A behavior that goes from 0 to 1 at time 0.+--+turnOn  = switch 0 0 1++-- |+-- A behavior that goes from 1 to 0 at time 0.+--+turnOff = switch 0 1 0++--+-- TODO+--+-- Because the 'Time' type is fixed and unbounded in the current version, we can not+-- define a generix isomorphism from behaviors to segments. If we change the library to+-- provide multiple time representations (using TFs or similar), we should provide+-- these combinators:+--+-- > focusOnFullRange :: Bounded Time => Behavior a -> Segment a+-- > focusingOnFullRange :: Bounded Time => Iso' (Behavior a) (Segment a)+--++{-+-- |+-- View part of a 'Behavior' as a 'Segment'.+--+-- This can be used to modify a behavior in a specific range, as in+--+-- @+-- 'line' & 'focusing' ``on`` (2 '<->' 3) '+a~' 1+-- 'line' & 'focusingOn' (2 '<->' 3) '+~' 1+-- @+--+focusingOn :: Span -> Lens' (Behavior a) (Segment a)+focusingOn s = flip whilstM (negateV s) . focusing+-- or focusing . flip whilstM s+-}++-- focusing `on` s == focusingOn s+f `on` s = flip whilstM (negateV s) . f++-- |+-- Instantly switch from one behavior to another.+--+switch :: Time -> Behavior a -> Behavior a -> Behavior a+switch t rx ry = switch' t rx ry ry++-- | Replace everthing before the given time by `mempty`.+trimBefore :: Monoid a => Time -> Behavior a -> Behavior a+trimBefore start = switch start mempty++-- | Replace everthing after the given time by `mempty`.+trimAfter :: Monoid a => Time -> Behavior a -> Behavior a+trimAfter stop x = switch stop x mempty++-- |+-- Instantly switch from one behavior to another with an optinal intermediate value.+--+switch' :: Time -> Behavior a -> Behavior a -> Behavior a -> Behavior a+switch' t rx ry rz = tabulate $ \u -> case u `compare` t of+  LT -> rx ! u+  EQ -> ry ! u+  GT -> rz ! u++-- TODO move+tau = 2 * pi++floor' :: RealFrac a => a -> a+floor' = fromIntegral . floor+
+ src/Music/Time/Bound.hs view
@@ -0,0 +1,152 @@++{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE ViewPatterns               #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-- /Warning/ This module is experimental.+--+-------------------------------------------------------------------------------------++module Music.Time.Bound (+    -- * Bound type+    Bound(..),+    +    -- * Construction+    bounds,+    bounding,+    -- trim,+    -- splice,+    -- bounded',+    -- bounded,+  ) where++import           Data.AffineSpace+import           Data.AffineSpace.Point+import           Data.Map               (Map)+import qualified Data.Map               as Map+import           Data.Ratio+import           Data.Semigroup+import           Data.Set               (Set)+import qualified Data.Set               as Set+import           Data.VectorSpace++import           Music.Time.Reverse+import           Music.Time.Split++import           Control.Applicative+import           Control.Arrow          (first, second, (&&&), (***))+import           Control.Lens           hiding (Indexable, Level, above, below,+                                         index, inside, parts, reversed,+                                         transform, (<|), (|>))+import           Data.Typeable++-- |+-- 'Bound' restricts the start and stop time of a value, and prevents access to values+-- outside the bounds.+--+-- 'Bound' is especially useful to restrict the range of a 'Behavior'. If we have a+-- value with can only be reasonably defined for a particular time range, we can+-- represent it as 'Bound' 'Behavior'. This is isomorphic to a 'Note' 'Segment', and+-- 'bounded' whitnesses the isomorphism.+--+-- 'Bound' is not 'Foldable' or 'Traversable', as that would allow us to access values+-- outside the bounds. However, we can still access values of a 'Bound' 'Behavior' in a+-- safe manner using 'trim' or 'splice'.+--+-- The semantics are given by+--+-- @+-- type Bound a = (Time, Time, a)+-- @+--+newtype Bound a = Bound { getBound :: (Span, a) }+  deriving (Functor, Semigroup, Typeable, Eq, Show)++--+-- These are both unsafe, as they allow us to define 'unBound'+--+-- instance Foldable Bound where+--   foldr f z (Bound (_,x)) = f x z+--+-- instance Traversable Bound where+--   traverse f (Bound (s,x)) = (Bound . (s,)) <$> f x+--++--+-- TODO define Applicative/Monad+--+--+-- This is a Writer-style instance with interval arithmetic style union/empty as the Monoid+-- A possible problem with this is that there are multiple representations of the empty+-- 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++instance Rewrapped (Bound a) (Bound b)++instance Reversible a => Reversible (Bound a) where+  -- rev = over (_Wrapped . each) rev+  rev = over _Wrapped $ (rev *** rev)++instance (HasPosition a, Splittable a) => Splittable (Bound a) where+  -- TODO++-- |+-- 'Bound' transform by transforming the bounded value as well as+-- the bounds.+--+instance Transformable a => Transformable (Bound a) where+  transform t = over _Wrapped (transform t *** transform t)++instance (HasPosition a, HasDuration a) => HasDuration (Bound a) where+  _duration x = _offset x .-. _onset x++instance HasPosition a => HasPosition (Bound a) where+  -- TODO lawless+  -- _position (Bound (view range -> (t, u), x)) d = truncating t u (_position x d)+  _position (Bound (view range -> (t, u), x)) = alerp t u++truncating :: Ord a => a -> a -> a -> a+truncating t u x = (x `max` t) `min` u++-- |+-- Add bounds.+--+bounds :: Time -> Time -> a -> Bound a+bounds t u x = Bound (t <-> u, x)++-- |+-- Add bounds.+--+-- @+-- (s,x)^.note = (bounding s . transform s) x+-- @+--+bounding :: Span -> a -> Bound a+bounding (view range -> (t, u)) = bounds t u+
+ src/Music/Time/Chord.hs view
@@ -0,0 +1,136 @@++{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-- /Warning/ This module is experimental.+--+-------------------------------------------------------------------------------------++module Music.Time.Chord (++      -- * Chord type+      Chord,+      -- * Construction+      chord,+      unsafeChord,++  ) where+++import           Data.AffineSpace+import           Data.AffineSpace.Point+import           Data.Map               (Map)+import qualified Data.Map               as Map+import           Data.Ratio+import           Data.Semigroup+import           Data.Set               (Set)+import qualified Data.Set               as Set+import           Data.VectorSpace++import           Music.Time.Delayed+import           Music.Time.Reverse+import           Music.Time.Split++import           Control.Applicative+import           Control.Arrow          (first, second, (&&&), (***))+import           Control.Lens           hiding (Indexable, Level, above, below,+                                         index, inside, parts, reversed,+                                         transform, (<|), (|>))+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.Dynamics.Literal+import           Music.Pitch.Literal+++-- |+-- A 'Chord' is a parallel composition of values.+--+-- @+-- type Chord a = [Delayed a]+-- @+--+newtype Chord a = Chord { getChord :: ChordList (ChordEv a) }+  deriving (Functor, Foldable, Traversable, Semigroup, Monoid, Typeable, Show, Eq)++-- Can use [] or Seq here+type ChordList = []++-- Can use any type as long as chordEv provides an Iso+type ChordEv a = Delayed a++chordEv :: Iso (Delayed a) (Delayed b) (ChordEv a) (ChordEv b)+chordEv = id++instance Applicative Chord where+  pure  = return+  (<*>) = ap++instance Monad Chord where+  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++instance Rewrapped (Chord a) (Chord b)++instance Transformable (Chord a) where+  transform s = over _Wrapped' (transform s)++instance HasDuration (Chord a) where+  _duration = Foldable.sum . fmap _duration . view _Wrapped'++instance Splittable a => Splittable (Chord a) where+  -- TODO++instance Reversible a => Reversible (Chord a) where+  rev = over _Wrapped' (fmap rev) -- TODO OK?++-- TODO+-- instance HasMeta (Chord a) where+  -- meta = error "Not implemented: meta"++chord :: Lens (Chord a) (Chord b) [Delayed a] [Delayed b]+chord = _Wrapped++-- TODO names are not consistent with other types+unsafeChord :: Iso (Chord a) (Chord b) [Delayed a] [Delayed b]+unsafeChord = _Wrapped++deriving instance IsPitch a => IsPitch (Chord a)	 +deriving instance IsInterval a => IsInterval (Chord a)	 +deriving instance IsDynamics a => IsDynamics (Chord a)+
− src/Music/Time/Delayable.hs 
@@ -1,121 +0,0 @@--{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies               #-}------------------------------------------------------------------------------------------ |--- Copyright   : (c) Hans Hoglund 2012------ License     : BSD-style------ Maintainer  : hans@hanshoglund.se--- Stability   : experimental--- Portability : non-portable (TF,GNTD)------ Provides delayable values.-------------------------------------------------------------------------------------------module Music.Time.Delayable (-        -- * Delayable class-        Delayable(..),-        undelay,-        delaying,-        move,-        moveBack,--        -- ** Utility-        delayTime,-        NoDelay(..),-  ) where--import           Data.AffineSpace-import           Data.AffineSpace.Point-import           Data.Map               (Map)-import qualified Data.Map               as Map-import           Data.Semigroup-import           Data.Set               (Set)-import qualified Data.Set               as Set-import           Data.VectorSpace       hiding (Sum)--import           Music.Time.Time---- |--- Delayable values.----class Delayable a where--    -- |-    -- Delay a value.-    ---    delay :: Duration -> a -> a-    delay _ = id--instance Delayable Time where-    delay n = (.+^ n)--instance Delayable (Time -> a) where-    delay n = (. delay (negateV n))--instance Delayable a => Delayable [a] where-    delay n = fmap (delay n)--instance (Ord a, Delayable a) => Delayable (Set a) where-    delay n = Set.map (delay n)--instance Delayable a => Delayable (Map k a) where-    delay n = fmap (delay n)--instance Delayable (Time, a) where-    delay n (t, a) = (n `delay` t, a)--instance Delayable (Time, Duration, a) where-    delay n (t, d, a) = (n `delay` t, d, a)--instance Delayable a => Delayable (Sum a) where-    delay n (Sum x) = Sum (delay n x)--instance Delayable a => Delayable (Product a) where-    delay n (Product x) = Product (delay n x)------ |--- Move a score forward in time. Equivalent to 'delay'.----move :: Delayable a => Duration -> a -> a---- |--- Move a score backward in time. Negated verison of 'delay'.----moveBack :: Delayable a => Duration -> a -> a---- |--- Delay relative to 'origin'. Provided for situations when you have a value that--- should forward based on the distance between some time @t@ and the origin, but--- it does not necessarily have a start time.----delayTime :: Delayable a => Time   -> a -> a--undelay t       = delay (negateV t)-move            = delay-moveBack t      = delay (negateV t)-delayTime t     = delay (t .-. origin)----- | Apply a function under delay.---   See also 'sunder'.-delaying :: (Delayable a, Delayable b) => Duration -> (a -> b) -> a -> b-delaying t f = undelay t . f . delay t--newtype NoDelay a = NoDelay { getNoDelay :: a }-    deriving (Eq, Ord, Enum, Show, Semigroup, Monoid-        {-Delayable, HasOnset, HasOffset, HasDuration-})--instance Delayable (NoDelay a) where-    delay _ = id
+ src/Music/Time/Delayed.hs view
@@ -0,0 +1,143 @@++{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------++module Music.Time.Delayed (+      -- * Delayed type+      Delayed,++      -- * Construction+      delayed,++      -- ** Inspecting delayed values+      delayedValue,+  ) where++import           Data.AffineSpace+import           Data.AffineSpace.Point+import           Data.Map               (Map)+import qualified Data.Map               as Map+import           Data.Ratio+import           Data.Semigroup+import           Data.Set               (Set)+import qualified Data.Set               as Set+import           Data.VectorSpace++import           Music.Time.Reverse+import           Music.Time.Split++import           Control.Applicative+import           Control.Arrow          (first, second, (&&&), (***))+import           Control.Comonad+import           Control.Comonad.Env+import           Control.Lens           hiding (Indexable, Level, above, below,+                                         index, inside, parts, reversed,+                                         transform, (<|), (|>))+import           Data.Foldable          (Foldable)+import qualified Data.Foldable          as Foldable+import           Data.PairMonad+import           Data.Typeable++import           Music.Dynamics.Literal+import           Music.Pitch.Literal+++-- |+-- 'Delayed' represents a value with an offset in time.+--+-- A delayed value has a known 'position', but no 'duration'.+--+-- Placing a value inside 'Delayed' does not make it invariant under 'stretch', as the+-- offset of a delayed value may be stretched with respect to the origin. However, in+-- contrast to a note the /duration/ is not stretched.+--+-- The semantics are given by+--+-- @+-- type Delayed a = (Time, a)+-- @+--+newtype Delayed a = Delayed   { _delayedValue :: (Time, a) }+  deriving (Eq, {-Ord, -}{-Show, -}+            Applicative, Monad, {-Comonad, -}+            Functor,  Foldable, Traversable, Typeable)++deriving instance Show a => Show (Delayed a)++-- | Unsafe: Do not use 'Wrapped' instances+instance Wrapped (Delayed a) where+  type Unwrapped (Delayed a) = (Time, a)+  _Wrapped' = iso _delayedValue Delayed++instance Rewrapped (Delayed a) (Delayed b)++instance Transformable (Delayed a) where+  transform t = over _Wrapped $ first (transform t)++instance HasDuration (Delayed a) where+  _duration x = _offset x .-. _onset x++instance HasPosition (Delayed a) where+  x `_position` p = ask (view _Wrapped x) `_position` p++instance Reversible (Delayed a) where+  rev = revDefault++instance Splittable a => Splittable (Delayed a) where+  -- FIXME++-- |+-- View a delayed value as a pair of a the original value and a delay time.+--+delayed :: Iso (Time, a) (Time, b) (Delayed a) (Delayed b)+delayed = _Unwrapped+++-- |+-- View a delayed value as a pair of the original value and the transformation (and vice versa).+--+delayedValue :: (Transformable a, Transformable b)+  => Lens+      (Delayed a) (Delayed b)+      a b+delayedValue = lens runDelayed (flip $ _delayed . const)+  where+    _delayed f (Delayed (t,x)) = Delayed (t, f `whilst` delaying (t .-. 0) $ x)+{-# INLINE delayedValue #-}+++runDelayed :: Transformable a => Delayed a -> a+runDelayed = uncurry delayTime . view _Wrapped+++deriving instance IsPitch a => IsPitch (Delayed a)	 +deriving instance IsInterval a => IsInterval (Delayed a)	 +deriving instance IsDynamics a => IsDynamics (Delayed a)+
+ src/Music/Time/Duration.hs view
@@ -0,0 +1,106 @@++{-# LANGUAGE ConstraintKinds           #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TupleSections             #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE UndecidableInstances      #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------++module Music.Time.Duration (+        module Music.Time.Transform,++        -- * The HasDuration class+        HasDuration(..),++        -- * Absolute duration+        duration,+        stretchTo,+  ) where++import           Music.Time.Transform++import           Control.Lens         hiding (Indexable, Level, above, below,+                                       index, inside, parts, reversed,+                                       transform, (<|), (|>))+import           Data.NumInstances    ()+import           Data.Semigroup       hiding ()+import           Data.VectorSpace     hiding (Sum (..))++-- |+-- Class of values that have a duration.+--+-- Law Duration+--+-- @+-- '_duration' x = ('offset' x '.-.' 'onset' x)+-- @+--+class HasDuration a where+  _duration :: a -> Duration++instance HasDuration Time where+  _duration = 0++instance HasDuration Duration where+  _duration = id++instance HasDuration Span where+  _duration = snd . view delta++--+-- By convention, we treat pairs and triplets as having the form+-- (t,x), (d,x) and (t,d,x) where t has a position and d has a+-- duration. This makes it convenient to represent simple event+-- lists as [(Time, Duration, a)] without needing any special+-- structure.+--++instance HasDuration a => HasDuration (a, b) where+  _duration (d,_) = _duration d++instance HasDuration b => HasDuration (a, b, c) where+  _duration (_,d,_) = _duration d++instance HasDuration a => HasDuration (Product a) where+  _duration (Product x) = _duration x++instance HasDuration a => HasDuration (Sum a) where+  _duration (Sum x) = _duration x++instance HasDuration a => HasDuration (Min a) where+  _duration (Min x) = _duration x++instance HasDuration a => HasDuration (Max a) where+  _duration (Max x) = _duration x+++-- |+-- Access the duration.+--+duration :: (Transformable a, HasDuration a) => Lens' a Duration+duration = lens _duration (flip stretchTo)+{-# INLINE duration #-}++-- |+-- Stretch a value to have the given duration.+--+stretchTo :: (Transformable a, HasDuration a) => Duration -> a -> a+stretchTo d x = (d ^/ _duration x) `stretch` x+{-# INLINE stretchTo #-}+
+ src/Music/Time/Internal/Quantize.hs view
@@ -0,0 +1,424 @@++{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE ViewPatterns               #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-- 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.+--+-------------------------------------------------------------------------------------++module Music.Time.Internal.Quantize (+        -- * Rhythm type+        Rhythm(..),+        mapWithDur,++        -- * Quantization+        quantize,+        rewrite,+        dotMod,+        +        -- * Utility+        drawRhythm+  ) where++import           Prelude             hiding (concat, concatMap, foldl, foldr,+                                      mapM, maximum, minimum, sum)++import           Control.Applicative+import           Control.Arrow       hiding (left)+import           Control.Lens        (over, (^.), _Left)+import           Control.Monad       (MonadPlus (..), ap, join)+import           Data.Either+import           Data.Foldable+import           Data.Function       (on)+import qualified Data.List           as List+import           Data.Maybe+import           Data.Ord            (comparing)+import           Data.Ratio+import           Data.Semigroup+import           Data.Traversable+import           Data.Tree+import           Data.VectorSpace++import           Text.Parsec         hiding ((<|>))+import           Text.Parsec.Pos++import           Music.Score.Ties+import           Music.Score.Internal.Util+import           Music.Time++data Rhythm a+  = Beat       Duration a                    -- d is divisible by 2+  | Group      [Rhythm a]                    --+  | Dotted     Int (Rhythm a)                -- n > 0.+  | Tuplet     Duration (Rhythm a)           -- d is an emelent of 'konstTuplets'.+  deriving (Eq, Show, Functor, Foldable)+  -- RInvTuplet  Duration (Rhythm a)++getBeatValue :: Rhythm a -> a+getBeatValue (Beat d a) = a+getBeatValue _          = error "getBeatValue: Not a beat"++getBeatDuration :: Rhythm a -> Duration+getBeatDuration (Beat d a) = d+getBeatDuration _          = error "getBeatValue: Not a beat"++-- TODO return voice+realize :: Rhythm a -> [Stretched a]+realize (Beat d a)      = [(d, a)^.stretched]+realize (Group rs)      = rs >>= realize+realize (Dotted n r)    = dotMod n `stretch` realize r+realize (Tuplet n r)    = n `stretch` realize r++-- rhythmToTree :: Rhythm a -> Tree (String, Maybe a)+-- rhythmToTree = go+--     where+--         go (Beat d a)     = Node ("beat "  ++ showD d, Just a) []+--         go (Group rs)     = Node ("group", Nothing) (fmap rhythmToTree rs)+--         go (Dotted n r)   = Node ("dotted " ++ show n, Nothing) [rhythmToTree r]+--         go (Tuplet n r)   = Node ("tuplet " ++ showD n, Nothing) [rhythmToTree r]+--         showD = show . toRational+--+-- drawRhythm :: Show a => Rhythm a -> String+-- drawRhythm = drawTree . fmap (uncurry (++) <<< (++ " ") *** show) . rhythmToTree++rhythmToTree :: Rhythm a -> Tree String+rhythmToTree = go+  where+    go (Beat d a)     = Node ("" ++ showD d) []+    go (Group rs)     = Node ("") (fmap rhythmToTree rs)+    go (Dotted n r)   = Node (replicate n '.') [rhythmToTree r]+    go (Tuplet n r)   = Node ("*^ " ++ showD n) [rhythmToTree r]+    showD = (\x -> show (numerator x) ++ "/" ++ show (denominator x)) . toRational++drawRhythm :: Show a => Rhythm a -> String+drawRhythm = drawTree . rhythmToTree++mapWithDur :: (Duration -> a -> b) -> Rhythm a -> Rhythm b+mapWithDur f = go+  where+    go (Beat d x)            = Beat d (f d x)+    go (Dotted n (Beat d x)) = Dotted n $ Beat d (f (dotMod n * d) x)+    go (Group rs)            = Group $ fmap (mapWithDur f) rs+    go (Tuplet m r)          = Tuplet m (mapWithDur f r)        ++instance Semigroup (Rhythm a) where+  (<>) = mappend++-- Catenates using 'Group'+instance Monoid (Rhythm a) where+  mempty = Group []+  Group as `mappend` Group bs   =  Group (as <> bs)+  r        `mappend` Group bs   =  Group ([r] <> bs)+  Group as `mappend` r          =  Group (as <> [r])+  a        `mappend` b          =  Group [a, b]++instance HasDuration (Rhythm a) where+  _duration (Beat d _)        = d+  _duration (Dotted n a)      = _duration a * dotMod n+  _duration (Tuplet c a)      = _duration a * c+  _duration (Group as)        = sum (fmap _duration as)++instance AdditiveGroup (Rhythm a) where+  zeroV   = error "No zeroV for (Rhythm a)"+  (^+^)   = error "No ^+^ for (Rhythm a)"+  negateV = error "No negateV for (Rhythm a)"++instance VectorSpace (Rhythm a) where+  type Scalar (Rhythm a) = Duration+  a *^ Beat d x = Beat (a*d) x+  -- TODO how does this preserve the invariant?++Beat d x `subDur` d' = Beat (d-d') x+++{-+    Rhythm rewrite laws (all up to realization equality)++    Note: Just sketching, needs more formal treatment.+++    Group [Group xs ...] = Group [xs ...]+        [JoinGroup]++    Tuplet m (Tuplet n x) = Tuplet (m * n) x+        [NestTuplet]++    Tuplet m (Group [a,b ...]) = Group [Tuplet m a, Tuplet m b ...]+        [DistributeTuplet]+        This is only OK in certain contexts! Which?++-}++rewrite :: Rhythm a -> Rhythm a+rewrite = rewriteR . rewrite1++rewriteR = go where+  go (Beat d a)     = Beat d a+  go (Group rs)     = Group (fmap (rewriteR . rewrite1) rs)+  go (Dotted n r)   = Dotted n ((rewriteR . rewrite1) r)+  go (Tuplet n r)   = Tuplet n ((rewriteR . rewrite1) r)++rewrite1 = tupletDot . splitTuplet . singleGroup+++singleGroup :: Rhythm a -> Rhythm a+singleGroup orig@(Group [x]) = x+singleGroup orig             = orig++-- | Removes dotted notes in 2/3 tuplets.+tupletDot :: Rhythm a -> Rhythm a+tupletDot orig@(Tuplet ((unRatio.realToFrac) -> (2,3)) (Dotted 1 x)) = x+tupletDot orig                                                       = orig++-- | Splits a tuplet iff it contans a group which can be split into two halves of exactly the same size.+-- TODO this should only happen if the tuplet lenght is longer than a beat+splitTuplet :: Rhythm a -> Rhythm a+splitTuplet orig@(Tuplet n (Group xs)) = case trySplit xs of+  Nothing       -> orig+  Just (as, bs) -> Tuplet n (Group as) <> Tuplet n (Group bs)+splitTuplet orig = orig++{-+-- TODO bad instance+instance HasDuration a => HasDuration [a] where+  _duration = sum . fmap _duration+-}++trySplit :: [Rhythm a] -> Maybe ([Rhythm a], [Rhythm a])+trySplit = firstJust . fmap g . splits+  where+      g (part1, part2)+          | (sum . fmap _duration) part1 == (sum . fmap _duration) part2 = Just (part1, part2)+          | otherwise                        = Nothing+      splits xs = List.inits xs `zip` List.tails xs+      firstJust = listToMaybe . fmap fromJust . List.dropWhile isNothing+++quantize :: Tiable a => [(Duration, a)] -> Either String (Rhythm a)+quantize = quantize' (atEnd rhythm)++testQuantize :: [Duration] -> IO ()+testQuantize x = case fmap rewrite $ quantize' (atEnd rhythm) $ fmap (\x -> (x,())) $ x of+  Left e -> error e+  Right x -> putStrLn $ drawRhythm x+++konstNumDotsAllowed :: [Int]+konstNumDotsAllowed = [1..4]++konstBounds :: [Duration]+konstBounds = [ 1/2, 1/4, 1/8, 1/16 ]++konstTuplets :: [Duration]+konstTuplets = [ 2/3, 4/5, 4/7, 8/9, 8/11, 8/13, 8/15, 16/17, 16/18, 16/19, 16/21, 16/23 ]++konstMaxTupletNest :: Int+konstMaxTupletNest = 1+++data RhythmContext = RhythmContext {++      -- Time scaling of the current note (from dots and tuplets).+      timeMod    :: Duration,++      -- Time subtracted from the current rhythm (from ties).+      timeSub    :: Duration,++      -- Number of tuplets above the current note (default 0).+      tupleDepth :: Int+  }++instance Monoid RhythmContext where+  mempty = RhythmContext { timeMod = 1, timeSub = 0, tupleDepth = 0 }+  a `mappend` _ = a++modifyTimeMod :: (Duration -> Duration) -> RhythmContext -> RhythmContext+modifyTimeMod f (RhythmContext tm ts td) = RhythmContext (f tm) ts td++modifyTimeSub :: (Duration -> Duration) -> RhythmContext -> RhythmContext+modifyTimeSub f (RhythmContext tm ts td) = RhythmContext tm (f ts) td++modifyTupleDepth :: (Int -> Int) -> RhythmContext -> RhythmContext+modifyTupleDepth f (RhythmContext tm ts td) = RhythmContext tm ts (f td)+++++++-- |+-- A @RhytmParser a b@ converts (Voice a) to b.+type RhythmParser a b = Parsec [(Duration, a)] RhythmContext b++quantize' :: Tiable a => RhythmParser a b -> [(Duration, a)] -> Either String b+quantize' p = over _Left show . runParser p mempty ""+++++++rhythm :: Tiable a => RhythmParser a (Rhythm a)+rhythm = Group <$> many1 (rhythm' <|> bound)++rhythmNoBound :: Tiable a => RhythmParser a (Rhythm a)+rhythmNoBound = Group <$> many1 rhythm'++rhythm' :: Tiable a => RhythmParser a (Rhythm a)+rhythm' = mzero+  <|> beat+  <|> dotted+  <|> tuplet++-- Matches a beat divisible by 2 (notated)+-- beat :: Tiable a => RhythmParser a (Rhythm a)+-- beat = do+--     RhythmContext tm ts _ <- getState+--     (\d -> (d^/tm) `subDur` ts) <$> match (\d _ ->+--         d - ts > 0  &&  isDivisibleBy 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)+++-- | Matches a dotted rhythm+dotted :: Tiable a => RhythmParser a (Rhythm a)+dotted = msum . fmap dotted' $ konstNumDotsAllowed++-- | Matches a bound rhythm+bound :: Tiable a => RhythmParser a (Rhythm a)+bound = msum . fmap bound' $ konstBounds++-- | Matches a tuplet+tuplet :: Tiable a => RhythmParser a (Rhythm a)+tuplet = msum . fmap tuplet' $ konstTuplets++++++dotted' :: Tiable a => Int -> RhythmParser a (Rhythm a)+dotted' n = do+  modifyState $ modifyTimeMod (* dotMod n)+  a <- beat+  modifyState $ modifyTimeMod (/ dotMod n)+  return (Dotted n a)++-- | Return the scaling applied to a note with the given number of dots (i.e. 3/2, 7/4 etc).+dotMod :: Int -> Duration+dotMod n = dotMods !! (n-1)++-- [3/2, 7/4, 15/8, 31/16 ..]+dotMods :: [Duration]+dotMods = zipWith (/) (fmap pred $ drop 2 times2) (drop 1 times2)+  where+      times2 = iterate (*2) 1++bound' :: Tiable a => Duration -> RhythmParser a (Rhythm a)+bound' d = do+  modifyState $ modifyTimeSub (+ d)+  a <- beat+  modifyState $ modifyTimeSub (subtract d)+  let (b,c) = toTied $ getBeatValue a++  -- TODO doesn't know order+  return $ Group [Beat (getBeatDuration a) b, Beat d c]++-- tuplet' 2/3 for triplet, 4/5 for quintuplet etc+tuplet' :: Tiable a => Duration -> RhythmParser a (Rhythm a)+tuplet' d = do+  RhythmContext _ _ depth <- getState+  onlyIf (depth < konstMaxTupletNest) $ do+      modifyState $ modifyTimeMod (* d)+                  . modifyTupleDepth succ+      a <- rhythmNoBound+      modifyState $ modifyTimeMod (/ d)+                  . modifyTupleDepth pred+      return (Tuplet d a)+++-------------------------------------------------------------------------------------++-- | Similar to 'many1', but tries longer sequences before trying one.+-- many1long :: Stream s m t => ParsecT s u m a -> ParsecT s u m [a]+-- many1long p = try (many2 p) <|> fmap return p++-- | Similar to 'many1', but applies the parser 2 or more times.+-- many2 :: Stream s m t => ParsecT s u m a -> ParsecT s u m [a]+-- many2 p = do { x <- p; xs <- many1 p; return (x : xs) }++-- Matches a (_duration, value) pair iff the predicate matches, returns beat+match :: Tiable a => (Duration -> a -> Bool) -> RhythmParser a (Rhythm a)+match p = tokenPrim show next test+  where+      show x        = ""+      next pos _ _  = updatePosChar pos 'x'+      test (d,x)    = if p d x then Just (Beat d x) else Nothing++-- Matches a (_duration, value) pair iff the predicate matches, returns beat+match' :: Tiable a => (Duration -> a -> Maybe (Duration, b)) -> RhythmParser a (Rhythm b)+match' f = tokenPrim show next test+  where+      show x        = ""+      next pos _ _  = updatePosChar pos 'x'+      test (d,x)    = case f d x of+          Nothing     -> Nothing+          Just (d,x)  -> Just $ Beat d x++-- |+-- Succeed only if the entire input is consumed.+--+atEnd :: RhythmParser a b -> RhythmParser a b+atEnd p = do+  x <- p+  notFollowedBy' anyToken' <?> "end of input"+  return x+  where+      notFollowedBy' p = try $ (try p >> unexpected "") <|> return ()+      anyToken'        = tokenPrim (const "") (\pos _ _ -> pos) Just++onlyIf :: MonadPlus m => Bool -> m b -> m b+onlyIf b p = if b then p else mzero++-- | Just x or Nothing+assuming :: a -> Bool -> Maybe a+assuming x b = if b then Just x else Nothing++logBaseR :: forall a . (RealFloat a, Floating a) => Rational -> Rational -> a+logBaseR k n | isInfinite (fromRational n :: a)      = logBaseR k (n/k) + 1+logBaseR k n | isDenormalized (fromRational n :: a)  = logBaseR k (n*k) - 1+logBaseR k n | otherwise                             = logBase (fromRational k) (fromRational n)+++divides     = isDivisibleBy+divisibleBy = flip isDivisibleBy++-- As it sounds, do NOT use infix+-- Only works for simple n such as 2 or 3, TODO determine+isDivisibleBy :: Duration -> Duration -> Bool+isDivisibleBy n = (== 0.0) . snd . properFraction . logBaseR (toRational n) . toRational+
+ src/Music/Time/Internal/Transform.hs view
@@ -0,0 +1,384 @@++{-# LANGUAGE ConstraintKinds           #-}+{-# LANGUAGE DeriveDataTypeable        #-}+{-# LANGUAGE DeriveFoldable            #-}+{-# LANGUAGE DeriveFunctor             #-}+{-# LANGUAGE DeriveTraversable         #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE StandaloneDeriving        #-}+{-# LANGUAGE TupleSections             #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE UndecidableInstances      #-}+{-# LANGUAGE ViewPatterns              #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------++module Music.Time.Internal.Transform (++        -- * The Transformable class+        Transformable(..),+        itransform,+        transformed,++        -- * Apply under a transformation+        whilst,+        whilstM,+        whilstL,+        whilstLT,+        whilstLD,+        whilstStretch,+        whilstDelay,+        spanned,+        onSpan,+        conjugateS,++        -- * Specific transformations+        delay,+        undelay,+        stretch,+        compress,+        -- ** Applied transformations+        delaying,+        undelaying,+        stretching,+        compressing,++        -- ** Utility+        delayTime,    ++  ) where++import           Music.Time.Types++import           Data.Ratio++import           Control.Applicative+import           Control.Lens           hiding (Indexable, Level, above, below,+                                         index, inside, parts, reversed,+                                         transform, (<|), (|>))+import           Data.AffineSpace+import           Data.AffineSpace.Point+import           Data.Map               (Map)+import qualified Data.Map               as Map+import           Data.Semigroup+import           Data.Sequence          (Seq)+import qualified Data.Sequence          as Seq+import           Data.VectorSpace       hiding (Sum (..))++-- |+-- Class of values that can be transformed (i.e. scaled and moved) in time.+--+-- Law+--+-- @+-- transform mempty = id+-- transform (s \<> t) = transform s . transform t+-- transform (s \<> negateV t) = id+-- @+--+-- Law+--+-- @+-- onset (delay n a)       = n ^+. onset a+-- offset (delay n a)      = n ^+. offset a+-- duration (stretch n a)  = n * duration a+-- duration (compress n a) = duration a / n+-- @+--+-- @+-- delay n b ! t    = b ! (t .-^ n)+-- undelay n b ! t  = b ! (t .+^ n)+-- @+--+-- Lemma+--+-- @+-- duration a = duration (delay n a)+-- @+--+class Transformable a where+  transform :: Span -> a -> a++instance Transformable () where+  transform _ = id++instance Transformable Bool where+  transform _ = id++instance Transformable Ordering where+  transform _ = id++instance Transformable Char where+  transform _ = id++instance Transformable Int where+  transform _ = id++instance Transformable Integer where+  transform _ = id++instance Transformable a => Transformable (Ratio a) where+  transform _ = id++instance Transformable Float where+  transform _ = id++instance Transformable Double where+  transform _ = id++instance Transformable Duration where+  (view delta -> (_, d1)) `transform` d2 = d1 * d2++instance Transformable Time where+  (view delta -> (t1, d1)) `transform` t2 = t1 ^+^ d1 *^ t2++instance Transformable Span where+  transform = (<>)++instance Transformable a => Transformable (Option a) where+  transform s = fmap (transform s)++instance Transformable a => Transformable (Last a) where+  transform s = fmap (transform s)++instance Transformable a => Transformable (Sum a) where+  transform s = fmap (transform s)++instance Transformable a => Transformable (Product a) where+  transform s = fmap (transform s)++-- |+-- Apply the inverse of the given transformation.+--+-- @+-- 'itransform' s = 'transform' ('negateV' s)+-- @+--+itransform :: Transformable a => Span -> a -> a+itransform s = transform (negateV s)++-- |+-- View the given value in the context of the given transformation.+--+-- @+-- 'over' ('transformed' s) = (``whilst`` s)+-- @+--+transformed :: Transformable a => Span -> Iso' a a+transformed s = iso (transform s) (itransform s)++--+-- TODO+--+-- Should really transform the /second/ element, but this is incompatible with Note/SCcore+--+-- 1) Change this to transform both components+--    Then Note could be defined as   type Note a = (Span, TransfInv a)+--+-- 2) Redefine note as                type Note a = (a, Span)+--+instance Transformable a => Transformable (b, a) where+  transform t (s,a) = (s, transform t a)++-- |+-- Lists transform by transforming each element.+--+instance Transformable a => Transformable [a] where+  transform t = map (transform t)++instance Transformable a => Transformable (Seq a) where+  transform t = fmap (transform t)++instance (Ord k, Transformable a) => Transformable (Map k a) where+  transform t = Map.map (transform t)++-- |+-- Functions transform by conjugation, i.e. we reverse-transform the argument+-- and transform the result.+--+instance (Transformable a, Transformable b) => Transformable (a -> b) where+  transform t = (`whilst` negateV t)++-- |+-- A transformation that moves a value forward in time.+--+delaying :: Duration -> Span+delaying x = (0 .+^ x) >-> 1++-- |+-- A transformation that stretches (augments) a value by the given factor.+--+stretching :: Duration -> Span+stretching x = 0 >-> x++-- |+-- A transformation that moves a value backward in time.+--+undelaying :: Duration -> Span+undelaying x = delaying (negate x)++-- |+-- A transformation that compresses (diminishes) a value by the given factor.+--+compressing :: Duration -> Span+compressing x = stretching (recip x)++-- |+-- Moves a value forward in time.+--+delay :: Transformable a => Duration -> a -> a+delay = transform . delaying++-- |+-- Moves a value backward in time. Equnitvalent to @'stretch' . 'negate'@.+--+undelay :: Transformable a => Duration -> a -> a+undelay = transform . undelaying++-- |+-- Stretches (augments) a value by the given factor.+--+stretch :: Transformable a => Duration -> a -> a+stretch = transform . stretching++-- |+-- Compresses (diminishes) a score. Equnitvalent to @'stretch' . 'recip'@.+--+compress :: Transformable a => Duration -> a -> a+compress = transform . compressing+++-- |+-- Delay relative to 'origin'.+--+-- Provided for situations when we really want to use 'startAt', but the+-- type does not have an instance for 'HasPosition' and we can assume that+-- the value is starting at time zero.+--+delayTime :: Transformable a => Time -> a -> a+delayTime t = delay (t .-. 0)++++--+-- $musicTimeSpanConstruct+--+-- - To convert a span to a pair, use @s^.'delta'@.+-- - To construct a span from a pair, use @(t, d)^.'from' 'delta'@.+--++--+-- $musicTimeSpanLaws+--+-- > forall s . id `whilst` s = id+-- > forall s . return `whilstM` s = return+-- > forall s . extract `whilstW` s = extract+++-- We really must flip all these functions. To do:+--+--    1) Come up with some other name for the infix version+--    2) Acknowledge that this is a valid Lens (when flipped)+--+-- 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++-- |+-- Apply a morphism under transformation (monadic version).+--++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)+-}+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++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++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+++-- |+-- Apply a function under transformation.+--+whilstDelay :: (Transformable a, Transformable b) => (a -> b) -> Time -> a -> b+whilstDelay     = flip (flip whilst . delaying . (.-. 0))++-- |+-- Apply a function under transformation.+--+whilstStretch :: (Transformable a, Transformable b) => (a -> b) -> Duration -> a -> b+whilstStretch = flip (flip whilst . stretching)++-- |+-- The conjugate of two spans.+--+conjugateS :: Span -> Span -> Span+conjugateS t1 t2  = negateV t1 <> t2 <> t1+++-- |+-- 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)+-- @+--+onSpan :: (Transformable a, Functor f) => LensLike' f a b -> Span -> LensLike' f a b+f `onSpan` s = spanned s . f+-- TODO name++-- TODO move!+deriving instance Functor Sum+deriving instance Functor Product+
+ src/Music/Time/Internal/Util.hs view
@@ -0,0 +1,373 @@++{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ViewPatterns #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------++module Music.Time.Internal.Util where++{-+    Rules:+    +        * Functions may depend on any module in the lastest Haskell Platform release+        * All functions but those in Prelude must be referred to with their full,+          qualified names (i.e. Data.List.unfoldr).+        * Each function must have a unique name (so the whole file is a loadable module).+        * Each function should have a synopisis, like:++            -- | Ordinary Haddock commentary ...+            -- > category: Categories (please use the common Hackage names)+            -- > depends : base (all packages in HP that the function depends on)+            +-}++import Control.Lens+import Control.Monad.Plus+import Control.Applicative+import qualified Data.Char+import qualified Data.Monoid+import qualified Data.List+import qualified Data.Ratio+import Data.Functor.Contravariant++-- | Divide a list into parts of maximum length n.+-- > category : List+-- > depends : base+divideList :: Int -> [a] -> [[a]]+divideList n xs+    | length xs <= n = [xs]+    | otherwise = [take n xs] ++ (divideList n $ drop n xs)++-- | Group a list into sublists whereever a predicate holds. The matched element+--   is the first in the sublist.+--+--   > splitWhile isSpace "foo bar baz"+--   >    ===> ["foo"," bar"," baz"]+--   >+--   > splitWhile (> 3) [1,5,4,7,0,1,2]+--   >    ===> [[1],[5],[4],[7,0,1,2]]+--+-- > category : List+-- > depends : base+splitWhile :: (a -> Bool) -> [a] -> [[a]]+splitWhile p xs = case splitWhile' p xs of+    []:xss -> xss+    xss    -> xss+    where+        splitWhile' p []     = [[]]+        splitWhile' p (x:xs) = case splitWhile' p xs of+            (xs:xss) -> if p x then []:(x:xs):xss else (x:xs):xss+++-- | Break up a list into parts of maximum length n, inserting the given list as separator.+--   Useful for breaking up strings, as in @breakList 80 "\n" str@.+--+-- > category : List+-- > depends : base+breakList :: Int -> [a] -> [a] -> [a]+breakList n z = Data.Monoid.mconcat . Data.List.intersperse z . divideList n++-- | Map over the indices and elements of list.+-- > category : List+-- > depends : base+mapIndexed :: (Int -> a -> b) -> [a] -> [b]+mapIndexed f as = map (uncurry f) (zip is as)+    where+        n  = length as - 1+        is = [0..n]+        +-- test++-- | Duplicate an element.+-- > category: Combinator, Tuple+-- > depends: base+dup :: a -> (a,a)+dup x = (x,x)++-- | Unfold a partial function. This is a simpler version of 'Data.List.unfoldr'. +-- > category: Function, List+-- > depends: base+unf :: (a -> Maybe a) -> a -> [a]+unf f = Data.List.unfoldr (fmap dup . f)++-- |+-- Map over first elements of a list.+-- Biased on first element for shorter lists.+-- > category: List+-- > depends: base+mapF f = mapFTL f id id++-- |+-- Map over all but the first and last elements of a list.+-- Biased on middle elements for shorter lists.+-- > category: List+-- > depends: base+mapT f = mapFTL id f id++-- |+-- Map over last elements of a list.+-- Biased on last element for shorter lists.+-- > category: List+-- > depends: base+mapL f = mapFTL id id f++-- |+-- Map over first, middle and last elements of list.+-- Biased on first, then on first and last for short lists.+--+-- > category: List+-- > depends: base+mapFTL :: (a -> b) -> (a -> b) -> (a -> b) -> [a] -> [b]+mapFTL f g h = go+    where+        go []    = []+        go [a]   = [f a]+        go [a,b] = [f a, h b]+        go xs    = [f $ head xs]          ++ +                   map g (tail $ init xs) ++ +                   [h $ last xs]++-- |+-- Extract the first consecutive sublist for which the predicate returns true, or+-- the empty list if no such sublist exists.+-- > category: List+-- > depends: base+filterOnce :: (a -> Bool) -> [a] -> [a]+filterOnce p = Data.List.takeWhile p . Data.List.dropWhile (not . p)+++-- | Returns all rotations of the given list. Given an infinite list, returns an infinite+-- list of rotated infinite lists.+-- > category: List+-- > depends: base+rots :: [a] -> [[a]]+rots xs = init (zipWith (++) (Data.List.tails xs) (Data.List.inits xs))++-- |+-- > category: List+-- > depends: base+rotl :: [a] -> [a]+rotl []     = []+rotl (x:xs) = xs ++ [x]++-- |+-- > category: List+-- > depends: base+rotr :: [a] -> [a]+rotr [] = []+rotr xs = last xs : init xs++-- |+-- > category: List+-- > depends: base+rotated :: Int -> [a] -> [a]+rotated = go+    where+        go n as +            | n >= 0 = iterate rotr as !! n+            | n <  0 = iterate rotl as !! abs n+++curry3 :: ((a, b, c) -> d) -> a -> b -> c -> d+curry3 = curry . curry . (. tripl)++uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d+uncurry3 = (. untripl) . uncurry . uncurry++untripl :: (a,b,c) -> ((a,b),c)+untripl (a,b,c) = ((a,b),c)++tripl :: ((a,b),c) -> (a,b,c)+tripl ((a,b),c) = (a,b,c)++tripr :: (a,(b,c)) -> (a,b,c)+tripr (a,(b,c)) = (a,b,c)+++-- TODO mo+partial2 :: (a -> b      -> Bool) -> a -> b      -> Maybe b+partial3 :: (a -> b -> c -> Bool) -> a -> b -> c -> Maybe c+partial2 f = curry  (fmap snd  . partial (uncurry f))+partial3 f = curry3 (fmap (view _3) . partial (uncurry3 f))++-- | Case matching on lists.+-- > category: List+-- > depends: base+list :: r -> ([a] -> r) -> [a] -> r+list z f [] = z+list z f xs = f xs++-- | Merge lists.+-- > category: List+-- > depends: base+merge :: Ord a => [a] -> [a] -> [a]+merge = mergeBy compare++-- | Merge lists.+-- > category: List+-- > depends: base+mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a]+mergeBy f = mergeBy' $ (fmap.fmap) orderingToBool f+    where+        orderingToBool LT = True+        orderingToBool EQ = True+        orderingToBool GT = False++mergeBy' :: (a -> a -> Bool) -> [a] -> [a] -> [a]+mergeBy' pred xs []         = xs+mergeBy' pred [] ys         = ys+mergeBy' pred (x:xs) (y:ys) =+    case pred x y of+        True  -> x: mergeBy' pred xs (y:ys)+        False -> y: mergeBy' pred (x:xs) ys++-- | Compose all functions.+-- > category: Function+-- > depends: base+composed :: [b -> b] -> b -> b+composed = Prelude.foldr (.) id++-- | Separate a ratio.+-- > category: Math+-- > depends: base+unRatio :: Integral a => Data.Ratio.Ratio a -> (a, a)+unRatio x = (Data.Ratio.numerator x, Data.Ratio.denominator x)++-- | Nicer printing of ratio as ordinary fractions.+-- > category: Math+-- > depends: base+showRatio :: (Integral a, Show a) => Data.Ratio.Ratio a -> String+showRatio (realToFrac -> (unRatio -> (x, 1))) = show x+showRatio (realToFrac -> (unRatio -> (x, y))) = "(" ++ show x ++ "/" ++ show y ++ ")"+++-- Replace all contigous ranges of equal values with [Just x, Nothing, Nothing ...]+-- > category: List+-- > depends: base+retainUpdates :: Eq a => [a] -> [Maybe a]+retainUpdates = snd . Data.List.mapAccumL g Nothing where+    g Nothing  x = (Just x, Just x)+    g (Just p) x = (Just x, if p == x then Nothing else Just x)+++-- Generic version of 'replicate'.+-- > category: List+-- > depends: base+replic :: Integral a => a -> b -> [b]+replic n = replicate (fromIntegral n)++-- Swap components.+-- > category: Tuple+-- > depends: base+swap :: (a, b) -> (b, a)+swap (x, y) = (y, x)++-- Interleave a list with the next consecutive element.+--+-- For any xs+--+-- > lenght xs == length (withNext xs)+--+-- If @xs@ is a finite list+--+-- > isNothing  $ snd $ last $ withNext xs == True+-- > all isJust $ snd $ init $ withNext xs == True+--+-- If @xs@ is an infinite list+--+-- > all isJust $ snd $ withNext xs == True+--+-- > category: List+-- > depends: base+withNext :: [a] -> [(a, Maybe a)]+withNext = fmap (\(p,c,n) -> (c,n)) . withPrevNext++withPrev :: [a] -> [(Maybe a, a)]+withPrev = fmap (\(p,c,n) -> (p,c)) . withPrevNext++-- withNext = go+--     where+--         go []       = []+--         go [x]      = [(x, Nothing)]+--         go (x:y:rs) = (x, Just y) : withNext (y : rs)++withPrevNext :: [a] -> [(Maybe a, a, Maybe a)]+withPrevNext xs = zip3 (pure Nothing ++ fmap Just xs) xs (fmap Just (tail xs) ++ repeat Nothing)++-- Map over a list with the next consecutive element.+--+-- > category: List+-- > depends: base+mapWithNext :: (a -> Maybe a -> b) -> [a] -> [b]+mapWithNext f = map (uncurry f) . withNext++mapWithPrev :: (Maybe a -> a -> b) -> [a] -> [b]+mapWithPrev f = map (uncurry f) . withPrev++mapWithPrevNext :: (Maybe a -> a -> Maybe a -> b) -> [a] -> [b]+mapWithPrevNext f = map (uncurry3 f) . withPrevNext++-- |+-- Rotate a list.+--+-- > rotate n xs == id iff (n `mod` length xs) == 0+-- > rotate (-n) . rotate n == id+rotate :: Int -> [a] -> [a]+rotate n xs = drop n' xs ++ take n' xs+  where+    n' = negate n `mod` length xs++--------++++++++toDouble :: Real a => a -> Double+toDouble = realToFrac++through :: Applicative f => +  Lens' s a +  -> Lens s t a b +  -> Lens (f s) (f t) (f a) (f b)+through lens1 lens2 = lens getter (flip setter)+  where+    getter = fmap (view lens1)+    setter = liftA2 (over lens2 . const)+{-# INLINE through #-}++single :: Prism' [a] a+single = prism' return $ \xs -> case xs of+  [x] -> Just x+  _   -> Nothing+{-# INLINE single #-}++tripped :: Iso ((a, b), c) ((a', b'), c') (a, b, c) (a', b', c')+tripped = iso tripl untripl+{-# INLINE tripped #-}++floor' :: RealFrac a => a -> a+floor' = fromIntegral . floor++-- Like Data.Ord.comparing+-- (Are both variants of contramap?)+inspecting :: Eq a => (b -> a) -> b -> b -> Bool+inspecting f x y = f x == f y++inspectingBy :: (b -> a) -> (a -> a -> Bool) -> (b -> b -> Bool)+inspectingBy f e = getEquivalence $ contramap f $ Equivalence e+-- inspectingBy f p x y = f x `p` f y+
src/Music/Time/Juxtapose.hs view
@@ -1,14 +1,18 @@ -{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE ConstraintKinds           #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TupleSections             #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE UndecidableInstances      #-}  ------------------------------------------------------------------------------------- -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund 2012-2014 -- -- License     : BSD-style --@@ -19,131 +23,151 @@ -------------------------------------------------------------------------------------  module Music.Time.Juxtapose (-        -- * Prerequisites-        Transformable(..),+       -- * Align without composition+        lead,+        follow, -        -- ** Juxtaposing values-        following,-        preceding,+        -- * Standard composition+        after,+        before,         during,--        -- * Composing values         (|>),-        (>|),         (<|),-        scat,-        pcat, -        -- ** Special composition+        -- ** More exotic         sustain,-        anticipate,+        palindrome, -        -- ** Repetition+        -- * Catenation+        scat,+        pcat,++        -- * Repetition         times,-        repeated,-        group,   ) where -+import           Control.Lens hiding ((|>), (<|)) import           Data.AffineSpace import           Data.AffineSpace.Point-import           Data.Monoid.WithSemigroup+-- import           Data.Monoid.WithSemigroup import           Data.Semigroup import           Data.VectorSpace -import           Music.Time.Delayable-import           Music.Time.Onset-import           Music.Time.Stretchable-import           Music.Time.Time+import           Music.Time.Reverse+import           Music.Time.Split --- |--- This pseudo-class gathers the restrictions needed to implement position a value at--- any point and duration in time.----type Transformable a   =  (Stretchable a, Delayable a) +--+-- TODO names+-- Especially 'after' is counter-intuitive+-- ----------------------------------------------------------------------------------------- Juxtaposition--------------------------------------------------------------------------------------+-- |+-- Move a value so that+--+-- @+-- '_offset' (a ``lead`` b) = '_onset' b+-- @+--+--+lead   :: (HasPosition a, HasPosition b, Transformable a) => a -> b -> a+a `lead` b   = placeAt 1 (b `_position` 0) a  -- |--- @a \`following\` b@ moves score /b/ so that its onset is at the offset of score--- /a/ and returns the moved score.+-- Move a value so that ---following :: (HasOffset a, Delayable b, HasOnset b) => a -> b -> b-a `following` b =  startAt (offset a) b+-- @+-- '_offset' a = '_onset' (a ``follow`` b)+-- @+--+follow :: (HasPosition a, HasPosition b, Transformable b) => a -> b -> b+a `follow` b = placeAt 0 (a `_position` 1) b  -- |--- @a \`preceding\` b@ moves score /a/ so that its offset is at the onset of score--- /b/ and returns the moved score.+-- Move a value so that ---preceding :: (Delayable a, HasOffset a, HasOnset b) => a -> b -> a-a `preceding` b =  stopAt (onset b) a+after :: (Semigroup a, Transformable a, HasPosition a) => a -> a -> a+a `after` b =  a <> (a `follow` b) --- | @a \`during\` b@ places /a/ at the same era as /b/ and returns the moved score.-during :: (Delayable a, Stretchable a, HasOnset a, HasDuration a, HasOnset b, HasDuration b) => a -> b -> a-a `during` b = startAt (onset b) $ stretchTo (duration b) a+-- |+-- Move a value so that+--+before :: (Semigroup a, Transformable a, HasPosition a) => a -> a -> a+a `before` b =  (a `lead` b) <> b ----------------------------------------------------------------------------------------- Composition--------------------------------------------------------------------------------------+-- |+-- A value followed by its reverse (retrograde).+--+palindrome :: (Semigroup a, Reversible a, HasPosition a) => a -> a+palindrome a = a `after` rev a  infixr 6 |>-infixr 6 >| infixr 6 <|  -- |--- Compose in sequence.------ @a |> b@ moves score /b/ as per 'following' and then composes the resulting scores with '<>'.------ > Score a -> Score a -> Score a+-- An infix alias for 'after'. ---(|>)            :: (Semigroup a, HasOnset a, HasOffset a, Delayable a) =>-                a -> a -> a+(|>) :: (Semigroup a, HasPosition a, Transformable a) => a -> a -> a+(|>) = after+ -- |--- Compose in sequence.+-- An infix alias for 'before'. ----- @a >| b@ moves score /a/ as per 'preceding' and then composes the resulting scores with '<>'.+(<|) :: (Semigroup a, HasPosition a, Transformable a) => a -> a -> a+(<|) = before++-- infixr 6 >|+-- infixr 6 |<++-- |+-- Compose a list of sequential objects, with onset and offset tangent to one another. ----- > Score a -> Score a -> Score a+-- For non-positioned types, this is the often same as 'mconcat'+-- For positioned types, this is the same as 'afterAnother' ---(>|)            :: (Semigroup a, HasOnset a, HasOffset a, Delayable a) =>-                a -> a -> a+scat :: (Semigroup a, Monoid a, HasPosition a, Transformable a) => [a] -> a+scat = Prelude.foldr (|>) mempty  -- |--- Compose in reverse sequence.------ To compose in parallel, use '<>'.+-- Compose a list of parallel objects, so that their local origins align. ----- > Score a -> Score a -> Score a+-- This not possible for non-positioned types, as they have no notion of an origin.+-- For positioned types this is the same as 'mconcat'. ---(<|)            :: (Semigroup a, HasOnset a, HasOffset a, Delayable a) =>-                a -> a -> a--a |> b =  a <> (a `following` b)-a >| b =  (a `preceding` b) <> b-a <| b =  b |> a+pcat :: (Semigroup a, Monoid a) => [a] -> a+pcat = Prelude.foldr (<>) mempty  -- |--- Sequential catenation.+-- Move a value so that its era is equal to the era of another value. ----- > [Score a] -> Score a+-- @+-- 'Score' a -> 'Score' a -> 'Score' a+-- @ ---scat            :: (Monoid' a, HasOnset a, HasOffset a, Delayable a) =>-                [a] -> a+during :: (HasPosition a, HasPosition b, Transformable a, Transformable b) => a -> b -> a+y `during` x = set era (view era x) y+ -- |--- Parallel catenation.+-- Like '<>', but scaling the second agument to the duration of the first. ----- > [Score a] -> Score a+-- @+-- 'Score' a -> 'Score' a -> 'Score' a+-- @ ---pcat            :: Monoid' a =>-                [a] -> a+sustain :: (Semigroup a, HasPosition a, Transformable a) => a -> a -> a+x `sustain` y = x <> y `during` x -scat = Prelude.foldr (|>) mempty-pcat = Prelude.foldr (<>) mempty+-- |+-- Repeat exact amount of times.+--+-- @+-- 'Int' -> 'Score' a -> 'Score' a+-- @+--+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.@@ -167,20 +191,7 @@ -- Like '<>', but truncating the second agument to the duration of the first. -- prolong x y = x <> before (duration x) y ---- ----------------------------------------------------------------------------------- -- Structure--- --------------------------------------------------------------------------------- -- |--- Repeat exact amount of times.------ > Duration -> Score Note -> Score Note----times           :: (Monoid' a, Transformable a, HasOnset a, HasOffset a) =>-                Int -> a -> a---- | -- Repeat once for each element in the list. -- -- Example:@@ -205,4 +216,5 @@ times n     = scat . replicate n repeated    = flip (\f -> scat . fmap f) group n     = times n . (fromIntegral n `compress`)+-}
+ src/Music/Time/Meta.hs view
@@ -0,0 +1,172 @@++{-# 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+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-- Provides meta-information.+--+-- Each score supports an unlimited number of 'Reactive' meta-values.+--+-- This is more or less based on Diagrams styles, which is in turn based+-- on XMonad.+--+-------------------------------------------------------------------------------------++module Music.Time.Meta (+        -- * Attributes+        IsAttribute,+        Attribute,+        +        -- ** Creating attributes+        wrapAttr,+        wrapTAttr,+        unwrapAttr,+        unwrapTAttr,++        -- * Meta-data+        Meta,++        -- ** Creating meta-data+        toMeta,+        fromMeta,++        -- ** The HasMeta class+        HasMeta(..),+        applyMeta,+  ) where++-- import           Control.Applicative+-- import           Control.Arrow+import           Control.Lens              hiding (transform)+import           Control.Monad.Plus+import           Data.Foldable             (Foldable)+import qualified Data.Foldable             as F+import qualified Data.List                 as List+import           Data.Map                  (Map)+import qualified Data.Map                  as Map+import           Data.Maybe+-- import           Data.Monoid.WithSemigroup+import           Data.Semigroup+import           Data.Set                  (Set)+import qualified Data.Set                  as Set+import           Data.String+-- import           Data.Traversable          (Traversable)+-- import qualified Data.Traversable          as T+import           Data.Typeable+import           Data.Void++-- import           Music.Score.Part+import           Music.Time.Internal.Util+import           Music.Time.Reverse+import           Music.Time.Split+import           Music.Time.Transform++type IsAttribute a = (Typeable a, Monoid a, Semigroup a)++-- | An existential wrapper type to hold attributes.+data Attribute :: * where+  Attribute  :: IsAttribute a => a -> Attribute+  TAttribute :: (Transformable a, IsAttribute a) => a -> Attribute++wrapAttr :: IsAttribute a => a -> Attribute+wrapAttr = Attribute++unwrapAttr :: IsAttribute a => Attribute -> Maybe a+unwrapAttr (Attribute a) = cast a++wrapTAttr :: (Transformable a, IsAttribute a) => a -> Attribute+wrapTAttr = TAttribute++unwrapTAttr :: (Transformable a, IsAttribute a) => Attribute -> Maybe a+unwrapTAttr (TAttribute a) = cast a++instance Semigroup Attribute where+  (Attribute a1) <> a2 = case unwrapAttr a2 of+    -- Nothing  -> a2+    Nothing  -> error "Attribute.(<>) mismatch"+    Just a2' -> Attribute (a1 <> a2')+  (TAttribute a1) <> a2 = case unwrapTAttr a2 of+    -- Nothing  -> a2+    Nothing  -> error "Attribute.(<>) mismatch"+    Just a2' -> TAttribute (a1 <> a2')++instance Transformable Attribute where+  transform _ (Attribute a) = Attribute a+  transform s (TAttribute a) = TAttribute (transform s a)++instance Splittable Attribute where+  split _ x = (x,x)++instance Reversible Attribute where+  rev = id++-- Meta is Transformable because the contents of the map is transformable+newtype Meta = Meta (Map String Attribute)+  deriving (Transformable, Reversible, Splittable)++instance Semigroup Meta where+  Meta s1 <> Meta s2 = Meta $ Map.unionWith (<>) s1 s2++-- | The empty meta contains no attributes; composition of metas is+--   a union of attributes; if the two metas have attributes of the+--   same type they are combined according to their semigroup+--   structure.+instance Monoid Meta where+  mempty = Meta Map.empty+  mappend = (<>)++instance HasMeta Meta where+  meta = ($)++--+-- TODO+-- Temporarily disabling part specific meta-events+-- The API still works, but all parts are merged together+--++toMeta :: forall a b . ({-HasPart' a, -}IsAttribute b, Transformable b) => Maybe a -> b -> Meta+toMeta partId a = Meta $ Map.singleton key $ wrapTAttr a+  where+    key = ty ++ pt+    pt = ""+    -- pt = show $ fmap getPart partId+    ty = show $ typeOf (undefined :: b)++fromMeta :: forall a b . ({-HasPart' a, -}IsAttribute b, Transformable b) => Maybe a -> Meta -> Maybe b+fromMeta partId (Meta s) = (unwrapTAttr =<<) $ Map.lookup key s+-- Note: unwrapAttr should never fail+  where+    key = ty ++ pt+    pt = ""+    -- pt = show $ fmap getPart partId+    ty = show . typeOf $ (undefined :: b)+++-- | Type class for things which have meta-information.+class HasMeta a where+  -- | Apply meta-information by combining it (on the left) with the+  --   existing meta-information.+  meta :: Lens' a Meta++applyMeta :: HasMeta a => Meta -> a -> a+applyMeta m = (meta <>~ m)+
+ src/Music/Time/Note.hs view
@@ -0,0 +1,158 @@++{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE ViewPatterns               #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------++module Music.Time.Note (+        -- * Note type+        Note,++        -- * Construction+        note,+        event,+        noteValue,      +  ) where++import           Data.AffineSpace+import           Data.AffineSpace.Point+import           Data.Map               (Map)+import qualified Data.Map               as Map+import           Data.Ratio+import           Data.Semigroup+import           Data.Set               (Set)+import qualified Data.Set               as Set+import           Data.VectorSpace++import           Music.Time.Reverse+import           Music.Time.Split++import           Control.Applicative+import           Control.Arrow          (first, second, (&&&), (***))+import           Control.Comonad+import           Control.Comonad.Env+import           Control.Lens           hiding (Indexable, Level, above, below,+                                         index, inside, parts, reversed,+                                         transform, (<|), (|>))+import           Data.Foldable          (Foldable)+import qualified Data.Foldable          as Foldable+import           Data.PairMonad+import           Data.Typeable+import           Music.Time.Internal.Util (through, tripped)++-- |+-- A 'Note' is a value with an 'onset' and and 'offset' in time. It is an instance+-- of 'Transformable'.+--+-- You can use 'value' to apply a function in the context of the transformation,+-- i.e.+--+-- @+-- over value (* line) (delay 2 $ return line)+-- @+--+-- @+-- ('view' 'value') . 'transform' s = 'transform' s . ('view' 'value')+-- @+--+-- The semantics are given by+--+-- @+-- type Note a = (Span, a)+-- @+--+newtype Note a = Note { _noteValue :: (Span, a) }+  deriving (Typeable)++deriving instance Eq a => Eq (Note a)+deriving instance Functor Note+deriving instance Foldable Note+deriving instance Traversable Note+deriving instance Comonad Note++instance (Show a, Transformable a) => Show (Note a) where+  show x = show (x^.from note) ++ "^.note"++-- |+-- Note is a 'Monad' and 'Applicative' in the style of pair, with 'return' placing a value+-- at the default span 'mempty' and 'join' composing time transformations.+deriving instance Monad Note+deriving instance Applicative Note++-- 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++instance Rewrapped (Note a) (Note b)++instance Transformable (Note a) where+  transform t = over _Wrapped $ first (transform t)++instance HasDuration (Note a) where+  _duration = _duration . ask . view _Wrapped++instance HasPosition (Note a) where+  x `_position` p = ask (view _Wrapped x) `_position` p++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)++instance Reversible (Note a) where+  rev = revDefault++-- |+-- View a note as a pair of the original value and the transformation (and vice versa).+--+note :: ({-Transformable a, Transformable b-}) => Iso (Span, a) (Span, b) (Note a) (Note b)+note = _Unwrapped++-- |+-- View the value in the note.+--+noteValue :: (Transformable a, Transformable b) => Lens (Note a) (Note b) a b+noteValue = lens runNote (flip $ mapNote . const)+  where+    runNote = uncurry transform . view _Wrapped+    -- setNote f (view (from note) -> (s,x)) = view note (s, itransform s x)+    mapNote f (view (from note) -> (s,x)) = view note (s, f `whilst` negateV s $ x)+{-# INLINE noteValue #-}++-- |+-- View a note as an events, i.e. a time-duration-value triplet.+--+event :: Iso (Note a) (Note b) (Time, Duration, a) (Time, Duration, b)+event = from note . bimapping delta id . tripped+++
− src/Music/Time/Onset.hs 
@@ -1,195 +0,0 @@--{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies               #-}------------------------------------------------------------------------------------------ |--- Copyright   : (c) Hans Hoglund 2012------ License     : BSD-style------ Maintainer  : hans@hanshoglund.se--- Stability   : experimental--- Portability : non-portable (TF,GNTD)------ This misleadingly named module provide a way to query a value for its---  'duration', 'onset' and 'offset'.-------------------------------------------------------------------------------------------module Music.Time.Onset (-        -- * Duration class-        HasDuration(..),-        stretchTo,--        -- * Onset and offset class-        HasOnset(..),-        HasOffset(..),-        startAt,-        stopAt,-        withSameOnset,-        withSameOffset,--        -- * Utility-        -- ** Default implementations-        durationDefault,-        onsetDefault,-        offsetDefault,-  ) where---import           Data.AffineSpace-import           Data.AffineSpace.Point-import           Data.Map               (Map)-import qualified Data.Map               as Map-import           Data.Semigroup-import           Data.Set               (Set)-import qualified Data.Set               as Set-import           Data.VectorSpace       hiding (Sum)--import           Music.Score.Util-import           Music.Time.Delayable-import           Music.Time.Stretchable-import           Music.Time.Time---- |--- Class of types with a duration.------ If a type has an instance for both 'HasOnset' and 'HasDuration', the following laws--- should hold:------ > duration a = offset a .-. onset a----class HasDuration a where-    duration :: a -> Duration--instance HasDuration Duration where-    duration = id--instance HasDuration (Duration, a) where-    duration = fst--instance HasDuration (Time, Duration, a) where-    duration (t,d,x) = d--instance HasDuration a => HasDuration (Product a) where-    duration (Product x) = duration x---- Works for monophonic containers but not in general--- instance HasDuration a => HasDuration [a] where-    -- duration = getSum . F.foldMap (Sum . duration)---- |--- Stretch a score to fit into the given duration.------ > Duration -> Score a -> Score a----stretchTo :: (Stretchable a, HasDuration a) => Duration -> a -> a---- |--- Class of types with a position in time.------ Onset and offset are logical start and stop time, i.e. the preferred beginning and end--- of the sound, not o the the time of the attack and damp actions on an instrument,------ If a type has an instance for both 'HasOnset' and 'HasDuration', the following laws--- should hold:------ > duration a = offset a .-- onset a----class HasOnset a where-    -- |-    -- Get the onset of the given value.-    ---    onset  :: a -> Time--class HasOffset a where-    -- |-    -- Get the offset of the given value.-    ---    offset :: a -> Time--instance HasOnset Time where-    onset = id--instance HasOnset (Time, a) where-    onset = fst--instance HasOnset (Time, Duration, a) where-    onset (t,d,x) = t--instance HasOffset (Time, Duration, a) where-    offset (t,d,x) = t .+^ d--instance HasOnset a => HasOnset [a] where-    onset = list origin (minimum . fmap onset)--instance HasOffset a => HasOffset [a] where-    offset = list origin (maximum . fmap offset)--instance HasOnset a => HasOnset (Set a) where-    onset = list origin (onset . head) . Set.toAscList--instance HasOffset a => HasOffset (Set a) where-    offset = list origin (offset . last) . Set.toAscList--instance HasOnset k => HasOnset (Map k a) where-    onset = list origin (onset . head) . Map.keys--instance HasOffset k => HasOffset (Map k a) where-    offset = list origin (offset . last) . Map.keys--instance HasOnset a => HasOnset (Sum a) where-    onset (Sum x) = onset x---- |--- Move a score so that its onset is at the specific time.------ > Time -> Score a -> Score a----startAt :: (HasOnset a, Delayable a) => Time ->  a -> a---- |--- Move a score so that its offset is at the specific time.------ > Time -> Score a -> Score a----stopAt :: (HasOffset a, Delayable a) => Time -> a -> a--t `stretchTo` x = (t / duration x) `stretch` x-t `startAt` x   = (t .-. onset x) `delay` x-t `stopAt`  x   = (t .-. offset x) `delay` x---- |--- Transform a score without affecting its onset.------ > Time -> Score a -> Score a----withSameOnset :: (Delayable a, HasOnset a, HasOnset b) => (b -> a) -> b -> a---- |--- Transform a score without affecting its offset.------ > Time -> Score a -> Score a----withSameOffset :: (Delayable a, HasOffset a, HasOffset b) => (b -> a) -> b -> a--withSameOnset f a  = startAt (onset a) $ f a-withSameOffset f a = stopAt (offset a) $ f a---- | Given 'HasOnset' and 'HasOffset' instances, this function implements 'duration'.-durationDefault :: (HasOffset a, HasOnset a) => a -> Duration-durationDefault x = offset x .-. onset x---- | Given 'HasDuration' and 'HasOffset' instances, this function implements 'onset'.-onsetDefault :: (HasOffset a, HasDuration a) => a -> Time-onsetDefault x = offset x .-^ duration x---- | Given 'HasOnset' and 'HasOnset' instances, this function implements 'offset'.-offsetDefault :: (HasOnset a, HasDuration a) => a -> Time-offsetDefault x = onset x .+^ duration x-
+ src/Music/Time/Position.hs view
@@ -0,0 +1,218 @@++{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE ViewPatterns               #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-- This misleadingly named module provide a way to query a value for its+--  'duration', 'onset' and 'offset'.+--+-------------------------------------------------------------------------------------++module Music.Time.Position (+      module Music.Time.Duration,++      -- * The HasPosition class+      HasPosition(..),+      -- * Inspecting position+      era,+      position,++      -- * Specific positions+      onset,+      offset,+      preOnset,+      postOnset,+      postOffset,++      -- * Moving to absolute positions+      startAt,+      stopAt,+      placeAt,++      -- * Internal+      -- TODO hide...+      _setEra,+      _getEra,+  ) where+++import           Data.AffineSpace+import           Data.AffineSpace.Point+import           Data.Map               (Map)+import qualified Data.Map               as Map+import           Data.Semigroup+import           Data.Set               (Set)+import qualified Data.Set               as Set+import           Data.VectorSpace       hiding (Sum)++import           Music.Time.Duration+import           Music.Time.Internal.Util++import           Control.Lens           hiding (Indexable, Level, above, below,+                                         index, inside, parts, reversed,+                                         transform, (<|), (|>))++-- |+-- Class of values that have a position in time.+--+-- Many values such as notes, envelopes etc can in fact have many positions such as onset,+-- attack point, offset, decay point time etc. Rather than having separate methods for a+-- discrete set of cases, this class provides an interpolation from a /local/ position to+-- a /global/ position. While the local position goes from 0 to 1, the global position+-- goes from the 'onset' to the 'offset' of the value.+--+-- For instantaneous values, a suitable instance is:+--+-- @+-- '_position' x = 'const' t+-- @+--+-- For values with an onset and offset we can use 'alerp':+--+-- @+-- '_position' x = 'alerp' ('_onset' x) ('_offset' x)+-- @+--+class HasDuration a => HasPosition a where+  -- |+  -- Return the onset of the given value, or the value between the attack and decay phases.+  --+  _position :: a -> Duration -> Time+  _position x = alerp (_onset x) (_offset x)++  -- |+  -- Return the onset of the given value, or the value between the attack and decay phases.+  --+  _onset, _offset :: a -> Time+  _onset     = (`_position` 0)+  _offset    = (`_position` 1.0)++instance HasPosition Time where+  _position = const++instance HasPosition Span where+  -- Override as an optimization:+  _onset    (view range -> (t1, t2)) = t1+  _offset   (view range -> (t1, t2)) = t2+  _position (view range -> (t1, t2)) = alerp t1 t2++instance (HasPosition a, HasDuration a) => HasDuration [a] where+  _duration x = _offset x .-. _onset x++instance (HasPosition a, HasDuration a) => HasPosition [a] where+  _onset  = foldr min 0 . fmap _onset+  _offset = foldr max 0 . fmap _offset++_getEra :: HasPosition a => a -> Span+_getEra x = _onset x <-> _offset x+{-# INLINE _getEra #-}++-- |+-- Position of the given value.+--+position :: (HasPosition a, Transformable a) => Duration -> Lens' a Time+position d = lens (`_position` d) (flip $ placeAt d)+{-# INLINE position #-}++-- |+-- Onset of the given value.+--+onset :: (HasPosition a, Transformable a) => Lens' a Time+onset = position 0+{-# INLINE onset #-}++-- |+-- Onset of the given value.+--+offset :: (HasPosition a, Transformable a) => Lens' a Time+offset = position 1+{-# INLINE offset #-}++-- |+-- Pre-onset of the given value, or the value right before the attack phase.+--+preOnset :: (HasPosition a, Transformable a) => Lens' a Time+preOnset = position (-0.5)+{-# INLINE preOnset #-}++-- |+-- Post-onset of the given value, or the value between the decay and sustain phases.+--+postOnset :: (HasPosition a, Transformable a) => Lens' a Time+postOnset = position 0.5+{-# INLINE postOnset #-}++-- |+-- Post-offset of the given value, or the value right after the release phase.+--+postOffset :: (HasPosition a, Transformable a) => Lens' a Time+postOffset = position 1.5+{-# INLINE postOffset #-}++++-- |+-- Move a value forward in time.+--+startAt :: (Transformable a, HasPosition a) => Time -> a -> a+startAt t x = (t .-. _onset x) `delay` x++-- |+-- Move a value forward in time.+--+stopAt  :: (Transformable a, HasPosition a) => Time -> a -> a+stopAt t x = (t .-. _offset x) `delay` x++-- |+-- Align a value to a given position.+--+-- @placeAt p t@ places the given thing so that its position p is at time t+--+-- @+-- 'placeAt' 0 = 'startAt'+-- 'placeAt' 1 = 'stopAt'+-- @+--+placeAt :: (Transformable a, HasPosition a) => Duration -> Time -> a -> a+placeAt p t x = (t .-. x `_position` p) `delay` x++-- |+-- Place a value over the given span.+--+-- @placeAt s t@ places the given thing so that @x^.place = s@+--+_setEra :: (HasPosition a, Transformable a) => Span -> a -> a+_setEra s x = transform (s ^-^ view era x) x++-- |+-- A lens to the position+--+era :: (HasPosition a, Transformable a) => Lens' a Span+era = lens _getEra (flip _setEra)+{-# INLINE era #-}++
src/Music/Time/Reactive.hs view
@@ -6,17 +6,17 @@ {-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GADTs                      #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-} {-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TemplateHaskell            #-} {-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE NoMonomorphismRestriction  #-} {-# LANGUAGE ViewPatterns               #-}  ------------------------------------------------------------------------------------- -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund 2012-2014 -- -- License     : BSD-style --@@ -24,6 +24,35 @@ -- Stability   : experimental -- Portability : non-portable (TF,GNTD) --+-------------------------------------------------------------------------------------++module Music.Time.Reactive (+        -- * Reactive type+        Reactive,+      +        -- * Construction+        initial,+        final,+        intermediate,+        discrete,+        updates,+        occs,+        atTime,+        splitReactive,+      +        -- * Combinators+        switchR,+        trimR,++        -- * Sampling and discretization+        continous,+        continousWith,+        sample,+        -- TODO+        -- window,+        -- windowed,   +  ) where+ -- Reactive values, or piecewise functions of time. -- -- Similar to Conal's definition in <http://conal.net/blog/posts/reactive-normal-form>,@@ -33,175 +62,94 @@ -- -- TODO integrate better in the library ---------------------------------------------------------------------------------------- -module Music.Time.Reactive (-        Reactive,+import           Music.Time.Behavior+import           Music.Time.Bound+import           Music.Time.Note+import           Music.Time.Reverse+import           Music.Time.Segment+import           Music.Time.Split -        -- * Create, isos etc (TODO)-        initial,-        updates,-        occs,-        -- final,-        -- Future,-        -- Past,-        -- resets,+import           Music.Pitch.Alterable+import           Music.Pitch.Augmentable+import           Music.Pitch.Literal -        -- * Predicates-        isConstant,-        isVariable, -        -- * Combinators-        -- step,--        switch,-        trim,-        -- trimBefore,-        -- trimAfter,--        -- * Semantics-        -- renderR,-        -- renderR',-        -- printR,-  ) where- import           Control.Applicative-import           Control.Arrow-import           Control.Lens+import           Control.Arrow           (first, second, (&&&), (***))+import           Control.Lens            hiding (Indexable, Level, above, below,+                                          index, inside, parts, reversed,+                                          transform, (<|), (|>)) import           Control.Monad-import           Control.Monad.Compose import           Control.Monad.Plus-import           Data.AffineSpace-import           Data.AffineSpace.Point-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.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.Distributive+import           Data.Functor.Rep+import           Data.Functor.Rep.Lens+import qualified Data.List               as List+import           Data.Semigroup          hiding () import           Data.Typeable-import           Data.VectorSpace--import           Music.Time.Delayable-import           Music.Time.Span-import           Music.Time.Stretchable-import           Music.Time.Time-import           Music.Time.Time--- import Music.Score.Note--- import Music.Score.Track--- import Music.Score.Pitch--- import Music.Score.Util--- import Music.Pitch.Literal--- import Music.Dynamics.Literal--newtype Reactive a = Reactive { getReactive :: ([Time], Time -> a) }-    deriving (Functor, Semigroup, Monoid)+import           Music.Dynamics.Literal+import           Music.Pitch.Literal -instance Delayable (Reactive a) where-    delay n (Reactive (t,r)) = Reactive (delay n t, delay n r)+-- |+-- Forms an applicative as per 'Behavior', but only switches at discrete points.+--+-- The semantics are given by+--+-- @+-- type Reactive a = (a, Time, Voice a)+-- @+--+newtype Reactive a = Reactive { getReactive :: ([Time], Behavior a) }+    deriving (Functor, Semigroup, Monoid, Typeable)+--+-- TODO Define a more compact representation and reimplement Behavior as (Reactive Segment).+--+-- Possible approach:+--+--  * Implement PosReactive (no negative values) and define Reactive = Delayed (PosReactive)+--+--  * Implement liftA2 for PosReactive (preferably with a single traversal)+-- -instance Stretchable (Reactive a) where-    stretch n (Reactive (t,r)) = Reactive (stretch n t, stretch n r)+instance Transformable (Reactive a) where+    transform s (Reactive (t,r)) = Reactive (transform s t, transform s r)  instance Wrapped (Reactive a) where-    type Unwrapped (Reactive a) = ([Time], Time -> a)+    type Unwrapped (Reactive a) = ([Time], Behavior a)     _Wrapped' = iso getReactive Reactive +instance Rewrapped (Reactive a) (Reactive b) instance Applicative Reactive where-    pure    = (^. _Unwrapped') . pure . pure-    ((^. _Wrapped') -> (tf, rf)) <*> ((^. _Wrapped') -> (tx, rx)) = (^. _Unwrapped') (tf <> tx, rf <*> rx)--instance HasBehavior Reactive where-    (?) = atTime--instance IsString a => IsString (Reactive a) where-    fromString = pure . fromString--instance Eq (Reactive b) where-    (==) = error "(==)"-    (/=) = error "(/=)"--instance Ord b => Ord (Reactive b) where-    min = liftA2 min-    max = liftA2 max--instance Enum a => Enum (Reactive a) where-    succ           = fmap succ-    pred           = fmap pred-    toEnum         = pure . toEnum-    fromEnum       = error "fromEnum"-    enumFrom       = error "enumFrom"-    enumFromThen   = error "enumFromThen"-    enumFromTo     = error "enumFromTo"-    enumFromThenTo = error "enumFromThenTo"--instance Num a => Num (Reactive a) where-    (+)         = liftA2 (+)-    (*)         = liftA2 (*)-    (-)         = liftA2 (-)-    abs         = fmap abs-    signum      = fmap signum-    fromInteger = pure . fromInteger--instance (Num a, Ord a) => Real (Reactive a) where-  toRational = error "toRational"+    pure  = pureDefault+    (<*>) = apDefault -instance Integral a => Integral (Reactive a) where-    quot      = liftA2 quot-    rem       = liftA2 rem-    div       = liftA2 div-    mod       = liftA2 mod-    quotRem   = (fmap.fmap) unzip' (liftA2 quotRem)-    divMod    = (fmap.fmap) unzip' (liftA2 divMod)-    toInteger = error "toInteger"+instance IsPitch a => IsPitch (Reactive a) where+  fromPitch = pure . fromPitch -instance Fractional b => Fractional (Reactive b) where-    recip        = fmap recip-    fromRational = pure . fromRational+instance IsInterval a => IsInterval (Reactive a) where+  fromInterval = pure . fromInterval -instance Floating b => Floating (Reactive b) where-    pi    = pure pi-    sqrt  = fmap sqrt-    exp   = fmap exp-    log   = fmap log-    sin   = fmap sin-    cos   = fmap cos-    asin  = fmap asin-    atan  = fmap atan-    acos  = fmap acos-    sinh  = fmap sinh-    cosh  = fmap cosh-    asinh = fmap asinh-    atanh = fmap atanh-    acosh = fmap acosh+instance IsDynamics a => IsDynamics (Reactive a) where+  fromDynamics = pure . fromDynamics -instance AdditiveGroup v => AdditiveGroup (Reactive v) where-    zeroV   = pure   zeroV-    (^+^)   = liftA2 (^+^)-    negateV = liftA   negateV+instance Alterable a => Alterable (Reactive a) where+    sharpen = fmap sharpen+    flatten = fmap flatten -instance VectorSpace v => VectorSpace (Reactive v) where-    type Scalar (Reactive v) = Scalar v-    (*^) s = fmap (s *^)+instance Augmentable a => Augmentable (Reactive a) where+    augment = fmap augment+    diminish = fmap diminish  --- | Get the time of all updatese.-occs :: Reactive a -> [Time]-occs = fst . (^. _Wrapped')---- | @b ?? t@ returns the value of the reactive at time @t@.---  Semantic function.-atTime :: Reactive a -> Time -> a-atTime = snd . (^. _Wrapped')+(view _Wrapped -> (tf, rf)) `apDefault` (view _Wrapped -> (tx, rx)) = view _Unwrapped (tf <> tx, rf <*> rx)+pureDefault = view _Unwrapped . pure . pure --- | Get the initial value.+-- |+-- Get the initial value.+-- initial :: Reactive a -> a-initial r = r ? minB (occs r)+initial r = r `atTime` minB (occs r)     where         -- If there are no updates, just use value at time 0         -- Otherwise pick an arbitrary time /before/ the first value@@ -210,64 +158,140 @@         minB (x:_) = x - 1  -- | Get the time of all updates and the value switched to at this point.-updates :: Reactive a -> [Future a]-updates r = (\t -> (t, r ? t)) <$> (List.sort . List.nub) (occs r)+updates :: Reactive a -> [(Time, a)]+updates r = (\t -> (t, r `atTime` t)) <$> (List.sort . List.nub) (occs r) --- | Get the final value.+renderR :: Reactive a -> (a, [(Time, a)])+renderR = initial &&& updates++occs :: Reactive a -> [Time]+occs = fst . (^. _Wrapped')++-- | Split a reactive into notes, 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)++{-# DEPRECATED updates "" #-}+{-# DEPRECATED occs "" #-}+{-# DEPRECATED splitReactive "" #-}+{-# DEPRECATED atTime "" #-}++atTime :: Reactive a -> Time -> a+atTime = (!) . snd . (^. _Wrapped')++-- |+-- Get the final value.+-- final :: Reactive a -> a final (renderR -> (i,[])) = i final (renderR -> (i,xs)) = snd $ last xs  -- | @switch t a b@ behaves as @a@ before time @t@, then as @b@.-switch :: Time -> Reactive a -> Reactive a -> Reactive a-switch t (Reactive (tx, rx)) (Reactive (ty, ry)) = Reactive $ (,)-    (filter (< t) tx <> [t] <> filter (> t) ty)-    (\u -> if u < t then rx u else ry u)+switchR :: Time -> Reactive a -> Reactive a -> Reactive a+switchR t (Reactive (tx, bx)) (Reactive (ty, by)) = Reactive $ (,)+    (filter (< t) tx <> [t] <> filter (> t) ty) (switch t bx by) +trimR :: Monoid a => Span -> Reactive a -> Reactive a+trimR (view range -> (t, u)) x = switchR t mempty (switchR u x mempty) +-- |+-- Get all intermediate values.+--+intermediate :: Transformable a => Reactive a -> [Note a]+intermediate (updates -> []) = []+intermediate (updates -> xs) = fmap (\((t1, x), (t2, _)) -> (t1 <-> t2, x)^.note) $ withNext $ xs+  where+    withNext xs = zip xs (tail xs) --- TODO separate these with newtype-type Future a = (Time, a)-type Past   a = (Time, a)+-- |+-- Realize a 'Reactive' value as a discretely changing behavior.+--+discrete :: Reactive a -> Behavior a+discrete = continous . fmap pure -isConstant :: Reactive a -> Bool-isConstant = null . occs+-- |+-- Realize a 'Reactive' value as an continous behavior.+--+-- See also 'concatSegment' and 'concatB'.+--+continous :: Reactive (Segment a) -> Behavior a -isVariable :: Reactive a -> Bool-isVariable = not . isConstant+-- |+-- Realize a 'Reactive' value as an continous behavior.+--+-- See also 'concatSegment' and 'concatB'.+--+continousWith :: Segment (a -> b) -> Reactive a -> Behavior b+continousWith f x = continous $ liftA2 (<*>) (pure f) (fmap pure x) -resets :: Reactive a -> [Past a]-resets = error "resets: Not impl"+-- |+-- Sample a 'Behavior' into a reactive.+--+sample   :: [Time] -> Behavior a -> Reactive a --- | The unit step function, which goes from 0 to 1 at 'start'.-step :: (AdditiveGroup a, Fractional a) => Reactive a-step = switch start zeroV 1.0 -- TODO some overloaded unit+-- TODO linear approximation+(continous, sample) = error "Not implemented: (continous, sample)" --- | Replace everthing outside the given span by `mempty`.-trim :: Monoid a => Span -> Reactive a -> Reactive a-trim (view range -> (t,u)) = trimBefore t . trimAfter u --- | Replace everthing before the given time by `mempty`.-trimBefore :: Monoid a => Time -> Reactive a -> Reactive a-trimBefore start x = switch start mempty x+window :: [Time] -> Behavior a -> Reactive (Segment a)+windowed :: Iso (Behavior a) (Behavior b) (Reactive (Segment a)) (Reactive (Segment b))+(window, windowed) = error "Not implemented: (window, windowed)" --- | Replace everthing after the given time by `mempty`.-trimAfter :: Monoid a => Time -> Reactive a -> Reactive a-trimAfter stop x = switch stop x mempty+{- --- | Semantic function.-renderR :: Reactive a -> (a, [(Time, a)])-renderR = initial &&& updates+-- Fre monad of ?+{-+data Score s a+  = SOne a+  | SPlus s [Score a]+-}+newtype Trans s a = Trans (s, [a]) deriving (Functor)+instance Monoid s => Monad (Trans s) where+  return = Trans . return . return+  -- TODO the usual >>= --- | Semantic function.-renderR' :: Reactive a -> ([Time], Time -> a)-renderR' = occs &&& (?)+type Score s a = Free (Trans s) a +viewScore :: Monoid s => Score s a -> [(s, a)]+viewScore x = case retract x of+  Trans (s,as) -> zip (repeat s) as -printR :: Show a => Reactive a -> IO ()-printR r = let (x, xs) = renderR r in do-    print x-    mapM_ print xs -unzip' :: Functor f => f (a, b) -> (f a, f b)-unzip' r = (fst <$> r, snd <$> r)+-- Free monad of (a,a)+{-+data Tree a+  = One a+  | Plus (Tree a) (Tree a)+-}+data Pair a = Pair a a deriving (Functor)+newtype MaybePair a = MaybePair (Maybe (Pair a)) deriving (Functor) -- Use compose+type Tree a = Free MaybePair a++-- CPS-version of Tree+newtype Search a = Search { getSearch :: forall r . (a -> Tree r) -> Tree r }+   -}++
+ src/Music/Time/Rest.hs view
@@ -0,0 +1,44 @@++{-# LANGUAGE ConstraintKinds           #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TupleSections             #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE UndecidableInstances      #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-- Many time structures such as 'Score' allows for rests between notes. Generally rests+-- are simply treated as blank space, and thus have no duration. Sometimes it is useful+-- to represent rests explicitly, so this module provides an alias for 'pure' 'Nothing' that+-- can be used to that end.+--+-- To remove rests from a score, use 'mcatMaybes', for example:+--+-- > open $ mcatMaybes $ scat [c,d,rest^*2,e]^/8+--+-------------------------------------------------------------------------------------++module Music.Time.Rest (+        -- * Rests+        rest,+  ) where++import           Control.Applicative+import           Music.Time.Reverse+import           Music.Time.Split++rest :: Applicative f => f (Maybe a)+rest = pure Nothing
src/Music/Time/Reverse.hs view
@@ -1,9 +1,24 @@ +{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}  ------------------------------------------------------------------------------------- -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund 2012-2014 -- -- License     : BSD-style --@@ -16,14 +31,17 @@ -------------------------------------------------------------------------------------  module Music.Time.Reverse (-        -- * Reversible class+        module Music.Time.Position,++        -- * The Reversible class         Reversible(..), -        -- ** Utility-        NoRev(..),-        WithRev(..),-        withRev,-        fromWithRev,+        -- * Reversed values+        reversed,+        revDefault,++        -- * Utility+        NoReverse(..),   ) where  import           Data.AffineSpace@@ -36,13 +54,144 @@ import qualified Data.Set               as Set import           Data.VectorSpace -import           Music.Time.Delayable-import           Music.Time.Juxtapose-import           Music.Time.Onset-import           Music.Time.Stretchable-import           Music.Time.Time+import           Music.Time.Position +import           Control.Lens           hiding (Indexable, Level, above, below,+                                         index, inside, parts, reversed,+                                         transform, (<|), (|>))+import           Data.AffineSpace+import           Data.AffineSpace.Point+import           Data.Map               (Map)+import qualified Data.Map               as Map+import           Data.Semigroup         hiding ()+import           Data.Sequence          (Seq)+import qualified Data.Sequence          as Seq+import           Data.Typeable+import           Data.VectorSpace       hiding (Sum (..))+ -- |+-- Class of values that can be reversed (retrograded).+--+-- For positioned values succh as 'Note', the value is reversed relative to its middle point, i.e.+-- the onset value becomes the offset value and vice versa.+--+-- For non-positioned values such as 'Stretched', the value is reversed in-place.+--+-- FIXME Second law is incompatible with 'revDefault' (and the 'Span' definition below)+--+-- Law+--+-- @+-- 'rev' ('rev' a) = a+-- @+--+-- @+-- 'abs' ('_duration' x) = _duration ('rev' x)+-- @+--+-- @+-- 'rev' s ``transform`` a = 'rev' (s ``transform`` a)+-- @+--+-- or equivalently,+--+-- @+-- 'transform' . 'rev' = 'fmap' 'rev' . 'transform'+-- @+--+-- For 'Span'+--+-- @+-- 'rev' = 'over' 'range' 'swap'+-- @+--+class Transformable a => Reversible a where++  -- | Reverse (retrograde) the given value.+  rev :: a -> a++--+-- XXX Counter-intuitive Behavior instances (just Behavior should reverse around origin,+-- while Bound (Behavior a) should reverse around the middle, like a note)+--++--+-- XXX Alternate formulation of second Reversiblee law+--+--     rev s `transform` a     = rev (s `transform` a)+-- ==> (rev s `transform`)     = rev . (s `transform`)+-- ==> transform (rev s)       = rev . (transform s)+-- ==> (transform . rev) s     = (rev .) (transform s)+-- ==> (transform . rev) s     = fmap rev (transform s)+-- ==> transform . rev         = fmap rev . transform+--++instance Reversible () where+  rev = id++instance Reversible Int where+  rev = id++instance Reversible Double where+  rev = id++instance Reversible Integer where+  rev = id++instance Reversible a => Reversible [a] where+  rev = reverse . map rev++instance Reversible a => Reversible (Seq a) where+  rev = Seq.reverse . fmap rev++instance (Ord k, Reversible a) => Reversible (Map k a) where+  rev = Map.map rev++instance Reversible Duration where+  rev = stretch (-1)++--+-- There is no instance for Reversible Time+-- as we can not satisfy the second Reversible law+--++instance Reversible Span where+  rev = revDefault++instance Reversible a => Reversible (b, a) where+  rev (s,a) = (s, rev a)++-- |+-- A default implementation of 'rev'+--+revDefault :: (HasPosition a, Transformable a) => a -> a+-- 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)++instance Transformable (NoReverse a) where+  transform _ = id++instance Reversible (NoReverse a) where+  rev = id++-- |+-- View the reverse of a value.+--+-- >>> [1,2,3] & reversed %~ sort+-- > [3,2,1]+--+reversed :: Reversible a => Iso' a a+reversed = iso rev rev++++++{-+-- | -- Reversible values. -- -- For instances of 'Reversible' and 'HasOnset', the following laws should hold:@@ -63,6 +212,7 @@ -- >     rev = withSameOnset (stretch (-1)) -- --+ class Reversible a where      -- |@@ -115,5 +265,6 @@ instance Reversible a => Reversible (WithRev a) where     rev (WithRev (r,x)) = WithRev (x,r) +                                         -}
+ src/Music/Time/Score.hs view
@@ -0,0 +1,550 @@++{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE ViewPatterns               #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------++module Music.Time.Score (+        -- * Score type+        Score,++        -- * Construction+        score,+      +        -- ** Extracting values+        notes,+        events,+      +        -- ** Pattern matching+        singleNote,++        -- ** Unsafe versions+        unsafeNotes,+        unsafeEvents,+++        -- * Simultaneous values+        -- TODO check for overlapping values etc+        simult,+        simultaneous,++        -- * Traversing+        mapWithSpan,+        filterWithSpan,+        mapFilterWithSpan,+        mapEvents,+        filterEvents,+        mapFilterEvents,++  ) where++import           Data.AffineSpace+import           Data.AffineSpace.Point+import qualified Data.List.NonEmpty     as NonEmpty+import           Data.Map               (Map)+import qualified Data.Map               as Map+import           Data.Ratio+import           Data.Semigroup+import           Data.Set               (Set)+import qualified Data.Set               as Set+import           Data.VectorSpace+import           Data.Functor.Adjunction  (unzipR)++import           Music.Time.Juxtapose   (scat)+import           Music.Time.Meta+import           Music.Time.Note+import           Music.Time.Reverse+import           Music.Time.Split+import           Music.Time.Stretched+import           Music.Time.Voice++import           Control.Applicative+import           Control.Arrow          (first, second, (&&&), (***))+import           Control.Comonad+import           Control.Lens           hiding (Indexable, Level, above, below,+                                         index, inside, parts, reversed,+                                         transform, (<|), (|>))+import           Control.Monad+import           Control.Monad.Compose+import           Control.Monad.Plus+import           Data.Foldable          (Foldable)+import qualified Data.Foldable          as Foldable+import qualified Data.List              as List+import qualified Data.Ord               as Ord+import           Data.Semigroup         hiding ()+import           Data.Traversable       (Traversable)+import qualified Data.Traversable       as T+import           Data.Typeable+import           Data.VectorSpace       hiding (Sum (..))+import           Music.Dynamics.Literal+import           Music.Pitch.Literal+import           Music.Time.Internal.Util++++type ScoreNote a = Note a++--   * 'empty' creates an empty score+--+--   * 'pure' creates a score containing a single note in the span @0 '<->' 1@+--+--   * '<|>' composes scores in parallel+--+--   * '|>' composes scores as a forward sequence+--+--   * '<|' composes scores as a backward sequence+--+-- You can also use '<>' and 'mempty' of course.+--++-- |+-- A 'Score' is a sequential or parallel composition of values, and allows overlapping events+--+-- You typically create a 'Score' using 'score', 'notes', 'voices', and 'phrases', or the 'Alternative' interface.+--+-- Score is an instance of 'Transformable', so you can use 'delay' and 'stretch'.+--+-- Score is an instance of 'HasPosition', so you can use 'duration', 'onset', 'offset', 'era'.+--+-- To inspect or deconstruct a score, see 'notes', 'voices', and 'phrases', as+-- well as 'singleNote', 'singleVoice', and 'singlePhrase'+--+-- The semantics are given by+--+-- @+-- type Score a = [Note a]+-- @+--++newtype Score a = Score { getScore' :: (Meta, NScore a) }+    deriving (Functor, Semigroup, Monoid, Foldable, Traversable, Typeable{-, Show, Eq, Ord-})++instance Wrapped (Score a) where+  type Unwrapped (Score a) = (Meta, NScore a)+  _Wrapped' = iso getScore' Score++instance Rewrapped (Score a) (Score b) where++instance Applicative Score where+  pure = return+  (<*>) = ap++instance Monad Score where+  return = (^. _Unwrapped') . return . return+  xs >>= f = (^. _Unwrapped') $ mbind ((^. _Wrapped') . f) ((^. _Wrapped') xs)++instance Alternative Score where+  empty = mempty+  (<|>) = mappend++instance MonadPlus Score where+  mzero = mempty+  mplus = mappend++instance FunctorWithIndex Span Score where+  imap f = over (_Wrapped._2) $ imap f++instance FoldableWithIndex Span Score where+  ifoldMap f (Score (m,x)) = ifoldMap f x++instance TraversableWithIndex Span Score where+  itraverse f (Score (m,x)) = fmap (\x -> Score (m,x)) $ itraverse f x++instance Transformable (Score a) where+  transform t (Score (m,x)) = Score (transform t m, transform t x)++instance Reversible a => Reversible (Score a) where+  rev (Score (m,x)) = Score (rev m, rev x)++instance Splittable a => Splittable (Score a) where+  split t (Score (m,x)) = (Score (m1,x1), Score (m2,x2))+    where+      (m1, m2) = split t m+      (x1, x2) = split t x++instance HasPosition (Score a) where+  _onset (Score (_,x))    = _onset x+  _offset (Score (_,x))   = _offset x+  _position (Score (_,x)) = _position x++instance HasDuration (Score a) where+  _duration (Score (_,x)) = _duration x++++-- Lifted instances++instance IsPitch a => IsPitch (Score a) where+  fromPitch = pure . fromPitch++instance IsInterval a => IsInterval (Score a) where+  fromInterval = pure . fromInterval++instance IsDynamics a => IsDynamics (Score a) where+  fromDynamics = pure . fromDynamics++-- Bogus instance, so we can use [c..g] expressions+instance Enum a => Enum (Score a) where+  toEnum = return . toEnum+  fromEnum = list 0 (fromEnum . head) . Foldable.toList++-- Bogus instance, so we can use numeric literals+instance Num a => Num (Score a) where+  fromInteger = return . fromInteger+  abs    = fmap abs+  signum = fmap signum+  (+)    = error "Not implemented"+  (-)    = error "Not implemented"+  (*)    = error "Not implemented"++-- Bogus instances, so we can use c^*2 etc.+instance AdditiveGroup (Score a) where+  zeroV   = error "Not implemented"+  (^+^)   = error "Not implemented"+  negateV = error "Not implemented"++instance VectorSpace (Score a) where+  type Scalar (Score a) = Duration+  d *^ s = d `stretch` s++instance HasMeta (Score a) where+  meta = _Wrapped . _1++++++++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 Wrapped (NScore a) where+  type Unwrapped (NScore a) = [ScoreNote a]+  _Wrapped' = iso getNScore NScore++instance Rewrapped (NScore a) (NScore b)++instance Applicative NScore where+  pure  = return+  (<*>) = ap++instance Monad NScore where+  return = (^. _Unwrapped) . pure . pure+  xs >>= f = (^. _Unwrapped) $ mbind ((^. _Wrapped') . f) ((^. _Wrapped') xs)++instance Alternative NScore where+  empty = mempty+  (<|>) = mappend++instance MonadPlus NScore where+  mzero = mempty+  mplus = mappend++instance FunctorWithIndex Span NScore where+  imap = undefined+  -- TODO++instance FoldableWithIndex Span NScore where+  ifoldMap = undefined+  -- TODO++instance TraversableWithIndex Span NScore where+  itraverse = undefined+  -- TODO++instance Transformable (NScore a) where+  transform t (NScore xs) = NScore (fmap (transform t) xs)++instance Reversible a => Reversible (NScore a) where+  rev (NScore xs) = NScore (fmap rev xs)++instance HasPosition (NScore a) where+  _onset  = safeMinimum . fmap _onset . view _Wrapped'+  _offset = safeMaximum . fmap _offset . view _Wrapped'++-- TODO move+safeMinimum xs = if null xs then 0 else minimum xs+safeMaximum xs = if null xs then 0 else maximum xs++instance HasDuration (NScore a) where+  _duration x = _offset x .-. _onset x++instance Splittable a => Splittable (NScore a) where+  split t (NScore notes) = over both (NScore . mfilter (not . isEmptyNote)) $ unzip $ map (\x -> splitAbs (0 .+^ t) x) notes+    where+      -- TODO move+      isEmptyNote :: Note a -> Bool+      isEmptyNote = isEmptySpan . view era+      +      isEmptySpan :: Span -> Bool+      isEmptySpan (view range -> (t, u)) = t == u+++-- |+-- Create a score from a list of notes.+--+-- This is a getter (rather than a function) for consistency:+--+-- @+-- [ (0 '<->' 1, 10)^.'note',+--   (1 '<->' 2, 20)^.'note',+--   (3 '<->' 4, 30)^.'note' ]^.'score'+-- @+--+-- @+-- 'view' 'score' $ 'map' ('view' 'note') [(0 '<->' 1, 1)]+-- @+--+-- Se also 'notes'.+--+score :: Getter [Note a] (Score a)+score = from unsafeNotes+{-# INLINE score #-}++-- |+-- View a 'Score' as a list of 'Note' values.+--+-- @+-- 'view' 'notes'                        :: 'Score' a -> ['Note' a]+-- 'set'  'notes'                        :: ['Note' a] -> 'Score' a -> 'Score' a+-- 'over' 'notes'                        :: (['Note' a] -> ['Note' b]) -> 'Score' a -> 'Score' b+-- @+--+-- @+-- 'preview'  ('notes' . 'each')           :: 'Score' a -> 'Maybe' ('Note' a)+-- 'preview'  ('notes' . 'element' 1)      :: 'Score' a -> 'Maybe' ('Note' a)+-- 'preview'  ('notes' . 'elements' odd)   :: 'Score' a -> 'Maybe' ('Note' a)+-- @+--+-- @+-- 'set'      ('notes' . 'each')           :: 'Note' a -> 'Score' a -> 'Score' a+-- 'set'      ('notes' . 'element' 1)      :: 'Note' a -> 'Score' a -> 'Score' a+-- 'set'      ('notes' . 'elements' odd)   :: 'Note' a -> 'Score' a -> 'Score' a+-- @+--+-- @+-- 'over'     ('notes' . 'each')           :: ('Note' a -> 'Note' b) -> 'Score' a -> 'Score' b+-- 'over'     ('notes' . 'element' 1)      :: ('Note' a -> 'Note' a) -> 'Score' a -> 'Score' a+-- 'over'     ('notes' . 'elements' odd)   :: ('Note' a -> 'Note' a) -> 'Score' a -> 'Score' a+-- @+--+-- @+-- 'toListOf' ('notes' . 'each')                :: 'Score' a -> ['Note' a]+-- 'toListOf' ('notes' . 'elements' odd)        :: 'Score' a -> ['Note' a]+-- 'toListOf' ('notes' . 'each' . 'filtered'+--              (\\x -> '_duration' x \< 2))  :: 'Score' a -> ['Note' a]+-- @+--+-- This is not an 'Iso', as the note list representation does not contain meta-data.+-- To construct a score from a note list, use 'score' or @'flip' ('set' 'notes') 'empty'@.+--+notes :: Lens (Score a) (Score b) [Note a] [Note b]+notes = _Wrapped . _2 . _Wrapped . sorted+  where+    sorted = iso (List.sortBy (Ord.comparing _onset)) (List.sortBy (Ord.comparing _onset))+-- notes = unsafeNotes+{-# INLINE notes #-}++-- -- |+-- -- View a score as a list of voices.+-- --+-- -- @+-- -- 'view' 'voices'                        :: 'Score' a -> ['Voice' a]+-- -- 'set'  'voices'                        :: ['Voice' a] -> 'Score' a -> 'Score' a+-- -- 'over' 'voices'                        :: (['Voice' a] -> ['Voice' b]) -> 'Score' a -> 'Score' b+-- -- @+-- --+-- -- @+-- -- 'preview'  ('voices' . 'each')           :: 'Score' a -> 'Maybe' ('Voice' a)+-- -- 'preview'  ('voices' . 'element' 1)      :: 'Score' a -> 'Maybe' ('Voice' a)+-- -- 'preview'  ('voices' . 'elements' odd)   :: 'Score' a -> 'Maybe' ('Voice' a)+-- -- @+-- --+-- -- @+-- -- 'set'      ('voices' . 'each')           :: 'Voice' a -> 'Score' a -> 'Score' a+-- -- 'set'      ('voices' . 'element' 1)      :: 'Voice' a -> 'Score' a -> 'Score' a+-- -- 'set'      ('voices' . 'elements' odd)   :: 'Voice' a -> 'Score' a -> 'Score' a+-- -- @+-- --+-- -- @+-- -- 'over'     ('voices' . 'each')           :: ('Voice' a -> 'Voice' b) -> 'Score' a -> 'Score' b+-- -- 'over'     ('voices' . 'element' 1)      :: ('Voice' a -> 'Voice' a) -> 'Score' a -> 'Score' a+-- -- 'over'     ('voices' . 'elements' odd)   :: ('Voice' a -> 'Voice' a) -> 'Score' a -> 'Score' a+-- -- @+-- --+-- -- @+-- -- 'toListOf' ('voices' . 'each')           :: 'Score' a -> ['Voice' a]+-- -- 'toListOf' ('voices' . 'elements' odd)   :: 'Score' a -> ['Voice' a]+-- -- 'toListOf' ('voices' . 'each' . 'filtered' (\\x -> '_duration' x \< 2)) :: 'Score' a -> ['Voice' a]+-- -- @+-- --+-- -- This is not an 'Iso', as the voice list representation does not contain meta-data.+-- -- To construct a score from a voice list, use 'score' or @'flip' ('set' 'voices') 'empty'@.+-- --+-- voices :: Lens (Score a) (Score b) [Voice a] [Voice b]+-- voices = unsafeVoices+-- {-# INLINE voices #-}++-- |+-- View a score as a list of notes.+--+-- This only an isomorphism up to meta-data. See also the safe (but more restricted)+-- 'notes' and 'score'.+--+unsafeNotes :: Iso (Score a) (Score b) [Note a] [Note b]+unsafeNotes = _Wrapped . noMeta . _Wrapped . sorted+  where+    sorted = iso (List.sortBy (Ord.comparing _onset)) (List.sortBy (Ord.comparing _onset))+    noMeta = iso extract return+    -- noMeta = iso (\(_,x) -> x) (\x -> (mempty,x))++{-# INLINE unsafeNotes #-}++-- |+-- View a score as a list of events.+--+-- This only an isomorphism up to meta-data. See also the safe (but more restricted)+-- 'notes' and 'score'.+--+unsafeEvents :: Iso (Score a) (Score b) [(Time, Duration, a)] [(Time, Duration, b)]+unsafeEvents = iso _getScore _score++-- |+-- View a score as a single note.+--+singleNote :: Prism' (Score a) (Note a)+singleNote = unsafeNotes . single+{-# INLINE singleNote #-}+-- TODO make prism fail if score contains meta-data+-- (or else second prism law is not satisfied)+++-- | Map with the associated time span.+mapScore :: (Note a -> b) -> Score a -> Score b+mapScore f = over (_Wrapped._2) (mapNScore f)+  where+    mapNScore f = over (_Wrapped.traverse) (extend f)++reifyScore :: Score a -> Score (Note a)+reifyScore = over (_Wrapped . _2 . _Wrapped) $ fmap duplicate++-- |+-- View a score as a list of events, i.e. time-duration-value triplets.+--+-- This is a convenient combination of 'notes' and 'event'.+--+-- @+-- 'events' = 'notes' . 'through' 'event' 'event'+-- @+--+events :: {-Transformable a => -}Lens (Score a) (Score b) [(Time, Duration, a)] [(Time, Duration, b)]+events = notes . through event event++_score :: [(Time, Duration, a)] -> Score a+_score = mconcat . fmap (uncurry3 event)+  where+    event t d x   = (delay (t .-. 0) . stretch d) (return x)++_getScore :: {-Transformable a => -}Score a -> [(Time, Duration, a)]+_getScore =+  fmap (\(view delta -> (t,d),x) -> (t,d,x)) .+  List.sortBy (Ord.comparing fst) .+  Foldable.toList .+  fmap (view $ from note) .+  reifyScore+++-- | Map over the values in a score.+mapWithSpan :: (Span -> a -> b) -> Score a -> Score b+mapWithSpan f = mapScore (uncurry f . view (from note))++-- | Filter the values in a score.+filterWithSpan :: (Span -> a -> Bool) -> Score a -> Score a+filterWithSpan f = mapFilterWithSpan (partial2 f)++-- | Combination of 'mapEvents' and 'filterEvents'.+mapFilterWithSpan :: (Span -> a -> Maybe b) -> Score a -> Score b+mapFilterWithSpan f = mcatMaybes . mapWithSpan f++-- | Map over the values in a score.+mapEvents :: (Time -> Duration -> a -> b) -> Score a -> Score b+mapEvents f = mapWithSpan (uncurry f . view delta)++-- | Filter the values in a score.+filterEvents   :: (Time -> Duration -> a -> Bool) -> Score a -> Score a+filterEvents f = mapFilterEvents (partial3 f)++-- | Efficient combination of 'mapEvents' and 'filterEvents'.+mapFilterEvents :: (Time -> Duration -> a -> Maybe b) -> Score a -> Score b+mapFilterEvents f = mcatMaybes . mapEvents f+++++eras :: Transformable a => Score a -> [Span]+eras sc = fmap getSpan . (^. events) $ sc++chordEvents :: Transformable a => Span -> Score a -> [a]+chordEvents era sc = fmap getValue . filter (\ev -> getSpan ev == era) . (^. events) $ sc++getValue :: (Time, Duration, a) -> a+getValue (t,d,a) = a++getSpan :: (Time, Duration, a) -> Span+getSpan (t,d,a) = t >-> d+++simultaneous' :: Transformable a => Score a -> Score [a]+simultaneous' sc = (^. from unsafeEvents) vs+  where+    -- es :: [Era]+    -- evs :: [[a]]+    -- vs :: [(Time, Duration, [a])]+    es  = List.nub $ eras sc+    evs = fmap (`chordEvents` sc) es+    vs  = zipWith (\(view delta -> (t,d)) a -> (t,d,a)) es evs++-- overSimult :: Transformable a => (Score [a] -> Score [b]) -> Score a -> Score b+-- overSimult f = mscatter . f . simultaneous'++-- |+-- Merge all simultaneous events using their 'Semigroup' instance.+--+-- Two events /a/ and /b/ are considered simultaneous if and only if they have the same+-- era, that is if @`era` a == `era` b@+--+simultaneous :: (Transformable a, Semigroup a) => Score a -> Score a+simultaneous = fmap (sconcat . NonEmpty.fromList) . simultaneous'++simult :: Transformable a => Lens (Score a) (Score b) (Score [a]) (Score [b])+simult = iso simultaneous' mscatter+-- TODO identical to: lens simultaneous' (flip $ mapSimultaneous . const)+-- wrap in something to preserve meta+
+ src/Music/Time/Segment.hs view
@@ -0,0 +1,371 @@++{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE ViewPatterns               #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------++module Music.Time.Segment (++        -- * Behavior type+        Behavior,+        -- ** Examples+        -- $musicTimeBehaviorExamples+        -- (!^),+        -- behavior',+        behavior,++        -- ** Combinators+        switch,+        switch',+        splice,+        trim,+        trimBefore,+        trimAfter,+        concatB,++        -- * Common behaviors+        line,+        unit,+        impulse,+        turnOn,+        turnOff,+        sawtooth,+        sine,+        cosine,++        -- * Segment type+        Segment,+        -- ** Examples+        -- $XXmusicTimeSegmentExamples+        segment,++        -- ** Combinators+        focusing,+        apSegments',+        apSegments,+        -- concatS,++        Bound,+        bounds,+        bounding,+        trim,+        splice,+        bounded',+        bounded,     ++  ) where++import           Data.AffineSpace+import           Data.AffineSpace.Point+import           Data.Clipped+import           Data.Functor.Rep.Lens+import           Data.Map               (Map)+import qualified Data.Map               as Map+import           Data.Ratio+import           Data.Semigroup+import           Data.Set               (Set)+import qualified Data.Set               as Set+import           Data.VectorSpace++import           Music.Time.Behavior+import           Music.Time.Bound+import           Music.Time.Note+import           Music.Time.Reverse+import           Music.Time.Score+import           Music.Time.Split+import           Music.Time.Stretched+import           Music.Time.Voice++import           Control.Applicative+import           Control.Arrow          (first, second, (&&&), (***))+import           Control.Lens           hiding (Indexable, Level, above, below,+                                         index, inside, parts, reversed,+                                         transform, (<|), (|>))+import           Data.Distributive+import           Data.Functor.Rep+import           Data.Functor.Rep.Lens+import           Data.Maybe+import           Data.Typeable+import           Music.Dynamics.Literal+import           Music.Pitch.Literal+++-- TODO Compare Diagram's Trail and Located (and see the conal blog post)++-- |+--+-- A 'Segment' is a value varying over some unknown time span.+--+-- To give a segment an explicit duration, use 'Stretched' 'Segment'.+--+-- To place a segment in a particular time span, use 'Note' 'Segment'.+--+-- The semantics are given by+--+-- @+-- type Segment a = 'Duration' -> a+-- @+--+newtype Segment a = Segment { getSegment :: Clipped Duration -> a }+  deriving (Functor, Applicative, Monad{-, Comonad-})++--+-- TODO constant-optimize a la Conal+--++-- $musicTimeSegmentExamples+--+-- > foldr1 apSegments' $ map (view stretched) $ [(0.5,0::Segment Float), (1, timeS), (2,rev timeS), (3,-1)]+--+-- > openG $ draw $ (1, timeS :: Segment Float)^.stretched+--++instance Show (Segment a) where+  show _ = "<<Segment>>"++deriving instance Typeable1 Segment+deriving instance Distributive Segment++instance Representable Segment where+  type Rep Segment = Duration+  tabulate f = Segment (f . fromClipped)+  index    (Segment f) = f . unsafeToClipped++-- |+-- Segments are /invariant/ under transformation. To transform a timve varying value, use+-- 'fromSegment'.+--+instance Transformable (Segment a) where+  transform _ = id++instance Reversible (Segment a) where+  -- TODO in terms of Representable+  rev (Segment f) = Segment (f . unsafeToClipped . r . fromClipped)+    where+      r x = (x * (-1)) + 1++-- TODO+-- type instance Pitch                 (Segment a) = Segment (Pitch a)+-- type instance SetPitch (Segment g)  (Segment a) = Segment (SetPitch g a)+--+-- instance (HasPitch a a, HasPitch a b) => HasPitches (Segment a) (Segment b) where+--   pitches = through pitch pitch+-- instance (HasPitch a a, HasPitch a b) => HasPitch (Segment a) (Segment b) where+--   pitch = through pitch pitch+--+-- type instance Dynamic                 (Segment a) = Segment (Dynamic a)+-- type instance SetDynamic (Segment g) (Segment a) = Segment (SetDynamic g a)+--+-- instance (HasDynamic a a, HasDynamic a b) => HasDynamics (Segment a) (Segment b) where+--   dynamics = through dynamic dynamic+-- instance (HasDynamic a a, HasDynamic a b) => HasDynamic (Segment a) (Segment b) where+--   dynamic = through dynamic dynamic+--+--+-- type instance Articulation                 (Segment a) = Segment (Articulation a)+-- type instance SetArticulation (Segment g) (Segment a) = Segment (SetArticulation g a)+--+-- instance (HasArticulation a a, HasArticulation a b) => HasArticulations (Segment a) (Segment b) where+--   articulations = through articulation articulation+-- instance (HasArticulation a a, HasArticulation a b) => HasArticulation (Segment a) (Segment b) where+--   articulation = through articulation articulation+--+--+-- type instance Part                 (Segment a) = Segment (Part a)+-- type instance SetPart (Segment g) (Segment a) = Segment (SetPart g a)+--+-- instance (HasPart a a, HasPart a b) => HasParts (Segment a) (Segment b) where+--   parts = through part part+-- instance (HasPart a a, HasPart a b) => HasPart (Segment a) (Segment b) where+--   part = through part part++-- #ifdef INCLUDE_LIFTED+-- deriving instance Semigroup a => Semigroup (Segment a)+-- deriving instance Monoid a => Monoid (Segment a)+-- deriving instance Num a => Num (Segment a)+-- deriving instance Fractional a => Fractional (Segment a)+-- deriving instance Floating a => Floating (Segment a)+--+-- instance IsPitch a => IsPitch (Segment a) where+--   fromPitch = pure . fromPitch+--+-- instance IsInterval a => IsInterval (Segment a) where+--   fromInterval = pure . fromInterval+--+-- instance Alterable a => Alterable (Segment a) where+--     sharpen = fmap sharpen+--     flatten = fmap flatten+--+-- instance Augmentable a => Augmentable (Segment a) where+--     augment = fmap augment+--     diminish = fmap diminish+--+-- instance Eq a => Eq (Segment a) where+--   (==) = error "No fun"+--+-- instance Ord a => Ord (Segment a) where+--   (<) = error "No fun"+--   max = liftA2 max+--   min = liftA2 min+-- #endif++-- |+-- View a segment as a time function and vice versa.+--+segment :: Iso (Duration -> a) (Duration -> b) (Segment a) (Segment b)+segment = tabulated++apSegments' :: Stretched (Segment a) -> Stretched (Segment a) -> Stretched (Segment a)+apSegments' (view (from stretched) -> (d1,s1)) (view (from stretched) -> (d2,s2))+  = view stretched (d1+d2, slerp (d1/(d1+d2)) s1 s2)++-- |+-- Append a voice of segments to a single stretched segment.+--+apSegments :: Voice (Segment a) -> Stretched (Segment a)+apSegments = foldr1 apSegments' . toListOf (stretcheds . each)++-- t < i && 0 <= t <= 1   ==> 0 < (t/i) < 1+-- i     is the fraction of the slerped segment spent in a+-- (1-i) is the fraction of the slerped segment spent in b+slerp :: Duration -> Segment a -> Segment a -> Segment a+slerp i a b+  | i < 0 || i >= 1    = error "slerp: Bad value"+  | otherwise = tabulate $ \t -> if t < i then a ! (t/i) else b ! ((t-i)/(1-i))++slerp2 :: (a -> a -> a) -> Duration -> Segment a -> Segment a -> Segment a+slerp2 f i a b+  | i < 0 || i >= 1    = error "slerp: Bad value"+  | otherwise = tabulate $ \t -> case t `compare` i of+      LT -> a ! (t/i)+      EQ -> (a ! 1) `f` (b ! 1)+      GT -> b ! ((t-i)/(1-i))+++-- |+-- View a 'Note' 'Segment' as a 'Bound' 'Behavior' and vice versa.+--+-- This can be used to safely turn a behavior into a segment and vice+-- versa. Often 'focusing' is more convenient to use.+--+bounded' :: Iso' (Note (Segment a)) (Bound (Behavior a))+bounded' = bounded++-- |+-- View a 'Note' 'Segment' as a 'Bound' 'Behavior' and vice versa.+--+-- This can be used to safely turn a behavior into a segment and vice+-- versa. Often 'focusing' is more convenient to use.+--+bounded :: Iso (Note (Segment a)) (Note (Segment b)) (Bound (Behavior a)) (Bound (Behavior b))+bounded = iso ns2bb bb2ns+  where+    bb2ns (Bound (s, x)) = view note (s, b2s $ transform (negateV s) $ x)+    ns2bb (view (from note) -> (s, x)) = Bound (s,       transform s           $ s2b $ x)+    s2b = under tabulated (. realToFrac)+    b2s = under tabulated (. realToFrac)++--+-- Note that the isomorhism only works because of 'Bound' being abstract.+-- A function @unBound :: Bound a -> a@ could break the isomorphism+-- as follows:+--+-- > (unBound . view (from bounded . bounded) . bounds 0 1) b ! 2+-- *** Exception: Outside 0-1+--++-- |+-- Extract a bounded behavior, replacing all values outside the bound with 'mempty'.+--+-- @+-- 'trim'   = 'splice' 'mempty'+-- 'trim' x = 'trimBefore' '_onset' x . 'trimAfter' '_offset' x+-- @+--+trim :: Monoid b => Bound (Behavior b) -> Behavior b+trim = trimG+  where+    trimG :: (Monoid b, Representable f, Rep f ~ Time) => Bound (f b) -> f b+    trimG (Bound (s, x)) = tabulate (trimOutside s) `apRep` x++trimOutside :: Monoid a => Span -> Time -> a -> a+trimOutside s t x = if t `inside` s then x else mempty++-- |+-- Inserts a bounded behavior on top of another behavior.+--+-- @+-- 'trim' = 'splice' 'mempty'+-- @+--+-- (Named after the analogous tape-editing technique.)+--+splice :: Behavior a -> Bound (Behavior a) -> Behavior a+splice constant insert = fmap fromLast $ fmap toLast constant <> trim (fmap (fmap toLast) insert)+  where+    toLast   = Option . Just . Last+    fromLast = getLast . fromJust . getOption+    -- fromJust is safe here, as toLast is used to create the Maybe wrapper+++concatSegment :: Monoid a => Note (Segment a) -> Behavior a+concatSegment = trim . view bounded++-- |+-- Concatenate a score of (possibly overlapping) segments.+--+-- See also 'concatB' and 'continous'.+--+concatS :: Monoid a => Score (Segment a) -> Behavior a+concatS = mconcat . map concatSegment . view notes+-- Or: mconcat.fmap trim.toListOf (notes.each.bounded)++-- |+-- Concatenate a score of (possibly overlapping) segments.+--+-- See also 'concatSegment' and 'continous'.+--+concatB :: Monoid a => Score (Behavior a) -> Behavior a+concatB = concatS . fmap (view focusing)+-- Or (more generally): mconcat.toListOf (notes.each.noteValue)+++-- |+-- View part of a 'Behavior' as a 'Segment'.+--+-- @+-- 'line' & 'focusing' ``onSpan`` (2 '<->' 3) '*~' 0+-- @+--+focusing :: Lens' (Behavior a) (Segment a)+focusing = lens get set+  where+    get = view (from bounded . noteValue) . {-pure-}bounding mempty+    set x = splice x . (view bounded) . pure++
− src/Music/Time/Span.hs 
@@ -1,190 +0,0 @@--{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE StandaloneDeriving         #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE ViewPatterns               #-}------------------------------------------------------------------------------------------ |--- Copyright   : (c) Hans Hoglund 2012------ License     : BSD-style------ Maintainer  : hans@hanshoglund.se--- Stability   : experimental--- Portability : non-portable (TF,GNTD)------ Provides time spans.-------------------------------------------------------------------------------------------module Music.Time.Span (-        Span,-        -- inSpan,--        -- ** Constructing spans-        (<->),-        (>->),-        era,--        -- ** Deconstructing spans-        -- _range,-        -- _delta,-        range,-        delta,-        -- mapRange,-        -- mapDelta,--        -- ** Span as transformation-        sunit,-        sapp,-        sunder,-        sinvert,-  ) where--import           Control.Arrow-import           Control.Lens-import           Data.AffineSpace-import           Data.AffineSpace.Point-import           Data.Semigroup-import           Data.VectorSpace--import           Music.Time.Delayable-import           Music.Time.Onset-import           Music.Time.Reverse-import           Music.Time.Stretchable-import           Music.Time.Time---- |--- A 'Span' represents two points in time @u@ and @v@ where @t <= u@ or, equivalently,--- a time @t@ and a duration @d@ where @d >= 0@.------ A third way of looking at 'Span' is that it represents a time transformation where--- onset is translation and duration is scaling.----newtype Span = Span (Time, Duration)-    deriving (Eq, Ord, Show)---- normalizeSpan :: Span -> Span--- normalizeSpan (Span (t,d))-    --  | d >= 0  =  t <-> (t .+^ d)-    --  | d <  0  =  (t .+^ d) <-> t--{--    "Applying a transformation t to a Located a results in the transformation being-    applied to the location, and the linear portion of t being applied to the value of-    type a (i.e. it is not translated)."--        -- Diagrams Haddocks--}-instance Delayable Span where-    delay n = delta %~ first (delay n)--instance Stretchable Span where-    stretch n = delta %~ (stretch n *** stretch n)---instance HasOnset Span where-    onset = fst . _range--instance HasOffset Span where-    offset = snd . _range--instance HasDuration Span where-    duration = snd . _delta--instance Semigroup Span where-    -- Span (t1, d1) <> Span (t2, d2) = Span (t1 `delayTime` (d1 `stretch` t2), d1 `stretch` d2)-    (<>) = sapp---instance Monoid Span where-    mempty  = start <-> stop-    mappend = (<>)--inSpan f = Span . f . _delta---- |--- The default span, i.e. 'start' '<->' 'stop'.----sunit :: Span-sunit = mempty---- | @t \<-\> u@ represents the span between @t@ and @u@.-(<->) :: Time -> Time -> Span-(<->) t u = t >-> (u .-. t)---- | @t >-> d@ represents the span between @t@ and @t .+^ d@.-(>->) :: Time -> Duration -> Span-t >-> d = Span (t,d)-    --  | d > 0     = Span (t,d)-    --  | otherwise = error "Invalid span"---- | Get the era (onset to offset) of a given value.-era :: (HasOnset a, HasOffset a) => a -> Span-era x = onset x <-> offset x--_delta :: Span -> (Time, Duration)-_delta (Span x) = x--_range :: Span -> (Time, Time)-_range x = let (t, d) = _delta x-    in (t, t .+^ d)---- |--- View a span as onset and offset.------ Typically used with the @ViewPatterns@ extension, as in------ > foo (view range -> (u,v)) = ...----range :: Iso' Span (Time, Time)-range = iso _range $ uncurry (<->)---- |--- View a span as a time and duration.------ Typically used with the @ViewPatterns@ extension, as in------ > foo (view delta -> (t,d)) = ...----delta :: Iso' Span (Time, Duration)-delta = iso _delta $ uncurry (>->)---- | Apply a span transformation.-sapp :: (Delayable a, Stretchable a) => Span -> a -> a-sapp (view delta -> (t,d)) = delayTime t . stretch d---- | Apply a function under a span transformation.-sunder :: (Delayable a, Stretchable a, Delayable b, Stretchable b) => Span -> (a -> b) -> a -> b--- sunder s f = sapp (sinvert s) . f . sapp s--sunder s f = sappInv s . f . sapp s-sappInv (view delta -> (t,d)) = stretch (recip d) . delayTime (mirror t)---- | The inversion of a span.------ > sinvert (sinvert s) = s--- > sapp (sinvert s) . sapp s = id----sinvert :: Span -> Span-sinvert (Span (t,d)) = Span (mirror t, recip d)---- TODO add "individual scaling" component, i.e. scale just duration not both time and duration--- Useful for implementing separation in articulation etc--deriving instance Delayable a => Delayable (NoStretch a)-deriving instance HasOnset a => HasOnset (NoStretch a)-deriving instance HasOffset a => HasOffset (NoStretch a)-deriving instance HasDuration a => HasDuration (NoStretch a)--deriving instance Stretchable a => Stretchable (NoDelay a)-deriving instance HasOnset a => HasOnset (NoDelay a)-deriving instance HasOffset a => HasOffset (NoDelay a)-deriving instance HasDuration a => HasDuration (NoDelay a)--
+ src/Music/Time/Split.hs view
@@ -0,0 +1,120 @@++{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE ViewPatterns               #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------++module Music.Time.Split (++        module Music.Time.Position,++        -- * The Splittable class+        Splittable(..),+        splitAbs,+    +        chunks,++  ) where++import           Music.Time.Position+import           Music.Time.Internal.Util++import           Control.Lens            hiding (Indexable, Level, above, below,+                                          index, inside, parts, reversed,+                                          transform, (<|), (|>))+import           Data.AffineSpace+import           Data.AffineSpace.Point+import           Data.Functor.Adjunction (unzipR)+import           Data.Functor.Rep+import           Data.Map                (Map)+import qualified Data.Map                as Map+import           Data.Semigroup          hiding ()+import           Data.Sequence           (Seq)+import qualified Data.Sequence           as Seq+import           Data.VectorSpace        hiding (Sum (..))++-- |+-- Class of values that can be split.+--+-- For non-positioned values such as 'Stretched', split cuts a value into pieces+-- of the given duration and the rest.+--+-- For positioned values succh as 'Note', split cuts a value relative to its onset.+-- To split at an absolute position, see 'splitAbs'.+--+--+-- Law+--+-- @+-- '_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+-- @+--+-- (Note that any of these three laws can be derived from the other two, so it is+-- sufficient to prove two!).+--+class Splittable a where+  split      :: Duration -> a -> (a, a)+  beginning  :: Duration -> a -> a+  ending     :: Duration -> a -> a+  split   d x = (beginning d x, ending d x)+  beginning d = fst . split d+  ending    d = snd . split d+-- TODO rename beginning/ending to fstSplit/sndSplit or similar++instance Splittable Duration where+  -- Directly from the laws+  -- Guard against t < 0+  split t x = (t' `min` x, x ^-^ (t' `min` x))+    where t' = t `max` 0++instance Splittable Span where+  -- Splitting a span splits the duration+  split pos (view delta -> (t, d)) = (t >-> d1, (t .+^ d1) >-> d2)+    where (d1, d2) = split pos d++instance (Ord k, Splittable a) => Splittable (Map k a) where+  split d = unzipR . Map.map (split d)+++-- takeMWhile :: (Monoid a, HasDuration a, Splittable a) => Duration -> (a -> Bool) -> a -> a+-- takeMWhile d p xs = if _duration xs <= 0 then mempty else takeMWhile' d p xs+--   where+--     takeMWhile' d p (split d -> (x, xs)) = if p x then x `mappend` takeMWhile d p xs else mempty++chunks :: (Splittable a, HasDuration a) => Duration -> a -> [a]+chunks d xs = if _duration xs <= 0 then [] else chunks' d xs+  where+    chunks' d (split d -> (x, xs)) = [x] ++ chunks d xs+++splitAbs :: (HasPosition a, Splittable a) => Time -> a -> (a, a)+splitAbs t x = split (t .-. _onset x) x++
− src/Music/Time/Stretchable.hs 
@@ -1,110 +0,0 @@--{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE UndecidableInstances       #-}------------------------------------------------------------------------------------------ |--- Copyright   : (c) Hans Hoglund 2012------ License     : BSD-style------ Maintainer  : hans@hanshoglund.se--- Stability   : experimental--- Portability : non-portable (TF,GNTD)------ Provides stretchable values.-------------------------------------------------------------------------------------------module Music.Time.Stretchable (-        -- * Stretchable class-        Stretchable(..),-        compress,-        stretching,--        -- ** Utility-        NoStretch(..),-  ) where--import           Control.Arrow--import           Data.AffineSpace-import           Data.AffineSpace.Point-import           Data.Map               (Map)-import qualified Data.Map               as Map-import           Data.Semigroup-import           Data.Set               (Set)-import qualified Data.Set               as Set-import           Data.VectorSpace       hiding (Sum)--import           Music.Time.Time---- |--- Stretchable values.----class Stretchable a where--    -- |-    -- Stretch (augment) a value by the given factor.-    ---    stretch :: Duration -> a -> a-    stretch _ = id--instance Stretchable Time where-    stretch n = (n*.)--instance Stretchable Duration where-    stretch n = (n*^)--instance Stretchable (Time, a) where-    stretch n (t, a) = (n `stretch` t, a)--instance Stretchable (Duration, a) where-    stretch n (d, a) = (n `stretch` d, a)--instance Stretchable (Time, Duration, a) where-    stretch n (t, d, a) = (n `stretch` t, n `stretch` d, a)--instance Stretchable (Time -> a) where-    stretch n = (. relative origin (^/ n))--instance Stretchable (Duration -> a) where-    stretch n = (. (^/ n))--instance Stretchable a => Stretchable [a] where-    stretch n = fmap (stretch n)--instance Stretchable a => Stretchable (Map k a) where-    stretch n = fmap (stretch n)--instance Stretchable a => Stretchable (Product a) where-    stretch n (Product x) = Product (stretch n x)--instance Stretchable a => Stretchable (Sum a) where-    stretch n (Sum x) = Sum (stretch n x)----- |--- Compress (diminish) a score. Flipped version of 'stretch'.----compress :: Stretchable a => Duration -> a -> a-compress x = stretch (recip x)---- | Apply a function under stretch.---   See also 'sunder'.-stretching :: (Stretchable a, Stretchable b) => Duration -> (a -> b) -> a -> b-stretching t f = compress t . f . stretch t---newtype NoStretch a = NoStretch { getNoStretch :: a }-    deriving (Eq, Ord, Enum, Show, Semigroup, Monoid-        {-Delayable, HasOnset, HasOffset, HasDuration-})--instance Stretchable (NoStretch a) where-    stretch _ = id
+ src/Music/Time/Stretched.hs view
@@ -0,0 +1,131 @@++{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------++module Music.Time.Stretched (++        -- * Stretched values+        Stretched,++        -- * Construction+        stretched,+        stretchedValue,   ++  ) where++import           Data.AffineSpace+import           Data.AffineSpace.Point+import           Data.Map               (Map)+import qualified Data.Map               as Map+import           Data.Ratio+import           Data.Semigroup+import           Data.Set               (Set)+import qualified Data.Set               as Set+import           Data.VectorSpace++import           Music.Time.Reverse+import           Music.Time.Split++import           Control.Applicative+import           Control.Arrow          (first, second, (&&&), (***))+import           Control.Comonad+import           Control.Comonad.Env+import           Control.Lens           hiding (Indexable, Level, above, below,+                                         index, inside, parts, reversed,+                                         transform, (<|), (|>))+import           Data.Foldable          (Foldable)+import qualified Data.Foldable          as Foldable+import           Data.PairMonad+import           Data.Typeable++-- |+-- A 'Stretched' value has a known 'duration', but no 'position'.+--+-- Placing a value inside 'Stretched' makes it invariante under 'delay'.+--+-- The semantics are given by+--+-- @+-- type Stretched = (Duration, a)+-- @+--+newtype Stretched a = Stretched { _stretchedValue :: (Duration, a) }+  deriving (Eq, {-Ord, -}{-Show, -}+            Applicative, Monad, {-Comonad, -}+            Functor,  Foldable, Traversable)++-- >>> stretch 2 $ (5,1)^.stretched+-- (10,1)^.stretched+--+-- >>> delay 2 $ (5,1)^.stretched+-- (5,1)^.stretched+--++deriving instance Typeable1 Stretched++-- | Unsafe: Do not use 'Wrapped' instances+instance Wrapped (Stretched a) where+  type Unwrapped (Stretched a) = (Duration, a)+  _Wrapped' = iso _stretchedValue Stretched++instance Rewrapped (Stretched a) (Stretched b)++instance Transformable (Stretched a) where+  transform t = over _Wrapped $ first (transform t)++instance HasDuration (Stretched a) where+  _duration = _duration . ask . view _Wrapped++instance Reversible (Stretched a) where+  rev = stretch (-1)++instance Splittable a => Splittable (Stretched a) where+  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)++-- |+-- View a stretched value as a pair of the original value and a stretch factor.+--+stretched :: Iso (Duration, a) (Duration, b) (Stretched a) (Stretched b)+stretched = _Unwrapped+++-- |+-- View a stretched value as a pair of the original value and the transformation (and vice versa).+--+stretchedValue :: (Transformable a, Transformable b) => Lens (Stretched a) (Stretched b) a b+stretchedValue = lens runStretched (flip $ _stretched . const)+  where+    _stretched f (Stretched (d,x)) = Stretched (d, f `whilst` stretching d $ x)+{-# INLINE stretchedValue #-}++runStretched :: Transformable a => Stretched a -> a+runStretched = uncurry stretch . view _Wrapped
− src/Music/Time/Time.hs 
@@ -1,113 +0,0 @@--{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies               #-}------------------------------------------------------------------------------------------ |--- Copyright   : (c) Hans Hoglund 2012------ License     : BSD-style------ Maintainer  : hans@hanshoglund.se--- Stability   : experimental--- Portability : non-portable (TF,GNTD)-------------------------------------------------------------------------------------------module Music.Time.Time (-        -- $convert--        -- * Time type-        Time(..),--        -- * Duration type-        Duration,--        -- * Behavior class-        HasBehavior(..),--        -- ** Identities-        start,-        stop,-        unit,--        -- ** Combinators-        -- TODO-  ) where--import           Data.AffineSpace-import           Data.AffineSpace.Point-import           Data.Semigroup-import           Data.VectorSpace--import           Music.Score.Util       (showRatio)---- $convert------ Note that you should use '.-.' and '.+^' to convert between time and--- duration. To refer to time zero (the beginning of the music), use--- 'origin'.------- |--- This type represents relative time in seconds.----newtype Duration = Duration { getDuration :: Rational }-    deriving (Eq, Ord, Num, Enum, Fractional, Real, RealFrac, AdditiveGroup)--instance Show Duration where-    show = showRatio . getDuration--instance VectorSpace Duration where-    type Scalar Duration = Duration-    (Duration x) *^ (Duration y) = Duration (x *^ y)---- |--- The unit duration.----unit :: Duration-unit = 1 -- TODO some overloaded unit value---- |--- This type represents absolute time in seconds since 'start'. Note that time can be--- negative, representing events occuring before the start time.------ Time forms an affine space with durations as the underlying vector space,--- that is, we can add a time to a duration to get a new time using '.+^',--- take the difference of two times to get a duration using '.-.'.----type Time = Point Duration--instance Num Time where-    (+)         = relative2 origin (+)-    (*)         = relative2 origin (*)-    negate      = mirror-    abs         = relative origin abs-    signum      = relative origin signum-    fromInteger = (origin .+^) . fromInteger-instance Fractional Time where-    recip        = relative origin recip-    fromRational = (origin .+^) . fromRational---- |--- The global start time, which usually means the the beginning of the musical performance.------ This is a synonym for 'origin'.----start :: Time-start = origin---- |--- The global end time, defined as @start .+^ unit@.----stop :: Time-stop = origin .+^ unit---class HasBehavior f where-    (?) :: f a -> Time -> a--instance HasBehavior ((->) Time) where-    (?) = id-
+ src/Music/Time/Track.hs view
@@ -0,0 +1,155 @@++{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------++module Music.Time.Track (++        -- * Track type++        Track,++        -- * Construction+        track,+        delayeds,+        singleDelayed,   ++  ) where+++import           Data.AffineSpace+import           Data.AffineSpace.Point+import           Data.Map               (Map)+import qualified Data.Map               as Map+import           Data.Ratio+import           Data.Semigroup+import           Data.Set               (Set)+import qualified Data.Set               as Set+import           Data.VectorSpace++import           Music.Time.Delayed+import           Music.Time.Reverse+import           Music.Time.Split++import           Control.Applicative+import           Control.Arrow          (first, second, (&&&), (***))+import           Control.Lens           hiding (Indexable, Level, above, below,+                                         index, inside, parts, reversed,+                                         transform, (<|), (|>))+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.Internal.Util++-- |+-- A 'Track' is a parallel composition of values.+--+-- @+-- type Track a = [Delayed a]+-- @+--+newtype Track a = Track { getTrack :: TrackList (TrackEv a) }+  deriving (Functor, Foldable, Traversable, Semigroup, Monoid, Typeable, Show, Eq)++-- A track is a list of events with explicit onset.+--+-- Track is a 'Monoid' under parallel composition. 'mempty' is the empty track+-- and 'mappend' interleaves values.+--+-- Track is a 'Monad'. 'return' creates a track containing a single value at time+-- zero, and '>>=' transforms the values of a track, allowing the addition and+-- removal of values relative to the time of the value. Perhaps more intuitively,+-- 'join' delays each inner track to start at the offset of an outer track, then+-- removes the intermediate structure.++-- Can use [] or Seq here+type TrackList = []++-- Can use any type as long as trackEv provides an Iso+type TrackEv a = Delayed a++trackEv :: Iso (Delayed a) (Delayed b) (TrackEv a) (TrackEv b)+trackEv = id++instance Applicative Track where+  pure  = return+  (<*>) = ap++instance Alternative Track where+  (<|>) = (<>)+  empty = mempty++instance Monad Track where+  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++instance Rewrapped (Track a) (Track b)++instance Transformable (Track a) where+  transform s = over _Wrapped' (transform s)++instance HasDuration (Track a) where+  _duration = Foldable.sum . fmap _duration . view _Wrapped'++instance Splittable a => Splittable (Track a) where+  -- TODO++instance Reversible a => Reversible (Track a) where+  rev = over _Wrapped' (fmap rev) -- TODO OK?+++-- |+-- Create a track from a list of notes.+--+-- Se also 'delayeds'.+--+track :: Getter [Delayed a] (Track a)+track = from unsafeTrack+{-# INLINE track #-}++delayeds :: Lens (Track a) (Track b) [Delayed a] [Delayed b]+delayeds = unsafeTrack++singleDelayed :: Prism' (Track a) (Delayed a)+singleDelayed = unsafeTrack . single+{-# INLINE singleDelayed #-}++unsafeTrack :: Iso (Track a) (Track b) [Delayed a] [Delayed b]+unsafeTrack = _Wrapped+{-# INLINE unsafeTrack #-}+
+ src/Music/Time/Transform.hs view
@@ -0,0 +1,66 @@++{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------++module Music.Time.Transform (++        module Music.Time.Types,++        -- * The Transformable class+        Transformable(..),+        itransform,+        transformed,++        -- * Apply under a transformation+        whilst,+        spanned,+        onSpan,+        -- conjugateS,++        -- * Specific transformations+        -- ** Transformations+        delay,+        undelay,+        stretch,+        compress,++        -- ** Transforming values+        delaying,+        undelaying,+        stretching,+        compressing,++        -- * Utility+        delayTime,++  ) where++import           Music.Time.Internal.Transform+import           Music.Time.Types+
+ src/Music/Time/Types.hs view
@@ -0,0 +1,421 @@++{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE ViewPatterns               #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------++module Music.Time.Types (++        -- * Duration+        Duration,+        toDuration,+        fromDuration,++        -- * Time points+        Time,+        toTime,+        fromTime,++        -- $convert++        -- * Time spans+        Span,+        -- *** Creating spans+        (<->),+        (>->),+        (<-<),+        -- *** Accessing spans+        range,+        delta,+        showRange,+        showDelta,++        -- ** Points in spans+        -- TODO move+        isProper,+        isBefore,+        inside,+        encloses,+        overlaps,+        -- union+        -- intersection (alt name 'overlap')+        -- difference (would actually become a split)++        -- TODO Abjad terminology: contains/curtails/delays/intersects/isCongruentTo++        -- ** Properties+        delayOnly,+        stretchOnly,+        -- Proper spans are always bounded and closed+  ) where++import           Control.Lens           hiding (Indexable, Level, above, below,+                                         index, inside, parts, reversed,+                                         transform, (<|), (|>))+import           Data.AffineSpace+import           Data.AffineSpace.Point+import           Data.Semigroup+import           Data.Typeable+import           Data.VectorSpace++import           Music.Time.Internal.Util (showRatio)+++-- $convert+--+-- Note that you should use '.-.' and '.+^' to convert between time and+-- duration. To refer to time zero (the beginning of the music), use+-- 'origin'.+--++-- |+-- Internal time representation. Can be anything with instances+-- for 'Fractional' and 'RealFrac'.+--+type TimeBase = Rational+-- type TimeBase = Fixed E12++-- instance HasResolution a => AdditiveGroup (Fixed a) where+--   zeroV = 0+--   negateV = negate+--   (^+^) = (+)++-- Can be enabled for experimental time representation+-- deriving instance Floating Time+-- deriving instance Floating Duration+++-- |+-- Duration, corresponding to note values in standard notation.+-- The standard names can be used: @1\/2@ for half note @1\/4@ for a quarter note and so on.+--+-- Duration is a one-dimensional 'VectorSpace', and is the associated vector space of time points.+-- It is a also an 'AdditiveGroup' (and hence also 'Monoid' and 'Semigroup') under addition.+--+-- 'Duration' is invariant under translation so 'delay' has no effect on it.+--+-- The semantics are given by+--+-- @+-- type Duration = R+-- @+--+newtype Duration = Duration { getDuration :: TimeBase }+  deriving (Eq, Ord, Num, Enum, Fractional, Real, RealFrac, Typeable)++instance Show Duration where+  show = showRatio . realToFrac++instance InnerSpace Duration where+  (<.>) = (*)++instance AdditiveGroup Duration where+  zeroV = 0+  (^+^) = (+)+  negateV = negate++instance VectorSpace Duration where+  type Scalar Duration = Duration+  (*^) = (*)++instance Semigroup Duration where+  (<>) = (*^)++instance Monoid Duration where+  mempty  = 1+  mappend = (*^)+ -- TODO use some notion of norm rather than 1++-- |+-- Convert a value to a duration.+--+toDuration :: Real a => a -> Duration+toDuration = realToFrac++-- |+-- Convert a value to a duration.+--+fromDuration :: Fractional a => Duration -> a+fromDuration = realToFrac+++-- |+-- Time points, representing duration since some known reference time, typically the start+-- of the music. Note that time can be negative, representing values occuring before the+-- reference time.+--+-- Time forms an affine space with durations as the underlying vector space, that is, we+-- can add a time to a duration to get a new time using '.+^', take the difference of two+-- times to get a duration using '.-.'. 'Time' forms an 'AffineSpace' with 'Duration' as+-- difference space.+--+-- The semantics are given by+--+-- @+-- type Time = R+-- @+--+newtype Time = Time { getTime :: TimeBase }+  deriving (Eq, Ord, Num, Enum, Fractional, Real, RealFrac, Typeable)++instance Show Time where+  show = showRatio . realToFrac++deriving instance AdditiveGroup Time++instance VectorSpace Time where+  type Scalar Time = Duration+  Duration x *^ Time y = Time (x * y)++instance AffineSpace Time where+  type Diff Time = Duration+  Time x .-. Time y   = Duration (x - y)+  Time x .+^ Duration y = Time   (x + y)++instance Semigroup Time where+  (<>) = (^+^)++instance Monoid Time where+  mempty  = zeroV+  mappend = (^+^)+  mconcat = sumV++-- |+-- Convert a value to a duration.+--+toTime :: Real a => a -> Time+toTime = realToFrac++-- |+-- Convert a value to a duration.+--+fromTime :: Fractional a => Time -> a+fromTime = realToFrac+++++-- |+-- A 'Span' represents an onset and offset in time (or equivalently: an onset and a+-- duration, /or/ a duration and an offset, /or/ a duration and a middle point).+--+-- Pattern matching over span is possible (with @ViewPatterns@):+--+-- @+-- foo ('view' 'range' -> (t1, t2)) = ...+-- foo ('view' 'delta' -> (t, d)) = ...+-- @+--+-- Another way of looking at 'Span' is that it represents a time transformation where+-- onset is translation and duration is scaling. TODO see 'transform' and 'whilst'+--+-- The semantics are given by+--+-- @+-- type Span = Time x Time+-- @+--+newtype Span = Delta { _delta :: (Time, Duration) }+  deriving (Eq, Ord, Typeable)++-- You can create a span using the '<->' and '>->' constructors. Note that:+--+-- > t <-> u = t >-> (u .-. t)+-- > t >-> d = t <-> t .+^ d+--+-- To create and destruct a span (in any of its incarnations), use the provided isomorphisms:+--+-- 'Span' is a 'Semigroup', 'Monoid' and 'AdditiveGroup':+--+-- - To convert a span to a pair, use @s^.'range'@.+--+-- - To construct a span from a pair, use @(t, u)^.'from' 'range'@.+--++--+-- $musicTimeSpanIsos+--+-- >>> (2 <-> 3)^.range+-- > (2, 3)+-- >+-- >>> hs> (2 <-> 3)^.delta+-- > (2, 1)+-- >+-- >>> hs> (10 >-> 5)^.range+-- > (10, 15)+-- >+-- >>> hs> (10 >-> 5)^.delta+-- > (10, 5)+--++instance Show Span where+  -- show = showDelta+  show = showRange+  -- Which form should we use?++-- |+-- 'zeroV' or 'mempty' represents the /unit interval/ @0 \<-\> 1@, which also happens to+-- be the identity transformation.+--+instance Semigroup Span where+  (<>) = (^+^)++-- |+-- '<>' or '^+^' composes transformations, i.e. both time and duration is stretched,+-- and then time is added.+--+instance Monoid Span where+  mempty  = zeroV+  mappend = (^+^)++-- |+-- 'negateV' returns the inverse of a given transformation.+--+instance AdditiveGroup Span where+  zeroV   = 0 <-> 1+  Delta (t1, d1) ^+^ Delta (t2, d2) = Delta (t1 ^+^ d1 *^ t2, d1*d2)+  negateV (Delta (t, d)) = Delta (-t ^/ d, recip d)++--+-- a >-> b = a         <-> (a .+^ b)+-- a <-< b = (b .-^ a) <-> b+-- a <-> b = a         >-> (b .-. a)+-- (b .-^ a) <-> b = a <-< b+--++-- |+-- @t \<-\> u@ represents the span between @t@ and @u@.+--+(<->) :: Time -> Time -> Span+t <-> u = t >-> (u .-. t)++-- |+-- @t >-> d@ represents the span between @t@ and @t .+^ d@.+--+(>->) :: Time -> Duration -> Span+(>->) = curry Delta++-- |+-- @d \<-\> t@ represents the span between @t .-^ d@ and @t@.+--+(<-<) :: Duration -> Time -> Span+a <-< b = (b .-^ a) <-> b+++-- > (<->) = curry $ view $ from range+-- > (>->) = curry $ view $ from delta++-- |+-- View a span as pair of onset and offset.+--+range :: Iso' Span (Time, Time)+range = iso _range $ uncurry (<->)+  where+    _range x = let (t, d) = _delta x in (t, t .+^ d)++-- |+-- View a span as a pair of onset and duration.+--+delta :: Iso' Span (Time, Duration)+delta = iso _delta Delta++-- |+-- Show a span in range notation, i.e. @t1 \<-\> t2@.+--+showRange :: Span -> String+showRange (view range -> (t,u)) = show t ++ " <-> " ++ show u++-- |+-- Show a span in range notation, i.e. @t >-> d@.+--+showDelta :: Span -> String+showDelta (view delta -> (t,d)) = show t ++ " >-> " ++ show d++-- |+-- A prism to the subset of 'Span' that performs a delay but no stretch.+--+-- To access the delay component in any span, use @'view' ('delta' . e'_1')@+--+delayOnly :: Prism' Span Time+delayOnly = prism' (\t -> view (from delta) (t, 1)) $ \x -> case view delta x of+  (t, 1) -> Just t+  _      -> Nothing+++-- |+-- A prism to the subset of 'Span' that performs a stretch but no delay.+--+-- To access the stretch component in any span, use @'view' ('delta' . '_2')@+--+stretchOnly :: Prism' Span Duration+stretchOnly = prism' (\d -> view (from delta) (0, d)) $ \x -> case view delta x of+  (0, d) -> Just d+  _      -> Nothing+++-- Same as (onset, offset), defined here for bootstrapping reasons+startTime  (view range -> (t1, t2)) = t1+stopTime   (view range -> (t1, t2)) = t2+++-- |+-- Whether this is a proper span, i.e. whether @'_onset' x '<' 'stopTime' x@.+--+isProper :: Span -> Bool+isProper (view range -> (t, u)) = t < u++-- |+-- Whether the given point falls inside the given span (inclusively).+--+-- Designed to be used infix, for example+--+-- @+-- 0.5 ``inside`` (1 '<->' 2)+-- @+--+inside :: Time -> Span -> Bool+inside x (view range -> (t, u)) = t <= x && x <= u++-- |+-- Whether the first given span encloses the second span.+--+encloses :: Span -> Span -> Bool+a `encloses` b = startTime b `inside` a && stopTime b `inside` a++-- |+-- Whether the given span overlaps.+--+overlaps :: Span -> Span -> Bool+a `overlaps` b = not (a `isBefore` b) && not (b `isBefore` a)++-- |+-- Whether the first given span occurs before the second span.+--+isBefore :: Span -> Span -> Bool+a `isBefore` b = (startTime a `max` stopTime a) <= (startTime b `min` stopTime b)+
+ src/Music/Time/Voice.hs view
@@ -0,0 +1,460 @@++{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE ViewPatterns               #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012-2014+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------++module Music.Time.Voice (++        -- * Voice type+        Voice,++        -- * Construction+        voice,++        -- ** Extracting values+        stretcheds,+        eventsV,++        -- ** Pattern matching+        singleStretched,++        -- *** Unsafe versions+        unsafeStretcheds,+        unsafeEventsV,+++        -- * Fusion+        fuse,+        fuseBy,++        -- * Traversing+        -- ** Separating rhythms and values+        withValues,+        withDurations,+        rotateValues,+        rotateDurations,+        reverseValues,+        reverseDurations,++        -- ** Zips+        unzipVoice,+        zipVoice,+        zipVoiceWith,+        zipVoiceWith',+        zipVoiceWithNoScale,++        -- * Context+        withContext,++        -- headV,+        -- middleV,+        -- lastV,   ++  ) where++import           Data.AffineSpace+import           Data.AffineSpace.Point+import           Data.Map               (Map)+import qualified Data.Map               as Map+import           Data.Ratio+import           Data.Semigroup+import           Data.Set               (Set)+import qualified Data.Set               as Set+import           Data.VectorSpace+import           Data.Functor.Adjunction  (unzipR)++import           Music.Time.Reverse+import           Music.Time.Split+import           Music.Time.Stretched++import           Control.Applicative+import           Control.Lens           hiding (Indexable, Level, above, below,+                                         index, inside, parts, reversed,+                                         transform, (<|), (|>))+import           Control.Monad+import           Control.Monad.Compose+import           Control.Monad.Plus+import           Data.Foldable          (Foldable)+import qualified Data.Foldable          as Foldable+import qualified Data.List+import           Data.List.NonEmpty     (NonEmpty)+import           Data.Traversable       (Traversable)+import qualified Data.Traversable       as T+import           Data.Typeable+import           Music.Dynamics.Literal+import           Music.Pitch.Literal+import           Music.Time.Internal.Util++-- |+-- A 'Voice' is a sequential composition of values. Events may not overlap.+--+-- @+-- type Voice a = [Stretched a]+-- @+--+newtype Voice a = Voice { getVoice :: VoiceList (VoiceEv a) }+  deriving (Functor, Foldable, Traversable, Semigroup, Monoid, Typeable, Show, Eq)++-- A voice is a list of events with explicit duration. Events can not overlap.+--+-- Voice is a 'Monoid' under sequential composition. 'mempty' is the empty part and 'mappend'+-- appends parts.+--+-- Voice is a 'Monad'. 'return' creates a part containing a single value of duration+-- one, and '>>=' transforms the values of a part, allowing the addition and+-- removal of values under relative duration. Perhaps more intuitively, 'join' scales+-- each inner part to the duration of the outer part, then removes the+-- intermediate structure.++-- Can use [] or Seq here+type VoiceList = []++-- Can use any type as long as voiceEv provides an Iso+type VoiceEv a = Stretched a++voiceEv :: Iso (Stretched a) (Stretched b) (VoiceEv a) (VoiceEv b)+voiceEv = id++instance Applicative Voice where+  pure  = return+  (<*>) = ap++instance Alternative Voice where+  (<|>) = (<>)+  empty = mempty++instance Monad Voice where+  return = view _Unwrapped . return . return+  xs >>= f = view _Unwrapped $ (view _Wrapped . f) `mbind` view _Wrapped xs++-- | Unsafe: Do not use 'Wrapped' instances+instance Wrapped (Voice a) where+  type Unwrapped (Voice a) = (VoiceList (VoiceEv a))+  _Wrapped' = iso getVoice Voice++instance Rewrapped (Voice a) (Voice b)++instance Transformable (Voice a) where+  transform s = over _Wrapped' (transform s)++instance HasDuration (Voice a) where+  _duration = Foldable.sum . fmap _duration . view _Wrapped'++-- TODO move+instance Splittable () where+  split _ x = (x,x)++instance Splittable a => Splittable (Voice a) where+  split t x+    | t <= 0           = (mempty, x)+    | t >= _duration x = (x,      mempty)+    | otherwise        = let (a,b) = split' t {-split-} (x^._Wrapped) in (a^._Unwrapped, b^._Unwrapped)+    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 IsPitch a => IsPitch (Voice a) where+  fromPitch = pure . fromPitch++instance IsInterval a => IsInterval (Voice a) where+  fromInterval = pure . fromInterval++instance IsDynamics a => IsDynamics (Voice a) where+  fromDynamics = pure . fromDynamics++-- Bogus instance, so we can use [c..g] expressions+instance Enum a => Enum (Voice a) where+  toEnum = return . toEnum+  fromEnum = list 0 (fromEnum . head) . Foldable.toList++-- Bogus instance, so we can use numeric literals+instance Num a => Num (Voice a) where+  fromInteger = return . fromInteger+  abs    = fmap abs+  signum = fmap signum+  (+)    = error "Not implemented"+  (-)    = error "Not implemented"+  (*)    = error "Not implemented"++-- Bogus instances, so we can use c^*2 etc.+instance AdditiveGroup (Voice a) where+  zeroV   = error "Not implemented"+  (^+^)   = error "Not implemented"+  negateV = error "Not implemented"++instance VectorSpace (Voice a) where+  type Scalar (Voice a) = Duration+  d *^ s = d `stretch` s+++-- |+-- Create a 'Voice' from a list of 'Stretched' values.+--+-- This is a 'Getter' (rather than a function) for consistency:+--+-- @+-- [ (0 '<->' 1, 10)^.'stretched',+--   (1 '<->' 2, 20)^.'stretched',+--   (3 '<->' 4, 30)^.'stretched' ]^.'voice'+-- @+--+-- @+-- 'view' 'voice' $ 'map' ('view' 'stretched') [(0 '<->' 1, 1)]+-- @+--+-- Se also 'stretcheds'.+--+voice :: Getter [Stretched a] (Voice a)+voice = from unsafeStretcheds+-- voice = to $ flip (set stretcheds) empty+{-# INLINE voice #-}++-- |+-- View a 'Voice' as a list of 'Stretched' values.+--+-- @+-- 'view' 'stretcheds'                        :: 'Voice' a -> ['Stretched' a]+-- 'set'  'stretcheds'                        :: ['Stretched' a] -> 'Voice' a -> 'Voice' a+-- 'over' 'stretcheds'                        :: (['Stretched' a] -> ['Stretched' b]) -> 'Voice' a -> 'Voice' b+-- @+--+-- @+-- 'preview'  ('stretcheds' . 'each')           :: 'Voice' a -> 'Maybe' ('Stretched' a)+-- 'preview'  ('stretcheds' . 'element' 1)      :: 'Voice' a -> 'Maybe' ('Stretched' a)+-- 'preview'  ('stretcheds' . 'elements' odd)   :: 'Voice' a -> 'Maybe' ('Stretched' a)+-- @+--+-- @+-- 'set'      ('stretcheds' . 'each')           :: 'Stretched' a -> 'Voice' a -> 'Voice' a+-- 'set'      ('stretcheds' . 'element' 1)      :: 'Stretched' a -> 'Voice' a -> 'Voice' a+-- 'set'      ('stretcheds' . 'elements' odd)   :: 'Stretched' a -> 'Voice' a -> 'Voice' a+-- @+--+-- @+-- 'over'     ('stretcheds' . 'each')           :: ('Stretched' a -> 'Stretched' b) -> 'Voice' a -> 'Voice' b+-- 'over'     ('stretcheds' . 'element' 1)      :: ('Stretched' a -> 'Stretched' a) -> 'Voice' a -> 'Voice' a+-- 'over'     ('stretcheds' . 'elements' odd)   :: ('Stretched' a -> 'Stretched' a) -> 'Voice' a -> 'Voice' a+-- @+--+-- @+-- 'toListOf' ('stretcheds' . 'each')                :: 'Voice' a -> ['Stretched' a]+-- 'toListOf' ('stretcheds' . 'elements' odd)        :: 'Voice' a -> ['Stretched' a]+-- 'toListOf' ('stretcheds' . 'each' . 'filtered'+--              (\\x -> '_duration' x \< 2))  :: 'Voice' a -> ['Stretched' a]+-- @+--+-- This is not an 'Iso', as the note list representation does not contain meta-data.+-- To construct a score from a note list, use 'score' or @'flip' ('set' 'stretcheds') 'empty'@.+--+stretcheds :: Lens (Voice a) (Voice b) [Stretched a] [Stretched b]+stretcheds = unsafeStretcheds+{-# INLINE stretcheds #-}++eventsV :: Lens (Voice a) (Voice b) [(Duration, a)] [(Duration, b)]+eventsV = unsafeEventsV+{-# INLINE eventsV #-}++unsafeEventsV :: Iso (Voice a) (Voice b) [(Duration, a)] [(Duration, b)]+unsafeEventsV = iso (map (^.from stretched) . (^.stretcheds)) ((^.voice) . map (^.stretched))+{-# INLINE unsafeEventsV #-}++unsafeStretcheds :: Iso (Voice a) (Voice b) [Stretched a] [Stretched b]+unsafeStretcheds = _Wrapped+{-# INLINE unsafeStretcheds #-}++singleStretched :: Prism' (Voice a) (Stretched a)+singleStretched = unsafeStretcheds . single+{-# INLINE singleStretched #-}+++-- |+-- Unzip the given voice. This is specialization of 'unzipR'. +--+unzipVoice :: Voice (a, b) -> (Voice a, Voice b)+unzipVoice = unzipR++-- |+-- Join the given voices by multiplying durations and pairing values.+--+zipVoice :: Voice a -> Voice b -> Voice (a, b)+zipVoice = zipVoiceWith (,)++-- |+-- Join the given voices by multiplying durations and combining values using the given function.+--+zipVoiceWith :: (a -> b -> c) -> Voice a -> Voice b -> Voice c+zipVoiceWith = zipVoiceWith' (*)++-- |+-- 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++-- |+-- Join the given voices by combining durations and values using the given function.+--+zipVoiceWith' :: (Duration -> Duration -> Duration) -> (a -> b -> c) -> Voice a -> Voice b -> Voice c+zipVoiceWith' f g+  ((unzip.view eventsV) -> (ad, as))+  ((unzip.view eventsV) -> (bd, bs))+  = let cd = zipWith f ad bd+        cs = zipWith g as bs+     in view (from unsafeEventsV) (zip cd cs)++-- |+-- Merge consecutive equal notes.+--+fuse :: Eq a => Voice a -> Voice a+fuse = fuseBy (==)++-- |+-- Merge consecutive equal notes using the given function.+--+fuseBy :: (a -> a -> Bool) -> Voice a -> Voice a+fuseBy p = fuseBy' p head++-- |+-- Merge consecutive equal notes using the given equality predicate and merge function.+--+fuseBy' :: (a -> a -> Bool) -> ([a] -> a) -> Voice a -> Voice a+fuseBy' p g = over unsafeEventsV $ fmap foldNotes . Data.List.groupBy (inspectingBy snd p)+  where+    -- Add up durations and use a custom function to combine notes+    -- Typically, the combination function us just 'head', as we know that group returns+    -- non-empty lists of equal elements.+    foldNotes (unzip -> (ds, as)) = (sum ds, g as)+++withContext :: Voice a -> Voice (Maybe a, a, Maybe a)+withContext = over valuesV withPrevNext++--+-- TODO more elegant definition of durationsV and valuesV using indexed traversal or similar?+--++durationsV :: Lens' (Voice a) [Duration]+durationsV = lens getDurs (flip setDurs)+  where+    getDurs :: Voice a -> [Duration]+    getDurs = map fst . view eventsV++    setDurs :: [Duration] -> Voice a -> Voice a+    setDurs ds as = zipVoiceWith' (\a b -> a) (\a b -> b) (mconcat $ map durToVoice ds) as++    durToVoice d = stretch d $ pure ()++valuesV :: Lens (Voice a) (Voice b) [a] [b]+valuesV = lens getValues (flip setValues)+  where+    getValues :: Voice a -> [a]+    getValues = map snd . view eventsV++    setValues :: [a] -> Voice b -> Voice a+    setValues as bs = zipVoiceWith' (\a b -> b) (\a b -> a) (listToVoice as) bs++    listToVoice = mconcat . map pure++-- |+-- Transform the durations, leaving values intact.+withDurations :: ([Duration] -> [Duration]) -> Voice a -> Voice a+withDurations = over durationsV++-- |+-- Transform the values, leaving durations intact.+withValues :: ([a] -> [b]) -> Voice a -> Voice b+withValues = over valuesV++-- |+-- Rotate durations by the given number of steps, leaving values intact.+--+rotateDurations :: Int -> Voice a -> Voice a+rotateDurations n = over durationsV (rotate n)++-- |+-- Rotate values by the given number of steps, leaving durations intact.+--+rotateValues :: Int -> Voice a -> Voice a+rotateValues n = over valuesV (rotate n)++-- |+-- Reverse durations, leaving values intact.+--+reverseDurations :: Voice a -> Voice a+reverseDurations = over durationsV reverse++-- |+-- Reverse values, leaving durations intact.+--+reverseValues :: Voice a -> Voice a+reverseValues = over valuesV reverse+++--+-- TODO+-- Implement meta-data+--++--+-- TODO make Voice/Voice an instance of Cons/Snoc and remove these+--++headV :: Traversal' (Voice a) a+headV = (eventsV._head._2)++middleV :: Traversal' (Voice a) a+middleV = (eventsV._middle.traverse._2)++lastV :: Traversal' (Voice a) a+lastV = (eventsV._last._2)++-- Traverse writing to all elements *except* first and last+_middle :: (Snoc s s a a, Cons s s b b) => Traversal' s s+_middle = _tail._init++