{-# LANGUAGE Trustworthy, DeriveFunctor, CPP #-} -- | A different presentation of functional reactive programming, based on the Reactive -- library on Hackage. Push-pull FRP is due to Conal Elliott. The functionals here -- are directly based on those from Reactive. module FRP.Reactivity.Combinators (module FRP.Reactivity, -- * Derived event combinators list, tick, untilE, eitherOf, holdE, delayedHoldE, zipE, simultE, intersectE, differenceE, unionE, filterE, justE, duplicateE, withPrev, switchE, scanlE, calmE, count, takeE, dropE, everyNth, delayE, slowE, rests, startAt, splitE, -- * Reactive behaviors Behavior, time, switcher, stepper, snapshot, flipFlop, history, scan, delay, slow, monoid, throttle, sumE, derivative, supersample, integral, threshold, frequencyToAmplitude, convolution) where import Control.Monad import Control.Monad.Fix import Control.Monad.Loops import Control.Applicative import Control.Exception import Control.Comonad import Control.Parallel.Strategies import Control.Parallel import Data.Maybe import Data.List import Data.Monoid import Data.Function import qualified Data.Map as M import Data.IORef import FRP.Reactivity -- | A convenience to generate a tick on a regular interval. {-# INLINE tick #-} tick t = list (map (\t -> (t, t)) [0,t..]) _untilE e = over e (\ei t rest -> either (\x -> cons x t (_untilE rest)) (\_ -> mzero) ei) -- | This functional can be used to terminate an event early. {-# INLINE untilE #-} untilE :: Event t -> Event u -> Event t untilE e u = _untilE (eitherOf e u) {-# INLINE eitherOf #-} eitherOf e e2 = fmap Left e <> fmap Right e2 -- | Give the event times of 'e', but latching onto the ticks of 'e2'. Prior to 'e2' ticking, gives 'x'. {-# INLINE holdE #-} holdE :: Event t -> Event u -> u -> Event (t, u) holdE e e2 x = justE $ corec (\x ei t -> either (\y -> (x, Just (y, x), t)) (\y2 -> (y2, Nothing, t)) ei) x $ eitherOf e e2 -- | Same deal as the previous, but holding is delayed. That is, if a tick from 'e' follows a value -- from 'e2' but happens at the same nominal time, the prior value of 'e2' is used and not said -- value. delayedHoldE e e2 x = justE $ corec (\(prevX, t, x) ei t2 -> either (\y -> ((prevX, t, x), Just (y, if t < t2 then x else prevX), t)) (\y2 -> ((x, t2, y2), Nothing, t2)) ei) (x, 0, x) $ eitherOf e e2 swap (x, y) = (y, x) {-# INLINE zipE #-} zipE e x e2 y = holdE e e2 y <> fmap swap (holdE e2 e x) {-# INLINE cozip #-} cozip ls = (catMaybes (map (either Just (const Nothing)) ls), catMaybes (map (either (const Nothing) Just) ls)) {-# INLINE groupOn #-} groupOn ls = map (\ls -> (map fst ls, snd (head ls))) $ groupBy ((==) `on` snd) ls {-# INLINE ungroup #-} ungroup ls = [ (y, x) | (l, x) <- ls, y <- l ] -- | Pair values from 'e' to simultaneous occurrences from 'a'. Multiple occurrences -- are paired up as with 'zip'. Excess occurrences from 'a' are discarded, while -- excess occurrences from 'e' are paired with 'Nothing'. {-# INLINE simultE #-} simultE :: Event t -> Event u -> Event (t, Maybe u) simultE e a = justE $ fmap (\(x, _, _) -> x) $ scanlE (\(_, prev, ti) (ei, t) -> if ti < t then -- Discard old occurrences either (\y -> (Nothing, [y], t)) (\x -> (Just (x, Nothing), [], t)) ei else -- Zip up occurrences at a single time either (\y -> (Nothing, prev ++ [y], t)) (\x -> case prev of { y:ys -> (Just (x, Just y), ys, t); [] -> (Just (x, Nothing), [], t) }) ei) (Nothing, [], 0) $ withTime $ eitherOf a e -- | Set operations on events {-# INLINE differenceE #-} differenceE e a = justE $ fmap (\(x, m) -> maybe (Just x) (const Nothing) m) $ simultE e a {-# INLINE intersectE #-} intersectE e a = justE $ fmap (uncurry fmap) $ simultE e a {-# INLINE unionE #-} unionE :: (Monoid t) => Event t -> Event t -> Event t unionE e e2 = intersectE (fmap (<>) e) e2 <> differenceE e e2 <> differenceE e2 e -- | Drop event occurrences that fail the predicate 'f'. filterE f e = over e (\x t rest -> if f x then cons x t (filterE f rest) else filterE f rest) {-# INLINE justE #-} justE e = fmap fromJust (filterE isJust e) {-# INLINE duplicateE #-} duplicateE e = fmap (\(x, e) -> return x <> e) (withRest e) {-# INLINE withPrev #-} withPrev e = justE $ corec (\may y t -> (Just y, fmap (\x -> (x, y)) may, t)) Nothing e {-# INLINE switchE #-} switchE e = withRest e >>= \(x, u) -> x `untilE` u {-# INLINE scanlE #-} scanlE f x e = corec (\x y t -> let x' = f x y in (x', x', t)) x e -- | "Calms" an event so that only one event occurs at a given time. {-# INLINE calmE #-} calmE e = once e <> fmap (fst . snd) (filterE (\((_, t), (_, t1)) -> t < t1) $ withPrev $ withTime e) {-# INLINE count #-} count e = corec (\n x t -> (n + 1, (x, n + 1), t)) 0 e -- | Event versions of 'drop' and 'take'. {-# INLINE dropE #-} dropE n e = fmap fst $ filterE ((>n) . snd) $ count e {-# INLINE takeE #-} takeE :: (Num n, Ord n) => n -> Event t -> Event t takeE n e = fmap fst $ filterE ((<=n) . snd) (c `untilE` delayE epsilon (filterE ((>n) . snd) c)) where c = count e {-# INLINE everyNth #-} everyNth :: (Num n, Ord n) => n -> Event t -> Event t everyNth n = justE . corec (\i x t -> if 1 + i >= n then (0, Just x, t) else (1 + i, Nothing, t)) n -- | Gives all the events of 'e', but delayed 't' seconds. {-# INLINE delayE #-} delayE :: Time -> Event t -> Event t delayE t e = rec t e where rec t1 e = displace t1 (over e (\x t1 rest -> let t2 = t + t1 in cons x t2 (rec t2 rest))) -- rec t e where -- rec t1 e = displace t1 (over e (\x t1 rest -> let t2 = t + t1 in cons x t2 (rec t2 rest))) {-# INLINE slowE #-} slowE x e = withTime e >>= \(y, t) -> list [(y, (x - 1) * t)] -- | Get the remainder events of 'e' looking forward from particular occurrences in 'a' {-# INLINE rests #-} rests e a = holdE a (fmap snd (withRest e)) e -- | Waits until 'a' ticks before it starts ticking. {-# INLINE startAt #-} startAt e a = once (rests e a) >>= snd -- | Divides 'e' into chunks based on the ticks of 'a', and returns those chunks in an event. -- The occurrences of 'e' prior to the first occurrence of 'a' are omitted. {-# INLINE splitE #-} splitE e a = fmap (\((_, a), e) -> e `untilE` a) $ rests e (withRest a) {-# INLINE sumE #-} sumE :: (Num t) => Event t -> Event t sumE = corec (\x y t -> let x' = x + y in (x', x', t)) 0 {-fixpoint :: (Event t -> Event t) -> Event t fixpoint f = E (\schedule disp g -> do -- When the event ticks, the current tick has to be in hand prior to evaluation. current <- newEmptyMVar let e = f $ E (\schedule _ g -> do -- Feeds the value to the handler (prior to its calculation!). let loop = do ~(x, t) <- unsafeInterleaveIO $ takeMVar current g mempty x t threadDelay 100000 loop thd <- forkIO loop return (killThread thd)) 0 -- When a value is obtained, provide it in the variable. internalRunEvent schedule disp e (\_ x t -> do tryPutMVar current (x, t) processEvent schedule g mempty x t)) 0 instance MonadFix Event where mfix f = join $ fixpoint $ fmap (>>= f)-} ------------------------------------------- -- Reactive behaviors data Behavior t = Switcher !(Time -> t) (Event (Time -> t)) deriving Functor {-# INLINE time #-} time = Switcher id mempty {-# INLINE switcher #-} switcher (Switcher f e) e2 = Switcher f (switchE $ return e <> fmap (\(Switcher f e) -> return f <> e) e2) {-# INLINE stepper #-} stepper x e = Switcher (const x) (fmap const e) {-# INLINE snapshot #-} snapshot e (Switcher f e2) = fmap (\((x, f), t) -> (x, f t)) $ withTime $ holdE e e2 f {-# INLINE flipFlop #-} flipFlop e e2 = stepper False (fmap (const True) e <> fmap (const False) e2) -- | Keep a history of 't' seconds as a "moving window" -- giving values for -- the behavior, 't' seconds prior to the current time. Outside of this -- moving window, gives a flat behavior. -- -- This functional should be enough for all "history-dependent" behaviors -- there -- should be some 't' which is a constant bound on a behavior's history, -- in order to conserve memory. history :: Time -> Behavior t -> Behavior (Time -> t) history t (Switcher f e) = function <$> stepper [(f, 0)] windowFunctions <*> time where function ls t1 t2 = if t1 <= t2 then fst (head ls) t1 else maybe (fst (last ls) (t1-t)) (($t2) . fst) $ find ((<=t2) . snd) ls windowFunctions = corec (\ls f t1 -> let ls' = (f, t1) : map fst (takeWhile (( Event t) -> t -> Event t scan b x = return x <> (snapshot (extract b x) (duplicate b) >>= uncurry (flip scan)) _monoid e b = return b <> (snapshot (once (withRest e)) (duplicate b) >>= \((x, e), b2) -> _monoid e (x <> b2)) -- | Collect the event occurrences and add them together into a single behavior, using a monoid. {-# INLINE monoid #-} monoid :: (Monoid t) => Event (Behavior t) -> Behavior t monoid e = switcher mempty $ _monoid e mempty -- | Each event occurrence casts a "shadow" for 't' seconds in the behavior. {-# INLINE throttle #-} throttle :: Time -> Event t -> Behavior (Maybe t) throttle t e = fmap getLast $ monoid (fmap (\(x, ti) -> stepper (Last Nothing) (list [(Last (Just x), ti), (Last Nothing, t + ti)])) (withTime e)) -- | Delay by 't' seconds before continuing as the behavior. {-# INLINE delay #-} delay t (Switcher f e) = Switcher (f . subtract t) (fmap (. subtract t) (delayE t e)) -- | Slow down the behavior by a factor of 'x'. {-# INLINE slow #-} slow x (Switcher f e) = Switcher (f . (/x)) (slowE x (fmap (. (/x)) e)) instance (Monoid t) => Monoid (Behavior t) where mempty = pure mempty mappend e e2 = mappend <$> e <*> e2 instance Alternative Behavior where empty = error "FRP.Reactivity.empty: use Monoid instead" (<|>) = error "FRP.Reactivity.<|>: use Monoid instead" instance Applicative Behavior where pure x = Switcher (const x) mempty Switcher f e <*> Switcher f2 e2 = Switcher (f <*> f2) $ fmap (uncurry (<*>)) $ zipE e f e2 f2 {-# INLINE cutoff #-} cutoff t f t1 = f (max t t1) -- The Behavior functor forms a /Comonad/. Its -- * 'duplicate' - produces, for a time 't', a version of the Behavior with a flat behavior up to 't'. -- If the original behavior (snapshotted) looks like [1,2,3,4,5], the duplicated -- behavior looks like [[1,2,3,4,5],[2,2,3,4,5],[3,3,3,4,5],[4,4,4,4,5],[5,5,5,5,5]]. -- -- * 'extract' - gets the value of the flat behavior, by sampling at t = 0. In the example, 'extract' -- would pull out the first element of each list, giving [1,2,3,4,5]. instance Comonad Behavior where extract (Switcher f _) = f 0 duplicate (Switcher f e) = Switcher (\t -> Switcher (cutoff t f) e) (fmap (\(f, e) t -> Switcher (cutoff t f) e) (withRest e)) ------------------------------------------- -- Integration epsilon = 0.0001 -- | Estimate the derivative of a behavior. derivative :: (Real t, Fractional t) => Behavior t -> Behavior t derivative b = (\x x1 -> (x1 - x) / fromRational (toRational epsilon)) <$> delay epsilon b <*> b -- | Adaptively supersample a behavior. supersample precision b = scan ((\t x deriv _ -> list [((t, x), if t < epsilon then t + epsilon else t + fromRational (toRational $ precision / (1 + abs deriv)))]) <$> time <*> b <*> derivative b) (extract b, 0) -- | Integral of behaviors integral precision b = -- Obtain the integral (trapezoidal integration) stepper 0 $ sumE $ fmap (\((t, x), (t1, x1)) -> 0.5 * (x1 + x) * fromRational (toRational (t1 - t))) $ withPrev $ supersample precision b -- | Given a differentiable behavior, find the times at which -- a certain value could be found. The result is an event which ticks -- when (an approximation of) the value is encountered. threshold precision b x = justE $ fmap (\(b, m) -> fmap (const b) m) $ scanlE (\(gt, _) (t, y) -> if gt == (y < x) then (not gt, Just t) else (gt, Nothing)) (extract b > x, Nothing) $ supersample precision b ------------------------------------------- -- Waveforms frequencyToAmplitude :: (Floating t) => [(t, Behavior t)] -> Behavior t frequencyToAmplitude frequencies = fmap sum $ traverse (\(frequency, intensity) -> (*) <$> intensity <*> fmap (sin . (* frequency) . fromRational . toRational) time) frequencies convolution :: (Real t) => [(Time, t)] -> Behavior t -> Behavior t convolution kernel b = fmap (\f -> sum $ map (\(x, y) -> f x * y) kernel) $ history kernelSize b where kernelSize = -minimum (map fst kernel) ------------------------------------------- -- Laws -- -- mempty >>= f = mempty [left-mempty] -- e >>= const mempty [right-mempty] -- (e <> e2) >>= f = (e >>= f) <> (e2 >>= f) [left-distributivity] -- e <> e2 <> e3 = e <> (e2 <> e3) [associativity] -- mempty <> e = e [left-mempty2] -- e <> mempty = e [right-mempty2] -- The monad laws -- -- firstE e e2 = e \/ firstE e e2 = e2 [in any given instance, either e or e2 ticks first] -- e `firstE` e2 `firstE` e2 = (e `firstE` e2) `firstE` e3 [associativity] -- firstE mempty e = e [left-mempty-firstE] -- -- withTimeE (withTimeE e) = fmap (\(x, t) -> ((x, t), t)) (withTimeE e) [fold-withTimeE] -- -- e `untilE` e = mempty [mempty-untilE] -- e `untilE` u `untilE` u2 = e `untilE` (u <> u2) [distributivity of untilE] -- -- filterE f e = e >>= \x -> guard (f x) >> return x -- -- fmap fst (withRestE e) = e -- calmE (join (duplicateE e)) = calmE e -- fmap (\(_, t) -> e `startAt` listE [((), t)]) (withTimeE e) = duplicateE e -- -- (e `untilE` a) <> (e `startAt` a) = e -- e `startAt` e = e -- e `startAt` a `startAt` a2 = e `startAt` (a >> a2) -- e `startAt` (e <> e2) = e -- e2 `startAt` (e <> e2) = e2 -- e `untilE` a `startAt` a2 = e `startAt` a2 `untilE` a -- -- delayE 0 e = e -- delayE t (delayE t2 e) = delayE (t + t2) e -- -- join (splitE e a) = startAt e a -- switchE (splitE e a) = startAt e a