diff --git a/music-score.cabal b/music-score.cabal --- a/music-score.cabal +++ b/music-score.cabal @@ -1,6 +1,6 @@ name: music-score -version: 1.7.2 +version: 1.8 author: Hans Hoglund maintainer: Hans Hoglund license: BSD3 @@ -23,7 +23,7 @@ library build-depends: base >= 4 && < 5, aeson >= 0.7.0.6 && < 1, - lens >= 4.3.3 && < 4.4, + lens >= 4.6 && < 4.7, process >= 1.2 && < 1.3, containers, void, @@ -31,7 +31,6 @@ data-default, average >= 0.6 && < 1, semigroups >= 0.13.0.1 && < 1, - semigroupoids, contravariant >= 1.2 && < 2, comonad >= 4.2.2 && < 5, bifunctors >= 4.1.1.1 && < 5, @@ -39,6 +38,7 @@ distributive >= 0.4.4 && < 5, adjunctions >= 4.2 && < 5, transformers >= 0.3.0.0 && < 0.5, + transformers-compat >= 0.3.3.4 && < 0.5, mtl >= 2.1.2 && < 2.3, monadplus, NumInstances, @@ -46,11 +46,10 @@ HCodecs >= 0.5 && < 0.6, vector-space >= 0.8.7 && < 0.9, vector-space-points >= 0.2 && < 0.3, - musicxml2 == 1.7.2, - lilypond == 1.7.2, - music-pitch-literal == 1.7.2, - music-dynamics-literal == 1.7.2, - + musicxml2 == 1.8, + lilypond == 1.8, + music-pitch-literal == 1.8, + music-dynamics-literal == 1.8, prettify, parsec exposed-modules: Data.Clipped @@ -70,9 +69,10 @@ Music.Time.Reverse Music.Time.Juxtapose Music.Time.Rest - Music.Time.Stretched - Music.Time.Delayed + Music.Time.Aligned Music.Time.Note + Music.Time.Placed + Music.Time.Event Music.Time.Future Music.Time.Past Music.Time.Nominal @@ -126,14 +126,14 @@ Music.Score.Import.Abc Music.Score.Import.Lilypond Music.Score.Import.Midi - Music.Score.Instances -- We expose these to allow GHCI development Music.Time.Internal.Convert Music.Time.Internal.Util Music.Time.Internal.Transform Music.Time.Internal.Quantize + Music.Score.Internal.Instances Music.Score.Internal.Util Music.Score.Internal.Export hs-source-dirs: src default-language: Haskell2010 - --ghc-options: -fwarn-unused-imports + ghc-options: -fno-warn-typed-holes diff --git a/src/Data/Functor/Context.hs b/src/Data/Functor/Context.hs --- a/src/Data/Functor/Context.hs +++ b/src/Data/Functor/Context.hs @@ -5,8 +5,10 @@ module Data.Functor.Context ( Ctxt(..), + toCtxt, mapCtxt, extractCtxt, + addCtxt, ) where import Control.Comonad @@ -14,10 +16,14 @@ import Control.Lens.Wrapped import Control.Lens.Iso --- TODO use newtype and derivice Functor, Comonad etc +-- | A value with a possible predecessor and successor. +-- Can be used to traverse values with their immediate context. newtype Ctxt a = Ctxt { getCtxt :: (Maybe a, a, Maybe a) } - deriving (Functor) + deriving (Functor, Eq, Ord) +instance Show a => Show (Ctxt a) where + show (Ctxt vs) = "toCtxt " ++ show vs + instance Wrapped (Ctxt a) where type Unwrapped (Ctxt a) = (Maybe a, a, Maybe a) _Wrapped' = iso getCtxt Ctxt @@ -36,9 +42,17 @@ -- duplicate (Ctxt (Nothing,x,Just a)) = Ctxt (Nothing, Ctxt (Nothing, x, Just a), Just a) -- duplicate (Ctxt (Just b,x,Just a)) = Ctxt (b, Ctxt (b, x, Just a), Just a) +toCtxt = Ctxt + mapCtxt :: (a -> b) -> Ctxt a -> Ctxt b mapCtxt = fmap extractCtxt :: Ctxt a -> a extractCtxt (Ctxt (_,x,_)) = x + +addCtxt :: [a] -> [Ctxt a] +addCtxt = fmap Ctxt . withPrevNext + where + withPrevNext :: [a] -> [(Maybe a, a, Maybe a)] + withPrevNext xs = zip3 (pure Nothing ++ fmap Just xs) xs (fmap Just (tail xs) ++ repeat Nothing) diff --git a/src/Music/Score.hs b/src/Music/Score.hs --- a/src/Music/Score.hs +++ b/src/Music/Score.hs @@ -12,7 +12,6 @@ ------------------------------------------------------------------------------------- module Music.Score ( - -- * Prerequisites module Control.Lens, module Control.Applicative, module Control.Monad, @@ -24,9 +23,6 @@ module Music.Time, -- module Music.Score.Combinators, - - -- * Music representation - -- ** Musical elements module Music.Score.Part, module Music.Score.Pitch, module Music.Score.Dynamics, @@ -37,12 +33,9 @@ module Music.Score.Harmonics, module Music.Score.Color, - -- ** Miscellaneous module Music.Score.Ties, module Music.Score.Phrases, - -- module Music.Score.Clef, - -- ** Meta-information module Music.Score.Meta, module Music.Score.Meta.Title, module Music.Score.Meta.Attribution, @@ -55,12 +48,10 @@ module Music.Score.Meta.Tempo, module Music.Score.Meta.Annotations, - -- * 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.Backend, module Music.Score.Export.NoteList, module Music.Score.Export.Midi, @@ -92,7 +83,6 @@ import Music.Time hiding (time) import Music.Score.Articulation --- import Music.Score.Clef import Music.Score.Color import Music.Score.Dynamics import Music.Score.Export.Backend @@ -107,7 +97,7 @@ import Music.Score.Import.Abc import Music.Score.Import.Lilypond import Music.Score.Import.Midi -import Music.Score.Instances +import Music.Score.Internal.Instances import Music.Score.Meta import Music.Score.Meta.Annotations import Music.Score.Meta.Attribution 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 @@ -187,17 +187,15 @@ type instance Articulation (Either c a) = Articulation a type instance SetArticulation b (Either c a) = Either c (SetArticulation b a) +type instance Articulation (Event a) = Articulation a +type instance SetArticulation g (Event a) = Event (SetArticulation g a) +type instance Articulation (Placed a) = Articulation a +type instance SetArticulation g (Placed a) = Placed (SetArticulation g a) 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) 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 @@ -221,30 +219,34 @@ -instance (HasArticulations a b) => HasArticulations (Note a) (Note b) where - articulations = _Wrapped . whilstL articulations +instance (HasArticulations a b) => HasArticulations (Event a) (Event b) where + articulations = from event . whilstL articulations -instance (HasArticulation a b) => HasArticulation (Note a) (Note b) where - articulation = _Wrapped . whilstL articulation +instance (HasArticulation a b) => HasArticulation (Event a) (Event b) where + articulation = from event . whilstL articulation -instance (HasArticulations a b) => HasArticulations (Delayed a) (Delayed b) where +instance (HasArticulations a b) => HasArticulations (Placed a) (Placed b) where articulations = _Wrapped . whilstLT articulations -instance (HasArticulation a b) => HasArticulation (Delayed a) (Delayed b) where +instance (HasArticulation a b) => HasArticulation (Placed a) (Placed b) where articulation = _Wrapped . whilstLT articulation -instance (HasArticulations a b) => HasArticulations (Stretched a) (Stretched b) where +instance (HasArticulations a b) => HasArticulations (Note a) (Note b) where articulations = _Wrapped . whilstLD articulations -instance (HasArticulation a b) => HasArticulation (Stretched a) (Stretched b) where +instance (HasArticulation a b) => HasArticulation (Note a) (Note b) where articulation = _Wrapped . whilstLD articulation instance HasArticulations a b => HasArticulations (Voice a) (Voice b) where articulations = traverse . articulations +{- +type instance Articulation (Chord a) = Articulation a +type instance SetArticulation b (Chord a) = Chord (SetArticulation b a) 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 @@ -254,7 +256,7 @@ _Wrapped . _2 -- into NScore . _Wrapped . traverse - . _Wrapped -- this needed? + . from event -- this needed? . whilstL articulations type instance Articulation (Couple c a) = Articulation a @@ -439,6 +441,7 @@ deriving instance Reversible a => Reversible (ArticulationT p a) instance (Tiable n, Tiable a) => Tiable (ArticulationT n a) where + isTieEndBeginning (ArticulationT (_,a)) = isTieEndBeginning a toTied (ArticulationT (d,a)) = (ArticulationT (d1,a1), ArticulationT (d2,a2)) where (a1,a2) = toTied a diff --git a/src/Music/Score/Color.hs b/src/Music/Score/Color.hs --- a/src/Music/Score/Color.hs +++ b/src/Music/Score/Color.hs @@ -112,6 +112,7 @@ (<>) = liftA2 (<>) instance Tiable a => Tiable (ColorT a) where + isTieEndBeginning (ColorT (Couple (_,a))) = isTieEndBeginning a toTied (ColorT (Couple (n,a))) = (ColorT $ Couple (n,b), ColorT $ Couple (n,c)) where (b,c) = toTied a diff --git a/src/Music/Score/Dynamics.hs b/src/Music/Score/Dynamics.hs --- a/src/Music/Score/Dynamics.hs +++ b/src/Music/Score/Dynamics.hs @@ -177,17 +177,15 @@ 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 (Event a) = Dynamic a +type instance SetDynamic b (Event a) = Event (SetDynamic b a) +type instance Dynamic (Placed a) = Dynamic a +type instance SetDynamic b (Placed a) = Placed (SetDynamic b a) +type instance Dynamic (Note a) = Dynamic a +type instance SetDynamic b (Note a) = Note (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 @@ -210,24 +208,24 @@ -instance (HasDynamics a b) => HasDynamics (Note a) (Note b) where - dynamics = _Wrapped . whilstL dynamics +instance (HasDynamics a b) => HasDynamics (Event a) (Event b) where + dynamics = from event . whilstL dynamics -instance (HasDynamic a b) => HasDynamic (Note a) (Note b) where - dynamic = _Wrapped . whilstL dynamic +instance (HasDynamic a b) => HasDynamic (Event a) (Event b) where + dynamic = from event . whilstL dynamic -instance (HasDynamics a b) => HasDynamics (Delayed a) (Delayed b) where +instance (HasDynamics a b) => HasDynamics (Placed a) (Placed b) where dynamics = _Wrapped . whilstLT dynamics -instance (HasDynamic a b) => HasDynamic (Delayed a) (Delayed b) where +instance (HasDynamic a b) => HasDynamic (Placed a) (Placed b) where dynamic = _Wrapped . whilstLT dynamic -instance (HasDynamics a b) => HasDynamics (Stretched a) (Stretched b) where +instance (HasDynamics a b) => HasDynamics (Note a) (Note b) where dynamics = _Wrapped . whilstLD dynamics -instance (HasDynamic a b) => HasDynamic (Stretched a) (Stretched b) where +instance (HasDynamic a b) => HasDynamic (Note a) (Note b) where dynamic = _Wrapped . whilstLD dynamic @@ -237,15 +235,19 @@ instance HasDynamics a b => HasDynamics (Track a) (Track b) where dynamics = traverse . dynamics +{- +type instance Dynamic (Chord a) = Dynamic a +type instance SetDynamic b (Chord a) = Chord (SetDynamic b a) 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? + . from event -- this needed? . whilstL dynamics type instance Dynamic (Behavior a) = Behavior a @@ -454,6 +456,7 @@ deriving instance Reversible a => Reversible (DynamicT p a) instance (Tiable n, Tiable a) => Tiable (DynamicT n a) where + isTieEndBeginning (DynamicT (_,a)) = isTieEndBeginning a toTied (DynamicT (d,a)) = (DynamicT (d1,a1), DynamicT (d2,a2)) where (a1,a2) = toTied a diff --git a/src/Music/Score/Export/ArticulationNotation.hs b/src/Music/Score/Export/ArticulationNotation.hs --- a/src/Music/Score/Export/ArticulationNotation.hs +++ b/src/Music/Score/Export/ArticulationNotation.hs @@ -42,7 +42,7 @@ import Data.Functor.Adjunction (unzipR) import Control.Lens -- () import Music.Score.Articulation -import Music.Score.Instances +-- import Music.Score.Instances import Music.Score.Ties import Music.Time 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 @@ -315,7 +315,7 @@ 1 -> Lilypond.Alto 2 -> Lilypond.Bass addStaffInfo = (,) $ StaffInfo { staffName = name, staffClef = clef } - splitIntoBars = splitTiesVoiceAt + splitIntoBars = splitTiesAt exportBar timeSignature = LyBar @@ -324,7 +324,7 @@ where addBarInfo = (,) $ BarInfo timeSignature - quantizeBar = mapWithDur LyContext . rewrite . handleErrors . quantize . view eventsV + quantizeBar = mapWithDur LyContext . rewrite . handleErrors . quantize . view pairs where -- FIXME propagate quantization errors handleErrors (Left e) = error $ "Quantization failed: " ++ e 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 @@ -163,7 +163,7 @@ setProgramChannel ch prg = ([(0, Midi.ProgramChange ch prg)] <>) . fmap (fmap $ setC ch) scoreToMidiTrack :: Score Midi.Message -> Midi.Track Midi.Ticks - scoreToMidiTrack = fmap (\(t,_,x) -> (round ((t .-. 0) ^* divisions), x)) . toRelative . (^. events) + scoreToMidiTrack = fmap (\(t,_,x) -> (round ((t .-. 0) ^* divisions), x)) . toRelative . (^. triples) -- Hardcoded values for Midi export -- We always generate MultiTrack (type 1) files with division 1024 @@ -185,11 +185,12 @@ exportScore _ xs = MidiScore [((getMidiChannel (xs^?!parts), getMidiProgram (xs^?!parts)), fmap Identity $ voiceToScore xs)] where voiceToScore :: Voice a -> Score a - voiceToScore = error "FIXME" + voiceToScore = renderAlignedVoice . aligned (0 :: Time) (0 :: LocalDuration) 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)) $ extractPartsWithInfo $ fixTempo xs) + exportScore _ xs = MidiScore (map (\(p,sc) -> ((getMidiChannel p, getMidiProgram p), fmap Identity sc)) + $ extractPartsWithInfo $ fixTempo $ normalizeScore 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 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 @@ -306,7 +306,7 @@ 1 -> (MusicXml.CClef, 3) 2 -> (MusicXml.FClef, 4) addStaffInfo = (,) $ StaffInfo { staffClef = clef } - splitIntoBars = splitTiesVoiceAt + splitIntoBars = splitTiesAt exportBar timeSignature = XmlBar @@ -315,7 +315,7 @@ where addBarInfo = (,) $ BarInfo timeSignature - quantizeBar = mapWithDur XmlContext . rewrite . handleErrors . quantize . view eventsV + quantizeBar = mapWithDur XmlContext . rewrite . handleErrors . quantize . view pairs where -- FIXME propagate quantization errors handleErrors (Left e) = error $ "Quantization failed: " ++ e diff --git a/src/Music/Score/Export/SuperCollider.hs b/src/Music/Score/Export/SuperCollider.hs --- a/src/Music/Score/Export/SuperCollider.hs +++ b/src/Music/Score/Export/SuperCollider.hs @@ -124,7 +124,7 @@ composeTracksInParallel = (\x -> "Ppar([" ++ x ++ "])") . Data.List.intercalate ", " exportTrack :: [(Duration, Maybe ScEvent)] -> String - exportTrack events = "Pbind(" + exportTrack triples = "Pbind(" ++ "\\dur, Pseq(" ++ show durs ++ ")" ++ ", " ++ "\\midinote, Pseq(" ++ showRestList pitches ++ ")" @@ -134,18 +134,18 @@ . Data.List.intercalate ", " . map (maybe "\\rest" show) - -- events :: ScEvent + -- triples :: 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 + durs = map (realToFrac . fst) triples + pitches = map (fmap fst . snd) triples + ampls = map (fmap snd . snd) triples instance () => HasBackendScore SuperCollider (Voice (Maybe a)) where type BackendScoreEvent SuperCollider (Voice (Maybe a)) = a - exportScore _ xs = Identity <$> ScScore [view eventsV xs] + exportScore _ xs = Identity <$> ScScore [view pairs xs] instance (HasPart' a, Ord (Part a)) => HasBackendScore SuperCollider (Score a) where type BackendScoreEvent SuperCollider (Score a) = a diff --git a/src/Music/Score/Instances.hs b/src/Music/Score/Instances.hs deleted file mode 100644 --- a/src/Music/Score/Instances.hs +++ /dev/null @@ -1,343 +0,0 @@ - -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} - -------------------------------------------------------------------------------------- --- | --- Copyright : (c) Hans Hoglund 2012-2014 --- --- License : BSD-style --- --- Maintainer : hans@hanshoglund.se --- Stability : experimental --- Portability : non-portable (TF,GNTD) --- --- Provides miscellaneous instances. --- -------------------------------------------------------------------------------------- - -module Music.Score.Instances () where - -import Control.Applicative -import Control.Comonad -import Control.Lens hiding (part, transform) -import Control.Monad -import Data.AffineSpace -import Data.Default -import Data.Monoid.Average -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 hiding (Sum) -import Data.Semigroup.Instances -import Data.Functor.Context - -import Music.Dynamics.Literal -import Music.Pitch.Alterable -import Music.Pitch.Augmentable -import Music.Pitch.Literal -import Music.Score.Articulation -import Music.Score.Color -import Music.Score.Dynamics -import Music.Score.Harmonics -import Music.Score.Meta -import Music.Score.Part -import Music.Score.Pitch -import Music.Score.Slide -import Music.Score.Text -import Music.Score.Ties -import Music.Score.Tremolo -import Music.Time - --- ------------------------------------------------------------------------------------- --- --- 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 Chord for - -- all Preludes). See #134 -instance Semigroup a => Semigroup (HarmonicT a) where - (<>) = liftA2 (<>) -instance Semigroup a => Semigroup (TextT a) where - (<>) = liftA2 (<>) -instance Semigroup a => Semigroup (PartT n a) where - PartT (v1,x1) <> PartT (v2,x2) = PartT (v1, x1 <> x2) - - --- ------------------------------------------------------------------------------------- - --- --- Aspect instaces (Pitch, Dynamics and Articulation) for PartT needs to go here, --- as the other aspects depends on partwise traversals etc --- - -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 - -type instance Pitch (DynamicT p a) = Pitch a -type instance SetPitch b (DynamicT p a) = DynamicT p (SetPitch b a) - -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 (ArticulationT p a) = Pitch a -type instance SetPitch b (ArticulationT p a) = ArticulationT p (SetPitch b 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 - - - -type instance Dynamic (PartT p a) = Dynamic a -type instance SetDynamic b (PartT p a) = PartT p (SetDynamic b 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 - -type instance Dynamic (ArticulationT p a) = Dynamic a -type instance SetDynamic b (ArticulationT p a) = ArticulationT p (SetDynamic b a) - -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 - - - -type instance Articulation (PartT p a) = Articulation a -type instance SetArticulation b (PartT p a) = PartT p (SetArticulation b a) - -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 - --- 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 - -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 - - --- ------------------------------------------------------------------------------------- - -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) - - -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) - - - --- TextT - -instance Tiable a => Tiable (TextT a) where - 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) - - --- HarmonicT - -instance Tiable a => Tiable (HarmonicT a) where - -- 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) - - --- SlideT - - -instance Tiable a => Tiable (SlideT a) where - 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) - - - - -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) - -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) - -deriving instance Transformable a => Transformable (SlideT a) -deriving instance Transformable a => Transformable (HarmonicT a) -deriving instance Transformable a => Transformable (TextT a) - -deriving instance Reversible a => Reversible (SlideT a) -deriving instance Reversible a => Reversible (HarmonicT a) -deriving instance Reversible a => Reversible (TextT a) - -deriving instance Alterable a => Alterable (SlideT a) -deriving instance Alterable a => Alterable (HarmonicT a) -deriving instance Alterable a => Alterable (TextT a) - -deriving instance Augmentable a => Augmentable (SlideT a) -deriving instance Augmentable a => Augmentable (HarmonicT a) -deriving instance Augmentable a => Augmentable (TextT a) - - - -------------------------------------------------------------------------------------- --- Literal instances -------------------------------------------------------------------------------------- - - -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 -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 --- ------------------------------------------------------------------------------------- --- --- PartT - -instance (Enum v, Eq v, Num a) => Num (PartT v a) where - PartT (v,a) + PartT (_,b) = PartT (v,a+b) - PartT (v,a) * PartT (_,b) = PartT (v,a*b) - PartT (v,a) - PartT (_,b) = PartT (v,a-b) - abs (PartT (v,a)) = PartT (v,abs a) - signum (PartT (v,a)) = PartT (v,signum a) - fromInteger a = PartT (toEnum 0,fromInteger a) - -instance (Enum v, Enum a) => Enum (PartT v a) where - toEnum a = PartT (toEnum 0, toEnum a) -- TODO use def, mempty or minBound? - fromEnum (PartT (v,a)) = fromEnum a - -instance (Enum v, Bounded a) => Bounded (PartT v a) where - minBound = PartT (toEnum 0, minBound) - maxBound = PartT (toEnum 0, maxBound) - -instance (Enum v, Ord v, Num a, Ord a, Real a) => Real (PartT v a) where - toRational (PartT (v,a)) = toRational a - -instance (Enum v, Ord v, Real a, Enum a, Integral a) => Integral (PartT v a) where - PartT (v,a) `quotRem` PartT (_,b) = (PartT (v,q), PartT (v,r)) where (q,r) = a `quotRem` b - toInteger (PartT (v,a)) = toInteger a - --- --- 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] - - --- TODO use wrapper type and replace withContext -type instance Dynamic (a,b,c) = (a,b,c) -type instance SetDynamic g (a,b,c) = g - -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) - --- TODO place for this? --- For use with single-note scores etc -instance Tiable a => Tiable (Score a) where - beginTie = fmap beginTie - endTie = fmap endTie - -instance Transformable a => Transformable (Ctxt a) where - transform s = fmap (transform s) - -instance Transformable a => Transformable (Average a) where - transform s = fmap (transform s) - -instance IsPitch a => IsPitch (Average a) where - fromPitch = pure . fromPitch - -instance IsInterval a => IsInterval (Average a) where - fromInterval = pure . fromInterval - -instance IsDynamics a => IsDynamics (Average a) where - fromDynamics = pure . fromDynamics - - diff --git a/src/Music/Score/Internal/Export.hs b/src/Music/Score/Internal/Export.hs --- a/src/Music/Score/Internal/Export.hs +++ b/src/Music/Score/Internal/Export.hs @@ -79,7 +79,7 @@ where defaultTimeSignature = time 4 4 timeSignatures = fmap swap - $ view eventsV . fuse . reactiveToVoice' (0 <-> (score^.offset)) + $ view pairs . fuse . reactiveToVoice' (0 <-> (score^.offset)) $ getTimeSignatures defaultTimeSignature score -- Despite the fuse above we need retainUpdates here to prevent redundant repetition of time signatures @@ -88,7 +88,7 @@ -- | 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 +voiceToBars' barDurs = fmap (map (^. from note) . (^. notes)) . splitTiesAt barDurs -- TODO remove prime from name -- | Basic spelling for integral types. @@ -118,8 +118,8 @@ toMVoice = scoreToVoice . simultaneous unvoice :: Voice b -> [(Duration, b)] -unvoice = toListOf (stretcheds . traverse . from stretched) --- unvoice = fmap (^. from stretched) . (^. stretcheds) +unvoice = toListOf (notes . traverse . from note) +-- unvoice = fmap (^. from note) . (^. notes) {-# DEPRECATED unvoice "Use 'unsafeEventsV'" #-} diff --git a/src/Music/Score/Internal/Instances.hs b/src/Music/Score/Internal/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Internal/Instances.hs @@ -0,0 +1,346 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012-2014 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Provides miscellaneous instances. +-- +------------------------------------------------------------------------------------- + +module Music.Score.Internal.Instances () where + +import Control.Applicative +import Control.Comonad +import Control.Lens hiding (part, transform) +import Control.Monad +import Data.AffineSpace +import Data.Default +import Data.Monoid.Average +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 hiding (Sum) +import Data.Semigroup.Instances +import Data.Functor.Context + +import Music.Dynamics.Literal +import Music.Pitch.Alterable +import Music.Pitch.Augmentable +import Music.Pitch.Literal +import Music.Score.Articulation +import Music.Score.Color +import Music.Score.Dynamics +import Music.Score.Harmonics +import Music.Score.Meta +import Music.Score.Part +import Music.Score.Pitch +import Music.Score.Slide +import Music.Score.Text +import Music.Score.Ties +import Music.Score.Tremolo +import Music.Time + +-- ------------------------------------------------------------------------------------- +-- +-- 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 Chord for + -- all Preludes). See #134 +instance Semigroup a => Semigroup (HarmonicT a) where + (<>) = liftA2 (<>) +instance Semigroup a => Semigroup (TextT a) where + (<>) = liftA2 (<>) +instance Semigroup a => Semigroup (PartT n a) where + PartT (v1,x1) <> PartT (v2,x2) = PartT (v1, x1 <> x2) + + +-- ------------------------------------------------------------------------------------- + +-- +-- Aspect instaces (Pitch, Dynamics and Articulation) for PartT needs to go here, +-- as the other aspects depends on partwise traversals etc +-- + +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 + +type instance Pitch (DynamicT p a) = Pitch a +type instance SetPitch b (DynamicT p a) = DynamicT p (SetPitch b a) + +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 (ArticulationT p a) = Pitch a +type instance SetPitch b (ArticulationT p a) = ArticulationT p (SetPitch b 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 + + + +type instance Dynamic (PartT p a) = Dynamic a +type instance SetDynamic b (PartT p a) = PartT p (SetDynamic b 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 + +type instance Dynamic (ArticulationT p a) = Dynamic a +type instance SetDynamic b (ArticulationT p a) = ArticulationT p (SetDynamic b a) + +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 + + + +type instance Articulation (PartT p a) = Articulation a +type instance SetArticulation b (PartT p a) = PartT p (SetArticulation b a) + +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 + +-- 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 + +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 + + +-- ------------------------------------------------------------------------------------- + +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) + + +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) + + + +-- TextT + +instance Tiable a => Tiable (TextT a) where + isTieEndBeginning (TextT (Couple (_,a))) = isTieEndBeginning 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) + + +-- HarmonicT + +instance Tiable a => Tiable (HarmonicT a) where + isTieEndBeginning (HarmonicT (Couple (_,a))) = isTieEndBeginning 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) + + +-- SlideT + + +instance Tiable a => Tiable (SlideT a) where + isTieEndBeginning (SlideT (Couple (_,a))) = isTieEndBeginning 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) + + + + +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) + +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) + +deriving instance Transformable a => Transformable (SlideT a) +deriving instance Transformable a => Transformable (HarmonicT a) +deriving instance Transformable a => Transformable (TextT a) + +deriving instance Reversible a => Reversible (SlideT a) +deriving instance Reversible a => Reversible (HarmonicT a) +deriving instance Reversible a => Reversible (TextT a) + +deriving instance Alterable a => Alterable (SlideT a) +deriving instance Alterable a => Alterable (HarmonicT a) +deriving instance Alterable a => Alterable (TextT a) + +deriving instance Augmentable a => Augmentable (SlideT a) +deriving instance Augmentable a => Augmentable (HarmonicT a) +deriving instance Augmentable a => Augmentable (TextT a) + + + +------------------------------------------------------------------------------------- +-- Literal instances +------------------------------------------------------------------------------------- + + +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 +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 +-- ------------------------------------------------------------------------------------- +-- +-- PartT + +instance (Enum v, Eq v, Num a) => Num (PartT v a) where + PartT (v,a) + PartT (_,b) = PartT (v,a+b) + PartT (v,a) * PartT (_,b) = PartT (v,a*b) + PartT (v,a) - PartT (_,b) = PartT (v,a-b) + abs (PartT (v,a)) = PartT (v,abs a) + signum (PartT (v,a)) = PartT (v,signum a) + fromInteger a = PartT (toEnum 0,fromInteger a) + +instance (Enum v, Enum a) => Enum (PartT v a) where + toEnum a = PartT (toEnum 0, toEnum a) -- TODO use def, mempty or minBound? + fromEnum (PartT (v,a)) = fromEnum a + +instance (Enum v, Bounded a) => Bounded (PartT v a) where + minBound = PartT (toEnum 0, minBound) + maxBound = PartT (toEnum 0, maxBound) + +instance (Enum v, Ord v, Num a, Ord a, Real a) => Real (PartT v a) where + toRational (PartT (v,a)) = toRational a + +instance (Enum v, Ord v, Real a, Enum a, Integral a) => Integral (PartT v a) where + PartT (v,a) `quotRem` PartT (_,b) = (PartT (v,q), PartT (v,r)) where (q,r) = a `quotRem` b + toInteger (PartT (v,a)) = toInteger a + +-- +-- 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] + + +-- TODO use wrapper type and replace withContext +type instance Dynamic (a,b,c) = (a,b,c) +type instance SetDynamic g (a,b,c) = g + +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) + +-- TODO place for this? +-- For use with single-note scores etc +instance Tiable a => Tiable (Score a) where + beginTie = fmap beginTie + endTie = fmap endTie + +instance Transformable a => Transformable (Ctxt a) where + transform s = fmap (transform s) + +instance Transformable a => Transformable (Average a) where + transform s = fmap (transform s) + +instance IsPitch a => IsPitch (Average a) where + fromPitch = pure . fromPitch + +instance IsInterval a => IsInterval (Average a) where + fromInterval = pure . fromInterval + +instance IsDynamics a => IsDynamics (Average a) where + fromDynamics = pure . fromDynamics + + diff --git a/src/Music/Score/Meta.hs b/src/Music/Score/Meta.hs --- a/src/Music/Score/Meta.hs +++ b/src/Music/Score/Meta.hs @@ -27,10 +27,6 @@ module Music.Score.Meta ( module Music.Time.Meta, - -- TODO move - (), - rcat, - -- * Meta-events addMetaNote, fromMetaReactive, @@ -66,66 +62,54 @@ import qualified Data.Foldable as Foldable import qualified Data.List as List -infixr 6 +addMetaNote :: forall a b . (AttributeClass a, HasMeta b) => Event a -> b -> b +addMetaNote x = applyMeta $ wrapTMeta $ noteToReactive x +fromMetaReactive :: forall a b . AttributeClass b => Meta -> Reactive b +fromMetaReactive = fromMaybe mempty . unwrapMeta --- | --- Concatenate parts. --- -rcat :: (HasParts' a, Enum (Part a)) => [Score a] -> Score a -rcat = List.foldr () mempty +metaAt :: AttributeClass b => Time -> Score a -> b +metaAt x = (`atTime` x) . runScoreMeta --- | --- 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 +metaAtStart :: AttributeClass b => Score a -> b +metaAtStart x = _onset x `metaAt` x - -- | - -- Move down one voice (all parts). - -- - moveParts :: (Integral b, HasParts' a, Enum (Part a)) => b -> Score a -> Score a - moveParts x = parts %~ (successor x) +withMeta :: AttributeClass a => (a -> Score b -> Score b) -> Score b -> Score b +withMeta f x = let + m = (view meta) x + r = fromMetaReactive 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 event) -> (s, a)) -> mapDuring s $ f a) $ bs) + $ mapAfter u (f c) + $ x - -- | - -- 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) +withMetaAtStart :: AttributeClass a => (a -> Score b -> Score b) -> Score b -> Score b +withMetaAtStart f x = let + m = view meta x + in f (fromMetaReactive m `atTime` _onset x) x - 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) -addMetaNote :: forall a b . (AttributeClass a, HasMeta b) => Note a -> b -> b -addMetaNote x = applyMeta $ wrapTMeta $ noteToReactive x -fromMetaReactive :: forall a b . AttributeClass b => Meta -> Reactive b -fromMetaReactive = fromMaybe mempty . unwrapMeta +-- JUNK + withSpan :: Score a -> Score (Span, a) -withSpan = mapEvents (\t d x -> (t >-> d,x)) -withTime = mapEvents (\t d x -> (t, x)) +withSpan = mapTriples (\t d x -> (t >-> d,x)) +withTime = mapTriples (\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 @@ -137,46 +121,14 @@ -- Transform the score with the current value of some meta-information -- Each "update chunk" of the meta-info is processed separately - --- INTERNAL runScoreMeta :: forall a b . AttributeClass b => Score a -> Reactive b runScoreMeta = fromMetaReactive . (view meta) --- EXT -metaAt :: AttributeClass b => Time -> Score a -> b -metaAt x = (`atTime` x) . runScoreMeta - --- EXT -metaAtStart :: AttributeClass b => Score a -> b -metaAtStart x = _onset x `metaAt` x - -withMeta :: AttributeClass a => (a -> Score b -> Score b) -> Score b -> Score b -withMeta f x = let - m = (view meta) x - r = fromMetaReactive 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 - -withMetaAtStart :: AttributeClass a => (a -> Score b -> Score b) -> Score b -> Score b -withMetaAtStart f x = let - m = view meta x - in f (fromMetaReactive m `atTime` _onset x) x - - - - -- JUNK --- TODO move -noteToReactive :: Monoid a => Note a -> Reactive a +noteToReactive :: Monoid a => Event a -> Reactive a noteToReactive n = (pure <$> n) `activate` pure mempty -activate :: Note (Reactive a) -> Reactive a -> Reactive a -activate (view (from note) -> (view range -> (start,stop), x)) y = y `turnOn` (x `turnOff` y) +activate :: Event (Reactive a) -> Reactive a -> Reactive a +activate (view (from event) -> (view range -> (start,stop), x)) y = y `turnOn` (x `turnOff` y) where turnOn = switchR start turnOff = switchR stop 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 @@ -118,15 +118,15 @@ -- | Set the given attribution in the given score. attribute :: (HasMeta a, HasPosition a) => Attribution -> a -> a -attribute a x = attributeDuring (_getEra x) a x +attribute a x = attributeDuring (_era x) a x -- | Set the given attribution in the given part of a score. attributeDuring :: (HasMeta a) => Span -> Attribution -> a -> a -attributeDuring s a = addMetaNote (view note (s, a)) +attributeDuring s a = addMetaNote (view event (s, a)) -- | Set composer of the given score. composer :: (HasMeta a, HasPosition a) => String -> a -> a -composer t x = composerDuring (_getEra x) t x +composer t x = composerDuring (_era x) t x -- | Set composer of the given part of a score. composerDuring :: HasMeta a => Span -> String -> a -> a @@ -134,7 +134,7 @@ -- | Set lyricist of the given score. lyricist :: (HasMeta a, HasPosition a) => String -> a -> a -lyricist t x = lyricistDuring (_getEra x) t x +lyricist t x = lyricistDuring (_era x) t x -- | Set lyricist of the given part of a score. lyricistDuring :: HasMeta a => Span -> String -> a -> a @@ -142,7 +142,7 @@ -- | Set arranger of the given score. arranger :: (HasMeta a, HasPosition a) => String -> a -> a -arranger t x = arrangerDuring (_getEra x) t x +arranger t x = arrangerDuring (_era x) t x -- | Set arranger of the given part of a score. arrangerDuring :: HasMeta a => Span -> String -> a -> a 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 @@ -81,7 +81,7 @@ -- | Add a barline over the whole score. barline :: (HasMeta a, HasPosition a) => Barline -> a -> a -barline c x = barlineDuring (_getEra x) c x +barline c x = barlineDuring (_era x) c x -- | Add a barline over the whole score. doubleBarline :: (HasMeta a, HasPosition a) => Barline -> a -> a @@ -93,7 +93,7 @@ -- | Add a barline to the given score. barlineDuring :: HasMeta a => Span -> Barline -> a -> a -barlineDuring s c = addMetaNote $ view note (s, (Option $ Just $ Last c)) +barlineDuring s c = addMetaNote $ view event (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 @@ -68,13 +68,19 @@ data Clef = GClef | CClef | FClef deriving (Eq, Ord, Show, Typeable) +instance IsPitch Clef where + fromPitch l + | l == c = CClef + | l == f = FClef + | otherwise = GClef + -- | Set clef of the given score. clef :: (HasMeta a, HasPosition a) => Clef -> a -> a -clef c x = clefDuring (_getEra x) c x +clef c x = clefDuring (_era x) c x -- | Set clef of the given part of a score. clefDuring :: HasMeta a => Span -> Clef -> a -> a -clefDuring s c = addMetaNote $ view note (s, (Option $ Just $ Last c)) +clefDuring s c = addMetaNote $ view event (s, (Option $ Just $ Last c)) -- | Extract the clef in from the given score, using the given default clef. withClef :: Clef -> (Clef -> Score a -> Score a) -> Score a -> Score a 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 @@ -77,11 +77,11 @@ -- | Add a fermata over the whole score. fermata :: (HasMeta a, HasPosition a) => Fermata -> a -> a -fermata c x = fermataDuring (_getEra x) c x +fermata c x = fermataDuring (_era x) c x -- | Add a fermata to the given score. fermataDuring :: HasMeta a => Span -> Fermata -> a -> a -fermataDuring s c = addMetaNote $ view note (s, (Option $ Just $ Last c)) +fermataDuring s c = addMetaNote $ view event (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 @@ -119,11 +119,11 @@ -- | Set the key signature of the given score. keySignature :: (HasMeta a, HasPosition a) => KeySignature -> a -> a -keySignature c x = keySignatureDuring (_getEra x) c x +keySignature c x = keySignatureDuring (_era x) c x -- | Set the key signature of the given part of a score. keySignatureDuring :: HasMeta a => Span -> KeySignature -> a -> a -keySignatureDuring s c = addMetaNote $ view note (s, (Option $ Just $ Last c)) +keySignatureDuring s c = addMetaNote $ view event (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/Pickup.hs b/src/Music/Score/Meta/Pickup.hs --- a/src/Music/Score/Meta/Pickup.hs +++ b/src/Music/Score/Meta/Pickup.hs @@ -88,10 +88,10 @@ -- metronome noteVal bpm = Tempo Nothing (Just noteVal) $ 60 / (bpm * noteVal) rehearsalMark :: (HasMeta a, HasPosition a) => Pickup -> a -> a -rehearsalMark c x = rehearsalMarkDuring (_getEra x) c x +rehearsalMark c x = rehearsalMarkDuring (_era x) c x rehearsalMarkDuring :: HasMeta a => Span -> Pickup -> a -> a -rehearsalMarkDuring s x = addMetaNote $ view note (s, x) +rehearsalMarkDuring s x = addMetaNote $ view event (s, x) withPickup :: (Pickup -> Score a -> Score a) -> Score a -> Score a withPickup = withMeta 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 @@ -92,10 +92,10 @@ -- metronome noteVal bpm = Tempo Nothing (Just noteVal) $ 60 / (bpm * noteVal) rehearsalMark :: (HasMeta a, HasPosition a) => RehearsalMark -> a -> a -rehearsalMark c x = rehearsalMarkDuring (_getEra x) c x +rehearsalMark c x = rehearsalMarkDuring (_era x) c x rehearsalMarkDuring :: HasMeta a => Span -> RehearsalMark -> a -> a -rehearsalMarkDuring s x = addMetaNote $ view note (s, x) +rehearsalMarkDuring s x = addMetaNote $ view event (s, x) withRehearsalMark :: (RehearsalMark -> Score a -> Score a) -> Score a -> Score a withRehearsalMark = withMeta diff --git a/src/Music/Score/Meta/Tempo.hs b/src/Music/Score/Meta/Tempo.hs --- a/src/Music/Score/Meta/Tempo.hs +++ b/src/Music/Score/Meta/Tempo.hs @@ -110,9 +110,11 @@ instance Show Tempo where show (getTempo -> (nv, bpm)) = "metronome " ++ showR nv ++ " " ++ showR bpm where - showR (realToFrac -> (unRatio -> (x, 1))) = show x - showR (realToFrac -> (unRatio -> (x, y))) = "(" ++ show x ++ "/" ++ show y ++ ")" +showR = showR' . realToFrac +showR' ((unRatio -> (x, 1))) = show x +showR' ((unRatio -> (x, y))) = "(" ++ show x ++ "/" ++ show y ++ ")" + instance Default Tempo where def = mempty @@ -176,11 +178,11 @@ -- | Set the tempo of the given score. tempo :: (HasMeta a, HasPosition a) => Tempo -> a -> a -tempo c x = tempoDuring (_getEra x) c x +tempo c x = tempoDuring (_era x) c x -- | Set the tempo of the given part of a score. tempoDuring :: HasMeta a => Span -> Tempo -> a -> a -tempoDuring s c = addMetaNote $ view note (s, c) +tempoDuring s c = addMetaNote $ view event (s, c) -- TODO move @@ -219,14 +221,14 @@ renderTempo sc = flip composed sc $ fmap renderTempoScore - $ tempoRegions (_getEra sc) - $ tempoRegions0 (_getEra sc) + $ tempoRegions (_era sc) + $ tempoRegions0 (_era sc) $ getTempoChanges defTempo sc renderTempoTest :: Score a -> [TempoRegion] renderTempoTest sc = id - $ tempoRegions (_getEra sc) - $ tempoRegions0 (_getEra sc) + $ tempoRegions (_era sc) + $ tempoRegions0 (_era sc) $ getTempoChanges defTempo sc @@ -319,16 +321,23 @@ -} -presto = metronome (1/4) 125 -allegro = metronome (1/4) 115 -allegretto = metronome (1/4) 105 -moderato = metronome (1/4) 95 -andante = metronome (1/4) 85 -adagio = metronome (1/4) 65 -largo = metronome (1/4) 55 -lento = metronome (1/4) 45 - +-- presto = metronome (1/4) 125 +-- allegro = metronome (1/4) 115 +-- allegretto = metronome (1/4) 105 +-- moderato = metronome (1/4) 95 +-- andante = metronome (1/4) 85 +-- adagio = metronome (1/4) 65 +-- largo = metronome (1/4) 55 +-- lento = metronome (1/4) 45 +presto = metronome (1/4) 140 +allegro = metronome (1/4) 128 +allegretto = metronome (1/4) 118 +moderato = metronome (1/4) 98 +andante = metronome (1/4) 84 +adagio = metronome (1/4) 64 +largo = metronome (1/4) 48 +lento = metronome (1/4) 42 -- TODO consolidate -- optionFirst = Option . Just . First 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 @@ -171,7 +171,7 @@ -- | Set the time signature of the given part of a score. timeSignatureDuring :: HasMeta a => Span -> TimeSignature -> a -> a -timeSignatureDuring s c = addMetaNote $ view note (s, optionFirst c) +timeSignatureDuring s c = addMetaNote $ view event (s, optionFirst c) getTimeSignatures :: TimeSignature -> Score a -> Reactive TimeSignature getTimeSignatures def = fmap (fromMaybe def . unOptionFirst) . fromMetaReactive . (view meta) 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 @@ -120,27 +120,27 @@ -- | Set title of the given score. title :: (HasMeta a, HasPosition a) => Title -> a -> a -title t x = titleDuring (_getEra x) t x +title t x = titleDuring (_era x) t x -- | Set title of the given part of a score. titleDuring :: HasMeta a => Span -> Title -> a -> a -titleDuring s t = addMetaNote $ view note (s, t) +titleDuring s t = addMetaNote $ view event (s, t) -- | Set subtitle of the given score. subtitle :: (HasMeta a, HasPosition a) => Title -> a -> a -subtitle t x = subtitleDuring (_getEra x) t x +subtitle t x = subtitleDuring (_era x) t x -- | Set subtitle of the given part of a score. subtitleDuring :: HasMeta a => Span -> Title -> a -> a -subtitleDuring s t = addMetaNote $ view note (s, denoteTitle t) +subtitleDuring s t = addMetaNote $ view event (s, denoteTitle t) -- | Set subsubtitle of the given score. subsubtitle :: (HasMeta a, HasPosition a) => Title -> a -> a -subsubtitle t x = subsubtitleDuring (_getEra x) t x +subsubtitle t x = subsubtitleDuring (_era x) t x -- | Set subsubtitle of the given part of a score. subsubtitleDuring :: HasMeta a => Span -> Title -> a -> a -subsubtitleDuring s t = addMetaNote $ view note (s, denoteTitle (denoteTitle t)) +subsubtitleDuring s t = addMetaNote $ view event (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/Part.hs b/src/Music/Score/Part.hs --- a/src/Music/Score/Part.hs +++ b/src/Music/Score/Part.hs @@ -64,6 +64,9 @@ -- HasPart', -- PartT(..), -- getParts, + + (), + rcat, ) where import Control.Applicative @@ -201,14 +204,14 @@ parts = traverse . parts -type instance Part (Note a) = Part a -type instance SetPart g (Note a) = Note (SetPart g a) +type instance Part (Event a) = Part a +type instance SetPart g (Event a) = Event (SetPart g a) -instance (HasPart a b) => HasPart (Note a) (Note b) where - part = _Wrapped . whilstL part +instance (HasPart a b) => HasPart (Event a) (Event b) where + part = from event . whilstL part -instance (HasParts a b) => HasParts (Note a) (Note b) where - parts = _Wrapped . whilstL parts +instance (HasParts a b) => HasParts (Event a) (Event b) where + parts = from event . whilstL parts -- | -- List all the parts @@ -282,6 +285,7 @@ rev = fmap rev instance Tiable a => Tiable (PartT n a) where + isTieEndBeginning (PartT (_,a)) = isTieEndBeginning a toTied (PartT (v,a)) = (PartT (v,b), PartT (v,c)) where (b,c) = toTied a @@ -309,7 +313,7 @@ _Wrapped . _2 -- into NScore . _Wrapped . traverse - . _Wrapped -- this needed? + . from event -- this needed? . whilstL parts type instance Part (Voice a) = Part a @@ -322,4 +326,47 @@ . _Wrapped -- this needed? . whilstLD parts + +infixr 6 + + +-- | +-- Concatenate parts. +-- +rcat :: (HasParts' a, Enum (Part a)) => [Score a] -> Score a +rcat = List.foldr () mempty + +-- | +-- 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 + + -- | + -- Move down one voice (all parts). + -- + moveParts :: (Integral b, HasParts' a, Enum (Part a)) => b -> Score a -> Score a + moveParts x = parts %~ (successor x) + + -- | + -- 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) + + + 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) diff --git a/src/Music/Score/Phrases.hs b/src/Music/Score/Phrases.hs --- a/src/Music/Score/Phrases.hs +++ b/src/Music/Score/Phrases.hs @@ -180,12 +180,12 @@ mvoiceToPVoice :: MVoice a -> PVoice a mvoiceToPVoice = map ( bimap voiceToRest voiceToPhrase - . bimap (^.from unsafeEventsV) (^.from unsafeEventsV) ) + . bimap (^.from unsafePairs) (^.from unsafePairs) ) . groupDiff' (isJust . snd) - . view eventsV + . view pairs voiceToRest :: MVoice a -> Duration - voiceToRest = sumOf (eventsV.each._1) . fmap (\x -> assert (isNothing x) x) + voiceToRest = sumOf (pairs.each._1) . fmap (\x -> assert (isNothing x) x) -- TODO just _duration voiceToPhrase :: MVoice a -> Phrase a @@ -206,11 +206,11 @@ singleMVoice = iso scoreToVoice voiceToScore' where scoreToVoice :: {-Transformable a =>-} Score a -> MVoice a - scoreToVoice = (^. voice) . fmap (^. stretched) . fmap throwTime . addRests . + scoreToVoice = (^. voice) . fmap (^. note) . fmap throwTime . addRests . -- TODO List.sortBy (comparing (^._1)) -- end TODO - . (^. events) + . (^. triples) where throwTime (t,d,x) = (d,x) addRests = concat . snd . List.mapAccumL g 0 @@ -221,7 +221,7 @@ | otherwise = error "singleMVoice: Strange prevTime" voiceToScore :: Voice a -> Score a - voiceToScore = scat . fmap g . (^. stretcheds) where g = (^. stretchedValue) . fmap return + voiceToScore = renderAlignedVoice . aligned 0 0 voiceToScore' :: MVoice a -> Score a voiceToScore' = mcatMaybes . voiceToScore @@ -232,7 +232,10 @@ mapPhrasesWithPrevAndCurrentOnset f = over (mvoices . mVoiceTVoice) (withPrevAndCurrentOnset f) withPrevAndCurrentOnset :: (Maybe Time -> Time -> a -> b) -> Track a -> Track b -withPrevAndCurrentOnset f = over delayeds (fmap (\(x,y,z) -> fmap (f (fmap _onset x) (_onset y)) y) . withPrevNext) +withPrevAndCurrentOnset f = over placeds (fmap (\(x,y,z) -> fmap (f (fmap placedOnset x) (placedOnset y)) y) . withPrevNext) + where + placedOnset :: Placed a -> Time + placedOnset = view (from placed . _1) mVoiceTVoice :: Lens (MVoice a) (MVoice b) (TVoice a) (TVoice b) mVoiceTVoice = mVoicePVoice . pVoiceTVoice @@ -269,7 +272,7 @@ firsts f = uncurry zip . first f . unzipR mkTrack :: [(Time, a)] -> Track a -mkTrack = view track . map (view delayed) +mkTrack = view track . map (view placed) withDurationR :: (Functor f, HasDuration a) => f a -> f (Duration, a) withDurationR = fmap $ \x -> (_duration x, x) 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 @@ -105,6 +105,12 @@ import Data.Traversable (Traversable) import Data.Typeable import Data.VectorSpace hiding (Sum) +import Data.Set (Set) +import Data.Map (Map) +import Data.Sequence (Seq) +import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified Data.Sequence as Seq import Music.Pitch.Literal import Music.Score.Harmonics @@ -112,7 +118,6 @@ 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 @@ -125,7 +130,7 @@ -- @ -- 'Pitch' (c,a) ~ 'Pitch' a -- 'Pitch' [a] ~ 'Pitch' a --- 'Pitch' ('Note' a) ~ 'Pitch' a +-- 'Pitch' ('Event' a) ~ 'Pitch' a -- 'Pitch' ('Voice' a) ~ 'Pitch' a -- 'Pitch' ('Score' a) ~ 'Pitch' a -- @ @@ -151,7 +156,7 @@ -- @ -- 'SetPitch' b (c,a) ~ (c, 'SetPitch' b a) -- 'SetPitch' b [a] ~ ['SetPitch' b a] --- 'SetPitch' g ('Note' a) ~ Note ('SetPitch' g a) +-- 'SetPitch' g ('Event' a) ~ Event ('SetPitch' g a) -- 'SetPitch' g ('Voice' a) ~ 'Voice' ('SetPitch' g a) -- 'SetPitch' g ('Score' a) ~ 'Score' ('SetPitch' g a) -- @ @@ -265,50 +270,61 @@ PRIM_PITCH_INSTANCE(Double) -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] +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] +type instance Pitch (Map k a) = Pitch a +type instance SetPitch b (Map k a) = Map k (SetPitch b a) +type instance Pitch (Seq a) = Pitch a +type instance SetPitch b (Seq a) = Seq (SetPitch b 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 (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 (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) +type instance Pitch (Event a) = Pitch a +type instance SetPitch b (Event a) = Event (SetPitch b a) +type instance Pitch (Placed a) = Pitch a +type instance SetPitch b (Placed a) = Placed (SetPitch b a) +type instance Pitch (Note a) = Pitch a +type instance SetPitch b (Note a) = Note (SetPitch b a) -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) +type instance Pitch (Voice a) = Pitch a +type instance SetPitch b (Voice a) = Voice (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) 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 -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 +instance HasPitches a b => HasPitches [a] [b] where + pitches = traverse . pitches -instance (HasPitches a b) => HasPitches (Delayed a) (Delayed b) where +instance HasPitches a b => HasPitches (Seq a) (Seq b) where + pitches = traverse . pitches + +instance HasPitches a b => HasPitches (Map k a) (Map k b) where + pitches = traverse . pitches + +instance (HasPitches a b) => HasPitches (Event a) (Event b) where + pitches = from event . whilstL pitches +instance (HasPitch a b) => HasPitch (Event a) (Event b) where + pitch = from event . whilstL pitch + +instance (HasPitches a b) => HasPitches (Placed a) (Placed b) where pitches = _Wrapped . whilstLT pitches -instance (HasPitch a b) => HasPitch (Delayed a) (Delayed b) where +instance (HasPitch a b) => HasPitch (Placed a) (Placed b) where pitch = _Wrapped . whilstLT pitch -instance (HasPitches a b) => HasPitches (Stretched a) (Stretched b) where +instance (HasPitches a b) => HasPitches (Note a) (Note b) where pitches = _Wrapped . whilstLD pitches -instance (HasPitch a b) => HasPitch (Stretched a) (Stretched b) where +instance (HasPitch a b) => HasPitch (Note a) (Note b) where pitch = _Wrapped . whilstLD pitch instance HasPitches a b => HasPitches (Maybe a) (Maybe b) where @@ -317,24 +333,25 @@ 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 +{- +type instance Pitch (Chord a) = Pitch a +type instance SetPitch b (Chord a) = Chord (SetPitch b a) 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? + . from event -- this needed? . whilstL pitches diff --git a/src/Music/Score/Slide.hs b/src/Music/Score/Slide.hs --- a/src/Music/Score/Slide.hs +++ b/src/Music/Score/Slide.hs @@ -91,7 +91,7 @@ setEndGliss n = fmap (setEndGliss n) setEndSlide n = fmap (setEndSlide n) -instance HasSlide a => HasSlide (Stretched a) where +instance HasSlide a => HasSlide (Note a) where setBeginGliss n = fmap (setBeginGliss n) setBeginSlide n = fmap (setBeginSlide n) setEndGliss n = fmap (setEndGliss n) diff --git a/src/Music/Score/Text.hs b/src/Music/Score/Text.hs --- a/src/Music/Score/Text.hs +++ b/src/Music/Score/Text.hs @@ -74,7 +74,7 @@ instance HasText a => HasText [a] where addText s = fmap (addText s) -instance HasText a => HasText (Stretched a) where +instance HasText a => HasText (Note a) where addText s = fmap (addText s) instance HasText a => HasText (Voice a) where diff --git a/src/Music/Score/Ties.hs b/src/Music/Score/Ties.hs --- a/src/Music/Score/Ties.hs +++ b/src/Music/Score/Ties.hs @@ -33,8 +33,8 @@ TieT(..), -- * Splitting tied notes in scores - -- splitTiesVoice, - splitTiesVoiceAt, + -- splitTies, + splitTiesAt, ) where @@ -54,7 +54,7 @@ import Data.Semigroup import Data.Typeable import Data.Monoid.Average -import Data.VectorSpace hiding (Sum) +import Data.VectorSpace hiding (Sum, getSum) import Music.Dynamics.Literal import Music.Pitch.Literal @@ -91,6 +91,14 @@ -- toTied :: a -> (a, a) toTied a = (beginTie a, endTie a) + + isTieEndBeginning :: a -> (Bool, Bool) + + isTieBeginning :: a -> Bool + isTieBeginning = snd . isTieEndBeginning + + isTieEnd :: a -> Bool + isTieEnd = fst . isTieEndBeginning @@ -103,16 +111,17 @@ 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 Double where { beginTie = id ; endTie = id ; isTieEndBeginning _ = (False, False) } +instance Tiable Float where { beginTie = id ; endTie = id ; isTieEndBeginning _ = (False, False) } +instance Tiable Char where { beginTie = id ; endTie = id ; isTieEndBeginning _ = (False, False) } +instance Tiable Int where { beginTie = id ; endTie = id ; isTieEndBeginning _ = (False, False) } +instance Tiable Integer where { beginTie = id ; endTie = id ; isTieEndBeginning _ = (False, False) } +instance Tiable () where { beginTie = id ; endTie = id ; isTieEndBeginning _ = (False, False) } +instance Tiable (Ratio a) where { beginTie = id ; endTie = id ; isTieEndBeginning _ = (False, False) } instance Tiable a => Tiable (TieT a) where - toTied (TieT ((prevTie, nextTie), a)) = (TieT ((prevTie, Any True), b), TieT ((Any True, nextTie), c)) + isTieEndBeginning (TieT (ties, _)) = over both getAny $ ties + 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 @@ -126,18 +135,23 @@ -- This restriction assures all chord notes are in the same part -- instance Tiable a => Tiable (c, a) where + isTieEndBeginning = isTieEndBeginning . extract toTied = unzipR . fmap toTied instance Tiable a => Tiable (Maybe a) where + isTieEndBeginning = maybe (False, False) isTieEndBeginning toTied = unzipR . fmap toTied instance Tiable a => Tiable (Average a) where + isTieEndBeginning = isTieEndBeginning . getAverage toTied = unzipR . fmap toTied instance Tiable a => Tiable (Sum a) where + isTieEndBeginning = isTieEndBeginning . getSum toTied = unzipR . fmap toTied instance Tiable a => Tiable (Product a) where + isTieEndBeginning = isTieEndBeginning . getProduct toTied = unzipR . fmap toTied -- Lifted instances @@ -202,10 +216,10 @@ -- | -- Split all notes that cross a barlines into a pair of tied notes. -- -splitTiesVoice :: Tiable a => Voice a -> Voice a -splitTiesVoice = (^. voice) . map (^. stretched) +splitTies :: Tiable a => Voice a -> Voice a +splitTies = (^. voice) . map (^. note) . concat . snd . List.mapAccumL g 0 - . map (^. from stretched) . (^. stretcheds) + . map (^. from note) . (^. notes) where g t (d, x) = (t + d, occs) where @@ -218,20 +232,20 @@ -- Split all voice into bars, using the given bar durations. Music that does not -- fit into the given durations is discarded. -- --- Notes that cross a barlines are split into tied notes. +-- Events that cross a barlines are split into tied notes. -- -splitTiesVoiceAt :: Tiable a => [Duration] -> Voice a -> [Voice a] -splitTiesVoiceAt barDurs x = fmap ((^. voice) . map (^. stretched)) $ splitTiesVoiceAt' barDurs ((map (^. from stretched) . (^. stretcheds)) x) +splitTiesAt :: Tiable a => [Duration] -> Voice a -> [Voice a] +splitTiesAt barDurs x = fmap ((^. voice) . map (^. note)) $ splitTiesAt' barDurs ((map (^. from note) . (^. notes)) x) -splitTiesVoiceAt' :: Tiable a => [Duration] -> [(Duration, a)] -> [[(Duration, a)]] -splitTiesVoiceAt' [] _ = [] -splitTiesVoiceAt' _ [] = [] -splitTiesVoiceAt' (barDur : rbarDur) occs = case splitDurFor barDur occs of +splitTiesAt' :: Tiable a => [Duration] -> [(Duration, a)] -> [[(Duration, a)]] +splitTiesAt' [] _ = [] +splitTiesAt' _ [] = [] +splitTiesAt' (barDur : rbarDur) occs = case splitDurFor barDur occs of (barOccs, []) -> barOccs : [] - (barOccs, restOccs) -> barOccs : splitTiesVoiceAt' rbarDur restOccs + (barOccs, restOccs) -> barOccs : splitTiesAt' rbarDur restOccs -tsplitTiesVoiceAt :: [Duration] -> [Duration] -> [[(Duration, Char)]] -tsplitTiesVoiceAt barDurs = fmap (map (^. from stretched) . (^. stretcheds)) . splitTiesVoiceAt barDurs . ((^. voice) . map (^. stretched)) . fmap (\x -> (x,'_')) +tsplitTiesAt :: [Duration] -> [Duration] -> [[(Duration, Char)]] +tsplitTiesAt barDurs = fmap (map (^. from note) . (^. notes)) . splitTiesAt barDurs . ((^. voice) . map (^. note)) . fmap (\x -> (x,'_')) -- | -- Split an event into one chunk of the duration @s@, followed parts shorter than duration @t@. @@ -247,14 +261,14 @@ -- | --- Extract as many notes or parts of notes as possible in the given positive duration, and --- return it with remaining notes. +-- Extract as many events or parts of events as possible in the given positive duration, and +-- return it with remaining events. -- --- The extracted notes always fit into the given duration, i.e. +-- The extracted events always fit into the given duration, i.e. -- -- > sum $ fmap duration $ fst $ splitDurFor maxDur xs <= maxDur -- --- If there are remaining notes, they always fit exactly, i.e. +-- If there are remaining events, they always fit exactly, i.e. -- -- > sum $ fmap duration $ fst $ splitDurFor maxDur xs == maxDur iff (not $ null $ snd $ splitDurFor maxDur xs) -- @@ -274,8 +288,8 @@ -- toTied _ = ('(',')') -- | --- Split a note if it is longer than the given duration. Returns the first part of the --- note (which always <= s) and the rest. +-- Split a event if it is longer than the given duration. Returns the first part of the +-- event (which always <= s) and the rest. -- -- > splitDur maxDur (d,a) -- diff --git a/src/Music/Score/Tremolo.hs b/src/Music/Score/Tremolo.hs --- a/src/Music/Score/Tremolo.hs +++ b/src/Music/Score/Tremolo.hs @@ -60,7 +60,6 @@ import Music.Pitch.Augmentable import Music.Pitch.Literal import Music.Score.Articulation --- import Music.Score.Color import Music.Score.Dynamics import Music.Score.Harmonics import Music.Score.Meta @@ -103,6 +102,7 @@ deriving instance (Monoid b, Alterable a) => Alterable (Couple b a) deriving instance (Monoid b, Augmentable a) => Augmentable (Couple b a) instance Tiable a => Tiable (Couple b a) where + isTieEndBeginning (Couple (_,a)) = isTieEndBeginning a toTied = unzipR . fmap toTied diff --git a/src/Music/Time.hs b/src/Music/Time.hs --- a/src/Music/Time.hs +++ b/src/Music/Time.hs @@ -12,13 +12,10 @@ ------------------------------------------------------------------------------------- module Music.Time ( - -- * Prerequisites module Data.Functor.Rep.Lens, - -- * Basic types module Music.Time.Types, - -- * Time transformations module Music.Time.Transform, module Music.Time.Duration, module Music.Time.Position, @@ -26,25 +23,25 @@ module Music.Time.Reverse, module Music.Time.Juxtapose, module Music.Time.Rest, + module Music.Time.Aligned, - -- * Time types - -- ** Discrete time - module Music.Time.Stretched, - module Music.Time.Delayed, + module Music.Time.Placed, module Music.Time.Note, - module Music.Time.Future, - module Music.Time.Past, - module Music.Time.Nominal, - module Music.Time.Graces, + module Music.Time.Event, module Music.Time.Voice, module Music.Time.Chord, module Music.Time.Track, module Music.Time.Score, - -- ** Continous time + module Music.Time.Nominal, + module Music.Time.Graces, + + module Music.Time.Future, + module Music.Time.Past, + module Music.Time.Reactive, + module Music.Time.Segment, module Music.Time.Behavior, - module Music.Time.Reactive, ) where import Data.Functor.Rep @@ -58,19 +55,19 @@ import Music.Time.Split import Music.Time.Transform import Music.Time.Types +import Music.Time.Aligned import Music.Time.Behavior import Music.Time.Chord -import Music.Time.Delayed -import Music.Time.Note +import Music.Time.Placed import Music.Time.Future -import Music.Time.Past -import Music.Time.Nominal import Music.Time.Graces +import Music.Time.Nominal +import Music.Time.Event +import Music.Time.Past import Music.Time.Reactive import Music.Time.Score import Music.Time.Segment -import Music.Time.Stretched +import Music.Time.Note import Music.Time.Track import Music.Time.Voice - diff --git a/src/Music/Time/Aligned.hs b/src/Music/Time/Aligned.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Aligned.hs @@ -0,0 +1,129 @@ + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012-2014 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +------------------------------------------------------------------------------------- + +module Music.Time.Aligned ( + Aligned, + aligned, + renderAligned, + renderAlignedVoice, + renderAlignedNote, + renderAlignedDuration, + ) where + +import Control.Applicative +import Control.Comonad +import Control.Lens hiding (Indexable, Level, above, below, + index, inside, parts, reversed, + transform, (<|), (|>)) +import Data.AffineSpace +import Data.AffineSpace.Point +import Data.Bifunctor +import Data.Foldable (Foldable) +import qualified Data.Foldable as Foldable +import Data.Functor.Adjunction (unzipR) +import Data.Functor.Couple +import Data.String +import Data.Typeable +import Data.VectorSpace + +import Music.Dynamics.Literal +import Music.Pitch.Literal +import Music.Time.Reverse +import Music.Time.Juxtapose +import Music.Time.Split +import Music.Time.Note +import Music.Time.Event +import Music.Time.Voice +import Music.Time.Score + + +-- type AlignedVoice a = Aligned (Voice a) + +-- | 'Aligned' places a vector-like object in space, by fixing a local duration interpolating +-- the vector to a specific point in time. The aligned value must be an instance of +-- 'HasDuration', with @'view' 'duration'@ providing the size of the vector. +-- +-- This is analogous to alignment in a graphical program. To align something at onset, midpoint +-- or offset, use 0, 0.5 or 1 as the local duration value. +newtype Aligned v = Aligned { getAligned :: (Time, LocalDuration, v) } + +-- | Align the given value so that its local duration occurs at the given time. +aligned :: Time -> LocalDuration -> v -> Aligned v +aligned t d a = Aligned (t, d, a) + +instance Show a => Show (Aligned a) where + show (Aligned (t,d,v)) = "aligned ("++show t++") ("++show d++") ("++ show v++")" + +instance Transformable v => Transformable (Aligned v) where + transform s (Aligned (t, d, v)) = Aligned (transform s t, d, transform s v) + +instance HasDuration v => HasDuration (Aligned v) where + _duration (Aligned (_, _, v)) = _duration v + +instance HasDuration v => HasPosition (Aligned v) where + -- _position (Aligned (position, alignment, v)) = alerp (position .-^ (size * alignment)) (position .+^ (size * (1-alignment))) + -- where + -- size = _duration v + _era (Aligned (position, alignment, v)) = + (position .-^ (size * alignment)) <-> (position .+^ (size * (1-alignment))) + where + size = _duration v + +-- renderAligned :: AlignedVoice a -> Score a +renderAligned :: HasDuration a => (Span -> a -> b) -> Aligned a -> b +renderAligned f a@(Aligned (_, _, v)) = f (_era a) v + + + + +-- Somewhat suspect, see below for clarity... + +voiceToScoreInEra :: Span -> Voice a -> Score a +voiceToScoreInEra e = set era e . scat . map (uncurry stretch) . view pairs . fmap pure + +noteToEventInEra :: Span -> Note a -> Event a +noteToEventInEra e = set era e . view notee . fmap pure + +durationToSpanInEra :: Span -> Duration -> Span +durationToSpanInEra = const + +-- TODO compare placeAt etc. + + +-- | Convert an aligned voice to a score. +renderAlignedVoice :: Aligned (Voice a) -> Score a +renderAlignedVoice = renderAligned voiceToScoreInEra + +-- | Convert an aligned note to an event. +renderAlignedNote :: Aligned (Note a) -> Event a +renderAlignedNote = renderAligned noteToEventInEra + +-- | Convert an aligned duration to a span. +renderAlignedDuration :: Aligned Duration -> Span +renderAlignedDuration = renderAligned durationToSpanInEra + + + + + 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,18 +1,11 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} ------------------------------------------------------------------------------------- -- | @@ -81,7 +74,7 @@ import Data.Typeable import Music.Time.Bound import Music.Time.Internal.Transform -import Music.Time.Note +import Music.Time.Event import Music.Time.Reverse import Music.Time.Score import Music.Time.Split @@ -145,6 +138,11 @@ instance Distributive Behavior where distribute = Behavior . distribute . fmap getBehavior +instance Representable Behavior where + type Rep Behavior = Time + tabulate = Behavior + index (Behavior x) = x + instance Transformable (Behavior a) where transform s (Behavior a) = Behavior (a `whilst` s) where @@ -152,28 +150,21 @@ instance Reversible (Behavior a) where rev = stretch (-1) - -- TODO alternative + -- Or: 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) +deriving instance AdditiveGroup a => AdditiveGroup (Behavior a) --- TODO bad instance +-- TODO bad instance Real a => Real (Behavior a) where toRational = toRational . (! 0) --- #ifdef INCLUDE_LIFTED -deriving instance AdditiveGroup a => AdditiveGroup (Behavior a) - instance IsString a => IsString (Behavior a) where fromString = pure . fromString @@ -195,12 +186,15 @@ diminish = fmap diminish instance Eq a => Eq (Behavior a) where - (==) = error "No fun" + (==) = error "No overloading for behavior: (<=)" instance Ord a => Ord (Behavior a) where - (<) = error "No fun" - max = liftA2 max - min = liftA2 min + (<=) = error "No overloading for behavior: (<=)" + (>=) = error "No overloading for behavior: (<=)" + (<) = error "No overloading for behavior: (<=)" + (>) = error "No overloading for behavior: (<=)" + max = liftA2 max + min = liftA2 min instance Enum a => Enum (Behavior a) where toEnum = pure . toEnum @@ -214,7 +208,6 @@ type Diff (Behavior a) = Behavior (Diff a) (.-.) = liftA2 (.-.) (.+^) = liftA2 (.+^) --- #endif -- | -- View a behavior as a time function and vice versa. @@ -240,22 +233,8 @@ unbehavior :: Iso (Behavior a) (Behavior b) (Time -> a) (Time -> b) unbehavior = from behavior --- --- @ --- ('const' x)^.'behavior' ! t = x forall t --- @ --- --- - - -- | --- A behavior that --- -line' :: Behavior Time -line' = id ^. R.tabulated - --- | --- A behavior that gives the current time, i.e. the identity function +-- A behavior that gives the current time. -- -- Should really have the type 'Behavior' 'Time', but is provided in a more general form -- for convenience. @@ -275,13 +254,12 @@ -- > f t | t < 0 = 0 -- > | t > 1 = 1 -- > | otherwise = t --- -- | -- A behavior that -- -interval :: (Fractional a, Transformable a) => Time -> Time -> Note (Behavior a) -interval t u = (t <-> u, line) ^. note +interval :: (Fractional a, Transformable a) => Time -> Time -> Event (Behavior a) +interval t u = (t <-> u, line) ^. event -- | -- A behavior that @@ -308,7 +286,6 @@ impulse = switch' 0 0 1 0 -- > f t | t == 0 = 1 -- > | otherwise = 0 --- -- | -- A behavior that goes from 0 to 1 at time 0. @@ -321,8 +298,6 @@ 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 @@ -331,27 +306,7 @@ -- > 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 = transformed (negateV s) . f - --- | -- Instantly switch from one behavior to another. -- switch :: Time -> Behavior a -> Behavior a -> Behavior a @@ -374,10 +329,11 @@ EQ -> ry ! u GT -> rz ! u --- TODO move + +-- Internal + +tau :: Floating a => a tau = 2 * pi floor' :: RealFrac a => a -> a floor' = fromIntegral . floor - --- JUNK diff --git a/src/Music/Time/Bound.hs b/src/Music/Time/Bound.hs --- a/src/Music/Time/Bound.hs +++ b/src/Music/Time/Bound.hs @@ -1,17 +1,11 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} ------------------------------------------------------------------------------------- diff --git a/src/Music/Time/Chord.hs b/src/Music/Time/Chord.hs --- a/src/Music/Time/Chord.hs +++ b/src/Music/Time/Chord.hs @@ -1,20 +1,15 @@ -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} {-# 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 #-} ------------------------------------------------------------------------------------- -- | @@ -31,12 +26,12 @@ module Music.Time.Chord ( -- * Chord type - Chord, + -- Chord, -- * Construction - chord, - unchord, - unsafeChord, + -- chord, + -- unchord, + -- unsafeChord, -- invertChord, -- inversions, @@ -65,7 +60,7 @@ import Data.VectorSpace import Data.String -import Music.Time.Delayed +import Music.Time.Placed import Music.Time.Reverse import Music.Time.Split @@ -90,7 +85,7 @@ -- A 'Chord' is a parallel composition of values. -- -- @ --- type Chord a = [Delayed a] +-- type Chord a = [Placed a] -- @ -- newtype Chord a = Chord { getChord :: ChordList (ChordEv a) } @@ -100,9 +95,9 @@ type ChordList = [] -- Can use any type as long as chordEv provides an Iso -type ChordEv a = Delayed a +type ChordEv a = Placed a -chordEv :: Iso (Delayed a) (Delayed b) (ChordEv a) (ChordEv b) +chordEv :: Iso (Placed a) (Placed b) (ChordEv a) (ChordEv b) chordEv = id instance Applicative Chord where @@ -119,30 +114,30 @@ 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 Transformable (Chord a) where +-- transform s = over _Wrapped' (transform s) -instance Splittable a => Splittable (Chord a) where +-- instance HasDuration (Chord a) where -- TODO -instance Reversible a => Reversible (Chord a) where - rev = over _Wrapped' (fmap rev) -- TODO OK? +-- 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 :: Getter [Delayed a] (Chord a) +chord :: Getter [Placed a] (Chord a) chord = from unsafeChord -unchord :: Lens (Chord a) (Chord b) [Delayed a] [Delayed b] +unchord :: Lens (Chord a) (Chord b) [Placed a] [Placed b] unchord = _Wrapped -- TODO names are not consistent with other types -unsafeChord :: Iso (Chord a) (Chord b) [Delayed a] [Delayed b] +unsafeChord :: Iso (Chord a) (Chord b) [Placed a] [Placed b] unsafeChord = _Wrapped instance IsString a => IsString (Chord a) where diff --git a/src/Music/Time/Delayed.hs b/src/Music/Time/Delayed.hs deleted file mode 100644 --- a/src/Music/Time/Delayed.hs +++ /dev/null @@ -1,156 +0,0 @@ - -{-# 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, - delayedValue, - ) where - -import Data.AffineSpace -import Data.AffineSpace.Point -import Data.Bifunctor -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.String -import Data.Functor.Adjunction (unzipR) - -import Control.Applicative -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 -import Music.Time.Reverse -import Music.Time.Split - - --- | --- '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. --- -newtype Delayed a = Delayed { _delayedValue :: (Time, a) } - deriving (Eq, {-Ord, -}{-Show, -} - Applicative, Monad, {-Comonad, -} - Functor, Foldable, Traversable, Typeable) - --- $semantics Delayed --- --- @ --- type Delayed a = (Time, a) --- @ --- - -instance (Show a, Transformable a) => Show (Delayed a) where - show x = show (x^.from delayed) ++ "^.delayed" - -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 - -- TODO is this right? - split t = unzipR . fmap (split t) - --- Lifted instances - -instance IsString a => IsString (Delayed a) where - fromString = pure . fromString - -instance IsPitch a => IsPitch (Delayed a) where - fromPitch = pure . fromPitch - -instance IsInterval a => IsInterval (Delayed a) where - fromInterval = pure . fromInterval - -instance IsDynamics a => IsDynamics (Delayed a) where - fromDynamics = pure . fromDynamics - --- | --- View a delayed value as a pair of a the original value and a delay time. --- -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 - where - delayTime t = delay (t .-. 0) - - diff --git a/src/Music/Time/Duration.hs b/src/Music/Time/Duration.hs --- a/src/Music/Time/Duration.hs +++ b/src/Music/Time/Duration.hs @@ -1,14 +1,15 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} ------------------------------------------------------------------------------------- -- | @@ -55,9 +56,6 @@ class HasDuration a where _duration :: a -> Duration -instance HasDuration Time where - _duration = 0 - instance HasDuration Duration where _duration = id @@ -98,34 +96,16 @@ _duration (Right 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 #-} -{- - --- TODO more general pattern here -withDurationR :: (Functor f, HasDuration a) => f a -> f (Duration, a) -withDurationR = fmap $ \x -> (_duration x, x) - -withDurationL :: (Contravariant f, HasDuration a) => f (Duration, a) -> f a -withDurationL = contramap $ \x -> (_duration x, x) - -mapWithDuration :: HasDuration a => (Duration -> a -> b) -> a -> b -mapWithDuration = over dual withDurationL . uncurry - where - dual :: Iso (a -> b) (c -> d) (Op b a) (Op d c) - dual = iso Op getOp - --} - +-- | +-- Access the duration. +-- +duration :: (Transformable a, HasDuration a) => Lens' a Duration +duration = lens _duration (flip stretchTo) +{-# INLINE duration #-} diff --git a/src/Music/Time/Event.hs b/src/Music/Time/Event.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Event.hs @@ -0,0 +1,271 @@ + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012-2014 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +------------------------------------------------------------------------------------- + +module Music.Time.Event ( + -- * Event type + Event, + + -- * Construction + event, + eventee, + spanEvent, + triple + ) where + +import Control.Applicative +import Control.Monad (join, mapM) +import Data.Semigroup +import Data.Functor.Couple +import Data.Functor.Classes +import Data.Functor.Compose +import Control.Monad.Compose +import Control.Comonad +import Control.Lens hiding (Indexable, Level, above, + below, index, inside, parts, + reversed, transform, (<|), (|>)) +import Data.PairMonad +import Data.String +import Data.VectorSpace +import Data.Foldable (Foldable) +import qualified Data.Foldable as Foldable +import Data.Typeable + +import Music.Dynamics.Literal +import Music.Pitch.Literal +import Music.Time.Internal.Util (through, tripped) +import Music.Time.Reverse +import Music.Time.Split +import Music.Time.Meta + + +-- | +-- A 'Event' 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') +-- @ +-- + +-- TODO +instance Traversable AddMeta where + traverse = annotated +instance Eq1 AddMeta where + eq1 = (==) +instance Eq a => Eq1 (Couple a) where + eq1 = (==) +instance Ord1 AddMeta where + compare1 = compare +instance Ord a => Ord1 (Couple a) where + compare1 = compare +instance Num (f (g a)) => Num (Compose f g a) where + Compose a + Compose b = Compose (a + b) + Compose a - Compose b = Compose (a - b) + Compose a * Compose b = Compose (a * b) + signum (Compose a) = Compose (signum a) + abs (Compose a) = Compose (abs a) + fromInteger = Compose . fromInteger +instance Fractional (f (g a)) => Fractional (Compose f g a) where + Compose a / Compose b = Compose (a / b) + fromRational = Compose . fromRational +instance Floating (f (g a)) => Floating (Compose f g a) where + +instance (Real (f (g a)), Ord1 f, Ord1 g, Ord a, Functor f) => Real (Compose f g a) where + -- TODO +instance (RealFrac (f (g a)), Ord1 f, Ord1 g, Ord a, Functor f) => RealFrac (Compose f g a) where + -- TODO +instance (Functor f, Monad f, Monad g, Traversable g) => Monad (Compose f g) where + return = Compose . return . return + xs >>= f = Compose $ mbind (getCompose . f) (getCompose xs) +instance (Comonad f, Comonad g) => Comonad (Compose f g) where + extract (Compose f) = (extract . extract) f + -- TODO duplicate + +newtype Event a = Event { getEvent :: Compose AddMeta (Couple Span) a } + deriving ( + Eq, + Ord, + Typeable, + Foldable, + Applicative, + Monad, + Comonad, + Traversable, + + Functor, + + Num, + Fractional, + Floating, + Real, + RealFrac + ) + +instance Wrapped (Event a) where + type Unwrapped (Event a) = AddMeta (Span, a) + _Wrapped' = iso (fmap getCouple . getCompose . getEvent) (Event . Compose . fmap Couple) + +instance Rewrapped (Event a) (Event b) + +instance Transformable (Event a) where + transform t = over eventSpan (transform t) + +instance HasDuration (Event a) where + _duration = _duration . _era + +instance HasPosition (Event a) where + _era = view eventSpan + +instance HasMeta (Event a) where + meta = _Wrapped . meta + +instance IsString a => IsString (Event a) where + fromString = pure . fromString + +instance IsPitch a => IsPitch (Event a) where + fromPitch = pure . fromPitch + +instance IsInterval a => IsInterval (Event a) where + fromInterval = pure . fromInterval + +instance IsDynamics a => IsDynamics (Event a) where + fromDynamics = pure . fromDynamics + +instance (Show a, Transformable a) => Show (Event a) where + show x = show (x^.from event) ++ "^.event" + +-- | View a event as a pair of the original value and the transformation (and vice versa). +event :: Iso (Span, a) (Span, b) (Event a) (Event b) +event = from (_Wrapped . unsafeAnnotated) +-- TODO not safe anymore... + +-- safeUnevent = _Wrapped . annotated == from event +eventSpan :: Lens' (Event a) Span +eventSpan = from event . _1 + +eventValue :: Lens (Event a) (Event b) a b +eventValue = from event . _2 + +-- | View the value in the event. +eventee :: (Transformable a, Transformable b) => Lens (Event a) (Event b) a b +eventee = from event `dependingOn` (transformed) + +-- | Event as a span with a trivial value. +spanEvent :: Iso' Span (Event ()) +spanEvent = iso (\s -> (s,())^.event) (^.era) + +-- | View a event as a @(time, duration, value)@ triple. +triple :: Iso (Event a) (Event b) (Time, Duration, a) (Time, Duration, b) +triple = from event . bimapping delta id . tripped + + +-- TODO consolidate +dependingOn :: Lens s t (x,a) (x,b) -> (x -> Lens a b c d) -> Lens s t c d +dependingOn l depending f = l (\ (x,a) -> (x,) <$> depending x f a) + + + + + + + + + +-- newtype AddMeta1 f a = AddMeta1 { getAddMeta1 :: Twain Meta (f a) } +-- deriving ( +-- ) +-- +-- instance Wrapped (AddMeta1 f a) where +-- type Unwrapped (AddMeta1 f a) = Twain Meta (f a) +-- _Wrapped' = iso getAddMeta1 AddMeta1 +-- +-- instance Rewrapped (AddMeta1 f a) (AddMeta1 f b) +-- +-- instance HasMeta (AddMeta1 f a) where +-- -- twain, pair, element +-- meta = _Wrapped . _Wrapped . _1 +-- +-- +-- -- instance FunctorWithIndex i AddMeta1 where +-- -- imap f = over annotated $ imap f +-- -- +-- -- instance FoldableWithIndex Span Score where +-- -- ifoldMap f (Score (m,x)) = ifoldMap f x +-- -- +-- -- instance TraversableWithIndex Span Score where +-- -- itraverse f (Score (m,x)) = fmap (\x -> Score (m,x)) $ itraverse f x +-- +-- instance Transformable (f a) => Transformable (AddMeta1 f a) where +-- transform t = over meta (transform t) . over annotated1 (transform t) +-- +-- instance Reversible (f a) => Reversible (AddMeta1 f a) where +-- rev = over meta rev . over annotated1 rev +-- +-- -- instance Splittable a => Splittable (AddMeta1 a) where +-- -- split t = unzipR . fmap (split t) +-- +-- instance HasPosition (f a) => HasPosition (AddMeta1 f a) where +-- _era = _era . extract +-- _position = _position . extract +-- +-- instance HasDuration (f a) => HasDuration (AddMeta1 f a) where +-- _duration = _duration . extract +-- +-- -- | +-- -- Access the annotated value. +-- -- +-- -- @ +-- -- over annotated = fmap +-- -- @ +-- -- +-- annotated1 :: Lens (AddMeta1 f a) (AddMeta1 f b) (f a) (f b) +-- annotated1 = unsafeAnnotated1 +-- +-- -- | +-- -- Access the annotated value. +-- -- +-- -- @ +-- -- view fromAnnotated = pure +-- -- @ +-- -- +-- unannotated1 :: Getter (f a) (AddMeta1 f a) +-- unannotated1 = from unsafeAnnotated1 +-- +-- unsafeAnnotated1 :: Iso (AddMeta1 f a) (AddMeta1 f b) (f a) (f b) +-- unsafeAnnotated1 = _Wrapped . extracted +-- +-- unzipR f = (map fst f, map snd f) +-- +-- extracted :: (Applicative m, Comonad m) => Iso (m a) (m b) a b +-- extracted = iso extract pure diff --git a/src/Music/Time/Future.hs b/src/Music/Time/Future.hs --- a/src/Music/Time/Future.hs +++ b/src/Music/Time/Future.hs @@ -1,6 +1,19 @@ +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012-2014 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +------------------------------------------------------------------------------------- + module Music.Time.Future ( module Music.Time.Past ) where +-- Future and Past are defined together in this module for now. import Music.Time.Past diff --git a/src/Music/Time/Graces.hs b/src/Music/Time/Graces.hs --- a/src/Music/Time/Graces.hs +++ b/src/Music/Time/Graces.hs @@ -1,17 +1,15 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} ------------------------------------------------------------------------------------- -- | diff --git a/src/Music/Time/Internal/Convert.hs b/src/Music/Time/Internal/Convert.hs --- a/src/Music/Time/Internal/Convert.hs +++ b/src/Music/Time/Internal/Convert.hs @@ -25,10 +25,8 @@ ------------------------------------------------------------------------------------- module Music.Time.Internal.Convert ( - voiceToScore, - voiceToScore', scoreToVoice, - reactiveToVoice', + reactiveToVoice' ) where import Control.Applicative @@ -51,34 +49,8 @@ import qualified Data.List as List -{- --- | Convert a note to an _onset and a voice. -noteToVoice :: Note a -> (Time, Voice a) -noteToVoice (view (from note) -> (s,x)) = (_onset s, stretchTo (_duration s) $ return x) --} - -{- --- | Convert a note to a score. -noteToScore :: Note a -> Score a -noteToScore (view (from note) -> (s,x)) = s `transform` return x --} - --- scoreToNotes :: Score a -> [Note a] --- scoreToNotes = Foldable.toList . reifyScore - --- notesToScore :: [Note a] -> Score a --- notesToScore = pcat . fmap noteToScore - -{- -reactiveToVoice :: Duration -> Reactive a -> Voice a -reactiveToVoice d r = (^. voice) $ fmap (^. stretched) $ durs `zip` (fmap (r `atTime`) times) - where - times = 0 : filter (\t -> 0 < t && t < 0 .+^ d) (occs r) - durs = toRelativeTimeN' (0 .+^ d) times --} - reactiveToVoice' :: Span -> Reactive a -> Voice a -reactiveToVoice' (view range -> (u,v)) r = (^. voice) $ fmap (^. stretched) $ durs `zip` (fmap (r `atTime`) times) +reactiveToVoice' (view range -> (u,v)) r = (^. voice) $ fmap (^. note) $ durs `zip` (fmap (r `atTime`) times) where times = 0 : filter (\t -> u < t && t < v) (occs r) durs = toRelativeTimeN' v times @@ -88,7 +60,7 @@ -- Convert a score to a voice. Fails if the score contain overlapping events. -- scoreToVoice :: Transformable a => Score a -> Voice (Maybe a) -scoreToVoice = (^. voice) . fmap (^. stretched) . fmap throwTime . addRests . (^. events) +scoreToVoice = (^. voice) . fmap (^. note) . fmap throwTime . addRests . (^. triples) where throwTime (t,d,x) = (d,x) addRests = concat . snd . mapAccumL g 0 @@ -99,77 +71,8 @@ | otherwise = error "scoreToVoice: Strange prevTime" {-# DEPRECATED scoreToVoice "" #-} --- | --- Convert a voice to a score. --- -voiceToScore :: Voice a -> Score a -voiceToScore = scat . fmap g . (^. stretcheds) where g = (^. stretchedValue) . fmap return -{-# DEPRECATED voiceToScore "" #-} - {- --- | Join voices in a given part into a score. -voicesToScore :: HasPart a => [(Part a, Voice a)] -> Score a -voicesToScore = pcat . fmap (voiceToScore . uncurry (\n -> fmap (setPart n))) --} - --- | --- Convert a voice which may contain rests to a score. --- -voiceToScore' :: Voice (Maybe a) -> Score a -voiceToScore' = mcatMaybes . voiceToScore -{-# DEPRECATED voiceToScore' "" #-} - -{- --- | --- Convert a track to a score where each event is given a fixed duration. --- -trackToScore :: Transformable a => Duration -> Track a -> Score a -trackToScore x = trackToScore' (const x) - --- | --- Convert a track to a score, using durations determined by the values. --- -trackToScore' :: Transformable a => (a -> Duration) -> Track a -> Score a -trackToScore' f = (^. from events) . fmap (\(t,x) -> (t,f x,x)) . map (^. from delayed) . (^. delayeds) +voiceToScore :: Voice a -> Score a +voiceToScore = renderAlignedVoice . aligned (0 :: Time) (0 :: LocalDuration) -} - - --- TODO rename during -noteToReactive :: Monoid a => Note a -> Reactive a -noteToReactive n = (pure <$> n) `activate` pure mempty - --- JUNK - --- | Split a reactive into mkNotes, as well as the values before and after the first/last update -splitReactive :: Reactive a -> Either a ((a, Time), [Note a], (Time, a)) -splitReactive r = case updates r of - [] -> Left (initial r) - (t,x):[] -> Right ((initial r, t), [], (t, x)) - (t,x):xs -> Right ((initial r, t), fmap mkNote $ mrights (res $ (t,x):xs), head $ mlefts (res $ (t,x):xs)) - - where - - mkNote (t,u,x) = (t <-> u, x)^.note - - -- Always returns a 0 or more Right followed by one left - res :: [(Time, a)] -> [Either (Time, a) (Time, Time, a)] - res rs = let (ts,xs) = unzip rs in - flip fmap (withNext ts `zip` xs) $ - \ ((t, mu), x) -> case mu of - Nothing -> Left (t, x) - Just u -> Right (t, u, x) - - -- lenght xs == length (withNext xs) - withNext :: [a] -> [(a, Maybe a)] - withNext = go - where - go [] = [] - go [x] = [(x, Nothing)] - go (x:y:rs) = (x, Just y) : withNext (y : rs) - -activate :: Note (Reactive a) -> Reactive a -> Reactive a -activate (view (from note) -> (view range -> (start,stop), x)) y = y `turnOn` (x `turnOff` y) - where - turnOn = switchR start - turnOff = switchR stop diff --git a/src/Music/Time/Internal/Quantize.hs b/src/Music/Time/Internal/Quantize.hs --- a/src/Music/Time/Internal/Quantize.hs +++ b/src/Music/Time/Internal/Quantize.hs @@ -76,8 +76,8 @@ getBeatDuration _ = error "getBeatValue: Not a beat" -- TODO return voice -realize :: Rhythm a -> [Stretched a] -realize (Beat d a) = [(d, a)^.stretched] +realize :: Rhythm a -> [Note a] +realize (Beat d a) = [(d, a)^.note] realize (Group rs) = rs >>= realize realize (Dotted n r) = dotMod n `stretch` realize r realize (Tuplet n r) = n `stretch` realize r @@ -184,7 +184,7 @@ tupletDot orig = orig splitTupletIfLongEnough :: Rhythm a -> Rhythm a -splitTupletIfLongEnough r = if _duration r > (1/4) then splitTuplet r else r +splitTupletIfLongEnough r = if _duration r > (1/2) then splitTuplet r else r -- TODO should compare against beat duration, not just (1/4) -- | Splits a tuplet iff it contans a group which can be split into two halves whose diff --git a/src/Music/Time/Internal/Transform.hs b/src/Music/Time/Internal/Transform.hs --- a/src/Music/Time/Internal/Transform.hs +++ b/src/Music/Time/Internal/Transform.hs @@ -34,9 +34,7 @@ -- * The Transformable class Transformable(..), - itransform, transformed, - itransformed, -- * Apply under a transformation whilst, @@ -46,7 +44,6 @@ whilstLD, whilstStretch, whilstDelay, - spanned, onSpan, conjugateS, @@ -86,36 +83,21 @@ import qualified Data.Set as Set 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 s) = 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 --- @ +-- Transformable laws: +-- > transform mempty = id +-- > transform (s <> t) = transform s . transform t -- --- @ --- delay n b ! t = b ! (t .-^ n) --- undelay n b ! t = b ! (t .+^ n) --- @ +-- Duration law: +-- > _duration a = _duration (_era a) -- --- Lemma +-- Position law: +-- > _position p (transform s a) = transform s (_position p a) -- --- @ --- duration a = duration (delay n a) --- @ +-- Lemma: +-- > _duration (transform s a) = transform s (_duration a) + +-- | +-- Class of values that can be transformed (i.e. scaled and moved) in time. -- class Transformable a where transform :: Span -> a -> a @@ -183,48 +165,26 @@ instance (Ord k, Transformable a) => Transformable (Map k a) where transform t = Map.map (transform t) --- | -- Functions transform by conjugation, i.e. we reverse-transform the argument -- and transform the result. -- instance (Transformable a, Transformable b) => Transformable (a -> b) where transform t = (`whilst` negateV t) - - --- | --- Apply the inverse of the given transformation. --- --- @ --- 'itransform' s = 'transform' ('negateV' s) --- @ --- -itransform :: Transformable a => Span -> a -> a -itransform s = transform (negateV s) + where + f `whilst` t = over (transformed t) f -- | -- View the given value in the context of the given transformation. -- transformed :: (Transformable a, Transformable b) => Span -> Iso a b a b -transformed s = iso (transform s) (itransform s) +transformed s = iso (transform s) (transform $ negateV s) -- | --- Transforms a lens of to a 'Transformable' type to act inside a transformation. --- -itransformed :: (Transformable a, Transformable b) => Span -> Iso a b a b -itransformed s = transformed (negateV s) - -spanned = itransformed -{-# DEPRECATED spanned "Use itransformed" #-} - --- | -- Apply a function under transformation. -- --- Designed to be used infix, as in --- --- @ --- 'stretch' 2 `whilst` 'delaying' 2 --- @ +-- >>> stretch 2 `whilst` delaying 2 $ (1 <-> 2) +-- 4 <-> 6 -- whilst :: (Transformable a, Transformable b) => (a -> b) -> Span -> a -> b -- f `whilst` t = transform (negateV t) . f . transform t @@ -436,7 +396,7 @@ -- onSpan :: (Transformable s, Transformable t, Functor f) => LensLike f s t a b -> Span -> LensLike f s t a b -f `onSpan` s = spanned s . f +f `onSpan` s = transformed (negateV s) . f -- TODO name -- deriving instance Functor Sum diff --git a/src/Music/Time/Internal/Util.hs b/src/Music/Time/Internal/Util.hs --- a/src/Music/Time/Internal/Util.hs +++ b/src/Music/Time/Internal/Util.hs @@ -29,6 +29,7 @@ partial, partial2, partial3, + _zipList, ) where {- @@ -360,16 +361,20 @@ through lens1 lens2 = lens getter (flip setter) where getter = fmap (view lens1) - setter = liftA2 (over lens2 . const) + setter = liftA2 (set lens2) {-# INLINE through #-} +_zipList :: Iso [a] [b] (ZipList a) (ZipList b) +_zipList = iso ZipList getZipList + + 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 ((a, b), c) ((d, e), f) (a, b, c) (d, e, f) tripped = iso tripl untripl {-# INLINE tripped #-} 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,7 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE RankNTypes #-} diff --git a/src/Music/Time/Meta.hs b/src/Music/Time/Meta.hs --- a/src/Music/Time/Meta.hs +++ b/src/Music/Time/Meta.hs @@ -12,6 +12,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} ------------------------------------------------------------------------------------- -- | @@ -236,7 +237,7 @@ -- -- You can access the meta-data using 'meta', and the annotated value using 'annotated'. -- -newtype AddMeta a = AddMeta { getAddMeta :: Twain Meta a } +newtype AddMeta a = AddMeta { getAddMeta :: Meta `Twain` a } deriving ( Show, Functor, Foldable, Typeable, Applicative, Monad, Comonad, Semigroup, Monoid, Num, Fractional, Floating, Enum, Bounded, @@ -274,8 +275,7 @@ split t = unzipR . fmap (split t) instance HasPosition a => HasPosition (AddMeta a) where - _onset = _onset . extract - _offset = _offset . extract + _era = _era . extract _position = _position . extract instance HasDuration a => HasDuration (AddMeta a) where diff --git a/src/Music/Time/Nominal.hs b/src/Music/Time/Nominal.hs --- a/src/Music/Time/Nominal.hs +++ b/src/Music/Time/Nominal.hs @@ -1,17 +1,16 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} ------------------------------------------------------------------------------------- -- | @@ -41,7 +40,16 @@ import Music.Time.Reverse newtype Nominal f a = Nominal { getNominal :: f a } - deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Monad) + deriving ( + Eq, + Ord, + Read, + Show, + Functor, + Foldable, + Traversable, + Monad + ) instance Applicative f => Applicative (Nominal f) where pure = Nominal . pure diff --git a/src/Music/Time/Note.hs b/src/Music/Time/Note.hs --- a/src/Music/Time/Note.hs +++ b/src/Music/Time/Note.hs @@ -1,21 +1,14 @@ -{-# 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 #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TupleSections #-} ------------------------------------------------------------------------------------- -- | @@ -32,108 +25,73 @@ module Music.Time.Note ( -- * Note type Note, - -- * Construction note, - event, - noteValue, + notee, + durationNote, + -- noteComplement, ) 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.String -import Data.VectorSpace - import Control.Applicative -import Control.Comonad -import Control.Comonad.Env import Control.Lens hiding (Indexable, Level, above, below, index, inside, parts, reversed, transform, (<|), (|>)) +import Data.Bifunctor import Data.Foldable (Foldable) import qualified Data.Foldable as Foldable -import Data.PairMonad +import Data.Functor.Couple +import Data.String import Data.Typeable +import Data.VectorSpace -import Music.Pitch.Literal import Music.Dynamics.Literal -import Music.Time.Internal.Util (through, tripped) - +import Music.Pitch.Literal import Music.Time.Reverse import Music.Time.Split -- | --- A 'Note' is a value with an 'onset' and and 'offset' in time. It is an instance --- of 'Transformable'. --- --- You can use 'value' to apply a function in the context of the transformation, --- i.e. --- --- @ --- over value (* line) (delay 2 $ return line) --- @ +-- A value 'Note' value, representing a suspended stretch of some 'Transformable' +-- value. We can access the value in bothits original and note form using 'note' +-- and 'notee', respectively. -- --- @ --- ('view' 'value') . 'transform' s = 'transform' s . ('view' 'value') --- @ +-- Placing a value inside 'Note' makes it invariant under 'delay', however the inner +-- value can still be delayed using @'fmap' 'delay'@. -- -newtype Note a = Note { _noteValue :: (Span, a) } - deriving (Typeable) +newtype Note a = Note { getNote :: Duration `Couple` a } + deriving ( + Eq, + Ord, + Typeable, + Foldable, + Traversable, --- $semantics --- --- type Note a = (Span, a) --- + Functor, + Applicative, + Monad, -deriving instance Eq a => Eq (Note a) -deriving instance Functor Note -deriving instance Foldable Note -deriving instance Traversable Note -deriving instance Comonad Note + Num, + Fractional, + Floating, + Real, + RealFrac + ) + -- Comonad, 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 - instance Wrapped (Note a) where - type Unwrapped (Note a) = (Span, a) - _Wrapped' = iso _noteValue Note + type Unwrapped (Note a) = (Duration, a) + _Wrapped' = iso (getCouple . getNote) (Note . Couple) instance Rewrapped (Note a) (Note b) instance Transformable (Note a) where - transform t = over (_Wrapped . _1) $ transform t + transform t = over (from note . _1) (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 (d / _duration s) v) - -instance Reversible (Note a) where - rev = revDefault - --- Lifted instances + _duration = _duration . view (from note) instance IsString a => IsString (Note a) where fromString = pure . fromString @@ -147,28 +105,50 @@ instance IsDynamics a => IsDynamics (Note a) where fromDynamics = pure . fromDynamics --- | --- View a note as a pair of the original value and the transformation (and vice versa). --- -note :: ({-Transformable a, Transformable b-}) => Iso (Span, a) (Span, b) (Note a) (Note b) +-- | View a note value as a pair of the original value and a stretch factor. +note :: Iso (Duration, a) (Duration, b) (Note a) (Note b) note = _Unwrapped --- | --- View the value in the note. +-- | Access the note value. +-- Taking a value out carries out the stretch (using the 'Transformable' instance), +-- while putting a value in carries out the reverse transformation. -- -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 notee $ (2,3::Duration)^.note +-- 6 +-- +-- >>> set notee 6 $ (2,1::Duration)^.note +-- (2,3)^.note +-- +notee :: (Transformable a, Transformable b) => Lens (Note a) (Note b) a b +notee = _Wrapped `dependingOn` (transformed . stretching) --- | --- View a note as an events, i.e. a time-duration-value triplet. +-- | A note value as a duration carrying an associated value. +-- Whitness by picking a trivial value. -- -event :: Iso (Note a) (Note b) (Time, Duration, a) (Time, Duration, b) -event = from note . bimapping delta id . tripped +-- >>> 2^.durationNote +-- (2,())^.note +-- +durationNote :: Iso' Duration (Note ()) +durationNote = iso (\d -> (d,())^.note) (^.duration) + +-- >>> (pure ())^.from durationNote +-- 1 +-- >>> (pure () :: Note ())^.duration +-- 1 + +-- TODO could also be an iso... +noteComplement :: Note a -> Note a +noteComplement (Note (Couple (d,x))) = Note $ Couple (negateV d, x) + +-- FIXME negateV is negate not recip +-- The negateV method should follow (^+^), which is (*) for durations (is this bad?) + + +-- TODO consolidate +dependingOn :: Lens s t (x,a) (x,b) -> (x -> Lens a b c d) -> Lens s t c d +dependingOn l depending f = l (\ (x,a) -> (x,) <$> depending x f a) + + diff --git a/src/Music/Time/Past.hs b/src/Music/Time/Past.hs --- a/src/Music/Time/Past.hs +++ b/src/Music/Time/Past.hs @@ -5,7 +5,16 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE CPP #-} -module Music.Time.Past where +module Music.Time.Past ( + Past(..), + Future(..), + past, + future, + indexPast, + firstTrue, + pastSeg, + futureSeg, + ) where import Control.Lens -- DEBUG import Control.Applicative @@ -28,7 +37,7 @@ -- -- It may be seen as a note whose era is a left-open, right-inclusive time interval. -- -newtype Past a = Past { getPast :: (Min Time, a) } +newtype Past a = Past { getPast :: (Min (Maybe Time), a) } deriving (Eq, Ord, Functor) -- | @@ -36,36 +45,38 @@ -- -- It may be seen as a note whose era is a left-open, right-inclusive time interval. -- -newtype Future a = Future { getFuture :: (Max Time, a) } +newtype Future a = Future { getFuture :: (Max (Maybe Time), a) } deriving (Eq, Ord, Functor) -instance HasDuration (Past a) where - _duration _ = 0 - -instance HasDuration (Future a) where - _duration _ = 0 - -instance HasPosition (Past a) where - _position (Past (extract -> t,_)) _ = t - -instance HasPosition (Future a) where - _position (Future (extract -> t,_)) _ = t +-- instance HasDuration (Past a) where +-- _duration _ = 0 +-- +-- instance HasDuration (Future a) where +-- _duration _ = 0 +-- +-- instance HasPosition (Past a) where +-- _position (Past ((extract . extract) -> t,_)) _ = t +-- +-- instance HasPosition (Future a) where + -- _position (Future (extract -> t,_)) _ = t -- | Query a past value. Semantic function. past :: Past a -> Time -> Maybe a past (Past (extract -> t, x)) t' - | t' <= t = Just x - | otherwise = Nothing + | Just t' <= t = Just x + | otherwise = Nothing -- | Query a future value. Semantic function. future :: Future a -> Time -> Maybe a future (Future (extract -> t, x)) t' - | t' >= t = Just x - | otherwise = Nothing + | Just t' >= t = Just x + | otherwise = Nothing -- TODO more elegant indexPast :: [Past a] -> Time -> Maybe a -indexPast ps t = firstTrue $ fmap (\p -> past p t) $ sortBy (comparing _onset) ps +indexPast ps t = firstTrue $ fmap (\p -> past p t) $ sortBy (comparing tv) ps + where + tv (Past (Min t, _)) = t firstTrue :: [Maybe a] -> Maybe a firstTrue = listToMaybe . join . fmap maybeToList diff --git a/src/Music/Time/Placed.hs b/src/Music/Time/Placed.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Placed.hs @@ -0,0 +1,116 @@ + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012-2014 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +------------------------------------------------------------------------------------- + +module Music.Time.Placed ( + -- * Placed type + Placed, + + -- * Construction + placed, + placee, + ) where + +import Control.Applicative +import Control.Comonad +import Control.Lens hiding (Indexable, Level, above, below, + index, inside, parts, reversed, + transform, (<|), (|>)) +import Data.AffineSpace +import Data.AffineSpace.Point +import Data.Bifunctor +import Data.Foldable (Foldable) +import qualified Data.Foldable as Foldable +import Data.Functor.Adjunction (unzipR) +import Data.Functor.Couple +import Data.String +import Data.Typeable +import Data.VectorSpace + +import Music.Dynamics.Literal +import Music.Pitch.Literal +import Music.Time.Reverse +import Music.Time.Split + + +-- | +-- 'Placed' represents a value with an offset in time. +-- +-- A placed value has a known 'position', but no 'duration'. +-- +-- Placing a value inside 'Placed' does not make it invariant under 'stretch', as the +-- offset of a placed value may be stretched with respect to the origin. However, in +-- contrast to a note the /duration/ is not stretched. +-- +newtype Placed a = Placed { getPlaced :: Time `Couple` a } + deriving ( + Eq, + Ord, + Typeable, + Foldable, + Traversable, + + Functor, + Applicative, + Monad, + Comonad + ) + +instance (Show a, Transformable a) => Show (Placed a) where + show x = show (x^.from placed) ++ "^.placed" + +instance Wrapped (Placed a) where + type Unwrapped (Placed a) = (Time, a) + _Wrapped' = iso (getCouple . getPlaced) (Placed . Couple) + +instance Rewrapped (Placed a) (Placed b) + +instance Transformable a => Transformable (Placed a) where + transform t = + over (from placed . _1) (transform t) + . + over (from placed . _2) (stretch $ stretchComponent t) + +instance IsString a => IsString (Placed a) where + fromString = pure . fromString + +instance IsPitch a => IsPitch (Placed a) where + fromPitch = pure . fromPitch + +instance IsInterval a => IsInterval (Placed a) where + fromInterval = pure . fromInterval + +instance IsDynamics a => IsDynamics (Placed a) where + fromDynamics = pure . fromDynamics + +placed :: Iso (Time, a) (Time, b) (Placed a) (Placed b) +placed = _Unwrapped + +placee :: (Transformable a, Transformable b) => Lens (Placed a) (Placed b) a b +placee = from placed `dependingOn` (transformed . delayingTime) + where + delayingTime = (>-> 1) + +-- TODO consolidate +dependingOn :: Lens s t (x,a) (x,b) -> (x -> Lens a b c d) -> Lens s t c d +dependingOn l depending f = l (\ (x,a) -> (x,) <$> depending x f a) diff --git a/src/Music/Time/Position.hs b/src/Music/Time/Position.hs --- a/src/Music/Time/Position.hs +++ b/src/Music/Time/Position.hs @@ -1,21 +1,17 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} {-# 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 #-} +{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------------- -- | @@ -40,6 +36,8 @@ -- * Era era, + _onset, + _offset, -- * Position position, @@ -57,10 +55,20 @@ stopAt, placeAt, - -- * Internal - -- TODO hide... - _setEra, - _getEra, + stretchRelative, + stretchRelativeOnset, + stretchRelativeMidpoint, + stretchRelativeOffset, + + delayRelative, + delayRelativeOnset, + delayRelativeMidpoint, + delayRelativeOffset, + + transformRelative, + transformRelativeOnset, + transformRelativeMidpoint, + transformRelativeOffset, ) where @@ -102,38 +110,26 @@ -- @ -- 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 + _position :: a -> Duration -> Time + _position x = alerp a b where (a, b) = (_era x)^.range + _era :: HasPosition a => a -> Span + _era x = x `_position` 0 <-> x `_position` 1 + 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 + _era = id +#ifndef GHCI 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 #-} + _era x = (f x, g x)^.from range + where + f = foldr min 0 . fmap _onset + g = foldr max 0 . fmap _offset +#endif -- | -- Position of the given value. @@ -208,6 +204,10 @@ placeAt :: (Transformable a, HasPosition a) => Duration -> Time -> a -> a placeAt p t x = (t .-. x `_position` p) `delay` x +_onset, _offset :: HasPosition a => a -> Time +_onset = (`_position` 0) +_offset = (`_position` 1.0) + -- | -- Place a value over the given span. -- @@ -220,7 +220,44 @@ -- A lens to the position -- era :: (HasPosition a, Transformable a) => Lens' a Span -era = lens _getEra (flip _setEra) +era = lens _era (flip _setEra) {-# INLINE era #-} + +stretchRelative :: (HasPosition a, Transformable a) => Duration -> Duration -> a -> a +stretchRelative p n x = over (transformed $ undelaying (realToFrac $ x^.position p)) (stretch n) x + +stretchRelativeOnset :: (HasPosition a, Transformable a) => Duration -> a -> a +stretchRelativeOnset = stretchRelative 0 + +stretchRelativeMidpoint :: (HasPosition a, Transformable a) => Duration -> a -> a +stretchRelativeMidpoint = stretchRelative 0.5 + +stretchRelativeOffset :: (HasPosition a, Transformable a) => Duration -> a -> a +stretchRelativeOffset = stretchRelative 1 + +delayRelative :: (HasPosition a, Transformable a) => Duration -> Duration -> a -> a +delayRelative p n x = over (transformed $ undelaying (realToFrac $ x^.position p)) (delay n) x + +delayRelativeOnset :: (HasPosition a, Transformable a) => Duration -> a -> a +delayRelativeOnset = delayRelative 0 + +delayRelativeMidpoint :: (HasPosition a, Transformable a) => Duration -> a -> a +delayRelativeMidpoint = delayRelative 0.5 + +delayRelativeOffset :: (HasPosition a, Transformable a) => Duration -> a -> a +delayRelativeOffset = delayRelative 1 + + +transformRelative :: (HasPosition a, Transformable a) => Duration -> Span -> a -> a +transformRelative p n x = over (transformed $ undelaying (realToFrac $ x^.position p)) (transform n) x + +transformRelativeOnset :: (HasPosition a, Transformable a) => Span -> a -> a +transformRelativeOnset = transformRelative 0 + +transformRelativeMidpoint :: (HasPosition a, Transformable a) => Span -> a -> a +transformRelativeMidpoint = transformRelative 0.5 + +transformRelativeOffset :: (HasPosition a, Transformable a) => Span -> a -> a +transformRelativeOffset = transformRelative 1 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 @@ -1,16 +1,13 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -70,7 +67,7 @@ import Music.Time.Behavior import Music.Time.Bound -import Music.Time.Note +import Music.Time.Event import Music.Time.Reverse import Music.Time.Segment import Music.Time.Split @@ -119,6 +116,9 @@ instance Transformable (Reactive a) where transform s (Reactive (t,r)) = Reactive (transform s t, transform s r) +instance Reversible (Reactive a) where + rev = stretch (-1) + instance Wrapped (Reactive a) where type Unwrapped (Reactive a) = ([Time], Behavior a) _Wrapped' = iso getReactive Reactive @@ -126,7 +126,12 @@ instance Rewrapped (Reactive a) (Reactive b) instance Applicative Reactive where pure = pureDefault + where + pureDefault = view _Unwrapped . pure . pure + (<*>) = apDefault + where + (view _Wrapped -> (tf, rf)) `apDefault` (view _Wrapped -> (tx, rx)) = view _Unwrapped (tf <> tx, rf <*> rx) instance IsPitch a => IsPitch (Reactive a) where fromPitch = pure . fromPitch @@ -146,8 +151,6 @@ diminish = fmap diminish -(view _Wrapped -> (tf, rf)) `apDefault` (view _Wrapped -> (tx, rx)) = view _Unwrapped (tf <> tx, rf <*> rx) -pureDefault = view _Unwrapped . pure . pure -- | -- Get the initial value. @@ -171,16 +174,16 @@ 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)) +-- | Split a reactive into events, as well as the values before and after the first/last update +splitReactive :: Reactive a -> Either a ((a, Time), [Event 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)) + (t,x):xs -> Right ((initial r, t), fmap mkEvent $ mrights (res $ (t,x):xs), head $ mlefts (res $ (t,x):xs)) where - mkNote (t,u,x) = (t <-> u, x)^.note + mkEvent (t,u,x) = (t <-> u, x)^.event -- Always returns a 0 or more Right followed by one left res :: [(Time, a)] -> [Either (Time, a) (Time, Time, a)] @@ -198,11 +201,6 @@ 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') @@ -224,9 +222,9 @@ -- | -- Get all intermediate values. -- -intermediate :: Transformable a => Reactive a -> [Note a] +intermediate :: Transformable a => Reactive a -> [Event a] intermediate (updates -> []) = [] -intermediate (updates -> xs) = fmap (\((t1, x), (t2, _)) -> (t1 <-> t2, x)^.note) $ withNext $ xs +intermediate (updates -> xs) = fmap (\((t1, x), (t2, _)) -> (t1 <-> t2, x)^.event) $ withNext $ xs where withNext xs = zip xs (tail xs) @@ -236,24 +234,14 @@ discrete :: Reactive a -> Behavior a discrete = continous . fmap pure --- | --- Realize a 'Reactive' value as an continous behavior. --- --- See also 'concatSegment' and 'concatB'. --- +-- | Realize a 'Reactive' value as an continous behavior. continous :: Reactive (Segment a) -> Behavior a --- | --- Realize a 'Reactive' value as an continous behavior. --- --- See also 'concatSegment' and 'concatB'. --- +-- | Realize a 'Reactive' value as an continous behavior. continousWith :: Segment (a -> b) -> Reactive a -> Behavior b continousWith f x = continous $ liftA2 (<*>) (pure f) (fmap pure x) --- | --- Sample a 'Behavior' into a reactive. --- +-- | Sample a 'Behavior' into a reactive. sample :: [Time] -> Behavior a -> Reactive a -- TODO linear approximation @@ -298,5 +286,4 @@ newtype Search a = Search { getSearch :: forall r . (a -> Tree r) -> Tree r } -} --- JUNK diff --git a/src/Music/Time/Reverse.hs b/src/Music/Time/Reverse.hs --- a/src/Music/Time/Reverse.hs +++ b/src/Music/Time/Reverse.hs @@ -1,20 +1,15 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} {-# 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 #-} ------------------------------------------------------------------------------------- -- | @@ -165,9 +160,11 @@ -- 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 +-- Alternative: +-- revDefault x = (stretch (-1) `whilst` undelaying (_position x 0.5 .-. 0)) x +-- where f `whilst` t = over (transformed t) f newtype NoReverse a = NoReverse { getNoReverse :: a } deriving (Typeable, Eq, Ord, Show) @@ -186,87 +183,4 @@ -- reversed :: Reversible a => Iso' a a reversed = iso rev rev - - - - - -{- --- | --- Reversible values. --- --- For instances of 'Reversible' and 'HasOnset', the following laws should hold: --- --- > onset a = onset (rev a) --- > duration a = duration (rev a) --- --- For structural types, 'rev' is applied recursively, hence the constraint on --- the 'Score' instance. 'rev' is id by default, so for a trivial type @T@ it --- suffices to write --- --- > instance Reversible T --- --- For instances 'U' of 'HasOnset' and 'Transformable', a suitable instance --- is --- --- > instance Reversible T where --- > rev = withSameOnset (stretch (-1)) --- --- - -class Reversible a where - - -- | - -- Reverse a value. - -- - -- Reverse is an involution, meaning that: - -- - -- > rev (rev a) = a - -- - rev :: a -> a - rev = id - --- instance Reversible Time where - -- rev t = mirror t - -instance Reversible Double -instance Reversible Float -instance Reversible Int -instance Reversible Integer -instance Reversible () -instance Reversible (Ratio a) - -instance Reversible a => Reversible [a] where - rev = fmap rev - -instance (Ord a, Reversible a) => Reversible (Set a) where - rev = Set.map rev - -instance Reversible a => Reversible (Map k a) where - rev = fmap rev - -newtype NoRev a = NoRev { getNoRev :: a } - deriving (Eq, Ord, Enum, Show, Semigroup, Monoid, - Delayable, Stretchable, HasOnset, HasOffset, HasDuration) - -instance Reversible (NoRev a) where - rev = id - - - -newtype WithRev a = WithRev (a,a) - deriving (Eq, Ord, Semigroup, Monoid) - -withRev :: Reversible a => a -> WithRev a -withRev x = WithRev (rev x, x) - -fromWithRev :: Reversible a => WithRev a -> a -fromWithRev (WithRev (_,x)) = x - -instance Reversible a => Reversible (WithRev a) where - rev (WithRev (r,x)) = WithRev (x,r) - --- JUNK - -} - diff --git a/src/Music/Time/Score.hs b/src/Music/Time/Score.hs --- a/src/Music/Time/Score.hs +++ b/src/Music/Time/Score.hs @@ -1,20 +1,14 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} {-# 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 #-} ------------------------------------------------------------------------------------- @@ -37,22 +31,21 @@ -- * Construction score, - notes, - eras, events, - singleNote, + eras, + triples, -- * Traversal mapWithSpan, filterWithSpan, mapFilterWithSpan, - mapEvents, - filterEvents, - mapFilterEvents, + mapTriples, + filterTriples, + mapFilterTriples, -- * Simultaneous -- TODO check for overlapping values etc - simult, + -- simult, simultaneous, -- * Normalize @@ -60,8 +53,8 @@ printEras, -- * Unsafe versions - unsafeNotes, unsafeEvents, + unsafeTriples, ) where @@ -80,10 +73,10 @@ import Music.Time.Juxtapose (scat) import Music.Time.Meta -import Music.Time.Note +import Music.Time.Event import Music.Time.Reverse import Music.Time.Split -import Music.Time.Stretched +import Music.Time.Note import Music.Time.Voice import Control.Applicative @@ -109,8 +102,6 @@ -type ScoreNote a = Note a - -- * 'empty' creates an empty score -- -- * 'pure' creates a score containing a single note in the span @0 '<->' 1@ @@ -124,30 +115,24 @@ -- You can also use '<>' and 'mempty' of course. -- --- | --- A 'Score' is a sequential or parallel composition of values, and allows overlapping events +-- | A 'Score' is a sequential or parallel composition of values, and allows overlapping events +newtype Score a = Score { getScore :: (Meta, Score' a) } + deriving (Functor, Semigroup, Monoid, Foldable, Traversable, Typeable{-, Show, Eq, Ord-}) + -- --- You typically create a 'Score' using 'score', 'notes', 'voices', and 'phrases', or the 'Alternative' interface. +-- You typically create a 'Score' using 'score', 'events', '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 +-- To inspect or deconstruct a score, see 'events', 'voices', and 'phrases', as -- well as 'singleNote', 'singleVoice', and 'singlePhrase' -- -newtype Score a = Score { getScore' :: (Meta, NScore a) } - deriving (Functor, Semigroup, Monoid, Foldable, Traversable, Typeable{-, Show, Eq, Ord-}) --- --- $semantics Score --- --- type Score a = [Note a] --- - instance Wrapped (Score a) where - type Unwrapped (Score a) = (Meta, NScore a) - _Wrapped' = iso getScore' Score + type Unwrapped (Score a) = (Meta, Score' a) + _Wrapped' = iso getScore Score instance Rewrapped (Score a) (Score b) where @@ -181,18 +166,18 @@ 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 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 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 --- TODO move these two "implementations" to NScore +-- TODO move these two "implementations" to Score' instance HasPosition (Score a) where - _position = _position . snd . view _Wrapped' . normalizeScore' + _position = _position . snd . view _Wrapped' {-. normalizeScore'-} -- TODO clean up in terms of AddMeta and optimize instance HasDuration (Score a) where @@ -247,204 +232,108 @@ -newtype NScore a = NScore { getNScore :: [ScoreNote a] } +newtype Score' a = Score' { getScore' :: [Event a] } deriving ({-Eq, -}{-Ord, -}{-Show, -}Functor, Foldable, Traversable, Semigroup, Monoid, Typeable, Show, Eq) instance (Show a, Transformable a) => Show (Score a) where - show x = show (x^.notes) ++ "^.score" + show x = show (x^.events) ++ "^.score" -instance Wrapped (NScore a) where - type Unwrapped (NScore a) = [ScoreNote a] - _Wrapped' = iso getNScore NScore +instance Wrapped (Score' a) where + type Unwrapped (Score' a) = [Event a] + _Wrapped' = iso getScore' Score' -instance Rewrapped (NScore a) (NScore b) +instance Rewrapped (Score' a) (Score' b) -instance Applicative NScore where +instance Applicative Score' where pure = return (<*>) = ap -instance Monad NScore where +instance Monad Score' where return = (^. _Unwrapped) . pure . pure xs >>= f = (^. _Unwrapped) $ mbind ((^. _Wrapped') . f) ((^. _Wrapped') xs) -instance Alternative NScore where +instance Alternative Score' where empty = mempty (<|>) = mappend -instance MonadPlus NScore where +instance MonadPlus Score' 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 Transformable (Score' a) where + transform t = over (_Wrapped) (transform t) -instance HasDuration (NScore a) where - _duration x = _offset x .-. _onset x +-- instance Reversible a => Reversible (Score' a) where +-- rev (Score' xs) = Score' (fmap rev xs) -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 +instance HasPosition (Score' a) where + _era x = (f x, g x)^.from range where - -- TODO move - isEmptyNote :: Note a -> Bool - isEmptyNote = isEmptySpan . view era - - isEmptySpan :: Span -> Bool - isEmptySpan (view range -> (t, u)) = t == u + f = safeMinimum . fmap (_onset . normalizeSpan) . toListOf (_Wrapped . each . era) + g = safeMaximum . fmap (_offset . normalizeSpan) . toListOf (_Wrapped . each . era) + safeMinimum xs = if null xs then 0 else minimum xs + safeMaximum xs = if null xs then 0 else maximum xs +instance HasDuration (Score' a) where + _duration x = _offset x .-. _onset x --- | --- 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 +-- | Create a score from a list of events. +score :: Getter [Event a] (Score a) +score = from unsafeEvents {-# INLINE score #-} --- | --- View a 'Score' as a list of 'Note' values. +-- | View a 'Score' as a list of 'Event' values. +events :: Lens (Score a) (Score b) [Event a] [Event b] +events = _Wrapped . _2 . _Wrapped . sorted + where + -- TODO should not have to sort... + sorted = iso (List.sortBy (Ord.comparing _onset)) (List.sortBy (Ord.comparing _onset)) +{-# INLINE events #-} + -- -- @ --- 'view' 'notes' :: 'Score' a -> ['Note' a] --- 'set' 'notes' :: ['Note' a] -> 'Score' a -> 'Score' a --- 'over' 'notes' :: (['Note' a] -> ['Note' b]) -> 'Score' a -> 'Score' b +-- 'view' 'events' :: 'Score' a -> ['Event' a] +-- 'set' 'events' :: ['Event' a] -> 'Score' a -> 'Score' a +-- 'over' 'events' :: (['Event' a] -> ['Event' 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) +-- 'preview' ('events' . 'each') :: 'Score' a -> 'Maybe' ('Event' a) +-- 'preview' ('events' . 'element' 1) :: 'Score' a -> 'Maybe' ('Event' a) +-- 'preview' ('events' . 'elements' odd) :: 'Score' a -> 'Maybe' ('Event' 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 +-- 'set' ('events' . 'each') :: 'Event' a -> 'Score' a -> 'Score' a +-- 'set' ('events' . 'element' 1) :: 'Event' a -> 'Score' a -> 'Score' a +-- 'set' ('events' . 'elements' odd) :: 'Event' 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 +-- 'over' ('events' . 'each') :: ('Event' a -> 'Event' b) -> 'Score' a -> 'Score' b +-- 'over' ('events' . 'element' 1) :: ('Event' a -> 'Event' a) -> 'Score' a -> 'Score' a +-- 'over' ('events' . 'elements' odd) :: ('Event' a -> 'Event' 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] +-- 'toListOf' ('events' . 'each') :: 'Score' a -> ['Event' a] +-- 'toListOf' ('events' . 'elements' odd) :: 'Score' a -> ['Event' a] +-- 'toListOf' ('events' . 'each' . 'filtered' +-- (\\x -> '_duration' x \< 2)) :: 'Score' a -> ['Event' 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 +-- | A score is a list of events up to meta-data. To preserve meta-data, use the more +-- restricted 'score' and 'events'. +unsafeEvents :: Iso (Score a) (Score b) [Event a] [Event b] +unsafeEvents = _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 +-- | A score is a list of (time-duration-value triples) up to meta-data. +-- To preserve meta-data, use the more restricted 'triples'. +unsafeTriples :: Iso (Score a) (Score b) [(Time, Duration, a)] [(Time, Duration, b)] +unsafeTriples = iso _getScore _score where _score :: [(Time, Duration, a)] -> Score a _score = mconcat . fmap (uncurry3 event) @@ -456,91 +345,61 @@ fmap (\(view delta -> (t,d),x) -> (t,d,x)) . List.sortBy (Ord.comparing fst) . Foldable.toList . - fmap (view $ from note) . + fmap (view $ from event) . reifyScore - - --- | --- View a score as a single note. --- -singleNote :: Prism' (Score a) (Note a) -singleNote = unsafeNotes . single -{-# INLINE singleNote #-} -{-# DEPRECATED singleNote "Use 'unsafeNotes . single'" #-} --- TODO make prism fail if score contains meta-data --- (or else second prism law is not satisfied) - - -- | Map with the associated time span. -mapScore :: (Note a -> b) -> Score a -> Score b -mapScore f = over (_Wrapped._2) (mapNScore f) +mapScore :: (Event a -> b) -> Score a -> Score b +mapScore f = over (_Wrapped._2) (mapScore' f) where - mapNScore f = over (_Wrapped.traverse) (extend f) + mapScore' f = over (_Wrapped.traverse) (extend f) -reifyScore :: Score a -> Score (Note a) +reifyScore :: Score a -> Score (Event 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 - +-- | View a score as a list of time-duration-value triplets. +triples :: {-Transformable a => -}Lens (Score a) (Score b) [(Time, Duration, a)] [(Time, Duration, b)] +triples = events . _zipList . through triple triple . from _zipList -- | Map over the values in a score. mapWithSpan :: (Span -> a -> b) -> Score a -> Score b -mapWithSpan f = mapScore (uncurry f . view (from note)) +mapWithSpan f = mapScore (uncurry f . view (from event)) -- | Filter the values in a score. filterWithSpan :: (Span -> a -> Bool) -> Score a -> Score a filterWithSpan f = mapFilterWithSpan (partial2 f) --- | Combination of 'mapEvents' and 'filterEvents'. +-- | Combination of 'mapTriples' and 'filterTriples'. 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) +mapTriples :: (Time -> Duration -> a -> b) -> Score a -> Score b +mapTriples 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) +filterTriples :: (Time -> Duration -> a -> Bool) -> Score a -> Score a +filterTriples f = mapFilterTriples (partial3 f) --- | Efficient combination of 'mapEvents' and 'filterEvents'. -mapFilterEvents :: (Time -> Duration -> a -> Maybe b) -> Score a -> Score b -mapFilterEvents f = mcatMaybes . mapEvents f +-- | Efficient combination of 'mapTriples' and 'filterTriples'. +mapFilterTriples :: (Time -> Duration -> a -> Maybe b) -> Score a -> Score b +mapFilterTriples f = mcatMaybes . mapTriples f --- | Mainly useful for backends. +-- | Normalize a score, assuring its events spans are all forward (as by 'isForwardSpan'), +-- and that its onset is at least zero. Consequently, the onset and offset of each event +-- in the score is at least zero. normalizeScore :: Score a -> Score a -normalizeScore = reset . normalizeScore' +normalizeScore = reset . normalizeScoreDurations where reset x = set onset (view onset x `max` 0) x + normalizeScoreDurations = over (events . each . era) normalizeSpan -normalizeScore' = over (notes . each . era) normalizeSpan -- TODO version that reverses the values where appropriate --- Use over (notes . each) normalizeNote or similar - --- normalizeScore = reset . absDurations --- where --- reset x = set onset (view onset x `max` 0) x --- absDurations = over (notes.each.era.delta._2) abs +-- Use over (events . each) normalizeEvent or similar -- | --- Extract all eras of the given score. --- --- >>> printEras $ scat [c,d,e :: Score Integer] --- 0 <-> 1 --- 1 <-> 2 --- 2 <-> 3 +-- Print the span of each event, as given by 'eras'. -- printEras :: Score a -> IO () printEras = mapM_ print . toListOf eras @@ -552,15 +411,15 @@ -- [0 <-> 1,1 <-> 2,2 <-> 3] -- eras :: Traversal' (Score a) Span -eras = notes . each . era +eras = events . each . era +-- TODO rename and expose this +-- We have an (Iso (Score a) (TMap Span [a])), with [] as default value chordEvents :: Transformable a => Span -> Score a -> [a] -chordEvents s = fmap extract . filter ((== s) . view era) . view notes - - +chordEvents s = fmap extract . filter ((== s) . view era) . view events simultaneous' :: Transformable a => Score a -> Score [a] -simultaneous' sc = (^. from unsafeEvents) vs +simultaneous' sc = (^. from unsafeTriples) vs where -- es :: [Era] -- evs :: [[a]] @@ -572,18 +431,7 @@ -- 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@ --- +-- | Merge all simultaneous events using their 'Semigroup' instance. 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 - --- JUNK diff --git a/src/Music/Time/Segment.hs b/src/Music/Time/Segment.hs --- a/src/Music/Time/Segment.hs +++ b/src/Music/Time/Segment.hs @@ -1,20 +1,14 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} {-# 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 #-} ------------------------------------------------------------------------------------- @@ -100,11 +94,11 @@ import Music.Time.Behavior import Music.Time.Bound -import Music.Time.Note +import Music.Time.Event import Music.Time.Reverse import Music.Time.Score import Music.Time.Split -import Music.Time.Stretched +import Music.Time.Note import Music.Time.Voice import Control.Applicative @@ -127,9 +121,9 @@ -- A 'Segment' is a value varying over some unknown time span. -- Intuitively, a 'Segment' is to a 'Behavior' what a /ray/ is to a /line/. -- --- To give a segment an explicit duration, use 'Stretched' 'Segment'. +-- To give a segment an explicit duration, use 'Event' 'Segment'. -- --- To place a segment in a particular time span, use 'Note' 'Segment'. +-- To place a segment in a particular time span, use 'Event' 'Segment'. -- newtype Segment a = Segment { getSegment :: Clipped Duration -> a } deriving (Functor, Applicative, Monad{-, Comonad-}, Typeable) @@ -143,9 +137,9 @@ -- $musicTimeSegmentExamples -- --- > foldr1 apSegments' $ map (view stretched) $ [(0.5,0::Segment Float), (1, timeS), (2,rev timeS), (3,-1)] +-- > foldr1 apSegments' $ map (view note) $ [(0.5,0::Segment Float), (1, timeS), (2,rev timeS), (3,-1)] -- --- > openG $ draw $ (1, timeS :: Segment Float)^.stretched +-- > openG $ draw $ (1, timeS :: Segment Float)^.note -- instance Show (Segment a) where @@ -207,7 +201,6 @@ -- 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) @@ -235,7 +228,6 @@ -- (<) = error "No fun" -- max = liftA2 max -- min = liftA2 min --- #endif -- | -- View a segment as a time function and vice versa. @@ -243,15 +235,15 @@ segment :: Iso (Duration -> a) (Duration -> b) (Segment a) (Segment b) segment = R.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) +apSegments' :: Note (Segment a) -> Note (Segment a) -> Note (Segment a) +apSegments' (view (from note) -> (d1,s1)) (view (from note) -> (d2,s2)) + = view note (d1+d2, slerp (d1/(d1+d2)) s1 s2) -- | --- Append a voice of segments to a single stretched segment. +-- Append a voice of segments to a single note segment. -- -apSegments :: Voice (Segment a) -> Stretched (Segment a) -apSegments = foldr1 apSegments' . toListOf (stretcheds . each) +apSegments :: Voice (Segment a) -> Note (Segment a) +apSegments = foldr1 apSegments' . toListOf (notes . each) -- t < i && 0 <= t <= 1 ==> 0 < (t/i) < 1 -- i is the fraction of the slerped segment spent in a @@ -271,30 +263,30 @@ -- | --- View a 'Note' 'Segment' as a 'Bound' 'Behavior' and vice versa. +-- View a 'Event' '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' :: Iso' (Event (Segment a)) (Bound (Behavior a)) bounded' = bounded -- | --- View a 'Note' 'Segment' as a 'Bound' 'Behavior' and vice versa. +-- View a 'Event' '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 (Event (Segment a)) (Event (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) + bb2ns (Bound (s, x)) = view event (s, b2s $ transform (negateV s) $ x) + ns2bb (view (from event) -> (s, x)) = Bound (s, transform s $ s2b $ x) s2b = under R.tabulated (. realToFrac) b2s = under R.tabulated (. realToFrac) -- --- Note that the isomorhism only works because of 'Bound' being abstract. +-- Event that the isomorhism only works because of 'Bound' being abstract. -- A function @unBound :: Bound a -> a@ could break the isomorphism -- as follows: -- @@ -336,7 +328,7 @@ -- fromJust is safe here, as toLast is used to create the Maybe wrapper -concatSegment :: Monoid a => Note (Segment a) -> Behavior a +concatSegment :: Monoid a => Event (Segment a) -> Behavior a concatSegment = trim . view bounded -- | @@ -345,8 +337,8 @@ -- 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) +concatS = mconcat . map concatSegment . view events +-- Or: mconcat.fmap trim.toListOf (events.each.bounded) -- | -- Concatenate a score of (possibly overlapping) segments. @@ -355,7 +347,7 @@ -- concatB :: Monoid a => Score (Behavior a) -> Behavior a concatB = concatS . fmap (view focusing) --- Or (more generally): mconcat.toListOf (notes.each.noteValue) +-- Or (more generally): mconcat.toListOf (events.each.eventee) -- | @@ -368,8 +360,6 @@ focusing :: Lens' (Behavior a) (Segment a) focusing = lens get set where - get = view (from bounded . noteValue) . {-pure-}bounding mempty + get = view (from bounded . eventee) . {-pure-}bounding mempty set x = splice x . (view bounded) . pure - --- JUNK diff --git a/src/Music/Time/Split.hs b/src/Music/Time/Split.hs --- a/src/Music/Time/Split.hs +++ b/src/Music/Time/Split.hs @@ -1,20 +1,14 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} {-# 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 #-} ------------------------------------------------------------------------------------- diff --git a/src/Music/Time/Stretched.hs b/src/Music/Time/Stretched.hs deleted file mode 100644 --- a/src/Music/Time/Stretched.hs +++ /dev/null @@ -1,156 +0,0 @@ - -{-# 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 type - Stretched, - - -- * Construction - stretched, - stretchedValue, - ) where - -import Data.AffineSpace -import Data.AffineSpace.Point -import Data.Bifunctor -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.String -import Data.Functor.Couple - -import Control.Applicative -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 -import Music.Time.Reverse -import Music.Time.Split - - --- | --- A 'Stretched' value has a known 'duration', but no 'position'. --- --- Placing a value inside 'Stretched' makes it invariant under 'delay', however the inner --- value can still be delayed using @'fmap' 'delay'@. --- -newtype Stretched a = Stretched { _stretchedValue :: Couple Duration a } - deriving (Applicative, Monad, {-Comonad, -} - Functor, Foldable, Traversable) - --- $semantics Stretched --- --- @ --- type Stretched = (Duration, a) --- @ --- - --- >>> stretch 2 $ (5,1)^.stretched --- (10,1)^.stretched --- --- >>> delay 2 $ (5,1)^.stretched --- (5,1)^.stretched --- - -deriving instance Eq a => Eq (Stretched a) -deriving instance Num a => Num (Stretched a) -deriving instance Fractional a => Fractional (Stretched a) -deriving instance Floating a => Floating (Stretched a) -deriving instance Ord a => Ord (Stretched a) -deriving instance Real a => Real (Stretched a) -deriving instance RealFrac a => RealFrac (Stretched a) - -deriving instance Typeable1 Stretched - -instance Wrapped (Stretched a) where - type Unwrapped (Stretched a) = (Duration, a) - _Wrapped' = iso (getCouple . _stretchedValue) (Stretched . Couple) - -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) - -instance (Show a, Transformable a) => Show (Stretched a) where - show x = show (x^.from stretched) ++ "^.stretched" - --- Lifted instances - -instance IsString a => IsString (Stretched a) where - fromString = pure . fromString - -instance IsPitch a => IsPitch (Stretched a) where - fromPitch = pure . fromPitch - -instance IsInterval a => IsInterval (Stretched a) where - fromInterval = pure . fromInterval - -instance IsDynamics a => IsDynamics (Stretched a) where - fromDynamics = pure . fromDynamics - --- | --- View a stretched value as a pair of the original value and a stretch factor. --- -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 (Couple (d, x))) = Stretched (Couple (d, f `whilst` stretching d $ x)) - runStretched = uncurry stretch . view _Wrapped -{-# INLINE stretchedValue #-} - diff --git a/src/Music/Time/Track.hs b/src/Music/Time/Track.hs --- a/src/Music/Time/Track.hs +++ b/src/Music/Time/Track.hs @@ -1,20 +1,15 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} {-# 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 #-} ------------------------------------------------------------------------------------- -- | @@ -36,8 +31,7 @@ -- * Construction track, - delayeds, - singleDelayed, + placeds, ) where @@ -52,7 +46,7 @@ import qualified Data.Set as Set import Data.VectorSpace -import Music.Time.Delayed +import Music.Time.Placed import Music.Time.Reverse import Music.Time.Split @@ -72,14 +66,15 @@ -- | -- A 'Track' is a parallel composition of values. +newtype Track a = Track { getTrack :: TrackList (TrackEv a) } + deriving (Functor, Foldable, Traversable, Semigroup, Monoid, Typeable, Show, Eq) +-- {-# DEPRECATED Track "Use 'Chord'" #-} + -- -- @ --- type Track a = [Delayed a] +-- type Track a = [Placed a] -- @ -- -newtype Track a = Track { getTrack :: TrackList (TrackEv a) } - deriving (Functor, Foldable, Traversable, Semigroup, Monoid, Typeable, Show, Eq) --- {-# DEPRECATED Track "Use 'Chord'" #-} -- A track is a list of events with explicit onset. -- @@ -96,9 +91,9 @@ type TrackList = [] -- Can use any type as long as trackEv provides an Iso -type TrackEv a = Delayed a +type TrackEv a = Placed a -trackEv :: Iso (Delayed a) (Delayed b) (TrackEv a) (TrackEv b) +trackEv :: Iso (Placed a) (Placed b) (TrackEv a) (TrackEv b) trackEv = id instance Applicative Track where @@ -119,45 +114,26 @@ instance Rewrapped (Track a) (Track b) -instance Transformable (Track a) where +instance Transformable a => Transformable (Track a) where transform s = over _Wrapped' (transform s) -instance HasPosition (Track a) where - _onset = safeMinimum . fmap _onset . view _Wrapped' - _offset = safeMaximum . fmap _offset . view _Wrapped' - --- TODO move -safeMinimum xs = if null xs then 0 else minimum xs -safeMaximum xs = if null xs then 0 else maximum xs - -instance HasDuration (Track a) where - _duration x = _offset x .-. _onset x - -instance Splittable a => Splittable (Track a) where - -- TODO +-- instance Splittable a => Splittable (Track a) where +-- -- TODO -instance Reversible a => Reversible (Track a) where - -- TODO +-- instance Reversible a => Reversible (Track a) where +-- -- TODO --- | --- Create a track from a list of notes. --- --- Se also 'delayeds'. --- -track :: Getter [Delayed a] (Track a) +-- | Create a track from a list of notes. +track :: Getter [Placed a] (Track a) track = from unsafeTrack {-# INLINE track #-} -delayeds :: Lens (Track a) (Track b) [Delayed a] [Delayed b] -delayeds = unsafeTrack -{-# INLINE delayeds #-} - -singleDelayed :: Prism' (Track a) (Delayed a) -singleDelayed = unsafeTrack . single -{-# INLINE singleDelayed #-} +placeds :: Lens (Track a) (Track b) [Placed a] [Placed b] +placeds = unsafeTrack +{-# INLINE placeds #-} -unsafeTrack :: Iso (Track a) (Track b) [Delayed a] [Delayed b] +unsafeTrack :: Iso (Track a) (Track b) [Placed a] [Placed b] unsafeTrack = _Wrapped {-# INLINE unsafeTrack #-} diff --git a/src/Music/Time/Transform.hs b/src/Music/Time/Transform.hs --- a/src/Music/Time/Transform.hs +++ b/src/Music/Time/Transform.hs @@ -34,12 +34,7 @@ -- * The Transformable class Transformable(..), - itransform, transformed, - whilst, - spanned, - onSpan, - conjugateS, -- * Specific transformations -- ** Transformations @@ -53,7 +48,6 @@ undelay, stretch, compress, - delayTime, ) where diff --git a/src/Music/Time/Types.hs b/src/Music/Time/Types.hs --- a/src/Music/Time/Types.hs +++ b/src/Music/Time/Types.hs @@ -33,62 +33,59 @@ module Music.Time.Types ( -- * Basic types - -- ** Time points Time, - toTime, - fromTime, - - -- ** Duration Duration, - toDuration, - fromDuration, + LocalDuration, -- ** Convert between time and duration -- $convert offsetPoints, + pointOffsets, toAbsoluteTime, toRelativeTime, toRelativeTimeN, - toRelativeTimeN', + toRelativeTimeN', -- TODO Fairbairn threshold -- * Time spans Span, - -- *** Creating spans + + -- ** Constructing spans (<->), (>->), (<-<), - -- *** Accessing spans - range, + delta, + range, codelta, - -- ** Properties - -- $forwardBackWardEmpty - isForwardSpan, - isBackwardSpan, - isEmptySpan, + stretchComponent, + delayComponent, + fixedDurationSpan, + fixedOnsetSpan, -- ** Transformations + normalizeSpan, reverseSpan, reflectSpan, - normalizeSpan, - -- ** Delay and stretch component - delayComponent, - stretchComponent, - fixedOnsetSpan, - fixedDurationSpan, + -- ** Properties + isEmptySpan, + isForwardSpan, + isBackwardSpan, + -- delayComponent, + -- stretchComponent, + -- ** Points in spans inside, -- ** Partial orders - isProper, - isBefore, encloses, properlyEncloses, overlaps, - + + -- *** etc. + isBefore, afterOnset, strictlyAfterOnset, beforeOnset, @@ -122,13 +119,10 @@ import Control.Lens hiding (Indexable, Level, above, below, index, inside, parts, reversed, transform, (<|), (|>)) --- import Control.Applicative.Backwards import Control.Monad.State.Lazy --- import Data.Aeson (ToJSON(..)) import qualified Data.Aeson as JSON - import Data.AffineSpace import Data.AffineSpace.Point import Data.Semigroup @@ -136,7 +130,6 @@ import Data.VectorSpace import Data.List (mapAccumL, mapAccumR) import Data.Ratio - import Music.Time.Internal.Util (showRatio) -- import Data.Fixed @@ -152,7 +145,7 @@ -- for 'Fractional' and 'RealFrac'. -- type TimeBase = Rational --- type TimeBase = Fixed E12 + {- type TimeBase = Fixed E12 @@ -161,39 +154,50 @@ negateV = negate (^+^) = (+) --- Can be enabled for experimental time representation instance Floating TimeBase where deriving instance Floating Time deriving instance Floating Duration -} +type LocalDuration = 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. -- +newtype Duration = Duration { getDuration :: TimeBase } + deriving ( + Eq, + Ord, + Typeable, + Enum, + + Num, + Fractional, + Real, + RealFrac + ) + -- 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. -- -newtype Duration = Duration { getDuration :: TimeBase } - deriving (Eq, Ord, Num, Enum, Fractional, Real, RealFrac, Typeable) --- $semantics Duration --- --- type Duration = R --- - instance Show Duration where - show = showRatio . realToFrac + show = showRatio . toRational instance ToJSON Duration where toJSON = JSON.Number . realToFrac -instance InnerSpace Duration where - (<.>) = (*) +instance Semigroup Duration where + (<>) = (*^) +instance Monoid Duration where + mempty = 1 + mappend = (*^) + instance AdditiveGroup Duration where zeroV = 0 (^+^) = (+) @@ -203,177 +207,136 @@ type Scalar Duration = Duration (*^) = (*) -instance Semigroup Duration where - (<>) = (*^) +instance InnerSpace Duration where + (<.>) = (*) -instance Monoid Duration where - mempty = 1 - mappend = (*^) - -- TODO use some notion of norm rather than 1 --- | --- Convert a value to a duration. +-- | 'Time' represents points in time space. The difference between two time points +-- is a 'Duration', for example in a bar of duration 4/4 (that is 1), the difference +-- between the first and third beat 1/2. -- -toDuration :: Real a => a -> Duration -toDuration = realToFrac - --- | --- Convert a value to a duration. +-- Time has an origin (zero) which usually represents the beginning of the musical +-- performance, but this may not always be the case, as the modelled music may be +-- infinite, or contain a musical pickup. Hence 'Time' values can be negative. -- -fromDuration :: Fractional a => Duration -> a -fromDuration = realToFrac +newtype Time = Time { getTime :: TimeBase } + deriving ( + Eq, + Ord, + Typeable, + Enum, + Num, + Fractional, + Real, + RealFrac + ) --- | --- 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. --- -newtype Time = Time { getTime :: TimeBase } - deriving (Eq, Ord, Num, Enum, Fractional, Real, RealFrac, Typeable) --- $semantics Time --- --- type Time = R --- - instance Show Time where - show = showRatio . realToFrac + show = showRatio . toRational instance ToJSON Time where toJSON = JSON.Number . 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 + mempty = 0 + mappend = (+) --- | --- Convert a value to a duration. --- -toTime :: Real a => a -> Time -toTime = realToFrac +instance AdditiveGroup Time where + zeroV = 0 + (^+^) = (+) + negateV = negate --- | --- Convert a value to a duration. --- -fromTime :: Fractional a => Time -> a -fromTime = realToFrac +instance VectorSpace Time where + type Scalar Time = LocalDuration + Duration x *^ Time y = Time (x * y) +instance AffineSpace Time where + type Diff Time = LocalDuration + Time x .-. Time y = Duration (x - y) + Time x .+^ Duration y = Time (x + y) +-- | Lay out a series of vectors from a given point. Return all intermediate points. +-- +-- > lenght xs + 1 == length (offsetPoints p xs) +-- +-- >>> offsetPoints 0 [1,1,1] :: [Time] +-- [0,1,2,3] +offsetPoints :: AffineSpace p => p -> [Diff p] -> [p] +offsetPoints = scanl (.+^) --- TODO terminology --- Return the "accumulative sum" of the given vecors +-- | Calculate the relative difference between vectors. +-- +-- > lenght xs + 1 == length (offsetPoints p xs) +-- +-- >>> offsetPoints 0 [1,1,1] :: [Time] +-- [0,1,2,3] +pointOffsets :: AffineSpace p => p -> [p] -> [Diff p] +pointOffsets or = (zeroV :) . snd . mapAccumL g or + where + g prev p = (p, p .-. prev) --- | --- @length (offsetPoints x xs) = length xs + 1@ +-- | Interpret as durations from 0. -- --- >>> offsetPoints (0 ::Double) [1,2,1] --- [0.0,1.0,3.0,4.0] +-- > toAbsoluteTime (toRelativeTime xs) == xs -- --- @ --- offsetPoints :: 'AffineSpace' a => 'Time' -> ['Duration'] -> ['Time'] --- @ +-- > lenght xs == length (toRelativeTime xs) -- -offsetPoints :: AffineSpace a => a -> [Diff a] -> [a] -offsetPoints = scanl (.+^) - --- | Convert to delta (time to wait before this note) -toRelativeTime :: [Time] -> [Duration] -toRelativeTime = snd . mapAccumL g 0 where g prev t = (t, t .-. prev) --- toRelativeTime xs = fst $ mapAccumL2 g xs 0 where g t prev = (t .-. prev, t) - --- | Convert to delta (time to wait before next note) -toRelativeTimeN :: [Time] -> [Duration] -toRelativeTimeN [] = [] -toRelativeTimeN xs = toRelativeTimeN' (last xs) xs - --- | Convert to delta (time to wait before next note) -toRelativeTimeN' :: Time -> [Time] -> [Duration] -toRelativeTimeN' end xs = snd $ mapAccumR g end xs where g prev t = (t, prev .-. t) - -{- -TODO consolidate with this beat (used in Midi export) - -toRelative = snd . List.mapAccumL g 0 - where - g now (t,d,x) = (t, (0 .+^ (t .-. now),d,x)) - --} --- 0 x,1 x,1 x,1 x - -- x 1,x 1,x 1,x 0 - --- | Convert from delta (time to wait before this note) +-- >>> toAbsoluteTime [1,1,1] :: [Time] +-- [1,2,3] toAbsoluteTime :: [Duration] -> [Time] toAbsoluteTime = tail . offsetPoints 0 - - - --- TODO use State instead - --- mapAccumL :: (s -> a -> (s, b)) -> s -> [a] -> (s, [b]) --- \f -> mapM (runState . f) :: MonadState s m => (a -> s -> (b, s)) -> [a] -> s -> ([b], s) - --- mapAccumL :: (s -> a -> (s, b)) -> s -> [a] -> (s, [b]) -mapAccumL2 :: (a -> s -> (b, s)) -> [a] -> s -> ([b], s) -mapAccumL2 f = runState . mapM (state . f) - +-- | Duration between 0 and first value and so on until the last. +-- +-- > toAbsoluteTime (toRelativeTime xs) == xs +-- +-- > lenght xs == length (toRelativeTime xs) +-- +-- >>> toRelativeTime [1,2,3] +-- [1,1,1] +toRelativeTime :: [Time] -> [Duration] +toRelativeTime = tail . pointOffsets 0 +-- TODO rename these two... +-- | Duration between values until the last, then up to the given final value. +-- > lenght xs == length (toRelativeTime xs) +toRelativeTimeN' :: Time -> [Time] -> [Duration] +toRelativeTimeN' or = snd . Data.List.mapAccumR g or + where + g prev p = (p, prev .-. p) +-- Same as toRelativeTimeN' but always returns 0 as the last value... +-- TODO remove +toRelativeTimeN :: [Time] -> [Duration] +toRelativeTimeN [] = [] +toRelativeTimeN xs = toRelativeTimeN' (last xs) xs -- | --- 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' -> (t1, d)) = ... --- foo ('view' 'codelta' -> (d, t2)) = ... --- @ +-- A 'Span' represents a specific time interval, such as the duration of +-- a note, phrase or musical piece. It can be modelled as two points, or as +-- a point and a vector. -- -- Another way of looking at 'Span' is that it represents a time transformation where -- onset is translation and duration is scaling. -- --- TODO How to use with 'transform', 'whilst' etc. --- --- @ --- a '<->' b = (a, b)^.'from' 'range' --- a '>->' b = (a, b)^.'from' 'delta' --- a '<-<' b = (a, b)^.'from' 'codelta' --- @ --- -newtype Span = Delta { _delta :: (Time, Duration) } - deriving (Eq, Ord, Typeable) - --- $semantics --- --- type Span = Time x Time --- +newtype Span = Span { getSpan :: (Time, Duration) } + deriving ( + Eq, + Ord, + Typeable + ) -- You can create a span using the constructors '<->', '<-<' and '>->'. Note that: -- @@ -407,37 +370,28 @@ -- instance Show Span where - -- show = showDelta show = showRange -- Which form should we use? instance ToJSON Span where toJSON (view range -> (a,b)) = JSON.object [ ("onset", toJSON a), ("offset", toJSON b) ] - --- | --- 'zeroV' or 'mempty' represents the /unit interval/ @0 \<-\> 1@, which also happens to --- be the identity transformation. --- 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) + zeroV = 0 <-> 1 + Span (t1, d1) ^+^ Span (t2, d2) = Span (t1 ^+^ d1 *^ t2, d1*d2) + negateV (Span (t, d)) = Span (-t ^/ d, recip d) +instance VectorSpace Span where + type Scalar Span = Duration + x *^ Span (t, d) = Span (x*^t, x*^d) + -- -- a >-> b = a <-> (a .+^ b) -- a <-< b = (b .-^ a) <-> b @@ -459,7 +413,7 @@ -- @t >-> d@ represents the span between @t@ and @t .+^ d@. -- (>->) :: Time -> Duration -> Span -(>->) = curry Delta +(>->) = curry Span -- | -- @d \<-\> t@ represents the span between @t .-^ d@ and @t@. @@ -472,23 +426,20 @@ -- 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) +range = iso (\x -> let (t, d) = getSpan x in (t, t .+^ d)) (uncurry (<->)) -- | -- View a span as a pair of onset and duration. -- + delta :: Iso' Span (Time, Duration) -delta = iso _delta Delta +delta = iso getSpan Span -- | -- View a span as a pair of duration and offset. -- codelta :: Iso' Span (Duration, Time) -codelta = iso _codelta $ uncurry (<-<) - where - _codelta x = let (t, d) = _delta x in (d, t .+^ d) +codelta = iso (\x -> let (t, d) = getSpan x in (d, t .+^ d)) (uncurry (<-<)) -- | -- Show a span in range notation, i.e. @t1 \<-\> t2@. @@ -786,8 +737,5 @@ a + b = a + b -} --- TODO move -fraction :: (RealFrac a, Integral b) => Iso' a (b, b) -fraction = iso (\(toRational -> a) -> (fromIntegral $ numerator a, fromIntegral $ denominator a)) (\(a,b) -> fromIntegral a / fromIntegral b) diff --git a/src/Music/Time/Voice.hs b/src/Music/Time/Voice.hs --- a/src/Music/Time/Voice.hs +++ b/src/Music/Time/Voice.hs @@ -1,20 +1,15 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} {-# 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 #-} ------------------------------------------------------------------------------------- @@ -36,30 +31,20 @@ -- * Construction voice, - - -- ** Extracting values - stretcheds, - eventsV, - singleStretched, - - -- * Fusion - fuse, - fuseBy, - - -- ** Fuse rests - fuseRests, - coverRests, + notes, + pairs, + durationsVoice, -- * Traversal -- ** Separating rhythms and values valuesV, durationsV, - withValues, - withDurations, - rotateValues, - rotateDurations, - reverseValues, - reverseDurations, + -- withValues, + -- withDurations, + -- rotateValues, + -- rotateDurations, + -- reverseValues, + -- reverseDurations, -- ** Zips unzipVoice, @@ -74,16 +59,34 @@ zipVoiceWith', zipVoiceWithNoScale, + -- * Fusion + fuse, + fuseBy, + + -- ** Fuse rests + fuseRests, + coverRests, + + -- * Homophonic/Polyphonic texture + sameDurations, + mergeIfSameDuration, + mergeIfSameDurationWith, + homoToPolyphonic, + + -- * Points in a voice + onsetsRelative, + offsetsRelative, + midpointsRelative, + erasRelative, + -- * Context + -- TODO clean withContext, - voiceLens, - -- voiceL, - voiceAsList, - listAsVoice, + -- voiceLens, -- * Unsafe versions - unsafeStretcheds, - unsafeEventsV, + unsafeNotes, + unsafePairs, ) where @@ -105,7 +108,7 @@ import Music.Time.Reverse import Music.Time.Split -import Music.Time.Stretched +import Music.Time.Note import Control.Applicative import Control.Lens hiding (Indexable, Level, above, @@ -126,23 +129,37 @@ import Music.Time.Internal.Util -- | --- A 'Voice' is a sequential composition of values. Events may not overlap. +-- A 'Voice' is a sequential composition of non-overlapping note values. -- -newtype Voice a = Voice { getVoice :: VoiceList (VoiceEv a) } - deriving (Functor, Foldable, Traversable, Semigroup, Monoid, Typeable, Eq) - -instance (Show a, Transformable a) => Show (Voice a) where - show x = show (x^.stretcheds) ++ "^.voice" - +-- Both 'Voice' and 'Note' have duration but no position. The difference +-- is that 'Note' sustains a single value throughout its duration, while +-- a voice may contain multiple values. It is called voice because it is +-- generalizes the notation of a voice in choral or multi-part instrumental music. -- --- $semantics Voice --- type Voice a = [Stretched a] +-- It may be useful to think about 'Voice' and 'Note' as vectors in time space +-- (i.e. 'Duration'), that also happens to carry around other values, such as pitches. -- +newtype Voice a = Voice { getVoice :: [Note a] } + deriving ( + Eq, + Ord, + Typeable, + Foldable, + Traversable, + Functor, + Semigroup, + Monoid + ) + +instance (Show a, Transformable a) => Show (Voice a) where + show x = show (x^.notes) ++ "^.voice" + -- 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 @@ -150,20 +167,6 @@ -- 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 --- type VoiceEv a = ((),Stretched a) - -voiceEv :: Iso (Stretched a) (Stretched b) (VoiceEv a) (VoiceEv b) -voiceEv = id --- voiceEv = iso add remove --- where --- add x = ((),x) --- remove ((),x) = x - instance Applicative Voice where pure = return (<*>) = ap @@ -181,40 +184,37 @@ mplus = mappend instance Wrapped (Voice a) where - type Unwrapped (Voice a) = (VoiceList (VoiceEv a)) + type Unwrapped (Voice a) = [Note a] _Wrapped' = iso getVoice Voice instance Rewrapped (Voice a) (Voice b) -instance Cons (Voice a) (Voice b) (Stretched a) (Stretched b) where - _Cons = prism (\(s,v) -> (view voice.return $ s) <> v) $ \v -> case view stretcheds v of +instance Cons (Voice a) (Voice b) (Note a) (Note b) where + _Cons = prism (\(s,v) -> (view voice.return $ s) <> v) $ \v -> case view notes v of [] -> Left mempty (x:xs) -> Right (x, view voice xs) -instance Snoc (Voice a) (Voice b) (Stretched a) (Stretched b) where - _Snoc = prism (\(v,s) -> v <> (view voice.return $ s)) $ \v -> case unsnoc (view stretcheds v) of +instance Snoc (Voice a) (Voice b) (Note a) (Note b) where + _Snoc = prism (\(v,s) -> v <> (view voice.return $ s)) $ \v -> case unsnoc (view notes v) of Nothing -> Left mempty Just (xs, x) -> Right (view voice xs, x) instance Transformable (Voice a) where - transform s = over _Wrapped' (transform s) + transform s = over notes (transform s) instance HasDuration (Voice a) where - _duration = Foldable.sum . fmap _duration . view _Wrapped' - -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" + _duration = sumOf (notes . each . duration) instance Reversible a => Reversible (Voice a) where - rev = over _Wrapped' (fmap rev) -- TODO OK? - + rev = over notes reverse . fmap rev --- Lifted instances +-- 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" instance IsString a => IsString (Voice a) where fromString = pure . fromString @@ -238,101 +238,77 @@ 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" + zeroV = mempty + (^+^) = (<>) + negateV = error "Not implemented" -- TODO negate durations 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 +-- | Create a 'Voice' from a list of 'Note's. +voice :: Getter [Note a] (Voice a) +voice = from unsafeNotes {-# INLINE voice #-} --- | --- View a 'Voice' as a list of 'Stretched' values. +-- | View a 'Voice' as a list of 'Note' values. +notes :: Lens (Voice a) (Voice b) [Note a] [Note b] +notes = unsafeNotes + -- -- @ --- 'view' 'stretcheds' :: 'Voice' a -> ['Stretched' a] --- 'set' 'stretcheds' :: ['Stretched' a] -> 'Voice' a -> 'Voice' a --- 'over' 'stretcheds' :: (['Stretched' a] -> ['Stretched' b]) -> 'Voice' a -> 'Voice' b +-- 'view' 'notes' :: 'Voice' a -> ['Note' a] +-- 'set' 'notes' :: ['Note' a] -> 'Voice' a -> 'Voice' a +-- 'over' 'notes' :: (['Note' a] -> ['Note' 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) +-- 'preview' ('notes' . 'each') :: 'Voice' a -> 'Maybe' ('Note' a) +-- 'preview' ('notes' . 'element' 1) :: 'Voice' a -> 'Maybe' ('Note' a) +-- 'preview' ('notes' . 'elements' odd) :: 'Voice' a -> 'Maybe' ('Note' 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 +-- 'set' ('notes' . 'each') :: 'Note' a -> 'Voice' a -> 'Voice' a +-- 'set' ('notes' . 'element' 1) :: 'Note' a -> 'Voice' a -> 'Voice' a +-- 'set' ('notes' . 'elements' odd) :: 'Note' 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 +-- 'over' ('notes' . 'each') :: ('Note' a -> 'Note' b) -> 'Voice' a -> 'Voice' b +-- 'over' ('notes' . 'element' 1) :: ('Note' a -> 'Note' a) -> 'Voice' a -> 'Voice' a +-- 'over' ('notes' . 'elements' odd) :: ('Note' a -> 'Note' 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] +-- 'toListOf' ('notes' . 'each') :: 'Voice' a -> ['Note' a] +-- 'toListOf' ('notes' . 'elements' odd) :: 'Voice' a -> ['Note' a] +-- 'toListOf' ('notes' . 'each' . 'filtered' +-- (\\x -> '_duration' x \< 2)) :: 'Voice' 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' '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 #-} +-- | View a score as a list of duration-value pairs. Analogous to 'triples'. +pairs :: Lens (Voice a) (Voice b) [(Duration, a)] [(Duration, b)] +pairs = unsafePairs -unsafeStretcheds :: Iso (Voice a) (Voice b) [Stretched a] [Stretched b] -unsafeStretcheds = _Wrapped -{-# INLINE unsafeStretcheds #-} +-- | A voice is a list of notes up to meta-data. To preserve meta-data, use the more +-- restricted 'voice' and 'notes'. +unsafeNotes :: Iso (Voice a) (Voice b) [Note a] [Note b] +unsafeNotes = _Wrapped -singleStretched :: Prism' (Voice a) (Stretched a) -singleStretched = unsafeStretcheds . single -{-# INLINE singleStretched #-} -{-# DEPRECATED singleStretched "Use 'unsafeStretcheds . single'" #-} +-- | A score is a list of (duration-value pairs) up to meta-data. +-- To preserve meta-data, use the more restricted 'pairs'. +unsafePairs :: Iso (Voice a) (Voice b) [(Duration, a)] [(Duration, b)] +unsafePairs = iso (map (^.from note) . (^.notes)) ((^.voice) . map (^.note)) +durationsVoice :: Iso' [Duration] (Voice ()) +durationsVoice = iso (mconcat . fmap (\d -> stretch d $ pure ())) (^. durationsV) -- | -- Unzip the given voice. This is specialization of 'unzipR'. @@ -406,12 +382,16 @@ -- 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)) + ((unzip.view pairs) -> (ad, as)) + ((unzip.view pairs) -> (bd, bs)) = let cd = zipWith f ad bd cs = zipWith g as bs - in view (from unsafeEventsV) (zip cd cs) + in view (from unsafePairs) (zip cd cs) + +-- TODO generalize these to use a Monoidal interface, rather than ([a] -> a) +-- The use of head (see below) if of course the First monoid + -- | -- Merge consecutive equal notes. -- @@ -419,7 +399,7 @@ fuse = fuseBy (==) -- | --- Merge consecutive equal notes using the given function. +-- Merge consecutive notes deemed equal by the given predicate. -- fuseBy :: (a -> a -> Bool) -> Voice a -> Voice a fuseBy p = fuseBy' p head @@ -428,7 +408,7 @@ -- 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) +fuseBy' p g = over unsafePairs $ fmap foldNotes . Data.List.groupBy (inspectingBy snd p) where -- Add up durations and use a custom function to combine notes -- @@ -447,7 +427,7 @@ -- if and only if the given voice contains rests only. -- coverRests :: Voice (Maybe a) -> Maybe (Voice a) -coverRests x = if hasOnlyRests then Nothing else Just (fmap fromJust $ fuseBy merge x) +coverRests x = if hasOnlyRests then Nothing else Just (fmap fromJust $ fuseBy merge x) where norm = fuseRests x merge Nothing Nothing = error "Voice normalized, so consecutive rests are impossible" @@ -456,151 +436,66 @@ merge (Just x) (Just y) = False hasOnlyRests = all isNothing $ toListOf traverse x -- norm - +-- | Decorate all notes in a voice with their context, i.e. previous and following value +-- if present. withContext :: Voice a -> Voice (Ctxt a) -withContext = over valuesV (fmap Ctxt . withPrevNext) - --- TODO expose? -voiceFromRhythm :: [Duration] -> Voice () -voiceFromRhythm = mkVoice . fmap (, ()) - -mkVoice = view voice . fmap (view stretched) +withContext = over valuesV addCtxt --- --- TODO more elegant definition of durationsV and valuesV using indexed traversal or similar? --- +-- TODO more elegant definition? +-- | A lens to the durations in a voice. durationsV :: Lens' (Voice a) [Duration] durationsV = lens getDurs (flip setDurs) where getDurs :: Voice a -> [Duration] - getDurs = map fst . view eventsV + getDurs = map fst . view pairs 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 () +-- | A lens to the values in a voice. valuesV :: Lens (Voice a) (Voice b) [a] [b] valuesV = lens getValues (flip setValues) where - getValues :: Voice a -> [a] - getValues = map snd . view eventsV + -- getValues :: Voice a -> [a] + getValues = map snd . view pairs - setValues :: [a] -> Voice b -> Voice a + -- 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 - -- Lens "filtered" through a voice voiceLens :: (s -> a) -> (b -> s -> t) -> Lens (Voice s) (Voice t) (Voice a) (Voice b) voiceLens getter setter = lens (fmap getter) (flip $ zipVoiceWithNoScale setter) - --- TODO generalize to any zippable thing --- voiceL :: ALens s t a b -> Lens (Voice s) (Voice t) (Voice a) (Voice b) -voiceL l = voiceLens (view $ cloneLens l) (set $ cloneLens l) - - --- TODO not meta-safe -voiceAsList :: Iso (Voice a) (Voice b) [a] [b] -voiceAsList = iso voiceToList listToVoice - where - voiceToList = map snd . view eventsV - listToVoice = mconcat . fmap pure - -listAsVoice :: Iso [a] [b] (Voice a) (Voice b) -listAsVoice = from voiceAsList - - --- --- TODO --- Implement meta-data --- - --- List functions -headV, lastV :: Voice a -> Maybe (Stretched a) -headV = preview _head -lastV = preview _head - -tailV, initV :: Voice a -> Maybe (Voice a) -tailV = preview _tail -initV = preview _init - -consV :: Stretched a -> Voice a -> Voice a -unconsV :: Voice a -> Maybe (Stretched a, Voice a) -consV = cons -unconsV = uncons - -snocV :: Voice a -> Stretched a -> Voice a -unsnocV :: Voice a -> Maybe (Voice a, Stretched a) -snocV = snoc -unsnocV = unsnoc - -nullV :: Voice a -> Bool -nullV = nullOf eventsV - -lengthV :: Voice a -> Int -lengthV = lengthOf eventsV - -mapV :: (a -> b) -> Voice a -> Voice b -mapV = fmap - - --- Voice-specific +-- TODO could also use (zipVoiceWith' max) or (zipVoiceWith' min) +-- | Whether two notes have exactly the same duration pattern. +-- Two empty voices are considered to have the same duration pattern. +-- Voices with an non-equal number of notes differ by default. sameDurations :: Voice a -> Voice b -> Bool sameDurations a b = view durationsV a == view durationsV b +-- | Pair the values of two voices if and only if they have the same duration +-- pattern (as per 'sameDurations'). mergeIfSameDuration :: Voice a -> Voice b -> Maybe (Voice (a, b)) mergeIfSameDuration = mergeIfSameDurationWith (,) +-- | Combine the values of two voices using the given function if and only if they +-- have the same duration pattern (as per 'sameDurations'). mergeIfSameDurationWith :: (a -> b -> c) -> Voice a -> Voice b -> Maybe (Voice c) mergeIfSameDurationWith f a b | sameDurations a b = Just $ zipVoiceWithNoScale f a b | otherwise = Nothing - --- splitAt :: [Duration] -> Voice a -> [Voice a] --- splitTiesVoiceAt :: Tiable a => [Duration] -> Voice a -> [Voice a] +-- TODO could also use (zipVoiceWith' max) or (zipVoiceWith' min) -- | -- Split all notes of the latter voice at the onset/offset of the former. -- --- >>> ["a",(2,"b")^.stretched,"c"]^.voice --- [(1,"a")^.stretched,(2,"b")^.stretched,(1,"c")^.stretched]^.voice +-- >>> ["a",(2,"b")^.note,"c"]^.voice +-- [(1,"a")^.note,(2,"b")^.note,(1,"c")^.note]^.voice -- splitLatterToAssureSameDuration :: Voice b -> Voice b -> Voice b splitLatterToAssureSameDuration = splitLatterToAssureSameDurationWith dup @@ -616,8 +511,15 @@ polyToHomophonicForce :: [Voice a] -> Voice [a] polyToHomophonicForce = undefined +-- | Split a homophonic texture into a polyphonic one. The returned voice list will not +-- have as many elements as the chord with the fewest number of notes. homoToPolyphonic :: Voice [a] -> [Voice a] -homoToPolyphonic = undefined +homoToPolyphonic xs = case nvoices xs of + Nothing -> [] + Just n -> fmap (\n -> fmap (!! n) xs) [0..n-1] + where + nvoices :: Voice [a] -> Maybe Int + nvoices = maybeMinimum . fmap length . (^.valuesV) changeCrossing :: Ord a => Voice a -> Voice a -> (Voice a, Voice a) changeCrossing = undefined @@ -631,17 +533,25 @@ processExactOverlaps' :: (a -> b -> Either (a,b) (b,a)) -> Voice a -> Voice b -> (Voice (Either b a), Voice (Either a b)) processExactOverlaps' = undefined +-- | Returns the onsets of all notes in a voice given the onset of the first note. onsetsRelative :: Time -> Voice a -> [Time] -onsetsRelative = undefined +onsetsRelative o v = case offsetsRelative o v of + [] -> [] + xs -> o : init xs +-- | Returns the offsets of all notes in a voice given the onset of the first note. offsetsRelative :: Time -> Voice a -> [Time] -offsetsRelative = undefined +offsetsRelative o = fmap (\t -> o .+^ (t .-. 0)) . toAbsoluteTime . (^. durationsV) +-- | Returns the midpoints of all notes in a voice given the onset of the first note. midpointsRelative :: Time -> Voice a -> [Time] -midpointsRelative = undefined +midpointsRelative o v = zipWith between (onsetsRelative o v) (offsetsRelative o v) + where + between p q = alerp p q 0.5 -erasRelative :: Time -> Voice a -> [Span] -erasRelative = undefined +-- | Returns the eras of all notes in a voice given the onset of the first note. +erasRelative :: Time -> Voice a -> [Span] +erasRelative o v = zipWith (<->) (onsetsRelative o v) (offsetsRelative o v) onsetMap :: Time -> Voice a -> Map Time a onsetMap = undefined @@ -669,7 +579,7 @@ mergeIfSameDuration :: Voice a -> Voice b -> Maybe (Voice (a, b)) mergeIfSameDurationWith :: (a -> b -> c) -> Voice a -> Voice b -> Maybe (Voice c) splitAt :: [Duration] -> Voice a -> [Voice a] --- splitTiesVoiceAt :: Tiable a => [Duration] -> Voice a -> [Voice a] +-- splitTiesAt :: Tiable a => [Duration] -> Voice a -> [Voice a] splitLatterToAssureSameDuration :: Voice b -> Voice b -> Voice b splitLatterToAssureSameDurationWith :: (b -> (b, b)) -> Voice b -> Voice b -> Voice b polyToHomophonic :: [Voice a] -> Maybe (Voice [a]) @@ -732,3 +642,5 @@ -} +maybeMinimum xs = if null xs then Nothing else Just (minimum xs) +maybeMaximum xs = if null xs then Nothing else Just (maximum xs)