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