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
import Foreign.Marshal.Array
import Foreign.Ptr
import Foreign.Storable
import Graphics.GLU hiding (
NURBSBeginCallback, NURBSVertexCallback, NURBSNormalCallback,
NURBSColorCallback, NURBSEndCallback )
import Graphics.Rendering.OpenGL.GL.Tensor
import Graphics.Rendering.OpenGL.GL.Capability
import Graphics.Rendering.OpenGL.GL.ControlPoint
import Graphics.Rendering.OpenGL.GL.CoordTrans
import Graphics.Rendering.OpenGL.GL.Exception
import Graphics.Rendering.OpenGL.GL.GLboolean
import Graphics.Rendering.OpenGL.GL.PrimitiveMode
import Graphics.Rendering.OpenGL.GL.PrimitiveModeInternal
import Graphics.Rendering.OpenGL.GL.VertexSpec
import Graphics.Rendering.OpenGL.GLU.ErrorsInternal
import Graphics.GL
type NURBSObj = Ptr GLUnurbs
isNullNURBSObj :: NURBSObj -> Bool
isNullNURBSObj = (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)
safeDeleteNurbsRenderer :: NURBSObj -> IO ()
safeDeleteNurbsRenderer nurbsObj =
unless (isNullNURBSObj nurbsObj) $ gluDeleteNurbsRenderer nurbsObj
type NURBSBeginCallback = PrimitiveMode -> IO ()
withNURBSBeginCallback :: NURBSObj -> NURBSBeginCallback -> IO a -> IO a
withNURBSBeginCallback nurbsObj beginCallback action =
bracket (makeNURBSBeginCallback (beginCallback . unmarshalPrimitiveMode))
freeHaskellFunPtr $ \callbackPtr -> do
gluNurbsCallback nurbsObj GLU_NURBS_BEGIN callbackPtr
action
type NURBSVertexCallback = Vertex3 GLfloat -> IO ()
withNURBSVertexCallback :: NURBSObj -> NURBSVertexCallback -> IO a -> IO a
withNURBSVertexCallback nurbsObj vertexCallback action =
bracket (makeNURBSVertexCallback (\p -> peek (castPtr p) >>= vertexCallback))
freeHaskellFunPtr $ \callbackPtr -> do
gluNurbsCallback nurbsObj GLU_NURBS_VERTEX callbackPtr
action
type NURBSNormalCallback = Normal3 GLfloat -> IO ()
withNURBSNormalCallback :: NURBSObj -> NURBSNormalCallback -> IO a -> IO a
withNURBSNormalCallback nurbsObj normalCallback action =
bracket (makeNURBSNormalCallback (\p -> peek (castPtr p) >>= normalCallback))
freeHaskellFunPtr $ \callbackPtr -> do
gluNurbsCallback nurbsObj GLU_NURBS_NORMAL callbackPtr
action
type NURBSColorCallback = Color4 GLfloat -> IO ()
withNURBSColorCallback :: NURBSObj -> NURBSColorCallback -> IO a -> IO a
withNURBSColorCallback nurbsObj colorCallback action =
bracket (makeNURBSColorCallback (\p -> peek (castPtr p) >>= colorCallback))
freeHaskellFunPtr $ \callbackPtr -> do
gluNurbsCallback nurbsObj GLU_NURBS_COLOR callbackPtr
action
type NURBSEndCallback = IO ()
withNURBSEndCallback :: NURBSObj -> NURBSEndCallback -> IO a -> IO a
withNURBSEndCallback nurbsObj endCallback action =
bracket (makeNURBSEndCallback endCallback)
freeHaskellFunPtr $ \callbackPtr -> do
gluNurbsCallback nurbsObj GLU_NURBS_END callbackPtr
action
type ErrorCallback = GLenum -> IO ()
withErrorCallback :: NURBSObj -> ErrorCallback -> IO a -> IO a
withErrorCallback nurbsObj errorCallback action =
bracket (makeNURBSErrorCallback errorCallback)
freeHaskellFunPtr $ \callbackPtr -> do
gluNurbsCallback nurbsObj GLU_NURBS_ERROR callbackPtr
action
checkForNURBSError :: NURBSObj -> IO a -> IO a
checkForNURBSError nurbsObj = withErrorCallback nurbsObj recordErrorCode
nurbsBeginEndCurve :: NURBSObj -> IO a -> IO a
nurbsBeginEndCurve nurbsObj =
bracket_ (gluBeginCurve nurbsObj) (gluEndCurve nurbsObj)
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
nurbsBeginEndSurface :: NURBSObj -> IO a -> IO a
nurbsBeginEndSurface nurbsObj =
bracket_ (gluBeginSurface nurbsObj) (gluEndSurface nurbsObj)
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))
class TrimmingPoint p where
trimmingTarget :: p GLfloat -> GLenum
instance TrimmingPoint Vertex2 where
trimmingTarget = const GLU_MAP1_TRIM_2
instance TrimmingPoint Vertex3 where
trimmingTarget = const GLU_MAP1_TRIM_3
nurbsBeginEndTrim :: NURBSObj -> IO a -> IO a
nurbsBeginEndTrim nurbsObj =
bracket_ (gluBeginTrim nurbsObj) (gluEndTrim nurbsObj)
pwlCurve :: TrimmingPoint p => NURBSObj -> GLint -> Ptr (p GLfloat) -> GLint -> IO ()
pwlCurve nurbsObj count points stride =
gluPwlCurve nurbsObj count (castPtr points) stride (trimmingTarget (pseudoPeek points))
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))
data NURBSMode =
NURBSTessellator
| NURBSRenderer
deriving ( Eq, Ord, Show )
marshalNURBSMode :: NURBSMode -> GLfloat
marshalNURBSMode x = fromIntegral $ case x of
NURBSTessellator -> GLU_NURBS_TESSELLATOR
NURBSRenderer -> GLU_NURBS_RENDERER
setNURBSMode :: NURBSObj -> NURBSMode -> IO ()
setNURBSMode nurbsObj = gluNurbsProperty nurbsObj GLU_NURBS_MODE . marshalNURBSMode
setNURBSCulling :: NURBSObj -> Capability -> IO ()
setNURBSCulling nurbsObj = gluNurbsProperty nurbsObj GLU_CULLING . fromIntegral . marshalCapability
data SamplingMethod' =
PathLength'
| ParametricError'
| DomainDistance'
| ObjectPathLength'
| ObjectParametricError'
marshalSamplingMethod' :: SamplingMethod' -> GLfloat
marshalSamplingMethod' x = fromIntegral $ case x of
PathLength' -> GLU_PATH_LENGTH
ParametricError' -> GLU_PARAMETRIC_TOLERANCE
DomainDistance' -> GLU_DOMAIN_DISTANCE
ObjectPathLength' -> GLU_OBJECT_PATH_LENGTH
ObjectParametricError' -> GLU_OBJECT_PARAMETRIC_ERROR
setSamplingMethod' :: NURBSObj -> SamplingMethod' -> IO ()
setSamplingMethod' nurbsObj = gluNurbsProperty nurbsObj GLU_SAMPLING_METHOD . 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
gluNurbsProperty nurbsObj GLU_SAMPLING_TOLERANCE s
setSamplingMethod' nurbsObj PathLength'
ParametricError p -> do
gluNurbsProperty nurbsObj GLU_PARAMETRIC_TOLERANCE p
setSamplingMethod' nurbsObj ParametricError'
DomainDistance u v -> do
gluNurbsProperty nurbsObj GLU_U_STEP u
gluNurbsProperty nurbsObj GLU_V_STEP v
setSamplingMethod' nurbsObj DomainDistance'
ObjectPathLength s -> do
gluNurbsProperty nurbsObj GLU_SAMPLING_TOLERANCE s
setSamplingMethod' nurbsObj ObjectPathLength'
ObjectParametricError p -> do
gluNurbsProperty nurbsObj GLU_PARAMETRIC_TOLERANCE p
setSamplingMethod' nurbsObj ObjectParametricError'
setAutoLoadMatrix :: NURBSObj -> Bool -> IO ()
setAutoLoadMatrix nurbsObj = gluNurbsProperty nurbsObj GLU_AUTO_LOAD_MATRIX . 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, fromIntegral w, fromIntegral 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
data DisplayMode' =
Fill'
| OutlinePolygon
| OutlinePatch
deriving ( Eq, Ord, Show )
marshalDisplayMode' :: DisplayMode' -> GLfloat
marshalDisplayMode' x = fromIntegral $ case x of
Fill' -> GLU_FILL
OutlinePolygon -> GLU_OUTLINE_POLYGON
OutlinePatch -> GLU_OUTLINE_PATCH
setDisplayMode' :: NURBSObj -> DisplayMode' -> IO ()
setDisplayMode' nurbsObj = gluNurbsProperty nurbsObj GLU_DISPLAY_MODE . marshalDisplayMode'