module Music.Time.Reactive (
Reactive,
initial,
final,
intermediate,
discrete,
updates,
occs,
atTime,
splitReactive,
switchR,
trimR,
continous,
continousWith,
sample,
) where
import Music.Time.Behavior
import Music.Time.Bound
import Music.Time.Note
import Music.Time.Reverse
import Music.Time.Segment
import Music.Time.Split
import Music.Pitch.Alterable
import Music.Pitch.Augmentable
import Music.Pitch.Literal
import Control.Applicative
import Control.Lens hiding (Indexable, Level, above, below,
index, inside, parts, reversed,
transform, (<|), (|>))
import Control.Monad
import Control.Monad.Plus
import Data.Distributive
import Data.Functor.Rep
import Data.Functor.Rep.Lens
import qualified Data.List as List
import Data.Semigroup hiding ()
import Data.Typeable
import Music.Dynamics.Literal
import Music.Pitch.Literal
newtype Reactive a = Reactive { getReactive :: ([Time], Behavior a) }
deriving (Functor, Semigroup, Monoid, Typeable)
instance Transformable (Reactive a) where
transform s (Reactive (t,r)) = Reactive (transform s t, transform s r)
instance Wrapped (Reactive a) where
type Unwrapped (Reactive a) = ([Time], Behavior a)
_Wrapped' = iso getReactive Reactive
instance Rewrapped (Reactive a) (Reactive b)
instance Applicative Reactive where
pure = pureDefault
(<*>) = apDefault
instance IsPitch a => IsPitch (Reactive a) where
fromPitch = pure . fromPitch
instance IsInterval a => IsInterval (Reactive a) where
fromInterval = pure . fromInterval
instance IsDynamics a => IsDynamics (Reactive a) where
fromDynamics = pure . fromDynamics
instance Alterable a => Alterable (Reactive a) where
sharpen = fmap sharpen
flatten = fmap flatten
instance Augmentable a => Augmentable (Reactive a) where
augment = fmap augment
diminish = fmap diminish
(view _Wrapped -> (tf, rf)) `apDefault` (view _Wrapped -> (tx, rx)) = view _Unwrapped (tf <> tx, rf <*> rx)
pureDefault = view _Unwrapped . pure . pure
initial :: Reactive a -> a
initial r = r `atTime` minB (occs r)
where
minB [] = 0
minB (x:_) = x 1
updates :: Reactive a -> [(Time, a)]
updates r = (\t -> (t, r `atTime` t)) <$> (List.sort . List.nub) (occs r)
renderR :: Reactive a -> (a, [(Time, a)])
renderR x = (initial x, updates x)
occs :: Reactive a -> [Time]
occs = fst . (^. _Wrapped')
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
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)
withNext :: [a] -> [(a, Maybe a)]
withNext = go
where
go [] = []
go [x] = [(x, Nothing)]
go (x:y:rs) = (x, Just y) : withNext (y : rs)
atTime :: Reactive a -> Time -> a
atTime = (!) . snd . (^. _Wrapped')
final :: Reactive a -> a
final (renderR -> (i,[])) = i
final (renderR -> (i,xs)) = snd $ last xs
switchR :: Time -> Reactive a -> Reactive a -> Reactive a
switchR t (Reactive (tx, bx)) (Reactive (ty, by)) = Reactive $ (,)
(filter (< t) tx <> [t] <> filter (> t) ty) (switch t bx by)
trimR :: Monoid a => Span -> Reactive a -> Reactive a
trimR (view range -> (t, u)) x = switchR t mempty (switchR u x mempty)
intermediate :: Transformable a => Reactive a -> [Note a]
intermediate (updates -> []) = []
intermediate (updates -> xs) = fmap (\((t1, x), (t2, _)) -> (t1 <-> t2, x)^.note) $ withNext $ xs
where
withNext xs = zip xs (tail xs)
discrete :: Reactive a -> Behavior a
discrete = continous . fmap pure
continous :: Reactive (Segment a) -> Behavior a
continousWith :: Segment (a -> b) -> Reactive a -> Behavior b
continousWith f x = continous $ liftA2 (<*>) (pure f) (fmap pure x)
sample :: [Time] -> Behavior a -> Reactive a
(continous, sample) = error "Not implemented: (continous, sample)"
window :: [Time] -> Behavior a -> Reactive (Segment a)
windowed :: Iso (Behavior a) (Behavior b) (Reactive (Segment a)) (Reactive (Segment b))
(window, windowed) = error "Not implemented: (window, windowed)"