    --------------------------------------------------------------------------------
    -- |
    -- Module      :  Graphics.Rendering.OpenGL.GL.PerFragment
    -- Copyright   :  (c) Sven Panne 2002-2009
    -- License     :  BSD-style (see the file libraries/OpenGL/LICENSE)
    --
    -- Maintainer  :  sven.panne@aedion.de
    -- Stability   :  stable
    -- Portability :  portable
    --
    -- This module corresponds to section 4.1 (Per-Fragment Operations) of the
    -- OpenGL 2.1 specs.
    --
    --------------------------------------------------------------------------------

    module Graphics.Rendering.OpenGL.GL.PerFragment (
       -- * Scissor Test
       scissor,

       -- * Multisample Fragment Operations
       sampleAlphaToCoverage,  sampleAlphaToOne, sampleCoverage,

       -- * Depth Bounds Test
       depthBounds,

       -- * Alpha Test
       ComparisonFunction(..), alphaFunc,

       -- * Stencil Test
       stencilTest, stencilFunc, stencilFuncSeparate, StencilOp(..), stencilOp,
       stencilOpSeparate, activeStencilFace,

       -- * Depth Buffer Test
       depthFunc,

       -- * Occlusion Queries
       QueryObject(QueryObject), QueryTarget(..), withQuery,
       beginQuery, endQuery,
       queryCounterBits, currentQuery,
       queryResult, queryResultAvailable,

       -- * Blending
       blend, BlendEquation(..), blendEquation, blendEquationSeparate,
       BlendingFactor(..), blendFuncSeparate, blendFunc, blendColor,

       -- * Dithering
       dither,

       -- * Logical Operation
       LogicOp(..), logicOp
    ) where

    import Control.Monad
    import Data.ObjectName
    import Data.StateVar
    import Foreign.Marshal.Alloc
    import Foreign.Marshal.Array
    import Graphics.Rendering.OpenGL.GL.BlendingFactor
    import Graphics.Rendering.OpenGL.GL.Capability
    import Graphics.Rendering.OpenGL.GL.ComparisonFunction
    import Graphics.Rendering.OpenGL.GL.CoordTrans
    import Graphics.Rendering.OpenGL.GL.Exception
    import Graphics.Rendering.OpenGL.GL.Face
    import Graphics.Rendering.OpenGL.GL.GLboolean
    import Graphics.Rendering.OpenGL.GL.PeekPoke
    import Graphics.Rendering.OpenGL.GL.QueryUtils
    import Graphics.Rendering.OpenGL.GL.VertexSpec
    import Graphics.Rendering.OpenGL.Raw.ARB.Compatibility (
       glAlphaFunc, gl_INDEX_LOGIC_OP )
    import Graphics.Rendering.OpenGL.Raw.Core31
    import Graphics.Rendering.OpenGL.Raw.EXT.DepthBoundsTest ( glDepthBounds )
    import Graphics.Rendering.OpenGL.Raw.EXT.StencilTwoSide ( glActiveStencilFace )

    --------------------------------------------------------------------------------

    scissor :: StateVar (Maybe (Position, Size))
    scissor =
       makeStateVarMaybe
          (return CapScissorTest)
          (getInteger4 makeSB GetScissorBox)
          (\(Position x y, Size w h) -> glScissor x y w h)
       where makeSB x y w h = (Position x y, Size (fromIntegral w) (fromIntegral h))

    --------------------------------------------------------------------------------

    sampleAlphaToCoverage :: StateVar Capability
    sampleAlphaToCoverage = makeCapability CapSampleAlphaToCoverage

    sampleAlphaToOne :: StateVar Capability
    sampleAlphaToOne = makeCapability CapSampleAlphaToOne

    sampleCoverage :: StateVar (Maybe (GLclampf, Bool))
    sampleCoverage =
       makeStateVarMaybe
          (return CapSampleCoverage)
          (liftM2 (,) (getClampf1 id GetSampleCoverageValue)
                      (getBoolean1 unmarshalGLboolean GetSampleCoverageInvert))
          (\(value, invert) -> glSampleCoverage value (marshalGLboolean invert))

    --------------------------------------------------------------------------------

    depthBounds :: StateVar (Maybe (GLclampd, GLclampd))
    depthBounds =
       makeStateVarMaybe
          (return CapDepthBoundsTest)
          (getClampd2 (,) GetDepthBounds)
          (uncurry glDepthBounds)

    --------------------------------------------------------------------------------

    alphaFunc :: StateVar (Maybe (ComparisonFunction, GLclampf))
    alphaFunc =
       makeStateVarMaybe
          (return CapAlphaTest)
          (liftM2 (,) (getEnum1 unmarshalComparisonFunction GetAlphaTestFunc)
                      (getClampf1 id GetAlphaTestRef))
          (uncurry (glAlphaFunc . marshalComparisonFunction))

    --------------------------------------------------------------------------------

    stencilTest :: StateVar Capability
    stencilTest = makeCapability CapStencilTest

    --------------------------------------------------------------------------------

    stencilFunc :: StateVar (ComparisonFunction, GLint, GLuint)
    stencilFunc =
       makeStateVar
          (liftM3 (,,) (getEnum1 unmarshalComparisonFunction GetStencilFunc)
                       (getInteger1 id GetStencilRef)
                       (getInteger1 fromIntegral GetStencilValueMask))
          (\(func, ref, mask) ->
             glStencilFunc (marshalComparisonFunction func) ref mask)

    stencilFuncSeparate :: Face -> SettableStateVar (ComparisonFunction, GLint, GLuint)
    stencilFuncSeparate face =
       makeSettableStateVar $ \(func, ref, mask) ->
          glStencilFuncSeparate (marshalFace face) (marshalComparisonFunction func) ref mask

    --------------------------------------------------------------------------------

    data StencilOp =
         OpZero
       | OpKeep
       | OpReplace
       | OpIncr
       | OpIncrWrap
       | OpDecr
       | OpDecrWrap
       | OpInvert
       deriving ( Eq, Ord, Show )

    marshalStencilOp :: StencilOp -> GLenum
    marshalStencilOp x = case x of
       OpZero -> gl_ZERO
       OpKeep -> gl_KEEP
       OpReplace -> gl_REPLACE
       OpIncr -> gl_INCR
       OpIncrWrap -> gl_INCR_WRAP
       OpDecr -> gl_DECR
       OpDecrWrap -> gl_DECR_WRAP
       OpInvert -> gl_INVERT

    unmarshalStencilOp :: GLenum -> StencilOp
    unmarshalStencilOp x
       | x == gl_ZERO = OpZero
       | x == gl_KEEP = OpKeep
       | x == gl_REPLACE = OpReplace
       | x == gl_INCR = OpIncr
       | x == gl_INCR_WRAP = OpIncrWrap
       | x == gl_DECR = OpDecr
       | x == gl_DECR_WRAP = OpDecrWrap
       | x == gl_INVERT = OpInvert
       | otherwise = error ("unmarshalStencilOp: illegal value " ++ show x)

    --------------------------------------------------------------------------------

    stencilOp :: StateVar (StencilOp, StencilOp, StencilOp)
    stencilOp =
       makeStateVar
          (liftM3 (,,) (getEnum1 unmarshalStencilOp GetStencilFail)
                       (getEnum1 unmarshalStencilOp GetStencilPassDepthFail)
                       (getEnum1 unmarshalStencilOp GetStencilPassDepthPass))
          (\(sf, spdf, spdp) -> glStencilOp (marshalStencilOp sf)
                                            (marshalStencilOp spdf)
                                            (marshalStencilOp spdp))

    stencilOpSeparate :: Face -> SettableStateVar (StencilOp, StencilOp, StencilOp)
    stencilOpSeparate face =
       makeSettableStateVar $ \(sf, spdf, spdp) ->
          glStencilOpSeparate (marshalFace face)
                              (marshalStencilOp sf)
                              (marshalStencilOp spdf)
                              (marshalStencilOp spdp)

    --------------------------------------------------------------------------------

    activeStencilFace :: StateVar (Maybe Face)
    activeStencilFace =
       makeStateVarMaybe
          (return CapStencilTestTwoSide)
          (getEnum1 unmarshalFace GetActiveStencilFace)
          (glActiveStencilFace . marshalFace)

    --------------------------------------------------------------------------------

    depthFunc :: StateVar (Maybe ComparisonFunction)
    depthFunc =
       makeStateVarMaybe
          (return CapDepthTest)
          (getEnum1 unmarshalComparisonFunction GetDepthFunc)
          (glDepthFunc . marshalComparisonFunction)

    --------------------------------------------------------------------------------

    newtype QueryObject = QueryObject { queryID :: GLuint }
       deriving ( Eq, Ord, Show )

    --------------------------------------------------------------------------------

    instance ObjectName QueryObject where
       genObjectNames n =
          allocaArray n $ \buf -> do
            glGenQueries (fromIntegral n) buf
            fmap (map QueryObject) $ peekArray n buf

       deleteObjectNames queryObjects =
          withArrayLen (map queryID queryObjects) $
             glDeleteQueries . fromIntegral

       isObjectName = fmap unmarshalGLboolean . glIsQuery . queryID

    --------------------------------------------------------------------------------

    data QueryTarget =
         SamplesPassed
       deriving ( Eq, Ord, Show )

    marshalQueryTarget :: QueryTarget -> GLenum
    marshalQueryTarget x = case x of
       SamplesPassed -> gl_SAMPLES_PASSED

    --------------------------------------------------------------------------------

    beginQuery :: QueryTarget -> QueryObject -> IO ()
    beginQuery t = glBeginQuery (marshalQueryTarget t) . queryID

    endQuery :: QueryTarget -> IO ()
    endQuery = glEndQuery . marshalQueryTarget

    -- | Convenience function for an exception-safe combination of 'beginQuery' and
    -- 'endQuery'.
    withQuery :: QueryTarget -> QueryObject -> IO a -> IO a
    withQuery t q = bracket_ (beginQuery t q) (endQuery t)

    --------------------------------------------------------------------------------

    data GetQueryPName =
         QueryCounterBits
       | CurrentQuery

    marshalGetQueryPName :: GetQueryPName -> GLenum
    marshalGetQueryPName x = case x of
       QueryCounterBits -> gl_QUERY_COUNTER_BITS
       CurrentQuery -> gl_CURRENT_QUERY

    --------------------------------------------------------------------------------

    queryCounterBits :: QueryTarget -> GettableStateVar GLsizei
    queryCounterBits = getQueryi fromIntegral QueryCounterBits

    currentQuery :: QueryTarget -> GettableStateVar (Maybe QueryObject)
    currentQuery =
       getQueryi
          (\q -> if q == 0 then Nothing else Just (QueryObject (fromIntegral q)))
          CurrentQuery

    getQueryi :: (GLint -> a) -> GetQueryPName -> QueryTarget -> GettableStateVar a
    getQueryi f p t =
       makeGettableStateVar $
          alloca $ \buf -> do
             glGetQueryiv (marshalQueryTarget t) (marshalGetQueryPName p) buf
             peek1 f buf

    --------------------------------------------------------------------------------

    data GetQueryObjectPName =
         QueryResult
       | QueryResultAvailable

    marshalGetQueryObjectPName :: GetQueryObjectPName -> GLenum
    marshalGetQueryObjectPName x = case x of
       QueryResult -> gl_QUERY_RESULT
       QueryResultAvailable -> gl_QUERY_RESULT_AVAILABLE

    --------------------------------------------------------------------------------

    queryResult :: QueryObject -> GettableStateVar GLuint
    queryResult = getQueryObjectui id QueryResult

    queryResultAvailable :: QueryObject -> GettableStateVar Bool
    queryResultAvailable = getQueryObjectui unmarshalGLboolean QueryResultAvailable

    getQueryObjectui ::
       (GLuint -> a) -> GetQueryObjectPName -> QueryObject -> GettableStateVar a
    getQueryObjectui f p q =
       makeGettableStateVar $
          alloca $ \buf -> do
             glGetQueryObjectuiv (queryID q) (marshalGetQueryObjectPName p) buf
             peek1 f buf

    --------------------------------------------------------------------------------

    blend :: StateVar Capability
    blend = makeCapability CapBlend

    --------------------------------------------------------------------------------

    data BlendEquation =
         FuncAdd
       | FuncSubtract
       | FuncReverseSubtract
       | Min
       | Max
       | LogicOp
       deriving ( Eq, Ord, Show )

    marshalBlendEquation :: BlendEquation -> GLenum
    marshalBlendEquation x = case x of
       FuncAdd -> gl_FUNC_ADD
       FuncSubtract -> gl_FUNC_SUBTRACT
       FuncReverseSubtract -> gl_FUNC_REVERSE_SUBTRACT
       Min -> gl_MIN
       Max -> gl_MAX
       LogicOp -> gl_INDEX_LOGIC_OP

    unmarshalBlendEquation :: GLenum -> BlendEquation
    unmarshalBlendEquation x
       | x == gl_FUNC_ADD = FuncAdd
       | x == gl_FUNC_SUBTRACT = FuncSubtract
       | x == gl_FUNC_REVERSE_SUBTRACT = FuncReverseSubtract
       | x == gl_MIN = Min
       | x == gl_MAX = Max
       | x == gl_INDEX_LOGIC_OP = LogicOp
       | otherwise = error ("unmarshalBlendEquation: illegal value " ++ show x)

    --------------------------------------------------------------------------------

    blendEquation :: StateVar BlendEquation
    blendEquation =
       makeStateVar
          (getEnum1 unmarshalBlendEquation GetBlendEquation)
          (glBlendEquation . marshalBlendEquation)

    blendEquationSeparate :: StateVar (BlendEquation,BlendEquation)
    blendEquationSeparate =
       makeStateVar
          (liftM2 (,) (getEnum1 unmarshalBlendEquation GetBlendEquation)
                      (getEnum1 unmarshalBlendEquation GetBlendEquationAlpha))
          (\(funcRGB, funcAlpha) ->
              glBlendEquationSeparate (marshalBlendEquation funcRGB)
                                      (marshalBlendEquation funcAlpha))

    --------------------------------------------------------------------------------

    blendFuncSeparate ::
       StateVar ((BlendingFactor, BlendingFactor), (BlendingFactor, BlendingFactor))
    blendFuncSeparate =
       makeStateVar
          (do srcRGB   <- getEnum1 unmarshalBlendingFactor GetBlendSrcRGB
              srcAlpha <- getEnum1 unmarshalBlendingFactor GetBlendSrcAlpha
              dstRGB   <- getEnum1 unmarshalBlendingFactor GetBlendDstRGB
              dstAlpha <- getEnum1 unmarshalBlendingFactor GetBlendDstAlpha
              return ((srcRGB, srcAlpha), (dstRGB, dstAlpha)))
          (\((srcRGB, srcAlpha), (dstRGB, dstAlpha)) ->
             glBlendFuncSeparate (marshalBlendingFactor srcRGB)
                                 (marshalBlendingFactor srcAlpha)
                                 (marshalBlendingFactor dstRGB)
                                 (marshalBlendingFactor dstAlpha))

    blendFunc :: StateVar (BlendingFactor, BlendingFactor)
    blendFunc =
       makeStateVar
          (liftM2 (,) (getEnum1 unmarshalBlendingFactor GetBlendSrc)
                      (getEnum1 unmarshalBlendingFactor GetBlendDst))
          (\(s, d) ->
             glBlendFunc (marshalBlendingFactor s) (marshalBlendingFactor d))

    blendColor :: StateVar (Color4 GLclampf)
    blendColor =
       makeStateVar
          (getClampf4 Color4 GetBlendColor)
          (\(Color4 r g b a) -> glBlendColor r g b a)

    --------------------------------------------------------------------------------

    dither :: StateVar Capability
    dither = makeCapability CapDither

    --------------------------------------------------------------------------------

    data LogicOp =
         Clear
       | And
       | AndReverse
       | Copy
       | AndInverted
       | Noop
       | Xor
       | Or
       | Nor
       | Equiv
       | Invert
       | OrReverse
       | CopyInverted
       | OrInverted
       | Nand
       | Set
       deriving ( Eq, Ord, Show )

    marshalLogicOp :: LogicOp -> GLenum
    marshalLogicOp x = case x of
       Clear -> gl_CLEAR
       And -> gl_AND
       AndReverse -> gl_AND_REVERSE
       Copy -> gl_COPY
       AndInverted -> gl_AND_INVERTED
       Noop -> gl_NOOP
       Xor -> gl_XOR
       Or -> gl_OR
       Nor -> gl_NOR
       Equiv -> gl_EQUIV
       Invert -> gl_INVERT
       OrReverse -> gl_OR_REVERSE
       CopyInverted -> gl_COPY_INVERTED
       OrInverted -> gl_OR_INVERTED
       Nand -> gl_NAND
       Set -> gl_SET

    unmarshalLogicOp :: GLenum -> LogicOp
    unmarshalLogicOp x
       | x == gl_CLEAR = Clear
       | x == gl_AND = And
       | x == gl_AND_REVERSE = AndReverse
       | x == gl_COPY = Copy
       | x == gl_AND_INVERTED = AndInverted
       | x == gl_NOOP = Noop
       | x == gl_XOR = Xor
       | x == gl_OR = Or
       | x == gl_NOR = Nor
       | x == gl_EQUIV = Equiv
       | x == gl_INVERT = Invert
       | x == gl_OR_REVERSE = OrReverse
       | x == gl_COPY_INVERTED = CopyInverted
       | x == gl_OR_INVERTED = OrInverted
       | x == gl_NAND = Nand
       | x == gl_SET = Set
       | otherwise = error ("unmarshalLogicOp: illegal value " ++ show x)

    --------------------------------------------------------------------------------

    logicOp :: StateVar (Maybe LogicOp)
    logicOp =
       makeStateVarMaybe
          (do rgba <- get rgbaMode
              return $ if rgba then CapColorLogicOp else CapIndexLogicOp)
          (getEnum1 unmarshalLogicOp GetLogicOpMode)
          (glLogicOp . marshalLogicOp)