Drawing a torus with Haskell

Posted on May 26, 2018 by Stéphane Laurent

Problem: With the Haskell OpenGL library, how to draw a torus passing by three given points?

Firstly, we write a function to get the circle passing by three given points, with the help of the linear library. The imported toList function will be used later.

The circleCenterRadius function returns the center of the circle passing by the points p1, p2, p3, its radius \(R\), as well as a vector perpendicular to the plane passing by these points.

Now we write a function which returns an appropriate transformation matrix. The torus drawn by Torus in the GLUT library is always centered at \((0,0,0)\) and it is in the \(xy\)-plane (the plane \(z=0\)). Setting its outer radius to \(R\), we are looking for the transformation matrix which maps this torus to the desired torus.

The function transformationMatrix also returns the radius \(R\). The matrix it returns is given by a list, thanks to the toList function. We return this list instead of a matrix of the linear library in order to use it in OpenGL. The transformation matrix is applied with the multMatrix function of OpenGL:

module TestTransformationMatrix
import           Data.Tuple.Extra             (fst3, snd3, thd3, second)
import           Graphics.Rendering.OpenGL.GL
import           Graphics.UI.GLUT
import           Linear                       (V3 (..))
import           TransformationMatrix

type Point = (GLfloat,GLfloat,GLfloat)

pointToV3 :: Point -> V3 GLfloat
pointToV3 (x,y,z) = V3 x y z

myTriplet :: (Point, Point, Point) -- the three points for our test
myTriplet = ((-1,5,1),(2,1,8),(-5,0,3))

white,black,blue :: Color4 GLfloat
white      = Color4    1    1    1    1
black      = Color4    0    0    0    1
blue       = Color4    0    0    1    1

tmatAndRadius :: ([GLfloat], GLdouble)
tmatAndRadius = second realToFrac (transformationMatrix
                                   (pointToV3 $ fst3 myTriplet)
                                   (pointToV3 $ snd3 myTriplet)
                                   (pointToV3 $ thd3 myTriplet))

display :: DisplayCallback
display = do
  clear [ColorBuffer, DepthBuffer]
  preservingMatrix $ do
    m <- newMatrix RowMajor (fst tmatAndRadius) :: IO (GLmatrix GLfloat)
    multMatrix m
    materialDiffuse Front $= blue
    renderObject Solid $ Torus 0.2 (snd tmatAndRadius) 30 30
  renderPrimitive Triangles $
    mapM_ (\(x, y, z) -> vertex $ Vertex3 x y z)
          [fst3 myTriplet, snd3 myTriplet, thd3 myTriplet]

resize :: Size -> IO ()
resize s@(Size w h) = do
  viewport $= (Position 0 0, s)
  matrixMode $= Projection
  perspective 45.0 (w'/h') 1.0 100.0
  lookAt (Vertex3 0 0 (-20)) (Vertex3 0 0 0) (Vector3 0 1 0)
  matrixMode $= Modelview 0
    w' = realToFrac w
    h' = realToFrac h

main :: IO ()
main = do
  _ <- getArgsAndInitialize
  _ <- createWindow "Torus passing by three points"
  windowSize $= Size 500 500
  initialDisplayMode $= [RGBAMode, DoubleBuffered, WithDepthBuffer]
  clearColor $= white
  materialAmbient Front $= black
  lighting $= Enabled
  light (Light 0) $= Enabled
  position (Light 0) $= Vertex4 0 0 (-100) 1
  ambient (Light 0) $= black
  diffuse (Light 0) $= white
  specular (Light 0) $= black
  depthFunc $= Just Less
  shadeModel $= Smooth
  displayCallback $= display
  reshapeCallback $= Just resize
  idleCallback $= Nothing

And here is the result:

Thanks to this technique, I made a Haskell library to draw Hopf tori with OpenGL. This library is available here.