I'm trying to simulate a bouncing ball with the Yampa-Framework: Given an initial x-position, height and velocity, the ball should bounce according to gravity rules. The signal function takes a "Tip-Event" as input, the idea being "when the ball is tipped, it's speed should double".
The ball bounces nicely, but every time there is a tipping event, the function goes in to an endless loop. I figured I probably need to add a delay (dSwitch, pre, notYet?), but I do not know how. Any help would be appreciated!
{-# LANGUAGE Arrows #-}
module Ball where
import FRP.Yampa
type Position = Double
type Velocity = Double
type Height = Double
data Ball = Ball {
height :: Height,
width :: Position,
vel :: Velocity
} deriving (Show)
type Tip = Event ()
fly :: Position -> (Height, Velocity) -> SF Tip (Ball, Event (Height,Velocity))
fly w0 (h0, v0) = proc tipEvent -> do
let tip = (tipEvent == Event ())
v <- (v0+) ^<< integral -< -10.0
h <- (h0+) ^<< integral -< v
returnA -< (Ball h w0 v,
if h < 0 then Event (0,(-v*0.6))
else if tip then Event (h, (v*2))
else NoEvent)
bounce w (h,v) = switch (fly w (h,v)) (bounce w)
runBounce w (h,v) = embed (bounce 10 (100.0, 10.0)) (deltaEncode 0.1 [NoEvent, NoEvent, NoEvent, Event (), NoEvent])
EDIT: I managed to avoid the endless loop by feeding back a flag when a tip occurred, but that still does not feel like the right way to do it...
fly :: Position -> (Height, Velocity, Bool) -> SF Tip (Ball, Event (Height,Velocity,Bool))
fly w0 (h0, v0, alreadyTipped) = proc tipEvent -> do
let tip = tipEvent == Event () && (not alreadyTipped)
v <- (v0+) ^<< integral -< -10.0
h <- (h0+) ^<< integral -< v
returnA -< (Ball h w0 v,
if h < 0 then Event (0,(-v*0.6), False)
else if tip then Event (h, (v*2), True)
else NoEvent)
bounce w (h,v,alreadyTipped) = switch (fly w (h,v,alreadyTipped)) (bounce w)
After a few days hacking I think I found the answer. The trick is to use notYet to delay the switching event to the next point in time, so that the switching (and hence the recursive call to fly) occurs when the "old" tipping event is gone. The second function makes sure that only the second part of the result tuple (Ball, Event (..)) will be put through notYet. This removes the endless loop, but also changes the semantics: The switching now takes place one "time step" later, this in turn leads to a different speed.
This Yampa thing is actually quite nice, sadly there is not much documentation to find. I still could not find out what the pre and iPre functions are good for, I figure they can be used in a similar context.
fly :: Position -> (Height, Velocity) -> SF Tip (Ball, Event (Height,Velocity))
fly w0 (h0, v0) = proc tipEvent -> do
let tip = tipEvent == Event ()
v <- (v0+) ^<< integral -< -10.0
h <- (h0+) ^<< integral -< v
returnA -< (Ball h w0 v,
if h < 0 then Event (0,-v*0.6)
else if tip then Event (h, v*2)
else NoEvent)
bounce w (h,v) = switch (fly w (h,v) >>> second notYet) (bounce w)
Related
I'm currently trying to create a snake-like game in haskell using hscurses in the terminal, and I'm having a bit of trouble implementing the input-functionality of the game. My problem is that whenever I hold down one of the movement keys, for example 'a', the character moves to the left for as many characters that were registered by the console. This leads to when I want to switch directions, for example down by pressing 's', the character keeps on moving to the left and the down-movement gets delayed.
res :: Int -> IO a -> IO (Maybe a)
res n f = concurrently (System.Timeout.timeout n f) (threadDelay n) >>= \(result, _) -> return
result
getInput :: IO Char
getInput = hSetEcho stdin False
>> hSetBuffering stdin NoBuffering
>> getChar
and the part of the main game-loop function that handles the input:
loop :: Window -> State -> Player -> IO State
loop window state player = do
threadDelay 1000000
k <- res 100 getInput
newState <- updateState player state
newPlayer <- movePlayer player k
render newState newPlayer window
and the movePlayer function:
movePlayer :: Player -> Maybe Char -> IO Player
movePlayer Player {xy=xy1, direction = d} k =
case k of
Just 'w' -> return Player {xy = (fst xy1, snd xy1-1), direction = Up}
Just 's' -> return Player {xy = (fst xy1, snd xy1+1), direction = Downie}
Just 'd' -> return Player {xy = (fst xy1+1, snd xy1), direction = Rightie}
Just 'a' -> return Player {xy = (fst xy1-1, snd xy1), direction = Leftie}
Nothing -> return Player {xy = addVecs xy1 (dirToVec d), direction = d}
_ -> return Player {xy = xy1, direction = d}
I can't figure out what the problem is, so any help is appreciated or if there's another method of implementing this input-functionality
Currently your input loop and your state update loop are tied together: there's always at most one input accepted per update. You will need to desynch them.
The low-tech alternative is to change the spot you currently have res 100 getInput to actually run getInput in a loop, and only keep the last Char it receives before blocking. The medium-tech alternative is to have two threads, one for reading input and one for doing state updates, with a shared MVar or similar saying what key was pressed last. The high-tech alternative is to use a library like brick to handle all of your input and output.
Simplifying the reality, my OpenGL program has the following structure:
At the beginning, there's a function f : (Double,Double,Double) -> Double.
Then there is a function triangulize :: ((Double,Double,Double) -> Double) -> [Triangle] such that triangulize f calculates a triangular mesh of the surface f(x,y,z)=0.
Then there is the displayCallback, a function display :: IORef Float -> DisplayCallBack which displays the graphics (that is to say it displays the triangular mesh). The first argument IORef Float is here to rotate the graphics, and its value (the angle of the rotation) changes when the user presses a key on the keyboard, thanks to the keyboardCallback defined later. Don't forget that the display function calls triangulize f.
Then the problem is the following one. When the user presses the key to rotate the graphic, the display function is triggered. And then triangulize f is re-evaluated, whereas it doesn't need to be re-evaluated: rotating the graphics does not change the triangular mesh (i.e. the result of triangulize f is the same as before).
So, is there a way to rotate the graphics by pressing a key without triggering triangulize f ? In other words, to "freeze" triangulize f so that it is evaluated only once and is never re-evaluated, which is time-consuming but useless since anyway the result is always the same.
I believe this is a standard way to rotate a graphics in Haskell OpenGL (I viewed that way in some tutos), so I don't think it is necessary to post my code. But of course I can post it if needed.
The reality is more complicated since there are other IORef's to control some parameters of the surface. But I would like to firstly know some solutions for this simplified situation.
EDIT: more details and some code
Simplified code
So, if I follow the simplified description above, my program looks like
fBretzel5 :: (Double,Double,Double) -> Double
fBretzel5 (x,y,z) = ((x*x+y*y/4-1)*(x*x/4+y*y-1))^2 + z*z
triangles :: [Triangle] -- Triangle: triplet of 3 vertices
triangles =
triangulize fBretzel5 ((-2.5,2.5),(-2.5,2.5),(-0.5,0.5))
-- "triangulize f (xbounds, ybounds, zbounds)"
-- calculates a triangular mesh of the surface f(x,y,z)=0
display :: IORef Float -> DisplayCallback
display rot = do
clear [ColorBuffer, DepthBuffer]
rot' <- get rot
loadIdentity
rotate rot $ Vector3 1 0 0
renderPrimitive Triangles $ do
materialDiffuse FrontAndBack $= red
mapM_ drawTriangle triangles
swapBuffers
where
drawTriangle (v1,v2,v3) = do
triangleNormal (v1,v2,v3) -- the normal of the triangle
vertex v1
vertex v2
vertex v3
keyboard :: IORef Float -- rotation angle
-> KeyboardCallback
keyboard rot c _ = do
case c of
'e' -> rot $~! subtract 2
'r' -> rot $~! (+ 2)
'q' -> leaveMainLoop
_ -> return ()
postRedisplay Nothing
This causes the issue described above. Each time the key 'e' or 'r' is pressed, the triangulize function runs while its output remains the same.
True code (almost)
Now, here is a version of my program closest to the reality. In fact, it calculates a triangular mesh for a surface f(x,y,z)=l, where the "isolevel" l can be changed with the keyboard.
voxel :: IO Voxel
voxel = makeVoxel fBretzel5 ((-2.5,2.5),(-2.5,2.5),(-0.5,0.5))
-- the voxel is a 3D-array of points; each entry of the array is
-- the value of the function at this point
-- !! the voxel should never changes throughout the program !!
trianglesBretz :: Double -> IO [Triangle]
trianglesBretz level = do
vxl <- voxel
computeContour3d vxl level
-- "computeContour3d vxl level" calculates a triangular mesh
-- of the surface f(x,y,z)=level
display :: IORef Float -> IORef Float -> DisplayCallback
display rot level = do
clear [ColorBuffer, DepthBuffer]
rot' <- get rot
level' <- get level
triangles <- trianglesBretz level'
loadIdentity
rotate rot $ Vector3 1 0 0
renderPrimitive Triangles $ do
materialDiffuse FrontAndBack $= red
mapM_ drawTriangle triangles
swapBuffers
where
drawTriangle (v1,v2,v3) = do
triangleNormal (v1,v2,v3) -- the normal of the triangle
vertex v1
vertex v2
vertex v3
keyboard :: IORef Float -- rotation angle
-> IORef Double -- isolevel
-> KeyboardCallback
keyboard rot level c _ = do
case c of
'e' -> rot $~! subtract 2
'r' -> rot $~! (+ 2)
'h' -> level $~! (+ 0.1)
'n' -> level $~! subtract 0.1
'q' -> leaveMainLoop
_ -> return ()
postRedisplay Nothing
A part of a solution
In fact, I have found a solution in order to "freeze" the voxel:
voxel :: Voxel
{-# NOINLINE voxel #-}
voxel = unsafePerformIO $ makeVoxel fBretzel5 ((-2.5,2.5),(-2.5,2.5),(-0.5,0.5))
trianglesBretz :: Double -> IO [Triangle]
trianglesBretz level =
computeContour3d voxel level
In this way, I think the voxel is never re-evaluated.
But there is still a problem. When the IORef rot changes, to rotate the graphics, then there's no reason to re-evaluate trianglesBretz: the triangular mesh of f(x,y,z)=level is always the same whatever the rotation.
So, how can I say to the display function: "hey! when rot changes, do not re-evaluate trianglesBretz, since you will find the same result" ?
I don't know how to use NOINLINE for trianglesBretz, as I did for voxel. Something which would "freezes" trianglesBretz level unless level changes.
And here is the 5-holes bretzel:
EDIT: solution based on #Petr Pudlák's answer.
After #Petr Pudlák's very good answer I came to the following code. I give this solution here in order to place the answer more in the context of OpenGL.
data Context = Context
{
contextRotation :: IORef Float
, contextTriangles :: IORef [Triangle]
}
red :: Color4 GLfloat
red = Color4 1 0 0 1
fBretz :: XYZ -> Double
fBretz (x,y,z) = ((x2+y2/4-1)*(x2/4+y2-1))^2 + z*z
where
x2 = x*x
y2 = y*y
voxel :: Voxel
{-# NOINLINE voxel #-}
voxel = unsafePerformIO $ makeVoxel fBretz ((-2.5,2.5),(-2.5,2.5),(-1,1))
trianglesBretz :: Double -> IO [Triangle]
trianglesBretz level = computeContour3d voxel level
display :: Context -> DisplayCallback
display context = do
clear [ColorBuffer, DepthBuffer]
rot <- get (contextRotation context)
triangles <- get (contextTriangles context)
loadIdentity
rotate rot $ Vector3 1 0 0
renderPrimitive Triangles $ do
materialDiffuse FrontAndBack $= red
mapM_ drawTriangle triangles
swapBuffers
where
drawTriangle (v1,v2,v3) = do
triangleNormal (v1,v2,v3) -- the normal of the triangle
vertex v1
vertex v2
vertex v3
keyboard :: IORef Float -- rotation angle
-> IORef Double -- isolevel
-> IORef [Triangle] -- triangular mesh
-> KeyboardCallback
keyboard rot level trianglesRef c _ = do
case c of
'e' -> rot $~! subtract 2
'r' -> rot $~! (+ 2)
'h' -> do
l $~! (+ 0.1)
l' <- get l
triangles <- trianglesBretz l'
writeIORef trianglesRef triangles
'n' -> do
l $~! (- 0.1)
l' <- get l
triangles <- trianglesBretz l'
writeIORef trianglesRef triangles
'q' -> leaveMainLoop
_ -> return ()
postRedisplay Nothing
main :: IO ()
main = do
_ <- getArgsAndInitialize
_ <- createWindow "Bretzel"
windowSize $= Size 500 500
initialDisplayMode $= [RGBAMode, DoubleBuffered, WithDepthBuffer]
clearColor $= white
materialAmbient FrontAndBack $= black
lighting $= Enabled
lightModelTwoSide $= Enabled
light (Light 0) $= Enabled
position (Light 0) $= Vertex4 0 0 (-100) 1
ambient (Light 0) $= black
diffuse (Light 0) $= white
specular (Light 0) $= white
depthFunc $= Just Less
shadeModel $= Smooth
rot <- newIORef 0.0
level <- newIORef 0.1
triangles <- trianglesBretz 0.1
trianglesRef <- newIORef triangles
displayCallback $= display Context {contextRotation = rot,
contextTriangles = trianglesRef}
reshapeCallback $= Just yourReshapeCallback
keyboardCallback $= Just (keyboard rot level trianglesRef)
idleCallback $= Nothing
putStrLn "*** Bretzel ***\n\
\ To quit, press q.\n\
\ Scene rotation:\n\
\ e, r, t, y, u, i\n\
\ Increase/Decrease level: h, n\n\
\"
mainLoop
And now my bretzel can be rotated without performing useless calculations.
I'm not very familiar with OpenGL, so I have some difficulty understanding the code in detail - please correct me if I misunderstood something.
I'd try to abstain from using unsafe functions or relying on INLINE as much as possible. This usually makes code brittle and obscures more natural solutions.
In the simplest case, if you don't need to re-evaluate triangularize, we could just replace it with its output. So we'd have
data Context = Context
{ contextRotation :: IORef Float,
, contextTriangles :: [Triangle]
}
and then
display :: Context -> DisplayCallback
which won't reevaluate triangles at all, they'll be computed only once when Context is created.
Now if there are two parameters, rotation and level, and triangles depend on the level, but not on rotation: The trick here would be to manage dependencies properly. Now we expose the storage for parameters explicitly (IORef Float), and as a consequence, we can't monitor when the value inside changes. But the caller doesn't need to know the representation of how the parameters are stored. It just needs to store them somehow. So instead, let's have
data Context = Context
{ contextRotation :: IORef Float,
, contextTriangles :: IORef [Triangle]
}
and
setLevel :: Context -> Float -> IO ()
That is, we expose a function to store the parameter, but we hide the internals. Now we can implement it as:
setLevel (Context _ trianglesRef) level = do
let newTriangles = ... -- compute the new triangles
writeIORef trianglesRef newTriangles
And as triangles don't depend on the rotation parameter, we can have just:
setRotation :: Context -> Float -> IO ()
setRoration (Context rotationRef _) = writeIORef rotationRef
Now the dependencies are hidden for callers. They can set the level or the rotation, without knowing what depends on them. At the same time, triangles are updated when needed (level changes), and only then. And Haskell's lazy evaluation gives a nice bonus: If the level changes multiple times before the triangles are needed, they are not evaluated. The [Triangle] thunk inside the IORef will be only evaluated when requested by display.
I am trying to model moving objects using Netwire and would like to know the recommended way to implement something like the bouncing of a ball off a wall. I have encountered several possible ways to do this and I need some help actually getting them to work.
The motion code looks like this:
type Pos = Float
type Vel = Float
data Collision = Collision | NoCollision
deriving (Show)
motion :: (HasTime t s, MonadFix m) => Pos -> Vel -> Wire s Collision m a Pos
motion x0 v0 = proc _ -> do
rec
v <- vel <<< delay 0 -< x
x <- pos x0 -< v
returnA -< x
pos :: (HasTime t s, MonadFix m) => Pos -> Wire s Collision m Vel Pos
pos x0 = integral x0
main :: IO ()
main = testWire clockSession_ (motion 0 5)
What is the recommended way to make a velocity arrow that causes a bounce at a certain position, eg x=20?
I have seen three different ways that I might be able to do this:
The netwire --> function which seems the simplest. I have a prototype using this function but I don't know how to make a new velocity arrow based on the velocity at the time of the collision, I can only use a fixed value which is not useful if the object can accelerate.
vel :: (HasTime t s, MonadFix m) => Wire s Collision m Pos Vel
vel = pure 5 . unless (>20) --> pure (-5)
Using the Event and switch in Netwire. I don't understand how to use this.
Using the (|||) function available to arrows in general.
The first two seem like the best options but I don't know how to implement them.
I have seen other similar questions to this but the incompatibility between different versions of netwire have made the answers not useful for me.
Disclaimer: I cannot comment on what is "recommended", but I can show a way that does what you want to do.
I want to describe two methods:
The first is using stateful wires, and is pretty similar to this a bit outdated tutorial from 2013, but based on Netwire 5.0.2.
The second is using stateless wires. Because they are stateless they need to be fed back their previous values, which makes the wire's input types and the final combination of the wires a bit more convoluted. Otherwise they are pretty similar.
The basic types that are involved in both examples are
type Collision = Bool
type Velocity = Float
type Position = Float
Stateful
You can model your problem with two (stateful) wires that are then combined.
One wire models the velocity, which is constant, and changes direction when a collision happens. The (simplified) type of this is Wire s e m Collision Velocity, i.e. it's input is if a collision happened and the output is the current velocity.
The other one models the position, and handles collisions. The (simplified) type of this is Wire s e m Velocity (Position, Collision), i.e. it takes a velocity, calculates the new position and returns that and if a collision happened.
Finally the velocity is fed into the position wire, and the collision result from that is fed back into the velocity wire.
Let's have a look at the details of the velocity wire:
-- stateful fixed velocity wire that switches direction when collision occurs
velocity :: Velocity -> Wire s e m Collision Velocity
velocity vel = mkPureN $ \collision ->
let nextVel = if collision then negate vel else vel
in (Right nextVel, velocity nextVel)
mkPureN creates a stateful wire that only depends on the input and its own state (not on a Monad, or time). The state is the current velocity, and the next velocity is negated if Collision=True is passed as input. The return value is a pair of the velocity value and the new wire with the new state.
For the position it is no longer sufficient to use the integral wire directly. We want an enhanced, "bounded" version of integral which makes sure that the value stays lower than an upper bound and greater than 0, and returns the information if such a collision has happened.
-- bounded integral [0, bound]
pos :: HasTime t s => Position -> Position -> Wire s e m Velocity (Position, Collision)
pos bound x = mkPure $ \ds dx ->
let dt = realToFrac (dtime ds)
nextx' = x + dt*dx -- candidate
(nextx, coll)
| nextx' <= 0 && dx < 0 = (-nextx', True)
| nextx' >= bound && dx > 0 = (bound - (nextx' - bound), True)
| otherwise = (nextx', False)
in (Right (nextx, coll), pos bound nextx)
mkPure is similar to mkPureN, but allows the wire to depend on time.
dt is the time difference.
nextx' is the new position, as it would be returned by integral.
The following lines check the bounds and return the new position, if a collision has occurred and the new wire with the new state.
Finally you feed them into each other using rec and delay. Full example:
{-# LANGUAGE Arrows #-}
module Main where
import Control.Monad.Fix
import Control.Wire
import FRP.Netwire
type Collision = Bool
type Velocity = Float
type Position = Float
-- bounded integral [0, bound]
pos :: HasTime t s => Position -> Position -> Wire s e m Velocity (Position, Collision)
pos bound x = mkPure $ \ds dx ->
let dt = realToFrac (dtime ds)
nextx' = x + dt*dx -- candidate
(nextx, coll)
| nextx' <= 0 && dx < 0 = (-nextx', True)
| nextx' >= bound && dx > 0 = (bound - (nextx' - bound), True)
| otherwise = (nextx', False)
in (Right (nextx, coll), pos bound nextx)
-- stateful fixed velocity wire that switches direction when collision occurs
velocity :: Velocity -> Wire s e m Collision Velocity
velocity vel = mkPureN $ \collision ->
let nextVel = if collision then negate vel else vel
in (Right nextVel, velocity nextVel)
run :: (HasTime t s, MonadFix m) => Position -> Velocity -> Position -> Wire s () m a Position
run start vel bound = proc _ -> do
rec
v <- velocity vel <<< delay False -< collision
(p, collision) <- pos bound start -< v
returnA -< p
main :: IO ()
main = testWire clockSession_ (run 0 5 20)
Stateless
The stateless variant is very similar to the stateful one, except that the state wanders to the input type of the wires instead of being a parameter to the functions that create the wire.
The velocity wire therefore takes a tuple (Velocity, Collision) as its input, and we can just lift a function to create it:
-- pure stateless independent from time
-- output velocity is input velocity potentially negated depending on collision
velocity :: Monad m => Wire s e m (Velocity, Collision) Velocity
velocity = arr $ \(vel, collision) -> if collision then -vel else vel
You can also use the function mkSF_ from Control.Wire.Core (and then get rid of the restriction to Monad m).
pos becomes
-- pure stateless but depending on time
-- output position is input position moved by input velocity (depending on timestep)
pos :: HasTime t s => Position -> Wire s e m (Position, Velocity) (Position, Collision)
pos bound = mkPure $ \ds (x,dx) ->
let dt = realToFrac (dtime ds)
nextx' = x + dt*dx -- candidate
(nextx, coll)
| nextx' <= 0 && dx < 0 = (-nextx', True)
| nextx' >= bound && dx > 0 = (bound - (nextx' - bound), True)
| otherwise = (nextx', False)
in (Right (nextx, coll), pos bound)
Here we still need to use mkPure, because there is no function that specifically can be used for stateless wires that depend on time.
To connect the two wire we now must feed the output of velocity into itself and the position, and from the pos wire the position into itself and the collision information into the velocity wire.
But actually with stateless wires you can also separate the "integrating" and the "bounds checking" parts of the pos wire. The pos wire then is a Wire s e m (Position, Velocity) Position that directly returns what is nextx' above, and the boundedPos wire is a Wire s e m (Position, Velocity) (Position, Collision) that gets the new position from pos and the velocity, and applies the bound check. That way the different logical parts become nicely separated.
Full example:
{-# LANGUAGE Arrows #-}
module Main where
import Control.Monad.Fix
import Control.Wire
import FRP.Netwire
type Collision = Bool
type Velocity = Float
type Position = Float
-- pure stateless but depending on time
-- output position is input position moved by input velocity (depending on timestep)
pos :: HasTime t s => Wire s e m (Position, Velocity) Position
pos = mkPure $ \ds (x,dx) ->
let dt = realToFrac (dtime ds)
in (Right (x + dt*dx), pos)
-- pure stateless independent from time
-- input position is bounced off the bounds
boundedPos :: Monad m => Position -> Wire s e m (Position, Velocity) (Position, Collision)
boundedPos bound = arr $ \(x, dx) ->
let (nextx, collision)
| x <= 0 && dx < 0 = (-x, True)
| x >= bound && dx > 0 = (bound - (x - bound), True)
| otherwise = (x, False)
in (nextx, collision)
-- pure stateless independent from time
-- output velocity is input velocity potentially negated depending on collision
velocity :: Monad m => Wire s e m (Velocity, Collision) Velocity
velocity = arr $ \(vel, collision) -> if collision then -vel else vel
-- plug the wires into each other
run :: (HasTime t s, MonadFix m) => Position -> Velocity -> Position -> Wire s () m a Position
run start vel bound = proc _ -> do
rec
v <- velocity <<< delay (vel, False) -< (v, collision)
lastPos <- delay start -< p'
p <- pos -< (lastPos, v)
(p', collision) <- boundedPos bound -< (p, v)
returnA -< p'
main :: IO ()
main = testWire clockSession_ (run 0 5 20)
Given the following:
integralB :: Num a => Behavior t a -> Behavior t a -- definite integral of a behaviour
eJump :: Event t a -- tells the player to jump
bYAccel = pure 4000 -- y acceleration
bYVel = integralB bYAccel -- y velocity
bY = integralB bYVel -- y position
How do I make the player jump (probably by setting its y velocity) when a jump event arrives?
You'll need to be able to apply an impulse to the Y velocity for the jump. From your own answer, you've come up with a way to do so by summing all the impulses from the jumps and adding them to the integral of the acceleration.
Your acceleration is also constant. If you don't want the player falling constantly, you'd need something like:
bYAccel = (ifB airborne) 4000 0
airborne = fmap (>0) bY
ifB :: Behavior t Bool -> a -> a -> Behavior t a
ifB boolBehavior yes no = fmap (\bool -> if bool then yes else no) boolBehavior
One possible reason the height of your jumps varies is you aren't resetting the velocity when the player lands. If you have rules that hold the player above some position (like the floor), and are somehow stopping acceleration when the player hits the floor, you will also need to set the velocity to 0 if it is in the direction of the floor. (If you also set it to 0 when it's not in the direction of the floor, the player can never get the velocity to leave the ground.)
The reason this would cause erratic jumping heights is that the final velocity when the player lands will be close to the impulse you applied for them to take off. Using your numbers, if a jump started with a velocity of -5000, and ended with a velocity of 4800, the next jump will add an impulse of -5000, taking the jump to a starting velocity of only -200. That might have an ending velocity of 300, so the next jump will be an almost full -4700 jump.
Here's a complete working example. It uses the gloss library for input and display. The gameDefinition corresponds to the components introduced in your question. integrateDeltas is equivalent to your integralB, but produces events that are impulses, which are easy to generate in a clocked framework like gloss, and easy to use mixed with other events that cause impulses, like jumping.
{-# LANGUAGE RankNTypes #-}
module Main where
import Reactive.Banana
import Reactive.Banana.Frameworks.AddHandler
import Reactive.Banana.Frameworks
import Data.IORef
import qualified Graphics.Gloss.Interface.IO.Game as Gloss
gameDefinition :: GlossGameEvents t -> Behavior t Gloss.Picture
gameDefinition events = renderBehavior
where
bY = accumB 0 (fmap sumIfPositive yShifts)
yShifts = integrateDeltas bYVel
bYVel = accumB 0 yVelChanges
yVelChanges = apply ((ifB airborne) (+) sumIfPositive) yVelShifts
yVelShifts = union (integrateDeltas bYAccel) (fmap (const 3) eJump)
bYAccel = (ifB airborne) (-10) 0
airborne = fmap (>0) bY
eJump = filterE isKeyEvent (event events)
integrateDeltas = integrateDeltaByTimeStep (timeStep events)
renderBehavior = (liftA3 render) bY bYVel bYAccel
render y yVel yAccel =
Gloss.Pictures [
Gloss.Translate 0 (20+y*100) (Gloss.Circle 20),
Gloss.Translate (-50) (-20) (readableText (show y)),
Gloss.Translate (-50) (-40) (readableText (show yVel)),
Gloss.Translate (-50) (-60) (readableText (show yAccel))
]
readableText = (Gloss.Scale 0.1 0.1) . Gloss.Text
-- Utilities
sumIfPositive :: (Ord n, Num n) => n -> n -> n
sumIfPositive x y = max 0 (x + y)
ifB :: Behavior t Bool -> a -> a -> Behavior t a
ifB boolBehavior yes no = fmap (\bool -> if bool then yes else no) boolBehavior
integrateDeltaByTimeStep :: (Num n) => Event t n -> Behavior t n -> Event t n
integrateDeltaByTimeStep timeStep derivative = apply (fmap (*) derivative) timeStep
isKeyEvent :: Gloss.Event -> Bool
isKeyEvent (Gloss.EventKey _ _ _ _) = True
isKeyEvent _ = False
-- Main loop to run it
main :: IO ()
main = do
reactiveGame (Gloss.InWindow "Reactive Game Example" (400, 400) (10, 10))
Gloss.white
100
gameDefinition
-- Reactive gloss game
data GlossGameEvents t = GlossGameEvents {
event :: Event t Gloss.Event,
timeStep :: Event t Float
}
makeReactiveGameNetwork :: Frameworks t
=> IORef Gloss.Picture
-> AddHandler Gloss.Event
-> AddHandler Float
-> (forall t. GlossGameEvents t -> Behavior t Gloss.Picture)
-> Moment t ()
makeReactiveGameNetwork latestFrame glossEvent glossTime game = do
eventEvent <- fromAddHandler glossEvent
timeStepEvent <- fromAddHandler glossTime
let
events = GlossGameEvents { event = eventEvent, timeStep = timeStepEvent }
pictureBehavior = game events
pictureChanges <- changes pictureBehavior
reactimate (fmap (writeIORef latestFrame) pictureChanges)
reactiveGame :: Gloss.Display
-> Gloss.Color
-> Int
-> (forall t. GlossGameEvents t -> Behavior t Gloss.Picture)
-> IO ()
reactiveGame display color steps game = do
latestFrame <- newIORef Gloss.Blank
(glossEvent, fireGlossEvent) <- newAddHandler
(glossTime, addGlossTime) <- newAddHandler
network <- compile (makeReactiveGameNetwork latestFrame glossEvent glossTime game)
actuate network
Gloss.playIO
display
color
steps
()
(\world -> readIORef latestFrame)
(\event world -> fireGlossEvent event)
(\time world -> addGlossTime time)
In this example, bY checks for collision with a floor at 0 by accumulating the impulses, but constraining the accumulated value to be above 0.
The velocity, bYVel, accumulates all impulses while airborne, but only those impulses that are directed away from the floor while not airborne. If you change
yVelChanges = apply ((ifB airborne) (+) sumIfPositive) yVelShifts
to
yVelChanges = fmap (+) yVelShifts
it recreates the erratic jumping bug.
The acceleration, bYAccel, is only present while airborne.
I used a coordinate system with a +Y axis in the up direction (opposite the acceleration).
The code at the end is a small framework to hook reactive-banana up to gloss.
Solved it! I feel a little silly for not thinking of this earlier, but I just increment a counter every eJump and add that counter on to bYVel.
bJumpVel = sumB $ (-5000) <$ eJump
bYVel = (+) <$> bJumpVel <*> integralB bYAccel
-- gives the sum of the events
sumB :: Num a => Event t a -> Behavior t a
sumB e = accumB 0 $ (+) <$> e
For some reason the height of the jump always varies quite a bit, but that's probably an unrelated problem to do with my timing of things.
I won't mark this question as answered yet in case someone wants to share a better one.
I think I need some incentive on how to make this, I'm not really experienced in general platforming game mechanics...
Anyway, my player figure has this up to now:
movePlayer = proc p -> do
let gravity = 100
sx <- keySpeed GLFW.LEFT GLFW.RIGHT 500 -< ()
dy <- integralLim_ collision 0 -< (gravity, p)
dx <- integralLim_ collision 0 -< (sx, p)
returnA -< (sx, sy)
where
keySpeed k1 k2 s = onKey k1 (-s) <|> onKey k2 s <|> pure 0
collision = undefined -- collision with the world
With gravity, the player object slowly falls down until there is something to stand on. Of course, the next step is to add jumping, in a sin curve... what is a simple way to add it using netwire? One that can also be have further collision detecting added to it?
I just have no idea where to begin with this one.
First of all note that integrals work for tuples:
(x, y) <- integralLim_ f (x0, y0) -< ((dx, dy), w)
Now consider that gravity is an acceleration value. You can easily add it to other acceleration values:
gravity = pure (0, -9.8)
jump = pure (0, 1000) . holdFor 0.1 (keyPressed space) <|> pure (0, 0)
pos = integralLim_ collision p0 . integral_ v0 . (gravity ^+^ jump)
where p0 is the initial position and v0 the initial velocity.