{-# LANGUAGE MultiParamTypeClasses, NamedFieldPuns #-}
module Graphics.LambdaCube.RenderSystem.GL.RenderSystem where

import Control.Monad
import Data.IORef
import Data.IntMap ((!))
import Data.Maybe
import Data.Word
import Foreign
import Foreign.C.String
import qualified Data.IntMap as IntMap
import qualified Data.Set as Set

import Graphics.Rendering.OpenGL.Raw.Core31
import qualified Graphics.Rendering.OpenGL.Raw.ARB as ARB
import qualified Graphics.Rendering.OpenGL.Raw.EXT as EXT
import qualified Graphics.Rendering.OpenGL.Raw.ARB.Compatibility as Compat

import Graphics.LambdaCube.BlendMode
import Graphics.LambdaCube.Common
import Graphics.LambdaCube.HardwareIndexBuffer
import Graphics.LambdaCube.HardwareVertexBuffer
import Graphics.LambdaCube.Light
import Graphics.LambdaCube.RenderOperation
import Graphics.LambdaCube.RenderSystem
import Graphics.LambdaCube.RenderSystem.GL.Capabilities
import Graphics.LambdaCube.RenderSystem.GL.GpuProgram
import Graphics.LambdaCube.RenderSystem.GL.IndexBuffer
import Graphics.LambdaCube.RenderSystem.GL.OcclusionQuery
import Graphics.LambdaCube.RenderSystem.GL.Texture
import Graphics.LambdaCube.RenderSystem.GL.Utils
import Graphics.LambdaCube.RenderSystem.GL.VertexBuffer
import Graphics.LambdaCube.RenderSystemCapabilities
import Graphics.LambdaCube.Texture
import Graphics.LambdaCube.TextureUnitState
import Graphics.LambdaCube.Types
import Graphics.LambdaCube.VertexIndexData

data GLState
    = GLState
    { stLight   :: (Proj4,[(Proj4,Light)])
    , stSurface :: (FloatType4,FloatType4,FloatType4,FloatType4,FloatType,TrackVertexColourType)
    }

mkGLState :: IO (IORef GLState)
mkGLState = do
    let st = GLState
            { stLight = (idmtx,[])
            , stSurface = (c,c,c,c,0,TrackVertexColourType False False False False)
            }
        c = (0,0,0,0)
    newIORef st

instance Eq Proj4 where
    a == b = fromProjective a == fromProjective b

data GLRenderSystem
    = GLRenderSystem
    { glrsWorldMatrix   :: IORef Proj4
    , glrsViewMatrix    :: IORef Proj4
    , glrsCapabilities  :: RenderSystemCapabilities
    , glrsState         :: IORef GLState
    }

mkGLRenderSystem :: IO GLRenderSystem
mkGLRenderSystem = do
    worldMat <- newIORef $ idmtx
    viewMat <- newIORef $ idmtx
    cap <- mkGLCapabilities
    glState <- mkGLState

    -- Initialize OpenGL
    {-
    glExtensions :: GettableStateVar [String]
    glExtensions = makeGettableStateVar (fmap words $ getString gl_EXTENSIONS)

    getString :: GLenum -> IO String
    getString n = glGetString n >>= maybeNullPtr (return "") (peekCString . castPtr)

    maybeNullPtr :: b -> (Ptr a -> b) -> Ptr a -> b
    maybeNullPtr n f ptr | ptr == nullPtr = n
                         | otherwise      = f ptr
    -}
    (major,minor) <- getGLVersion
    extSList <- getGLExtensions
    -- setup capabilities
    let ext = Set.fromList extSList
        glVer a b = major > a || (major >= a && minor >= b)
        supports s = Set.member s ext
        f = fromIntegral

    when (glVer 1 2) $ do
        -- Set nicer lighting model -- d3d9 has this by default
        Compat.glLightModeli Compat.gl_LIGHT_MODEL_COLOR_CONTROL $ f Compat.gl_SEPARATE_SPECULAR_COLOR
        Compat.glLightModeli Compat.gl_LIGHT_MODEL_LOCAL_VIEWER 1

    when (glVer 1 4) $ do
        glEnable Compat.gl_COLOR_SUM
        glDisable gl_DITHER

    -- Check for FSAA
    when (supports "GL_ARB_multisample") $ do
        fsaa <- getInteger ARB.gl_SAMPLE_BUFFERS
        when (fsaa > 0) $ do
            glEnable ARB.gl_MULTISAMPLE
            putStrLn $ "Render System " ++ "Using FSAA from GL_ARB_multisample extension."

    return $ GLRenderSystem
        { glrsWorldMatrix   = worldMat
        , glrsViewMatrix    = viewMat
        , glrsCapabilities  = cap
        , glrsState         = glState
        }

glWithFrameBuffer :: Int -> Int -> Int -> Int -> (Ptr Word8 -> IO ()) -> IO ()
glWithFrameBuffer x y w h fn = allocaBytes (w*h*4) $ \p -> do
    glReadPixels (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) gl_RGBA gl_UNSIGNED_BYTE $ castPtr p
    fn p
{-
copyTexImage2D :: Maybe CubeMapTarget -> Level -> PixelInternalFormat -> Position -> TextureSize2D -> Border -> IO ()
copyTexImage2D mbCubeMap level int (Position x y) (TextureSize2D w h) border =
   glCopyTexImage2D
      (maybe (marshalTextureTarget Texture2D) marshalCubeMapTarget mbCubeMap) level
      (marshalPixelInternalFormat' int) x y w h border
-}
glDirtyHackCopyTexImage :: GLTexture -> Int -> Int -> Int -> Int -> IO ()
glDirtyHackCopyTexImage tex x y w h = do
    {-
    GL.textureBinding GL.Texture2D $= (Just $ gltxTextureObject tex)
            -- only hint code: glCopyTexImage2D(GL_TEXTURE_2D, 0, GL_LUMINANCE, 0, 0, 128, 128, 0);
    GL.copyTexImage2D Nothing 0 GL.RGBA' (GL.Position (fromIntegral x) (fromIntegral y)) (GL.TextureSize2D (fromIntegral w) (fromIntegral h)) 0
    -}
    glActiveTexture $ fromIntegral gl_TEXTURE0
    --glEnable gl_TEXTURE_2D
    glBindTexture gl_TEXTURE_2D $ gltxTextureObject tex
            -- only hint code: glCopyTexImage2D(GL_TEXTURE_2D, 0, GL_LUMINANCE, 0, 0, 128, 128, 0);
    glCopyTexImage2D gl_TEXTURE_2D 0 gl_RGBA (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) 0

instance RenderSystem GLRenderSystem GLVertexBuffer GLIndexBuffer GLOcclusionQuery GLTexture GLGpuProgram GLLinkedGpuProgram where
    withFrameBuffer _               = glWithFrameBuffer
    dirtyHackCopyTexImage _         = glDirtyHackCopyTexImage
    getName _                       = "OpenGL Rendering Subsystem"
    getCapabilities                 = glrsCapabilities
    createVertexBuffer _            = mkGLVertexBuffer
    createIndexBuffer _             = mkGLIndexBuffer
    createOcclusionQuery _          = mkGLOcclusionQuery
    createTexture rs                = mkGLTexture (glrsCapabilities rs)
    createGpuProgram _              = mkGLGpuProgram
    createLinkedGpuProgram _        = mkGLLinkedGpuProgram
    bindLinkedGpuProgram _          = glBindLinkedGpuProgram
    unbindLinkedGpuProgram _        = glUnBindLinkedGpuProgram
    render _                        = glRender
    bindGeometry _                  = glBindGeometry
    unbindGeometry rs               = glUnBindGeometry (glrsCapabilities rs)
    setViewport _ x y w h           = glSetViewport x y w h
    setPolygonMode _ pm             = glSetPolygonMode pm
    setWorldMatrix                  = glSetWorldMatrix
    setViewMatrix                   = glSetViewMatrix
    setProjectionMatrix _ m         = glSetProjectionMatrix m
    clearFrameBuffer _ b c d s      = glClearFrameBuffer b c d s
    setShadingType _                = glSetShadingType
    setCullingMode _                = glSetCullingMode
    setAlphaRejectSettings rs       = glSetAlphaRejectSettings (glrsCapabilities rs)
    setDepthBias _                  = glSetDepthBias
    setDepthBufferCheckEnabled _    = glSetDepthBufferCheckEnabled
    setDepthBufferWriteEnabled _    = glSetDepthBufferWriteEnabled
    setDepthBufferFunction _        = glSetDepthBufferFunction  --FIXME
    setColourBufferWriteEnabled _   = glSetColourBufferWriteEnabled
    setSurfaceParams                = glSetSurfaceParams
    setLightingEnabled _            = glSetLightingEnabled
    useLights                       = glUseLights
    setFog _                        = glSetFog
    setSceneBlending _              = glSetSceneBlending
    setSeparateSceneBlending _      = glSetSeparateSceneBlending
    setPointParameters              = glSetPointParameters
    setPointSpritesEnabled rs       = glSetPointSpritesEnabled (glrsCapabilities rs)
    setActiveTextureUnit _          = glSetActiveTextureUnit
    setTexture _                    = glSetTexture
    setTextureAddressingMode _      = glSetTextureAddressingMode
    setTextureUnitFiltering _       = glSetTextureUnitFiltering
    setTextureLayerAnisotropy _     = glSetTextureLayerAnisotropy
    setTextureMipmapBias _          = glSetTextureMipmapBias
    setTextureMatrix _              = glSetTextureMatrix
    setTextureBorderColour _        = glSetTextureBorderColour
    setTextureCoordCalculation _    = glSetTextureCoordCalculation
    setTextureBlendMode rs          = glSetTextureBlendMode (glrsCapabilities rs)
    getMinimumDepthInputValue _     = -1
    getMaximumDepthInputValue _     = 1
    prepareRender _                 = glPrepareRender
    finishRender _                  = glFinishRender

glPrepareRender :: IO ()
glPrepareRender = do
    Compat.glColor3f 1 1 1
    glEnable gl_SCISSOR_TEST

glFinishRender :: IO ()
glFinishRender = do
    Compat.glColor3f 1 1 1
    glDisable gl_SCISSOR_TEST

glSetDepthBias :: FloatType -> FloatType -> IO ()
glSetDepthBias constantBias slopeScaleBias = case constantBias /= 0 || slopeScaleBias /= 0 of
    True  -> do
        glEnable gl_POLYGON_OFFSET_FILL
        glEnable gl_POLYGON_OFFSET_POINT
        glEnable gl_POLYGON_OFFSET_LINE
        glPolygonOffset (realToFrac (-slopeScaleBias)) (realToFrac (-constantBias))
    False -> do
        glDisable gl_POLYGON_OFFSET_FILL
        glDisable gl_POLYGON_OFFSET_POINT
        glDisable gl_POLYGON_OFFSET_LINE

glSetViewport :: Int -> Int -> Int -> Int -> IO ()
glSetViewport x y w h = do
    let x' = fromIntegral x
        y' = fromIntegral y
        w' = fromIntegral w
        h' = fromIntegral h
    glViewport x' y' w' h'
    glScissor x' y' w' h' -- Configure the viewport clipping

glSetPolygonMode :: PolygonMode -> IO ()
glSetPolygonMode pm = case pm of
    PM_POINTS     -> polygonMode gl_POINT
    PM_WIREFRAME  -> polygonMode gl_LINE
    PM_SOLID      -> polygonMode gl_FILL
  where
    polygonMode m = do
        glPolygonMode gl_FRONT m
        glPolygonMode gl_BACK m

-- TODO: handle double type, currently it supports Float only
glSetupMatrix :: Proj4 -> Proj4 -> IO ()
glSetupMatrix vm wm = do
    Compat.glMatrixMode Compat.gl_MODELVIEW
    with (wm .*. vm) $ \mp -> do
        Compat.glLoadMatrixf $ castPtr mp

glSetWorldMatrix :: GLRenderSystem -> Proj4 -> IO ()
glSetWorldMatrix rs wm = do
    writeIORef (glrsWorldMatrix rs) wm
    viewMat <- readIORef $ glrsViewMatrix rs
    glSetupMatrix viewMat wm

glSetViewMatrix :: GLRenderSystem -> Proj4 -> IO ()
glSetViewMatrix rs vm = do
    writeIORef (glrsViewMatrix rs) vm
    worldMat <- readIORef $ glrsWorldMatrix rs
    glSetupMatrix vm worldMat

glSetProjectionMatrix :: Mat4 -> IO ()
glSetProjectionMatrix pm = do
    Compat.glMatrixMode Compat.gl_PROJECTION
    with pm $ \pp -> do
        Compat.glLoadMatrixf $ castPtr pp

glClearFrameBuffer :: FrameBufferType -> FloatType4 -> FloatType -> Word16 -> IO ()
glClearFrameBuffer buffers colour depth stencil = do
    tmpColorMask    <- getBoolean4 gl_COLOR_WRITEMASK
    tmpDepthMask    <- getBoolean gl_DEPTH_WRITEMASK
    tmpStencilMask  <- getInteger gl_STENCIL_WRITEMASK
    tmpScissor      <- getInteger4 gl_SCISSOR_BOX

    when (fbtColour buffers) $ do
        let (r',g',b',a')   = colour
            (r,g,b,a)       = (f r',f g',f b',f a')
            f               :: FloatType -> GLclampf
            f               = realToFrac
        glColorMask 1 1 1 1
        glClearColor r g b a

    when (fbtDepth buffers) $ do
        let f :: FloatType -> GLclampd
            f  = realToFrac
        glDepthMask $ fromIntegral gl_TRUE
        glClearDepth $ f depth

    when (fbtStencil buffers) $ do
        let f :: Word16 -> GLint
            f  = fromIntegral
        glStencilMask 0xFFFFFFFF
        glClearStencil $ f stencil

    let f  = fromIntegral
    (x,y,w,h) <- getInteger4 gl_VIEWPORT
    glScissor x y (f w) (f h)

    -- HINT: workaround for a mesa gma bug
    when (fbtColour buffers) $ glClear $ fromIntegral gl_COLOR_BUFFER_BIT
    when (fbtDepth buffers) $ glClear $ fromIntegral gl_DEPTH_BUFFER_BIT
    when (fbtStencil buffers) $ glClear $ fromIntegral gl_STENCIL_BUFFER_BIT
    --GL.clear $ map fst $ filter (\(_,b) -> b) $ zip [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer] [fbtColour buffers, fbtDepth buffers, fbtStencil buffers]

    let uncurry4 mf (a,b,c,d) = mf (fromIntegral a) (fromIntegral b) (fromIntegral c) (fromIntegral d)
        uncurry4b mf (a,b,c,d) = mf (a) (b) (c) (d)
    uncurry4 glScissor tmpScissor
    glDepthMask $ fromIntegral tmpDepthMask
    uncurry4b glColorMask tmpColorMask
    glStencilMask $ fromIntegral tmpStencilMask

glBindGeometry :: (Texture t) => RenderOperation GLVertexBuffer GLIndexBuffer -> [TextureUnitState t] -> IO ()
glBindGeometry ro tl = do
    let multitexturing  = True -- 1 < (rscNumTextureUnits rcap)
        vertexData      = roVertexData ro
        decl            = vdVertexDeclaration vertexData
        checkBinding e  = case vdVertexBufferBinding vertexData of
            VertexBufferBinding bm -> veSource e `IntMap.member` bm
    --  bind vertex elements
    mapM_ (bindElement ro tl) $ filter checkBinding $ vdElementList decl

    when multitexturing $ Compat.glClientActiveTexture gl_TEXTURE0
    --  bind index data and call draw operation
    case roIndexData ro of
        Just indexData    -> glBindBuffer gl_ELEMENT_ARRAY_BUFFER $ glibBufferObject $ idIndexBuffer indexData
        Nothing           -> return ()

    return ()

glUnBindGeometry :: RenderSystemCapabilities -> RenderOperation GLVertexBuffer GLIndexBuffer -> IO ()
glUnBindGeometry rsc _ro = do
    let multitexturing  = True -- 1 < (rscNumTextureUnits rcap)
        f = fromIntegral

    Compat.glDisableClientState Compat.gl_VERTEX_ARRAY
    -- only valid up to GL_MAX_TEXTURE_UNITS, which is recorded in mFixedFunctionTextureUnits
    case multitexturing of
        True  -> do
            forM_ [0..(rscNumTextureUnits rsc - 1)] $ \stage -> do
                Compat.glClientActiveTexture $ fromIntegral gl_TEXTURE0 + f stage
                Compat.glDisableClientState Compat.gl_TEXTURE_COORD_ARRAY
            Compat.glClientActiveTexture gl_TEXTURE0
        False -> Compat.glDisableClientState Compat.gl_TEXTURE_COORD_ARRAY
    Compat.glDisableClientState Compat.gl_NORMAL_ARRAY
    Compat.glDisableClientState Compat.gl_COLOR_ARRAY
    Compat.glDisableClientState Compat.gl_SECONDARY_COLOR_ARRAY

    -- unbind any custom attributes

    -- unbind buffers
    glBindBuffer gl_ELEMENT_ARRAY_BUFFER 0
    glBindBuffer gl_ARRAY_BUFFER 0
    return ()

-- _render :: RenderSystemCapabilities -> RenderOperation -> IO ()
--glRender :: Int -> GLRenderState -> RenderOperation -> IO GLRenderState
--glRender :: (HardwareVertexBuffer vb, HardwareIndexBuffer ib) => Int -> RenderOperation vb ib -> IO ()
glRender :: RenderOperation GLVertexBuffer GLIndexBuffer -> IO ()
glRender ro = do
    -- TODO:
    let vertexData      = roVertexData ro
        --multitexturing  = True -- 1 < (rscNumTextureUnits rcap)
        --Use adjacency if there is a geometry program and it requested adjacency info
        -- TODO
        --bool useAdjacency = (mGeometryProgramBound && mCurrentGeometryProgram->isAdjacencyInfoRequired());
        primType        = case roOperationType ro of -- Find the correct type to render
            OT_POINT_LIST     -> gl_POINTS
            OT_LINE_LIST      -> gl_LINES
            OT_LINE_STRIP     -> gl_LINE_STRIP
            OT_TRIANGLE_LIST  -> gl_TRIANGLES
            OT_TRIANGLE_STRIP -> gl_TRIANGLE_STRIP
            OT_TRIANGLE_FAN   -> gl_TRIANGLE_FAN

    --  bind index data and call draw operation
    case roIndexData ro of
        Just indexData  -> do
            let indexBuffer = idIndexBuffer indexData
                dp          = if 0 /= glibBufferObject indexBuffer then nullPtr else fromMaybe (error "fromJust 7") $ glibShadowBuffer indexBuffer
                pBufferData = plusPtr dp $ idIndexStart indexData * getIndexSize indexBuffer
                indexType   = if getIndexType indexBuffer == IT_16BIT then gl_UNSIGNED_SHORT else gl_UNSIGNED_INT
                --putStrLn $ "glDrawElements (VBI) buf ptr: " ++ show dp ++ " data ptr: " ++ show pBufferData
            glDrawElements primType (fromIntegral (idIndexCount indexData)) indexType pBufferData
        Nothing -> do
            --putStrLn $ "glDrawArrays (VBI)"
            glDrawArrays primType 0 (fromIntegral (vdVertexCount vertexData))

bindElement :: (Texture t, HardwareIndexBuffer ib) => RenderOperation GLVertexBuffer ib -> [TextureUnitState t] -> VertexElement  -> IO ()
bindElement rop tl elem = do
    let vertexData      = roVertexData $ rop

    case vdVertexBufferBinding vertexData of
        VertexBufferBinding bm -> let vertexBuffer = bm ! (veSource elem) in do
            dp <- case glvbBufferObject vertexBuffer of
                0 -> do
                    return $ fromMaybe (error "fromJust 8") $ glvbShadowBuffer vertexBuffer
                b -> do
                    glBindBuffer gl_ARRAY_BUFFER b
                    return nullPtr

            let pBufferData     = plusPtr dp $ vdVertexStart vertexData * getVertexSize vertexBuffer + veOffset elem
                sem             = veSemantic elem
                isCustomAttrib  = False
                bindWith t     = t (fromIntegral . getTypeCount . veType $ elem) (getGLType . veType $ elem) (fromIntegral . getVertexSize $ vertexBuffer) pBufferData
                bindWith' t    = t (getGLType . veType $ elem) (fromIntegral . getVertexSize $ vertexBuffer) pBufferData
            --putStrLn $ show sem ++ " (VBO) buf ptr: " ++ show dp ++ " data ptr: " ++ show pBufferData
            --bind vertexBuffer
            case isCustomAttrib of
                True  -> do
                    -- Custom attribute support
                    -- tangents, binormals, blendweights etc always via this route
                    -- builtins may be done this way too
                    let attrib = fromIntegral . getFixedAttributeIndex sem $ veIndex elem
                        normalised = case veType elem of
                            VET_COLOUR_ABGR -> gl_TRUE
                            VET_COLOUR_ARGB -> gl_TRUE
                            _               -> gl_FALSE
                    glVertexAttribPointer attrib (fromIntegral . getTypeCount . veType $ elem) (getGLType . veType $ elem) (fromIntegral normalised) (fromIntegral . getVertexSize $ vertexBuffer) pBufferData
                    glEnableVertexAttribArray attrib
                    --attribsBound.push_back(attrib);
                False -> case sem of -- fixed-function & builtin attribute support
                    VES_POSITION              -> bindWith Compat.glVertexPointer >> Compat.glEnableClientState Compat.gl_VERTEX_ARRAY
                    VES_NORMAL                -> bindWith' Compat.glNormalPointer >> Compat.glEnableClientState Compat.gl_NORMAL_ARRAY
                    VES_DIFFUSE               -> bindWith Compat.glColorPointer >> Compat.glEnableClientState Compat.gl_COLOR_ARRAY
                    VES_SPECULAR              -> bindWith Compat.glSecondaryColorPointer >> Compat.glEnableClientState Compat.gl_SECONDARY_COLOR_ARRAY
                    VES_TEXTURE_COORDINATES   -> do
                    -- TODO
                        let idx = veIndex elem
                            tus = map fst $ filter (\(_,a)-> idx==a) $ zip [0 :: Int ..] $ map tusTextureCoordSetIndex tl
                        forM_ tus $ \tidx -> do
                            --print $ "bind stage="++show tidx ++ " texcoord="++show idx
                            Compat.glClientActiveTexture $ fromIntegral gl_TEXTURE0 + fromIntegral tidx
                            bindWith Compat.glTexCoordPointer >> Compat.glEnableClientState Compat.gl_TEXTURE_COORD_ARRAY
                    _ -> error "bindElement"

glSetShadingType :: ShadeOptions -> IO ()
glSetShadingType so = case so of
    SO_FLAT   -> Compat.glShadeModel Compat.gl_FLAT
    _         -> Compat.glShadeModel Compat.gl_SMOOTH

glSetAlphaRejectSettings :: RenderSystemCapabilities -> CompareFunction -> Int  -> Bool -> IO ()
glSetAlphaRejectSettings rsc func value alphaToCoverage = do
    let caps    = rscCapabilities rsc
        f       = fromIntegral :: Int -> GLclampf
    case func == CMPF_ALWAYS_PASS of
        { True  -> do
            glDisable Compat.gl_ALPHA_TEST
            when (Set.member RSC_ALPHA_TO_COVERAGE caps) $ glDisable gl_SAMPLE_ALPHA_TO_COVERAGE
        ; False -> do
            glEnable Compat.gl_ALPHA_TEST
            Compat.glAlphaFunc (convertCompareFunction func) (f value / 255)
            when (Set.member RSC_ALPHA_TO_COVERAGE caps) $ case alphaToCoverage of
                True    -> glEnable gl_SAMPLE_ALPHA_TO_COVERAGE
                False   -> glDisable gl_SAMPLE_ALPHA_TO_COVERAGE
        }

glSetDepthBufferCheckEnabled :: Bool -> IO ()
glSetDepthBufferCheckEnabled enabled = case enabled of
    { True  -> glClearDepth 1 >> glEnable gl_DEPTH_TEST
    ; False -> glDisable gl_DEPTH_TEST
    }

glSetDepthBufferWriteEnabled :: Bool -> IO ()
glSetDepthBufferWriteEnabled enabled = case enabled of
    { True  -> glDepthMask $ fromIntegral gl_TRUE
    ; False -> glDepthMask $ fromIntegral gl_FALSE
    }

glSetDepthBufferFunction :: CompareFunction -> IO ()
glSetDepthBufferFunction func = glDepthFunc $ convertCompareFunction func

glSetPointSpritesEnabled :: RenderSystemCapabilities -> Bool -> IO ()
glSetPointSpritesEnabled rsc enabled = when (Set.member RSC_POINT_SPRITES $ rscCapabilities rsc) $ do
    case enabled of
        { True  -> glEnable Compat.gl_POINT_SPRITE
        ; False -> glDisable Compat.gl_POINT_SPRITE
        }
    let en = if enabled then gl_TRUE else gl_FALSE
    -- Set sprite texture coord generation
    -- Don't offer this as an option since D3D links it to sprite enabled
    forM_ [0..rscNumTextureUnits rsc] $ \i -> do
        glActiveTexture $ fromIntegral gl_TEXTURE0 + fromIntegral i
        Compat.glTexEnvi Compat.gl_POINT_SPRITE Compat.gl_COORD_REPLACE $ fromIntegral en
    glActiveTexture $ fromIntegral gl_TEXTURE0

glSetSceneBlending :: SceneBlendFactor -> SceneBlendFactor -> SceneBlendOperation -> IO ()
glSetSceneBlending sourceFactor destFactor op = do
    case sourceFactor == SBF_ONE && destFactor == SBF_ZERO of
        { True  -> glDisable gl_BLEND
        ; False -> do
            glEnable gl_BLEND
            glBlendFunc (getBlendMode sourceFactor) (getBlendMode destFactor)
        }
    glBlendEquation $ getBlendEquation op

glSetSurfaceParams :: GLRenderSystem -> FloatType4 -> FloatType4 -> FloatType4 -> FloatType4 -> FloatType -> TrackVertexColourType -> IO ()
glSetSurfaceParams rs ambient diffuse specular emissive shininess tc@(TrackVertexColourType a d s e) = do
    st@GLState { stSurface } <- readIORef $ glrsState rs
    let newSt = (ambient, diffuse, specular, emissive, shininess, tc)
    when (stSurface /= newSt) $ do
        writeIORef (glrsState rs) $ st { stSurface = newSt }
        -- Track vertex colour
        -- There are actually 15 different combinations for tracking, of which
        -- GL only supports the most used 5. This means that we have to do some
        -- magic to find the best match. NOTE:
        --  GL_AMBIENT_AND_DIFFUSE != GL_AMBIENT | GL__DIFFUSE
        case (a,d,s,e) of
            (False,False,False,False) -> glDisable Compat.gl_COLOR_MATERIAL
            (True,True,_,_)           -> glEnable Compat.gl_COLOR_MATERIAL >> Compat.glColorMaterial gl_FRONT_AND_BACK Compat.gl_AMBIENT_AND_DIFFUSE
            (True,False,_,_)          -> glEnable Compat.gl_COLOR_MATERIAL >> Compat.glColorMaterial gl_FRONT_AND_BACK Compat.gl_AMBIENT
            (_,True,_,_)              -> glEnable Compat.gl_COLOR_MATERIAL >> Compat.glColorMaterial gl_FRONT_AND_BACK Compat.gl_DIFFUSE
            (_,_,True,_)              -> glEnable Compat.gl_COLOR_MATERIAL >> Compat.glColorMaterial gl_FRONT_AND_BACK Compat.gl_SPECULAR
            (_,_,_,True)              -> glEnable Compat.gl_COLOR_MATERIAL >> Compat.glColorMaterial gl_FRONT_AND_BACK Compat.gl_EMISSION
        let f           = realToFrac
            c (r,g,b,a') = [f r, f g, f b, f a']
        withArray (c diffuse) $ \p -> Compat.glMaterialfv gl_FRONT_AND_BACK Compat.gl_DIFFUSE p
        withArray (c ambient) $ \p -> Compat.glMaterialfv gl_FRONT_AND_BACK Compat.gl_AMBIENT p
        withArray (c specular) $ \p -> Compat.glMaterialfv gl_FRONT_AND_BACK Compat.gl_SPECULAR p
        withArray (c emissive) $ \p -> Compat.glMaterialfv gl_FRONT_AND_BACK Compat.gl_EMISSION p
        Compat.glMaterialf gl_FRONT_AND_BACK Compat.gl_SHININESS $ f shininess

glSetLightingEnabled :: Bool -> IO ()
glSetLightingEnabled enabled = case enabled of
    True  -> glEnable Compat.gl_LIGHTING
    False -> glDisable Compat.gl_LIGHTING

glSetFog :: FogMode -> FloatType4 -> FloatType -> FloatType -> FloatType -> IO ()
glSetFog mode (r,g,b,a) density start end = case mode of
    FOG_NONE  -> glDisable Compat.gl_FOG
    FOG_EXP   -> setFog $ fromIntegral Compat.gl_EXP
    FOG_EXP2  -> setFog $ fromIntegral Compat.gl_EXP2
    FOG_LINEAR-> setFog $ fromIntegral gl_LINEAR
  where
    f = realToFrac
    setFog fm = withArray [r,g,b,a] $ \p -> do
        glEnable Compat.gl_FOG
        Compat.glFogi Compat.gl_FOG_MODE fm
        Compat.glFogfv Compat.gl_FOG_COLOR $ castPtr p
        Compat.glFogf Compat.gl_FOG_DENSITY $ f density
        Compat.glFogf Compat.gl_FOG_START $ f start
        Compat.glFogf Compat.gl_FOG_END $ f end

glSetSeparateSceneBlending :: SceneBlendFactor -> SceneBlendFactor -> SceneBlendFactor -> SceneBlendFactor -> SceneBlendOperation -> SceneBlendOperation -> IO ()
glSetSeparateSceneBlending sourceFactor destFactor sourceFactorAlpha destFactorAlpha op alphaOp = do
    case sourceFactor == SBF_ONE && destFactor == SBF_ZERO &&
            sourceFactorAlpha == SBF_ONE && destFactorAlpha == SBF_ZERO of
        True  -> glDisable gl_BLEND
        False -> do
          let f = getBlendMode
          glEnable gl_BLEND
          glBlendFuncSeparate (f sourceFactor)  (f sourceFactorAlpha) (f destFactor) (f destFactorAlpha)
    glBlendEquationSeparate (getBlendEquation op) (getBlendEquation alphaOp)

glSetPointParameters :: (RenderSystem rs vb ib q t p lp) => rs -> FloatType  -> Bool -> FloatType -> FloatType -> FloatType -> FloatType -> FloatType -> IO ()
glSetPointParameters rs size attenuationEnabled constant linear quadratic minSize maxSize = do
    let rsc     = getCapabilities rs
        caps    = rscCapabilities rsc
        f = realToFrac
    (size',_minSize',_maxSize',val') <- case attenuationEnabled of
        True  -> do
            when (Set.member RSC_VERTEX_PROGRAM caps) $
                glEnable gl_VERTEX_PROGRAM_POINT_SIZE
            let correction = 0.005
            return (size,minSize,if maxSize == 0 then rscMaxPointSize rsc else maxSize,[f $ constant,f $ linear * correction,f $ quadratic * correction,1])
        False -> do
            when (Set.member RSC_VERTEX_PROGRAM caps) $
                glDisable gl_VERTEX_PROGRAM_POINT_SIZE
            return (size,minSize,if maxSize == 0 then rscMaxPointSize rsc else maxSize,[1,0,0,1])
    --no scaling required
    -- GL has no disabled flag for this so just set to constant
    glPointSize $ f size'
    withArray val' $ \val -> case Set.member RSC_POINT_EXTENDED_PARAMETERS caps of
        True    -> do
            glPointParameterfv Compat.gl_POINT_DISTANCE_ATTENUATION val
            glPointParameterf Compat.gl_POINT_SIZE_MIN $ f minSize
            glPointParameterf Compat.gl_POINT_SIZE_MAX $ f maxSize
        False   -> case Set.member RSC_POINT_EXTENDED_PARAMETERS_ARB caps of
            True    -> do
                ARB.glPointParameterfv Compat.gl_POINT_DISTANCE_ATTENUATION val
                ARB.glPointParameterf Compat.gl_POINT_SIZE_MIN $ f minSize
                ARB.glPointParameterf Compat.gl_POINT_SIZE_MAX $ f maxSize
            False   -> case Set.member RSC_POINT_EXTENDED_PARAMETERS_EXT caps of
                True    -> do
                    EXT.glPointParameterfv Compat.gl_POINT_DISTANCE_ATTENUATION val
                    EXT.glPointParameterf Compat.gl_POINT_SIZE_MIN $ f minSize
                    EXT.glPointParameterf Compat.gl_POINT_SIZE_MAX $ f maxSize
                False   -> return ()

glSetActiveTextureUnit :: Int -> IO ()
glSetActiveTextureUnit stage = do
    let f = fromIntegral
    glActiveTexture $ fromIntegral $ gl_TEXTURE0 + f stage

glSetTexture :: Maybe GLTexture -> IO ()
glSetTexture tex = do
    glDisable gl_TEXTURE_1D
    glBindTexture gl_TEXTURE_1D 0

    glDisable gl_TEXTURE_2D
    glBindTexture gl_TEXTURE_2D 0

    glDisable gl_TEXTURE_3D
    glBindTexture gl_TEXTURE_3D 0

    glDisable gl_TEXTURE_CUBE_MAP
    glBindTexture gl_TEXTURE_CUBE_MAP 0
    case tex of
        Just t    -> do
            --TEMP CODE
            let target = getGLTextureTarget $ txTextureType t
            glEnable target
            glBindTexture target $ gltxTextureObject t
        Nothing   -> return ()
            --TODO

glUseLights :: GLRenderSystem -> [(Proj4,Light)] -> IO ()
glUseLights rs lights = do
    viewMat <- readIORef $ glrsViewMatrix rs
    worldMat <- readIORef $ glrsWorldMatrix rs
    st@GLState { stLight } <- readIORef $ glrsState rs
    when (stLight /= (worldMat, lights)) $ do
        writeIORef (glrsState rs) $ st { stLight = (worldMat,lights) }
        glSetupMatrix viewMat idmtx

        -- disable unused lights
        forM_ [length lights..7] $ \i -> glDisable $ Compat.gl_LIGHT0 + fromIntegral i

        forM_ (zip [0..] $ take 8 lights) $ \(i,(mt,lt)) -> do
            let gl_index = Compat.gl_LIGHT0 + i
                rad2deg = 180 / pi
                f = realToFrac
                c (r,g,b,a) = [f r, f g, f b, f a]
                pos1 = _4 $ fromProjective mt
                --pos0 = extendZero $ (trim pos1 :: Vec3) :: Vec4

            case lgType lt of
                LT_SPOTLIGHT    -> do
                    Compat.glLightf gl_index Compat.gl_SPOT_CUTOFF $ realToFrac $ 0.5 * rad2deg * lgSpotOuter lt
                    Compat.glLightf gl_index Compat.gl_SPOT_EXPONENT $ realToFrac $ lgSpotFalloff lt
                _ -> Compat.glLightf gl_index Compat.gl_SPOT_CUTOFF 180

            withArray (c $ lgDiffuse lt) $ \p ->
                Compat.glLightfv gl_index Compat.gl_DIFFUSE p

            withArray (c $ lgSpecular lt) $ \p ->
                Compat.glLightfv gl_index Compat.gl_SPECULAR p

            -- Disable ambient light for movables
            withArray [0,0,0,1] $ \p ->
                Compat.glLightfv gl_index Compat.gl_AMBIENT p

            -- Set position / direction
            let pos = if lgType lt == LT_DIRECTIONAL then neg dir4 else pos1
                dir4 = (extendZero $ lgDirection lt :: Vec4) .* (fromProjective mt)
            --putStrLn $ show (lgType lt) ++ " glPos: " ++ show pos
            --putStrLn $ " glMat: " ++ show mt
            with pos $ \p ->
                Compat.glLightfv gl_index Compat.gl_POSITION $ castPtr p

            -- Set spotlight direction
            when (lgType lt == LT_SPOTLIGHT) $ with dir4 $ \p ->
                Compat.glLightfv gl_index Compat.gl_SPOT_DIRECTION $ castPtr p

            -- Attenuation
            Compat.glLightf gl_index Compat.gl_CONSTANT_ATTENUATION $ realToFrac $ lgAttenuationConst lt
            Compat.glLightf gl_index Compat.gl_LINEAR_ATTENUATION $ realToFrac $ lgAttenuationLinear lt
            Compat.glLightf gl_index Compat.gl_QUADRATIC_ATTENUATION $ realToFrac $ lgAttenuationQuad lt
            -- Enable in the scene
            --putStrLn $ "setup light " ++ show i ++ " pos: " ++ show pos
            glEnable gl_index
        glSetupMatrix viewMat worldMat

glSetTextureAddressingMode :: TextureType -> UVWAddressingMode -> IO ()
glSetTextureAddressingMode texTarget (UVWAddressingMode u v w) = do
    let target = getGLTextureTarget texTarget
    glTexParameteri target gl_TEXTURE_WRAP_S $ fromIntegral $ getTextureAddressingMode u
    glTexParameteri target gl_TEXTURE_WRAP_T $ fromIntegral $ getTextureAddressingMode v
    glTexParameteri target gl_TEXTURE_WRAP_R $ fromIntegral $ getTextureAddressingMode w

glSetTextureBorderColour :: TextureType -> FloatType4 -> IO ()
glSetTextureBorderColour texTarget (r,g,b,a) = withArray [r,g,b,a] $ \p -> do
    let target = getGLTextureTarget texTarget
    glTexParameterfv target gl_TEXTURE_BORDER_COLOR $ castPtr p

glSetTextureUnitFiltering :: TextureType  -> FilterOptions  -> FilterOptions -> FilterOptions -> IO ()
glSetTextureUnitFiltering texTarget minFilter magFilter mipFilter = do
    let target  = getGLTextureTarget texTarget
        mag     = case magFilter of
            FO_ANISOTROPIC    -> gl_LINEAR
            FO_LINEAR         -> gl_LINEAR
            FO_POINT          -> gl_NEAREST
            FO_NONE           -> gl_NEAREST
        min'    = case minFilter of
            FO_ANISOTROPIC    -> FO_LINEAR
            FO_LINEAR         -> FO_LINEAR
            FO_POINT          -> FO_POINT
            FO_NONE           -> FO_POINT
        mip     = case mipFilter of
            FO_ANISOTROPIC    -> Just FO_LINEAR
            FO_LINEAR         -> Just FO_LINEAR
            FO_POINT          -> Just FO_POINT
            FO_NONE           -> Nothing
        min'' = case (min',mip) of
            (FO_POINT,    Nothing)        -> gl_NEAREST
            (FO_LINEAR,   Nothing)        -> gl_LINEAR
            (FO_POINT,    Just FO_POINT)  -> gl_NEAREST_MIPMAP_NEAREST
            (FO_LINEAR,   Just FO_POINT)  -> gl_LINEAR_MIPMAP_NEAREST
            (FO_POINT,    Just FO_LINEAR) -> gl_NEAREST_MIPMAP_LINEAR
            (FO_LINEAR,   Just FO_LINEAR) -> gl_LINEAR_MIPMAP_LINEAR
            _                             -> error "glSetTextureUnitFiltering"
    glTexParameteri target gl_TEXTURE_MAG_FILTER $ fromIntegral mag
    glTexParameteri target gl_TEXTURE_MIN_FILTER $ fromIntegral min''

glSetTextureLayerAnisotropy :: TextureType -> Int -> IO ()
glSetTextureLayerAnisotropy texTarget maxAnisotropy = do
    largest_supported_anisotropy <- alloca $ \p-> do
        glGetFloatv EXT.gl_MAX_TEXTURE_MAX_ANISOTROPY p
        peek p
    let target = getGLTextureTarget texTarget
        maxAnisotropy' = if fromIntegral maxAnisotropy > largest_supported_anisotropy then largest_supported_anisotropy else fromIntegral maxAnisotropy
    glTexParameterf target EXT.gl_TEXTURE_MAX_ANISOTROPY maxAnisotropy'

glSetTextureMipmapBias :: FloatType -> IO ()
glSetTextureMipmapBias bias = do
    Compat.glTexEnvf EXT.gl_TEXTURE_FILTER_CONTROL EXT.gl_TEXTURE_LOD_BIAS $ realToFrac bias

{-
doc: http://www.informit.com/articles/article.aspx?p=770639&seqNum=6
FIXME: Test this code
-}

glSetTextureBlendMode :: RenderSystemCapabilities -> LayerBlendModeEx -> LayerBlendModeEx -> IO ()
glSetTextureBlendMode rsc colorbm alphabm = do
    let caps    = rscCapabilities rsc
        hasDot3 = Set.member RSC_DOT3 caps
        csrc1op = getLayerBlendSource $ lbSource1 colorbm
        csrc2op = getLayerBlendSource $ lbSource2 colorbm
        ccmd    = getTextureCombineFunction hasDot3 $ lbOperation colorbm
        asrc1op = getLayerBlendSource $ lbSource1 alphabm
        asrc2op = getLayerBlendSource $ lbSource2 alphabm
        acmd    = getTextureCombineFunction hasDot3 $ lbOperation alphabm
        f       = realToFrac
        src2Fun m = do
            Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_SOURCE2_RGB m
            Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_SOURCE2_ALPHA m
        cf (r,g,b,a) = [f r, f g, f b, f a]
        alphaCol (r,g,b,_) a = cf (r, g, b, a)

    -- Color blending
    Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_TEXTURE_ENV_MODE $ fromIntegral Compat.gl_COMBINE

    Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_COMBINE_RGB $ fromIntegral ccmd
    Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_SOURCE0_RGB $ fromIntegral csrc1op
    Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_SOURCE1_RGB $ fromIntegral csrc2op
    Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_SOURCE2_RGB $ fromIntegral Compat.gl_CONSTANT

    case lbOperation colorbm of
        LBX_BLEND_DIFFUSE_COLOUR    -> src2Fun $ fromIntegral Compat.gl_PRIMARY_COLOR
        LBX_BLEND_DIFFUSE_ALPHA     -> src2Fun $ fromIntegral Compat.gl_PRIMARY_COLOR
        LBX_BLEND_TEXTURE_ALPHA     -> src2Fun $ fromIntegral gl_TEXTURE
        LBX_BLEND_CURRENT_ALPHA     -> src2Fun $ fromIntegral Compat.gl_PREVIOUS
        LBX_BLEND_MANUAL            -> withArray [0, 0, 0, realToFrac $ lbFactor colorbm] $ \p ->
            Compat.glTexEnvfv Compat.gl_TEXTURE_ENV Compat.gl_TEXTURE_ENV_COLOR p
        LBX_MODULATE_X2             -> Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_RGB_SCALE 2
        LBX_MODULATE_X4             -> Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_RGB_SCALE 4
        _                           -> Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_RGB_SCALE 1

    Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND0_RGB $ fromIntegral gl_SRC_COLOR
    Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND1_RGB $ fromIntegral gl_SRC_COLOR
    case lbOperation colorbm of
        LBX_BLEND_DIFFUSE_COLOUR    -> Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND2_RGB $ fromIntegral gl_SRC_COLOR
        _                           -> Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND2_RGB $ fromIntegral gl_SRC_ALPHA

    Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND0_ALPHA $ fromIntegral gl_SRC_ALPHA
    Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND1_ALPHA $ fromIntegral gl_SRC_ALPHA
    Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND2_ALPHA $ fromIntegral gl_SRC_ALPHA
    when (lbSource1 colorbm == LBS_MANUAL) $ withArray (cf $ lbColourArg1 colorbm) $ \p -> Compat.glTexEnvfv Compat.gl_TEXTURE_ENV Compat.gl_TEXTURE_ENV_COLOR p
    when (lbSource2 colorbm == LBS_MANUAL) $ withArray (cf $ lbColourArg2 colorbm) $ \p -> Compat.glTexEnvfv Compat.gl_TEXTURE_ENV Compat.gl_TEXTURE_ENV_COLOR p

    -- Alpha blending
    Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_TEXTURE_ENV_MODE $ fromIntegral Compat.gl_COMBINE

    Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_COMBINE_ALPHA $ fromIntegral acmd
    Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_SOURCE0_ALPHA $ fromIntegral asrc1op
    Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_SOURCE1_ALPHA $ fromIntegral asrc2op
    Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_SOURCE2_ALPHA $ fromIntegral Compat.gl_CONSTANT

    case lbOperation alphabm of
        LBX_BLEND_DIFFUSE_COLOUR    -> src2Fun $ fromIntegral Compat.gl_PRIMARY_COLOR
        LBX_BLEND_DIFFUSE_ALPHA     -> src2Fun $ fromIntegral Compat.gl_PRIMARY_COLOR
        LBX_BLEND_TEXTURE_ALPHA     -> src2Fun $ fromIntegral gl_TEXTURE
        LBX_BLEND_CURRENT_ALPHA     -> src2Fun $ fromIntegral Compat.gl_PREVIOUS
        LBX_BLEND_MANUAL            -> withArray [0, 0, 0, realToFrac $ lbFactor alphabm] $ \p ->
            Compat.glTexEnvfv Compat.gl_TEXTURE_ENV Compat.gl_TEXTURE_ENV_COLOR p
        LBX_MODULATE_X2             -> Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_ALPHA_SCALE 2
        LBX_MODULATE_X4             -> Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_ALPHA_SCALE 4
        _                           -> Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_ALPHA_SCALE 1

    Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND0_ALPHA $ fromIntegral gl_SRC_ALPHA
    Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND1_ALPHA $ fromIntegral gl_SRC_ALPHA
    Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND2_ALPHA $ fromIntegral gl_SRC_ALPHA
    when (lbSource1 alphabm == LBS_MANUAL) $ withArray (alphaCol (lbColourArg1 colorbm) (lbAlphaArg1 alphabm)) $ \p -> Compat.glTexEnvfv Compat.gl_TEXTURE_ENV Compat.gl_TEXTURE_ENV_COLOR p
    when (lbSource2 alphabm == LBS_MANUAL) $ withArray (alphaCol (lbColourArg2 colorbm) (lbAlphaArg2 alphabm)) $ \p -> Compat.glTexEnvfv Compat.gl_TEXTURE_ENV Compat.gl_TEXTURE_ENV_COLOR p

glSetCullingMode :: CullingMode -> IO ()
glSetCullingMode mode = case mode of
    CULL_NONE             -> glDisable gl_CULL_FACE
    CULL_CLOCKWISE        -> glEnable gl_CULL_FACE >> glCullFace gl_BACK
    CULL_ANTICLOCKWISE    -> glEnable gl_CULL_FACE >> glCullFace gl_FRONT

glSetColourBufferWriteEnabled :: Bool -> Bool -> Bool -> Bool -> IO ()
glSetColourBufferWriteEnabled r g b a = do
    let f = fromBool
    glColorMask (f r) (f g) (f b) (f a)

glBindLinkedGpuProgram :: GLLinkedGpuProgram -> IO ()
glBindLinkedGpuProgram lp = do
    let p = gllgpProgramObject lp
        withGLString :: String -> (Ptr GLchar -> IO a) -> IO a
        withGLString s act = withCAString s $ act . castPtr
    glUseProgram p
    --TEMP CODE

    loc_tex0 <- withGLString "tex0" $ glGetUniformLocation p
    loc_tex1 <- withGLString "tex1" $ glGetUniformLocation p
    glUniform1i loc_tex0 0
    glUniform1i loc_tex1 1

glUnBindLinkedGpuProgram :: IO ()
glUnBindLinkedGpuProgram = glUseProgram 0

glSetTextureMatrix :: Proj4 -> IO ()
glSetTextureMatrix xform = do
    Compat.glMatrixMode gl_TEXTURE
    with xform $ \p -> do
        Compat.glLoadMatrixf $ castPtr p

glSetTextureCoordCalculation :: TexCoordCalcMethod -> IO ()
glSetTextureCoordCalculation m = case m of
    TEXCALC_NONE -> do
        glDisable Compat.gl_TEXTURE_GEN_S
        glDisable Compat.gl_TEXTURE_GEN_T
        glDisable Compat.gl_TEXTURE_GEN_R
        glDisable Compat.gl_TEXTURE_GEN_Q

    TEXCALC_ENVIRONMENT_MAP   -> do
        Compat.glTexGeni Compat.gl_S Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_SPHERE_MAP
        Compat.glTexGeni Compat.gl_T Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_SPHERE_MAP

        glEnable Compat.gl_TEXTURE_GEN_S
        glEnable Compat.gl_TEXTURE_GEN_T
        glDisable Compat.gl_TEXTURE_GEN_R
        glDisable Compat.gl_TEXTURE_GEN_Q

    TEXCALC_ENVIRONMENT_MAP_PLANAR -> do
        Compat.glTexGeni Compat.gl_S Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_SPHERE_MAP
        Compat.glTexGeni Compat.gl_T Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_SPHERE_MAP

        glEnable Compat.gl_TEXTURE_GEN_S
        glEnable Compat.gl_TEXTURE_GEN_T
        glDisable Compat.gl_TEXTURE_GEN_R
        glDisable Compat.gl_TEXTURE_GEN_Q

    TEXCALC_ENVIRONMENT_MAP_REFLECTION -> do
        Compat.glTexGeni Compat.gl_S Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_REFLECTION_MAP
        Compat.glTexGeni Compat.gl_T Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_REFLECTION_MAP
        Compat.glTexGeni Compat.gl_R Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_REFLECTION_MAP

        glEnable Compat.gl_TEXTURE_GEN_S
        glEnable Compat.gl_TEXTURE_GEN_T
        glEnable Compat.gl_TEXTURE_GEN_R
        glDisable Compat.gl_TEXTURE_GEN_Q

    TEXCALC_ENVIRONMENT_MAP_NORMAL -> do
        Compat.glTexGeni Compat.gl_S Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_NORMAL_MAP
        Compat.glTexGeni Compat.gl_T Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_NORMAL_MAP
        Compat.glTexGeni Compat.gl_R Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_NORMAL_MAP
        glEnable Compat.gl_TEXTURE_GEN_S
        glEnable Compat.gl_TEXTURE_GEN_T
        glEnable Compat.gl_TEXTURE_GEN_R
        glDisable Compat.gl_TEXTURE_GEN_Q

    TEXCALC_PROJECTIVE_TEXTURE -> do
        Compat.glTexGeni Compat.gl_S Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_EYE_LINEAR
        Compat.glTexGeni Compat.gl_T Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_EYE_LINEAR
        Compat.glTexGeni Compat.gl_R Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_EYE_LINEAR
        Compat.glTexGeni Compat.gl_Q Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_EYE_LINEAR
        withArray [1, 0, 0, 0] $ \p -> Compat.glTexGenfv Compat.gl_S Compat.gl_EYE_PLANE p
        withArray [0, 1, 0, 0] $ \p -> Compat.glTexGenfv Compat.gl_T Compat.gl_EYE_PLANE p
        withArray [0, 0, 1, 0] $ \p -> Compat.glTexGenfv Compat.gl_R Compat.gl_EYE_PLANE p
        withArray [0, 0, 0, 1] $ \p -> Compat.glTexGenfv Compat.gl_Q Compat.gl_EYE_PLANE p
        glEnable Compat.gl_TEXTURE_GEN_S
        glEnable Compat.gl_TEXTURE_GEN_T
        glEnable Compat.gl_TEXTURE_GEN_R
        glEnable Compat.gl_TEXTURE_GEN_Q