module Music.Time.Reactive (
Reactive,
initial,
final,
Future,
Past,
updates,
resets,
occs,
isConstant,
isVariable,
step,
switch,
trim,
trimBefore,
trimAfter,
) where
import Control.Applicative
import Control.Arrow
import Control.Lens
import Control.Monad
import Control.Monad.Compose
import Control.Monad.Plus
import Data.AffineSpace
import Data.AffineSpace.Point
import Data.Foldable (Foldable)
import qualified Data.Foldable as F
import qualified Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Semigroup
import Data.Set (Set)
import qualified Data.Set as Set
import Data.String
import Data.Traversable (Traversable)
import qualified Data.Traversable as T
import Data.Typeable
import Data.VectorSpace
import Music.Time.Delayable
import Music.Time.Span
import Music.Time.Stretchable
import Music.Time.Time
import Music.Time.Time
newtype Reactive a = Reactive { getReactive :: ([Time], Time -> a) }
deriving (Functor, Semigroup, Monoid)
instance Delayable (Reactive a) where
delay n (Reactive (t,r)) = Reactive (delay n t, delay n r)
instance Stretchable (Reactive a) where
stretch n (Reactive (t,r)) = Reactive (stretch n t, stretch n r)
instance Wrapped (Reactive a) where
type Unwrapped (Reactive a) = ([Time], Time -> a)
_Wrapped' = iso getReactive Reactive
instance Applicative Reactive where
pure = (^. _Unwrapped') . pure . pure
((^. _Wrapped') -> (tf, rf)) <*> ((^. _Wrapped') -> (tx, rx)) = (^. _Unwrapped') (tf <> tx, rf <*> rx)
instance HasBehavior Reactive where
(?) = atTime
instance IsString a => IsString (Reactive a) where
fromString = pure . fromString
instance Eq (Reactive b) where
(==) = error "(==)"
(/=) = error "(/=)"
instance Ord b => Ord (Reactive b) where
min = liftA2 min
max = liftA2 max
instance Enum a => Enum (Reactive a) where
succ = fmap succ
pred = fmap pred
toEnum = pure . toEnum
fromEnum = error "fromEnum"
enumFrom = error "enumFrom"
enumFromThen = error "enumFromThen"
enumFromTo = error "enumFromTo"
enumFromThenTo = error "enumFromThenTo"
instance Num a => Num (Reactive a) where
(+) = liftA2 (+)
(*) = liftA2 (*)
() = liftA2 ()
abs = fmap abs
signum = fmap signum
fromInteger = pure . fromInteger
instance (Num a, Ord a) => Real (Reactive a) where
toRational = error "toRational"
instance Integral a => Integral (Reactive a) where
quot = liftA2 quot
rem = liftA2 rem
div = liftA2 div
mod = liftA2 mod
quotRem = (fmap.fmap) unzip' (liftA2 quotRem)
divMod = (fmap.fmap) unzip' (liftA2 divMod)
toInteger = error "toInteger"
instance Fractional b => Fractional (Reactive b) where
recip = fmap recip
fromRational = pure . fromRational
instance Floating b => Floating (Reactive b) where
pi = pure pi
sqrt = fmap sqrt
exp = fmap exp
log = fmap log
sin = fmap sin
cos = fmap cos
asin = fmap asin
atan = fmap atan
acos = fmap acos
sinh = fmap sinh
cosh = fmap cosh
asinh = fmap asinh
atanh = fmap atanh
acosh = fmap acosh
instance AdditiveGroup v => AdditiveGroup (Reactive v) where
zeroV = pure zeroV
(^+^) = liftA2 (^+^)
negateV = liftA negateV
instance VectorSpace v => VectorSpace (Reactive v) where
type Scalar (Reactive v) = Scalar v
(*^) s = fmap (s *^)
occs :: Reactive a -> [Time]
occs = fst . (^. _Wrapped')
atTime :: Reactive a -> Time -> a
atTime = snd . (^. _Wrapped')
initial :: Reactive a -> a
initial r = r ? minB (occs r)
where
minB [] = 0
minB (x:_) = x 1
updates :: Reactive a -> [Future a]
updates r = (\t -> (t, r ? t)) <$> (List.sort . List.nub) (occs r)
final :: Reactive a -> a
final (renderR -> (i,[])) = i
final (renderR -> (i,xs)) = snd $ last xs
switch :: Time -> Reactive a -> Reactive a -> Reactive a
switch t (Reactive (tx, rx)) (Reactive (ty, ry)) = Reactive $ (,)
(filter (< t) tx <> [t] <> filter (> t) ty)
(\u -> if u < t then rx u else ry u)
type Future a = (Time, a)
type Past a = (Time, a)
isConstant :: Reactive a -> Bool
isConstant = null . occs
isVariable :: Reactive a -> Bool
isVariable = not . isConstant
resets :: Reactive a -> [Past a]
resets = error "resets: Not impl"
step :: (AdditiveGroup a, Fractional a) => Reactive a
step = switch start zeroV 1.0
trim :: Monoid a => Span -> Reactive a -> Reactive a
trim (view range -> (t,u)) = trimBefore t . trimAfter u
trimBefore :: Monoid a => Time -> Reactive a -> Reactive a
trimBefore start x = switch start mempty x
trimAfter :: Monoid a => Time -> Reactive a -> Reactive a
trimAfter stop x = switch stop x mempty
renderR :: Reactive a -> (a, [(Time, a)])
renderR = initial &&& updates
renderR' :: Reactive a -> ([Time], Time -> a)
renderR' = occs &&& (?)
printR :: Show a => Reactive a -> IO ()
printR r = let (x, xs) = renderR r in do
print x
mapM_ print xs
unzip' :: Functor f => f (a, b) -> (f a, f b)
unzip' r = (fst <$> r, snd <$> r)