module Graphics.Rendering.OGL.GL.Selection (
HitRecord(..), getHitRecords,
Name(..), withName, loadName, maxNameStackDepth, nameStackDepth,
RenderMode(..), renderMode
) where
import Foreign.Marshal.Array ( allocaArray )
import Foreign.Ptr ( Ptr )
import Graphics.Rendering.OGL.Monad
import Graphics.Rendering.OGL.GL.BasicTypes (
GLint, GLsizei, GLuint, GLfloat )
import Graphics.Rendering.OGL.GL.Exception ( bracket_ )
import Graphics.Rendering.OGL.GL.IOState (
IOState, peekIOState, evalIOState, nTimes )
import Graphics.Rendering.OGL.GL.QueryUtils (
GetPName(GetMaxNameStackDepth,GetNameStackDepth), getSizei1 )
import Graphics.Rendering.OGL.GL.RenderMode (
RenderMode(..), withRenderMode, renderMode )
import Graphics.Rendering.OGL.GL.StateVar (
GettableStateVar, makeGettableStateVar )
data HitRecord = HitRecord GLfloat GLfloat [Name]
deriving ( Eq, Ord, Show )
getHitRecords :: GLsizei -> GL a -> GL (a, Maybe [HitRecord])
getHitRecords bufSize action = liftIO .
allocaArray (fromIntegral bufSize) $ \buf -> do
glSelectBuffer bufSize buf
(value, numHits) <- withRenderMode Select $ do
glInitNames
runGL action
hits <- parseSelectionBuffer numHits buf
return (value, hits)
foreign import CALLCONV unsafe "glInitNames" glInitNames :: IO ()
foreign import CALLCONV unsafe "glSelectBuffer" glSelectBuffer ::
GLsizei -> Ptr GLuint -> IO ()
parseSelectionBuffer :: GLint -> Ptr GLuint -> IO (Maybe [HitRecord])
parseSelectionBuffer numHits buf
| numHits < 0 = return Nothing
| otherwise = fmap Just $ evalIOState (nTimes numHits parseSelectionHit) buf
type Parser a = IOState GLuint a
parseSelectionHit :: Parser HitRecord
parseSelectionHit = do
numNames <- parseGLuint
minZ <- parseGLfloat
maxZ <- parseGLfloat
nameStack <- nTimes numNames parseName
return $ HitRecord minZ maxZ nameStack
parseGLuint :: Parser GLuint
parseGLuint = peekIOState
parseGLfloat :: Parser GLfloat
parseGLfloat = fmap (\x -> fromIntegral x / 0xffffffff) parseGLuint
parseName :: Parser Name
parseName = fmap Name parseGLuint
newtype Name = Name GLuint
deriving ( Eq, Ord, Show )
withName :: Name -> GL a -> GL a
withName name f = liftIO $ bracket_ (glPushName name) glPopName (runGL f)
foreign import CALLCONV unsafe "glPopName" glPopName :: IO ()
foreign import CALLCONV unsafe "glPushName" glPushName :: Name -> IO ()
foreign import CALLCONV unsafe "glLoadName" loadName :: Name -> GL ()
maxNameStackDepth :: GettableStateVar GLsizei
maxNameStackDepth = makeGettableStateVar (getSizei1 id GetMaxNameStackDepth)
nameStackDepth :: GettableStateVar GLsizei
nameStackDepth = makeGettableStateVar (getSizei1 id GetNameStackDepth)