GLUT-2.7.0.13: examples/RedBook4/AccPersp.hs
{-
AccPersp.hs (adapted from accpersp.c which is (c) Silicon Graphics, Inc.)
Copyright (c) Sven Panne 2002-2018 <svenpanne@gmail.com>
This file is part of HOpenGL and distributed under a BSD-style license
See the file libraries/GLUT/LICENSE
Use the accumulation buffer to do full-scene antialiasing on a scene with
perspective projection, using the special routines accFrustum and
accPerspective.
-}
import Data.List ( genericLength )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
-- j8 contains values in the range -.5 < x < .5, -.5 < y < .5, and have a
-- gaussian distribution around the origin. Use these to do model jittering for
-- scene anti-aliasing and view volume jittering for depth of field effects. Use
-- in conjunction with the accwindow routine.
j8 :: [Vector2 GLdouble]
j8 = [
Vector2 (-0.334818) 0.435331 ,
Vector2 0.286438 (-0.393495),
Vector2 0.459462 0.141540 ,
Vector2 (-0.414498) (-0.192829),
Vector2 (-0.183790) 0.082102 ,
Vector2 (-0.079263) (-0.317383),
Vector2 0.102254 0.299133 ,
Vector2 0.164216 (-0.054399) ]
-- The first 6 arguments are identical to the frustum call. pixD is anti-alias
-- jitter in pixels. Use (Vector2 0 0) for no anti-alias jitter. eyeD is
-- depth-of field jitter in pixels. Use (Vector2 0 0) for no depth of field
-- effects. focus is distance from eye to plane in focus. focus must be greater
-- than, but not equal to 0. Note that accFrustum calls translate. You will
-- probably want to insure that your ModelView matrix has been initialized to
-- identity before calling accFrustum.
accFrustum :: GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble
-> Vector2 GLdouble -> Vector2 GLdouble -> GLdouble -> IO ()
accFrustum left right bottom top zNear zFar
(Vector2 pixDx pixDy) (Vector2 eyeDx eyeDy) focus = do
(_, Size w h) <- get viewport
let xWSize = right - left;
yWSize = top - bottom;
dx = -(pixDx * xWSize / fromIntegral w + eyeDx * zNear / focus)
dy = -(pixDy * yWSize / fromIntegral h + eyeDy * zNear / focus)
matrixMode $= Projection
loadIdentity
frustum (left + dx) (right + dx) (bottom + dy) (top + dy) zNear zFar
matrixMode $= Modelview 0
loadIdentity
translate (Vector3 (-eyeDx) (-eyeDy) 0)
-- The first 4 arguments are identical to the perspective call. pixD is
-- anti-alias jitter in pixels. Use (Vector2 0 0) for no anti-alias jitter. eyeD
-- is depth-of field jitter in pixels. Use (Vector2 0 0) for no depth of field
-- effects. focus is distance from eye to plane in focus. focus must be greater
-- than, but not equal to 0. Note that accPerspective calls accFrustum.
accPerspective :: GLdouble -> GLdouble -> GLdouble -> GLdouble
-> Vector2 GLdouble -> Vector2 GLdouble -> GLdouble -> IO ()
accPerspective fovY aspect zNear zFar pixD eyeD focus = do
let fov2 = ((fovY * pi) / 180) / 2
top = zNear / (cos fov2 / sin fov2)
bottom = -top
right = top * aspect
left = -right
accFrustum left right bottom top zNear zFar pixD eyeD focus
-- Initialize lighting and other values.
myInit :: IO ()
myInit = do
materialAmbient Front $= Color4 1 1 1 1
materialSpecular Front $= Color4 1 1 1 1
materialShininess Front $= 50
position (Light 0) $= Vertex4 0 0 10 1
lightModelAmbient $= Color4 0.2 0.2 0.2 1
lighting $= Enabled
light (Light 0) $= Enabled
depthFunc $= Just Less
shadeModel $= Flat
clearColor $= Color4 0 0 0 0
clearAccum $= Color4 0 0 0 0
displayObjects :: IO ()
displayObjects = do
-- resolve overloading, not needed in "real" programs
let translatef = translate :: Vector3 GLfloat -> IO ()
rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO ()
preservingMatrix $ do
translatef (Vector3 0 0 (-5))
rotatef 30 (Vector3 1 0 0)
preservingMatrix $ do
translatef (Vector3 (-0.80) 0.35 0)
rotatef 100 (Vector3 1 0 0)
materialDiffuse Front $= Color4 0.7 0.7 0 1
renderObject Solid (Torus 0.275 0.85 16 16)
preservingMatrix $ do
translatef (Vector3 (-0.75) (-0.50) 0)
rotatef 45 (Vector3 0 0 1)
rotatef 45 (Vector3 1 0 0)
materialDiffuse Front $= Color4 0 0.7 0.7 1
renderObject Solid (Cube 1.5)
preservingMatrix $ do
translatef (Vector3 0.75 0.60 0)
rotatef 30 (Vector3 1 0 0)
materialDiffuse Front $= Color4 0.7 0 0.7 1
renderObject Solid (Sphere' 1 16 16)
preservingMatrix $ do
translatef (Vector3 0.70 (-0.90) 0.25)
materialDiffuse Front $= Color4 0.7 0.4 0.4 1
renderObject Solid Octahedron
-- display draws 5 teapots into the accumulation buffer several times; each time
-- with a jittered perspective. The focal point is at z = 5.0, so the gold
-- teapot will stay in focus. The amount of jitter is adjusted by the magnitude
-- of the accPerspective jitter; in this example, 0.33. In this example, the
-- teapots are drawn 8 times.
display :: DisplayCallback
display = do
(_, Size w h) <- get viewport
clear [ AccumBuffer ]
flip mapM_ j8 $ \(Vector2 x y) -> do
clear [ ColorBuffer, DepthBuffer ]
accPerspective 50 (fromIntegral w / fromIntegral h) 1 15
(Vector2 x y) (Vector2 0 0) 1
displayObjects
accum Accum (recip (genericLength j8))
accum Return 1
flush
reshape :: ReshapeCallback
reshape size = do
viewport $= (Position 0 0, size)
keyboard :: KeyboardMouseCallback
keyboard (Char '\27') Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ = return ()
-- Main Loop: Be certain you request an accumulation buffer.
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode, WithAccumBuffer, WithDepthBuffer ]
initialWindowSize $= Size 250 250
initialWindowPosition $= Position 100 100
_ <- createWindow progName
myInit
reshapeCallback $= Just reshape
displayCallback $= display
keyboardMouseCallback $= Just keyboard
mainLoop