neocturne/htanks
Archived
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Added buffer swap and some other things to the GLX backend and main loop

Browse source
This commit is contained in:
Matthias Schiffer 2010-02-23 15:05:31 +01:00
parent f10352a0f1
commit 9772130708
6 changed files with 186 additions and 99 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

27
Bindings/GLX.chs
View file

@ -2,6 +2,7 @@
module Bindings.GLX ( createColormap
, createWindow
, setClassHint
, chooseFBConfig
, getVisualFromFBConfig
, VisualInfo(..)
@ -18,28 +19,33 @@ module Bindings.GLX ( createColormap
, createContext
, makeCurrent
, destroyContext
, swapBuffers
, Context(..)
, Drawable
) where
import Data.Generics
import Data.Int
import Data.Word
import Foreign.C.String (withCString)
import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Alloc (alloca, allocaBytes)
import Foreign.Marshal.Array (peekArray, withArray0)
import Foreign.Storable
import Graphics.X11.Types (AttributeMask, Colormap, ColormapAlloc, Cursor, EventMask, Pixmap, Window, WindowClass, VisualID, XID)
import Graphics.X11.Xlib.Extras (none, xFree)
import Graphics.X11.Xlib.Extras (none, xFree, ClassHint, resName, resClass, TextProperty)
import Graphics.X11.Xlib.Types (Dimension, Display, Pixel, Position)
#include <GL/glx.h>
type Drawable = XID
newtype FBConfig = FBConfig (Ptr FBConfig)
deriving (Eq, Ord, Show, Typeable, Data, Storable)
@ -189,6 +195,16 @@ foreign import ccall unsafe "GL/glx.h XCreateWindow"
Dimension -> Dimension -> CInt -> CInt -> WindowClass ->
Visual -> AttributeMask -> Ptr SetWindowAttributes -> IO Window
foreign import ccall unsafe "GL/glx.h XSetClassHint"
xSetClassHint :: Display -> Window -> Ptr ClassHint -> IO ()
setClassHint :: Display -> Window -> ClassHint -> IO ()
setClassHint disp wnd hint = allocaBytes (#size XClassHint) $ \p ->
withCString (resName hint) $ \res_name ->
withCString (resClass hint) $ \res_class -> do
(#poke XClassHint, res_name) p res_name
(#poke XClassHint, res_class) p res_class
xSetClassHint disp wnd p
foreign import ccall unsafe "GL/glx.h glXChooseFBConfig"
@ -241,7 +257,10 @@ foreign import ccall unsafe "GL/glx.h glXCreateContext"
createContext :: Display -> Ptr VisualInfo -> Context -> Bool -> IO Context
foreign import ccall unsafe "GL/glx.h glXMakeCurrent"
makeCurrent :: Display -> XID -> Context -> IO Bool
makeCurrent :: Display -> Drawable -> Context -> IO Bool
foreign import ccall unsafe "GL/glx.h glXDestroyContext"
destroyContext :: Display -> Context -> IO ()
destroyContext :: Display -> Context -> IO ()
foreign import ccall unsafe "GL/glx.h glXSwapBuffers"
swapBuffers :: Display -> Drawable -> IO ()

188
Bindings/GLX.hs
View file

@ -5,6 +5,7 @@
module Bindings.GLX ( createColormap
, createWindow
, setClassHint
, chooseFBConfig
, getVisualFromFBConfig
, VisualInfo(..)
@ -21,29 +22,34 @@ module Bindings.GLX ( createColormap
, createContext
, makeCurrent
, destroyContext
, swapBuffers
, Context(..)
, Drawable
) where
import Data.Generics
import Data.Int
import Data.Word
import Foreign.C.String (withCString)
import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Alloc (alloca, allocaBytes)
import Foreign.Marshal.Array (peekArray, withArray0)
import Foreign.Storable
import Graphics.X11.Types (AttributeMask, Colormap, ColormapAlloc, Cursor, EventMask, Pixmap, Window, WindowClass, VisualID, XID)
import Graphics.X11.Xlib.Extras (none, xFree)
import Graphics.X11.Xlib.Extras (none, xFree, ClassHint, resName, resClass, TextProperty)
import Graphics.X11.Xlib.Types (Dimension, Display, Pixel, Position)
{-# LINE 41 "GLX.chs" #-}
{-# LINE 45 "GLX.chs" #-}
type Drawable = XID
newtype FBConfig = FBConfig (Ptr FBConfig)
deriving (Eq, Ord, Show, Typeable, Data, Storable)
@ -68,55 +74,55 @@ data VisualInfo = VisualInfo
instance Storable VisualInfo where
sizeOf _ = ((40))
{-# LINE 67 "GLX.chs" #-}
{-# LINE 73 "GLX.chs" #-}
alignment _ = alignment (undefined :: CULong)
peek vi = do
visual <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) vi
{-# LINE 71 "GLX.chs" #-}
visualid <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) vi
{-# LINE 72 "GLX.chs" #-}
screen <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) vi
{-# LINE 73 "GLX.chs" #-}
depth <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) vi
{-# LINE 74 "GLX.chs" #-}
viclass <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) vi
{-# LINE 75 "GLX.chs" #-}
red_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) vi
{-# LINE 76 "GLX.chs" #-}
green_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) vi
{-# LINE 77 "GLX.chs" #-}
blue_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) vi
visualid <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) vi
{-# LINE 78 "GLX.chs" #-}
colormap_size <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) vi
screen <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) vi
{-# LINE 79 "GLX.chs" #-}
bits_per_rgb <- ((\hsc_ptr -> peekByteOff hsc_ptr 36)) vi
depth <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) vi
{-# LINE 80 "GLX.chs" #-}
viclass <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) vi
{-# LINE 81 "GLX.chs" #-}
red_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) vi
{-# LINE 82 "GLX.chs" #-}
green_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) vi
{-# LINE 83 "GLX.chs" #-}
blue_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) vi
{-# LINE 84 "GLX.chs" #-}
colormap_size <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) vi
{-# LINE 85 "GLX.chs" #-}
bits_per_rgb <- ((\hsc_ptr -> peekByteOff hsc_ptr 36)) vi
{-# LINE 86 "GLX.chs" #-}
return (VisualInfo visual visualid screen depth viclass red_mask green_mask blue_mask colormap_size bits_per_rgb)
poke vi (VisualInfo visual visualid screen depth viclass red_mask green_mask blue_mask colormap_size bits_per_rgb) = do
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) vi visual
{-# LINE 86 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) vi visualid
{-# LINE 87 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) vi screen
{-# LINE 88 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 12)) vi depth
{-# LINE 89 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) vi viclass
{-# LINE 90 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 20)) vi red_mask
{-# LINE 91 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 24)) vi green_mask
{-# LINE 92 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 28)) vi blue_mask
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) vi visualid
{-# LINE 93 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 32)) vi colormap_size
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) vi screen
{-# LINE 94 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 36)) vi bits_per_rgb
((\hsc_ptr -> pokeByteOff hsc_ptr 12)) vi depth
{-# LINE 95 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) vi viclass
{-# LINE 96 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 20)) vi red_mask
{-# LINE 97 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 24)) vi green_mask
{-# LINE 98 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 28)) vi blue_mask
{-# LINE 99 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 32)) vi colormap_size
{-# LINE 100 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 36)) vi bits_per_rgb
{-# LINE 101 "GLX.chs" #-}
data SetWindowAttributes = SetWindowAttributes
@ -138,38 +144,38 @@ data SetWindowAttributes = SetWindowAttributes
instance Storable SetWindowAttributes where
sizeOf _ = ((60))
{-# LINE 116 "GLX.chs" #-}
{-# LINE 122 "GLX.chs" #-}
alignment _ = alignment (undefined :: CULong)
peek swa = do
background_pixmap <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) swa
{-# LINE 120 "GLX.chs" #-}
background_pixel <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) swa
{-# LINE 121 "GLX.chs" #-}
border_pixmap <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) swa
{-# LINE 122 "GLX.chs" #-}
bit_gravity <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) swa
{-# LINE 123 "GLX.chs" #-}
win_gravity <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) swa
{-# LINE 124 "GLX.chs" #-}
backing_store <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) swa
{-# LINE 125 "GLX.chs" #-}
backing_planes <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) swa
{-# LINE 126 "GLX.chs" #-}
backing_pixel <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) swa
background_pixel <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) swa
{-# LINE 127 "GLX.chs" #-}
save_under <- ((\hsc_ptr -> peekByteOff hsc_ptr 36)) swa
border_pixmap <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) swa
{-# LINE 128 "GLX.chs" #-}
event_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 40)) swa
bit_gravity <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) swa
{-# LINE 129 "GLX.chs" #-}
do_not_propagate_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 44)) swa
win_gravity <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) swa
{-# LINE 130 "GLX.chs" #-}
override_redirect <- ((\hsc_ptr -> peekByteOff hsc_ptr 48)) swa
backing_store <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) swa
{-# LINE 131 "GLX.chs" #-}
colormap <- ((\hsc_ptr -> peekByteOff hsc_ptr 52)) swa
backing_planes <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) swa
{-# LINE 132 "GLX.chs" #-}
cursor <- ((\hsc_ptr -> peekByteOff hsc_ptr 56)) swa
backing_pixel <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) swa
{-# LINE 133 "GLX.chs" #-}
save_under <- ((\hsc_ptr -> peekByteOff hsc_ptr 36)) swa
{-# LINE 134 "GLX.chs" #-}
event_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 40)) swa
{-# LINE 135 "GLX.chs" #-}
do_not_propagate_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 44)) swa
{-# LINE 136 "GLX.chs" #-}
override_redirect <- ((\hsc_ptr -> peekByteOff hsc_ptr 48)) swa
{-# LINE 137 "GLX.chs" #-}
colormap <- ((\hsc_ptr -> peekByteOff hsc_ptr 52)) swa
{-# LINE 138 "GLX.chs" #-}
cursor <- ((\hsc_ptr -> peekByteOff hsc_ptr 56)) swa
{-# LINE 139 "GLX.chs" #-}
return (SetWindowAttributes
background_pixmap
@ -203,33 +209,33 @@ instance Storable SetWindowAttributes where
colormap
cursor) = do
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) swa background_pixmap
{-# LINE 166 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) swa background_pixel
{-# LINE 167 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) swa border_pixmap
{-# LINE 168 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) swa bit_gravity
{-# LINE 169 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 20)) swa win_gravity
{-# LINE 170 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 24)) swa backing_store
{-# LINE 171 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 28)) swa backing_planes
{-# LINE 172 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 32)) swa backing_pixel
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) swa background_pixel
{-# LINE 173 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 36)) swa save_under
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) swa border_pixmap
{-# LINE 174 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 40)) swa event_mask
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) swa bit_gravity
{-# LINE 175 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 44)) swa do_not_propagate_mask
((\hsc_ptr -> pokeByteOff hsc_ptr 20)) swa win_gravity
{-# LINE 176 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 48)) swa override_redirect
((\hsc_ptr -> pokeByteOff hsc_ptr 24)) swa backing_store
{-# LINE 177 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 52)) swa colormap
((\hsc_ptr -> pokeByteOff hsc_ptr 28)) swa backing_planes
{-# LINE 178 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 56)) swa cursor
((\hsc_ptr -> pokeByteOff hsc_ptr 32)) swa backing_pixel
{-# LINE 179 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 36)) swa save_under
{-# LINE 180 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 40)) swa event_mask
{-# LINE 181 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 44)) swa do_not_propagate_mask
{-# LINE 182 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 48)) swa override_redirect
{-# LINE 183 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 52)) swa colormap
{-# LINE 184 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 56)) swa cursor
{-# LINE 185 "GLX.chs" #-}
nullSetWindowAttributes :: SetWindowAttributes
nullSetWindowAttributes = (SetWindowAttributes 0 0 0 0 0 0 0 0 False 0 0 False 0 0)
@ -243,6 +249,19 @@ foreign import ccall unsafe "GL/glx.h XCreateWindow"
Dimension -> Dimension -> CInt -> CInt -> WindowClass ->
Visual -> AttributeMask -> Ptr SetWindowAttributes -> IO Window
foreign import ccall unsafe "GL/glx.h XSetClassHint"
xSetClassHint :: Display -> Window -> Ptr ClassHint -> IO ()
setClassHint :: Display -> Window -> ClassHint -> IO ()
setClassHint disp wnd hint = allocaBytes ((8)) $ \p ->
{-# LINE 203 "GLX.chs" #-}
withCString (resName hint) $ \res_name ->
withCString (resClass hint) $ \res_class -> do
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) p res_name
{-# LINE 206 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) p res_class
{-# LINE 207 "GLX.chs" #-}
xSetClassHint disp wnd p
foreign import ccall unsafe "GL/glx.h glXChooseFBConfig"
@ -259,35 +278,35 @@ chooseFBConfig disp sc attr = alloca $ \n -> withArray0 (fromIntegral none) (con
renderType :: CInt
renderType = (32785)
{-# LINE 208 "GLX.chs" #-}
{-# LINE 224 "GLX.chs" #-}
rgbaBit :: CInt
rgbaBit = (1)
{-# LINE 211 "GLX.chs" #-}
{-# LINE 227 "GLX.chs" #-}
drawableType :: CInt
drawableType = (32784)
{-# LINE 214 "GLX.chs" #-}
{-# LINE 230 "GLX.chs" #-}
windowBit :: CInt
windowBit = (1)
{-# LINE 217 "GLX.chs" #-}
{-# LINE 233 "GLX.chs" #-}
xRenderable :: CInt
xRenderable = (32786)
{-# LINE 220 "GLX.chs" #-}
{-# LINE 236 "GLX.chs" #-}
doublebuffer :: CInt
doublebuffer = (5)
{-# LINE 223 "GLX.chs" #-}
{-# LINE 239 "GLX.chs" #-}
depthSize :: CInt
depthSize = (12)
{-# LINE 226 "GLX.chs" #-}
{-# LINE 242 "GLX.chs" #-}
stencilSize :: CInt
stencilSize = (13)
{-# LINE 229 "GLX.chs" #-}
{-# LINE 245 "GLX.chs" #-}
foreign import ccall unsafe "GL/glx.h glXGetVisualFromFBConfig"
glXGetVisualFromFBConfig :: Display -> FBConfig -> IO (Ptr VisualInfo)
@ -303,7 +322,10 @@ foreign import ccall unsafe "GL/glx.h glXCreateContext"
createContext :: Display -> Ptr VisualInfo -> Context -> Bool -> IO Context
foreign import ccall unsafe "GL/glx.h glXMakeCurrent"
makeCurrent :: Display -> XID -> Context -> IO Bool
makeCurrent :: Display -> Drawable -> Context -> IO Bool
foreign import ccall unsafe "GL/glx.h glXDestroyContext"
destroyContext :: Display -> Context -> IO ()
destroyContext :: Display -> Context -> IO ()
foreign import ccall unsafe "GL/glx.h glXSwapBuffers"
swapBuffers :: Display -> Drawable -> IO ()

2
GLDriver.hs
View file

@ -16,6 +16,8 @@ class Driver a where
initGL :: a -> IO a
deinitGL :: a -> IO ()
swapBuffers :: a -> IO ()
nextEvent :: a -> IO (Maybe SomeEvent)

15
GLX.hs
View file

@ -13,10 +13,10 @@ import Graphics.X11.Types
import Graphics.X11.Xlib.Atom (internAtom)
import Graphics.X11.Xlib.Display (defaultScreen, openDisplay, rootWindow)
import Graphics.X11.Xlib.Event (XEventPtr, allocaXEvent, nextEvent, get_Window, get_EventType, pending)
import Graphics.X11.Xlib.Extras (getEvent, ev_event_type, ev_keycode, ev_data)
import Graphics.X11.Xlib.Extras (ClassHint(..), getEvent, ev_event_type, ev_keycode, ev_data)
import Graphics.X11.Xlib.Misc (keycodeToKeysym, setWMProtocols)
import Graphics.X11.Xlib.Types
import Graphics.X11.Xlib.Window (destroyWindow, mapWindow)
import Graphics.X11.Xlib.Window (destroyWindow, mapWindow, storeName)
import Foreign.Marshal.Utils (with)
import Foreign.Ptr
@ -41,10 +41,10 @@ glxDriver = GLX
instance Driver GLX where
initialized glx = ((glxContext glx) == (Context nullPtr))
initialized glx = ((glxContext glx) /= (Context nullPtr))
initGL glx = do
when ((glxContext glx) /= (Context nullPtr)) $ fail "GLX already initialized"
when (initialized glx) $ fail "GLX already initialized"
disp <- openDisplay ""
delwnd <- internAtom disp "WM_DELETE_WINDOW" False
@ -64,8 +64,11 @@ instance Driver GLX where
wnd <- with swa $ \swaptr ->
createWindow disp rootwindow 0 0 800 600 0 (fromIntegral $ viDepth visualinfo) inputOutput (viVisual visualinfo) (cWBorderPixel.|.cWColormap.|.cWEventMask) swaptr
setClassHint disp wnd (ClassHint "HTanks" "htanks")
setWMProtocols disp wnd [delwnd]
storeName disp wnd "HTanks"
mapWindow disp wnd
waitForMapNotify disp wnd
@ -84,6 +87,8 @@ instance Driver GLX where
destroyWindow (glxDisplay glx) (glxWindow glx)
destroyContext (glxDisplay glx) (glxContext glx)
swapBuffers glx = Bindings.GLX.swapBuffers (glxDisplay glx) (glxWindow glx)
nextEvent glx = allocaXEvent $ nextEvent' glx $ glxDisplay glx

39
HTanks.hs
View file

@ -2,6 +2,7 @@
import Game
import Level
import Render
import Tank
import GLDriver
@ -10,6 +11,7 @@ import GLX
import Control.Concurrent (threadDelay)
import Control.Monad.State
import Data.Maybe
import System.Time
main :: IO ()
@ -18,16 +20,39 @@ main = do
let gameState = GameState {level = testLevel, tanks = [Tank 0.5 0.5 0]}
runGame gameState $ mainLoop gl
deinitGL gl
when (initialized gl) $ do
time <- getClockTime
runGame gameState $ mainLoop gl time
deinitGL gl
mainLoop :: Driver a => a -> Game ()
mainLoop gl = do
minFrameTime :: Integer
minFrameTime = 10000
mainLoop :: Driver a => a -> ClockTime -> Game ()
mainLoop gl time = do
run <- liftIO $ handleEvents gl
liftIO $ threadDelay 10000
when run $ mainLoop gl
render
liftIO $ swapBuffers gl
newTime <- liftIO getClockTime
let td = timeDiff newTime time
when (td < minFrameTime) $
liftIO $ threadDelay $ fromIntegral (minFrameTime - td)
newTime <- liftIO getClockTime
liftIO $ print $ timeDiff newTime time
when run $ mainLoop gl newTime
timeDiff :: ClockTime -> ClockTime -> Integer
timeDiff (TOD s1 ps1) (TOD s2 ps2) = (s1-s2)*1000000 + (ps1-ps2)`div`1000000
handleEvents :: Driver a => a -> IO Bool
handleEvents gl = do
event <- nextEvent gl

14
Render.hs Normal file
View file

@ -0,0 +1,14 @@
module Render ( render
) where
import Game
import Control.Monad.State
import Graphics.Rendering.OpenGL.GL.Framebuffer (clear, ClearBuffer(..))
render :: Game ()
render = do
liftIO $ clear [ColorBuffer]