diff options
Diffstat (limited to 'GLX.hs')
| -rw-r--r-- | GLX.hs | 49 |
1 files changed, 36 insertions, 13 deletions
@@ -9,6 +9,9 @@ import Control.Monad (when, unless) import Data.Bits ((.|.)) import Data.Maybe (isJust) +import Graphics.Rendering.OpenGL.GL (($=), GLdouble, Capability(..)) +import Graphics.Rendering.OpenGL.GL.CoordTrans (matrixMode, MatrixMode(..), viewport, Position(..), Size(..), loadIdentity, ortho) + import Graphics.X11.Types import Graphics.X11.Xlib.Atom (internAtom) import Graphics.X11.Xlib.Display (defaultScreen, openDisplay, rootWindow) @@ -29,6 +32,7 @@ data GLX = GLX , glxWindow :: !Window , glxContext :: !Context , glxDeleteWindow :: !Atom + , glxScale :: !GLdouble } glxDriver :: GLX @@ -37,6 +41,7 @@ glxDriver = GLX , glxWindow = 0 , glxContext = Context nullPtr , glxDeleteWindow = 0 + , glxScale = 1 } @@ -60,7 +65,7 @@ instance Driver GLX where rootwindow <- rootWindow disp (fromIntegral $ viScreen visualinfo) cmap <- createColormap disp rootwindow (viVisual visualinfo) allocNone - let swa = nullSetWindowAttributes {swaColormap = cmap, swaEventMask = structureNotifyMask .|. keyPressMask .|. keyReleaseMask} + let swa = nullSetWindowAttributes {swaColormap = cmap, swaEventMask = structureNotifyMask .|. keyPressMask .|. keyReleaseMask .|. pointerMotionMask} wnd <- with swa $ \swaptr -> createWindow disp rootwindow 0 0 800 600 0 (fromIntegral $ viDepth visualinfo) inputOutput (viVisual visualinfo) (cWBorderPixel.|.cWColormap.|.cWEventMask) swaptr @@ -77,11 +82,14 @@ instance Driver GLX where ctx <- with visualinfo $ \vi -> createContext disp vi (Context nullPtr) True makeCurrent disp wnd ctx + resize 800 600 + return GLX { glxDisplay = disp , glxWindow = wnd , glxContext = ctx , glxDeleteWindow = delwnd + , glxScale = 1 } deinitGL glx = do @@ -90,33 +98,34 @@ instance Driver GLX where swapBuffers glx = Bindings.GLX.swapBuffers (glxDisplay glx) (glxWindow glx) - nextEvent glx = allocaXEvent $ nextEvent' glx $ glxDisplay glx + nextEvent glx = allocaXEvent $ nextEvent' glx -nextEvent' :: GLX -> Display -> XEventPtr -> IO (Maybe SomeEvent) -nextEvent' glx disp xevent = do - p <- pending disp +nextEvent' :: GLX -> XEventPtr -> IO (Maybe SomeEvent) +nextEvent' glx xevent = do + p <- pending $ glxDisplay glx if (p > 0) then do - Graphics.X11.Xlib.Event.nextEvent disp xevent - ev <- handleEvent glx disp xevent + Graphics.X11.Xlib.Event.nextEvent (glxDisplay glx) xevent + ev <- handleEvent glx xevent if isJust ev then return ev else - nextEvent' glx disp xevent + nextEvent' glx xevent else return Nothing -handleEvent :: GLX -> Display -> XEventPtr -> IO (Maybe SomeEvent) -handleEvent glx disp xevent = do +handleEvent :: GLX -> XEventPtr -> IO (Maybe SomeEvent) +handleEvent glx xevent = do event <- getEvent xevent let evtype = ev_event_type event case () of _ | evtype == configureNotify -> do - return $ Just $ SomeEvent $ ResizeEvent (fromIntegral . ev_width $ event) (fromIntegral . ev_height $ event) + resize (fromIntegral . ev_width $ event) (fromIntegral . ev_height $ event) + return Nothing | evtype == keyPress -> do - keysym <- keycodeToKeysym disp (ev_keycode event) 0 + keysym <- keycodeToKeysym (glxDisplay glx) (ev_keycode event) 0 case () of _ | keysym == xK_Escape -> return $ Just $ SomeEvent QuitEvent | keysym == xK_Up -> return $ Just $ SomeEvent $ KeyPressEvent KeyUp @@ -125,7 +134,7 @@ handleEvent glx disp xevent = do | keysym == xK_Right -> return $ Just $ SomeEvent $ KeyPressEvent KeyRight | otherwise -> return Nothing | evtype == keyRelease -> do - keysym <- keycodeToKeysym disp (ev_keycode event) 0 + keysym <- keycodeToKeysym (glxDisplay glx) (ev_keycode event) 0 case () of _ | keysym == xK_Up -> return $ Just $ SomeEvent $ KeyReleaseEvent KeyUp | keysym == xK_Down -> return $ Just $ SomeEvent $ KeyReleaseEvent KeyDown @@ -141,6 +150,20 @@ handleEvent glx disp xevent = do | otherwise -> return Nothing +resize :: Int -> Int -> IO () +resize w h = do + let aspect = (fromIntegral w)/(fromIntegral h) + s = max (5/aspect) 5 :: GLdouble + + matrixMode $= Projection + loadIdentity + ortho (-s*aspect) (s*aspect) (-s) s (-1) 1 + + matrixMode $= Modelview 0 + + viewport $= ((Position 0 0), (Size (fromIntegral w) (fromIntegral h))) + + waitForMapNotify :: Display -> Window -> IO () waitForMapNotify disp wnd = allocaXEvent waitForMapNotify' where |