htanks/GLX.hs

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}
      
      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)
                               | 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)
                               | 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
                           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
                               lw = fromIntegral . glxLevelWidth $ glx
                               lh = fromIntegral . glxLevelHeight $ glx
                           return (glx, Just $ SomeEvent $ MouseMotionEvent ((w/2+x)/s - lw/2) ((h/2-y)/s + lh/2))
      | otherwise -> return (glx, Nothing)


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