GLFW-b-demo 1.0.1 → 1.0.2
raw patch · 2 files changed
+130/−1 lines, 2 files
Files
- GLFW-b-demo.cabal +4/−1
- src/Gear.hs +126/−0
GLFW-b-demo.cabal view
@@ -1,5 +1,5 @@ name: GLFW-b-demo-version: 1.0.1+version: 1.0.2 author: Brian Lewis <brian@lorf.org> maintainer: Brian Lewis <brian@lorf.org>@@ -32,6 +32,9 @@ hs-source-dirs: src main-is: Main.hs++ other-modules:+ Gear build-depends: GLFW-b == 1.1.*,
+ src/Gear.hs view
@@ -0,0 +1,126 @@+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)