Now that I’ve got the business of being able to write image files from Haskell sorted, I need to move on to the next most simple thing: projecting three-dimensional shapes onto the screen. Here I’m not going to worry about lighting - everything will be flat shaded.

The main source on Github is split into separate folders for each ‘experiment’. Each folder starts as a copy-paste of the previous, so you can see what’s changed to get from the previous stage to the next just by diffing the source trees.

I’ve collected the core maths routines, into a single file:

https://github.com/stu-smith/rendering-in-haskell/blob/master/src/experiment01/Core.hs

It’s all pretty standard stuff so I won’t show the code, but suffice to say I defined the following types:

`Vector`

`Point`

`Ray`

(a combination of a`Point`

and a`Vector`

)

I have a typeclass `Transform`

that allows me to translate (move) `Point`

s and `Vector`

s.

Finally I have utility functions:

`to`

: Get a`Vector`

between two`Point`

s;`normalize`

: Convert a`Vector`

to have unit length;`magnitude`

and`magnitudeSquared`

, to get the length of a vector;`neg`

, to reverse a vector;`|*|`

, for vector scaling;`|+|`

, to add two vectors;`cross`

, to find the cross-product between two vectors;`|.|`

, to take the dot product between two vectors.

I represent three-dimensional objects in the scene as surfaces. Each surface only needs two pieces of information: a function that determines whether a ray intersects the surface, and a color to shade the surface.

```
data Surface = Surface
{ intersection :: Ray -> Maybe Double
, flatColor :: !Color
}
```

In this first example, I only support two kinds of surfaces: planes and spheres.

```
mkPlane :: Point -> Vector -> Color -> Surface
mkPlane !point !normal !color = Surface
{ intersection = planeIntersection point normal
, flatColor = color
}
planeIntersection :: Point -> Vector -> Ray -> Maybe Double
planeIntersection point normal (Ray ro rd)
| ln == 0.0 = Nothing
| d < 0.0 = Nothing
| otherwise = Just d
where
d = ((ro `to` point) |.| normal) / ln
ln = rd |.| normal
```

Spheres are always created at the origin for simplicity:

```
mkSphere :: Double -> Color -> Surface
mkSphere !radius !color = Surface
{ intersection = sphereIntersection radius
, flatColor = color
}
sphereIntersection :: Double -> Ray -> Maybe Double
sphereIntersection !r (Ray !ro !rd)
| det < 0 = Nothing
| b - sd > eps = Just (b - sd)
| b + sd > eps = Just (b + sd)
| otherwise = Nothing
where
!op = ro `to` origin
!eps = 1e-4
!b = op |.| rd
!det = (b * b) - (op |.| op) + (r * r)
sd = sqrt det
```

That’s clearly very limiting, so I allow a `Surface`

to be translated using the `Transform`

typeclass,
in exactly the same way that I allow `Point`

s and `Vector`

s to be translated:

```
instance Transform Surface where
translate !v (Surface sfcIntersection sfcColor) =
Surface { intersection = newIntersection
, flatColor = sfcColor
}
where
newIntersection !ray = sfcIntersection $ translate nv ray
nv = neg v
```

A `Scene`

is simply a collection of `Surface`

s. In keeping with much of the rest of the code, the actual
data constructur is private to the module, and only a constructor function is exposed:

```
data Scene = Scene [Surface]
mkScene :: [Surface] -> Scene
mkScene =
Scene
```

The primary function of a `Scene`

is to manage testing rays against the surfaces within it. If a `Ray`

intersects a `Surface`

, we want to know details about that intersection:

```
data Intersection = Intersection
{ rayTested :: Ray
, surface :: Surface
, rayPosition :: Double
, worldPosition :: Point
}
```

When a `Ray`

is cast into a `Scene`

, we need to know the closest `Surface`

that intersected. Here
I do this via a very simple brute-force linear scan of all `Surface`

s, ordered by distance from
the ray’s origin. (Later I expect I’ll have to change this to a more optimal algorithm, but it will
do for now).

```
sceneIntersection :: Scene -> Ray -> Maybe Intersection
sceneIntersection (Scene surfaces) ray =
minimumBy (comparing rayPosition) <$> maybeIntersections
where
allIntersections = mapMaybe (renderableIntersection ray) surfaces
maybeIntersections = maybeList allIntersections
maybeList [] = Nothing
maybeList xs@(_:_) = Just xs
renderableIntersection :: Ray -> Surface -> Maybe Intersection
renderableIntersection ray sfc =
toIntersection <$> intersection sfc ray
where
toIntersection t =
Intersection { rayTested = ray
, surface = sfc
, rayPosition = t
, worldPosition = ray `at` t
}
```

Everything here is in terms of `Maybe`

s - a `Ray`

might or might not intersect a `Surface`

.

The rendering function for this experiment is very simple: if we intersect a `Surface`

, we simply
use its defined flat color:

```
renderRay :: Ray -> Scene -> Color
renderRay ray scene =
getColor maybeIntersection
where
maybeIntersection = sceneIntersection scene ray
getColor Nothing = Color 0.0 0.0 0.0
getColor (Just (Intersection _ (Surface _ c) _ _)) = c
```

Generating the `Ray`

s from pixel positions is slightly more involved, but is a basic perspective
transform:

```
render :: Ray -> Scene -> Int -> Int -> Int -> Int -> Color
render (Ray camOrigin camDirection) scene !x !y !w !h =
renderRay rr scene
where
rr = Ray { rayOrigin = translate (d |*| focal) camOrigin
, rayDirection = normalize d
}
d = (cx |*| ( dx / dw - 0.5)) |+|
(cy |*| (0.5 - dy / dh )) |+|
camDirection
cx = Vector (dw * aspect / dh) 0.0 0.0
cy = normalize (cx `cross` camDirection) |*| aspect
aspect = dh / dw / 2.0
focal = 140.0
dw = fromIntegral w
dh = fromIntegral h
dx = fromIntegral x
dy = fromIntegral y
```

(This function matches the x,y,width,height format used previously, so it slots straight into the bitmap render function we used before).

For my example scene, I’m using a modified Cornell box:

```
cornellBox :: Scene
cornellBox = mkScene
[ plane (Point 1.0 40.8 81.6) (Vector 1.0 0.0 0.0) (Color 0.75 0.25 0.25)
, plane (Point 99.0 40.8 81.6) (Vector (-1.0) 0.0 0.0) (Color 0.25 0.25 0.75)
, plane (Point 50.0 40.8 0.0) (Vector 0.0 0.0 1.0) (Color 0.75 0.75 0.75)
, plane (Point 50.0 0.0 81.6) (Vector 0.0 1.0 0.0) (Color 0.75 0.75 0.75)
, plane (Point 50.0 81.6 81.6) (Vector 0.0 (-1.0) 0.0) (Color 0.75 0.75 0.75)
, plane (Point 50.0 40.8 170.0) (Vector 0.0 0.0 (-1.0)) (Color 0.00 0.00 0.00)
, sphere (Point 27.0 16.5 47.0) 16.5 (Color 0.99 0.99 0.99)
, sphere (Point 73.0 16.5 78.0) 16.5 (Color 0.99 0.99 0.99)
, sphere (Point 50.0 681.33 81.6) 600.0 (Color 1.00 1.00 1.00)
]
sphere :: Point -> Double -> Color -> Surface
sphere center radius color =
translate (origin `to` center) $ mkSphere radius color
plane :: Point -> Vector -> Color -> Surface
plane =
mkPlane
```

Finally, my `main`

function is modified slightly to tie everything together, viewed from a suitable
camera angle (supplied as a `Ray`

):

```
main :: IO ()
main = do
putStrLn "Starting render..."
createDirectoryIfMissing True "output"
saveRender "output/experiment01.bmp" 640 480 $ render cam cornellBox
putStrLn "Written output to output/experiment01.bmp"
where
cam = Ray { rayOrigin = Point 50.0 52.0 295.6
, rayDirection = normalize $ Vector 0.0 (-0.042612) (-1.0)
}
```

The final image is as follows:

It’s still nowhere near being photorealistic, but at least we have basic intersection tests in place, plus perspective transforms.

Code is in Github, if you want to take a look.

Published: Monday, July 06, 2015

Hackification.io is a participant in the Amazon Services LLC Associates Program, an affiliate advertising program designed to provide a means for sites to earn advertising fees by advertising and linking to amazon.com. I may earn a small commission for my endorsement, recommendation, testimonial, and/or link to any products or services from this website.