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