{-
Select.hs (adapted from select.c which is (c) Silicon Graphics, Inc.)
Copyright (c) Sven Panne 2002-2005 <svenpanne@gmail.com>
This file is part of HOpenGL and distributed under a BSD-style license
See the file libraries/GLUT/LICENSE
Select.hs (adapted from select.c which is (c) Silicon Graphics, Inc.)
Copyright (c) Sven Panne 2002-2005 <svenpanne@gmail.com>
This file is part of HOpenGL and distributed under a BSD-style license
See the file libraries/GLUT/LICENSE
This is an illustration of the selection mode and name stack, which detects
whether objects which collide with a viewing volume. First, four triangles
and a rectangular box representing a viewing volume are drawn (drawScene
routine). The green triangle and yellow triangles appear to lie within the
viewing volume, but the red triangle appears to lie outside it. Then the
selection mode is entered (selectObjects routine). Drawing to the screen
ceases. To see if any collisions occur, the four triangles are called. In
this example, the green triangle causes one hit with the name 1, and the
yellow triangles cause one hit with the name 3.
-}
whether objects which collide with a viewing volume. First, four triangles
and a rectangular box representing a viewing volume are drawn (drawScene
routine). The green triangle and yellow triangles appear to lie within the
viewing volume, but the red triangle appears to lie outside it. Then the
selection mode is entered (selectObjects routine). Drawing to the screen
ceases. To see if any collisions occur, the four triangles are called. In
this example, the green triangle causes one hit with the name 1, and the
yellow triangles cause one hit with the name 3.
-}
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
import Graphics.UI.GLUT
— draw a triangle with vertices at (x1, y1), (x2, y2) and (x3, y3) at z units
— away from the origin.
drawTriangle ::
Vertex2 GLfloat -> Vertex2 GLfloat -> Vertex2 GLfloat -> GLfloat -> IO ()
drawTriangle (Vertex2 x1 y1) (Vertex2 x2 y2) (Vertex2 x3 y3) z = do
renderPrimitive Triangles $ mapM_ vertex [
Vertex3 x1 y1 z,
Vertex3 x2 y2 z,
Vertex3 x3 y3 z]
— away from the origin.
drawTriangle ::
Vertex2 GLfloat -> Vertex2 GLfloat -> Vertex2 GLfloat -> GLfloat -> IO ()
drawTriangle (Vertex2 x1 y1) (Vertex2 x2 y2) (Vertex2 x3 y3) z = do
renderPrimitive Triangles $ mapM_ vertex [
Vertex3 x1 y1 z,
Vertex3 x2 y2 z,
Vertex3 x3 y3 z]
— draw a rectangular box with these outer x, y, and z values
drawViewVolume :: Vertex3 GLfloat -> Vertex3 GLfloat -> IO ()
drawViewVolume (Vertex3 x1 y1 z1) (Vertex3 x2 y2 z2) = do
— resolve overloading, not needed in “real” programs
let color3f = color :: Color3 GLfloat -> IO ()
color3f (Color3 1 1 1)
renderPrimitive LineLoop $ mapM_ vertex [
Vertex3 x1 y1 (-z1),
Vertex3 x2 y1 (-z1),
Vertex3 x2 y2 (-z1),
Vertex3 x1 y2 (-z1)]
drawViewVolume :: Vertex3 GLfloat -> Vertex3 GLfloat -> IO ()
drawViewVolume (Vertex3 x1 y1 z1) (Vertex3 x2 y2 z2) = do
— resolve overloading, not needed in “real” programs
let color3f = color :: Color3 GLfloat -> IO ()
color3f (Color3 1 1 1)
renderPrimitive LineLoop $ mapM_ vertex [
Vertex3 x1 y1 (-z1),
Vertex3 x2 y1 (-z1),
Vertex3 x2 y2 (-z1),
Vertex3 x1 y2 (-z1)]
renderPrimitive LineLoop $ mapM_ vertex [
Vertex3 x1 y1 (-z2),
Vertex3 x2 y1 (-z2),
Vertex3 x2 y2 (-z2),
Vertex3 x1 y2 (-z2)]
Vertex3 x1 y1 (-z2),
Vertex3 x2 y1 (-z2),
Vertex3 x2 y2 (-z2),
Vertex3 x1 y2 (-z2)]
renderPrimitive Lines $ mapM_ vertex [ — 4 lines
Vertex3 x1 y1 (-z1),
Vertex3 x1 y1 (-z2),
Vertex3 x1 y2 (-z1),
Vertex3 x1 y2 (-z2),
Vertex3 x2 y1 (-z1),
Vertex3 x2 y1 (-z2),
Vertex3 x2 y2 (-z1),
Vertex3 x2 y2 (-z2)]
Vertex3 x1 y1 (-z1),
Vertex3 x1 y1 (-z2),
Vertex3 x1 y2 (-z1),
Vertex3 x1 y2 (-z2),
Vertex3 x2 y1 (-z1),
Vertex3 x2 y1 (-z2),
Vertex3 x2 y2 (-z1),
Vertex3 x2 y2 (-z2)]
— drawScene draws 4 triangles and a wire frame which represents the viewing
— volume.
drawScene :: IO ()
drawScene = do
matrixMode $= Projection
loadIdentity
perspective 40 (4/3) 1 100
— volume.
drawScene :: IO ()
drawScene = do
matrixMode $= Projection
loadIdentity
perspective 40 (4/3) 1 100
matrixMode $= Modelview 0
loadIdentity
lookAt (Vertex3 7.5 7.5 12.5) (Vertex3 2.5 2.5 (-5)) (Vector3 0 1 0)
— resolve overloading, not needed in “real” programs
let color3f = color :: Color3 GLfloat -> IO ()
color3f (Color3 0 1 0) — green triangle
drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-5)
color3f (Color3 1 0 0) — red triangle
drawTriangle (Vertex2 2 7) (Vertex2 3 7) (Vertex2 2.5 8) (-5)
color3f (Color3 1 1 0) — yellow triangles
drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-1)
drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-9)
drawViewVolume (Vertex3 0 0 0) (Vertex3 5 5 10)
loadIdentity
lookAt (Vertex3 7.5 7.5 12.5) (Vertex3 2.5 2.5 (-5)) (Vector3 0 1 0)
— resolve overloading, not needed in “real” programs
let color3f = color :: Color3 GLfloat -> IO ()
color3f (Color3 0 1 0) — green triangle
drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-5)
color3f (Color3 1 0 0) — red triangle
drawTriangle (Vertex2 2 7) (Vertex2 3 7) (Vertex2 2.5 8) (-5)
color3f (Color3 1 1 0) — yellow triangles
drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-1)
drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-9)
drawViewVolume (Vertex3 0 0 0) (Vertex3 5 5 10)
processHits :: Maybe [HitRecord] -> IO ()
processHits Nothing = putStrLn “selection buffer overflow”
processHits (Just hitRecords) = do
putStrLn (“hits = ” ++ show (length hitRecords))
mapM_ (\(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’)
hitRecords
processHits Nothing = putStrLn “selection buffer overflow”
processHits (Just hitRecords) = do
putStrLn (“hits = ” ++ show (length hitRecords))
mapM_ (\(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’)
hitRecords
— selectObjects “draws” the triangles in selection mode, assigning names for
— the triangles. Note that the third and fourth triangles share one name, so
— that if either or both triangles intersects the viewing/clipping volume,
— only one hit will be registered.
— the triangles. Note that the third and fourth triangles share one name, so
— that if either or both triangles intersects the viewing/clipping volume,
— only one hit will be registered.
bufSize :: GLsizei
bufSize = 512
bufSize = 512
selectObjects :: IO ()
selectObjects = do
(_, maybeHitRecords) <- getHitRecords bufSize $ do
withName (Name 0) $ do
preservingMatrix $ do
matrixMode $= Projection
loadIdentity
ortho 0 5 0 5 0 10
matrixMode $= Modelview 0
loadIdentity
loadName (Name 1)
drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-5)
loadName (Name 2)
drawTriangle (Vertex2 2 7) (Vertex2 3 7) (Vertex2 2.5 8) (-5)
loadName (Name 3)
drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-1)
drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-9)
flush
processHits maybeHitRecords
selectObjects = do
(_, maybeHitRecords) <- getHitRecords bufSize $ do
withName (Name 0) $ do
preservingMatrix $ do
matrixMode $= Projection
loadIdentity
ortho 0 5 0 5 0 10
matrixMode $= Modelview 0
loadIdentity
loadName (Name 1)
drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-5)
loadName (Name 2)
drawTriangle (Vertex2 2 7) (Vertex2 3 7) (Vertex2 2.5 8) (-5)
loadName (Name 3)
drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-1)
drawTriangle (Vertex2 2 2) (Vertex2 3 2) (Vertex2 2.5 3) (-9)
flush
processHits maybeHitRecords
myInit :: IO ()
myInit = do
depthFunc $= Just Less
shadeModel $= Flat
myInit = do
depthFunc $= Just Less
shadeModel $= Flat
display :: DisplayCallback
display = do
clearColor $= Color4 0 0 0 0
clear [ ColorBuffer, DepthBuffer ]
drawScene
selectObjects
flush
display = do
clearColor $= Color4 0 0 0 0
clear [ ColorBuffer, DepthBuffer ]
drawScene
selectObjects
flush
keyboard :: KeyboardMouseCallback
keyboard (Char ‘\27’) Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ = return ()
keyboard (Char ‘\27’) Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ = return ()
— Main Loop
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 200 200
initialWindowPosition $= Position 100 100
_ <- createWindow progName
myInit
displayCallback $= display
keyboardMouseCallback $= Just keyboard
mainLoop
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 200 200
initialWindowPosition $= Position 100 100
_ <- createWindow progName
myInit
displayCallback $= display
keyboardMouseCallback $= Just keyboard
mainLoop
{-
PickSquare.hs (adapted from picksquare.c which is (c) Silicon Graphics, Inc.)
Copyright (c) Sven Panne 2002-2005 <svenpanne@gmail.com>
This file is part of HOpenGL and distributed under a BSD-style license
See the file libraries/GLUT/LICENSE
PickSquare.hs (adapted from picksquare.c which is (c) Silicon Graphics, Inc.)
Copyright (c) Sven Panne 2002-2005 <svenpanne@gmail.com>
This file is part of HOpenGL and distributed under a BSD-style license
See the file libraries/GLUT/LICENSE
Use of multiple names and picking are demonstrated. A 3×3 grid of squares is
drawn. When the left mouse button is pressed, all squares under the cursor
position have their color changed.
-}
drawn. When the left mouse button is pressed, all squares under the cursor
position have their color changed.
-}
import Data.Array ( Array, listArray, (!) )
import Data.IORef ( IORef, newIORef )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
import Data.IORef ( IORef, newIORef )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
type Board = Array (Int,Int) (IORef Int)
data State = State { board :: Board }
makeState :: IO State
makeState = do
refs <- sequence . replicate 9 . newIORef $ 0
return $ State { board = listArray ((0,0),(2,2)) refs }
makeState = do
refs <- sequence . replicate 9 . newIORef $ 0
return $ State { board = listArray ((0,0),(2,2)) refs }
— Clear color value for every square on the board
myInit :: IO ()
myInit = do
clearColor $= Color4 0 0 0 0
myInit :: IO ()
myInit = do
clearColor $= Color4 0 0 0 0
— 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.
drawSquares :: State -> IO ()
drawSquares state =
flip mapM_ [ 0 .. 2 ] $ \i -> do
loadName (Name (fromIntegral i))
flip mapM_ [ 0 .. 2 ] $ \j ->
withName (Name (fromIntegral j)) $ do
val <- get (board state ! (i,j))
— resolve overloading, not needed in “real” programs
let color3f = color :: Color3 GLfloat -> IO ()
color3f (Color3 (fromIntegral i / 3.0)
(fromIntegral j / 3.0)
(fromIntegral val / 3.0))
let vertex2i :: Int -> Int -> Vertex2 GLint
vertex2i x y = Vertex2 (fromIntegral x) (fromIntegral y)
rect (vertex2i i j) (vertex2i (i + 1) (j + 1))
— 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.
drawSquares :: State -> IO ()
drawSquares state =
flip mapM_ [ 0 .. 2 ] $ \i -> do
loadName (Name (fromIntegral i))
flip mapM_ [ 0 .. 2 ] $ \j ->
withName (Name (fromIntegral j)) $ do
val <- get (board state ! (i,j))
— resolve overloading, not needed in “real” programs
let color3f = color :: Color3 GLfloat -> IO ()
color3f (Color3 (fromIntegral i / 3.0)
(fromIntegral j / 3.0)
(fromIntegral val / 3.0))
let vertex2i :: Int -> Int -> Vertex2 GLint
vertex2i x y = Vertex2 (fromIntegral x) (fromIntegral y)
rect (vertex2i i j) (vertex2i (i + 1) (j + 1))
— processHits prints the hit records and updates the board array.
processHits :: Maybe[HitRecord] -> State -> IO ()
processHits Nothing _ = putStrLn “selection buffer overflow”
processHits (Just hitRecords) state = do
putStrLn (“hits = ” ++ show (length hitRecords))
mapM_ (\(HitRecord z1 z2 names) -> do
putStrLn (” number of names for this hit = ” ++ show (length names))
putStr (” z1 is ” ++ show z1)
putStrLn (“; z2 is ” ++ show z2)
putStr ” names are”
sequence_ [ putStr (” ” ++ show n) | Name n <- names ]
putChar ‘\n’
let [i, j] = [ fromIntegral n | Name n <- names ]
(board state ! (i,j)) $~ (\x -> (x + 1) `mod` 3))
hitRecords
processHits :: Maybe[HitRecord] -> State -> IO ()
processHits Nothing _ = putStrLn “selection buffer overflow”
processHits (Just hitRecords) state = do
putStrLn (“hits = ” ++ show (length hitRecords))
mapM_ (\(HitRecord z1 z2 names) -> do
putStrLn (” number of names for this hit = ” ++ show (length names))
putStr (” z1 is ” ++ show z1)
putStrLn (“; z2 is ” ++ show z2)
putStr ” names are”
sequence_ [ putStr (” ” ++ show n) | Name n <- names ]
putChar ‘\n’
let [i, j] = [ fromIntegral n | Name n <- names ]
(board state ! (i,j)) $~ (\x -> (x + 1) `mod` 3))
hitRecords
— pickSquares sets up selection mode, name stack, and projection matrix for
— picking. Then the objects are drawn.
— picking. Then the objects are drawn.
bufSize :: GLsizei
bufSize = 512
bufSize = 512
pickSquares :: State -> KeyboardMouseCallback
pickSquares state (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 5×5 pixel picking region near cursor location
pickMatrix (fromIntegral x, fromIntegral height – fromIntegral y) (5, 5) vp
ortho2D 0 3 0 3
drawSquares state
flush
processHits maybeHitRecords state
postRedisplay Nothing
pickSquares _ (Char ‘\27’) Down _ _ = exitWith ExitSuccess
pickSquares _ _ _ _ _ = return ()
pickSquares state (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 5×5 pixel picking region near cursor location
pickMatrix (fromIntegral x, fromIntegral height – fromIntegral y) (5, 5) vp
ortho2D 0 3 0 3
drawSquares state
flush
processHits maybeHitRecords state
postRedisplay Nothing
pickSquares _ (Char ‘\27’) Down _ _ = exitWith ExitSuccess
pickSquares _ _ _ _ _ = return ()
display :: State -> DisplayCallback
display state = do
clear [ ColorBuffer ]
drawSquares state
flush
display state = do
clear [ ColorBuffer ]
drawSquares state
flush
reshape :: ReshapeCallback
reshape size = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
ortho2D 0 3 0 3
matrixMode $= Modelview 0
loadIdentity
reshape size = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
ortho2D 0 3 0 3
matrixMode $= Modelview 0
loadIdentity
— Main Loop
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode ]
initialWindowSize $= Size 100 100
initialWindowPosition $= Position 100 100
_ <- createWindow progName
state <- makeState
myInit
reshapeCallback $= Just reshape
displayCallback $= display state
keyboardMouseCallback $= Just (pickSquares state)
mainLoop
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode ]
initialWindowSize $= Size 100 100
initialWindowPosition $= Position 100 100
_ <- createWindow progName
state <- makeState
myInit
reshapeCallback $= Just reshape
displayCallback $= display state
keyboardMouseCallback $= Just (pickSquares state)
mainLoop
{-
PickDepth.hs (adapted from pickdepth.c which is (c) Silicon Graphics, Inc.)
Copyright (c) Sven Panne 2002-2005 <svenpanne@gmail.com>
This file is part of HOpenGL and distributed under a BSD-style license
See the file libraries/GLUT/LICENSE
PickDepth.hs (adapted from pickdepth.c which is (c) Silicon Graphics, Inc.)
Copyright (c) Sven Panne 2002-2005 <svenpanne@gmail.com>
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.
-}
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
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
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.
— 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))
— 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’
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.
— picking. Then the objects are drawn.
bufSize :: GLsizei
bufSize = 512
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 5×5 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 ()
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 5×5 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
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
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
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
{-
Feedback.hs (adapted from feedback.c which is (c) Silicon Graphics, Inc.)
Copyright (c) Sven Panne 2002-2005 <svenpanne@gmail.com>
This file is part of HOpenGL and distributed under a BSD-style license
See the file libraries/GLUT/LICENSE
Feedback.hs (adapted from feedback.c which is (c) Silicon Graphics, Inc.)
Copyright (c) Sven Panne 2002-2005 <svenpanne@gmail.com>
This file is part of HOpenGL and distributed under a BSD-style license
See the file libraries/GLUT/LICENSE
This program demonstrates use of OpenGL feedback. First, a lighting
environment is set up and a few lines are drawn. Then feedback mode is
entered, and the same lines are drawn. The results in the feedback buffer are
printed.
-}
environment is set up and a few lines are drawn. Then feedback mode is
entered, and the same lines are drawn. The results in the feedback buffer are
printed.
-}
import Control.Monad ( when )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
— Initialize lighting.
myInit :: IO ()
myInit = do
lighting $= Enabled
light (Light 0) $= Enabled
myInit :: IO ()
myInit = do
lighting $= Enabled
light (Light 0) $= Enabled
— Draw a few lines and two points, one of which will be clipped. If in feedback
— mode, a passthrough token is issued between each primitive
drawGeometry :: IO ()
drawGeometry = do
mode <- get renderMode
— resolve overloading, not needed in “real” programs
let normal3f = normal :: Normal3 GLfloat -> IO ()
vertex3f = vertex :: Vertex3 GLfloat -> IO ()
renderPrimitive LineStrip $ do
normal3f (Normal3 0 0 1)
vertex3f (Vertex3 30 30 0)
vertex3f (Vertex3 50 60 0)
vertex3f (Vertex3 70 40 0)
when (mode == Feedback) $
passThrough (PassThroughValue 1)
renderPrimitive Points $
vertex3f (Vertex3 (-100) (-100) (-100)) — will be clipped
when (mode == Feedback) $
passThrough (PassThroughValue 2)
renderPrimitive Points $ do
normal3f (Normal3 0 0 1)
vertex3f (Vertex3 50 50 0)
flush — not in original example
— mode, a passthrough token is issued between each primitive
drawGeometry :: IO ()
drawGeometry = do
mode <- get renderMode
— resolve overloading, not needed in “real” programs
let normal3f = normal :: Normal3 GLfloat -> IO ()
vertex3f = vertex :: Vertex3 GLfloat -> IO ()
renderPrimitive LineStrip $ do
normal3f (Normal3 0 0 1)
vertex3f (Vertex3 30 30 0)
vertex3f (Vertex3 50 60 0)
vertex3f (Vertex3 70 40 0)
when (mode == Feedback) $
passThrough (PassThroughValue 1)
renderPrimitive Points $
vertex3f (Vertex3 (-100) (-100) (-100)) — will be clipped
when (mode == Feedback) $
passThrough (PassThroughValue 2)
renderPrimitive Points $ do
normal3f (Normal3 0 0 1)
vertex3f (Vertex3 50 50 0)
flush — not in original example
printBuffer :: Maybe [FeedbackToken] -> IO ()
printBuffer = maybe (putStrLn “feedback buffer overflow”) (mapM_ print)
printBuffer = maybe (putStrLn “feedback buffer overflow”) (mapM_ print)
display :: DisplayCallback
display = do
matrixMode $= Projection
loadIdentity
ortho 0 100 0 100 0 1
display = do
matrixMode $= Projection
loadIdentity
ortho 0 100 0 100 0 1
clearColor $= Color4 0 0 0 0
clear [ ColorBuffer ]
drawGeometry
clear [ ColorBuffer ]
drawGeometry
(_, tokens) <- getFeedbackTokens 1024 ThreeDColor drawGeometry
printBuffer tokens
printBuffer tokens
keyboard :: KeyboardMouseCallback
keyboard (Char ‘\27’) Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ = return ()
keyboard (Char ‘\27’) Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ = return ()
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode ]
initialWindowSize $= Size 100 100
initialWindowPosition $= Position 100 100
_ <- createWindow progName
myInit
displayCallback $= display
keyboardMouseCallback $= Just keyboard
mainLoop
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode ]
initialWindowSize $= Size 100 100
initialWindowPosition $= Position 100 100
_ <- createWindow progName
myInit
displayCallback $= display
keyboardMouseCallback $= Just keyboard
mainLoop
InfoCad Blog 