{-# LANGUAGE Arrows #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
module FRP.BearRiver
(module FRP.BearRiver, module X)
where
import Control.Applicative
import Control.Arrow as X
import qualified Control.Category as Category
import Control.Monad (mapM)
import Control.Monad.Random
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.MSF hiding (switch)
import qualified Control.Monad.Trans.MSF as MSF
import Control.Monad.Trans.MSF.Except as MSF hiding
(switch)
import Control.Monad.Trans.MSF.List (sequenceS,
widthFirst)
import Control.Monad.Trans.MSF.Random
import Data.Functor.Identity
import Data.Maybe
import Data.MonadicStreamFunction as X hiding (reactimate,
repeatedly,
sum,
switch,
trace)
import qualified Data.MonadicStreamFunction as MSF
import Data.MonadicStreamFunction.Instances.ArrowLoop
import Data.MonadicStreamFunction.InternalCore
import Data.Traversable as T
import FRP.Yampa.VectorSpace as X
infixr 0 -->, -:>, >--, >=-
type Time = Double
type DTime = Double
type SF m = MSF (ClockInfo m)
type ClockInfo m = ReaderT DTime m
data Event a = Event a | NoEvent
deriving (Eq, Show)
arrPrim :: Monad m => (a -> b) -> SF m a b
arrPrim = arr
arrEPrim :: Monad m => (Event a -> b) -> SF m (Event a) b
arrEPrim = arr
identity :: Monad m => SF m a a
identity = Category.id
constant :: Monad m => b -> SF m a b
constant = arr . const
localTime :: Monad m => SF m a Time
localTime = constant 1.0 >>> integral
time :: Monad m => SF m a Time
time = localTime
(-->) :: Monad m => b -> SF m a b -> SF m a b
b0 --> sf = sf >>> replaceOnce b0
(-:>) :: Monad m => b -> SF m a b -> SF m a b
b -:> sf = iPost b sf
(>--) :: Monad m => a -> SF m a b -> SF m a b
a0 >-- sf = replaceOnce a0 >>> sf
(>=-) :: Monad m => (a -> a) -> SF m a b -> SF m a b
f >=- sf = MSF $ \a -> do
(b, sf') <- unMSF sf (f a)
return (b, sf')
initially :: Monad m => a -> SF m a a
initially = (--> identity)
sscan :: Monad m => (b -> a -> b) -> b -> SF m a b
sscan f b_init = feedback b_init u
where u = undefined
sscanPrim :: Monad m => (c -> a -> Maybe (c, b)) -> c -> b -> SF m a b
sscanPrim f c_init b_init = MSF $ \a -> do
let o = f c_init a
case o of
Nothing -> return (b_init, sscanPrim f c_init b_init)
Just (c', b') -> return (b', sscanPrim f c' b')
never :: Monad m => SF m a (Event b)
never = constant NoEvent
now :: Monad m => b -> SF m a (Event b)
now b0 = Event b0 --> never
after :: Monad m
=> Time
-> b
-> SF m a (Event b)
after q x = feedback q go
where go = MSF $ \(_, t) -> do
dt <- ask
let t' = t - dt
e = if t > 0 && t' < 0 then Event x else NoEvent
ct = if t' < 0 then constant (NoEvent, t') else go
return ((e, t'), ct)
repeatedly :: Monad m => Time -> b -> SF m a (Event b)
repeatedly q x
| q > 0 = afterEach qxs
| otherwise = error "bearriver: repeatedly: Non-positive period."
where
qxs = (q,x):qxs
afterEach :: Monad m => [(Time,b)] -> SF m a (Event b)
afterEach qxs = afterEachCat qxs >>> arr (fmap head)
afterEachCat :: Monad m => [(Time,b)] -> SF m a (Event [b])
afterEachCat = afterEachCat' 0
where
afterEachCat' :: Monad m => Time -> [(Time,b)] -> SF m a (Event [b])
afterEachCat' _ [] = never
afterEachCat' t qxs = MSF $ \_ -> do
dt <- ask
let t' = t + dt
(qxsNow, qxsLater) = span (\p -> fst p <= t') qxs
ev = if null qxsNow then NoEvent else Event (map snd qxsNow)
return (ev, afterEachCat' t' qxsLater)
instance Functor Event where
fmap f NoEvent = NoEvent
fmap f (Event c) = Event (f c)
instance Applicative Event where
pure = Event
Event f <*> Event x = Event (f x)
_ <*> _ = NoEvent
mapEventS :: Monad m => MSF m a b -> MSF m (Event a) (Event b)
mapEventS msf = proc eventA -> case eventA of
Event a -> arr Event <<< msf -< a
NoEvent -> returnA -< NoEvent
eventToMaybe = event Nothing Just
boolToEvent :: Bool -> Event ()
boolToEvent True = Event ()
boolToEvent False = NoEvent
edge :: Monad m => SF m Bool (Event ())
edge = edgeFrom True
iEdge :: Monad m => Bool -> SF m Bool (Event ())
iEdge = edgeFrom
edgeTag :: Monad m => a -> SF m Bool (Event a)
edgeTag a = edge >>> arr (`tag` a)
edgeJust :: Monad m => SF m (Maybe a) (Event a)
edgeJust = edgeBy isJustEdge (Just undefined)
where
isJustEdge Nothing Nothing = Nothing
isJustEdge Nothing ma@(Just _) = ma
isJustEdge (Just _) (Just _) = Nothing
isJustEdge (Just _) Nothing = Nothing
edgeBy :: Monad m => (a -> a -> Maybe b) -> a -> SF m a (Event b)
edgeBy isEdge a_prev = MSF $ \a ->
return (maybeToEvent (isEdge a_prev a), edgeBy isEdge a)
maybeToEvent :: Maybe a -> Event a
maybeToEvent = maybe NoEvent Event
edgeFrom :: Monad m => Bool -> SF m Bool (Event())
edgeFrom prev = MSF $ \a -> do
let res | prev = NoEvent
| a = Event ()
| otherwise = NoEvent
ct = edgeFrom a
return (res, ct)
notYet :: Monad m => SF m (Event a) (Event a)
notYet = feedback False $ arr (\(e,c) ->
if c then (e, True) else (NoEvent, True))
once :: Monad m => SF m (Event a) (Event a)
once = takeEvents 1
takeEvents :: Monad m => Int -> SF m (Event a) (Event a)
takeEvents n | n <= 0 = never
takeEvents n = dSwitch (arr dup) (const (NoEvent >-- takeEvents (n - 1)))
dropEvents :: Monad m => Int -> SF m (Event a) (Event a)
dropEvents n | n <= 0 = identity
dropEvents n = dSwitch (never &&& identity)
(const (NoEvent >-- dropEvents (n - 1)))
noEvent :: Event a
noEvent = NoEvent
noEventFst :: (Event a, b) -> (Event c, b)
noEventFst (_, b) = (NoEvent, b)
noEventSnd :: (a, Event b) -> (a, Event c)
noEventSnd (a, _) = (a, NoEvent)
event :: a -> (b -> a) -> Event b -> a
event _ f (Event x) = f x
event x _ NoEvent = x
fromEvent (Event x) = x
fromEvent _ = error "fromEvent NoEvent"
isEvent (Event _) = True
isEvent _ = False
isNoEvent (Event _) = False
isNoEvent _ = True
tag :: Event a -> b -> Event b
tag NoEvent _ = NoEvent
tag (Event _) b = Event b
tagWith :: b -> Event a -> Event b
tagWith = flip tag
attach :: Event a -> b -> Event (a, b)
e `attach` b = fmap (\a -> (a, b)) e
lMerge :: Event a -> Event a -> Event a
lMerge = mergeBy (\e1 _ -> e1)
rMerge :: Event a -> Event a -> Event a
rMerge = flip lMerge
merge :: Event a -> Event a -> Event a
merge = mergeBy $ error "Bearriver: merge: Simultaneous event occurrence."
mergeBy :: (a -> a -> a) -> Event a -> Event a -> Event a
mergeBy _ NoEvent NoEvent = NoEvent
mergeBy _ le@(Event _) NoEvent = le
mergeBy _ NoEvent re@(Event _) = re
mergeBy resolve (Event l) (Event r) = Event (resolve l r)
mapMerge :: (a -> c) -> (b -> c) -> (a -> b -> c)
-> Event a -> Event b -> Event c
mapMerge _ _ _ NoEvent NoEvent = NoEvent
mapMerge lf _ _ (Event l) NoEvent = Event (lf l)
mapMerge _ rf _ NoEvent (Event r) = Event (rf r)
mapMerge _ _ lrf (Event l) (Event r) = Event (lrf l r)
mergeEvents :: [Event a] -> Event a
mergeEvents = foldr lMerge NoEvent
catEvents :: [Event a] -> Event [a]
catEvents eas = case [ a | Event a <- eas ] of
[] -> NoEvent
as -> Event as
joinE :: Event a -> Event b -> Event (a,b)
joinE NoEvent _ = NoEvent
joinE _ NoEvent = NoEvent
joinE (Event l) (Event r) = Event (l,r)
splitE :: Event (a,b) -> (Event a, Event b)
splitE NoEvent = (NoEvent, NoEvent)
splitE (Event (a,b)) = (Event a, Event b)
filterE :: (a -> Bool) -> Event a -> Event a
filterE p e@(Event a) = if p a then e else NoEvent
filterE _ NoEvent = NoEvent
mapFilterE :: (a -> Maybe b) -> Event a -> Event b
mapFilterE _ NoEvent = NoEvent
mapFilterE f (Event a) = case f a of
Nothing -> NoEvent
Just b -> Event b
gate :: Event a -> Bool -> Event a
_ `gate` False = NoEvent
e `gate` True = e
switch :: Monad m => SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b
switch sf sfC = MSF $ \a -> do
(o, ct) <- unMSF sf a
case o of
(_, Event c) -> unMSF (sfC c) a
(b, NoEvent) -> return (b, switch ct sfC)
dSwitch :: Monad m => SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b
dSwitch sf sfC = MSF $ \a -> do
(o, ct) <- unMSF sf a
case o of
(b, Event c) -> do (_,ct') <- unMSF (sfC c) a
return (b, ct')
(b, NoEvent) -> return (b, dSwitch ct sfC)
#if MIN_VERSION_base(4,8,0)
parB :: (Monad m) => [SF m a b] -> SF m a [b]
#else
parB :: (Functor m, Monad m) => [SF m a b] -> SF m a [b]
#endif
parB = widthFirst . sequenceS
dpSwitchB :: (Monad m , Traversable col)
=> col (SF m a b) -> SF m (a, col b) (Event c) -> (col (SF m a b) -> c -> SF m a (col b))
-> SF m a (col b)
dpSwitchB sfs sfF sfCs = MSF $ \a -> do
res <- T.mapM (`unMSF` a) sfs
let bs = fmap fst res
sfs' = fmap snd res
(e,sfF') <- unMSF sfF (a, bs)
let ct = case e of
Event c -> sfCs sfs' c
NoEvent -> dpSwitchB sfs' sfF' sfCs
return (bs, ct)
parC :: Monad m => SF m a b -> SF m [a] [b]
parC sf = parC' [sf]
parC' :: Monad m => [SF m a b] -> SF m [a] [b]
parC' sfs = MSF $ \as -> do
os <- T.mapM (\(a,sf) -> unMSF sf a) $ zip as sfs
let bs = fmap fst os
cts = fmap snd os
return (bs, parC' cts)
hold :: Monad m => a -> SF m (Event a) a
hold a = feedback a $ arr $ \(e,a') ->
dup (event a' id e)
where
dup x = (x,x)
accumBy :: Monad m => (b -> a -> b) -> b -> SF m (Event a) (Event b)
accumBy f b = mapEventS $ accumulateWith (flip f) b
accumHoldBy :: Monad m => (b -> a -> b) -> b -> SF m (Event a) b
accumHoldBy f b = feedback b $ arr $ \(a, b') ->
let b'' = event b' (f b') a
in (b'', b'')
loopPre :: Monad m => c -> SF m (a, c) (b, c) -> SF m a b
loopPre = feedback
integral :: (Monad m, VectorSpace a s) => SF m a a
integral = integralFrom zeroVector
integralFrom :: (Monad m, VectorSpace a s) => a -> SF m a a
integralFrom a0 = proc a -> do
dt <- constM ask -< ()
accumulateWith (^+^) a0 -< realToFrac dt *^ a
derivative :: (Monad m, VectorSpace a s) => SF m a a
derivative = derivativeFrom zeroVector
derivativeFrom :: (Monad m, VectorSpace a s) => a -> SF m a a
derivativeFrom a0 = proc a -> do
dt <- constM ask -< ()
aOld <- MSF.iPre a0 -< a
returnA -< (a ^-^ aOld) ^/ realToFrac dt
iterFrom :: Monad m => (a -> a -> DTime -> b -> b) -> b -> SF m a b
iterFrom f b = MSF $ \a -> do
dt <- ask
let b' = f a a dt b
return (b, iterFrom f b')
occasionally :: MonadRandom m
=> Time
-> b
-> SF m a (Event b)
occasionally tAvg b
| tAvg <= 0 = error "bearriver: Non-positive average interval in occasionally."
| otherwise = proc _ -> do
r <- getRandomRS (0, 1) -< ()
dt <- timeDelta -< ()
let p = 1 - exp (-(dt / tAvg))
returnA -< if r < p then Event b else NoEvent
where
timeDelta :: Monad m => SF m a DTime
timeDelta = constM ask
reactimate :: Monad m => m a -> (Bool -> m (DTime, Maybe a)) -> (Bool -> b -> m Bool) -> SF Identity a b -> m ()
reactimate senseI sense actuate sf = do
MSF.reactimateB $ senseSF >>> sfIO >>> actuateSF
return ()
where sfIO = morphS (return.runIdentity) (runReaderS sf)
senseSF = switch senseFirst senseRest
senseFirst = constM senseI >>> (arr $ \x -> ((0, x), Event x))
senseRest a = constM (sense True) >>> (arr id *** keepLast a)
keepLast :: Monad m => a -> MSF m (Maybe a) a
keepLast a = MSF $ \ma -> let a' = fromMaybe a ma in return (a', keepLast a')
actuateSF = arr (\x -> (True, x)) >>> arrM (uncurry actuate)
switch sf sfC = MSF.switch (sf >>> second (arr eventToMaybe)) sfC
evalAtZero :: SF Identity a b -> a -> (b, SF Identity a b)
evalAtZero sf a = runIdentity $ runReaderT (unMSF sf a) 0
evalAt :: SF Identity a b -> DTime -> a -> (b, SF Identity a b)
evalAt sf dt a = runIdentity $ runReaderT (unMSF sf a) dt
evalFuture :: SF Identity a b -> a -> DTime -> (b, SF Identity a b)
evalFuture sf = flip (evalAt sf)
replaceOnce :: Monad m => a -> SF m a a
replaceOnce a = dSwitch (arr $ const (a, Event ())) (const $ arr id)
dup x = (x,x)