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.
Related
When doing a ray trace with rayTraceP, I can find the point where a ray intersects with a diagram.
> rayTraceP (p2 (0, 0)) (r2 (1, 0)) ((p2 (1,-1) ~~ p2 (1,1))
Just (p2 (1.0, 0.0))
I want to use this to find not only the "collision point", but also the collision time and the normal vector to the surface at that point.
-- A Collision has a time, a contact point, and a normal vector.
-- The normal vector is perpendicular to the surface at the contact
-- point.
data Collision v n = Collision n (Point v n) (v n)
deriving (Show)
Given a start point for the ray and a velocity vector along the ray, I can find the contact point end using rayTraceP:
end <- rayTraceP start vel dia
And I can find the collision time using the distance between start and end:
time = distance start end / norm vel
But I'm stuck on finding the normal vector. I'm working within this function:
rayTraceC :: (Metric v, OrderedField n)
=> Point v n -> v n -> QDiagram B v n Any -> Maybe (Collision v n)
-- Takes a starting position for the ray, a velocity vector for the
-- ray, and a diagram to trace the ray to. If the ray intersects with
-- the diagram, it returns a Collision containing:
-- * The amount of time it takes for a point along the ray going at
-- the given velocity to intersect with the diagram.
-- * The point at which it intersects with the diagram.
-- * The normal vector to the surface at that point (which will be
-- perpendicular to the surface there).
-- If the ray does not intersect with the diagram, it returns Nothing.
rayTraceC start vel dia =
do
end <- rayTraceP start vel dia
let time = distance start end / norm vel
-- This is where I'm getting stuck.
-- How do I find the normal vector?
let normalV = ???
return (Collision time end normalV)
Some examples of what I want it to do:
> -- colliding straight on:
> rayTraceC (p2 (0, 0)) (r2 (1, 0)) (p2 (1,-1) ~~ p2 (1,1))
Just (Collision 1 (p2 (1, 0)) (r2 (-1, 0)))
> -- colliding from a diagonal:
> rayTraceC (p2 (0, 0)) (r2 (1, 1)) (p2 (1,0) ~~ p2 (1,2))
Just (Collision 1 (p2 (1, 1)) (r2 (-1, 0))
> -- colliding onto a diagonal:
> rayTraceC (p2 (0, 0)) (r2 (1, 0)) (p2 (0,-1) ~~ p2 (2,1))
Just (Collision 1 (p2 (1, 0)) (r2 (-√2/2, √2/2)))
> -- no collision
> rayTraceC (p2 (0, 0)) (r2 (1, 0)) (p2 (1,1) ~~ p2 (1,2))
Nothing
It is correct on everything in these examples except for the normal vector.
I have looked in the documentation for both Diagrams.Trace and Diagrams.Core.Trace, but maybe I'm looking in the wrong places.
There is no way to do this in general; it depends on what exactly you hit. There is a module Diagrams.Tangent for computing tangents of trails, but to compute the tangent at a given point you have to know its parameter with respect to the trail; and one thing we are missing at the moment is a way to convert from a given point to the parameter of the closest point on a given segment/trail/path (it's been on the to-do list for a while).
Dreaming even bigger, perhaps traces themselves ought to return something more informative---not just parameters telling you how far along the ray the hit are, but also information about what you hit (from which one could more easily do things like compute a normal vector).
What kinds of things are you computing traces of? There might be a way to take advantage of the particular details of your use case to get the normals you want in a not-too-terrible way.
Brent Yorgey's answer points out the Diagrams.Tangent module, and in particular normalAtParam, which works on Parameteric functions, including trails, but not all Diagrams.
Fortunately, many 2D diagram functions, like circle, square, rect, ~~, etc. can actually return any TrailLike type, including Trail V2 n. So a function with the type
rayTraceTrailC :: forall n . (RealFloat n, Epsilon n)
=>
Point V2 n
-> V2 n
-> Located (Trail V2 n)
-> Maybe (Collision V2 n)
Would actually work on the values returned by circle, square, rect, ~~, etc. if it could be defined:
> rayTraceTrailC
(p2 (0, 0))
(r2 (1, 0))
(circle 1 # moveTo (p2 (2,0)))
Just (Collision 1 (p2 (1, 0)) (r2 (-1, 0)))
And this function can be defined by breaking the trail up into a list of fixed segments which are either linear or bezier curves, using the fixTrail function. That reduces the problem to the simpler rayTraceFixedSegmentC.
rayTraceTrailC start vel trail =
combine (mapMaybe (rayTraceFixedSegmentC start vel) (fixTrail trail))
where
combine [] = Nothing
combine cs = Just (minimumBy (\(Collision a _ _) (Collision b _ _) -> compare a b) cs)
The rayTraceFixedSegmentC can use rayTraceP to calculate the contact point, but we can't find the normal vector right away because we don't know what the parameter is at that contact point. So punt further and add fixedSegmentNormalV helper function to the wish list:
rayTraceFixedSegmentC :: forall n . (RealFloat n, Epsilon n)
=>
Point V2 n
-> V2 n
-> FixedSegment V2 n
-> Maybe (Collision V2 n)
rayTraceFixedSegmentC start vel seg =
do
end <- rayTraceP start vel (unfixTrail [seg])
let time = distance start end / norm vel
let normalV = normalize (project (fixedSegmentNormalV seg end) (negated vel))
return (Collision time end normalV)
This fixedSegmentNormalV function just has to return a normal vector for a single segment going through a single point, without worrying about the vel direction. It can destruct the FixedSegment type, and if it's linear, that's easy:
fixedSegmentNormalV :: forall n . (OrderedField n)
=>
FixedSegment V2 n -> Point V2 n -> V2 n
fixedSegmentNormalV seg pt =
case seg of
FLinear a b -> perp (b .-. a)
FCubic a b c d ->
???
In the FCubic case, to calculate the parameter where the curve goes through pt, I'm not sure what to do, but if you don't mind approximations here we can just take a bunch of points along it and find the one closest to pt. After that we can call normalAtParam as Brent Yorgey suggested.
fixedSegmentNormalV seg pt =
case seg of
FLinear a b -> perp (b .-. a)
FCubic a b c d ->
-- APPROXIMATION: find the closest parameter value t
let ts = map ((/100) . fromIntegral) [0..100]
dist t = distance (seg `atParam` t) pt
t = minimumBy (\a b -> compare (dist a) (dist b)) ts
-- once we have that parameter value we can call a built-in function
in normalAtParam seg t
With this, the rayTraceTrailC function is working with this approximation. However, it doesn't work for Diagrams, only Located Trails.
It can work on the values returned by functions like circle and rect, but not on combined diagrams. So you have to keep those building blocks of diagrams separate, as trails, for as long as you need this collision ray tracing.
Using the normal vectors to reflect the rays (the outgoing ray has an equal angle from the normal vector) looks like this:
Yesterday I finally decided to start learning Haskell. I started scanning through tutorials, but quickly decided practical exercises would be more beneficial. Therefore I proceeded to port a python script of mine which supposedly simulates gravity into Haskell. To my surprise it actually worked and the generated values match those of python.
I realize the implementation is probably absolutely terrible. The horrible lack of performance does not bother me so much, but what bothers me is that I keep running out of memory when attempting to run the simulation for a longer period of time. Is this because the implementation is inherently flawed or can it be made to work?
I have tried to construct the main loop with three different approaches: "iterate", a recursive function (I read about tail recursion, but didn't manage to make it work) and with a more experimental recursive do function. The functions in question are named simulation, test and test2. I compiled the program with option "-O2".
Why does the program run out of memory, and what can I do to prevent that?
Not so relevant parts of the code:
import System.Environment
import Data.List (tails)
import System.CPUTime
import Text.Printf
import Control.Exception
gConst = 6.674e-11
data Vector = Vector2D Double Double | Vector3D Double Double Double deriving (Show)
deltaVector :: Vector -> Vector -> Vector
deltaVector (Vector2D x1 y1) (Vector2D x2 y2) = Vector2D (x2 - x1) (y2 - y1)
deltaVector (Vector3D x1 y1 z1) (Vector3D x2 y2 z2) = Vector3D (x2 - x1) (y2 - y1) (z2 - z1)
data Position = Position Vector deriving (Show)
data Velocity = Velocity Vector deriving (Show)
distance2DSquared (Vector2D deltaX deltaY) = deltaX ** 2 + deltaY ** 2
distance3DSquared (Vector3D deltaX deltaY deltaZ) = (distance2DSquared $ Vector2D deltaX deltaY) + deltaZ ** 2
distance vector = sqrt (distance3DSquared $ vector)
force vector mass1 mass2 = gConst * (mass1 * mass2) / (distance3DSquared vector)
acceleration force mass = force / mass
vectorComponentDivide (Vector2D x y) c = Vector2D (x/c) (y/c)
vectorComponentDivide (Vector3D x y z) c = Vector3D (x/c) (y/c) (z/c)
vectorComponentMultiply (Vector2D x y) c = Vector2D (x*c) (y*c)
vectorComponentMultiply (Vector3D x y z) c = Vector3D (x*c) (y*c) (z*c)
vectorComponentAdd (Vector2D x1 y1) (Vector2D x2 y2) = Vector2D (x1+x2) (y1+y2)
vectorComponentAdd (Vector3D x1 y1 z1) (Vector3D x2 y2 z2) = Vector3D (x1+x2) (y1+y2) (z1+z2)
invertedVector (Vector2D x1 y1) = Vector2D (-x1) (-y1)
invertedVector (Vector3D x1 y1 z1) = Vector3D (-x1) (-y1) (-z1)
normalizedVector :: Vector -> Vector
normalizedVector vector = vectorComponentDivide vector $ distance vector
velocity vel0 mass1 mass2 vector deltaT =
vectorComponentMultiply (vectorComponentAdd vel0 (vectorComponentMultiply (normalizedVector vector) (acceleration (force vector mass1 mass2) mass1))) deltaT
data Actor = Actor String Vector Vector Double deriving (Show)
earth = Actor "Object1" (Vector3D 0 0 0) (Vector3D 0 0 0) 10
moon = Actor "Object2" (Vector3D 10 0 0) (Vector3D 0 0 0) 10
actors = [earth, moon]
combinations :: Int -> [a] -> [[a]]
combinations 0 _ = [ [] ]
combinations n xs = [ y:ys | y:xs' <- tails xs
, ys <- combinations (n-1) xs']
updateVelocity [(Actor name1 position1 velocity1 mass1),(Actor name2 position2 velocity2 mass2)] =
[(Actor name1 position1 a mass1),(Actor name2 position2 b mass2)]
where a = velocity velocity1 mass1 mass2 vector deltaT
b = velocity velocity2 mass2 mass1 (invertedVector vector) deltaT
vector = deltaVector position1 position2
deltaT = 1
updatePosition [(Actor name1 position1 velocity1 mass1),(Actor name2 position2 velocity2 mass2)] =
[Actor name1 (vectorComponentAdd position1 velocity1) velocity1 mass1, Actor name2 (vectorComponentAdd position2 velocity2) velocity2 mass2]
Relevant parts:
update list = map updatePosition (map updateVelocity list)
simulation state n = do
if n == 0
then do
print state
return ()
else do
let newState = update state
simulation newState $! (n-1)
test list n = iterate update list !! n
test2 list 0 = list
test2 list n = (test2 (update list) (n-1))
time :: IO t -> IO t
time a = do
start <- getCPUTime
v <- a
end <- getCPUTime
let diff = (fromIntegral (end - start)) / (10^12)
printf "Computation time: %0.3f sec\n" (diff :: Double)
return v
main :: IO ()
main = do
let combo = combinations 2 actors
putStrLn "Hello World!"
let n = 1000000
print n
--time $ print (test combo n)
time $ simulation combo n
_ <- getLine
putStrLn "BAI"
I believe laziness harms your code: your code builds large thunks (unevaluated expressions) which lead to OOM.
For instance, iterate is (in)famous for leading to large thunks, when you access the resulting list in the middle without forcing the previous list elements. More precisely
iterate f x !! n
is bad, since it will build the expression f (f (f ...(f x))) before really performing any work. We want to evaluate every list element before accessing the next one. This could be dome by a custom !! function:
(!!!) :: [a] -> Int -> a
[] !!! _ = error "!!!: out of range"
(x:_ ) !!! 0 = x
(x:xs) !!! n = seq x (xs !!! pred n)
Now we can use iterate f a !!! n without large thunks building up.
This has the same problem:
simulation state n = do
if n == 0
then do
print state
return ()
else do
let newState = update state
simulation newState $! (n-1)
It will build large update (update (update ...)) thunks without evaluating them. A possible fix could be
...
(simulation $! newState) $! (n-1)
However, keep in mind that in your case newState is a list (of lists!). In such case, seq or $! will only demand the list to be evaluated as far as its first cell constructor -- just enough to check whether the list is empty or not. This "forcing" might be enough or not for your purposes.
There is a library function named deepSeq which will force the full list, if really needed (use Hoogle to find the docs).
Summing up: lazy evaluation has its benefits and its downsides. It usually allows for more efficiency, e.g. sometimes providing constant space list processing without the need of writing carefully crafted functions. It also allows infinite lists tricks which are handy. However, it can also cause unwanted thunks to stick around for too long, wasting memory. So, in those cases, programmers have some burden put on them. Especially when one is used to strict semantics, these issues can be scary at first (we've been there!).
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 am attempting to implement the following algorithm, as detailed here.
Start with a flat terrain (initialize all height values to zero).
Pick a random point on or near the terrain, and a random radius
between some predetermined minimum and maximum. Carefully choosing
this min and max will make a terrain rough and rocky or smooth and
rolling.
Raise a hill on the terrain centered at the point, having the given
radius.
Go back to step 2, and repeat as many times as necessary. The number
of iterations chosen will affect the appearance of the terrain.
However, I start to struggle once I get to the point where I have to select a random point on the terrain. This random point is wrapped in an IO monad, which is then passed up my chain of functions.
Can I cut the IO off at a certain point and, if so, how do I find that point?
The following is my (broken) code. I would appreciate any suggestions on improving it / stopping the randomness from infecting everything.
type Point = (GLfloat, GLfloat, GLfloat)
type Terrain = [Point]
flatTerrain :: Double -> Double -> Double -> Double -> Terrain
flatTerrain width length height spacing =
[(realToFrac x, realToFrac y, realToFrac z)
| x <- [-width,-1+spacing..width], y <- [height], z <- [-length,-1+spacing..length]]
hill :: Terrain -> Terrain
hill terrain = hill' terrain 100
where hill' terrain 0 = terrain
hill' terrain iterations = do
raised <- raise terrain
hill' (raise terrain) (iterations - 1)
raise terrain = do
point <- pick terrain
map (raisePoint 0.1 point) terrain
raisePoint r (cx,cy,cz) (px,py,pz) =
(px, r^2 - ((cx - px)^2 + (cz - pz)^2), pz)
pick :: [a] -> IO a
pick xs = randomRIO (0, (length xs - 1)) >>= return . (xs !!)
The algorithm says that you need to iterate and in each iteration select a random number and update the terrain which can be viewed as generate a list of random points and use this list to update the terrain i.e iteration to generate random numbers == list of random numbers.
So you can do something like:
selectRandomPoints :: [Points] -> Int -> IO [Points] -- generate Int times random points
updateTerrain :: Terrain -> [Points] -> Terrain
-- somewhere in IO
do
pts <- selectRandomPoints allPts iterationCount
let newTerrain = updateTerrain t pts
One of the most useful features of haskell is to know a function is deterministic just based on its type - it makes testing much easier. For this reason, I would base my design on limiting randomness as much as possible, and wrapping the core non random functions with a random variant. This is easily done with the MonadRandom type class, which is the best way of writing code in haskell that requires random values.
For fun, I wrote a console version of that hill generator. It is pretty basic, with a lot of hard coded constants. However, it does provide a pretty cool ascii terrain generator :)
Note with my solution all of the calculations are isolated in pure, non random functions. This could then be tested easily, as the result is deterministic. As little as possible occurs in the IO monad.
import Control.Monad
import Control.Monad.Random
import Data.List
import Data.Function (on)
type Point = (Double, Double, Double)
type Terrain = [Point]
-- Non random code
flatTerrain :: Double -> Double -> Double -> Double -> Terrain
flatTerrain width length height spacing = [(realToFrac x, realToFrac y, realToFrac z)
| x <- [-width,-width+spacing..width], y <- [height], z <- [-length,-length+spacing..length]]
-- simple terrain displayer, uses ascii to render the area.
-- assumes the terrain points are all separated by the same amount
showTerrain :: Terrain -> String
showTerrain terrain = unlines $ map (concat . map showPoint) pointsByZ where
pointsByZ = groupBy ((==) `on` getZ) $ sortBy (compare `on` getZ) terrain
getZ (_, _, z) = z
getY (_, y, _) = y
largest = getY $ maximumBy (compare `on` getY) terrain
smallest = getY $ minimumBy (compare `on` getY) terrain
atPC percent = (largest - smallest) * percent + smallest
showPoint (_, y, _)
| y < atPC (1/5) = " "
| y < atPC (2/5) = "."
| y < atPC (3/5) = "*"
| y < atPC (4/5) = "^"
| otherwise = "#"
addHill :: Double -- Radius of hill
-> Point -- Position of hill
-> Terrain -> Terrain
addHill radius point = map (raisePoint radius point) where
raisePoint :: Double -> Point -> Point -> Point
-- I had to add max py here, otherwise new hills destroyed the
-- old hills with negative values.
raisePoint r (cx,cy,cz) (px,py,pz) = (px, max py (r^2 - ((cx - px)^2 + (cz - pz)^2)), pz)
-- Some random variants. IO is an instance of MonadRandom, so these function can be run in IO. They
-- can also be run in any other monad that has a MonadRandom instance, so they are pretty flexible.
-- creates a random point. Note that the ranges are hardcoded - an improvement would
-- be to be able to specify them, either through parameters, or through reading from a Reader
-- monad or similar
randomPoint :: (MonadRandom m) => m Point
randomPoint = do
x <- getRandomR (-30, 30)
y <- getRandomR (0,10)
z <- getRandomR (-30, 30)
return (x, y, z)
addRandomHill :: (MonadRandom m) => Terrain -> m Terrain
addRandomHill terrain = do
radius <- getRandomR (0, 8) -- hardcoded again
position <- randomPoint
return $ addHill radius position terrain
-- Add many random hills to the Terrain
addRandomHills :: (MonadRandom m) => Int -> Terrain -> m Terrain
addRandomHills count = foldr (>=>) return $ replicate count addRandomHill
-- testing code
test hillCount = do
let terrain = flatTerrain 30 30 0 2
withHills <- addRandomHills hillCount terrain
-- let oneHill = addHill 8 (0, 3, 0) terrain
-- putStrLn $ showTerrain oneHill
putStrLn $ showTerrain withHills
main = test 200
Example output:
... .. ..*. .***^^^***.
... ... .***. .***^^^*^^*.
... .. .*^**......*^*^^^^.
. .***.***. ..*^^^*.
....*^^***^*. .^##^*.
..*.*^^^*****. .^###^..*
.**^^^^.***... .*^#^*.**
.***^##^**..*^^*.*****..**
....***^^##^*.*^##^****. ..
.......*^###^.*###^****.
.*********^###^**^##^***....
*^^^*^##^^^^###^.^^^*. .****..
*^^^^####*^####^..**. .******.
*^^^*####**^###*. .. .*******
*^#^^^##^***^^*. ...........***
*^^^**^^*..*... ..*******...***
.***..*^^*... ..*^^#^^^*......
...*^##^**. .*^^#####*.
.*^##^**....**^^####*. .***
.. ..*^^^*...*...**^^###^* *^#^
..****^^*. .... ...**###^*.^###
..*******.**. ..**^^^#^^..^###
.*****..*^^* ..**^##^**...*^##
.^^^^....*^^*..*^^^##^* ..**^^^
*###^*. .*^**..^###^^^*...*****
^####*.*..*^^*.^###^**.....*..
*###^**^**^^^*.*###^. .. .
.^^^***^^^^#^*.**^^**.
.....***^##^**^^^*^^*.
.*^^##^*^##^^^^^.
.*^^^^*.^##^*^^*.
Nope, you can't escape IO. Perhaps you can do all your randomness up front and rewrite your functions to take that randomness as a parameter; if not, you can use MonadRandom or similar to track a random seed or just put everything in IO.
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)