[HOpenGL] GlxGears

16 Mar 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