1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
|
{-
ARBOcclude.hs (adapted from arbocclude.c which is (c) Brian Paul)
Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>
This file is part of HOpenGL and distributed under a BSD-style license
See the file libraries/GLUT/LICENSE
-}
import Control.Monad ( unless, when )
import Data.IORef ( IORef, newIORef )
import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure )
import Graphics.UI.GLUT
data State = State {
anim :: IORef Bool,
xPos :: IORef GLfloat,
sign :: IORef GLfloat,
lastTime :: IORef Int }
makeState :: IO State
makeState = do
a <- newIORef True
x <- newIORef 0
s <- newIORef 1
l <- newIORef =<< get elapsedTime
return $ State { anim = a, xPos = x, sign = s, lastTime = l }
petrol, orange, white :: Color3 GLfloat
petrol = Color3 0.0 0.6 0.8
orange = Color3 0.8 0.5 0.0
white = Color3 1.0 1.0 1.0
printString :: Vertex2 GLfloat -> String -> IO ()
printString pos s = do
color white
rasterPos pos
renderString Fixed8By13 s
idle :: State -> IdleCallback
idle state = do
time <- get elapsedTime
l <- get (lastTime state)
let timeDiff = fromIntegral (time - l)
when (timeDiff >= 20) $ do -- 50Hz update
lastTime state $= time
s <- get (sign state)
step state (timeDiff / 1000 * s)
x <- get (xPos state)
when (x > 2.5) $ do
xPos state $= 2.5
sign state $= (-1)
when (x < -2.5) $ do
xPos state $= (-2.5)
sign state $= 1
display :: QueryObject -> State -> DisplayCallback
display occQuery state = do
clear [ ColorBuffer, DepthBuffer ]
matrixMode $= Projection
loadIdentity
frustum (-1) 1 (-1) 1 5 25
matrixMode $= Modelview 0
loadIdentity
translate (Vector3 0 0 (-15 :: GLfloat))
drawOccludingPolygons
-- draw the test polygon with occlusion testing
passed <- preservingMatrix $ do
x <- get (xPos state)
translate (Vector3 x 0 (-0.5))
scale 0.3 0.3 (1.0 :: GLfloat)
rotate (-90 * x) (Vector3 0 0 1)
withQuery SamplesPassed occQuery $ do
colorMask $= Color4 Disabled Disabled Disabled Disabled
depthMask $= Disabled
drawRect
p <- waitForResult occQuery
-- turn off occlusion testing
colorMask $= Color4 Enabled Enabled Enabled Enabled
depthMask $= Enabled
-- draw the orange rect, so we can see what's going on
color orange
drawRect
return p
-- Print result message
matrixMode $= Projection
loadIdentity
ortho (-1) 1 (-1) 1 (-1) 1
matrixMode $= Modelview 0
loadIdentity
printString (Vertex2 (-0.50) (-0.7))
(" " ++ flushRight 4 passed ++ " Fragments Visible")
when (passed == 0) $
printString (Vertex2 (-0.25) (-0.8)) "Fully Occluded"
swapBuffers
drawOccludingPolygons :: IO ()
drawOccludingPolygons = do
color petrol
drawQuads [
Vertex2 (-1.6) (-1.5),
Vertex2 (-0.4) (-1.5),
Vertex2 (-0.4) 1.5 ,
Vertex2 (-1.6) 1.5 ,
Vertex2 0.4 (-1.5),
Vertex2 1.6 (-1.5),
Vertex2 1.6 1.5 ,
Vertex2 0.4 1.5 ]
drawRect :: IO ()
drawRect = do
drawQuads [
Vertex2 (-1) (-1),
Vertex2 1 (-1),
Vertex2 1 1 ,
Vertex2 (-1) 1 ]
drawQuads :: [Vertex2 GLfloat] -> IO ()
drawQuads = renderPrimitive Quads . mapM_ vertex
waitForResult :: QueryObject -> IO GLuint
waitForResult occQuery = do
let loop = do -- do useful work here, if any
ready <- get (queryResultAvailable occQuery)
unless ready loop
loop
get (queryResult occQuery)
flushRight :: Show a => Int -> a -> String
flushRight width x = replicate (width - length s) ' ' ++ s
where s = show x
keyboard :: State -> KeyboardMouseCallback
keyboard _ (Char '\27') Down _ _ = exitWith ExitSuccess
keyboard state (Char ' ') Down _ _ = do anim state $~ not
setIdleCallback state
keyboard state (SpecialKey KeyLeft) Down _ _ = step state (-0.1)
keyboard state (SpecialKey KeyRight) Down _ _ = step state 0.1
keyboard _ _ _ _ _ = return ()
setIdleCallback :: State -> IO ()
setIdleCallback state = do
a <- get (anim state)
idleCallback $= if a then Just (idle state) else Nothing
step :: State -> GLfloat -> IO ()
step state s = do
xPos state $~ (+ s)
postRedisplay Nothing
myInit :: IO ()
myInit = do
exts <- get glExtensions
unless ("GL_ARB_occlusion_query" `elem` exts) $ do
putStrLn "Sorry, this demo requires the GL_ARB_occlusion_query extension."
exitFailure
bits <- get (queryCounterBits SamplesPassed)
unless (bits > 0) $ do
putStrLn "Hmmm, GL_QUERY_COUNTER_BITS_ARB is zero!"
exitFailure
depthFunc $= Just Less
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialWindowPosition $= Position 0 0
initialWindowSize $= Size 400 400
initialDisplayMode $= [ RGBMode, DoubleBuffered, WithDepthBuffer ]
createWindow progName
state <- makeState
reshapeCallback $= Just (\size -> viewport $= (Position 0 0, size))
keyboardMouseCallback $= Just (keyboard state)
setIdleCallback state
[ occQuery ] <- genObjectNames 1
displayCallback $= display occQuery state
myInit
mainLoop
|
