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
|
{-
PickDepth.hs (adapted from pickdepth.c which is (c) Silicon Graphics, Inc.)
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
Picking is demonstrated in this program. In rendering mode, three
overlapping rectangles are drawn. When the left mouse button is pressed,
selection mode is entered with the picking matrix. Rectangles which are drawn
under the cursor position are "picked." Pay special attention to the depth
value range, which is returned.
-}
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
myInit :: IO ()
myInit = do
clearColor $= Color4 0 0 0 0
depthFunc $= Just Less
shadeModel $= Flat
depthRange $= (0, 1) -- The default z mapping
-- The nine squares are drawn. Each square is given two names: one for the row
-- and the other for the column on the grid. The color of each square is
-- determined by its position on the grid, and the value in the board array.
-- Note: In contrast to the the original example, we always give names to
-- squares, regardless of the render mode. This simplifies the code a bit and
-- is even suggested by the Red Book.
-- The three rectangles are drawn, each with a different name. Note that each
-- rectangle is drawn with a different z value. Note: In contrast to the the
-- original example, we always give names to squares, regardless of the render
-- mode. This simplifies the code a bit and is even suggested by the Red Book.
drawRects :: IO ()
drawRects = do
-- resolve overloading, not needed in "real" programs
let color3 = color :: Color3 GLfloat -> IO ()
vertex3 = vertex :: Vertex3 GLint -> IO ()
loadName (Name 1)
renderPrimitive Quads $ do
color3 (Color3 1.0 1.0 0.0)
vertex3 (Vertex3 2 0 0)
vertex3 (Vertex3 2 6 0)
vertex3 (Vertex3 6 6 0)
vertex3 (Vertex3 6 0 0)
loadName (Name 2)
renderPrimitive Quads $ do
color3 (Color3 0.0 1.0 1.0)
vertex3 (Vertex3 3 2 (-1))
vertex3 (Vertex3 3 8 (-1))
vertex3 (Vertex3 8 8 (-1))
vertex3 (Vertex3 8 2 (-1))
loadName (Name 3)
renderPrimitive Quads $ do
color3 (Color3 1.0 0.0 1.0)
vertex3 (Vertex3 0 2 (-2))
vertex3 (Vertex3 0 7 (-2))
vertex3 (Vertex3 5 7 (-2))
vertex3 (Vertex3 5 2 (-2))
-- processHits prints the hit records.
processHits :: Maybe[HitRecord] -> IO ()
processHits Nothing = putStrLn "selection buffer overflow"
processHits (Just hitRecords) = do
putStrLn ("hits = " ++ show (length hitRecords))
flip mapM_ hitRecords $ \(HitRecord z1 z2 names) -> do
putStrLn (" number of names for hit = " ++ show (length names))
putStr (" z1 is " ++ show z1)
putStrLn ("; z2 is " ++ show z2)
putStr " the name is"
sequence_ [ putStr (" " ++ show n) | Name n <- names ]
putChar '\n'
-- pickRects() sets up selection mode, name stack, and projection matrix for
-- picking. Then the objects are drawn.
bufSize :: GLsizei
bufSize = 512
pickRects :: KeyboardMouseCallback
pickRects (MouseButton LeftButton) Down _ (Position x y) = do
vp@(_, (Size _ height)) <- get viewport
(_, maybeHitRecords) <- getHitRecords bufSize $
withName (Name 0) $ do
matrixMode $= Projection
preservingMatrix $ do
loadIdentity
-- create 5x5 pixel picking region near cursor location
pickMatrix (fromIntegral x, fromIntegral height - fromIntegral y) (5, 5) vp
ortho 0 8 0 8 (-0.5) 2.5
drawRects
flush
processHits maybeHitRecords
postRedisplay Nothing
pickRects (Char '\27') Down _ _ = exitWith ExitSuccess
pickRects _ _ _ _ = return ()
display :: DisplayCallback
display = do
clear [ ColorBuffer, DepthBuffer ]
drawRects
flush
reshape :: ReshapeCallback
reshape size = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
ortho 0 8 0 8 (-0.5) 2.5
matrixMode $= Modelview 0
loadIdentity
-- Main Loop
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 200 200
initialWindowPosition $= Position 100 100
createWindow progName
myInit
reshapeCallback $= Just reshape
displayCallback $= display
keyboardMouseCallback $= Just pickRects
mainLoop
|
