[HOpenGL] GlxGears
Shawn P. Garbett
listman at garbett.org
Mon Mar 15 20:34:13 EST 2004
I translated GlxGears to HOpenGl, and it runs a bit slower than C
version. I was curious what optimizations could be made to run it
faster, or other comments. I love the style of Haskell, it leads one
down the road to strong cohesion and low coupling as the easiest path.
Even if all out speed was a top concern, I think it would be
faster/more effective to write it in Haskell, then convert it to C.
Haskell Version on my laptop, FPS = 103
C Version on my laptop, FPS = 192
I've included the source as text. Enjoy-- all constructive criticism
appreciated. Beware the line wrap...
Shawn
-----------------------------------------------------------------------------
--
--
-- Copyright (c) 2004 Shawn P. Garbett
-- All rights reserved.
--
-- Redistribution and use in sourse and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by Shawn P. Garbett. The name of Shawn P. Garbett
-- may not be used to endorse or promote products derived from this
-- software without specific prior writte permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EPXRESS OR
-- IMPLIED WARRANTIES, INCLUDING LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
--
-------------------------------------------------------------------------------
-----------------------------------------------------------------------------
--
-- Author -
-- Shawn P. Garbett
-- eLucid Software
-- March, 2004
-- Modifications -
--
-- Status -
-- Public Domain. Distribution Unlimited.
--
-- Bugs -
-- The -i option prints nothing
-- Auto exit not complete
-- Why is it so slow compared to C? 103 fps in Haskell versus 192
fps in C
--
-- Compile: ghc -package GLUT -o Gears Gears.hs
--
-------------------------------------------------------------------------------
import Graphics.UI.GLUT as GLUT
import Graphics.Rendering.OpenGL as OpenGL
import System.Exit
import Data.IORef
import GHC.Base (chr)
import System.Console.GetOpt
import System.Environment (getArgs)
instance HasSetter IORef where
($=) var val = writeIORef var val
instance HasGetter IORef where
get var = readIORef var
new = newIORef
type Frames = IORef (Int, Int)
type View = IORef (GLfloat, GLfloat, GLfloat)
type ViewFunc =
((GLfloat->GLfloat),(GLfloat->GLfloat),(GLfloat->GLfloat))
pi :: GLfloat
pi = 3.14159265
configure :: IO (DisplayList,DisplayList,DisplayList)
configure = do
position (Light 0) $= Vertex4 5.0 5.0 10.0 0.0
lighting $= Enabled
light (Light 0) $= Enabled
depthFunc $= Just Less
g1 <- gear1
g2 <- gear2
g3 <- gear3
normalize $= Enabled
return (g1, g2, g3)
-- Command line options (that start with a dash)
data Flag = GLInfo | Exit deriving Show
options :: [OptDescr Flag]
options =
[ Option ['i'] ["info"] (NoArg GLInfo) "print gl information",
Option ['e'] ["exit"] (NoArg Exit) "auto exit after 30 seconds" ]
usageHeader :: String
usageHeader = "Usage: Gears [-info] [-exit]"
opts :: [String] -> IO [Flag]
opts argv =
case (getOpt Permute options argv) of
(o,_,[]) -> return o
(_,_,errs) -> ioError $ userError $
concat errs ++ usageInfo usageHeader
options
-- Print info about the GL renderer
info' :: IO ()
info' =
do
rendererStr <- get renderer
putStr "GL_RENDERER = "
putStr rendererStr
putStr "\n"
vendorStr <- get vendor
putStr "GL_VENDOR = "
putStr vendorStr
putStr "\n"
versionStr <- get glVersion
putStr "GL_VERSION = "
putStr versionStr
putStr "\n"
extStr <- get glExtensions
putStr "GL_EXTENSIONS = "
putStr $ show extStr
putStr "\n"
-- Was the info flag given?
info :: [Flag] -> IO ()
info (GLInfo:_) = info'
info (_:fs) = info fs
info _ = return ()
-- Main
main :: IO ()
main =
do
(progName,args) <- getArgsAndInitialize
flags <- opts args
info flags
initialDisplayMode $= [RGBMode, WithDepthBuffer, DoubleBuffered]
-- View rotation variable (x,y,z)
viewRot <- new (20.0::GLfloat, 30.0::GLfloat, 0.0::GLfloat)
-- Gear angle variable
angle <- new (0.0::GLfloat)
-- Frames
frames <- new (0, 0)
-- Create the window
createWindow progName
gears <- configure
-- Hook up callbacks
displayCallback $= display gears frames viewRot angle
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboard viewRot)
visibilityCallback $= Just (visible angle)
--go for it
mainLoop
-- Reshape event handling
reshape :: Size -> IO ()
reshape s@(Size w h) =
do
let r = (fromIntegral h)/(fromIntegral w)
viewport $= (Position 0 0, s)
matrixMode $= Projection
loadIdentity
frustum (-1.0) 1.0 (-r) r 5.0 60.0
matrixMode $= Modelview 0
loadIdentity
translate (Vector3 0 0 (-40.0::GLfloat))
-- Visibility event handling
visible :: IORef GLfloat -> Visibility -> IO ()
visible angle Visible = idleCallback $= Just (idle angle)
visible _ NotVisible = idleCallback $= Nothing
-- Idle event handling
idle :: IORef GLfloat -> IO ()
idle angle = do
a <- get angle
angle $= a + 2.0;
postRedisplay Nothing
-- Color constants
red = Color4 0.8 0.1 0.0 1.0
green = Color4 0.0 0.8 0.2 1.0
blue = Color4 0.2 0.2 1.0 1.0
-- Front of gear face
gearFront :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLint -> GLint
-> IO ()
gearFront r0 r1 w da n t =
do
let angle = (fromIntegral n)*2.0*Main.pi/(fromIntegral t)
vertex $ Vertex3 (r0*(cos angle)) (r0*(sin angle)) w
vertex $ Vertex3 (r1*(cos angle)) (r1*(sin angle)) w
if (n<t)
then do
vertex $ Vertex3 (r0*(cos angle)) (r0*(sin angle)) w
vertex $ Vertex3 (r1*(cos (angle+3*da))) (r1*(sin
(angle+3*da))) w
gearFront r0 r1 w da (n+1) t
else return ()
-- front side of teeth
teethFront :: GLfloat->GLfloat->GLfloat->GLfloat->GLint->GLint->IO ()
teethFront r1 r2 w da n t =
do
if (n<t)
then do
let angle = (fromIntegral n)*2.0*Main.pi/(fromIntegral t)
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.0*da))) (r2*(sin
(angle+2.0*da))) w
vertex $ Vertex3 (r1*(cos (angle+3.0*da))) (r1*(sin
(angle+3.0*da))) w
teethFront r1 r2 w da (n+1) t
else
return ()
--back side of gear
gearBack :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLint -> GLint
-> IO ()
gearBack r0 r1 w da n t =
do
let angle = (fromIntegral n)*2.0*Main.pi/(fromIntegral t)
vertex $ Vertex3 (r1*(cos angle)) (r1*(sin angle)) w
vertex $ Vertex3 (r0*(cos angle)) (r0*(sin angle)) w
if (n<t)
then do
vertex $ Vertex3 (r1*(cos (angle+3*da))) (r1*(sin
(angle+3*da))) w
vertex $ Vertex3 (r0*(cos angle)) (r0*(sin angle)) w
gearFront r0 r1 w da (n+1) t
else return ()
-- back side of teeth
teethBack :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLint -> GLint
-> IO()
teethBack r1 r2 w da n t =
do
if (n<t)
then do
let angle = (fromIntegral n)*2.0*Main.pi/(fromIntegral t)
vertex $ Vertex3 (r1*(cos (angle+3.0*da))) (r1*(sin
(angle+3.0*da))) w
vertex $ Vertex3 (r2*(cos (angle+2.0*da))) (r2*(sin
(angle+2.0*da))) w
vertex $ Vertex3 (r2*(cos (angle+1.0*da))) (r2*(sin
(angle+1.0*da))) w
vertex $ Vertex3 (r1*(cos (angle+da))) (r1*(sin (angle+da)))
w
teethBack r1 r2 w da (n+1) t
else
return ()
-- Outward faces of teeth */
teethFace :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLint -> GLint
-> IO ()
teethFace r1 r2 w da n t =
if (n<t) then do
let angle = (fromIntegral n)*2.0*Main.pi/(fromIntegral t)
nw = (-w)
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
u2 = r1*(cos (angle+3.0*da))-r2*(cos (angle+2.0*da))
v2 = r1*(sin (angle+3.0*da))-r2*(sin (angle+2.0*da))
vertex $ Vertex3 (r1*(cos angle)) (r1*(sin angle)) w
vertex $ Vertex3 (r1*(cos angle)) (r1*(sin angle)) nw
currentNormal $= Normal3 v (-u) 0.0
vertex $ Vertex3 (r2*(cos (angle+da))) (r2*(sin (angle+da))) w
vertex $ Vertex3 (r2*(cos (angle+da))) (r2*(sin (angle+da))) nw
currentNormal $= Normal3 (cos angle) (sin angle) 0.0
vertex $ Vertex3 (r2*(cos (angle+2.0*da))) (r2*(sin (angle+2.0*da)))
w
vertex $ Vertex3 (r2*(cos (angle+2.0*da))) (r2*(sin (angle+2.0*da)))
nw
currentNormal $= Normal3 v (-u) 0.0
vertex $ Vertex3 (r1*(cos (angle+3.0*da))) (r1*(sin (angle+3.0*da)))
w
vertex $ Vertex3 (r1*(cos (angle+3.0*da))) (r1*(sin (angle+3.0*da)))
nw
currentNormal $= Normal3 (cos angle) (sin angle) 0.0
teethFace r1 r2 w da (n+1) t
else do
vertex $ Vertex3 r1 0.0 w
vertex $ Vertex3 r1 0.0 (-w)
-- Inside Radius
gearInside :: GLfloat -> GLfloat -> GLint -> GLint -> IO ()
gearInside r w n t =
do
let angle = (fromIntegral n)*2.0*Main.pi/(fromIntegral t)
currentNormal $= Normal3 (-(cos angle)) (-(sin angle)) 0.0
vertex $ Vertex3 (r*(cos angle)) (r*(sin angle)) (-w)
vertex $ Vertex3 (r*(cos angle)) (r*(sin angle)) w
if (n<t) then gearInside r w (n+1) t
else return ()
-- Gear drawing routine
gear :: GLfloat -> GLfloat -> GLfloat -> GLint -> GLfloat -> IO ()
gear r0 o_radius width teeth depth =
do
let r1 = o_radius - depth / 2.0::GLfloat
r2 = o_radius + depth / 2.0::GLfloat
da = 2.0 * Main.pi / (fromIntegral teeth) / 4.0::GLfloat
w = 0.5 * width
shadeModel $= Flat
currentNormal $= Normal3 0.0 0.0 (1.0::GLfloat)
renderPrimitive QuadStrip $ gearFront r0 r1 w da 0 teeth
renderPrimitive Quads $ teethFront r1 r2 w da 0 teeth
renderPrimitive QuadStrip $ gearBack r0 r1 (-w) da 0 teeth
renderPrimitive Quads $ teethBack r1 r2 (-w) da 0 teeth
renderPrimitive QuadStrip $ teethFace r1 r2 w da 0 teeth
shadeModel $= Smooth
renderPrimitive QuadStrip $ gearInside r0 w 0 teeth
return ()
-- Create the different gears
gear1 :: IO DisplayList
gear1 = defineNewList Compile $ do
materialAmbientAndDiffuse Front $= red
gear (1.0::GLfloat) (4.0::GLfloat) (1.0::GLfloat)
(20::GLint) (0.7::GLfloat)
gear2 :: IO DisplayList
gear2 = defineNewList Compile $ do
materialAmbientAndDiffuse Front $= green
gear (0.5::GLfloat) (2.0::GLfloat) (2.0::GLfloat)
(10::GLint) (0.7::GLfloat)
gear3 :: IO DisplayList
gear3 = defineNewList Compile $ do
materialAmbientAndDiffuse Front $= blue
gear (1.3::GLfloat) (2.0::GLfloat) (0.5::GLfloat)
(10::GLint) (0.7::GLfloat)
printFPS :: Frames -> IO ()
printFPS frame =
do
(f,et) <- get frame
ms <- get elapsedTime
if ((ms - et) > 5000)
then
do
let seconds = (fromIntegral (ms - et))/1000.0
fps = (fromIntegral f) / seconds
putStr $ show f
putStr " frames in "
putStr $ show seconds
putStr " seconds = "
putStr $ show fps
putStr " FPS\n"
frame $= (0, ms)
else
frame $= (f+1, et)
-- Display event handling
display :: (DisplayList,DisplayList,DisplayList) ->
Frames -> View -> IORef GLfloat -> IO ()
display (g1,g2,g3) frames viewRot angle =
do
clear [ColorBuffer,DepthBuffer]
(x,y,z) <- get viewRot
a <- get angle
printFPS frames
preservingMatrix $ do
rotate x $ Vector3 (1.0::GLfloat) 0 0
rotate y $ Vector3 0 (1.0::GLfloat) 0
rotate z $ Vector3 0 0 (1.0::GLfloat)
-- Gear 1
preservingMatrix $ do
translate $ Vector3 (-3.0::GLfloat) (-2.0::GLfloat) 0
rotate a $ Vector3 0 0 (1.0::GLfloat)
callList g1
-- Gear 2
preservingMatrix $ do
translate $ Vector3 (3.1::GLfloat) (-2.0::GLfloat) 0
rotate (-2.0 * a - 9.0) $ Vector3 0 0 (1.0::GLfloat)
callList g2
-- Gear 3
preservingMatrix $ do
translate $ Vector3 (-3.1::GLfloat) (4.2::GLfloat) 0
rotate (-2.0 * a - 25.0) $ Vector3 0 0 (1.0::GLfloat)
callList g3
swapBuffers
-- Keyboard event handling (modify view or exit)
keyboard :: View -> Key -> KeyState -> Modifiers -> Position -> IO ()
keyboard view c _ _ _ = keyForPos view c
keyForPos :: View -> Key -> IO ()
keyForPos _ (Char 'q') = exitWith ExitSuccess
keyForPos _ (Char 'Q') = exitWith ExitSuccess
keyForPos viewRot (Char 'z') = modRot viewRot (id, id,
\x->x-5)
keyForPos viewRot (Char 'Z') = modRot viewRot (id, id,
(+)5)
keyForPos viewRot (SpecialKey KeyLeft) = modRot viewRot (id, (+)5,
id)
keyForPos viewRot (SpecialKey KeyRight)= modRot viewRot (id,
\x->x-5,id)
keyForPos viewRot (SpecialKey KeyUp) = modRot viewRot ((+)5, id,
id)
keyForPos viewRot (SpecialKey KeyDown) = modRot viewRot (\x->x-5,id,
id)
keyForPos _ (Char c) = if (c == (chr 27))
then exitWith ExitSuccess
else return ()
keyForPos _ _ = return ()
modRot :: View -> ViewFunc -> IO ()
modRot viewRot (fx,fy,fz) = do
(x,y,z) <- get viewRot
viewRot $= (fx x, fy y, fz z)
postRedisplay Nothing
More information about the HOpenGL
mailing list