{-# LANGUAGE RebindableSyntax, GeneralizedNewtypeDeriving, TupleSections, FlexibleInstances, MultiParamTypeClasses, RankNTypes, ViewPatterns #-}
module Data.Reactive (
  -- * Reactive Modules
  module Algebra.Time,

  -- * Reactive Events
  Event,_event,headE,Reactive(..),

  -- ** Contructing events
  atTimes,mkEvent,
  withTime,times,times',
  mapFutures,

  -- ** Combining events
  (//),(<|*>),(<*|>),
               
  -- ** Filtering events
  groupE,mask,

  -- ** Real-world event synchronization
  realize,realtime,realizeRT,eventMay,event,react,react2,react3,
  
  -- * Future values
  Future,_future,_time,_value,futureIO,
  ) where

import Algebra
import Control.Concurrent
import Data.TimeVal
import System.IO.Unsafe (unsafeInterleaveIO)
import Data.List (group)
import Algebra.Time

-- |An event (a list of time-value pairs of increasing times)
newtype Event t a = Event { getEvent :: (OrdList:.:Future t) a }
                  deriving (Unit,Functor,Foldable,Traversable)
data Reactive t a = Reactive a (Event t a)
instance Ord t => Unit (Reactive t) where
  pure a = Reactive a zero
instance Functor (Reactive t) where 
  map f (Reactive a e) = Reactive (f a) (map f e)
instance Ord t => Applicative (Reactive t) where
  Reactive f fs <*> Reactive x xs = Reactive (f x) (cons f fs<*>cons x xs)
    where cons a = _event %%~ ((minBound,a)^._future :)

instance (Ord t,Show t,Show a) => Show (Event t a) where show = show . yb _event
instance Ord t => Semigroup (Event t a) where
  (+) = (++)^.(_event<.>_event<.>_event)
    where (x:xt) ++ (y:yt) = a : zs
            where (a,b,sw) = inOrder x y
                  zs | b==maxBound = if sw then xt else yt
                     | sw = xt ++ (y:yt)
                     | otherwise = (x:xt) ++ yt
          a ++ [] = a
          [] ++ b = b
instance Ord t => Monoid (Event t a) where
  zero = [(maxBound,undefined)]^.mapping _future._event
instance Ord t => Applicative (Event t) where
  fe@(yb _event -> ff:_) <*> xe@(yb _event -> fx:_) =
    ste & traverse (by state) & yb state & map snd & \st ->
    br (ff^._time + fx^._time) (st (ff^._value,fx^._value))
    where ste = map (\f (_,x) -> ((f,x),f x)) fe
              + map (\x (f,_) -> ((f,x),f x)) xe
          br t (yb _event -> e) = uniq (map (_time %- t) b + a)^._event
            where (b,a) = span (\f -> f^._time<t) e
                  uniq = map last . group
  _ <*> _ = zero
instance Ord t => Monad (Event t) where
  join = _event %%~ merge . map2 (yb _event)
    where
      merge [] = []
      merge [t] = t^._value
      merge (xs:ys:t) = xi + merge ((ys&_value%~add xe) : t) & _head._time%~(tx+)
        where add = warp2 _OrdList (+)
              (tx,(xi,xe)) = xs^.._future & _2%~break (ltFut ys)
type EventRep t a = OrdList (Future t a)
_Event :: Iso (Event t a) (Event t' b) (EventRep t a) (EventRep t' b)
_Event = _Compose.iso Event getEvent
_event :: Iso (Event t a) (Event t' b) [Future t a] [Future t' b]
_event = _OrdList._Event
atTimes :: [t] -> Event t ()
atTimes ts = (ts <&> \t -> (pure t,())^._future)^._event
mkEvent :: [(t,a)] -> Event t a
mkEvent as = (as <&> by _future . (_1 %~ pure))^._event

{-| The \'splice\' operator. Occurs when @a@ occurs.

> by t: a // b = (a,before t: b)
-}
(//) :: Ord t => Event t a -> Event t b -> Event t (a, Event t b)
ea // eb = mapAccum_ fun (ea^.._event) (eb^.._event) ^. _event
  where fun a bs = (ys,a & _value %~ (,xs^._event))
          where (xs,ys) = span (flip ltFut a) bs
infixl 1 //

{-|
The \'over\' operator. Occurs only when @a@ occurs.

> by t: a <|*> (bi,b) = a <*> (minBound,bi):b
-}
(<*|>) :: Ord t => Event t (a -> b) -> Reactive t a -> Event t b
ef <*|> Reactive a ea = (traverse tr (ef // ea) ^.. state <&> snd) a
  where tr (f,as) = traverse_ put as >> f<$>get
infixl 1 <*|>
(<|*>) :: Ord t => Reactive t (a -> b) -> Event t a -> Event t b
f <|*> a = (&)<$>a<*|>f
infixr 1 <|*>

-- |Group the occurences of an event by equality. Occurs when the first occurence of a group occurs. 
groupE :: (Eq a, Ord t) => Event t a -> Event t (Event t a)
groupE = _event %%~ group_ . (+repeat (Future (maxBound,undefined)))
  where group_ fs = (f & _value %- (xs^._event))
                    : (z & _time %~ (sum_ (by _time<$>xs)+)):zs
          where (xs,ys) = span ((==f^._value) . by _value) fs ; f = head fs
                ~(z:zs) = group_ ys
                sum_ = foldl' (+) zero
headE :: Event t a -> a
headE = by _value . head . yb _event

mapFutures :: (Future t a -> Future t' b) -> Event t a -> Event t' b
mapFutures f = _event %%~ map f
withTime :: Ord t => Event t a -> Event t (Time t,a)
withTime = mapFutures (_future %%~ listen)
times :: Ord t => Event t a -> Event t (Time t)
times = map2 fst withTime
times' :: (Ord t,Monoid t) => Event t a -> Event t t
times' = map2 (fold . timeVal) times

mask :: Ord t => Event t Bool -> Event t a -> Event t a
mask m ea = (m // ea) `withNext` (True,zero) >>= \((b,_),(_,a)) -> guard b >> a

-- |Sinks an action event into the Real World. Actions are evaluated
-- as closely to their specified time as possible. However, they are
-- all executed in order, even if it means delaying the next action
-- further than its required time. For real-time realization of
-- events, see the 'realizeRT' function
realize :: Event Seconds (IO ()) -> IO ()
realize l = traverse_ (sink_ . first timeVal) (withTime l)
  where sink_ (Since t,v) = waitTill t >> v
        sink_ (Always,v) = v
        sink_ (Never,_) = unit

-- |Creates a real-time action event (an event that skips "frames" as needed) from an ordinary event.
realtime :: Event Seconds (IO ()) -> Event Seconds (IO ())
realtime e = (e & flip withNext (maxBound,undefined).withTime) <&> \((_,m),(t,_)) -> do
  c <- currentTime
  when (pure c<t) m
        
-- |Sinks a frame event into the real-world, skipping frames if they come
-- too late, thus always performing the frame closest to the current time.
realizeRT :: Event Seconds (IO ()) -> IO ()
realizeRT = realize . realtime

eventMay :: IO (Maybe a) -> IO (Event Seconds a)
eventMay m = by _event <$> do
  c <- newChan
  sem <- newEmptyMVar
  _ <- forkIO $ do
    while $ do
      a <- newEmptyMVar
      writeChan c a
      foldMap (const True)<$>(m <*= maybe unit (putMVar a))
    putMVar sem ()
  let event' ~(a:as) = unsafeInterleaveIO $ do
        (:)<$>futureIO (takeMVar a)<*>event' as
  (event' =<< getChanContents c) <*= \e -> do
    t <- forkIO $ traverse_ (yb thunk . timeVal . by _time) e
    forkIO (takeMVar sem <* killThread t)
event :: IO a -> IO (Event Seconds a)
event = eventMay . try (pure Nothing) . map Just
react :: IO a -> (Event Seconds a -> IO (Event Seconds (IO ()))) -> IO ()
react a f = realize =<< join (f<$>event a)
react2 :: IO a -> IO b -> (Event Seconds a -> Event Seconds b -> IO (Event Seconds (IO ()))) -> IO ()
react2 a b f = realize =<< join (f<$>event a<*>event b)
react3 :: IO a -> IO b -> IO c -> (Event Seconds a -> Event Seconds b -> Event Seconds c -> IO (Event Seconds (IO ()))) -> IO ()
react3 a b c f = realize =<< join (f<$>event a<*>event b<*>event c)

-- |A Future value (a value with a timestamp)
newtype Future t a = Future (Time t,a)
                   deriving (Show,Functor,Unit,Applicative,Traversable,Foldable,Monad,Semigroup,Monoid)
instance Ord t => Eq (Future t a) where f == f' = compare f f'==EQ
instance Ord t => Ord (Future t a) where compare = cmpFut
instance Ord t => Bounded (Future t a) where
  minBound = (minBound,undefined)^._future
  maxBound = (maxBound,undefined)^._future
instance Ord t => Orderable (Future t a) where
  inOrder (Future (t,a)) (Future (t',b)) = (Future (tx,x),Future (ty,y),z)
    where (tx,ty,z) = inOrder t t'
          ~(x,y) = if z then (a,b) else (b,a)
_future :: Iso (Future t a) (Future t' b) (Time t,a) (Time t',b)
_future = iso Future (\(Future ~(t,a)) -> (t,a))
_time :: Lens (Time t) (Time t') (Future t a) (Future t' a)
_time = from _future._1
_value :: Lens a b (Future t a) (Future t b)
_value = from _future._2

cmpFut :: Ord t => Future t a -> Future t b -> Ordering
cmpFut a b = compare (a^._time) (b^._time)
ltFut :: Ord t => Future t a -> Future t b -> Bool
ltFut a b = cmpFut a b == LT

futureIO :: IO a -> IO (Future Seconds a)
futureIO m = do
  val <- newEmptyMVar
  _ <- forkIO $ putMVar val =<< m 
  time <- timeIO (readMVar val)
  return (Future (time,try (return undefined) (readMVar val)^.thunk))