GLUT-2.7.0.16: examples/Misc/Gears.hs
{-
Gears.hs (adapted from gears.c which is (c) Brian Paul)
Copyright (c) Shawn P. Garbett 2004 <shawn@garbett.org>
Further hacked by Sven Panne <svenpanne@gmail.com>
This file is part of HOpenGL and distributed under a BSD-style license
See the file libraries/GLUT/LICENSE
Command line options:
-info print GL implementation information
-exit automatically exit after 30 seconds
-}
--------------------------------------------------------------------------------
import Control.Monad ( when )
import Data.IORef ( IORef, newIORef )
import Data.List ( intersperse )
import System.Console.GetOpt
import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure )
import Graphics.UI.GLUT
--------------------------------------------------------------------------------
type View = (GLfloat, GLfloat, GLfloat)
data State = State {
frames :: IORef Int,
t0 :: IORef Int,
viewRot :: IORef View,
angle' :: IORef GLfloat }
makeState :: IO State
makeState = do
f <- newIORef 0
t <- newIORef 0
v <- newIORef (20, 30, 0)
a <- newIORef 0
return $ State { frames = f, t0 = t, viewRot = v, angle' = a }
-- Draw a gear wheel. You'll probably want to call this function when
-- building a display list since we do a lot of trig here.
--
-- Input: innerRadius - radius of hole at center
-- outerRadius - radius at center of teeth
-- width - width of gear
-- teeth - number of teeth
-- toothDepth - depth of tooth
gear :: GLfloat -> GLfloat -> GLfloat -> GLint -> GLfloat -> IO ()
gear innerRadius outerRadius width teeth toothDepth = do
let r0 = innerRadius
r1 = outerRadius - toothDepth / 2
r2 = outerRadius + toothDepth / 2
da = 2 * pi / fromIntegral teeth / 4
w = 0.5 * width
render p f =
renderPrimitive p $
mapM_ (\i -> let angle = fromIntegral i * 2 * pi / fromIntegral teeth
in f r0 r1 r2 w da teeth i angle)
[ 0 .. teeth ]
shadeModel $= Flat
currentNormal $= Normal3 0 0 1
render QuadStrip gearFront
render Quads teethFront
currentNormal $= Normal3 0 0 (-1)
render QuadStrip gearBack
render Quads teethBack
render QuadStrip teethFace
shadeModel $= Smooth
render QuadStrip gearInside
type Renderer =
GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLint -> GLint -> GLfloat -> IO ()
-- draw front face
gearFront :: Renderer
gearFront r0 r1 _ w da teeth i angle = do
vertex (Vertex3 (r0 * cos angle) (r0 * sin angle) w)
vertex (Vertex3 (r1 * cos angle) (r1 * sin angle) w)
when (i < teeth) $ do
vertex (Vertex3 (r0 * cos angle ) (r0 * sin angle ) w)
vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da)) w)
-- draw front sides of teeth
teethFront :: Renderer
teethFront _ r1 r2 w da teeth i angle =
when (i < teeth) $ do
vertex (Vertex3 (r1 * cos angle ) (r1 * sin angle ) w)
vertex (Vertex3 (r2 * cos (angle + da)) (r2 * sin (angle + da)) w)
vertex (Vertex3 (r2 * cos (angle + 2 * da)) (r2 * sin (angle + 2 * da)) w)
vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da)) w)
-- draw back face
gearBack :: Renderer
gearBack r0 r1 _ w da teeth i angle = do
vertex (Vertex3 (r1 * cos angle) (r1 * sin angle) (-w))
vertex (Vertex3 (r0 * cos angle) (r0 * sin angle) (-w))
when (i < teeth) $ do
vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da)) (-w))
vertex (Vertex3 (r0 * cos angle ) (r0 * sin angle ) (-w))
-- draw back sides of teeth
teethBack :: Renderer
teethBack _ r1 r2 w da teeth i angle =
when (i < teeth) $ do
vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da)) (-w))
vertex (Vertex3 (r2 * cos (angle + 2 * da)) (r2 * sin (angle + 2 * da)) (-w))
vertex (Vertex3 (r2 * cos (angle + da)) (r2 * sin (angle + da)) (-w))
vertex (Vertex3 (r1 * cos angle ) (r1 * sin angle ) (-w))
-- draw outward faces of teeth
teethFace :: Renderer
teethFace _ r1 r2 w da teeth i angle =
if (i < teeth) then do
vertex (Vertex3 (r1*(cos angle)) (r1*(sin angle)) w)
vertex (Vertex3 (r1*(cos angle)) (r1*(sin angle)) (-w))
let u' = r2 * cos (angle + da) - r1 * cos angle
v' = r2 * sin (angle + da) - r1 * sin angle
len = sqrt (u' * u' + v' * v')
u = u' / len
v = v' / len
currentNormal $= Normal3 v (-u) 0
vertex (Vertex3 (r2 * cos (angle + da)) (r2 * sin (angle + da)) w )
vertex (Vertex3 (r2 * cos (angle + da)) (r2 * sin (angle + da)) (-w))
currentNormal $= Normal3 (cos angle) (sin angle) 0
vertex (Vertex3 (r2 * cos (angle + 2 * da)) (r2 * sin (angle + 2 * da)) w )
vertex (Vertex3 (r2 * cos (angle + 2 * da)) (r2 * sin (angle + 2 * da)) (-w))
let u2 = r1 * cos (angle + 3 * da) - r2 * cos (angle + 2 * da);
v2 = r1 * sin (angle + 3 * da) - r2 * sin (angle + 2 * da);
currentNormal $= Normal3 v2 (-u2) 0
vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da)) w )
vertex (Vertex3 (r1 * cos (angle + 3 * da)) (r1 * sin (angle + 3 * da)) (-w))
currentNormal $= Normal3 (cos angle) (sin angle) 0
else do
vertex (Vertex3 (r1 * cos 0) (r1 * sin 0) w )
vertex (Vertex3 (r1 * cos 0) (r1 * sin 0) (-w))
-- draw inside radius cylinder
gearInside :: Renderer
gearInside r0 _ _ w _ _ _ angle = do
currentNormal $= Normal3 (-cos angle) (-sin angle) 0
vertex (Vertex3 (r0 * cos angle) (r0 * sin angle) (-w))
vertex (Vertex3 (r0 * cos angle) (r0 * sin angle) w )
draw :: (DisplayList,DisplayList,DisplayList,Int) -> State -> IO ()
draw (gear1, gear2, gear3, autoexit) state = do
clear [ ColorBuffer, DepthBuffer ]
(x, y, z) <- get (viewRot state)
a <- get (angle' state)
let translatef = translate :: Vector3 GLfloat -> IO ()
preservingMatrix $ do
rotate x (Vector3 1 0 0)
rotate y (Vector3 0 1 0)
rotate z (Vector3 0 0 1)
preservingMatrix $ do
translatef (Vector3 (-3) (-2) 0)
rotate a (Vector3 0 0 1)
callList gear1
preservingMatrix $ do
translatef (Vector3 3.1 (-2) 0)
rotate (-2 * a - 9) (Vector3 0 0 1)
callList gear2
preservingMatrix $ do
translatef (Vector3 (-3.1) 4.2 0)
rotate (-2 * a - 25) (Vector3 0 0 1)
callList gear3
swapBuffers
frames state $~! (+1)
t0' <- get (t0 state)
t <- get elapsedTime
when (t - t0' >= 5000) $ do
f <- get (frames state)
let seconds = fromIntegral (t - t0') / 1000 :: GLfloat
fps = fromIntegral f / seconds
putStrLn (show f ++ " frames in " ++ show seconds ++ " seconds = "++ show fps ++ " FPS")
t0 state $= t
frames state $= 0
when ((t >= 999 * autoexit) && (autoexit /= 0)) $
exitWith ExitSuccess
idle :: State -> IdleCallback
idle state = do
angle' state $~! (+2)
postRedisplay Nothing
keyboard :: State -> KeyboardMouseCallback
keyboard state (Char 'z') _ _ _ = modRot state ( 0, 0, 5)
keyboard state (Char 'Z') _ _ _ = modRot state ( 0, 0, -5)
keyboard state (SpecialKey KeyUp) _ _ _ = modRot state ( 5, 0, 0)
keyboard state (SpecialKey KeyDown) _ _ _ = modRot state (-5, 0, 0)
keyboard state (SpecialKey KeyLeft) _ _ _ = modRot state ( 0, 5, 0)
keyboard state (SpecialKey KeyRight)_ _ _ = modRot state ( 0, -5, 0)
keyboard _ (Char '\27') _ _ _ = exitWith ExitSuccess
keyboard _ _ _ _ _ = return ()
modRot :: State -> View -> IO ()
modRot state (dx,dy,dz) = do
(x, y, z) <- get (viewRot state)
viewRot state $= (x + dx, y + dy, z + dz)
postRedisplay Nothing
-- new window size or exposure
reshape :: ReshapeCallback
reshape s@(Size width height) = do
let h = fromIntegral height / fromIntegral width
viewport $= (Position 0 0, s)
matrixMode $= Projection
loadIdentity
frustum (-1) 1 (-h) h 5 60
matrixMode $= Modelview 0
loadIdentity
translate (Vector3 0 0 (-40 :: GLfloat))
data Flag = GLInfo | AutoExit deriving ( Eq, Ord, Show )
argInfo :: [OptDescr Flag]
argInfo = [
Option ['i'] ["info"] (NoArg GLInfo) "print gl information",
Option ['e'] ["exit"] (NoArg AutoExit) "auto exit after 30 seconds" ]
opts :: [String] -> IO [Flag]
opts args =
case getOpt Permute argInfo args of
(o,_,[]) -> return o
(_,_,errs) -> do
putStr (concat errs ++ usageInfo "Usage: Gears [OPTION...]" argInfo)
exitFailure
info :: IO ()
info = do
rendererStr <- get renderer
putStrLn ("GL_RENDERER = " ++ rendererStr)
vendorStr <- get vendor
putStrLn ("GL_VENDOR = " ++ vendorStr)
versionStr <- get glVersion
putStrLn ("GL_VERSION = " ++ versionStr)
exts <- get glExtensions
putStrLn ("GL_EXTENSIONS = " ++ concat (intersperse " " exts))
myInit :: [String] -> IO (DisplayList,DisplayList,DisplayList,Int)
myInit args = do
position (Light 0) $= Vertex4 5 5 10 0
cullFace $= Just Back
lighting $= Enabled
light (Light 0) $= Enabled
depthFunc $= Just Less
-- make the gears
g1 <- defineNewList Compile $ do
materialAmbientAndDiffuse Front $= Color4 0.8 0.1 0.0 1.0
gear 1 4 1 20 0.7
g2 <- defineNewList Compile $ do
materialAmbientAndDiffuse Front $= Color4 0.0 0.8 0.2 1.0
gear 0.5 2 2 10 0.7
g3 <- defineNewList Compile $ do
materialAmbientAndDiffuse Front $= Color4 0.2 0.2 1.0 1.0
gear 1.3 2 0.5 10 0.7
normalize $= Enabled
flags <- opts args
when (GLInfo `elem` flags) info
let autoexit = if AutoExit `elem` flags then 30 else 0
when (autoexit /= 0) $
putStrLn ("Auto Exit after " ++ show autoexit ++ " seconds.")
return (g1, g2, g3, autoexit)
visible :: State -> Visibility -> IO ()
visible state Visible = idleCallback $= Just (idle state)
visible _ NotVisible = idleCallback $= Nothing
main :: IO ()
main = do
(_progName, args) <- getArgsAndInitialize
initialDisplayMode $= [ RGBMode, WithDepthBuffer, DoubleBuffered ]
initialWindowPosition $= Position 0 0
initialWindowSize $= Size 300 300
_ <- createWindow "Gears"
state <- makeState
gearsAndAuto <- myInit args
displayCallback $= draw gearsAndAuto state
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboard state)
visibilityCallback $= Just (visible state)
mainLoop