Moved source files to src directory
This commit is contained in:
Matthias Schiffer
parent
2bb8561836
commit
7327695ca3
14 changed files with 3 additions and 6 deletions
214
src/GLX.hs
Normal file
214
src/GLX.hs
Normal file
|
|
@ -0,0 +1,214 @@
|
|||
module GLX ( glxDriver
|
||||
) where
|
||||
|
||||
import GLDriver
|
||||
import Bindings.GLX
|
||||
|
||||
import Control.Monad (when, unless)
|
||||
|
||||
import Data.Bits ((.|.))
|
||||
import Data.Maybe (isJust)
|
||||
import Data.Ratio
|
||||
|
||||
import Graphics.Rendering.OpenGL.GL (($=), GLdouble, GLfloat, Vector3(..), Capability(..))
|
||||
import Graphics.Rendering.OpenGL.GL.CoordTrans (matrixMode, MatrixMode(..), viewport, Position(..), Size(..), loadIdentity, ortho, translate)
|
||||
|
||||
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 (ClassHint(..), getEvent, ev_event_type, ev_width, ev_height, ev_keycode, ev_data, ev_x, ev_y, getWindowAttributes, wa_width, wa_height)
|
||||
import Graphics.X11.Xlib.Misc (keycodeToKeysym, setWMProtocols)
|
||||
import Graphics.X11.Xlib.Types
|
||||
import Graphics.X11.Xlib.Window (destroyWindow, mapWindow, storeName)
|
||||
|
||||
import Foreign.Marshal.Utils (with)
|
||||
import Foreign.Ptr
|
||||
import Foreign.Storable
|
||||
|
||||
|
||||
|
||||
data GLX = GLX
|
||||
{ glxDisplay :: !Display
|
||||
, glxWindow :: !Window
|
||||
, glxContext :: !Context
|
||||
, glxDeleteWindow :: !Atom
|
||||
, glxScale :: !Rational
|
||||
, glxLevelWidth :: !Int
|
||||
, glxLevelHeight :: !Int
|
||||
}
|
||||
|
||||
glxDriver :: Int -> Int -> GLX
|
||||
glxDriver w h = GLX
|
||||
{ glxDisplay = Display nullPtr
|
||||
, glxWindow = 0
|
||||
, glxContext = Context nullPtr
|
||||
, glxDeleteWindow = 0
|
||||
, glxScale = 1
|
||||
, glxLevelWidth = w
|
||||
, glxLevelHeight = h
|
||||
}
|
||||
|
||||
|
||||
instance Driver GLX where
|
||||
initialized glx = ((glxContext glx) /= (Context nullPtr))
|
||||
|
||||
initGL glx = do
|
||||
when (initialized glx) $ fail "GLX already initialized"
|
||||
|
||||
disp <- openDisplay ""
|
||||
delwnd <- internAtom disp "WM_DELETE_WINDOW" False
|
||||
fbconfigs <- chooseFBConfig disp (fromIntegral . defaultScreen $ disp)
|
||||
[ (renderType, rgbaBit)
|
||||
, (drawableType, windowBit)
|
||||
, (doublebuffer, 1)
|
||||
, (xRenderable, 1)
|
||||
, (depthSize, 1)
|
||||
, (stencilSize, 1)
|
||||
]
|
||||
visualinfo <- getVisualFromFBConfig disp (head fbconfigs)
|
||||
rootwindow <- rootWindow disp (fromIntegral $ viScreen visualinfo)
|
||||
cmap <- createColormap disp rootwindow (viVisual visualinfo) allocNone
|
||||
|
||||
let swa = nullSetWindowAttributes {swaColormap = cmap, swaEventMask = structureNotifyMask .|. keyPressMask .|. keyReleaseMask .|. pointerMotionMask .|. buttonPressMask}
|
||||
|
||||
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
|
||||
|
||||
ctx <- with visualinfo $ \vi -> createContext disp vi (Context nullPtr) True
|
||||
makeCurrent disp wnd ctx
|
||||
|
||||
wa <- getWindowAttributes disp wnd
|
||||
s <- resize (glxLevelWidth glx) (glxLevelHeight glx) (fromIntegral . wa_width $ wa) (fromIntegral . wa_height $ wa)
|
||||
|
||||
return glx
|
||||
{ glxDisplay = disp
|
||||
, glxWindow = wnd
|
||||
, glxContext = ctx
|
||||
, glxDeleteWindow = delwnd
|
||||
, glxScale = s
|
||||
}
|
||||
|
||||
deinitGL glx = do
|
||||
destroyWindow (glxDisplay glx) (glxWindow glx)
|
||||
destroyContext (glxDisplay glx) (glxContext glx)
|
||||
|
||||
swapBuffers glx = Bindings.GLX.swapBuffers (glxDisplay glx) (glxWindow glx)
|
||||
|
||||
nextEvent glx = allocaXEvent $ nextEvent' glx
|
||||
|
||||
|
||||
nextEvent' :: GLX -> XEventPtr -> IO (GLX, Maybe SomeEvent)
|
||||
nextEvent' glx xevent = do
|
||||
p <- pending $ glxDisplay glx
|
||||
if (p > 0) then do
|
||||
Graphics.X11.Xlib.Event.nextEvent (glxDisplay glx) xevent
|
||||
(newglx, ev) <- handleEvent glx xevent
|
||||
|
||||
if isJust ev then
|
||||
return (newglx, ev)
|
||||
else
|
||||
nextEvent' newglx xevent
|
||||
else
|
||||
return (glx, Nothing)
|
||||
|
||||
|
||||
handleEvent :: GLX -> XEventPtr -> IO (GLX, Maybe SomeEvent)
|
||||
handleEvent glx xevent = do
|
||||
event <- getEvent xevent
|
||||
let evtype = ev_event_type event
|
||||
case () of
|
||||
_ | evtype == configureNotify -> do
|
||||
s <- resize (glxLevelWidth glx) (glxLevelHeight glx) (fromIntegral . ev_width $ event) (fromIntegral . ev_height $ event)
|
||||
return (glx {glxScale = s}, Nothing)
|
||||
| evtype == keyPress -> do
|
||||
keysym <- keycodeToKeysym (glxDisplay glx) (ev_keycode event) 0
|
||||
case () of
|
||||
_ | keysym == xK_Escape -> return (glx, Just $ SomeEvent QuitEvent)
|
||||
| keysym == xK_Up -> return (glx, Just $ SomeEvent $ KeyPressEvent KeyUp)
|
||||
| keysym == xK_Down -> return (glx, Just $ SomeEvent $ KeyPressEvent KeyDown)
|
||||
| keysym == xK_Left -> return (glx, Just $ SomeEvent $ KeyPressEvent KeyLeft)
|
||||
| keysym == xK_Right -> return (glx, Just $ SomeEvent $ KeyPressEvent KeyRight)
|
||||
| keysym == xK_w -> return (glx, Just $ SomeEvent $ KeyPressEvent KeyUp)
|
||||
| keysym == xK_s -> return (glx, Just $ SomeEvent $ KeyPressEvent KeyDown)
|
||||
| keysym == xK_a -> return (glx, Just $ SomeEvent $ KeyPressEvent KeyLeft)
|
||||
| keysym == xK_d -> return (glx, Just $ SomeEvent $ KeyPressEvent KeyRight)
|
||||
| otherwise -> return (glx, Nothing)
|
||||
| evtype == keyRelease -> do
|
||||
keysym <- keycodeToKeysym (glxDisplay glx) (ev_keycode event) 0
|
||||
case () of
|
||||
_ | keysym == xK_Up -> return (glx, Just $ SomeEvent $ KeyReleaseEvent KeyUp)
|
||||
| keysym == xK_Down -> return (glx, Just $ SomeEvent $ KeyReleaseEvent KeyDown)
|
||||
| keysym == xK_Left -> return (glx, Just $ SomeEvent $ KeyReleaseEvent KeyLeft)
|
||||
| keysym == xK_Right -> return (glx, Just $ SomeEvent $ KeyReleaseEvent KeyRight)
|
||||
| keysym == xK_w -> return (glx, Just $ SomeEvent $ KeyReleaseEvent KeyUp)
|
||||
| keysym == xK_s -> return (glx, Just $ SomeEvent $ KeyReleaseEvent KeyDown)
|
||||
| keysym == xK_a -> return (glx, Just $ SomeEvent $ KeyReleaseEvent KeyLeft)
|
||||
| keysym == xK_d -> return (glx, Just $ SomeEvent $ KeyReleaseEvent KeyRight)
|
||||
| otherwise -> return (glx, Nothing)
|
||||
| evtype == clientMessage -> do
|
||||
if ((glxDeleteWindow glx) == (fromIntegral . head . ev_data $ event))
|
||||
then
|
||||
return (glx, Just $ SomeEvent QuitEvent)
|
||||
else
|
||||
return (glx, Nothing)
|
||||
| evtype == motionNotify -> do
|
||||
(x, y) <- windowToGameCoords glx (ev_x event) (ev_y event)
|
||||
wa <- getWindowAttributes (glxDisplay glx) (glxWindow glx)
|
||||
return (glx, Just $ SomeEvent $ MouseMotionEvent x y)
|
||||
| evtype == buttonPress -> do
|
||||
(x, y) <- windowToGameCoords glx (ev_x event) (ev_y event)
|
||||
wa <- getWindowAttributes (glxDisplay glx) (glxWindow glx)
|
||||
return (glx, Just $ SomeEvent $ MousePressEvent x y)
|
||||
|
||||
| otherwise -> return (glx, Nothing)
|
||||
|
||||
|
||||
windowToGameCoords :: Integral a => GLX -> a -> a -> IO (Float, Float)
|
||||
windowToGameCoords glx x y = getWindowAttributes (glxDisplay glx) (glxWindow glx) >>= \wa ->
|
||||
let w = fromIntegral . wa_width $ wa
|
||||
h = fromIntegral . wa_height $ wa
|
||||
in return (((-w/2 + wx)/s + lw/2), ((h/2 - wy)/s + lh/2))
|
||||
where s = fromRational . glxScale $ glx
|
||||
lw = fromIntegral . glxLevelWidth $ glx
|
||||
lh = fromIntegral . glxLevelHeight $ glx
|
||||
wx = fromIntegral x
|
||||
wy = fromIntegral y
|
||||
|
||||
|
||||
resize :: Int -> Int -> Int -> Int -> IO Rational
|
||||
resize lw lh w h = do
|
||||
let aspect = (fromIntegral w)%(fromIntegral h)
|
||||
s = (max ((fromIntegral lw)/aspect) (fromIntegral lh))/2
|
||||
sf = fromRational s
|
||||
aspectf = fromRational aspect
|
||||
|
||||
matrixMode $= Projection
|
||||
loadIdentity
|
||||
ortho (-sf*aspectf) (sf*aspectf) (-sf) sf (-1) 1
|
||||
translate $ Vector3 (-(fromIntegral lw)/2) (-(fromIntegral lh)/2) (0 :: GLfloat)
|
||||
|
||||
matrixMode $= Modelview 0
|
||||
|
||||
viewport $= ((Position 0 0), (Size (fromIntegral w) (fromIntegral h)))
|
||||
|
||||
return $ (fromIntegral h)/(2*s)
|
||||
|
||||
waitForMapNotify :: Display -> Window -> IO ()
|
||||
waitForMapNotify disp wnd = allocaXEvent waitForMapNotify'
|
||||
where
|
||||
waitForMapNotify' event = do
|
||||
Graphics.X11.Xlib.Event.nextEvent disp event
|
||||
window <- get_Window event
|
||||
eventType <- get_EventType event
|
||||
unless (window == wnd && eventType == mapNotify) $
|
||||
waitForMapNotify' event
|
||||
Reference in a new issue