Closed geraldus closed 10 years ago
Oh, I'm sorry, I was so inattentive! kill
defined right within main's do block!
Oh, guys, please help :)
Hello! I'm glad you found 'kill'. Do you want some help with something else? We don't have an IRC channel.
Yes, I try to understand the pattern itself, so I understood that first I create a dummy event stream:
(et, pushT) <- sync newEvent
Then I need somehow feed the stream with values, right? For example I need a loop where I catch system time, and make new event with timestamp occur? But is it OK with this in mind:
Sodium/others: Events and behaviour state changes are ordered. Time is just another behaviour.
So I have troubles with implementing or in other words describing entire process as a function.
For falling ball I need two behaviors for position and speed, acceleration is constant, and time is behavior also. And I need to describe a switch in future to have a bouncing ball. So how should I describe entire process in Haskell code?
P.S. Sorry, it looks like this is not best place to post such question, doesn't it?
I'm quite happy for you to post here.
Yes, that's right. You'll need some I/O code that feeds the event with time. To make the ball bounce, you won't need to use switch. There are several ways to do it.
There's one thing that's a little tricky: if your time is sent at regular intervals (e.g. once per animation frame), then the instant when the ball hits the ground is between those times. One way to deal with that - if you are ready for it to be a little more difficult - is to write some code at the I/O level to handle alarms.
So, a falling ball would be something like this (I have not tried compiling this):
import Control.Applicative
import FRP.Sodium
t <- hold 0 et -- turn time into a behaviour
let acc = pure (-100) -- I have no idea what this should be
t0_init <- sample time
t0 <- hold t0_init never -- change this when we add bounce
v0 <- hold 0 never -- velocity at t0: change this when we add bounce
y0 <- hold 100 never -- change this when we add bounce
let dt = liftA2 subtract t0 t -- can also be written: subtract <$> t0 <*> t
let vel = liftA3 (\acc v0 dt -> v0 + acc * dt) acc v0 dt
-- note: We can't base y on 'vel' because vel only tells us the velocity now.
-- To integrate velocity we would need to know more information than that.
-- Maybe you can think of some solution.
let y = liftA3 (\acc y0 dt -> y0 + v0 * dt + acc * dt^2) acc y0 dt
Then to listen to y so you can draw it...
kill <- listen (value y) $ \y -> print y
Make sure 'kill' doesn't get garbage collected.
Here's a simple bounce:
{-# LANGUAGE RecursiveDo #-} -- Needed so 'rec' will work
rec
...
let floor = 0
let eBounce = filterE (<= floor) $ value y
y0' <- snapshot (flip const) eBounce y -- flip const can be written as (\_ y0 -> y0)
v0' <- snapshot (flip const) eBounce vel
t0' <- snapshot (flip const) eBounce t
then we change the three holds above to this:
t0 <- hold t0_init t0'
v0 <- hold 0 v0'
y0 <- hold 100 y0'
The problem with this eBounce is that it will happen once the ball has already fallen through the floor. The way to fix that is to implement a system of alarms, where the FRP tells the I/O code what time it wants to be alarmed at.
You can calculate the alarm time by solving the quadratic y0 + v0 * dt + acc * dt^2 == floor
Express the alarm time as a behaviour, then have some I/O code that generates an alarm event when the alarm happens. It will have to send a value to et first, then send a value into the alarm event. eBounce is replaced by the alarm event.
Correction. Hopefully my maths are right.
let vel = liftA2 (\v0 dt -> v0 + acc * dt) v0 dt
-- note: We can't base y on 'vel' because vel only tells us the velocity now.
-- To integrate velocity we would need to know more information than that.
-- Maybe you can think of some solution.
let y = liftA3 (\y0 v0 dt -> y0 + v0 * dt + acc * dt^2) y0 v0 dt
Also I forgot that we have to reverse the velocity when we bounce:
v0' <- snapshot (\_ v -> negate v) eBounce vel
One thing I need to mention is that you can't call 'sync' from inside a listener handler (it will deadlock if you try), so you can't implement your alarms that way. You'll need to use IORefs to pass the alarm time out to the main loop, and have the main loop generate the alarm event.
If you write a simple example, then please send it to me to post on reactiveprogramming.org if you like.
By the way, it is possible to generalize this alarm system. To do this, you merge all pending alarms into a single behaviour and pass that out of your FRP logic. On the input side, you have a single 'eAlarm' event, but you have to guard it for each instance by making sure the alarm time has passed.
Thank you a lot, Stephen! I'll study your example and hopefully post a result tomorrow.
_UPDATED!_ Finally I've back!!! I've tried to do what you said, but after few hours I decided first to implement the simplest thing ever possible – the time behavoiur itself, and finally I've done that!
My final working code is:
import Control.Applicative
import Control.Concurrent
import Data.Time.Clock
import FRP.Sodium
import System.Timeout(timeout)
getCurrentDayTime :: IO Integer
getCurrentDayTime = getCurrentTime >>= (\ x -> return (floor (toRational (utctDayTime x))))
main :: IO ()
main = do
time <- sync newEvent
let (timeEvent, pushTime) = time
cdt <- getCurrentDayTime
currentTime <- sync $ hold cdt timeEvent
kill <- sync $ listen (value currentTime) print
timeout 4000000 $ loop pushTime
kill
This is quite obvious now! I'll continue and post the final result first of just falling ball, and then bouncing ball!
Great!
OK, now I have working "falling ball" version!
import Control.Applicative
import Control.Monad ( liftM )
import Data.Time.Clock( getCurrentTime )
import Data.Time.Clock.POSIX( utcTimeToPOSIXSeconds )
import FRP.Sodium
getClockTimeMs :: IO Integer
-- | Reads current time from environment as UTCTime and converts it to Integer UTC timestamp
getClockTimeMs = liftM (floor . ((10^6)*) . utcTimeToPOSIXSeconds) getCurrentTime
loop :: (Double -> Reactive b) -> IO ()
-- | Main loop which feeds event stream of time behavior with values as Double
loop pushFn = do
t <- getClockTimeMs
sync $ pushFn $ fromInteger t
loop pushFn
main :: IO ()
main = do
-- | time is a Reactive, which holds Event stream and a Reactive `push` action, that actually pushes occurance to the stream
time <- sync newEvent
-- | Extracting event stream of time and pushing action
let (timeEvent, pushTime) = time
-- | Evaluate current timestamp
cdt <- liftM fromInteger getClockTimeMs
-- | startTime is a Behaviour with constant value -- startup timestamp
startTime <- sync $ hold cdt never
-- | Pushing first value to currentTime event stream
currentTime <- sync $ hold cdt timeEvent
-- | deltaTime is a Bahviour, simple difference between current and initial timestamps
let deltaTime = liftA2 (\s c -> (s - c)/(10**6)) startTime currentTime
-- | y0, v0, and acc is Behaviours with contant values
y0 <- sync $ hold (100 :: Double) never
v0 <- sync $ hold (0 :: Double) never
acc <- sync $ hold (-9.81 :: Double) never
-- | Pure function to calculate current object position, falling from some initial height with some initial speed and being influenced by some gravity acceleration at some time passed
let y' y0' v0' a' t' = y0' + v0'*t' + ((a'/2)*(t'**2))
-- | y is a Behaviour, which is just application of pure y' function to Behavoiurs, which are Applicatives
let y = y' <$> y0 <*> v0 <*> acc <*> deltaTime
kill <- sync $ listen (value y) print
loop pushTime
kill
Lovely! You can combine several of your lines together by doing this:
(currentTime, pushTime) <- sync $ newBehavior cdt
Here are two alternative ways you could define startTime:
let startTime = pure cdt
or
startTime <- sync $ sample currentTime
Good news! I've reached my goal! Now I have bouncing ball working! I'll refactor final code a bit and then post it here! There will be few questions I assume.
And here is my code!
Now I described moment when ball will hit the ground as Behavior
and named it as bounceTime
, it depends on v0
and y0
and updates only when any of this values updates.
I've also described few pure functions to calculate current position of falling ball, so acc
behaviour became useless and I removed it.
Now within the main loop I'm checking current timestamp which should be pushed as next time occurrence, and in the case of ball already reached the ground:
t0
, v0
, and y0
.One thing I'm wondering about: I've "glued" all updates in one sync
operation instead of separate sync actions. Is this really matters?
And there is one problem I faced: I have to pass all behaviours and pushing functions to loop function in order to have ability to check values and change behaviours. It's not a big deal, but type signature of loop
is a bit frightening. One possible solution I can mention about is to implement some state (with State
monad) but maybe there is another better way to do that?
Last question is why we "call" kill
as the last action inside main
? Is it to prevent kill
to be garbage collected?
import Control.Applicative
import Control.Monad ( liftM, when )
import Data.Time.Clock( getCurrentTime )
import Data.Time.Clock.POSIX( utcTimeToPOSIXSeconds )
import FRP.Sodium
-- | Reads current time from environment as UTCTime and converts it to Integer UTC timestamp.
getClockTimeMs :: IO Integer
getClockTimeMs = liftM (floor . ((10^6)*) . utcTimeToPOSIXSeconds) getCurrentTime
-- | Constant gravitational acceleration.
a_free_fall = 9.81
-- | Instantaneous speed of freely falling object with some initial speed at some time.
v' :: Double -> Double -> Double
v' v0 t = v0 - a_free_fall*t
-- | Distance which the object will pass having some average speed at some time.
dist_avg_vel :: Double -> Double -> Double
dist_avg_vel v t = v*t
-- | Distance which the freely falling object (without initial speed) will pass at some time.
dist_free_fall :: Double -> Double
dist_free_fall t = a_free_fall/2*(t**2)
-- | Time (in seconds) which object needs to hit the ground.
fall_time :: Double -> Double -> Double
fall_time y0 v0 = (v0 + sqrt(v0**2 + 2*y0*a_free_fall))/a_free_fall
-- | Pure function to calculate current position of object falling from some initial height
-- with some initial speed and being influenced by gravity acceleration at some time.
y' :: Double -> Double -> Double -> Double
y' y0 v0 t = y0 + dist_avg_vel v0 t - dist_free_fall t
-- | Main loop which feeds occurrences of time and checks the bounce.
loop :: (Double -> Reactive b)
-> (Double -> Reactive ())
-> (Behavior Double, Double -> Reactive ())
-> (Behavior Double, Double -> Reactive ())
-> Behavior Double
-> Behavior Double
-> IO ()
loop pushTime setT (vB, setV) (yB, setY) delta bounce = do
t <- getClockTimeMs
-- | Check if ball have already hit the floor. In this case we should
-- | push new values of initial position and speed of the ball.
dt <- sync $ sample delta
b <- sync $ sample bounce
when (dt >= b) $ sync $ do
oldV <- sample vB
oldY <- sample yB
let newV = negate $ 0.6 * v' oldV b
setY 0
setV newV
setT $ fromInteger t - (b + dt)/(10^6)
sync $ pushTime $ fromInteger t
loop pushTime setT (vB, setV) (yB, setY) delta bounce
-- | Helper function which prints the Double with 2 significant digits.
prettyPrint :: Double -> IO ()
prettyPrint = print . (\x -> fromInteger x/100) . round . (100*)
main :: IO ()
main = do
-- | Evaluate current (first) timestamp.
startupTimestamp <- liftM fromInteger getClockTimeMs
-- | Push first value to currentTime event stream.
(currentTime, pushTime) <- sync $ newBehavior startupTimestamp
-- | t0, y0, v0, and acc is Behaviours which contain initial timestamp,
-- position and speed of ball.
(t0, setT) <- sync $ newBehavior startupTimestamp
(y0, setY) <- sync $ newBehavior (30.0 :: Double)
(v0, setV) <- sync $ newBehavior (0.0 :: Double)
let bounceTime = fall_time <$> y0 <*> v0
let deltaTime = liftA2 (\s c -> (c - s)/(10**6)) t0 currentTime
-- | `y` is just an application of pure y' function to behavoiurs,
-- which are Applicatives, thus it's also a behaviour.
let y = y' <$> y0 <*> v0 <*> deltaTime
-- | Prints y position when new value is available.
kill <- sync $ listen (value y) prettyPrint
-- | Start pushing time occurrences.
loop pushTime setT (v0, setV) (y0, setY) deltaTime bounceTime
kill
As a creator of Sodium
can you point possible issues with this code and maybe offer some improvements of it?
Now, when I've become a little bit familiar with Sodium
my next step is to use it with GHCJS
in my current project. So, I assume there will be some new questions and examples in future.
P.S. Excuse me for possible mistakes and typos, some time it's very difficult for me to explain something in English.
One thing I'm wondering about: I've "glued" all updates in one sync operation instead of separate sync actions. Is this really matters?
It's actually best to keep your reactive logic separate from your I/O code and run it inside one big sync. All your 'newBehavior's, 'newEvent's, and 'listen's would generally be outside of this in the I/O section.
The reason for doing things like this is to "free" you from the world of I/O.
So, in keeping with this philosophy, you could set up an animation timer like this:
t0 <- liftM fromInteger getClockTimeMs
(time, pushTime) <- sync $ newBehavior t0
The "game" would have a type signature like this:
game :: Event Double -- ^ Time
-> Event () -- ^ Alarm fired
-> Reactive (Behavior Double, Behavior Double)
The input value is the animation clock. The first returned value is the Y position to draw, and the second is the alarm time.
The main program would continue like this, using the {-# LANGUAGE RecursiveDo #-} pragma at the top of your program:
rec
(eAlarm, pushEAlarm) <- sync newEvent
(y, tAlarm) <- sync $ game time eAlarm
kill <- sync $ listen (value y) print
let handleAlarms now = do
ta <- sync $ sample tAlarm
if ta < now then do
-- Note: These must be separate transactions (i.e. two sync's) or the event handling will see
-- an out-of-date time.
sync $ pushTime ta
sync $ pushEAlarm ()
handleAlarms -- check alarms again, because a new alarm may have been set
else
return ()
forever $ do -- 'forever' comes from Control.Monad
t <- liftM fromInteger getClockTimeMs
handleAlarms t
sync $ pushTime t
threadDelay 50000
kill
So the point here is that we have the absolute minimum of logic in this code, and we let the logic all be pure reactive code.
If you use the approach I described above, you should find that the only things you need to pass around are behaviours and events.
The type signatures can be long sometimes, and you might find a ReaderT transformer on top of Reactive is useful. You wouldn't need a State monad, because behaviors and events are all constant values. I have not needed to do this, but I have found that it's sometimes useful to define data structures.
Yes, the way it's currently implemented, it is actually necessary to do that. If you find that your listeners stop working, this could be the reason.
I have been using GHCJS + Sodium to make web-based games. GHCJS is quite difficult to install at the moment, but it works well. I think there are some bugs that cause memory leaks. I am working on those.
I think my code was a bit wrong. This should fix it:
(eAlarm, pushEAlarm) <- sync newEvent
(y, tAlarm) <- sync $ game time eAlarm
kill <- sync $ listen (value y) print
let handleAlarms now = do
ta <- sync $ sample tAlarm
if ta < now then do
-- Note: These must be separate transactions (i.e. two sync's) or the event handling will see
-- an out-of-date time.
sync $ pushTime ta
sync $ pushEAlarm ()
handleAlarms -- check alarms again, because a new alarm may have been set
else
return ()
forever $ do -- 'forever' comes from Control.Monad
t <- liftM fromInteger getClockTimeMs
handleAlarms t
sync $ pushTime t
threadDelay 50000 -- from Control.Concurrent
kill
Now try refactoring your code to work with a loop like this, and you should find that it is very nice code. You will need a 'rec' loop, using {-# LANGUAGE RecursiveDo #-} pragma.
t0, y0 and v0 will be defined using 'hold'
The event passed to hold will be based on a snapshots of eAlarm, e.g.
startupTimestamp <- sample time
t0 <- hold startupTimestamp $ snapshot (flip const) eAlarm time
Fix some other things:
(eAlarm, pushEAlarm) <- sync newEvent
(y, tAlarm) <- sync $ game time eAlarm
kill <- sync $ listen (value y) print
let handleAlarms now = do
ta <- sync $ sample tAlarm
if ta <= now then do
-- Note: These must be separate transactions (i.e. two sync's) or the event handling will see
-- an out-of-date time.
sync $ pushTime ta
sync $ pushEAlarm ()
handleAlarms now -- check alarms again, because a new alarm may have been set
else
return ()
forever $ do -- 'forever' comes from Control.Monad
t <- liftM fromInteger getClockTimeMs
handleAlarms t
sync $ pushTime t
threadDelay 50000 -- from Control.Concurrent
kill
Note that it will get stuck in an infinite loop if eAlarm doesn't cause tAlarm to be recalculated.
Stephen, I still can not understand what you wrote and refactor example code because of my stupidity. This makes my spirit broken. Look:
t0 <- liftM fromInteger getClockTimeMs
(time, pushTime) <- sync $ newBehavior t0
time
is Behavior
, right?
But game
wants Event
, isn't it?
game :: Event Double -- ^ Time
-> Event () -- ^ Alarm fired
-> Reactive (Behavior Double, Behavior Double)
(y, tAlarm) <- sync $ game time eAlarm
How to convert Behavior
to Event
? In other words what should I pass to game
a time behaviour or events of time values occurrences? In first case I have to get values and in the second to listen for events? Right?
In general, I can't understand relation of Events and Behaviors. If I need to create time delta behaviour inside game
, I can sample
behaviour's current value but how can I fetch value of time from Event
?
Then, why pushTime
goes before pushEAlarm
inside handleAlarms
if ta <= now then do
sync $ pushTime ta
sync $ pushEAlarm ()
handleAlarms now -- check alarms again, because a new alarm may have been set
else
return ()
And how to check alarms within game
?
Anyway I'll keep trying.
P.S. It definitely would be great to have some kind of Getting started tutorial with simplest examples and common patterns. I think I can do one with your help :)
Moreover, it seems that your example can cause infinite loop when we have non elastic bounce. When ball stops (e.g. can't bounce anymore), time of next bounce always equals to 0, thus this code should turn into infinite loop:
let handleAlarms now = do
ta <- sync $ sample tAlarm
if ta <= now then do
-- ta is less or equal now, because ball is already on the ground.
sync $ pushTime ta
sync $ pushEAlarm ()
handleAlarms now
Looks like this approach is a bit wrong, we need another way to describe process, right?
OK, I don't sure if this is what you talked about, here is another version:
module FallingBall.Alternative where
import Control.Applicative( (<$>), (<*>), liftA2 )
import Control.Monad( liftM, when, unless )
import Data.Time( UTCTime, getCurrentTime )
import Data.Time.Clock.POSIX( posixSecondsToUTCTime, utcTimeToPOSIXSeconds )
import Data.Time.Clock( diffUTCTime )
import FRP.Sodium
import Main
loop :: (UTCTime -> Reactive ())
-> (UTCTime -> Reactive ())
-> Reactive Bool
-> IO ()
loop pusher controller check = do
now <- getCurrentTime
sync $ controller now
sync $ pusher now
end <- sync check
unless end $ loop pusher controller check
fallingBall :: Behavior UTCTime
-> Double
-> Double
-> Reactive( Behavior Double
, UTCTime -> Reactive ()
, Reactive Bool
)
fallingBall bTime v0 y0 = do
t <- sample bTime
rT <- newBehavior t
rV <- newBehavior v0
rY <- newBehavior y0
let (bT0, setT0) = rT
dt = liftA2 (\c s -> realToFrac (diffUTCTime c s)) bTime bT0
(bV0, setV0) = rV
(bY0, setY0) = rY
y = y' <$> bY0 <*> bV0 <*> dt
-- | Checking if new y0 and v0 are negligible, in this case we assume that the ball has become still.
check = do
v0' <- sample bV0
y0' <- sample bY0
return (v0' <= 0.000001 && y0' <= 0.000001)
-- | Updates v0 and y0 when ball hits the ground
controller now = do
t0PS <- liftM utcTimeToPOSIXSeconds $ sample bT0
y0' <- sample bY0
v0' <- sample bV0
let ft = fallTime y0' v0'
ftPS = t0PS + realToFrac ft
nowPS = realToFrac $ utcTimeToPOSIXSeconds now
when (nowPS >= ftPS) $ do
let fv = v' v0' ft
setT0 $ posixSecondsToUTCTime ftPS
setY0 0
setV0 $ negate fv*0.7
return (y, controller, check)
nextFrame :: UTCTime -> UTCTime
nextFrame = posixSecondsToUTCTime . (1/60 + ) . realToFrac . utcTimeToPOSIXSeconds
main :: IO ()
main = do
let yStart = 10.0
now <- getCurrentTime
(bTime, pushTime) <- sync $ newBehavior now
(y, cnt, chk) <- sync $ fallingBall bTime 0 yStart
kill <- sync $ listen (value y) $ print . (/100) . fromInteger . round . (100*)
loop pushTime cnt chk
kill
This code works and program exits when ball becomes still!
If this fits what you mentioned about the last thing to be done is to sync y
value printing with 60Hz.
I made a mistake. Time should be Behavior Double, not Event Double.
You can think of a behaviour as an event with memory, so that it is possible to ask "what is the current value of the behaviour?"
I am trying to push you in the direction of separating the logic from the I/O loop, so that you can start programming pure FRP, instead of having imperative (bad) code mixed in with the functional (good) code. When the bounce happens, your code operates imperatively, and this is not the FRP way of doing things. If you do it imperatively, then FRP is not giving you any benefit.
The problem with the infinite loop is a separate issue. You can figure out a solution to that. Perhaps the easiest thing to do is just to have some threshold for it to detect when it has stopped bouncing.
I'll try to sketch the whole thing out. This will be very rough because I don't have time to test it at the moment:
{-# LANGUAGE RecursiveDo #-}
main = do
(eAlarm, pushEAlarm) <- sync newEvent
(y, tAlarm) <- sync $ game time eAlarm
kill <- sync $ listen (value y) print
let handleAlarms now = do
ta <- sync $ sample tAlarm
if ta <= now then do
-- Note: These must be separate transactions (i.e. two sync's) or the event handling will see
-- an out-of-date time.
sync $ pushTime ta
sync $ pushEAlarm ()
handleAlarms now -- check alarms again, because a new alarm may have been set
else
return ()
forever $ do
t <- liftM fromInteger getClockTimeMs
handleAlarms t
sync $ pushTime t
threadDelay 50000
kill
game :: Behavior Double -- ^ Time
-> Event () -- ^ Alarm fired
-> Reactive (Behavior Double, Behavior Double)
game time eAlarm = do
t00 <- sample time
t0 <- hold t00 $ snapshot (flip const) eAlarm time
let dt = liftA2 (\t0 t -> t - t0) t0 time
rec
y0 <- hold (100 :: Double) $ snapshot (flip const) eAlarm y
v <- hold (0 :: Double) $ snapshot (\() v -> (-0.6) * v) eAlarm v
let y = (\dt y0 v -> .. some function ..) <$> dt<*> y0 <*> v
-- Need to define whenBounce to figure out the time when the bounce will happen
let tAlarm = whenBounce <$> t0 <*> y0 <*> v
return (y, tAlarm)
Sorry for making that mistake. Time is definitely a behaviour.
The reason why pushTime goes before pushEAlarm is so that when the alarm is handled in the FRP, the time is set to the correct alarm time. We are capturing the new time using 'snapshot' and so we push it first, so that 'snapshot' can pick it up.
Even though there is an infinite loop, I don't think the approach is wrong. This is correct if you are modelling a real ball that bounces faster and faster and faster. Some bounce size threshold that sets the bounce time to 'never' when the bounce gets small enough (some large time e.g. 1e12) would fix it.
@the-real-blackh, Stephen, please have a look at last code I've posted, looks like I almost there. I've also realized synchronizational already, but it is a bit ugly I think.
I'll attentively study your latest comments and show how I tried to synchronize rendering tommorow (It's dead of night now or more pricisly early morning and I have good idea to have a sleep).
I see snapshot
and I think it is great! Moreover, I think it would be great to have an acknowledgement of all eight primitives of Sodium, and I think you can help with that, right!? Thanks!
See you!
Have a good sleep!
In my last two messages, I was commenting about your newest code above. Even though you've made the type of fallingBall 'Reactive', you're passing functions out and running them imperatively, so it is still working in an imperative way. 'game' should only have events and behaviours going in and out.
Yes, I'm happy to help about the eight primitives. Let me know what you want me to do.
Constants (such as the acceleration for gravity) are also OK.
Oh, is snapshot
an another way to listen or handle events?
snapshot allows you to combine the value of an event with the value of a behaviour sampled when the event fires. 'listen' should only be used on the outputs of the system. It shouldn't be part of the internal logic of your 'game' because it's imperative.
Hmm, I supposed this code should turn into loop, but it is not:
{-# LANGUAGE RecursiveDo #-}
import FRP.Sodium
import Data.Time( UTCTime, getCurrentTime )
import Data.Time.Clock.POSIX( posixSecondsToUTCTime, utcTimeToPOSIXSeconds )
import FRP.Sodium()
timeStep :: Integral a => UTCTime -> a -> UTCTime
timeStep t f = posixSecondsToUTCTime $ realToFrac (utcTimeToPOSIXSeconds t) + 1/(fromIntegral f)
chronos :: Behavior UTCTime -> Int -> Reactive (Behavior UTCTime)
chronos time freq = do
t <- sample time
rec
tStep <- hold t $ snapshot (\_ t' -> timeStep t' freq) justFrame time
let eFrame = snapshot (\t' f -> if t' >= f then Just () else Nothing) (updates time) tStep
justFrame = filterJust eFrame
hold t $ snapshot (flip const) justFrame time
loop :: (UTCTime -> Reactive ()) -> IO ()
loop push = do
now <- getCurrentTime
sync $ push now
main :: IO ()
main = do
now <- getCurrentTime
(bTime, pushTime) <- sync $ newBehavior now
(frames) <- sync $ chronos bTime 60
kill <- sync $ listen (value frames) print
loop pushTime
kill
Please explain why?
'loop' doesn't loop. You could add 'forever' like this:
loop :: (UTCTime -> Reactive ()) -> IO ()
loop push = forever $ do
now <- getCurrentTime
sync $ push now
(import Control.Monad)
Oh, oviously! I'm dumbass :)
Did I catch the idea with snapshot
?
Yes, you've definitely got the right idea with snapshot. Reading the code, it looks correct and should update 'frames' at the desired time interval. It will use 100% of CPU, though, but if you don't mind that, then great. :)
I actually works with forever
. Wow! And what about full CPU usage? How should I prevent that?
Thank you for details :)
I've just checked you're right - I had 100% CPU usage!
I think the easiest way to do this is imperatively:
loop :: (UTCTime -> Reactive ()) -> IO ()
loop push = forever $ do
now <- getCurrentTime
sync $ push now
threadDelay (1000000 / framesPerSecond)
The problem with this is that it'll be a bit irregular (if it's a real video game). One way to make it better would be to calculate the delay time each time round.
{-# LANGUAGE RecursiveDo #-}
module Main where
import Control.Applicative( (<$>), (<*>), liftA2 )
import Control.Concurrent( threadDelay )
import Control.Monad( forever, liftM, when, unless )
import Control.Monad.State
import Data.Time( NominalDiffTime, UTCTime, getCurrentTime )
import Data.Time.Clock.POSIX( posixSecondsToUTCTime, utcTimeToPOSIXSeconds )
import Data.Time.Clock( diffUTCTime )
import FRP.Sodium
import Text.Printf( printf )
-- | Constant gravitational acceleration.
aFreeFall :: Double
aFreeFall = 9.81
-- | Distance which the object will pass having some average speed at some time.
distFromAvgVelAndTime :: Double -> Double -> Double
distFromAvgVelAndTime v t = v*t
-- | Distance which the freely falling object (without initial speed) will pass at some time.
freeFallDistFromTime :: Double -> Double
freeFallDistFromTime t = aFreeFall/2*(t**2)
-- | Time (in seconds) which object needs to hit the ground.
bounceTimeFromPosAndVel :: Double -> Double -> Double
bounceTimeFromPosAndVel y0 v0
| y0 < 0 = 0
| y0 <= 1e-12 && v0 <= 1e-12 = 0
| otherwise = (v0 + sqrt(v0**2 + 2*y0*aFreeFall))/aFreeFall
-- | Instantaneous speed of freely falling object with some initial speed at some time.
v' :: Double -> Double -> Double
v' v0 t = v0 - aFreeFall*t
-- | Pure function to calculate current position of object falling from some initial height
-- with some initial speed and being influenced by gravity acceleration at some time.
y' :: Double -> Double -> Double -> Double
y' y0 v0 t
| y0 <= 1e-12 && v0 <= 1e-12 = 0
| otherwise = y0 + distFromAvgVelAndTime v0 t - freeFallDistFromTime t
timeToFrac :: Fractional a => UTCTime -> a
timeToFrac = realToFrac . utcTimeToPOSIXSeconds
addFracToTime :: RealFrac a => a -> UTCTime -> UTCTime
addFracToTime a t = posixSecondsToUTCTime $ realToFrac (timeToFrac t) + realToFrac a
timeStep :: Integral a => UTCTime -> a -> UTCTime
timeStep t f = posixSecondsToUTCTime $ realToFrac (utcTimeToPOSIXSeconds t) + 1/(fromIntegral f)
nextFrame :: UTCTime -> UTCTime
nextFrame = (flip timeStep) 60
type FrameDelays = [NominalDiffTime]
avgFrameMs :: FrameDelays -> NominalDiffTime
avgFrameMs [] = 0
avgFrameMs fs = sum (map realToFrac fs) / fromIntegral (length fs)
fallingBall :: Behavior UTCTime
-> Double
-> Double
-> Event ()
-> Reactive ( Behavior String
, Behavior UTCTime )
fallingBall utcTime vel pos eBounce = do
t <- sample utcTime
t0 <- hold t $ snapshot (flip const) eBounce utcTime
let
dt = liftA2 (\t0' t' -> realToFrac (diffUTCTime t' t0')) t0 utcTime
rec
y0 <- hold pos $ snapshot (flip const) eBounce y
v0 <- hold vel $ snapshot (\_ v'' -> (-0.6)*v'') eBounce v
let y = y' <$> y0 <*> v0 <*> dt
v = v' <$> v0 <*> dt
tBounce = bounceTimeFromPosAndVel <$> y0 <*> v0
render = (printf "%.2f") <$> y
utcTBounce = addFracToTime <$> tBounce <*> t0
return (render, utcTBounce)
main :: IO ()
main = do
let yStart = 10.0
now <- getCurrentTime
(bTime, pushTime) <- sync $ newBehavior now
(eAlarm, pushAlarm) <- sync newEvent
(frameDelays, pushFrameDelay) <- sync $ newBehavior ([] :: FrameDelays)
let avgFM = avgFrameMs <$> frameDelays
addFrameDelay f = do
cfms <- sync $ sample frameDelays
sync $ pushFrameDelay $ f : take 9 cfms
(frames, tAlarm) <- sync $ fallingBall bTime 0 yStart eAlarm
kill <- sync $ listen (value frames) putStrLn
let handleAlarms now' brk = do
ta <- sync $ sample tAlarm
when (now' > ta) $ do
sync $ pushTime ta
sync $ pushAlarm ()
when (brk) $ handleAlarms now' False
forever $ do
t <- getCurrentTime
t' <- sync $ sample bTime
handleAlarms t True
sync $ pushTime t
addFrameDelay $ diffUTCTime t t'
delay <- sync $ sample avgFM
threadDelay $ round $ 10^6/60 - delay
kill
I think this is the final version. But I have to implement few new tricks. One of them is second boolean argument of handleAlarm
function. As mentioned before without that when ball are close to stop, handleAlarms
turns into infinite loop, breaking normal behaviour of the entire system.
I think the way I modeling the process itself is not perfect, but I have not found another way for now. Maybe I'll recall this example later.
But it seems that alarms system is a kind of common pattern, right? :)
Very nice!
Yes, alarms are definitely a common pattern. You can combine multiple alarms with 'min' - or better still, make a new alarm time type and make it a monoid. On the input side, you need to filter out alarms based on the alarm time (because you might be looking at someone else's alarm).
One way I have done this before is to have a monad transformer based on a state monad. In some ways this design is good and in other ways it's not. These are the sorts of things that experience will teach us.
Can I use your code as an example in the sodium distribution?
Of course!
@the-real-blackh, Hi Stephen! How d'you do? :) Can you give me your email? I'm going to create UI with GHCJS. It's quite simple for now it is just one page with modal window and tabs within it, I assume the way to do that is very close to "channels example" in your presentation. The scheme itself seems to be very obvious and I'll try to replicate it by myself, but I can bet hundred to one I'll need your help! Maybe it's good idea to create new "issue"? What do you think?
Sounds great! My email is phoebe.guffawing.stephen@blacksapphire.com
Hello awesome people!
I'm new to Haskell, still studying (almost finished) "Learn You a Haskell", thus some things are still a bit tricky for me. I'm very excited by reactive programming at all, because only Haskell showed me existence of FRP, so it is another big shift in way of thinking (first one if FP itself). So I decide to look at examples and try to implement simple process - falling ball in FRP style. And now I stuck a bit, there is a function
kill
in memory tests, but Hoogle can't find it. And I failed to find its implementation in Sodium source, what iskill
? And is there Sodium IRC channel somewhere? :)