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 (nGLfloat->GLfloat->GLfloat->GLint->GLint->IO () teethFront r1 r2 w da n t = do if (n 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 GLfloat -> GLfloat -> GLfloat -> GLint -> GLint -> IO() teethBack r1 r2 w da n t = do if (n GLfloat -> GLfloat -> GLfloat -> GLint -> GLint -> IO () teethFace r1 r2 w da n t = if (n 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 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