Added buffer swap and some other things to the GLX backend and main loop
This commit is contained in:
parent
f10352a0f1
commit
9772130708
6 changed files with 186 additions and 99 deletions
|
@ -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 ()
|
||||
|
||||
foreign import ccall unsafe "GL/glx.h glXSwapBuffers"
|
||||
swapBuffers :: Display -> Drawable -> IO ()
|
||||
|
|
186
Bindings/GLX.hs
186
Bindings/GLX.hs
|
@ -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 ()
|
||||
|
||||
foreign import ccall unsafe "GL/glx.h glXSwapBuffers"
|
||||
swapBuffers :: Display -> Drawable -> IO ()
|
||||
|
|
|
@ -16,6 +16,8 @@ class Driver a where
|
|||
initGL :: a -> IO a
|
||||
deinitGL :: a -> IO ()
|
||||
|
||||
swapBuffers :: a -> IO ()
|
||||
|
||||
nextEvent :: a -> IO (Maybe SomeEvent)
|
||||
|
||||
|
||||
|
|
13
GLX.hs
13
GLX.hs
|
@ -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
|
||||
|
||||
|
||||
|
|
35
HTanks.hs
35
HTanks.hs
|
@ -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,15 +20,38 @@ main = do
|
|||
|
||||
let gameState = GameState {level = testLevel, tanks = [Tank 0.5 0.5 0]}
|
||||
|
||||
runGame gameState $ mainLoop 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
|
||||
|
|
14
Render.hs
Normal file
14
Render.hs
Normal 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]
|
||||
|
Reference in a new issue