{-# 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 (
-- * Derived event combinators
tick, untilE, eitherOf, holdE, zipE, simultE, intersectE, differenceE, unionE, filterE, justE, duplicateE, withPrev, calmE, count, takeE, dropE, once, everyNth, slowE, rests, startAt, splitE,
-- * Reactive behaviors
Behavior, extractB, duplicateB, time, switcher, stepper, snapshot, flipFlop, history, scanB, delayB, 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.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.AlternateEvent
import Data.Time.Clock.POSIX

-- | A convenience to generate a tick on a regular interval.
{-# INLINE tick #-}
tick time t = eventFromList (map (\t -> (t, t)) [time,time+t..])

-- | This functional can be used to terminate an event early.
{-# INLINE untilE #-}
untilE :: (EventStream e) => e t -> e u -> e t
untilE e u = switch (return e `mplus` fmap (const mzero) u)

{-# INLINE eitherOf #-}
eitherOf :: (Functor e, MonadPlus e) => e t -> e u -> e (Either t u)
eitherOf e e2 = fmap Left e `mplus` 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 :: (EventStream e) => e t -> e u -> u -> e (t, u)
holdE e e2 x = justE
	$ scan (\x ei -> either (\y -> (x, Just (y, x))) (\y2 -> (y2, Nothing)) 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
	$ scan (\(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 `mplus` 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 WithAtoms falses atomsoccurrences from 'e' are paired with 'N(E simultE #-)
simultE :: (EventStream e) => e t -> e u -> e (t, Maybe u)
simultE e a = justE
	$ scan (\(prev, ti) (ei, t) -> if ti < t then
			-- Discard old occurrences
			either
			(\y -> (([y], t), Nothing))
			(\x -> (([], t), Just (x, Nothing)))
			ei
		else
			-- Zip up occurrences at a single time
			either
			(\y -> ((prev ++ [y], t), Nothing))
			(\x -> case prev of { y:ys -> ((ys, t), Just (x, Just y)); [] -> (([], t), Just (x, Nothing)) })
			ei)
	([], 0)
	$ adjoinTime
	$ eitherOf a e

-- | Set-theoretical operations on event streams
{-# 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 :: (EventStream e, Monoid t) => e t -> e t -> e t
unionE e e2 = intersectE (fmap (<>) e) e2
	`mplus` differenceE e e2
	`mplus` differenceE e2 e

{-# INLINE filterE #-}
filterE f e = e >>= \x -> guard (f x) >> return x

{-# INLINE justE #-}
justE e = fmap fromJust (filterE isJust e)

{-# INLINE duplicateE #-}
duplicateE e = fmap (\(x, e) -> return x `mplus` e) (withRemainder e)

{-# INLINE withPrev #-}
withPrev e = justE $ scan (\may y -> (Just y, fmap (\x -> (x, y)) may)) Nothing e

-- | "Calms" an event stream so that only one event occurs at a given time.
{-# INLINE calmE #-}
calmE e = once e
	`mplus`
	fmap (fst . snd)
	(filterE (\((_, t), (_, t1)) -> t < t1)
	$ withPrev
	$ adjoinTime e)

{-# INLINE count #-}
count e = scan (\n x -> (n + 1, (x, n + 1))) 0 e

-- | Event versions of 'drop' and 'take'.
{-# INLINE dropE #-}
dropE n e = fmap fst $ filterE ((>n) . snd) $ count e

{-# INLINE takeE #-}
takeE :: (EventStream e, Num n, Ord n) => n -> e t -> e t
takeE n e = fmap fst $ filterE ((<=n) . snd) c where
	c = count e

{-# INLINE once #-}
once e = takeE 1 e

{-# INLINE everyNth #-}
everyNth :: (EventStream e, Num n, Ord n) => n -> e t -> e t
everyNth n =
	justE
	. scan (\i x -> if 1 + i >= n then
		(0, Just x)
	else
		(1 + i, Nothing))
	n

{-# INLINE slowE #-}
slowE x e = adjoinTime e >>= \(y, t) -> eventFromList [(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 (withRemainder 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 stream.
--   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 (withRemainder a)

{-# INLINE sumE #-}
sumE :: (Num t) => Event t -> Event t
sumE = scan (\x y -> let x' = x + y in (x', x')) 0

-------------------------------------------
-- Reactive behaviors

data Behavior e t = Switcher !(POSIXTime -> t) (e (POSIXTime -> t)) deriving Functor

{-# INLINE time #-}
time :: (MonadPlus e) => Behavior e POSIXTime
time = Switcher id mzero

{-# INLINE switcher #-} 
switcher (Switcher f e) e2 = Switcher f (switch $ return e `mplus` fmap (\(Switcher f e) -> return f `mplus` 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))
	$ adjoinTime
	$ holdE e e2 f

{-# INLINE flipFlop #-}
flipFlop e e2 = stepper False (fmap (const True) e `mplus` 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 constant 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 :: (EventStream e) => Double -> Behavior e t -> Behavior e (POSIXTime -> t)
history t (Switcher f e) = function
	<$> stepper [(f, 0)] windowFunctions
	<*> time where
	tCoerced = fromRational (toRational t)
	function ls t1 t2 = if t1 <= t2 then fst (head ls) t1
		else maybe (fst (last ls) (t1-tCoerced)) (($t2) . fst)
			$ find ((<=t2) . snd) ls
	windowFunctions = scan (\ls (f, t1) -> let ls' = (f, t1) : map fst (takeWhile ((>=t1-tCoerced) . snd . snd) $ zip ls $ tail ls) `using` evalList rseq in
		(ls, ls))
		[(f, 0)]
		$ adjoinTime e

-- | A scan for behaviors.
scanB :: (EventStream e) => Behavior e (t -> e t) -> t -> e t
scanB b x = return x `mplus` (snapshot (extractB b x) (duplicateB b) >>= uncurry (flip scanB))

_monoid :: (EventStream e, Monoid t) => e (Behavior e t) -> Behavior e t -> e (Behavior e t)
_monoid e b = return b `mplus` (snapshot (once (withRemainder e)) (duplicateB 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 :: (EventStream e, Monoid t) => e (Behavior e t) -> Behavior e t
monoid e = switcher mempty $ _monoid e mempty

-- | Each event occurrence casts a shadow for 't' seconds in the behavior.
{-# INLINE throttle #-}
throttle :: (EventStream e) => Double -> e t -> Behavior e (Maybe t)
throttle t e = fmap getLast $ monoid (fmap (\(x, ti) -> stepper (Last Nothing) (eventFromList [(Last (Just x), ti), (Last Nothing, tCoerce + ti)])) (adjoinTime e)) where
	tCoerce = fromRational (toRational t)

-- | Delay by 't' seconds before continuing as the behavior.
{-# INLINE delayB #-}
delayB t (Switcher f e) = Switcher (f . subtract t) (fmap (. subtract t) (delay 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 (EventStream e, Monoid t) => Monoid (Behavior e t) where
	mempty = pure mempty
	mappend e e2 = mappend <$> e <*> e2

instance (EventStream e) => Alternative (Behavior e) where
	empty = error "FRP.Reactivity.empty: use Monoid instead"
	(<|>) = error "FRP.Reactivity.<|>: use Monoid instead"

instance (EventStream e) => Applicative (Behavior e) where
	pure x = Switcher (const x) mzero
	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.
extractB (Switcher f _) = f 0

duplicateB (Switcher f e) = Switcher (\t -> Switcher (cutoff t f) e) (fmap (\(f, e) t -> Switcher (cutoff t f) e) (withRemainder e))

-------------------------------------------
-- Integration

epsilon = 0.0001

-- | Estimate the derivative of a behavior.
derivative :: (EventStream e, Real t, Fractional t) => Behavior e t -> Behavior e t
derivative b = (\x x1 -> (x1 - x) / fromRational (toRational epsilon)) <$> delayB epsilon b <*> b

-- | Adaptively supersample a behavior.
supersample :: (EventStream e, Real t, Fractional t) => Double -> Behavior e t -> e (POSIXTime, t)
supersample precision b = scanB
	((\t x deriv _ -> eventFromList [((t, x), if t < epsilon then t + epsilon else t + fromRational (toRational precision) / (1 + fromRational (toRational (abs deriv))))]) <$> time <*> b <*> derivative b)
	(0, extractB b)

-- | 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 :: (EventStream e, Real t, Fractional t) => Double -> Behavior e t -> t -> e Bool
threshold precision b x = justE
	$ scan (\gt (t, y) -> if gt == (y < x) then (not gt, Just (not gt)) else (gt, Nothing)) (extractB b > x)
	$ 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)-}