Combinators.hs

{-# 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, zipE, simultE, intersectE, differenceE, unionE, filterE, justE, duplicateE, withPrev, switchE, scanlE, calmE, count, takeE, dropE, delayE, slowE, rests, startAt, splitE,
-- * Reactive behaviors
Behavior, time, switcher, stepper, snapshot, flipFlop, history, scan, delay, slow, monoid, throttle, sumE, derivative, supersample, integral, threshold) 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

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

-- | 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

-- | The opposite of 'untilE', 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 ((<t1-t) . snd . snd) $ zip ls $ tail ls) `using` evalList rseq in
		(ls, ls, t1))
		[(f, 0)]
		e

-- | A scan for behaviors.
scan :: Behavior (t -> 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 (b <> 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 b = scan
	((\t x deriv _ -> list [((t, x), if t < epsilon then t + epsilon else t + fromRational (toRational $ 0.1 / (1 + abs deriv)))]) <$> time <*> b <*> derivative b)
	(extract b, 0)

-- | Integral of behaviors
integral b =
	-- Obtain the integral (trapezoidal integration)
	stepper 0
	$ sumE
	$ fmap (\((t, x), (t1, x1)) -> 0.5 * (x1 + x) * fromRational (toRational (t1 - t)))
	$ withPrev
	$ supersample 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 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 b

-------------------------------------------
-- Laws
--
-- mempty >>= f = mempty
-- (e <> e2) >>= f = (e >>= f) <> (e2 >>= f)
-- e <> e2 <> e3 = e <> (e2 <> e3)
-- mempty <> e = e
-- The monad laws
--
-- withTimeE (withTimeE e) = fmap (\(x, t) -> ((x, t), t)) (withTimeE e)
--
-- e `untilE` e = mempty
-- e `untilE` u `untilE` u2 = e `untilE` (u <> u2)
--
-- 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