Related
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 have done numerous graphics with Haskell OpenGL. They are in my repo here: opengl-examples (the gallery is not exhaustive). However I have a problem: when I use materialShininess nothing happens. It there something to enable in order to have the shininess ?
Here is an example of one of my prog. It it not complete but I hope it's enough to identify the issue.
module CompoundFiveTetrahedra2
where
import CompoundFiveTetrahedra.Data
import Control.Monad (when)
import qualified Data.ByteString as B
import Data.IORef
import Graphics.Rendering.OpenGL.Capture (capturePPM)
import Graphics.Rendering.OpenGL.GL
import Graphics.UI.GLUT
import Text.Printf
import Utils.ConvertPPM
import Utils.OpenGL (negateNormal)
import Utils.Prism
blue,red,green,yellow,purple,white,black :: Color4 GLfloat
blue = Color4 0 0 1 1
red = Color4 1 0 0 1
green = Color4 0 1 0 1
yellow = Color4 1 1 0 1
white = Color4 1 1 1 1
black = Color4 0 0 0 1
purple = Color4 0.5 0 0.5 1
display :: IORef GLfloat -> IORef GLfloat -> IORef GLfloat -> IORef GLdouble
-> IORef GLint -> IORef GLfloat -> DisplayCallback
display rot1 rot2 rot3 zoom capture angle = do
clear [ColorBuffer, DepthBuffer]
r1 <- get rot1
r2 <- get rot2
r3 <- get rot3
z <- get zoom
a <- get angle
i <- get capture
loadIdentity
(_, size) <- get viewport
resize z size
rotate a $ Vector3 1 1 1
rotate r1 $ Vector3 1 0 0
rotate r2 $ Vector3 0 1 0
rotate r3 $ Vector3 0 0 1
mapM_ (drawEdge blue) (edges!!0)
mapM_ (drawEdge red) (edges!!1)
mapM_ (drawEdge green) (edges!!2)
mapM_ (drawEdge yellow) (edges!!3)
mapM_ (drawEdge purple) (edges!!4)
mapM_ (drawVertex blue) vertices1
mapM_ (drawVertex red) vertices2
mapM_ (drawVertex green) vertices3
mapM_ (drawVertex yellow) vertices4
mapM_ (drawVertex purple) vertices5
when (i > 0) $ do
let ppm = printf "tetrahedra%04d.ppm" i
png = printf "tetrahedra%04d.png" i
(>>=) capturePPM (B.writeFile ppm)
convert ppm png True
capture $~! (+1)
swapBuffers
drawVertex :: Color4 GLfloat -> Vertex3 GLfloat -> IO ()
drawVertex col v =
preservingMatrix $ do
translate $ toVector v
materialDiffuse Front $= col
renderObject Solid $ Sphere' 0.03 30 30
where
toVector (Vertex3 x y z) = Vector3 x y z
drawEdge :: Color4 GLfloat -> (Vertex3 GLfloat, Vertex3 GLfloat) -> IO ()
drawEdge col (v1,v2) = do
let cylinder = prism v1 v2 30 0.03
renderPrimitive Quads $ do
materialDiffuse Front $= col
mapM_ drawQuad cylinder
where
drawQuad ((w1,w2,w3,w4),n) = do
normal $ negateNormal n
vertex w1
vertex w2
vertex w3
vertex w4
resize :: Double -> Size -> IO ()
resize zoom s#(Size w h) = do
viewport $= (Position 0 0, s)
matrixMode $= Projection
loadIdentity
perspective 45.0 (w'/h') 1.0 100.0
lookAt (Vertex3 0 0 (-3 + zoom)) (Vertex3 0 0 0) (Vector3 0 1 0)
matrixMode $= Modelview 0
where
w' = realToFrac w
h' = realToFrac h
keyboard :: IORef GLfloat -> IORef GLfloat -> IORef GLfloat -> IORef GLint
-> KeyboardCallback
keyboard rot1 rot2 rot3 capture c _ =
case c of
'r' -> rot1 $~! subtract 1
't' -> rot1 $~! (+1)
'f' -> rot2 $~! subtract 1
'g' -> rot2 $~! (+1)
'v' -> rot3 $~! subtract 1
'b' -> rot3 $~! (+1)
'c' -> capture $~! (+1)
'q' -> leaveMainLoop
_ -> return ()
mouse :: IORef GLdouble -> MouseCallback
mouse zoom button keyState _ =
case (button, keyState) of
(LeftButton, Down) -> zoom $~! (+0.1)
(RightButton, Down) -> zoom $~! subtract 0.1
_ -> return ()
idle :: IORef GLfloat -> IdleCallback
idle angle = do
angle $~! (+ 2)
postRedisplay Nothing
main :: IO ()
main = do
_ <- getArgsAndInitialize
_ <- createWindow "Five tetrahedra"
initialDisplayMode $= [RGBAMode, DoubleBuffered, WithDepthBuffer]
clearColor $= black
materialAmbient Front $= black
materialShininess Front $= 80 -- THIS DOES NOT WORK
lighting $= Enabled
light (Light 0) $= Enabled
position (Light 0) $= Vertex4 0 0 (-100) 1
ambient (Light 0) $= white
diffuse (Light 0) $= white
specular (Light 0) $= white
depthFunc $= Just Lequal
depthMask $= Enabled
shadeModel $= Smooth
rot1 <- newIORef 0.0
rot2 <- newIORef 0.0
rot3 <- newIORef 0.0
zoom <- newIORef 0.0
capture <- newIORef 0
angle <- newIORef 0.0
displayCallback $= display rot1 rot2 rot3 zoom capture angle
reshapeCallback $= Just (resize 0)
keyboardCallback $= Just (keyboard rot1 rot2 rot3 capture)
mouseCallback $= Just (mouse zoom)
idleCallback $= Just (idle angle)
mainLoop
Do I miss something to enable the shininess ?
EDIT
Here is an example with the R package rgl, which is also a wrapper to OpenGL. Look at the white part on the spheres. I cannot achieve that with Haskell.
Update: Try shininess of 1.0 to see the difference more clearly at low resolutions.
The shininess parameter affects the sharpness of specular lighting, so you need to turn this type of lighting on for your materials by giving them a specular color. (By default, the specular color is black, so the effect of the shininess parameter will not be visible.) You'll also want to reduce the shininess value for this scene, because it's too high to be very visible.
Try:
materialSpecular Front $= white
materialShininess Front $= 1.0
and you'll start to see white highlights, particularly along the curved edges of your shape. The flat faces will also reflect some white light, but only when they are nearly perpendicular to a line that's mid-angle between the viewer and the light source -- it's a little complicated.
Note that the specular color of most materials is taken to be some "multiple" of white (i.e., somewhere between black for a perfectly dull material to white for the shiniest materials in the scene). The only materials with tinted specular color would be colored metals, like gold or bronze.
Some additional notes:
You're using old-style OpenGL 2.1 shading, not "modern OpenGL", so you don't have to worry so much about the "shaders" that #user2297560 is talking about. OpenGL 2.1 comes with built-in shaders to do basic shading; with modern OpenGL, you have to build everything from scratch.
As #luqui mentioned, if you're looking for materials that actually reflect other parts of the scenes, this kind of shininess won't help you.
Here is the difference. Your original code on the left, the settings above on the right, on your "compoundfivetetrahedra" example. It'll look better if you increase the size of the window.
Note that it works better on curved surfaces. Here's your cylinder example, using:
materialShininess Front $= 5
materialSpecular Front $= white
You can see the shininess on the closer sphere.
I am currently writing a game using gloss' play. The basic structure of this game is very simple: I have a board with units on it, one of which is in focus.
I have added the ability to change the focus by cycling through the units on the board using KeyTab. Quite quickly, I realised that I wanted to also be able to cycle back so I thought I'd use Shift + KeyTab to do so as is customary in this situation.
gloss' Events come with Modifiers, one of which is shift. Perfect? Well... not quite: whenever I press Shift + KeyTab, the event is never received by the window (I used Debug.Trace's trace to print all the received Events).
With CAPS LOCK, I do receive KeyTab with the shift modifier marked as Down. If I switch to using Ctrl + KeyTab as my shortcut, it works perfectly well. Here is a minimal example reproducing the problem:
module Main where
import Graphics.Gloss
import Graphics.Gloss.Interface.Pure.Game
data Board = Board Color Color Color
forward :: Board -> Board
forward (Board x y z) = Board y z x
backward :: Board -> Board
backward (Board x y z) = Board z x y
displayPoint :: Point -> Color -> Picture
displayPoint (x, y) c = translate x y $ color c $ circle 10
displayBoard :: Board -> Picture
displayBoard (Board x y z) =
Pictures $ zipWith displayPoint coordinates [x, y, z]
where coordinates = [(0, 30), (-30, -30), (30, -30)]
react :: Event -> Board -> Board
react (EventKey (SpecialKey KeyTab) Down mods _) b =
case shift mods of
Up -> forward b
Down -> backward b
react _ b = b
main :: IO ()
main =
let window = InWindow "Buggy" (100, 100) (200, 200)
board = Board blue red yellow
in play window black 24 board displayBoard react (const id)
The output looks like this:
You should just see a flat, continuous red wall on one side, blue wall on another, green on another, yellow on another (see the definition of the map, testMapTiles, it's just a map with four walls). Yet there are these phantom wall faces of varying height, which are perpendicular to the real walls. Why?
Note that the white "gaps" aren't actually gaps: it's trying to draw a wall of height Infinity (distance 0). If you specifically account for it (this version of the code doesn't) and just cap it at screen height, then you just see a very high wall there.
The source code is below. It's plain Haskell, using Haste to compile to JavaScript and render to canvas. It is based on the C++ code from this tutorial, though note that I replaced mapX and mapY with tileX and tileY, and I don't have the ray prefix for pos and dir within the main loop. Any discrepancies from the C++ code are probably what's breaking everything, but I can't seem to find any after having pored over this code many times.
Any help?
import Data.Array.IArray
import Control.Arrow (first, second)
import Control.Monad (forM_)
import Haste
import Haste.Graphics.Canvas
data MapTile = Empty | RedWall | BlueWall | GreenWall | YellowWall deriving (Eq)
type TilemapArray = Array (Int, Int) MapTile
emptyTilemapArray :: (Int, Int) -> TilemapArray
emptyTilemapArray dim#(w, h) = listArray ((1, 1), dim) $ replicate (w * h) Empty
testMapTiles :: TilemapArray
testMapTiles =
let arr = emptyTilemapArray (16, 16)
myBounds#((xB, yB), (w, h)) = bounds arr
in listArray myBounds $ flip map (indices arr) (\(x, y) ->
if x == xB then RedWall
else if y == yB then BlueWall
else if x == w then GreenWall
else if y == h then YellowWall
else Empty)
type Vec2 a = (a, a)
type DblVec2 = Vec2 Double
type IntVec2 = Vec2 Int
add :: (Num a) => Vec2 a -> Vec2 a -> Vec2 a
add (x1, y1) (x2, y2) = (x1 + x2, y1 + y2)
mul :: (Num a) => Vec2 a -> a -> Vec2 a
mul (x, y) factor = (x * factor, y * factor)
rot :: (Floating a) => Vec2 a -> a -> Vec2 a
rot (x, y) angle =
(x * (cos angle) - y * (sin angle), x * (sin angle) + y * (cos angle))
dbl :: Int -> Double
dbl = fromIntegral
-- fractional part of a float
-- `truncate` matches behaviour of C++'s int()
frac :: Double -> Double
frac d = d - dbl (truncate d)
-- get whole and fractional parts of a float
split :: Double -> (Int, Double)
split d = (truncate d, frac d)
-- stops 'Warning: Defaulting the following constraint(s) to type ‘Integer’'
square :: Double -> Double
square = (^ (2 :: Int))
-- raycasting algorithm based on code here:
-- http://lodev.org/cgtutor/raycasting.html#Untextured_Raycaster_
data HitSide = NorthSouth | EastWest deriving (Show)
-- direction, tile, distance
type HitInfo = (HitSide, IntVec2, Double)
-- pos: start position
-- dir: initial direction
-- plane: camera "plane" (a line, really, perpendicular to the direction)
traceRays :: TilemapArray -> Int -> DblVec2 -> DblVec2 -> DblVec2 -> [HitInfo]
traceRays arr numRays pos dir plane =
flip map [0..numRays] $ \x ->
let cameraX = 2 * ((dbl x) / (dbl numRays)) - 1
in traceRay arr pos $ dir `add` (plane `mul` cameraX)
traceRay :: TilemapArray -> DblVec2 -> DblVec2 -> HitInfo
traceRay arr pos#(posX, posY) dir#(dirX, dirY) =
-- map tile we're in (whole part of position)
-- position within map tile (fractional part of position)
let ((tileX, fracX), (tileY, fracY)) = (split posX, split posY)
tile = (tileX, tileY)
-- length of ray from one x or y-side to next x or y-side
deltaDistX = sqrt $ 1 + (square dirY / square dirX)
deltaDistY = sqrt $ 1 + (square dirX / square dirY)
deltaDist = (deltaDistX, deltaDistY)
-- direction of step
stepX = if dirX < 0 then -1 else 1
stepY = if dirY < 0 then -1 else 1
step = (stepX, stepY)
-- length of ray from current position to next x or y-side
sideDistX = deltaDistX * if dirX < 0 then fracX else 1 - fracX
sideDistY = deltaDistY * if dirY < 0 then fracY else 1 - fracY
sideDist = (sideDistX, sideDistY)
(hitSide, wallTile) = traceRayInner arr step deltaDist tile sideDist
in (hitSide, wallTile, calculateDistance hitSide pos dir wallTile step)
traceRayInner :: TilemapArray -> IntVec2 -> DblVec2 -> IntVec2 -> DblVec2 -> (HitSide, IntVec2)
traceRayInner arr step#(stepX, stepY) deltaDist#(deltaDistX, deltaDistY) tile sideDist#(sideDistX, sideDistY)
-- a wall has been hit, report hit direction and coördinates
| arr ! tile /= Empty = (hitSide, tile)
-- advance until a wall is hit
| otherwise = case hitSide of
EastWest ->
let newSideDist = first (deltaDistX+) sideDist
newTile = first (stepX+) tile
in
traceRayInner arr step deltaDist newTile newSideDist
NorthSouth ->
let newSideDist = second (deltaDistY+) sideDist
newTile = second (stepY+) tile
in
traceRayInner arr step deltaDist newTile newSideDist
where
hitSide = if sideDistX < sideDistY then EastWest else NorthSouth
-- calculate distance projected on camera direction
-- (an oblique distance would give a fisheye effect)
calculateDistance :: HitSide -> DblVec2 -> DblVec2 -> IntVec2 -> IntVec2 -> Double
calculateDistance EastWest (startX, _) (dirX, _) (tileX, _) (stepX, _) =
((dbl tileX) - startX + (1 - dbl stepX) / 2) / dirX
calculateDistance NorthSouth (_, startY) (_, dirY) (_, tileY) (_, stepY) =
((dbl tileY) - startY + (1 - dbl stepY) / 2) / dirY
-- calculate the height of the vertical line on-screen based on the distance
calculateHeight :: Double -> Double -> Double
calculateHeight screenHeight 0 = screenHeight
calculateHeight screenHeight perpWallDist = screenHeight / perpWallDist
width :: Double
height :: Double
(width, height) = (640, 480)
main :: IO ()
main = do
cvElem <- newElem "canvas" `with` [
attr "width" =: show width,
attr "height" =: show height
]
addChild cvElem documentBody
Just canvas <- getCanvas cvElem
let pos = (8, 8)
dir = (-1, 0)
plane = (0, 0.66)
renderGame canvas pos dir plane
renderGame :: Canvas -> DblVec2 -> DblVec2 -> DblVec2 -> IO ()
renderGame canvas pos dir plane = do
let rays = traceRays testMapTiles (floor width) pos dir plane
render canvas $ forM_ (zip [0..width - 1] rays) (\(x, (side, tile, dist)) ->
let lineHeight = calculateHeight height dist
wallColor = case testMapTiles ! tile of
RedWall -> RGB 255 0 0
BlueWall -> RGB 0 255 0
GreenWall -> RGB 0 0 255
YellowWall -> RGB 255 255 0
_ -> RGB 255 255 255
shadedWallColor = case side of
EastWest ->
let (RGB r g b) = wallColor
in RGB (r `div` 2) (g `div` 2) (b `div` 2)
NorthSouth -> wallColor
in color shadedWallColor $ do
translate (x, height / 2) $ stroke $ do
line (0, -lineHeight / 2) (0, lineHeight / 2))
-- 25fps
let fps = 25
timeout = (1000 `div` fps) :: Int
rots_per_min = 1
rots_per_sec = dbl rots_per_min / 60
rots_per_frame = rots_per_sec / dbl fps
tau = 2 * pi
increment = tau * rots_per_frame
setTimeout timeout $ do
renderGame canvas pos (rot dir $ -increment) (rot plane $ -increment)
HTML page:
<!doctype html>
<meta charset=utf-8>
<title>Raycaster</title>
<noscript>If you're seeing this message, either your browser doesn't support JavaScript, or it is disabled for some reason. This game requires JavaScript to play, so you'll need to make sure you're using a browser which supports it, and enable it, to play.</noscript>
<script src=raycast.js></script>
The "phantom faces" are occurring because an incorrect HitSide is being reported: you're saying the face was hit on a horizontal move (EastWest), but was actually hit on a vertical move (NorthSouth), or vice-versa.
Why is it reporting an incorrect value, then? if sideDistX < sideDistY then EastWest else NorthSouth seems pretty foolproof, right? And it is.
The problem isn't how we calculated that value. It's when we calculated that value. The distance calculation function needs to know the direction we moved in to get to the wall. However, what we've actually given is the direction we would move in if we were to keep going (that is, if that tile wasn't a wall, or we were to ignore it for some reason).
Look at the Haskell code:
traceRayInner arr step#(stepX, stepY) deltaDist#(deltaDistX, deltaDistY) tile sideDist#(sideDistX, sideDistY)
-- a wall has been hit, report hit direction and coördinates
| arr ! tile /= Empty = (hitSide, tile)
-- advance until a wall is hit
| otherwise = case hitSide of
EastWest ->
let newSideDist = first (deltaDistX+) sideDist
newTile = first (stepX+) tile
in
traceRayInner arr step deltaDist newTile newSideDist
NorthSouth ->
let newSideDist = second (deltaDistY+) sideDist
newTile = second (stepY+) tile
in
traceRayInner arr step deltaDist newTile newSideDist
where
hitSide = if sideDistX < sideDistY then EastWest else NorthSouth
Notice that we do things in this order:
calculate hitSide
check if a wall has been hit, and if so, report hitSide
move
Compare this to the original C++ code:
//perform DDA
while (hit == 0)
{
//jump to next map square, OR in x-direction, OR in y-direction
if (sideDistX < sideDistY)
{
sideDistX += deltaDistX;
mapX += stepX;
side = 0;
}
else
{
sideDistY += deltaDistY;
mapY += stepY;
side = 1;
}
//Check if ray has hit a wall
if (worldMap[mapX][mapY] > 0) hit = 1;
}
It does things in a different order:
check if a wall has been hit, and if so, report side (equivalent to hitSide)
move and calculate side
The C++ code only calculates side when it moves, and then it reports that value if it hits a wall. So, it reports the way it moved in order to hit the wall.
The Haskell code calculates side whether or not it moves: so it's correct for each move, but when it hits a wall, it reports the way it would have moved were it to keep going.
So, the Haskell code can be fixed by re-ordering it so that it checks for a hit after moving, and if so, reports the hitSide value from that move. This isn't pretty code, but it works:
traceRayInner arr step#(stepX, stepY) deltaDist#(deltaDistX, deltaDistY) tile sideDist#(sideDistX, sideDistY) =
let hitSide = if sideDistX < sideDistY then EastWest else NorthSouth
in case hitSide of
EastWest ->
let newSideDist = first (deltaDistX+) sideDist
newTile = first (stepX+) tile
in case arr ! newTile of
-- advance until a wall is hit
Empty -> traceRayInner arr step deltaDist newTile newSideDist
-- a wall has been hit, report hit direction and coördinates
_ -> (hitSide, newTile)
NorthSouth ->
let newSideDist = second (deltaDistY+) sideDist
newTile = second (stepY+) tile
in case arr ! newTile of
-- advance until a wall is hit
Empty -> traceRayInner arr step deltaDist newTile newSideDist
-- a wall has been hit, report hit direction and coördinates
_ -> (hitSide, newTile)
Problem solved!
Side note: I figured out what was wrong after carrying out the algorithm on paper. While in that particular case it just so happened the last two HitSide values matched, it became obvious that that they might not in every case. So, a big thanks to Madsy on Freenode's #algorithms for suggesting trying it out on paper. :)
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.