-- Behavior primitives.

-- Implement behaviors roughly as in Pidgets++, with data-driven
-- invalidation and demand-driven, cached sampling.  Need to handle
-- continuous case, which requires some changes, but also want to optimize
-- the piecewise-constant case.

-- To extend to handle time transformation, events and behaviors will need
-- to be memoized functions from time transforms to "talkers" and
-- "performances", respectively.

-- To do:
--   + Efficient implementation of cond and other non-strict functions.
--     Don't propagate invalidation of the *then* (or *else*) behavior
--     while the condition is constant false (or true).
--   + Optimize for the case that an event has had its last occurrence,
--     and for neverE in particular.

\begin{code}
module BPrim where

import Maybe (isJust)
import IOExts
import Monad (when)
import Compatibility
import BaseTypes
import EventPrim
import Event
import FranTime
import Delayed

infixr 1 `stepper`, `switcherB`

infixr 0  $*

infixl 3 `snapshotFE`,`snapshotFL`
\end{code}

Sampling function, yielding a value and flag saying whether currently
constant.

\begin{code}
type Sampler a = Time -> IO (a, Bool)
\end{code}

-- A behavior is something that can be sampled, and has an "invalidation
-- event" that occurs whenever a constant segment ends.

\begin{code}
data Behavior a = Behavior (Sampler a) (Event ())

mkBehavior s e = Behavior s e

instance Show (Behavior a) where
  showsPrec _ _ = showString "<<behavior>>"


sample :: Behavior a -> Sampler a
sample (Behavior s _) = s

at :: Behavior a -> Time -> IO a
at b t = fmap fst $ sample b t

invalidateEv :: Behavior a -> Event ()
invalidateEv (Behavior _ e) = e
\end{code}

Some basic behaviors 
\begin{code}
-- An always constant behavior
constantB :: a -> Behavior a
constantB a = mkBehavior (const (return (a, True))) neverE 

-- The time behavior
time :: Behavior Time
time = mkBehavior (\ t -> return (t,False)) neverE 

-- function application with behaviors
($*) :: Behavior (a -> b) -> Behavior a -> Behavior b
fb $* xb = cachingBehavior sampler invalidate
 where
   sampler t  = do (f,fConst) <- fbAt t
                   (x,xConst) <- xbAt t
                   return (f x, fConst && xConst)
   fbAt = sample fb ; xbAt = sample xb
   invalidate = invalidateEv fb .|. invalidateEv xb

-- The first lifting  function
lift1 :: (a -> b) -> Behavior a -> Behavior b
lift1 f b = constantB f $* b
\end{code}


If we're not careful behaviors will be redundantly cached. To fix this
we use Behavior caching.

\begin{code}
-- Behavior cache.  Stashes sample time and result.
type BCache a = IORef (Time, (a,Bool))

newBCache :: IO (BCache a)
newBCache =
  newIORef (minTime, (error "Accessed undefined cache value", False))

cachingSampler :: BCache a -> Sampler a -> Sampler a
cachingSampler cache sampler t = do
  (tLast, p@(_, isConst)) <- readIORef cache
  if isConst || tLast==t then do
     return p
   else do
     p <- sampler t
     writeIORef cache (t,p)
     return p
\end{code}

We make a caching behavior from a sampler and invalidate event. At each invalidation, 
we check the cache. If it contains a constant value, we replace the sample time by 
the invalidation time and mark the cache as non-constant. 

There is a complication here. An event does not affect a behavior until immediately 
after the event occurrence. To handle this we clear the behavior cache just after 
the event, because other samples may occur between the invalidate event firing, 
and the actual change of the behavior. These samplings could set the cache back to 
constant, before the value of the behavior has changed, resulting in an incorrect 
result. We also assume that the time when the cache is sampled, is strictly later 
than the time when the cache is reset, otherwise the cache's value will still 
not be updated.

We can achieve this by updating the cache with the time when the invalidating event 
was fired, not when the delayed action is run. Finally, when created we must also 
add a delayed action that resets the cache to non-constant. This is because the 
same event that is used to invalidate the cache may also create a caching behavior. 
Clearly in this case the cache's value should change when the behavior changes. 
Unfortunately, the cache will have missed this occurrence of the invalidation event. 
If the cache is sampled before its behavior is updated, then we will again have 
an incorrect value in the cache. Adding the delayed action therefore solves 
this problem.

\begin{code}
cachingBehavior :: Sampler a -> Event () -> Behavior a
cachingBehavior sampler invalidate = 
  unsafePerformIO $ cachingBehaviorIO sampler invalidate 

cachingBehaviorIO :: Sampler a -> Event () -> IO (Behavior a)
cachingBehaviorIO sampler invalidate = do
   cache <- newBCache
 
   let reset cache _ = do
        te <- getFranTime
        addDelayedAction $ do
	 (tLast, (x, isConst)) <- readIORef cache
         when isConst $ writeIORef cache (te, (x, False))
      
   addWeakListener invalidate reset cache
   reset cache (minTime,undefined)
   return $ Behavior (cachingSampler cache sampler) invalidate
\end{code}

Reactive behaviors

It can be implemented as follows. The implementation stores the sampler action for 
the current behavior in a variable. The current behavior changes on every event 
occurrence. In particular, the semantics of switcherB say that the behavior 
switches immediately after the event occurrence. There might, however, be samplings
on the current time, still waiting to be done. We must therefore delay the
sampler replacement with addDelayedAction. The behavior constructed by switcherB may
have constant segments. We must define an appropriate invalidation event. There are
two possible reasons to invalidate the behavior. The first is if the switching 
event occurs. The second is if the constant segment of the current behavior ends. 
We define the second using switcherE. This produces an event which behaves as 
the current invalidation event.

\begin{code}
switcherB :: Behavior a -> Event (Behavior a) -> IO (Behavior a)
b0 `switcherB` e = do
  samplerRef <- newIORef (sample b0)
  let alter samplerRef b = do
	 addDelayedAction $ do
	   writeIORef samplerRef (sample b)
  addWeakListener e alter samplerRef
  invE <- cacheIO $ (e -=> () .|.
		        (invalidateEv b0 `switcherE'` (e ==> invalidateEv)))
  let sampler t = readIORef samplerRef >>= ($ t)
  return $ Behavior sampler invE
		    
stepper :: a -> Event a -> IO (Behavior a)
x0 `stepper` e = do
  samplerRef <- newIORef x0
  let alter samplerRef x = do
	 addDelayedAction $ do
	   writeIORef samplerRef x
  addWeakListener e alter samplerRef
  let sampler t = do 
        x <- readIORef samplerRef
        return (x,True)
  return $ Behavior sampler (e -=> ())

   
stepAccum :: a -> Event (a -> a) -> IO (Behavior a)
x0 `stepAccum` e = x0 `stepper` (accumE' x0 e)
\end{code}

Snapshotting behaviors

\begin{code}
snapshotFL :: (a -> Behavior b) -> Listener (a,b) -> Listener a
snapshotFL f = liftL1 $ \op (t,a) -> do
 (b,_) <- sample (f a) t
 op (t,(a,b))

snapshotFE :: Event a -> (a -> Behavior b) -> Event (a,b)
e `snapshotFE` f = cache (mapLE (snapshotFL f) e)
\end{code}

-- Tracing
\begin{code}
traceB :: Show a => String -> Behavior a -> Behavior a
traceB s (Behavior act e) = Behavior act' e
 where act' t = do
         v <- act t
         putStrLn $ "traceB " ++ s ++ ": " ++ show v
         return v
\end{code}
