Skip to content
Browse files

Inital commit.

- Functional Window.hs that creates an OpenGL window with a (0,0) x (1.3, 1.0)
  viewport and calls a user-defined functions fps times per second.
- Main.hs demonstrates the usage by drawing a border and random colored lines.
  • Loading branch information...
0 parents commit 6d42b4e222a27e0f53e0d915eda0642fdc4e9977 @mlesniak committed Jun 7, 2011
Showing with 173 additions and 0 deletions.
  1. +50 −0 Main.hs
  2. +11 −0 Makefile
  3. +18 −0 TODO
  4. +12 −0 Tools.hs
  5. +82 −0 Window.hs
50 Main.hs
@@ -0,0 +1,50 @@
+module Main where
+
+import Control.Monad
+import Data.IORef
+import Graphics.UI.GLUT
+import System.Random (randomRIO)
+import Unsafe.Coerce (unsafeCoerce)
+import Window
+
+
+main :: IO ()
+main = do
+ list <- newIORef []
+ let wc = WindowConfig {
+ frameHandler = FrameHandler $ do
+ pNew <- randomPoint (0, 1.3)
+ modifyIORef list (pNew:)
+ l <- readIORef list
+ when (length l `mod` 100 == 0) $
+ putStrLn $ "Number of lines: " ++ show (length l)
+ forM_ l $ \(x,y) -> do
+ color $ Color3 (abs x) (abs y) (abs $ x-y)
+ renderPrimitive Lines $ do
+ vertex $ Vertex3 0.65 (0.65 :: GLfloat) 0.0
+ vertex $ Vertex3 x y 0.0
+
+ -- Rectangle
+ renderPrimitive LineLoop $ do
+ let f (x,y) = vertex $ Vertex3 x (y :: GLfloat) 0.0
+ mapM_ f [
+ (0.00, 0.00)
+ , (1.30, 0.00)
+ , (1.30, 1.30)
+ , (0.00, 1.30)]
+
+ , keyHandler = Nothing
+ , title = "Colors"
+ , size = Size 640 480
+ , fps = 30
+ }
+ windowLoop wc
+
+
+randomPoint :: (Float, Float) -> IO (GLfloat, GLfloat)
+randomPoint (l, r) = do
+ x1 <- unsafeCoerce `liftM` randomRIO (l, r)
+ x2 <- unsafeCoerce `liftM` randomRIO (l, r)
+ return (x1, x2)
+
+
11 Makefile
@@ -0,0 +1,11 @@
+OPTIONS=--make -O2 -threaded -Wall -fno-warn-unused-do-bind
+SOURCES=Window.hs Main.hs Tools.hs
+
+all:
+ ghc $(OPTIONS) $(SOURCES) -main-is Main -o main
+
+hlint:
+ hlint *.hs
+
+clean:
+ rm -f *.o *.hi tags main
18 TODO
@@ -0,0 +1,18 @@
+-- Todo --
+- .cabal - file for dependency managament
+- how to handle game state?
+- load graphics
+- draw graphics
+
+
+-- Done --
+X functional window.hs
+ X compile
+ X show a main window
+ X change viewport
+ X change window geometry
+ X Size in WindowConfig
+X separate main for testing
+X primitive, fps-based gameloop
+
+
12 Tools.hs
@@ -0,0 +1,12 @@
+module Tools (
+ separator
+) where
+
+
+separator :: String -> String
+separator msg =
+ let width = 80
+ pre = "-- "
+ post = replicate (width - length pre - length msg - 1) '-' in
+ pre ++ msg ++ " " ++ post
+
82 Window.hs
@@ -0,0 +1,82 @@
+-- | An OpenGL based game loop.
+--
+
+module Window where
+
+import Control.Concurrent
+import Control.Monad
+import Data.Time.Clock.POSIX (getPOSIXTime)
+import Graphics.UI.GLUT
+
+
+newtype FrameHandler = FrameHandler { getFrame :: IO () }
+newtype KeyHandler = KeyHandler (Key -> IO ())
+
+
+data WindowConfig = WindowConfig {
+ frameHandler :: FrameHandler
+ , keyHandler :: Maybe KeyHandler
+ , title :: String
+ , size :: Size
+ , fps :: Double
+}
+
+
+-- | Creates a new output window using the specified config.
+--
+window :: WindowConfig -> IO ()
+window wc = forkOS (windowMain wc) >> return ()
+
+
+windowLoop :: WindowConfig -> IO ()
+windowLoop wc = do
+ windowMain wc
+ forever (return ())
+
+
+-- | Shows the main window and initializes the fps-based loop.
+windowMain :: WindowConfig -> IO ()
+windowMain wc = do
+ getArgsAndInitialize
+ createWindow (title wc)
+ perWindowKeyRepeat $= PerWindowKeyRepeatOff
+ initialDisplayMode $= [DoubleBuffered]
+ clearColor $= Color4 1 1 (1 :: GLclampf) 1
+ windowSize $= size wc
+ keyboardMouseCallback $= Nothing
+ actionOnWindowClose $= Exit
+
+ -- For antialiasing.
+ lineSmooth $= Enabled
+ lineWidth $= 3.5
+ hint LineSmooth $= Nicest
+
+ displayCallback $= do
+ clear [ColorBuffer]
+ loadIdentity
+ translate $ Vector3 (-1.0) (-1.0) (0.0 :: GLfloat)
+ scale (2/1.3) (2/1.3) (1.0 :: GLfloat)
+ getFrame (frameHandler wc)
+ swapBuffers
+
+ gameLoop (fps wc)
+ mainLoop
+
+
+gameLoop :: Double -> IO ()
+gameLoop fps_ = loop
+ where loop = do
+ t1 <- getTime
+ postRedisplay Nothing
+ t2 <- getTime
+ let twait = t2 - t1
+ tdelay = fromEnum $ (1/fps_ - twait) * 1000
+ if twait < 1/fps_
+ then addTimerCallback tdelay loop
+ else loop
+ getTime :: IO Double
+ getTime = (fromRational . toRational) `fmap` getPOSIXTime
+
+
+
+

0 comments on commit 6d42b4e

Please sign in to comment.
Something went wrong with that request. Please try again.