Rendering in Haskell, Part 2: Flat Shading

Flat shading 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:

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) Points and Vectors.

Finally I have utility functions:

  • to: Get a Vector between two Points;
  • 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
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 Points and Vectors 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 Surfaces. 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 Surfaces, 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 Maybes - 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 Rays 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:

Flat shading

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

Pinterest
Reddit
Hacker News

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.

Comments? Questions?