module Graphics.Rendering.OpenGL.GL.Selection (
HitRecord(..), getHitRecords,
Name(..), withName, loadName, maxNameStackDepth, nameStackDepth,
RenderMode(..), renderMode
) where
import Data.StateVar
import Foreign.Marshal.Array
import Foreign.Ptr
import Graphics.Rendering.OpenGL.GL.Exception
import Graphics.Rendering.OpenGL.GL.IOState
import Graphics.Rendering.OpenGL.GL.QueryUtils
import Graphics.Rendering.OpenGL.GL.RenderMode
import Graphics.GL
data HitRecord = HitRecord GLfloat GLfloat [Name]
deriving ( HitRecord -> HitRecord -> Bool
(HitRecord -> HitRecord -> Bool)
-> (HitRecord -> HitRecord -> Bool) -> Eq HitRecord
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HitRecord -> HitRecord -> Bool
$c/= :: HitRecord -> HitRecord -> Bool
== :: HitRecord -> HitRecord -> Bool
$c== :: HitRecord -> HitRecord -> Bool
Eq, Eq HitRecord
Eq HitRecord
-> (HitRecord -> HitRecord -> Ordering)
-> (HitRecord -> HitRecord -> Bool)
-> (HitRecord -> HitRecord -> Bool)
-> (HitRecord -> HitRecord -> Bool)
-> (HitRecord -> HitRecord -> Bool)
-> (HitRecord -> HitRecord -> HitRecord)
-> (HitRecord -> HitRecord -> HitRecord)
-> Ord HitRecord
HitRecord -> HitRecord -> Bool
HitRecord -> HitRecord -> Ordering
HitRecord -> HitRecord -> HitRecord
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: HitRecord -> HitRecord -> HitRecord
$cmin :: HitRecord -> HitRecord -> HitRecord
max :: HitRecord -> HitRecord -> HitRecord
$cmax :: HitRecord -> HitRecord -> HitRecord
>= :: HitRecord -> HitRecord -> Bool
$c>= :: HitRecord -> HitRecord -> Bool
> :: HitRecord -> HitRecord -> Bool
$c> :: HitRecord -> HitRecord -> Bool
<= :: HitRecord -> HitRecord -> Bool
$c<= :: HitRecord -> HitRecord -> Bool
< :: HitRecord -> HitRecord -> Bool
$c< :: HitRecord -> HitRecord -> Bool
compare :: HitRecord -> HitRecord -> Ordering
$ccompare :: HitRecord -> HitRecord -> Ordering
Ord, Int -> HitRecord -> ShowS
[HitRecord] -> ShowS
HitRecord -> String
(Int -> HitRecord -> ShowS)
-> (HitRecord -> String)
-> ([HitRecord] -> ShowS)
-> Show HitRecord
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HitRecord] -> ShowS
$cshowList :: [HitRecord] -> ShowS
show :: HitRecord -> String
$cshow :: HitRecord -> String
showsPrec :: Int -> HitRecord -> ShowS
$cshowsPrec :: Int -> HitRecord -> ShowS
Show )
getHitRecords :: GLsizei -> IO a -> IO (a, Maybe [HitRecord])
getHitRecords :: forall a. GLint -> IO a -> IO (a, Maybe [HitRecord])
getHitRecords GLint
bufSize IO a
action =
Int
-> (Ptr GLuint -> IO (a, Maybe [HitRecord]))
-> IO (a, Maybe [HitRecord])
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray (GLint -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
bufSize) ((Ptr GLuint -> IO (a, Maybe [HitRecord]))
-> IO (a, Maybe [HitRecord]))
-> (Ptr GLuint -> IO (a, Maybe [HitRecord]))
-> IO (a, Maybe [HitRecord])
forall a b. (a -> b) -> a -> b
$ \Ptr GLuint
buf -> do
GLint -> Ptr GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLint -> Ptr GLuint -> m ()
glSelectBuffer GLint
bufSize Ptr GLuint
buf
(a
value, GLint
numHits) <- RenderMode -> IO a -> IO (a, GLint)
forall a. RenderMode -> IO a -> IO (a, GLint)
withRenderMode RenderMode
Select (IO a -> IO (a, GLint)) -> IO a -> IO (a, GLint)
forall a b. (a -> b) -> a -> b
$ do
IO ()
forall (m :: * -> *). MonadIO m => m ()
glInitNames
IO a
action
Maybe [HitRecord]
hits <- GLint -> Ptr GLuint -> IO (Maybe [HitRecord])
parseSelectionBuffer GLint
numHits Ptr GLuint
buf
(a, Maybe [HitRecord]) -> IO (a, Maybe [HitRecord])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
value, Maybe [HitRecord]
hits)
parseSelectionBuffer :: GLint -> Ptr GLuint -> IO (Maybe [HitRecord])
parseSelectionBuffer :: GLint -> Ptr GLuint -> IO (Maybe [HitRecord])
parseSelectionBuffer GLint
numHits Ptr GLuint
buf
| GLint
numHits GLint -> GLint -> Bool
forall a. Ord a => a -> a -> Bool
< GLint
0 = Maybe [HitRecord] -> IO (Maybe [HitRecord])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [HitRecord]
forall a. Maybe a
Nothing
| Bool
otherwise = ([HitRecord] -> Maybe [HitRecord])
-> IO [HitRecord] -> IO (Maybe [HitRecord])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [HitRecord] -> Maybe [HitRecord]
forall a. a -> Maybe a
Just (IO [HitRecord] -> IO (Maybe [HitRecord]))
-> IO [HitRecord] -> IO (Maybe [HitRecord])
forall a b. (a -> b) -> a -> b
$ IOState GLuint [HitRecord] -> Ptr GLuint -> IO [HitRecord]
forall s a. IOState s a -> Ptr s -> IO a
evalIOState (GLint -> IOState GLuint HitRecord -> IOState GLuint [HitRecord]
forall a b c. Integral a => a -> IOState b c -> IOState b [c]
nTimes GLint
numHits IOState GLuint HitRecord
parseSelectionHit) Ptr GLuint
buf
type Parser a = IOState GLuint a
parseSelectionHit :: Parser HitRecord
parseSelectionHit :: IOState GLuint HitRecord
parseSelectionHit = do
GLuint
numNames <- Parser GLuint
parseGLuint
GLfloat
minZ <- Parser GLfloat
parseGLfloat
GLfloat
maxZ <- Parser GLfloat
parseGLfloat
[Name]
nameStack <- GLuint -> IOState GLuint Name -> IOState GLuint [Name]
forall a b c. Integral a => a -> IOState b c -> IOState b [c]
nTimes GLuint
numNames IOState GLuint Name
parseName
HitRecord -> IOState GLuint HitRecord
forall (m :: * -> *) a. Monad m => a -> m a
return (HitRecord -> IOState GLuint HitRecord)
-> HitRecord -> IOState GLuint HitRecord
forall a b. (a -> b) -> a -> b
$ GLfloat -> GLfloat -> [Name] -> HitRecord
HitRecord GLfloat
minZ GLfloat
maxZ [Name]
nameStack
parseGLuint :: Parser GLuint
parseGLuint :: Parser GLuint
parseGLuint = Parser GLuint
forall a. Storable a => IOState a a
peekIOState
parseGLfloat :: Parser GLfloat
parseGLfloat :: Parser GLfloat
parseGLfloat = (GLuint -> GLfloat) -> Parser GLuint -> Parser GLfloat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\GLuint
x -> GLuint -> GLfloat
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLuint
x GLfloat -> GLfloat -> GLfloat
forall a. Fractional a => a -> a -> a
/ GLfloat
0xffffffff) Parser GLuint
parseGLuint
parseName :: Parser Name
parseName :: IOState GLuint Name
parseName = (GLuint -> Name) -> Parser GLuint -> IOState GLuint Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GLuint -> Name
Name Parser GLuint
parseGLuint
newtype Name = Name GLuint
deriving ( Name -> Name -> Bool
(Name -> Name -> Bool) -> (Name -> Name -> Bool) -> Eq Name
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Name -> Name -> Bool
$c/= :: Name -> Name -> Bool
== :: Name -> Name -> Bool
$c== :: Name -> Name -> Bool
Eq, Eq Name
Eq Name
-> (Name -> Name -> Ordering)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Name)
-> (Name -> Name -> Name)
-> Ord Name
Name -> Name -> Bool
Name -> Name -> Ordering
Name -> Name -> Name
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Name -> Name -> Name
$cmin :: Name -> Name -> Name
max :: Name -> Name -> Name
$cmax :: Name -> Name -> Name
>= :: Name -> Name -> Bool
$c>= :: Name -> Name -> Bool
> :: Name -> Name -> Bool
$c> :: Name -> Name -> Bool
<= :: Name -> Name -> Bool
$c<= :: Name -> Name -> Bool
< :: Name -> Name -> Bool
$c< :: Name -> Name -> Bool
compare :: Name -> Name -> Ordering
$ccompare :: Name -> Name -> Ordering
Ord, Int -> Name -> ShowS
[Name] -> ShowS
Name -> String
(Int -> Name -> ShowS)
-> (Name -> String) -> ([Name] -> ShowS) -> Show Name
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Name] -> ShowS
$cshowList :: [Name] -> ShowS
show :: Name -> String
$cshow :: Name -> String
showsPrec :: Int -> Name -> ShowS
$cshowsPrec :: Int -> Name -> ShowS
Show )
withName :: Name -> IO a -> IO a
withName :: forall a. Name -> IO a -> IO a
withName (Name GLuint
name) = IO () -> IO () -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glPushName GLuint
name) IO ()
forall (m :: * -> *). MonadIO m => m ()
glPopName
loadName :: Name -> IO ()
loadName :: Name -> IO ()
loadName (Name GLuint
n) = GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glLoadName GLuint
n
maxNameStackDepth :: GettableStateVar GLsizei
maxNameStackDepth :: GettableStateVar GLint
maxNameStackDepth = GettableStateVar GLint -> GettableStateVar GLint
forall a. IO a -> IO a
makeGettableStateVar ((GLint -> GLint) -> PName1I -> GettableStateVar GLint
forall p a. GetPName1I p => (GLint -> a) -> p -> IO a
getSizei1 GLint -> GLint
forall a. a -> a
id PName1I
GetMaxNameStackDepth)
nameStackDepth :: GettableStateVar GLsizei
nameStackDepth :: GettableStateVar GLint
nameStackDepth = GettableStateVar GLint -> GettableStateVar GLint
forall a. IO a -> IO a
makeGettableStateVar ((GLint -> GLint) -> PName1I -> GettableStateVar GLint
forall p a. GetPName1I p => (GLint -> a) -> p -> IO a
getSizei1 GLint -> GLint
forall a. a -> a
id PName1I
GetNameStackDepth)