summaryrefslogtreecommitdiffstats
path: root/GLX.hs
diff options
context:
space:
mode:
Diffstat (limited to 'GLX.hs')
-rw-r--r--GLX.hs93
1 files changed, 53 insertions, 40 deletions
diff --git a/GLX.hs b/GLX.hs
index 4e9abc4..affc185 100644
--- a/GLX.hs
+++ b/GLX.hs
@@ -8,6 +8,7 @@ import Control.Monad (when, unless)
import Data.Bits ((.|.))
import Data.Maybe (isJust)
+import Data.Ratio
import Graphics.Rendering.OpenGL.GL (($=), GLdouble, Capability(..))
import Graphics.Rendering.OpenGL.GL.CoordTrans (matrixMode, MatrixMode(..), viewport, Position(..), Size(..), loadIdentity, ortho)
@@ -16,7 +17,7 @@ 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)
+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)
@@ -32,7 +33,7 @@ data GLX = GLX
, glxWindow :: !Window
, glxContext :: !Context
, glxDeleteWindow :: !Atom
- , glxScale :: !GLdouble
+ , glxScale :: !Rational
}
glxDriver :: GLX
@@ -82,14 +83,14 @@ instance Driver GLX where
ctx <- with visualinfo $ \vi -> createContext disp vi (Context nullPtr) True
makeCurrent disp wnd ctx
- resize 800 600
+ s <- resize 800 600
return GLX
{ glxDisplay = disp
, glxWindow = wnd
, glxContext = ctx
, glxDeleteWindow = delwnd
- , glxScale = 1
+ , glxScale = s
}
deinitGL glx = do
@@ -101,68 +102,80 @@ instance Driver GLX where
nextEvent glx = allocaXEvent $ nextEvent' glx
-nextEvent' :: GLX -> XEventPtr -> IO (Maybe SomeEvent)
+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
- ev <- handleEvent glx xevent
+ (newglx, ev) <- handleEvent glx xevent
if isJust ev then
- return ev
+ return (newglx, ev)
else
- nextEvent' glx xevent
+ nextEvent' newglx xevent
else
- return Nothing
+ return (glx, Nothing)
-handleEvent :: GLX -> XEventPtr -> IO (Maybe SomeEvent)
+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
- resize (fromIntegral . ev_width $ event) (fromIntegral . ev_height $ event)
- return Nothing
+ s <- resize (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 $ Just $ SomeEvent QuitEvent
- | keysym == xK_Up -> return $ Just $ SomeEvent $ KeyPressEvent KeyUp
- | keysym == xK_Down -> return $ Just $ SomeEvent $ KeyPressEvent KeyDown
- | keysym == xK_Left -> return $ Just $ SomeEvent $ KeyPressEvent KeyLeft
- | keysym == xK_Right -> return $ Just $ SomeEvent $ KeyPressEvent KeyRight
- | otherwise -> return Nothing
+ 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)
+ | otherwise -> return (glx, Nothing)
| evtype == keyRelease -> do
- 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
- | keysym == xK_Left -> return $ Just $ SomeEvent $ KeyReleaseEvent KeyLeft
- | keysym == xK_Right -> return $ Just $ SomeEvent $ KeyReleaseEvent KeyRight
- | otherwise -> return Nothing
+ 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)
+ | otherwise -> return (glx, Nothing)
| evtype == clientMessage -> do
- if ((glxDeleteWindow glx) == (fromIntegral . head . ev_data $ event))
- then
- return $ Just $ SomeEvent QuitEvent
- else
- return Nothing
- | otherwise -> return Nothing
-
-
-resize :: Int -> Int -> IO ()
+ if ((glxDeleteWindow glx) == (fromIntegral . head . ev_data $ event))
+ then
+ return (glx, Just $ SomeEvent QuitEvent)
+ else
+ return (glx, Nothing)
+ | evtype == motionNotify -> do
+ wa <- getWindowAttributes (glxDisplay glx) (glxWindow glx)
+ let x = fromIntegral . ev_x $ event
+ y = fromIntegral . ev_y $ event
+ w = fromIntegral . wa_width $ wa
+ h = fromIntegral . wa_height $ wa
+ s = fromRational . glxScale $ glx
+ return (glx, Just $ SomeEvent $ MouseMotionEvent ((x-w/2)/s) ((-y+h/2)/s))
+ | otherwise -> return (glx, Nothing)
+
+
+resize :: Int -> Int -> IO Rational
resize w h = do
- let aspect = (fromIntegral w)/(fromIntegral h)
- s = max (5/aspect) 5 :: GLdouble
+ let size = 5
+ aspect = (fromIntegral w)%(fromIntegral h)
+ s = max (size/aspect) size
+ sf = fromRational s
+ aspectf = fromRational aspect
matrixMode $= Projection
loadIdentity
- ortho (-s*aspect) (s*aspect) (-s) s (-1) 1
+ ortho (-sf*aspectf) (sf*aspectf) (-sf) sf (-1) 1
matrixMode $= Modelview 0
viewport $= ((Position 0 0), (Size (fromIntegral w) (fromIntegral h)))
-
+
+ return $ (fromIntegral h)/(s*2)
waitForMapNotify :: Display -> Window -> IO ()
waitForMapNotify disp wnd = allocaXEvent waitForMapNotify'