module Main where

import Control.Monad
import Control.Exception
import Data.Bits hiding (rotate)
import Data.List
import Data.Maybe
import Data.Word
import Foreign.Marshal.Alloc
import Foreign.Marshal.Utils
import Foreign.Ptr
import Foreign.Storable
import qualified Graphics.Rendering.OpenGL.GL as GL
import qualified Graphics.Rendering.OpenGL.GLU.Matrix as Matrix
import Graphics.Rendering.OpenGL.GLU.Matrix

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 Graphics.UI.SDL.General
import Graphics.UI.SDL.Keysym
import Graphics.UI.SDL.Events
import Graphics.UI.SDL.Types hiding (SrcAlpha)
import Graphics.UI.SDL.Video
-}
import GLX
import GLX.Constants

import FreeType
import ClientMessage

-- create 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

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 GL.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
                  withFreeType $ \ftLibrary ->
                      do ret <- withNewFace ftLibrary "/var/lib/defoma/fontconfig.d/B/Bitstream-Vera-Sans.ttf" 0 $ \ftFace ->
                                do _ <- setCharSize ftFace 0 (22*64) 150 150
                                   glInit
--                                   glImage@(GLImage (GL.Size w' h) pixelData) <- glyph ftFace >>= glyphToGLImage 
--                                   [t] <- GL.genObjectNames 1 
--                                   GL.textureBinding GL.Texture2D GL.$= Just t
--                                   GL.texImage2D Nothing GL.NoProxy 0 GL.RGB' (GL.TextureSize2D w' h) 0 pixelData
--                                   GL.textureFilter GL.Texture2D GL.$= ((GL.Linear', Nothing), GL.Linear')
--                                   glDrawScene glImage
                                   glDrawString ftFace "hello, world!" (GL.Vertex2 50 200 :: GL.Vertex2 GL.GLint)
                                   swapBuffers dpy w
                                   waitForDelete ftFace dpy w gc xe
                         return ()
    where
      waitForMapNotify dpy xe =
          do nextEvent dpy xe
             et <- get_EventType xe
             if et == mapNotify
              then return ()
              else waitForMapNotify dpy xe
      waitForDelete ftFace dpy w gc xe =
          do glDrawString ftFace "hello, world!" (GL.Vertex2 50 200 :: GL.Vertex2 GL.GLint)
             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 ftFace dpy w gc xe
                          else waitForDelete ftFace dpy w gc xe
                  | otherwise -> waitForDelete ftFace dpy w gc xe

glInit =
    do GL.clearColor GL.$= GL.Color4 0 0 0 1
       GL.blendFunc GL.$= (GL.SrcAlpha, GL.One)
       GL.blend GL.$= GL.Enabled
       GL.texture GL.Texture2D GL.$= GL.Enabled
       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


glDrawScene (GLImage size _offset pixelData) =
    do GL.loadIdentity
       GL.clear [GL.ColorBuffer,GL.DepthBuffer]
--       GL.rasterPos ((GL.Vertex2 (-0.25) (-0.25)) :: GL.Vertex2 GL.GLfloat)
       GL.rowAlignment GL.Unpack GL.$= 1
       GL.drawPixels size pixelData -- (Size (abs (fromIntegral w)) (fromIntegral r)) (PixelData Luminance UnsignedByte buf)
       GL.flush

-- glDrawString :: FT_Face -> String -> (GL.Vertex2 GL.GLInt) -> IO (GL.Vertex2 GL.GLInt)
glDrawString face str pos =
    do GL.clear [GL.ColorBuffer,GL.DepthBuffer]
       GL.matrixMode GL.$= GL.Projection
       GL.loadIdentity
       Matrix.ortho2D 0.0 400.0 0.0 400.0
       GL.matrixMode GL.$= GL.Modelview 0
       GL.loadIdentity
       GL.translate ((GL.Vector3 0.375 0.375 0.0) :: GL.Vector3 GL.GLfloat)
       GL.rowAlignment GL.Unpack GL.$= 1
       drawString str pos Nothing
    where
      drawString [] _ pos = return pos
      drawString (c:cs) pos@(GL.Vertex2 x y) prev =
          do flags <- faceFlags face
--             print ("kerning?", flags .&. faceFlagKerning == faceFlagKerning)
             loadFace face c
             gly' <- glyph face
             glImage@(GLImage size@(GL.Size _ h) (GL.Vector2 left top) pixelData) <- glyphToGLImage gly'
             case prev of
               Nothing -> GL.rasterPos (GL.Vertex2 (x + left) (y - (h - top)))
               (Just prevC) ->
                   do leftIndex <- getCharIndex face prevC
                      rightIndex <- getCharIndex face c
                      mDelta <- getKerning face leftIndex rightIndex KerningDefault
                      case mDelta of
                        Left e -> error $ "Failed to get kerning for " ++ show (prevC, c)
                        Right (FT_Vector (deltaX, deltaY)) ->
                            do -- print (deltaX, deltaX `shiftR` 6)
                               GL.rasterPos (GL.Vertex2 (x + left + (deltaX `shiftR` 6)) (y - (h - top)))
             GL.drawPixels size pixelData
             (FT_Vector (xOffset,yOffset)) <- advance gly'
--             print (c,"advance",xOffset `shiftR` 6 ,yOffset `shiftR` 6)
             drawString cs (GL.Vertex2 (x + (xOffset `shiftR` 6)) y) (Just c)

glDrawSceneTextureMap t (GLImage size _ pixelData) r =
    do GL.loadIdentity
       GL.clear [GL.ColorBuffer,GL.DepthBuffer]
--       rasterPos ((Vertex2 (-0.25) (-0.25)) :: Vertex2 GLfloat)
--       rowAlignment Unpack $= 1
--       drawPixels size pixelData -- (Size (abs (fromIntegral w)) (fromIntegral r)) (PixelData Luminance UnsignedByte buf)
       GL.textureBinding GL.Texture2D GL.$= Just t
       GL.rotate r (GL.Vector3 1.0 1.0 1.0 :: GL.Vector3 GL.GLfloat)
       GL.renderPrimitive GL.Quads $ do GL.texCoord (GL.TexCoord2 0.0 0.0 :: GL.TexCoord2 GL.GLfloat)
                                        GL.vertex (GL.Vertex2 (-0.5) (-0.5) :: GL.Vertex2 GL.GLfloat)
                                        GL.texCoord (GL.TexCoord2 1.0 0.0 :: GL.TexCoord2 GL.GLfloat)
                                        GL.vertex (GL.Vertex2 (0.3) (-0.5) :: GL.Vertex2 GL.GLfloat)
                                        GL.texCoord (GL.TexCoord2 1.0 1.0 :: GL.TexCoord2 GL.GLfloat)
                                        GL.vertex (GL.Vertex2 (0.3) (0.5) :: GL.Vertex2 GL.GLfloat)
                                        GL.texCoord (GL.TexCoord2 0.0 1.0 :: GL.TexCoord2 GL.GLfloat)
                                        GL.vertex (GL.Vertex2 (-0.5) (0.5) :: GL.Vertex2 GL.GLfloat)


-- * Helper Functions

data GLImage a = GLImage GL.Size (GL.Vector2 GL.GLint) (GL.PixelData a)

roundUpToNextPowerOf2 :: (Num a, Ord a) => a -> a
roundUpToNextPowerOf2 n = fromJust $ find (\ n' -> n' > n) [ 2^p | p <- [0..]]

-- FIXME: need finalizer..
glyphToGLImage :: FT_GlyphSlot -> IO (GLImage Word8)
glyphToGLImage glyph =
    do let bm = FreeType.bitmap glyph
       w <- pitch bm
       h <- rows bm
       buf <- buffer bm
       top <- bitmap_top glyph
       left <- bitmap_left glyph
       buf' <- flipBuf buf (fromIntegral w) (fromIntegral h)
       return $ GLImage (GL.Size (fromIntegral w) (fromIntegral h)) (GL.Vector2 (fromIntegral left) (fromIntegral top)) (GL.PixelData GL.Luminance GL.UnsignedByte buf')
{-
       let w' = fromIntegral $ roundUpToNextPowerOf2 w
           h' = fromIntegral $ roundUpToNextPowerOf2 h
       buf' <- resizeBuf (fromIntegral w) (fromIntegral h) buf w' h' 
       return $ GLImage (GL.Size (fromIntegral w') (fromIntegral h')) (GL.Vector2 (fromIntegral left) (fromIntegral top)) (GL.PixelData GL.Luminance GL.UnsignedByte buf')
-}
-- FIXME: free memory
flipBuf buf w h =
    do buf' <- mallocBytes (w * h)
       copyRows (buf' `plusPtr` (w * (h - 1))) buf (h - 1)
       return buf'
    where
      copyRows to from rows | rows < 0 = return ()
      copyRows to from rows =
              do copyBytes to from w
                 copyRows (to `plusPtr` (-w)) (from `plusPtr` w) (rows - 1)

-- FIXME: zero memory
-- assumes dstLen > srcLen
resizeBuf w h buf w' h' =
    do buf' <- mallocBytes (w' * h')
       copyRows (buf' `plusPtr` ((h' - 1) * w')) buf h w w'
       return buf'
    where 
      copyRows to from 0 srcLen dstLen =
          do zeroRows to dstLen (h' - h)
      copyRows to from rows srcLen dstLen = 
              do copyBytes to from srcLen
                 zeroBytes (to `plusPtr` srcLen) (dstLen - srcLen)
                 copyRows (to `plusPtr` (-dstLen)) (from `plusPtr` srcLen) (rows - 1) srcLen dstLen
      zeroBytes ptr 0 = return ()
      zeroBytes ptr n = poke ptr (0 :: Word8) >> zeroBytes (ptr `plusPtr` 1) (n - 1)
      zeroRows ptr len 0 = return ()
      zeroRows ptr len n = 
          do zeroBytes ptr len
             zeroRows (ptr `plusPtr` (-len)) len (n - 1)

loadFace :: FT_Face -> Char -> IO ()
loadFace ftFace c =
    do i <- getCharIndex ftFace c
       res <- loadGlyph ftFace i [LoadRender]
       when (res /= 0) (error "Error loading glyph")
{-
       bm <- liftM FreeType.bitmap $ glyph ftFace
       w <- width bm
       p <- pitch bm
       r <- rows bm
       ng <- numGrays bm
       print (ng,(w,p),r)
-}