    --------------------------------------------------------------------------------
    -- |
    -- Module      :  Graphics.Rendering.OpenGL.GLU.NURBS
    -- Copyright   :  (c) Sven Panne 2002-2006
    -- License     :  BSD-style (see the file libraries/OpenGL/LICENSE)
    --
    -- Maintainer  :  sven.panne@aedion.de
    -- Stability   :  stable
    -- Portability :  portable
    --
    -- This module corresponds to chapter 7 (NURBS) of the GLU specs.
    --
    --------------------------------------------------------------------------------

    module Graphics.Rendering.OpenGL.GLU.NURBS (
       NURBSObj, withNURBSObj,
       NURBSBeginCallback, withNURBSBeginCallback,
       NURBSVertexCallback, withNURBSVertexCallback,
       NURBSNormalCallback, withNURBSNormalCallback,
       NURBSColorCallback, withNURBSColorCallback,
       NURBSEndCallback, withNURBSEndCallback,
       checkForNURBSError,
       nurbsBeginEndCurve, nurbsCurve,
       nurbsBeginEndSurface, nurbsSurface,
       TrimmingPoint, nurbsBeginEndTrim, pwlCurve, trimmingCurve,
       NURBSMode(..), setNURBSMode,
       setNURBSCulling,
       SamplingMethod(..), setSamplingMethod,
       loadSamplingMatrices,
       DisplayMode'(..), setDisplayMode'
    ) where

    import Control.Monad ( unless )
    import Foreign.Marshal.Array ( withArray )
    import Foreign.Ptr ( Ptr, nullPtr, castPtr, FunPtr, freeHaskellFunPtr )
    import Foreign.Storable ( Storable(..) )
    import Graphics.Rendering.OpenGL.GL.BasicTypes (
       GLenum, GLint, GLfloat, Capability )
    import Graphics.Rendering.OpenGL.GL.Capability ( marshalCapability )
    import Graphics.Rendering.OpenGL.GL.ControlPoint
    import Graphics.Rendering.OpenGL.GL.CoordTrans (
       Position(..), Size(..), MatrixOrder(ColumnMajor), MatrixComponent, Matrix(..) )
    import Graphics.Rendering.OpenGL.GL.Exception ( bracket, bracket_ )
    import Graphics.Rendering.OpenGL.GL.GLboolean ( marshalGLboolean )
    import Graphics.Rendering.OpenGL.GL.PrimitiveMode ( unmarshalPrimitiveMode )
    import Graphics.Rendering.OpenGL.GL.BeginEnd ( PrimitiveMode )
    import Graphics.Rendering.OpenGL.GL.VertexSpec (
       Vertex2, Vertex3, Normal3, Color4 )
    import Graphics.Rendering.OpenGL.GLU.ErrorsInternal (
       recordErrorCode, recordOutOfMemory )

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

    data NURBSCallback =
         Error
       | Begin
       | Vertex
       | Normal
       | Color
       | TextureCoord
       | End
       | BeginData
       | VertexData
       | NormalData
       | ColorData
       | TextureCoordData
       | EndData

    marshalNURBSCallback :: NURBSCallback -> GLenum
    marshalNURBSCallback x = case x of
       Error -> 100103
       Begin -> 100164
       Vertex -> 100165
       Normal -> 100166
       Color -> 100167
       TextureCoord -> 100168
       End -> 100169
       BeginData -> 100170
       VertexData -> 100171
       NormalData -> 100172
       ColorData -> 100173
       TextureCoordData -> 100174
       EndData -> 100175

    --------------------------------------------------------------------------------
    -- chapter 7.1: The NURBS Object

    -- an opaque pointer to a NURBS object
    newtype NURBSObj = NURBSObj (Ptr NURBSObj)

    isNullNURBSObj :: NURBSObj -> Bool
    isNullNURBSObj (NURBSObj ptr) = ptr == nullPtr

    withNURBSObj :: a -> (NURBSObj -> IO a) -> IO a
    withNURBSObj failureValue action =
       bracket gluNewNurbsRenderer safeDeleteNurbsRenderer
               (\nurbsObj -> if isNullNURBSObj nurbsObj
                                then do recordOutOfMemory
                                        return failureValue
                                else action nurbsObj)

    foreign import CALLCONV safe "gluNewNurbsRenderer"
       gluNewNurbsRenderer :: IO NURBSObj

    safeDeleteNurbsRenderer :: NURBSObj -> IO ()
    safeDeleteNurbsRenderer nurbsObj =
       unless (isNullNURBSObj nurbsObj) $ gluDeleteNurbsRenderer nurbsObj

    foreign import CALLCONV safe "gluDeleteNurbsRenderer"
       gluDeleteNurbsRenderer :: NURBSObj -> IO ()

    --------------------------------------------------------------------------------
    -- chapter 7.2: Callbacks (begin)

    type NURBSBeginCallback = PrimitiveMode -> IO ()

    type BeginCallback' = GLenum -> IO ()

    withNURBSBeginCallback :: NURBSObj -> NURBSBeginCallback -> IO a -> IO a
    withNURBSBeginCallback nurbsObj beginCallback action =
       bracket (makeBeginCallback (beginCallback . unmarshalPrimitiveMode))
               freeHaskellFunPtr $ \callbackPtr -> do
          setBeginCallback nurbsObj (marshalNURBSCallback Begin) callbackPtr
          action

    foreign import CALLCONV "wrapper" makeBeginCallback ::
       BeginCallback' -> IO (FunPtr BeginCallback')

    foreign import CALLCONV safe "gluNurbsCallback"
       setBeginCallback :: NURBSObj -> GLenum -> FunPtr BeginCallback' -> IO ()

    --------------------------------------------------------------------------------
    -- chapter 7.2: Callbacks (vertex)

    type NURBSVertexCallback = Vertex3 GLfloat -> IO ()

    type VertexCallback' = Ptr (Vertex3 GLfloat) -> IO ()

    withNURBSVertexCallback :: NURBSObj -> NURBSVertexCallback -> IO a -> IO a
    withNURBSVertexCallback nurbsObj vertexCallback action =
       bracket (makeVertexCallback (\p -> peek p >>= vertexCallback))
               freeHaskellFunPtr $ \callbackPtr -> do
          setVertexCallback nurbsObj (marshalNURBSCallback Vertex) callbackPtr
          action

    foreign import CALLCONV "wrapper" makeVertexCallback ::
       VertexCallback' -> IO (FunPtr VertexCallback')

    foreign import CALLCONV safe "gluNurbsCallback"
       setVertexCallback :: NURBSObj -> GLenum -> FunPtr VertexCallback' -> IO ()

    --------------------------------------------------------------------------------
    -- chapter 7.2: Callbacks (normal)

    type NURBSNormalCallback = Normal3 GLfloat -> IO ()

    type NormalCallback' = Ptr (Normal3 GLfloat) -> IO ()

    withNURBSNormalCallback :: NURBSObj -> NURBSNormalCallback -> IO a -> IO a
    withNURBSNormalCallback nurbsObj normalCallback action =
       bracket (makeNormalCallback (\p -> peek p >>= normalCallback))
               freeHaskellFunPtr $ \callbackPtr -> do
          setNormalCallback nurbsObj (marshalNURBSCallback Normal) callbackPtr
          action

    foreign import CALLCONV "wrapper" makeNormalCallback ::
       NormalCallback' -> IO (FunPtr NormalCallback')

    foreign import CALLCONV safe "gluNurbsCallback"
       setNormalCallback :: NURBSObj -> GLenum -> FunPtr NormalCallback' -> IO ()

    --------------------------------------------------------------------------------
    -- chapter 7.2: Callbacks (color)

    type NURBSColorCallback = Color4 GLfloat -> IO ()

    type ColorCallback' = Ptr (Color4 GLfloat) -> IO ()

    withNURBSColorCallback :: NURBSObj -> NURBSColorCallback -> IO a -> IO a
    withNURBSColorCallback nurbsObj colorCallback action =
       bracket (makeColorCallback (\p -> peek p >>= colorCallback))
               freeHaskellFunPtr $ \callbackPtr -> do
          setColorCallback nurbsObj (marshalNURBSCallback Color) callbackPtr
          action

    foreign import CALLCONV "wrapper" makeColorCallback ::
       ColorCallback' -> IO (FunPtr ColorCallback')

    foreign import CALLCONV safe "gluNurbsCallback"
       setColorCallback :: NURBSObj -> GLenum -> FunPtr ColorCallback' -> IO ()

    --------------------------------------------------------------------------------
    -- chapter 7.2: Callbacks (end)

    type NURBSEndCallback = IO ()

    withNURBSEndCallback :: NURBSObj -> NURBSEndCallback -> IO a -> IO a
    withNURBSEndCallback nurbsObj endCallback action =
       bracket (makeEndCallback endCallback)
               freeHaskellFunPtr $ \callbackPtr -> do
          setEndCallback nurbsObj (marshalNURBSCallback End) callbackPtr
          action

    foreign import CALLCONV "wrapper" makeEndCallback ::
       NURBSEndCallback -> IO (FunPtr NURBSEndCallback)

    foreign import CALLCONV safe "gluNurbsCallback"
       setEndCallback :: NURBSObj -> GLenum -> FunPtr NURBSEndCallback -> IO ()

    --------------------------------------------------------------------------------
    -- chapter 7.2: Callbacks (error)

    type ErrorCallback = GLenum -> IO ()

    withErrorCallback :: NURBSObj -> ErrorCallback -> IO a -> IO a
    withErrorCallback nurbsObj errorCallback action =
       bracket (makeErrorCallback errorCallback)
               freeHaskellFunPtr $ \callbackPtr -> do
          setErrorCallback nurbsObj (marshalNURBSCallback Error) callbackPtr
          action

    foreign import CALLCONV "wrapper" makeErrorCallback ::
       ErrorCallback -> IO (FunPtr ErrorCallback)

    foreign import CALLCONV safe "gluNurbsCallback"
       setErrorCallback :: NURBSObj -> GLenum -> FunPtr ErrorCallback -> IO ()

    checkForNURBSError :: NURBSObj -> IO a -> IO a
    checkForNURBSError nurbsObj = withErrorCallback nurbsObj recordErrorCode

    --------------------------------------------------------------------------------
    -- chapter 7.3: NURBS Curves

    nurbsBeginEndCurve :: NURBSObj -> IO a -> IO a
    nurbsBeginEndCurve nurbsObj =
       bracket_ (gluBeginCurve nurbsObj) (gluEndCurve nurbsObj)

    foreign import CALLCONV safe "gluBeginCurve"
       gluBeginCurve :: NURBSObj -> IO ()

    nurbsCurve :: ControlPoint c => NURBSObj -> GLint -> Ptr GLfloat -> GLint -> Ptr (c GLfloat) -> GLint -> IO ()
    nurbsCurve nurbsObj knotCount knots stride control order =
       gluNurbsCurve nurbsObj knotCount knots stride (castPtr control) order (map1Target (pseudoPeek control))

    pseudoPeek :: Ptr (c GLfloat) -> c GLfloat
    pseudoPeek _ = undefined

    foreign import CALLCONV safe "gluNurbsCurve"
       gluNurbsCurve :: NURBSObj -> GLint -> Ptr GLfloat -> GLint -> Ptr GLfloat -> GLint -> GLenum -> IO ()

    foreign import CALLCONV safe "gluEndCurve"
       gluEndCurve :: NURBSObj -> IO ()

    --------------------------------------------------------------------------------
    -- chapter 7.4: NURBS Surfaces

    nurbsBeginEndSurface :: NURBSObj -> IO a -> IO a
    nurbsBeginEndSurface nurbsObj =
       bracket_ (gluBeginSurface nurbsObj) (gluEndSurface nurbsObj)

    foreign import CALLCONV safe "gluBeginSurface"
       gluBeginSurface :: NURBSObj -> IO ()

    nurbsSurface :: ControlPoint c => NURBSObj -> GLint -> Ptr GLfloat -> GLint -> Ptr GLfloat -> GLint -> GLint -> Ptr (c GLfloat) -> GLint -> GLint -> IO ()
    nurbsSurface nurbsObj sKnotCount sKnots tKnotCount tKnots sStride tStride control sOrder tOrder =
       gluNurbsSurface nurbsObj sKnotCount sKnots tKnotCount tKnots sStride tStride (castPtr control) sOrder tOrder (map2Target (pseudoPeek control))

    foreign import CALLCONV safe "gluNurbsSurface"
       gluNurbsSurface :: NURBSObj -> GLint -> Ptr GLfloat -> GLint -> Ptr GLfloat -> GLint -> GLint -> Ptr GLfloat -> GLint -> GLint -> GLenum -> IO ()

    foreign import CALLCONV safe "gluEndSurface"
       gluEndSurface :: NURBSObj -> IO ()

    --------------------------------------------------------------------------------
    -- chapter 7.5: Trimming

    class TrimmingPoint p where
       trimmingTarget :: p GLfloat -> GLenum

    instance TrimmingPoint Vertex2 where
       trimmingTarget = marshalNURBSTrim . const Map1Trim2

    instance TrimmingPoint Vertex3 where
       trimmingTarget = marshalNURBSTrim . const Map1Trim3

    data NURBSTrim =
         Map1Trim2
       | Map1Trim3

    marshalNURBSTrim :: NURBSTrim -> GLenum
    marshalNURBSTrim x = case x of
       Map1Trim2 -> 100210
       Map1Trim3 -> 100211

    nurbsBeginEndTrim :: NURBSObj -> IO a -> IO a
    nurbsBeginEndTrim nurbsObj =
       bracket_ (gluBeginTrim nurbsObj) (gluEndTrim nurbsObj)

    foreign import CALLCONV safe "gluBeginTrim"
       gluBeginTrim :: NURBSObj -> IO ()

    pwlCurve :: TrimmingPoint p => NURBSObj -> GLint -> Ptr (p GLfloat) -> GLint -> IO ()
    pwlCurve nurbsObj count points stride =
       gluPwlCurve nurbsObj count (castPtr points) stride (trimmingTarget (pseudoPeek points))

    foreign import CALLCONV safe "gluPwlCurve"
       gluPwlCurve :: NURBSObj -> GLint -> Ptr GLfloat -> GLint -> GLenum -> IO ()

    trimmingCurve :: TrimmingPoint c => NURBSObj -> GLint -> Ptr GLfloat -> GLint -> Ptr (c GLfloat) -> GLint -> IO ()
    trimmingCurve nurbsObj knotCount knots stride control order =
       gluNurbsCurve nurbsObj knotCount knots stride (castPtr control) order (trimmingTarget (pseudoPeek control))

    foreign import CALLCONV safe "gluEndTrim"
       gluEndTrim :: NURBSObj -> IO ()

    --------------------------------------------------------------------------------
    -- chapter 7.6: NURBS Properties

    data NURBSProperty =
         AutoLoadMatrix
       | Culling
       | ParametricTolerance
       | SamplingTolerance
       | DisplayMode'
       | SamplingMethod
       | UStep
       | VStep
       | NURBSMode

    marshalNURBSProperty :: NURBSProperty -> GLenum
    marshalNURBSProperty x = case x of
       AutoLoadMatrix -> 100200
       Culling -> 100201
       ParametricTolerance -> 100202
       SamplingTolerance -> 100203
       DisplayMode' -> 100204
       SamplingMethod -> 100205
       UStep -> 100206
       VStep -> 100207
       NURBSMode -> 100160

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

    setNURBSProperty :: NURBSObj -> NURBSProperty -> GLfloat -> IO ()
    setNURBSProperty nurbsObj = gluNurbsProperty nurbsObj . marshalNURBSProperty

    foreign import CALLCONV safe "gluNurbsProperty"
       gluNurbsProperty :: NURBSObj -> GLenum -> GLfloat -> IO ()

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

    data NURBSMode =
         NURBSTessellator
       | NURBSRenderer
       deriving ( Eq, Ord, Show )

    marshalNURBSMode :: NURBSMode -> GLfloat
    marshalNURBSMode x = case x of
       NURBSTessellator -> 100161
       NURBSRenderer -> 100162

    setNURBSMode :: NURBSObj -> NURBSMode -> IO ()
    setNURBSMode nurbsObj = setNURBSProperty nurbsObj NURBSMode . marshalNURBSMode

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

    setNURBSCulling :: NURBSObj -> Capability -> IO ()
    setNURBSCulling nurbsObj = setNURBSProperty nurbsObj Culling . fromIntegral . marshalCapability

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

    data SamplingMethod' =
         PathLength'
       | ParametricError'
       | DomainDistance'
       | ObjectPathLength'
       | ObjectParametricError'

    marshalSamplingMethod' :: SamplingMethod' -> GLfloat
    marshalSamplingMethod' x = case x of
       PathLength' -> 100215
       ParametricError' -> 100216
       DomainDistance' -> 100217
       ObjectPathLength' -> 100209
       ObjectParametricError' -> 100208

    setSamplingMethod' :: NURBSObj -> SamplingMethod' -> IO ()
    setSamplingMethod' nurbsObj = setNURBSProperty nurbsObj SamplingMethod . marshalSamplingMethod'

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

    data SamplingMethod =
         PathLength GLfloat
       | ParametricError GLfloat
       | DomainDistance GLfloat GLfloat
       | ObjectPathLength GLfloat
       | ObjectParametricError GLfloat
       deriving ( Eq, Ord, Show )

    setSamplingMethod :: NURBSObj -> SamplingMethod -> IO ()
    setSamplingMethod nurbsObj x = case x of
       PathLength s -> do
          setNURBSProperty nurbsObj SamplingTolerance s
          setSamplingMethod' nurbsObj PathLength'
       ParametricError p -> do
          setNURBSProperty nurbsObj ParametricTolerance p
          setSamplingMethod' nurbsObj ParametricError'
       DomainDistance u v -> do
          setNURBSProperty nurbsObj UStep u
          setNURBSProperty nurbsObj VStep v
          setSamplingMethod' nurbsObj DomainDistance'
       ObjectPathLength s -> do
          setNURBSProperty nurbsObj SamplingTolerance s
          setSamplingMethod' nurbsObj ObjectPathLength'
       ObjectParametricError p -> do
          setNURBSProperty nurbsObj ParametricTolerance p
          setSamplingMethod' nurbsObj ObjectParametricError'

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

    setAutoLoadMatrix :: NURBSObj -> Bool -> IO ()
    setAutoLoadMatrix nurbsObj = setNURBSProperty nurbsObj AutoLoadMatrix . marshalGLboolean

    loadSamplingMatrices :: (Matrix m1, Matrix m2) => NURBSObj -> Maybe (m1 GLfloat, m2 GLfloat, (Position, Size)) -> IO ()
    loadSamplingMatrices nurbsObj =
       maybe
          (setAutoLoadMatrix nurbsObj True)
          (\(mv, proj, (Position x y, Size w h)) -> do
              withMatrixColumnMajor mv $ \mvBuf ->
                 withMatrixColumnMajor proj $ \projBuf ->
                    withArray [x, y, w, h] $ \viewportBuf ->
                      gluLoadSamplingMatrices nurbsObj mvBuf projBuf viewportBuf
              setAutoLoadMatrix nurbsObj False)

    withMatrixColumnMajor :: (Matrix m, MatrixComponent c) => m c -> (Ptr c -> IO a) -> IO a
    withMatrixColumnMajor mat act =
       withMatrix mat $ \order p ->
          if order == ColumnMajor
             then act p
             else do
                elems <- mapM (peekElemOff p) [ 0, 4,  8, 12,
                                                1, 5,  9, 13,
                                                2, 6, 10, 14,
                                                3, 7, 11, 15 ]
                withArray elems act

    foreign import CALLCONV safe "gluLoadSamplingMatrices"
       gluLoadSamplingMatrices :: NURBSObj -> Ptr GLfloat -> Ptr GLfloat -> Ptr GLint -> IO ()

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

    data DisplayMode' =
         Fill'
       | OutlinePolygon
       | OutlinePatch
       deriving ( Eq, Ord, Show )

    marshalDisplayMode' :: DisplayMode' -> GLfloat
    marshalDisplayMode' x = case x of
       Fill' -> 100012
       OutlinePolygon -> 100240
       OutlinePatch -> 100241

    setDisplayMode' :: NURBSObj -> DisplayMode' -> IO ()
    setDisplayMode' nurbsObj = setNURBSProperty nurbsObj DisplayMode' . marshalDisplayMode'