module Graphics.Rendering.OpenGL.GL.Feedback (
FeedbackToken(..), VertexInfo(..), ColorInfo, FeedbackType(..),
getFeedbackTokens, PassThroughValue(..), passThrough
) where
import Control.Monad ( liftM2, liftM3, liftM4 )
import Foreign.Marshal.Array ( allocaArray )
import Foreign.Ptr ( Ptr, plusPtr )
import Foreign.Storable ( Storable(sizeOf) )
import Graphics.Rendering.OpenGL.GL.BasicTypes (
GLenum, GLint, GLsizei, GLfloat )
import Graphics.Rendering.OpenGL.GL.IOState (
IOState, getIOState, peekIOState, evalIOState, nTimes )
import Graphics.Rendering.OpenGL.GL.RenderMode ( withRenderMode )
import Graphics.Rendering.OpenGL.GL.Selection ( RenderMode(Feedback) )
import Graphics.Rendering.OpenGL.GL.StateVar ( HasGetter(get) )
import Graphics.Rendering.OpenGL.GL.VertexSpec (
Vertex2(..), Vertex3(..), Vertex4(..), Index1(..), Color4(..),
TexCoord4(..), rgbaMode )
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 == 0x701 = PointTag
| x == 0x702 = LineTag
| x == 0x707 = LineResetTag
| x == 0x703 = PolygonTag
| x == 0x704 = BitmapTag
| x == 0x705 = DrawPixelTag
| x == 0x706 = CopyPixelTag
| x == 0x700 = 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 -> 0x600
ThreeD -> 0x601
ThreeDColor -> 0x602
ThreeDColorTexture -> 0x603
FourDColorTexture -> 0x604
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)
foreign import CALLCONV unsafe "glFeedbackBuffer" glFeedbackBuffer ::
GLsizei -> GLenum -> Ptr GLfloat -> IO ()
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 )
foreign import CALLCONV unsafe "glPassThrough" passThrough ::
PassThroughValue -> IO ()