music-score 1.7.2 → 1.8

raw patch · 63 files changed

+2026/−2361 lines, 63 filesdep +transformers-compatdep −semigroupoidsdep ~lensdep ~lilyponddep ~music-dynamics-literalPVP ok

version bump matches the API change (PVP)

Dependencies added: transformers-compat

Dependencies removed: semigroupoids

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

API changes (from Hackage documentation)

Files

• music-score.cabal +12/−12
• src/Data/Functor/Context.hs +16/−2
• src/Music/Score.hs +1/−11
• src/Music/Score/Articulation.hs +18/−15
• src/Music/Score/Color.hs +1/−0
• src/Music/Score/Dynamics.hs +20/−17
• src/Music/Score/Export/ArticulationNotation.hs +1/−1
• src/Music/Score/Export/Lilypond.hs +2/−2
• src/Music/Score/Export/Midi.hs +4/−3
• src/Music/Score/Export/MusicXml.hs +2/−2
• src/Music/Score/Export/SuperCollider.hs +6/−6
• src/Music/Score/Instances.hs +0/−343
• src/Music/Score/Internal/Export.hs +4/−4
• src/Music/Score/Internal/Instances.hs +346/−0
• src/Music/Score/Meta.hs +31/−79
• src/Music/Score/Meta/Attribution.hs +5/−5
• src/Music/Score/Meta/Barline.hs +2/−2
• src/Music/Score/Meta/Clef.hs +8/−2
• src/Music/Score/Meta/Fermata.hs +2/−2
• src/Music/Score/Meta/Key.hs +2/−2
• src/Music/Score/Meta/Pickup.hs +2/−2
• src/Music/Score/Meta/RehearsalMark.hs +2/−2
• src/Music/Score/Meta/Tempo.hs +26/−17
• src/Music/Score/Meta/Time.hs +1/−1
• src/Music/Score/Meta/Title.hs +6/−6
• src/Music/Score/Part.hs +54/−7
• src/Music/Score/Phrases.hs +11/−8
• src/Music/Score/Pitch.hs +54/−37
• src/Music/Score/Slide.hs +1/−1
• src/Music/Score/Text.hs +1/−1
• src/Music/Score/Ties.hs +44/−30
• src/Music/Score/Tremolo.hs +1/−1
• src/Music/Time.hs +16/−19
• src/Music/Time/Aligned.hs +129/−0
• src/Music/Time/Behavior.hs +23/−67
• src/Music/Time/Bound.hs +1/−7
• src/Music/Time/Chord.hs +22/−27
• src/Music/Time/Delayed.hs +0/−156
• src/Music/Time/Duration.hs +17/−37
• src/Music/Time/Event.hs +271/−0
• src/Music/Time/Future.hs +13/−0
• src/Music/Time/Graces.hs +4/−6
• src/Music/Time/Internal/Convert.hs +5/−102
• src/Music/Time/Internal/Quantize.hs +3/−3
• src/Music/Time/Internal/Transform.hs +18/−58
• src/Music/Time/Internal/Util.hs +7/−2
• src/Music/Time/Juxtapose.hs +0/−2
• src/Music/Time/Meta.hs +3/−3
• src/Music/Time/Nominal.hs +14/−6
• src/Music/Time/Note.hs +75/−95
• src/Music/Time/Past.hs +30/−19
• src/Music/Time/Placed.hs +116/−0
• src/Music/Time/Position.hs +72/−35
• src/Music/Time/Reactive.hs +21/−34
• src/Music/Time/Reverse.hs +5/−91
• src/Music/Time/Score.hs +114/−266
• src/Music/Time/Segment.hs +25/−35
• src/Music/Time/Split.hs +1/−7
• src/Music/Time/Stretched.hs +0/−156
• src/Music/Time/Track.hs +22/−46
• src/Music/Time/Transform.hs +0/−6
• src/Music/Time/Types.hs +145/−197
• src/Music/Time/Voice.hs +168/−256

@@ -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

@@ -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)     

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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--

@@ -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'" #-}  

@@ -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++

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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) 

@@ -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)

@@ -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  

@@ -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)

@@ -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

@@ -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) --

@@ -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  

@@ -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-

@@ -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+++++

@@ -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

@@ -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               #-}  -------------------------------------------------------------------------------------

@@ -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

@@ -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)--

@@ -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 #-} 

@@ -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

@@ -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

@@ -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               #-}  ------------------------------------------------------------------------------------- -- |

@@ -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 

@@ -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

@@ -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

@@ -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 #-} 

@@ -1,7 +1,5 @@  {-# LANGUAGE ConstraintKinds           #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE FlexibleInstances         #-} {-# LANGUAGE MultiParamTypeClasses     #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE RankNTypes                #-}

@@ -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

@@ -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

@@ -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)++   

@@ -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

@@ -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)

@@ -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  

@@ -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 

@@ -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-                                         -}- 

@@ -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

@@ -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 

@@ -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               #-}  -------------------------------------------------------------------------------------

@@ -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 #-}-

@@ -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 #-} 

@@ -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 

@@ -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)  

@@ -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)