module Main where

-- Standard GHC modules

import Control.Monad
import Control.Monad.Fix
import Control.Exception

import Data.Bits
import Data.Maybe
import Data.Word

import Foreign.Ptr

import Graphics.X11.Types
import Graphics.X11.Xlib
import Graphics.X11.Xlib.Types
import Graphics.X11.Xlib.Color
import Graphics.X11.Xlib.Misc

import qualified Graphics.Rendering.OpenGL.GL as GL
import Graphics.Rendering.OpenGL.GL.Framebuffer

-- Local Modules

import ClientMessage
import GLX
import GLX.Constants

-- |createGlWindow - a helper function that creates an OpenGL window
createGlWindow :: Display -> Window -> Position -> Position -> Dimension -> Dimension -> [Attribute] -> IO (Maybe Window)
createGlWindow dpy win xpos ypos xdimen ydimen glxAttrs =
    do mVis <- chooseVisual dpy (defaultScreen dpy) glxAttrs
       case mVis of
         Nothing -> return Nothing
         (Just vis) -> 
             do dep <- depth vis
                w <- allocaXSetWindowAttributes $ \xwa -> 
                     do set_background_pixel xwa (blackPixel dpy (defaultScreen dpy))
                        set_border_pixel xwa (blackPixel dpy (defaultScreen dpy))
                        colorMap <- createColormap dpy win (visual vis) allocNone
                        set_colormap xwa colorMap
                        createWindow dpy win xpos ypos xdimen ydimen 0 dep inputOutput (visual vis) (cWBackPixel .|. cWBorderPixel .|. cWColormap) xwa
                mCtx <- createContext dpy vis Nothing True
                case mCtx of
                  Nothing -> return Nothing
                  (Just ctx) ->
                      do ok <- makeCurrent dpy w ctx
                         if ok
                            then return (Just w)
                            else return Nothing
                       
-- draw something on the OpenGL surface
glDrawScene =
    do GL.clearColor GL.$= GL.Color4 0 0 0 1
       bMap <- GL.newMap1 (0.0,1.0) [ GL.Vertex3 (-0.9) 0.0 0.0
                                    , GL.Vertex3 (-0.5) 3.0 0.0
                                    , GL.Vertex3 0.5 (-3.0) 0.0
                                    , GL.Vertex3 0.9 0.0 0.0
                                    ] :: IO (GL.GLmap1 GL.Vertex3 GL.GLfloat)
       GL.map1 GL.$= Just bMap
       GL.loadIdentity
       GL.clear [ColorBuffer,DepthBuffer]
       GL.color (GL.Color3 1.0 1.0 1.0 :: GL.Color3 GL.GLfloat)
--       GL.renderPrimitive GL.Points $ mapM_ (\i -> GL.vertex $ GL.Vertex2 i i) ([0.0,0.1.. 1.0] :: [GL.GLfloat])
       GL.renderPrimitive GL.Points $ mapM_ GL.evalCoord1 ([0.0,0.01 .. 1.0] :: [GL.GLfloat])
       GL.flush

main =
    bracket (openDisplay ":0") (\d -> closeDisplay d >> putStrLn "done.") $ \dpy ->
        do mW <- createGlWindow dpy (defaultRootWindow dpy) 100 100 400 400 [DoubleBuffer, RGBA, RedSize 1, GreenSize 1, BlueSize 1]
           when (isNothing mW) (error "Could not initialize GL window")
           (Just w) <- return mW
           GL.get doubleBuffer >>= print 
           atom <- internAtom dpy "WM_DELETE_WINDOW" False
           setWMProtocols dpy w [atom]
           selectInput dpy w (structureNotifyMask .|. pointerMotionMask .|. exposureMask)
           mapWindow dpy w
           gc <- createGC dpy w
           setForeground dpy gc (whitePixel dpy (defaultScreen dpy))
           allocaXEvent $ \xe -> 
               do waitForMapNotify dpy xe
                  glDrawScene
                  swapBuffers dpy w
                  waitForDelete dpy w gc xe
    where
      waitForMapNotify dpy xe =
          do nextEvent dpy xe
             et <- get_EventType xe
             if et == mapNotify
              then return ()
              else waitForMapNotify dpy xe
      waitForDelete dpy w gc xe =
          do glDrawScene
             swapBuffers dpy w
             nextEvent dpy xe
             et <- get_EventType xe
             case () of
               () | et == clientMessage ->
                      do (mt, data') <- get_ClientMessageEvent xe
                         protocolsAtom <- internAtom dpy "WM_PROTOCOLS" True
                         deleteWindowAtom <- internAtom dpy "WM_DELETE_WINDOW" True
                         if (mt == protocolsAtom)
                          then case data' of
                                  (ClientData32 (h:_)) | (fromIntegral h) == deleteWindowAtom -> return () -- error "done."
                                  _ -> print data' >> waitForDelete dpy w gc xe
                          else waitForDelete dpy w gc xe
                  | otherwise -> waitForDelete dpy w gc xe