 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.

## Core Maths

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

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.

## Surfaces

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
, 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
``````

## Scenes

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`.

## Rendering

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
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

### You may be interested in...

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.