diff --git a/music-score.cabal b/music-score.cabal --- a/music-score.cabal +++ b/music-score.cabal @@ -1,6 +1,6 @@ name: music-score -version: 1.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 diff --git a/src/Data/Clipped.hs b/src/Data/Clipped.hs new file mode 100644 --- /dev/null +++ b/src/Data/Clipped.hs @@ -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 (+) diff --git a/src/Data/Functor/Context.hs b/src/Data/Functor/Context.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Context.hs @@ -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 + diff --git a/src/Data/Functor/Couple.hs b/src/Data/Functor/Couple.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Couple.hs @@ -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 + diff --git a/src/Data/Functor/Rep/Lens.hs b/src/Data/Functor/Rep/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Rep/Lens.hs @@ -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 + + diff --git a/src/Data/Semigroup/Instances.hs b/src/Data/Semigroup/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semigroup/Instances.hs @@ -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 +-} diff --git a/src/Music/Score.hs b/src/Music/Score.hs --- a/src/Music/Score.hs +++ b/src/Music/Score.hs @@ -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 diff --git a/src/Music/Score/Articulation.hs b/src/Music/Score/Articulation.hs --- a/src/Music/Score/Articulation.hs +++ b/src/Music/Score/Articulation.hs @@ -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 diff --git a/src/Music/Score/Chord.hs b/src/Music/Score/Chord.hs deleted file mode 100644 --- a/src/Music/Score/Chord.hs +++ /dev/null @@ -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 - - - - - diff --git a/src/Music/Score/Clef.hs b/src/Music/Score/Clef.hs --- a/src/Music/Score/Clef.hs +++ b/src/Music/Score/Clef.hs @@ -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 diff --git a/src/Music/Score/Color.hs b/src/Music/Score/Color.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Color.hs @@ -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 + diff --git a/src/Music/Score/Combinators.hs b/src/Music/Score/Combinators.hs deleted file mode 100644 --- a/src/Music/Score/Combinators.hs +++ /dev/null @@ -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) - diff --git a/src/Music/Score/Convert.hs b/src/Music/Score/Convert.hs --- a/src/Music/Score/Convert.hs +++ b/src/Music/Score/Convert.hs @@ -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 diff --git a/src/Music/Score/Dynamics.hs b/src/Music/Score/Dynamics.hs --- a/src/Music/Score/Dynamics.hs +++ b/src/Music/Score/Dynamics.hs @@ -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 diff --git a/src/Music/Score/Export/Abc.hs b/src/Music/Score/Export/Abc.hs --- a/src/Music/Score/Export/Abc.hs +++ b/src/Music/Score/Export/Abc.hs @@ -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 diff --git a/src/Music/Score/Export/ArticulationNotation.hs b/src/Music/Score/Export/ArticulationNotation.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Export/ArticulationNotation.hs @@ -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] + _ -> [] + diff --git a/src/Music/Score/Export/Backend.hs b/src/Music/Score/Export/Backend.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Export/Backend.hs @@ -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 + diff --git a/src/Music/Score/Export/Common.hs b/src/Music/Score/Export/Common.hs deleted file mode 100644 --- a/src/Music/Score/Export/Common.hs +++ /dev/null @@ -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] - diff --git a/src/Music/Score/Export/DynamicNotation.hs b/src/Music/Score/Export/DynamicNotation.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Export/DynamicNotation.hs @@ -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) diff --git a/src/Music/Score/Export/Lilypond.hs b/src/Music/Score/Export/Lilypond.hs --- a/src/Music/Score/Export/Lilypond.hs +++ b/src/Music/Score/Export/Lilypond.hs @@ -1,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 diff --git a/src/Music/Score/Export/Midi.hs b/src/Music/Score/Export/Midi.hs --- a/src/Music/Score/Export/Midi.hs +++ b/src/Music/Score/Export/Midi.hs @@ -1,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 diff --git a/src/Music/Score/Export/MusicXml.hs b/src/Music/Score/Export/MusicXml.hs --- a/src/Music/Score/Export/MusicXml.hs +++ b/src/Music/Score/Export/MusicXml.hs @@ -1,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 +-- diff --git a/src/Music/Score/Export/NoteList.hs b/src/Music/Score/Export/NoteList.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Export/NoteList.hs @@ -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) + + diff --git a/src/Music/Score/Export/SuperCollider.hs b/src/Music/Score/Export/SuperCollider.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Export/SuperCollider.hs @@ -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 +-- ). 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" + diff --git a/src/Music/Score/Harmonics.hs b/src/Music/Score/Harmonics.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Harmonics.hs @@ -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 + + + diff --git a/src/Music/Score/Import/Abc.hs b/src/Music/Score/Import/Abc.hs --- a/src/Music/Score/Import/Abc.hs +++ b/src/Music/Score/Import/Abc.hs @@ -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 diff --git a/src/Music/Score/Import/Lilypond.hs b/src/Music/Score/Import/Lilypond.hs --- a/src/Music/Score/Import/Lilypond.hs +++ b/src/Music/Score/Import/Lilypond.hs @@ -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 diff --git a/src/Music/Score/Import/Midi.hs b/src/Music/Score/Import/Midi.hs --- a/src/Music/Score/Import/Midi.hs +++ b/src/Music/Score/Import/Midi.hs @@ -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 ) diff --git a/src/Music/Score/Instances.hs b/src/Music/Score/Instances.hs --- a/src/Music/Score/Instances.hs +++ b/src/Music/Score/Instances.hs @@ -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)) diff --git a/src/Music/Score/Internal/Export.hs b/src/Music/Score/Internal/Export.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Internal/Export.hs @@ -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 +-} diff --git a/src/Music/Score/Internal/Util.hs b/src/Music/Score/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Internal/Util.hs @@ -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 + diff --git a/src/Music/Score/Meta.hs b/src/Music/Score/Meta.hs --- a/src/Music/Score/Meta.hs +++ b/src/Music/Score/Meta.hs @@ -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 + diff --git a/src/Music/Score/Meta/Annotations.hs b/src/Music/Score/Meta/Annotations.hs --- a/src/Music/Score/Meta/Annotations.hs +++ b/src/Music/Score/Meta/Annotations.hs @@ -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) diff --git a/src/Music/Score/Meta/Attribution.hs b/src/Music/Score/Meta/Attribution.hs --- a/src/Music/Score/Meta/Attribution.hs +++ b/src/Music/Score/Meta/Attribution.hs @@ -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. diff --git a/src/Music/Score/Meta/Barline.hs b/src/Music/Score/Meta/Barline.hs --- a/src/Music/Score/Meta/Barline.hs +++ b/src/Music/Score/Meta/Barline.hs @@ -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 diff --git a/src/Music/Score/Meta/Clef.hs b/src/Music/Score/Meta/Clef.hs --- a/src/Music/Score/Meta/Clef.hs +++ b/src/Music/Score/Meta/Clef.hs @@ -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) + diff --git a/src/Music/Score/Meta/Fermata.hs b/src/Music/Score/Meta/Fermata.hs --- a/src/Music/Score/Meta/Fermata.hs +++ b/src/Music/Score/Meta/Fermata.hs @@ -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 diff --git a/src/Music/Score/Meta/Key.hs b/src/Music/Score/Meta/Key.hs --- a/src/Music/Score/Meta/Key.hs +++ b/src/Music/Score/Meta/Key.hs @@ -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 diff --git a/src/Music/Score/Meta/RehearsalMark.hs b/src/Music/Score/Meta/RehearsalMark.hs --- a/src/Music/Score/Meta/RehearsalMark.hs +++ b/src/Music/Score/Meta/RehearsalMark.hs @@ -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 diff --git a/src/Music/Score/Meta/Tempo.hs b/src/Music/Score/Meta/Tempo.hs --- a/src/Music/Score/Meta/Tempo.hs +++ b/src/Music/Score/Meta/Tempo.hs @@ -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) + diff --git a/src/Music/Score/Meta/Time.hs b/src/Music/Score/Meta/Time.hs --- a/src/Music/Score/Meta/Time.hs +++ b/src/Music/Score/Meta/Time.hs @@ -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 - diff --git a/src/Music/Score/Meta/Title.hs b/src/Music/Score/Meta/Title.hs --- a/src/Music/Score/Meta/Title.hs +++ b/src/Music/Score/Meta/Title.hs @@ -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 diff --git a/src/Music/Score/Note.hs b/src/Music/Score/Note.hs deleted file mode 100644 --- a/src/Music/Score/Note.hs +++ /dev/null @@ -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) diff --git a/src/Music/Score/Ornaments.hs b/src/Music/Score/Ornaments.hs deleted file mode 100644 --- a/src/Music/Score/Ornaments.hs +++ /dev/null @@ -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 - diff --git a/src/Music/Score/Part.hs b/src/Music/Score/Part.hs --- a/src/Music/Score/Part.hs +++ b/src/Music/Score/Part.hs @@ -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 + diff --git a/src/Music/Score/Phrases.hs b/src/Music/Score/Phrases.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Phrases.hs @@ -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) + + + diff --git a/src/Music/Score/Pitch.hs b/src/Music/Score/Pitch.hs --- a/src/Music/Score/Pitch.hs +++ b/src/Music/Score/Pitch.hs @@ -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 + diff --git a/src/Music/Score/Rhythm.hs b/src/Music/Score/Rhythm.hs deleted file mode 100644 --- a/src/Music/Score/Rhythm.hs +++ /dev/null @@ -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 diff --git a/src/Music/Score/Score.hs b/src/Music/Score/Score.hs deleted file mode 100644 --- a/src/Music/Score/Score.hs +++ /dev/null @@ -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)) diff --git a/src/Music/Score/Slide.hs b/src/Music/Score/Slide.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Slide.hs @@ -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 + diff --git a/src/Music/Score/Text.hs b/src/Music/Score/Text.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Text.hs @@ -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 + diff --git a/src/Music/Score/Ties.hs b/src/Music/Score/Ties.hs --- a/src/Music/Score/Ties.hs +++ b/src/Music/Score/Ties.hs @@ -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 diff --git a/src/Music/Score/Track.hs b/src/Music/Score/Track.hs deleted file mode 100644 --- a/src/Music/Score/Track.hs +++ /dev/null @@ -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 - diff --git a/src/Music/Score/Tremolo.hs b/src/Music/Score/Tremolo.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Tremolo.hs @@ -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 + diff --git a/src/Music/Score/Util.hs b/src/Music/Score/Util.hs deleted file mode 100644 --- a/src/Music/Score/Util.hs +++ /dev/null @@ -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 diff --git a/src/Music/Score/Voice.hs b/src/Music/Score/Voice.hs deleted file mode 100644 --- a/src/Music/Score/Voice.hs +++ /dev/null @@ -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 - - diff --git a/src/Music/Time.hs b/src/Music/Time.hs --- a/src/Music/Time.hs +++ b/src/Music/Time.hs @@ -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 diff --git a/src/Music/Time/Behavior.hs b/src/Music/Time/Behavior.hs --- a/src/Music/Time/Behavior.hs +++ b/src/Music/Time/Behavior.hs @@ -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 _ = "<>" -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 + diff --git a/src/Music/Time/Bound.hs b/src/Music/Time/Bound.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Bound.hs @@ -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 + diff --git a/src/Music/Time/Chord.hs b/src/Music/Time/Chord.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Chord.hs @@ -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) + diff --git a/src/Music/Time/Delayable.hs b/src/Music/Time/Delayable.hs deleted file mode 100644 --- a/src/Music/Time/Delayable.hs +++ /dev/null @@ -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 diff --git a/src/Music/Time/Delayed.hs b/src/Music/Time/Delayed.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Delayed.hs @@ -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) + diff --git a/src/Music/Time/Duration.hs b/src/Music/Time/Duration.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Duration.hs @@ -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 #-} + diff --git a/src/Music/Time/Internal/Quantize.hs b/src/Music/Time/Internal/Quantize.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Internal/Quantize.hs @@ -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 + diff --git a/src/Music/Time/Internal/Transform.hs b/src/Music/Time/Internal/Transform.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Internal/Transform.hs @@ -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 + diff --git a/src/Music/Time/Internal/Util.hs b/src/Music/Time/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Internal/Util.hs @@ -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 + diff --git a/src/Music/Time/Juxtapose.hs b/src/Music/Time/Juxtapose.hs --- a/src/Music/Time/Juxtapose.hs +++ b/src/Music/Time/Juxtapose.hs @@ -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`) +-} diff --git a/src/Music/Time/Meta.hs b/src/Music/Time/Meta.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Meta.hs @@ -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) + diff --git a/src/Music/Time/Note.hs b/src/Music/Time/Note.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Note.hs @@ -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 + + + diff --git a/src/Music/Time/Onset.hs b/src/Music/Time/Onset.hs deleted file mode 100644 --- a/src/Music/Time/Onset.hs +++ /dev/null @@ -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 - diff --git a/src/Music/Time/Position.hs b/src/Music/Time/Position.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Position.hs @@ -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 #-} + + diff --git a/src/Music/Time/Reactive.hs b/src/Music/Time/Reactive.hs --- a/src/Music/Time/Reactive.hs +++ b/src/Music/Time/Reactive.hs @@ -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 , @@ -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 } + -} + + diff --git a/src/Music/Time/Rest.hs b/src/Music/Time/Rest.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Rest.hs @@ -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 diff --git a/src/Music/Time/Reverse.hs b/src/Music/Time/Reverse.hs --- a/src/Music/Time/Reverse.hs +++ b/src/Music/Time/Reverse.hs @@ -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) + -} diff --git a/src/Music/Time/Score.hs b/src/Music/Time/Score.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Score.hs @@ -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 + diff --git a/src/Music/Time/Segment.hs b/src/Music/Time/Segment.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Segment.hs @@ -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 _ = "<>" + +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 + + diff --git a/src/Music/Time/Span.hs b/src/Music/Time/Span.hs deleted file mode 100644 --- a/src/Music/Time/Span.hs +++ /dev/null @@ -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) - - diff --git a/src/Music/Time/Split.hs b/src/Music/Time/Split.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Split.hs @@ -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 + + diff --git a/src/Music/Time/Stretchable.hs b/src/Music/Time/Stretchable.hs deleted file mode 100644 --- a/src/Music/Time/Stretchable.hs +++ /dev/null @@ -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 diff --git a/src/Music/Time/Stretched.hs b/src/Music/Time/Stretched.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Stretched.hs @@ -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 diff --git a/src/Music/Time/Time.hs b/src/Music/Time/Time.hs deleted file mode 100644 --- a/src/Music/Time/Time.hs +++ /dev/null @@ -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 - diff --git a/src/Music/Time/Track.hs b/src/Music/Time/Track.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Track.hs @@ -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 #-} + diff --git a/src/Music/Time/Transform.hs b/src/Music/Time/Transform.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Transform.hs @@ -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 + diff --git a/src/Music/Time/Types.hs b/src/Music/Time/Types.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Types.hs @@ -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) + diff --git a/src/Music/Time/Voice.hs b/src/Music/Time/Voice.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Voice.hs @@ -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 + +