diff options
Diffstat (limited to 'src/GLX.hs')
| -rw-r--r-- | src/GLX.hs | 214 |
1 files changed, 214 insertions, 0 deletions
diff --git a/src/GLX.hs b/src/GLX.hs new file mode 100644 index 0000000..6f5b0fc --- /dev/null +++ b/src/GLX.hs @@ -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 |