module Music.Score.Meta (
module Music.Time.Meta,
(</>),
rcat,
addMetaNote,
fromMetaReactive,
metaAt,
metaAtStart,
withMeta,
withMetaAtStart,
) where
import Control.Applicative
import Control.Lens hiding (parts, perform)
import Control.Monad
import Control.Monad.Plus
import Data.Bifunctor
import Data.AffineSpace
import Data.AffineSpace.Point
import Data.Foldable (Foldable (..))
import Data.Maybe
import Data.Ord
import Data.Ratio
import Data.Semigroup
import Data.String
import Data.Traversable
import Data.VectorSpace
import Music.Score.Part
import Music.Score.Internal.Util
import Music.Time
import Music.Time.Meta
import Music.Time.Reactive
import qualified Data.Foldable as Foldable
import qualified Data.List as List
infixr 6 </>
rcat :: (HasParts' a, Enum (Part a)) => [Score a] -> Score a
rcat = List.foldr (</>) mempty
(</>) :: (HasParts' a, Enum (Part a)) => Score a -> Score a -> Score a
a </> b = a <> moveParts offset b
where
offset = succ $ maximum' 0 $ fmap fromEnum $ toListOf parts a
moveParts :: (Integral b, HasParts' a, Enum (Part a)) => b -> Score a -> Score a
moveParts x = parts %~ (successor x)
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)
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
withSpan :: Score a -> Score (Span, a)
withSpan = mapEvents (\t d x -> (t >-> d,x))
withTime = mapEvents (\t d x -> (t, x))
inSpan t' (view range -> (t,u)) = t <= t' && t' < u
mapBefore :: Time -> (Score a -> Score a) -> Score a -> Score a
mapDuring :: Span -> (Score a -> Score a) -> Score a -> Score a
mapAfter :: Time -> (Score a -> Score a) -> Score a -> Score a
mapBefore t f x = let (y,n) = (fmap snd `bimap` fmap snd) $ mpartition (\(t2,x) -> t2 < t) (withTime x) in (f y <> n)
mapDuring s f x = let (y,n) = (fmap snd `bimap` fmap snd) $ mpartition (\(t,x) -> t `inSpan` s) (withTime x) in (f y <> n)
mapAfter t f x = let (y,n) = (fmap snd `bimap` fmap snd) $ mpartition (\(t2,x) -> t2 >= t) (withTime x) in (f y <> n)
runScoreMeta :: forall a b . AttributeClass b => Score a -> Reactive b
runScoreMeta = fromMetaReactive . (view meta)
metaAt :: AttributeClass b => Time -> Score a -> b
metaAt x = (`atTime` x) . runScoreMeta
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
noteToReactive :: Monoid a => Note 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)
where
turnOn = switchR start
turnOff = switchR stop