module Graphics.Rendering.OpenGL.GL.Feedback (
FeedbackToken(..), VertexInfo(..), ColorInfo, FeedbackType(..),
getFeedbackTokens, PassThroughValue(..), passThrough
) where
import Control.Monad
import Data.StateVar
import Foreign.Marshal.Array
import Foreign.Ptr
import Foreign.Storable
import Graphics.Rendering.OpenGL.GL.IOState
import Graphics.Rendering.OpenGL.GL.RenderMode
import Graphics.Rendering.OpenGL.GL.Tensor
import Graphics.Rendering.OpenGL.GL.VertexSpec
import Graphics.GL
data FeedbackToken =
PointToken VertexInfo
| LineToken VertexInfo VertexInfo
| LineResetToken VertexInfo VertexInfo
| PolygonToken [VertexInfo]
| BitmapToken VertexInfo
| DrawPixelToken VertexInfo
| CopyPixelToken VertexInfo
| PassThroughToken PassThroughValue
deriving ( Eq, Ord, Show )
data VertexInfo =
Vertex2D (Vertex2 GLfloat)
| Vertex3D (Vertex3 GLfloat)
| Vertex3DColor (Vertex3 GLfloat) ColorInfo
| Vertex3DColorTexture (Vertex3 GLfloat) ColorInfo (TexCoord4 GLfloat)
| Vertex4DColorTexture (Vertex4 GLfloat) ColorInfo (TexCoord4 GLfloat)
deriving ( Eq, Ord, Show )
type ColorInfo = Either (Index1 GLint) (Color4 GLfloat)
data FeedbackTag =
PointTag
| LineTag
| LineResetTag
| PolygonTag
| BitmapTag
| DrawPixelTag
| CopyPixelTag
| PassThroughTag
unmarshalFeedbackTag :: GLenum -> FeedbackTag
unmarshalFeedbackTag x
| x == GL_POINT_TOKEN = PointTag
| x == GL_LINE_TOKEN = LineTag
| x == GL_LINE_RESET_TOKEN = LineResetTag
| x == GL_POLYGON_TOKEN = PolygonTag
| x == GL_BITMAP_TOKEN = BitmapTag
| x == GL_DRAW_PIXEL_TOKEN = DrawPixelTag
| x == GL_COPY_PIXEL_TOKEN = CopyPixelTag
| x == GL_PASS_THROUGH_TOKEN = PassThroughTag
| otherwise = error ("unmarshalFeedbackTag: illegal value " ++ show x)
data FeedbackType =
TwoD
| ThreeD
| ThreeDColor
| ThreeDColorTexture
| FourDColorTexture
deriving ( Eq, Ord, Show )
marshalFeedbackType :: FeedbackType -> GLenum
marshalFeedbackType x = case x of
TwoD -> GL_2D
ThreeD -> GL_3D
ThreeDColor -> GL_3D_COLOR
ThreeDColorTexture -> GL_3D_COLOR_TEXTURE
FourDColorTexture -> GL_4D_COLOR_TEXTURE
getFeedbackTokens ::
GLsizei -> FeedbackType -> IO a -> IO (a, Maybe [FeedbackToken])
getFeedbackTokens bufSize feedbackType action =
allocaArray (fromIntegral bufSize) $ \buf -> do
glFeedbackBuffer bufSize (marshalFeedbackType feedbackType) buf
(value, numValues) <- withRenderMode Feedback action
tokens <- parseFeedbackBuffer numValues buf feedbackType
return (value, tokens)
parseFeedbackBuffer ::
GLint -> Ptr GLfloat -> FeedbackType -> IO (Maybe [FeedbackToken])
parseFeedbackBuffer numValues buf feedbackType
| numValues < 0 = return Nothing
| otherwise = do
rgba <- get rgbaMode
let end = buf `plusPtr`
(sizeOf (undefined :: GLfloat) * fromIntegral numValues)
infoParser = calcInfoParser feedbackType (calcColorParser rgba)
loop tokens = do
ptr <- getIOState
if ptr == end
then return (reverse tokens)
else do token <- tokenParser infoParser
loop (token : tokens)
fmap Just $ evalIOState (loop []) buf
type Parser a = IOState GLfloat a
tokenParser :: Parser VertexInfo -> Parser FeedbackToken
tokenParser infoParser = do
tag <- parseGLenum
case unmarshalFeedbackTag tag of
PointTag -> fmap PointToken infoParser
LineTag -> liftM2 LineToken infoParser infoParser
LineResetTag -> liftM2 LineResetToken infoParser infoParser
PolygonTag -> do n <- parseGLint; fmap PolygonToken (nTimes n infoParser)
BitmapTag -> fmap BitmapToken infoParser
DrawPixelTag -> fmap DrawPixelToken infoParser
CopyPixelTag -> fmap CopyPixelToken infoParser
PassThroughTag -> fmap PassThroughToken parsePassThroughValue
calcInfoParser :: FeedbackType -> Parser ColorInfo -> Parser VertexInfo
calcInfoParser feedbackType colorParser = case feedbackType of
TwoD ->
fmap Vertex2D parseVertex2
ThreeD ->
fmap Vertex3D parseVertex3
ThreeDColor ->
liftM2 Vertex3DColor parseVertex3 colorParser
ThreeDColorTexture ->
liftM3 Vertex3DColorTexture parseVertex3 colorParser parseTexCoord4
FourDColorTexture ->
liftM3 Vertex4DColorTexture parseVertex4 colorParser parseTexCoord4
parseVertex2 :: Parser (Vertex2 GLfloat)
parseVertex2 = liftM2 Vertex2 parseGLfloat parseGLfloat
parseVertex3 :: Parser (Vertex3 GLfloat)
parseVertex3 = liftM3 Vertex3 parseGLfloat parseGLfloat parseGLfloat
parseVertex4 :: Parser (Vertex4 GLfloat)
parseVertex4 =
liftM4 Vertex4 parseGLfloat parseGLfloat parseGLfloat parseGLfloat
calcColorParser :: Bool -> Parser ColorInfo
calcColorParser False = fmap Left parseIndex1
calcColorParser True = fmap Right parseColor4
parseIndex1 :: Parser (Index1 GLint)
parseIndex1 = fmap Index1 parseGLint
parseColor4 :: Parser (Color4 GLfloat)
parseColor4 = liftM4 Color4 parseGLfloat parseGLfloat parseGLfloat parseGLfloat
parseTexCoord4 :: Parser (TexCoord4 GLfloat)
parseTexCoord4 =
liftM4 TexCoord4 parseGLfloat parseGLfloat parseGLfloat parseGLfloat
parsePassThroughValue :: Parser PassThroughValue
parsePassThroughValue = fmap PassThroughValue parseGLfloat
parseGLenum :: Parser GLenum
parseGLenum = fmap round parseGLfloat
parseGLint :: Parser GLint
parseGLint = fmap round parseGLfloat
parseGLfloat :: Parser GLfloat
parseGLfloat = peekIOState
newtype PassThroughValue = PassThroughValue GLfloat
deriving ( Eq, Ord, Show )
passThrough :: PassThroughValue -> IO ()
passThrough (PassThroughValue ptv) = glPassThrough ptv