{-# LANGUAGE Arrows #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
#if __GLASGOW_HASKELL__ < 800
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
#else
{-# OPTIONS_GHC -Wno-deprecations #-}
#endif
{-# OPTIONS_HADDOCK ignore-exports #-}
module FRP.BearRiver
(module FRP.BearRiver, module X)
where
import Control.Arrow as X
import Control.Monad.Random (MonadRandom)
import Data.Functor.Identity (Identity (..))
import Data.Maybe (fromMaybe)
import Data.VectorSpace as X
import Control.Monad.Trans.MSF hiding (dSwitch)
import qualified Control.Monad.Trans.MSF as MSF
import Data.MonadicStreamFunction as X hiding (iPre,
once, reactimate,
repeatedly,
switch, trace)
import qualified Data.MonadicStreamFunction as MSF
import Data.MonadicStreamFunction.InternalCore (MSF (MSF, unMSF))
import FRP.BearRiver.Arrow as X
import FRP.BearRiver.Basic as X
import FRP.BearRiver.Conditional as X
import FRP.BearRiver.Delays as X
import FRP.BearRiver.Event as X
import FRP.BearRiver.EventS as X
import FRP.BearRiver.InternalCore as X
import FRP.BearRiver.Scan as X
import FRP.BearRiver.Switches as X
import Data.MonadicStreamFunction.Instances.ArrowLoop ()
localTime :: Monad m => SF m a Time
localTime :: forall (m :: * -> *) a. Monad m => SF m a Time
localTime = forall (m :: * -> *) b a. Monad m => b -> SF m a b
constant Time
1.0 forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (m :: * -> *) s a.
(Monad m, Fractional s, VectorSpace a s) =>
SF m a a
integral
time :: Monad m => SF m a Time
time :: forall (m :: * -> *) a. Monad m => SF m a Time
time = forall (m :: * -> *) a. Monad m => SF m a Time
localTime
mapEventS :: Monad m => MSF m a b -> MSF m (Event a) (Event b)
mapEventS :: forall (m :: * -> *) a b.
Monad m =>
MSF m a b -> MSF m (Event a) (Event b)
mapEventS MSF m a b
msf = proc Event a
eventA -> case Event a
eventA of
Event a
a -> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a. a -> Event a
Event forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< MSF m a b
msf -< a
a
Event a
NoEvent -> forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< forall a. Event a
NoEvent
eventToMaybe :: Event a -> Maybe a
eventToMaybe :: forall a. Event a -> Maybe a
eventToMaybe = forall a b. a -> (b -> a) -> Event b -> a
event forall a. Maybe a
Nothing forall a. a -> Maybe a
Just
boolToEvent :: Bool -> Event ()
boolToEvent :: Bool -> Event ()
boolToEvent Bool
True = forall a. a -> Event a
Event ()
boolToEvent Bool
False = forall a. Event a
NoEvent
hold :: Monad m => a -> SF m (Event a) a
hold :: forall (m :: * -> *) a. Monad m => a -> SF m (Event a) a
hold a
a = forall (m :: * -> *) c a b.
Monad m =>
c -> MSF m (a, c) (b, c) -> MSF m a b
feedback a
a forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a b. (a -> b) -> a -> b
$ \(Event a
e, a
a') ->
forall a. a -> (a, a)
dup (forall a b. a -> (b -> a) -> Event b -> a
event a
a' forall a. a -> a
id Event a
e)
accumBy :: Monad m => (b -> a -> b) -> b -> SF m (Event a) (Event b)
accumBy :: forall (m :: * -> *) b a.
Monad m =>
(b -> a -> b) -> b -> SF m (Event a) (Event b)
accumBy b -> a -> b
f b
b = forall (m :: * -> *) a b.
Monad m =>
MSF m a b -> MSF m (Event a) (Event b)
mapEventS forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a s.
Monad m =>
(a -> s -> s) -> s -> MSF m a s
accumulateWith (forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> a -> b
f) b
b
accumHoldBy :: Monad m => (b -> a -> b) -> b -> SF m (Event a) b
accumHoldBy :: forall (m :: * -> *) b a.
Monad m =>
(b -> a -> b) -> b -> SF m (Event a) b
accumHoldBy b -> a -> b
f b
b = forall (m :: * -> *) c a b.
Monad m =>
c -> MSF m (a, c) (b, c) -> MSF m a b
feedback b
b forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a b. (a -> b) -> a -> b
$ \(Event a
a, b
b') ->
let b'' :: b
b'' = forall a b. a -> (b -> a) -> Event b -> a
event b
b' (b -> a -> b
f b
b') Event a
a
in (b
b'', b
b'')
loopPre :: Monad m => c -> SF m (a, c) (b, c) -> SF m a b
loopPre :: forall (m :: * -> *) c a b.
Monad m =>
c -> SF m (a, c) (b, c) -> SF m a b
loopPre = forall (m :: * -> *) c a b.
Monad m =>
c -> MSF m (a, c) (b, c) -> MSF m a b
feedback
integral :: (Monad m, Fractional s, VectorSpace a s) => SF m a a
integral :: forall (m :: * -> *) s a.
(Monad m, Fractional s, VectorSpace a s) =>
SF m a a
integral = forall (m :: * -> *) s a.
(Monad m, Fractional s, VectorSpace a s) =>
a -> SF m a a
integralFrom forall v a. VectorSpace v a => v
zeroVector
integralFrom :: (Monad m, Fractional s, VectorSpace a s) => a -> SF m a a
integralFrom :: forall (m :: * -> *) s a.
(Monad m, Fractional s, VectorSpace a s) =>
a -> SF m a a
integralFrom a
a0 = proc a
a -> do
Time
dt <- forall (m :: * -> *) b a. Monad m => m b -> MSF m a b
constM forall (m :: * -> *) r. Monad m => ReaderT r m r
ask -< ()
forall (m :: * -> *) a s.
Monad m =>
(a -> s -> s) -> s -> MSF m a s
accumulateWith forall v a. VectorSpace v a => v -> v -> v
(^+^) a
a0 -< forall a b. (Real a, Fractional b) => a -> b
realToFrac Time
dt forall v a. VectorSpace v a => a -> v -> v
*^ a
a
derivative :: (Monad m, Fractional s, VectorSpace a s) => SF m a a
derivative :: forall (m :: * -> *) s a.
(Monad m, Fractional s, VectorSpace a s) =>
SF m a a
derivative = forall (m :: * -> *) s a.
(Monad m, Fractional s, VectorSpace a s) =>
a -> SF m a a
derivativeFrom forall v a. VectorSpace v a => v
zeroVector
derivativeFrom :: (Monad m, Fractional s, VectorSpace a s) => a -> SF m a a
derivativeFrom :: forall (m :: * -> *) s a.
(Monad m, Fractional s, VectorSpace a s) =>
a -> SF m a a
derivativeFrom a
a0 = proc a
a -> do
Time
dt <- forall (m :: * -> *) b a. Monad m => m b -> MSF m a b
constM forall (m :: * -> *) r. Monad m => ReaderT r m r
ask -< ()
a
aOld <- forall (m :: * -> *) a. Monad m => a -> MSF m a a
MSF.iPre a
a0 -< a
a
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< (a
a forall v a. VectorSpace v a => v -> v -> v
^-^ a
aOld) forall v a. VectorSpace v a => v -> a -> v
^/ forall a b. (Real a, Fractional b) => a -> b
realToFrac Time
dt
iterFrom :: Monad m => (a -> a -> DTime -> b -> b) -> b -> SF m a b
iterFrom :: forall (m :: * -> *) a b.
Monad m =>
(a -> a -> Time -> b -> b) -> b -> SF m a b
iterFrom a -> a -> Time -> b -> b
f b
b = forall (m :: * -> *) a b. (a -> m (b, MSF m a b)) -> MSF m a b
MSF forall a b. (a -> b) -> a -> b
$ \a
a -> do
Time
dt <- forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
let b' :: b
b' = a -> a -> Time -> b -> b
f a
a a
a Time
dt b
b
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, forall (m :: * -> *) a b.
Monad m =>
(a -> a -> Time -> b -> b) -> b -> SF m a b
iterFrom a -> a -> Time -> b -> b
f b
b')
occasionally :: MonadRandom m
=> Time
-> b
-> SF m a (Event b)
occasionally :: forall (m :: * -> *) b a.
MonadRandom m =>
Time -> b -> SF m a (Event b)
occasionally Time
tAvg b
b
| Time
tAvg forall a. Ord a => a -> a -> Bool
<= Time
0
= forall a. HasCallStack => [Char] -> a
error [Char]
"bearriver: Non-positive average interval in occasionally."
| Bool
otherwise = proc a
_ -> do
Time
r <- forall (m :: * -> *) b a.
(MonadRandom m, Random b) =>
(b, b) -> MSF m a b
getRandomRS (Time
0, Time
1) -< ()
Time
dt <- forall (m :: * -> *) a. Monad m => SF m a Time
timeDelta -< ()
let p :: Time
p = Time
1 forall a. Num a => a -> a -> a
- forall a. Floating a => a -> a
exp (-(Time
dt forall a. Fractional a => a -> a -> a
/ Time
tAvg))
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< if Time
r forall a. Ord a => a -> a -> Bool
< Time
p then forall a. a -> Event a
Event b
b else forall a. Event a
NoEvent
where
timeDelta :: Monad m => SF m a DTime
timeDelta :: forall (m :: * -> *) a. Monad m => SF m a Time
timeDelta = forall (m :: * -> *) b a. Monad m => m b -> MSF m a b
constM forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
reactimate :: Monad m
=> m a
-> (Bool -> m (DTime, Maybe a))
-> (Bool -> b -> m Bool)
-> SF Identity a b
-> m ()
reactimate :: forall (m :: * -> *) a b.
Monad m =>
m a
-> (Bool -> m (Time, Maybe a))
-> (Bool -> b -> m Bool)
-> SF Identity a b
-> m ()
reactimate m a
senseI Bool -> m (Time, Maybe a)
sense Bool -> b -> m Bool
actuate SF Identity a b
sf = do
forall (m :: * -> *). Monad m => MSF m () Bool -> m ()
MSF.reactimateB forall a b. (a -> b) -> a -> b
$ forall {a}. MSF m a (Time, a)
senseSF forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> MSF m (Time, a) b
sfIO forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> MSF m b Bool
actuateSF
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
sfIO :: MSF m (Time, a) b
sfIO = forall (m2 :: * -> *) (m1 :: * -> *) a b.
(Monad m2, Monad m1) =>
(forall c. m1 c -> m2 c) -> MSF m1 a b -> MSF m2 a b
morphS (forall (m :: * -> *) a. Monad m => a -> m a
returnforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Identity a -> a
runIdentity) (forall (m :: * -> *) r a b.
Monad m =>
MSF (ReaderT r m) a b -> MSF m (r, a) b
runReaderS SF Identity a b
sf)
senseSF :: MSF m a (Time, a)
senseSF = forall (m :: * -> *) a b c.
Monad m =>
MSF m a (b, Maybe c) -> (c -> MSF m a b) -> MSF m a b
MSF.dSwitch forall {a}. MSF m a ((Time, a), Maybe a)
senseFirst forall {a}. a -> MSF m a (Time, a)
senseRest
senseFirst :: MSF m a ((Time, a), Maybe a)
senseFirst = forall (m :: * -> *) b a. Monad m => m b -> MSF m a b
constM m a
senseI forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\a
x -> ((Time
0, a
x), forall a. a -> Maybe a
Just a
x))
senseRest :: a -> MSF m a (Time, a)
senseRest a
a = forall (m :: * -> *) b a. Monad m => m b -> MSF m a b
constM (Bool -> m (Time, Maybe a)
sense Bool
True) forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a. a -> a
id forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** forall (m :: * -> *) a. Monad m => a -> MSF m (Maybe a) a
keepLast a
a)
keepLast :: Monad m => a -> MSF m (Maybe a) a
keepLast :: forall (m :: * -> *) a. Monad m => a -> MSF m (Maybe a) a
keepLast a
a = forall (m :: * -> *) a b. (a -> m (b, MSF m a b)) -> MSF m a b
MSF forall a b. (a -> b) -> a -> b
$ \Maybe a
ma ->
let a' :: a
a' = forall a. a -> Maybe a -> a
fromMaybe a
a Maybe a
ma
in a
a' seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return (a
a', forall (m :: * -> *) a. Monad m => a -> MSF m (Maybe a) a
keepLast a
a')
actuateSF :: MSF m b Bool
actuateSF = forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\b
x -> (Bool
True, b
x)) forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (m :: * -> *) a b. Monad m => (a -> m b) -> MSF m a b
arrM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Bool -> b -> m Bool
actuate)
evalAtZero :: SF Identity a b -> a -> (b, SF Identity a b)
evalAtZero :: forall a b. SF Identity a b -> a -> (b, SF Identity a b)
evalAtZero SF Identity a b
sf a
a = forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF SF Identity a b
sf a
a) Time
0
evalAt :: SF Identity a b -> DTime -> a -> (b, SF Identity a b)
evalAt :: forall a b. SF Identity a b -> Time -> a -> (b, SF Identity a b)
evalAt SF Identity a b
sf Time
dt a
a = forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF SF Identity a b
sf a
a) Time
dt
evalFuture :: SF Identity a b -> a -> DTime -> (b, SF Identity a b)
evalFuture :: forall a b. SF Identity a b -> a -> Time -> (b, SF Identity a b)
evalFuture SF Identity a b
sf = forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a b. SF Identity a b -> Time -> a -> (b, SF Identity a b)
evalAt SF Identity a b
sf)