module FRP.Yampa.Simulation
(
reactimate
, ReactHandle
, reactInit
, react
, embed
, embedSynch
, deltaEncode
, deltaEncodeBy
, FutureSF
, evalAtZero
, evalAt
, evalFuture
)
where
import Control.Monad (unless)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Maybe (fromMaybe)
import FRP.Yampa.Diagnostics (intErr, usrErr)
import FRP.Yampa.InternalCore (DTime, SF (..), SF' (..), sfTF')
reactimate :: Monad m
=> m a
-> (Bool -> m (DTime, Maybe a))
-> (Bool -> b -> m Bool)
-> SF a b
-> m ()
reactimate :: forall (m :: * -> *) a b.
Monad m =>
m a
-> (Bool -> m (DTime, Maybe a))
-> (Bool -> b -> m Bool)
-> SF a b
-> m ()
reactimate m a
init Bool -> m (DTime, Maybe a)
sense Bool -> b -> m Bool
actuate (SF {sfTF :: forall a b. SF a b -> a -> Transition a b
sfTF = a -> Transition a b
tf0}) = do
a
a0 <- m a
init
let (SF' a b
sf, b
b0) = a -> Transition a b
tf0 a
a0
SF' a b -> a -> b -> m ()
loop SF' a b
sf a
a0 b
b0
where
loop :: SF' a b -> a -> b -> m ()
loop SF' a b
sf a
a b
b = do
Bool
done <- Bool -> b -> m Bool
actuate Bool
True b
b
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (a
a seq :: forall a b. a -> b -> b
`seq` b
b seq :: forall a b. a -> b -> b
`seq` Bool
done) forall a b. (a -> b) -> a -> b
$ do
(DTime
dt, Maybe a
ma') <- Bool -> m (DTime, Maybe a)
sense Bool
False
let a' :: a
a' = forall a. a -> Maybe a -> a
fromMaybe a
a Maybe a
ma'
(SF' a b
sf', b
b') = (forall a b. SF' a b -> DTime -> a -> Transition a b
sfTF' SF' a b
sf) DTime
dt a
a'
SF' a b -> a -> b -> m ()
loop SF' a b
sf' a
a' b
b'
data ReactState a b = ReactState
{ forall a b.
ReactState a b -> ReactHandle a b -> Bool -> b -> IO Bool
rsActuate :: ReactHandle a b -> Bool -> b -> IO Bool
, :: SF' a b
, forall a b. ReactState a b -> a
rsA :: a
, forall a b. ReactState a b -> b
rsB :: b
}
newtype ReactHandle a b = ReactHandle
{ forall a b. ReactHandle a b -> IORef (ReactState a b)
reactHandle :: IORef (ReactState a b) }
reactInit :: IO a
-> (ReactHandle a b -> Bool -> b -> IO Bool)
-> SF a b
-> IO (ReactHandle a b)
reactInit :: forall a b.
IO a
-> (ReactHandle a b -> Bool -> b -> IO Bool)
-> SF a b
-> IO (ReactHandle a b)
reactInit IO a
init ReactHandle a b -> Bool -> b -> IO Bool
actuate (SF {sfTF :: forall a b. SF a b -> a -> Transition a b
sfTF = a -> Transition a b
tf0}) = do
a
a0 <- IO a
init
let (SF' a b
sf, b
b0) = a -> Transition a b
tf0 a
a0
IORef (ReactState a b)
r' <- forall a. a -> IO (IORef a)
newIORef (ReactState { rsActuate :: ReactHandle a b -> Bool -> b -> IO Bool
rsActuate = ReactHandle a b -> Bool -> b -> IO Bool
actuate, rsSF :: SF' a b
rsSF = SF' a b
sf
, rsA :: a
rsA = a
a0, rsB :: b
rsB = b
b0
}
)
let r :: ReactHandle a b
r = forall a b. IORef (ReactState a b) -> ReactHandle a b
ReactHandle IORef (ReactState a b)
r'
Bool
_ <- ReactHandle a b -> Bool -> b -> IO Bool
actuate ReactHandle a b
r Bool
True b
b0
forall (m :: * -> *) a. Monad m => a -> m a
return ReactHandle a b
r
react :: ReactHandle a b
-> (DTime, Maybe a)
-> IO Bool
react :: forall a b. ReactHandle a b -> (DTime, Maybe a) -> IO Bool
react ReactHandle a b
rh (DTime
dt, Maybe a
ma') = do
ReactState a b
rs <- forall a. IORef a -> IO a
readIORef (forall a b. ReactHandle a b -> IORef (ReactState a b)
reactHandle ReactHandle a b
rh)
let ReactState {rsActuate :: forall a b.
ReactState a b -> ReactHandle a b -> Bool -> b -> IO Bool
rsActuate = ReactHandle a b -> Bool -> b -> IO Bool
actuate, rsSF :: forall a b. ReactState a b -> SF' a b
rsSF = SF' a b
sf, rsA :: forall a b. ReactState a b -> a
rsA = a
a, rsB :: forall a b. ReactState a b -> b
rsB = b
_b } = ReactState a b
rs
let a' :: a
a' = forall a. a -> Maybe a -> a
fromMaybe a
a Maybe a
ma'
(SF' a b
sf', b
b') = (forall a b. SF' a b -> DTime -> a -> Transition a b
sfTF' SF' a b
sf) DTime
dt a
a'
forall a. IORef a -> a -> IO ()
writeIORef (forall a b. ReactHandle a b -> IORef (ReactState a b)
reactHandle ReactHandle a b
rh) (ReactState a b
rs {rsSF :: SF' a b
rsSF = SF' a b
sf', rsA :: a
rsA = a
a', rsB :: b
rsB = b
b'})
Bool
done <- ReactHandle a b -> Bool -> b -> IO Bool
actuate ReactHandle a b
rh Bool
True b
b'
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
done
embed :: SF a b -> (a, [(DTime, Maybe a)]) -> [b]
embed :: forall a b. SF a b -> (a, [(DTime, Maybe a)]) -> [b]
embed SF a b
sf0 (a
a0, [(DTime, Maybe a)]
dtas) = b
b0 forall a. a -> [a] -> [a]
: forall {t} {a}. t -> SF' t a -> [(DTime, Maybe t)] -> [a]
loop a
a0 SF' a b
sf [(DTime, Maybe a)]
dtas
where
(SF' a b
sf, b
b0) = (forall a b. SF a b -> a -> Transition a b
sfTF SF a b
sf0) a
a0
loop :: t -> SF' t a -> [(DTime, Maybe t)] -> [a]
loop t
_ SF' t a
_ [] = []
loop t
aPrev SF' t a
sf ((DTime
dt, Maybe t
ma) : [(DTime, Maybe t)]
dtas) =
a
b forall a. a -> [a] -> [a]
: (t
a seq :: forall a b. a -> b -> b
`seq` a
b seq :: forall a b. a -> b -> b
`seq` t -> SF' t a -> [(DTime, Maybe t)] -> [a]
loop t
a SF' t a
sf' [(DTime, Maybe t)]
dtas)
where
a :: t
a = forall a. a -> Maybe a -> a
fromMaybe t
aPrev Maybe t
ma
(SF' t a
sf', a
b) = (forall a b. SF' a b -> DTime -> a -> Transition a b
sfTF' SF' t a
sf) DTime
dt t
a
embedSynch :: SF a b -> (a, [(DTime, Maybe a)]) -> SF Double b
embedSynch :: forall a b. SF a b -> (a, [(DTime, Maybe a)]) -> SF DTime b
embedSynch SF a b
sf0 (a
a0, [(DTime, Maybe a)]
dtas) = SF {sfTF :: DTime -> Transition DTime b
sfTF = forall {p}. p -> Transition DTime b
tf0}
where
tts :: [DTime]
tts = forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl (\DTime
t (DTime
dt, Maybe a
_) -> DTime
t forall a. Num a => a -> a -> a
+ DTime
dt) DTime
0 [(DTime, Maybe a)]
dtas
bbs :: [b]
bbs@(b
b:[b]
_) = forall a b. SF a b -> (a, [(DTime, Maybe a)]) -> [b]
embed SF a b
sf0 (a
a0, [(DTime, Maybe a)]
dtas)
tf0 :: p -> Transition DTime b
tf0 p
_ = (forall {b}. DTime -> [(DTime, b)] -> SF' DTime b
esAux DTime
0 (forall a b. [a] -> [b] -> [(a, b)]
zip [DTime]
tts [b]
bbs), b
b)
esAux :: DTime -> [(DTime, b)] -> SF' DTime b
esAux DTime
_ [] = forall a. String -> String -> String -> a
intErr String
"Yampa" String
"embedSynch" String
"Empty list!"
esAux DTime
tpPrev [(DTime, b)]
tbtbs = forall a b. (DTime -> a -> Transition a b) -> SF' a b
SF' DTime -> DTime -> (SF' DTime b, b)
tf
where
tf :: DTime -> DTime -> (SF' DTime b, b)
tf DTime
dt DTime
r | DTime
r forall a. Ord a => a -> a -> Bool
< DTime
0 = forall a. String -> String -> String -> a
usrErr String
"Yampa" String
"embedSynch" String
"Negative ratio."
| Bool
otherwise = (DTime -> [(DTime, b)] -> SF' DTime b
esAux DTime
tp [(DTime, b)]
tbtbs', b
b)
where
tp :: DTime
tp = DTime
tpPrev forall a. Num a => a -> a -> a
+ DTime
dt forall a. Num a => a -> a -> a
* DTime
r
(b
b, [(DTime, b)]
tbtbs') = forall {t} {a}. Ord t => t -> [(t, a)] -> (a, [(t, a)])
advance DTime
tp [(DTime, b)]
tbtbs
advance :: t -> [(t, a)] -> (a, [(t, a)])
advance t
_ tbtbs :: [(t, a)]
tbtbs@[(t
_, a
b)] = (a
b, [(t, a)]
tbtbs)
advance t
tp tbtbtbs :: [(t, a)]
tbtbtbs@((t
_, a
b) : tbtbs :: [(t, a)]
tbtbs@((t
t', a
_) : [(t, a)]
_))
| t
tp forall a. Ord a => a -> a -> Bool
< t
t' = (a
b, [(t, a)]
tbtbtbs)
| t
t' forall a. Ord a => a -> a -> Bool
<= t
tp = t -> [(t, a)] -> (a, [(t, a)])
advance t
tp [(t, a)]
tbtbs
advance t
_ [(t, a)]
_ = forall a. HasCallStack => a
undefined
deltaEncode :: Eq a => DTime -> [a] -> (a, [(DTime, Maybe a)])
deltaEncode :: forall a. Eq a => DTime -> [a] -> (a, [(DTime, Maybe a)])
deltaEncode DTime
_ [] = forall a. String -> String -> String -> a
usrErr String
"Yampa" String
"deltaEncode" String
"Empty input list."
deltaEncode DTime
dt aas :: [a]
aas@(a
_:[a]
_) = forall a.
(a -> a -> Bool) -> DTime -> [a] -> (a, [(DTime, Maybe a)])
deltaEncodeBy forall a. Eq a => a -> a -> Bool
(==) DTime
dt [a]
aas
deltaEncodeBy :: (a -> a -> Bool) -> DTime -> [a] -> (a, [(DTime, Maybe a)])
deltaEncodeBy :: forall a.
(a -> a -> Bool) -> DTime -> [a] -> (a, [(DTime, Maybe a)])
deltaEncodeBy a -> a -> Bool
_ DTime
_ [] = forall a. String -> String -> String -> a
usrErr String
"Yampa" String
"deltaEncodeBy" String
"Empty input list."
deltaEncodeBy a -> a -> Bool
eq DTime
dt (a
a0:[a]
as) = (a
a0, forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. a -> [a]
repeat DTime
dt) (a -> [a] -> [Maybe a]
debAux a
a0 [a]
as))
where
debAux :: a -> [a] -> [Maybe a]
debAux a
_ [] = []
debAux a
aPrev (a
a:[a]
as) | a
a a -> a -> Bool
`eq` a
aPrev = forall a. Maybe a
Nothing forall a. a -> [a] -> [a]
: a -> [a] -> [Maybe a]
debAux a
a [a]
as
| Bool
otherwise = forall a. a -> Maybe a
Just a
a forall a. a -> [a] -> [a]
: a -> [a] -> [Maybe a]
debAux a
a [a]
as
newtype FutureSF a b = FutureSF { forall a b. FutureSF a b -> SF' a b
unsafeSF :: SF' a b }
evalAtZero :: SF a b
-> a
-> (b, FutureSF a b)
evalAtZero :: forall a b. SF a b -> a -> (b, FutureSF a b)
evalAtZero (SF { sfTF :: forall a b. SF a b -> a -> Transition a b
sfTF = a -> Transition a b
tf }) a
a = (b
b, forall a b. SF' a b -> FutureSF a b
FutureSF SF' a b
tf' )
where
(SF' a b
tf', b
b) = a -> Transition a b
tf a
a
evalAt :: FutureSF a b
-> DTime -> a
-> (b, FutureSF a b)
evalAt :: forall a b. FutureSF a b -> DTime -> a -> (b, FutureSF a b)
evalAt (FutureSF { unsafeSF :: forall a b. FutureSF a b -> SF' a b
unsafeSF = SF' a b
tf }) DTime
dt a
a = (b
b, forall a b. SF' a b -> FutureSF a b
FutureSF SF' a b
tf')
where
(SF' a b
tf', b
b) = (forall a b. SF' a b -> DTime -> a -> Transition a b
sfTF' SF' a b
tf) DTime
dt a
a
evalFuture :: SF a b -> a -> DTime -> (b, SF a b)
evalFuture :: forall a b. SF a b -> a -> DTime -> (b, SF a b)
evalFuture SF a b
sf a
a DTime
dt = (b
b, DTime -> SF a b
sf' DTime
dt)
where
(b
b, DTime -> SF a b
sf') = forall a b. SF a b -> a -> (b, DTime -> SF a b)
evalStep SF a b
sf a
a
evalStep :: SF a b -> a -> (b, DTime -> SF a b)
evalStep :: forall a b. SF a b -> a -> (b, DTime -> SF a b)
evalStep (SF a -> Transition a b
sf) a
a = (b
b, \DTime
dt -> forall a b. (a -> Transition a b) -> SF a b
SF (forall a b. SF' a b -> DTime -> a -> Transition a b
sfTF' SF' a b
sf' DTime
dt))
where
(SF' a b
sf', b
b) = a -> Transition a b
sf a
a