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) 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 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) rotate (-30) $ Vector3 1 0 (0 :: GLfloat) 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