Gear.hs

module Gear
  ( makeGear
  ) where

--------------------------------------------------------------------------------

import Control.Monad (forM_, when)

import qualified Graphics.Rendering.OpenGL as GL

--------------------------------------------------------------------------------

makeGear :: Float -> Float -> Float -> Int -> Float -> GL.Color4 GL.GLfloat -> IO GL.DisplayList
makeGear inradius outradius width teeth toothdepth color =
    GL.defineNewList GL.Compile $ do
        GL.colorMaterial GL.$= Just (GL.Front, GL.AmbientAndDiffuse)
        GL.color color
        drawGear
  where
    drawGear = do
        let r0   = inradius
            r1   = outradius - toothdepth / 2
            r2   = outradius + toothdepth / 2
            pi2  = 2 * pi
            da   = pi2 / realToFrac teeth / 4 :: Float
            wd2  = width * 0.5
            wd2n = negate wd2

            calca :: Int -> Float
            calca i = realToFrac i * pi2 / realToFrac teeth :: Float

        GL.shadeModel GL.$= GL.Flat
        normal 0 0 1

        -- front face
        GL.renderPrimitive GL.QuadStrip $
            forM_ [0 .. teeth] $ \i -> do
                let a = calca i
                vertex (r0 * cos a) (r0 * sin a) wd2
                vertex (r1 * cos a) (r1 * sin a) wd2
                when (i < teeth) $ do
                    vertex (r0 * cos a) (r0 * sin a) wd2
                    vertex (r1 * cos (a + 3 * da)) (r1 * sin (a + 3 * da)) wd2

        -- front sides of teeth
        GL.renderPrimitive GL.Quads $
            forM_ [0 .. pred teeth] $ \i -> do
                let a = calca i
                vertex (r1 * cos a) (r1 * sin a) wd2
                vertex (r2 * cos (a + da)) (r2 * sin (a + da)) wd2
                vertex (r2 * cos (a + 2 * da)) (r2 * sin (a + 2 * da)) wd2
                vertex (r1 * cos (a + 3 * da)) (r1 * sin (a + 3 * da)) wd2

        normal 0 0 (-1)

        -- back face
        GL.renderPrimitive GL.QuadStrip $
            forM_ [0 .. teeth] $ \i -> do
                let a = calca i
                vertex (r1 * cos a) (r1 * sin a) wd2n
                vertex (r0 * cos a) (r0 * sin a) wd2n
                when (i < teeth) $ do
                    vertex (r1 * cos (a + 3 * da)) (r1 * sin (a + 3 * da)) wd2n
                    vertex (r0 * cos a) (r0 * sin a) wd2n

        -- back sides of teeth
        GL.renderPrimitive GL.Quads $
            forM_ [0 .. pred teeth] $ \i -> do
                let a = calca i
                vertex (r1 * cos (a + 3 * da)) (r1 * sin (a + 3 * da)) wd2n
                vertex (r2 * cos (a + 2 * da)) (r2 * sin (a + 2 * da)) wd2n
                vertex (r2 * cos (a + da)) (r2 * sin (a + da)) wd2n
                vertex (r1 * cos a) (r1 * sin a) wd2n

        -- outward faces of teeth
        GL.renderPrimitive GL.QuadStrip $ do
            forM_ [0 .. pred teeth] $ \i -> do
                let a = calca i
                vertex (r1 * cos a) (r1 * sin a) wd2
                vertex (r1 * cos a) (r1 * sin a) wd2n
                let u = r2 * cos (a + da) - r1 * cos a
                    v = r2 * sin (a + da) - r1 * sin a
                    len = sqrt (u * u + v * v)
                    un = u / len
                    vn = v / len
                normal vn (-un) 0
                vertex (r2 * cos (a + da)) (r2 * sin (a + da)) wd2
                vertex (r2 * cos (a + da)) (r2 * sin (a + da)) wd2n
                normal (cos a) (sin a) 0
                vertex (r2 * cos (a + 2 * da)) (r2 * sin (a + 2 * da)) wd2
                vertex (r2 * cos (a + 2 * da)) (r2 * sin (a + 2 * da)) wd2n
                let u' = r1 * cos (a + 3 * da) - r2 * cos (a + 2 * da)
                    v' = r1 * sin (a + 3 * da) - r2 * sin (a + 2 * da)
                normal v' (-u') 0
                vertex (r1 * cos (a + 3 * da)) (r1 * sin (a + 3 * da)) wd2
                vertex (r1 * cos (a + 3 * da)) (r1 * sin (a + 3 * da)) wd2n
                normal (cos a) (sin a) 0

            vertex (r1 * cos 0) (r1 * sin 0) wd2
            vertex (r1 * cos 0) (r1 * sin 0) wd2n

        GL.shadeModel GL.$= GL.Smooth

        -- inside radius cylinder
        GL.renderPrimitive GL.QuadStrip $
            forM_ [0 .. teeth] $ \i -> do
                let a = calca i
                normal (negate $ cos a) (negate $ sin a) 0
                vertex (r0 * cos a) (r0 * sin a) wd2n
                vertex (r0 * cos a) (r0 * sin a) wd2

vertex :: Float -> Float -> Float -> IO ()
vertex x y z =
    GL.vertex $ mkVertex x y z

mkVertex :: Float -> Float -> Float -> GL.Vertex3 GL.GLfloat
mkVertex x y z =
    GL.Vertex3 (realToFrac x) (realToFrac y) (realToFrac z)

normal :: Float -> Float -> Float -> IO ()
normal x y z =
    GL.normal $ mkNormal x y z

mkNormal :: Float -> Float -> Float -> GL.Normal3 GL.GLfloat
mkNormal x y z =
    GL.Normal3 (realToFrac x) (realToFrac y) (realToFrac z)