module Music.Time.Score (
Score,
score,
events,
eras,
triples,
mapWithSpan,
filterWithSpan,
mapFilterWithSpan,
mapTriples,
filterTriples,
mapFilterTriples,
hasOverlappingEvents,
simultaneous,
normalizeScore,
removeRests,
printEras,
unsafeEvents,
unsafeTriples,
) where
import Data.AffineSpace
import Data.AffineSpace.Point
import qualified Data.List.NonEmpty as NonEmpty
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Ratio
import Data.Semigroup
import Data.Set (Set)
import qualified Data.Set as Set
import Data.VectorSpace
import Data.String
import Data.Functor.Adjunction (unzipR)
import Music.Time.Juxtapose (scat)
import Music.Time.Meta
import Music.Time.Event
import Music.Time.Reverse
import Music.Time.Split
import Music.Time.Note
import Music.Time.Voice
import Control.Applicative
import Control.Comonad
import Control.Lens hiding (Indexable, Level, above, below,
index, inside, parts, reversed,
transform, (<|), (|>))
import Control.Monad
import Control.Monad.Compose
import Control.Monad.Plus
import Data.Foldable (Foldable)
import qualified Data.Foldable as Foldable
import qualified Data.List as List
import qualified Data.Ord as Ord
import Data.Semigroup hiding ()
import Data.Traversable (Traversable)
import qualified Data.Traversable as T
import Data.Typeable
import Data.VectorSpace hiding (Sum (..))
import Music.Dynamics.Literal
import Music.Pitch.Literal
import Music.Time.Internal.Util
newtype Score a = Score { getScore :: (Meta, Score' a) }
deriving (Functor, Semigroup, Monoid, Foldable, Traversable, Typeable)
instance Wrapped (Score a) where
type Unwrapped (Score a) = (Meta, Score' a)
_Wrapped' = iso getScore Score
instance Rewrapped (Score a) (Score b) where
instance Applicative Score where
pure = return
(<*>) = ap
instance Monad Score where
return = (^. _Unwrapped') . return . return
xs >>= f = (^. _Unwrapped') $ mbind ((^. _Wrapped') . f) ((^. _Wrapped') xs)
instance Alternative Score where
empty = mempty
(<|>) = mappend
instance MonadPlus Score where
mzero = mempty
mplus = mappend
instance Transformable (Score a) where
transform t (Score (m,x)) = Score (transform t m, transform t x)
instance HasPosition (Score a) where
_position = _position . snd . view _Wrapped'
instance HasDuration (Score a) where
_duration x = _offset x .-. _onset x
instance IsString a => IsString (Score a) where
fromString = pure . fromString
instance IsPitch a => IsPitch (Score a) where
fromPitch = pure . fromPitch
instance IsInterval a => IsInterval (Score a) where
fromInterval = pure . fromInterval
instance IsDynamics a => IsDynamics (Score a) where
fromDynamics = pure . fromDynamics
instance Enum a => Enum (Score a) where
toEnum = return . toEnum
fromEnum = list 0 (fromEnum . head) . Foldable.toList
instance Num a => Num (Score a) where
fromInteger = return . fromInteger
abs = fmap abs
signum = fmap signum
(+) = error "Not implemented"
() = error "Not implemented"
(*) = error "Not implemented"
instance AdditiveGroup (Score a) where
zeroV = error "Not implemented"
(^+^) = error "Not implemented"
negateV = error "Not implemented"
instance VectorSpace (Score a) where
type Scalar (Score a) = Duration
d *^ s = d `stretch` s
instance HasMeta (Score a) where
meta = _Wrapped . _1
newtype Score' a = Score' { getScore' :: [Event a] }
deriving (Functor, Foldable, Traversable, Semigroup, Monoid, Typeable, Show, Eq)
instance (Show a, Transformable a) => Show (Score a) where
show x = show (x^.events) ++ "^.score"
instance Wrapped (Score' a) where
type Unwrapped (Score' a) = [Event a]
_Wrapped' = iso getScore' Score'
instance Rewrapped (Score' a) (Score' b)
instance Applicative Score' where
pure = return
(<*>) = ap
instance Monad Score' where
return = (^. _Unwrapped) . pure . pure
xs >>= f = (^. _Unwrapped) $ mbind ((^. _Wrapped') . f) ((^. _Wrapped') xs)
instance Alternative Score' where
empty = mempty
(<|>) = mappend
instance MonadPlus Score' where
mzero = mempty
mplus = mappend
instance Transformable (Score' a) where
transform t = over (_Wrapped) (transform t)
instance HasPosition (Score' a) where
_era x = (f x, g x)^.from range
where
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
score :: Getter [Event a] (Score a)
score = from unsafeEvents
events :: Lens (Score a) (Score b) [Event a] [Event b]
events = _Wrapped . _2 . _Wrapped . sorted
where
sorted = iso (List.sortBy (Ord.comparing _onset)) (List.sortBy (Ord.comparing _onset))
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
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)
where
event t d x = (delay (t .-. 0) . stretch d) (return x)
_getScore :: Score a -> [(Time, Duration, a)]
_getScore =
fmap (\(view delta -> (t,d),x) -> (t,d,x)) .
List.sortBy (Ord.comparing fst) .
Foldable.toList .
fmap (view $ from event) .
reifyScore
mapScore :: (Event a -> b) -> Score a -> Score b
mapScore f = over (_Wrapped._2) (mapScore' f)
where
mapScore' f = over (_Wrapped.traverse) (extend f)
reifyScore :: Score a -> Score (Event a)
reifyScore = over (_Wrapped . _2 . _Wrapped) $ fmap duplicate
triples :: Lens (Score a) (Score b) [(Time, Duration, a)] [(Time, Duration, b)]
triples = events . _zipList . through triple triple . from _zipList
mapWithSpan :: (Span -> a -> b) -> Score a -> Score b
mapWithSpan f = mapScore (uncurry f . view (from event))
filterWithSpan :: (Span -> a -> Bool) -> Score a -> Score a
filterWithSpan f = mapFilterWithSpan (partial2 f)
mapFilterWithSpan :: (Span -> a -> Maybe b) -> Score a -> Score b
mapFilterWithSpan f = mcatMaybes . mapWithSpan f
mapTriples :: (Time -> Duration -> a -> b) -> Score a -> Score b
mapTriples f = mapWithSpan (uncurry f . view delta)
filterTriples :: (Time -> Duration -> a -> Bool) -> Score a -> Score a
filterTriples f = mapFilterTriples (partial3 f)
mapFilterTriples :: (Time -> Duration -> a -> Maybe b) -> Score a -> Score b
mapFilterTriples f = mcatMaybes . mapTriples f
normalizeScore :: Score a -> Score a
normalizeScore = reset . normalizeScoreDurations
where
reset x = set onset (view onset x `max` 0) x
normalizeScoreDurations = over (events . each . era) normalizeSpan
removeRests :: Score (Maybe a) -> Score a
removeRests = mcatMaybes
printEras :: Score a -> IO ()
printEras = mapM_ print . toListOf eras
eras :: Traversal' (Score a) Span
eras = events . each . era
chordEvents :: Transformable a => Span -> Score a -> [a]
chordEvents s = fmap extract . filter ((== s) . view era) . view events
simultaneous' :: Transformable a => Score a -> Score [a]
simultaneous' sc = (^. from unsafeTriples) vs
where
es = List.nub $ toListOf eras sc
evs = fmap (`chordEvents` sc) es
vs = zipWith (\(view delta -> (t,d)) a -> (t,d,a)) es evs
simultaneous :: (Transformable a, Semigroup a) => Score a -> Score a
simultaneous = fmap (sconcat . NonEmpty.fromList) . simultaneous'
hasOverlappingEvents :: Score a -> Bool
hasOverlappingEvents = anyDistinctOverlaps . toListOf (events.each.era)
hasDuplicates :: Eq a => [a] -> Bool
hasDuplicates xs = List.nub xs /= xs
anyDistinctOverlaps :: [Span] -> Bool
anyDistinctOverlaps xs = hasDuplicates xs || anyOverlaps xs
where
anyOverlaps = foldr (||) False . combined overlaps
combined :: Eq a => (a -> a -> b) -> [a] -> [b]
combined f as = mcatMaybes [if x == y then Nothing else Just (x `f` y) | x <- as, y <- as]
squared :: (a -> a -> b) -> [a] -> [b]
squared f as = [x `f` y | x <- as, y <- as]