228 lines
10 KiB
Haskell
228 lines
10 KiB
Haskell
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, scale, rotate, frustum)
|
|
|
|
import Graphics.X11.Types
|
|
import Graphics.X11.Xlib.Atom (internAtom)
|
|
import Graphics.X11.Xlib.Color (queryColor)
|
|
import Graphics.X11.Xlib.Display (defaultScreen, openDisplay, rootWindow, whitePixel)
|
|
import Graphics.X11.Xlib.Event (XEventPtr, allocaXEvent, nextEvent, get_Window, get_EventType, pending, sync)
|
|
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, createPixmap, createPixmapCursor, defineCursor)
|
|
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]
|
|
|
|
color <- queryColor disp cmap $ Graphics.X11.Xlib.Types.Color (whitePixel disp $ fromIntegral . viScreen $ visualinfo) 0 0 0 0
|
|
pixmap <- createPixmap disp wnd 1 1 1
|
|
cursor <- createPixmapCursor disp pixmap pixmap color color 0 0
|
|
sync disp False
|
|
|
|
storeName disp wnd "HTanks"
|
|
|
|
mapWindow disp wnd
|
|
|
|
waitForMapNotify disp wnd
|
|
|
|
defineCursor disp wnd cursor
|
|
|
|
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
|
|
|
|
usleep _ usecs = glxUsleep $ fromIntegral usecs
|
|
|
|
|
|
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)/sx + lw/2), ((h/2 - wy)/sy + lh/2))
|
|
where sx = fromRational . glxScale $ glx
|
|
sy = sx*(cos $ pi/6)
|
|
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
|
|
--scale 1 1 (0.1 :: GLfloat)
|
|
frustum (-sf*aspectf) (sf*aspectf) (-sf) sf 10 100
|
|
rotate (-30) $ Vector3 1 0 (0 :: GLfloat)
|
|
translate $ Vector3 (-(fromIntegral lw)/2) ((fromIntegral lh)/2) (-11 :: 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
|