GLUT-2.5.0.0: examples/RedBook4/ShadowMap.hs
{-
ShadowMap.hs (adapted from shadowmap.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
-}
import Control.Monad ( when, unless )
import Data.IORef ( IORef, newIORef )
import Foreign.Marshal.Array ( allocaArray )
import Foreign.Ptr ( nullPtr )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
shadowMapSize :: TextureSize2D
shadowMapSize = TextureSize2D 256 256
fovy, nearPlane, farPlane :: GLdouble
fovy = 60
nearPlane = 10
farPlane = 100
lightPos :: Vertex4 GLfloat
lightPos = Vertex4 25 25 25 1
lookat :: Vertex3 GLdouble
lookat = Vertex3 0 0 0
up :: Vector3 GLdouble
up = Vector3 0 0 1
data State = State {
angle :: IORef GLdouble,
torusAngle :: IORef GLfloat,
showShadow :: IORef Bool,
animate :: IORef Bool,
funcMode :: IORef ComparisonFunction }
makeState :: IO State
makeState = do
a <- newIORef 0
t <- newIORef 0
s <- newIORef False
n <- newIORef True
f <- newIORef Lequal
return $ State { angle = a, torusAngle = t, showShadow = s,
animate = n, funcMode = f }
myInit :: IO ()
myInit = do
texImage2D Texture2D NoProxy 0 DepthComponent' shadowMapSize 0
(PixelData DepthComponent UnsignedByte nullPtr)
position (Light 0) $= lightPos
let white = Color4 1 1 1 1
specular (Light 0) $= white
diffuse (Light 0) $= white
textureWrapMode Texture2D S $= (Repeated, ClampToEdge)
textureWrapMode Texture2D T $= (Repeated, ClampToEdge)
textureFilter Texture2D $= ((Linear', Nothing), Linear')
textureCompareMode Texture2D $= Just Lequal
depthTextureMode Texture2D $= Luminance'
colorMaterial $= Just (FrontAndBack, AmbientAndDiffuse)
cullFace $= Just Back
depthFunc $= Just Less
light (Light 0) $= Enabled
lighting $= Enabled
texture Texture2D $= Enabled
reshape :: ReshapeCallback
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
perspective fovy (fromIntegral w / fromIntegral h) nearPlane farPlane
matrixMode $= Modelview 0
idle :: State -> IdleCallback
idle state = do
angle state $~! (+ (pi / 10000))
torusAngle state $~! (+ 0.1)
postRedisplay Nothing
keyboard :: State -> KeyboardMouseCallback
keyboard state (Char c) Down _ _ = do
case c of
'\27' -> exitWith ExitSuccess
't' ->
texture Texture2D $~ \cap -> if cap == Enabled then Disabled else Enabled
'm' -> do
fm <- get (funcMode state)
textureCompareMode Texture2D $~ maybe (Just fm) (const Nothing)
compareMode <- get (textureCompareMode Texture2D)
putStrLn ("Compare mode " ++ maybe "Off" (const "On") compareMode)
'f' -> do
funcMode state $~ \fm -> if fm == Lequal then Gequal else Lequal
fm <- get (funcMode state)
putStrLn ("Operator " ++ show fm)
textureCompareMode Texture2D $~ maybe Nothing (const (Just fm))
's' -> showShadow state $~ not
'p' -> do
animate state $~ not
animate' <- get (animate state)
idleCallback $= if animate' then Just (idle state) else Nothing
_ -> return ()
postRedisplay Nothing
keyboard _ _ _ _ _ = return ()
drawObjects :: GLfloat -> Bool -> IO ()
drawObjects torusAngle' shadowRender = do
textureOn <- get (texture Texture2D)
when shadowRender $
texture Texture2D $= Disabled
-- resolve overloading, not needed in "real" programs
let normal3f = normal :: Normal3 GLfloat -> IO ()
color3f = color :: Color3 GLfloat -> IO ()
rectf = rect :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO ()
translatef = translate :: Vector3 GLfloat -> IO ()
rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO ()
unless shadowRender $ do
normal3f (Normal3 0 0 1)
color3f (Color3 1 1 1)
rectf (Vertex2 (-20) (-20)) (Vertex2 20 20)
preservingMatrix $ do
translatef (Vector3 11 11 11)
rotatef 54.73 (Vector3 (-5) 5 0)
rotate torusAngle' (Vector3 1 0 0)
color3f (Color3 1 0 0)
renderObject Solid (Torus 1 4 8 36)
preservingMatrix $ do
translatef (Vector3 2 2 2)
color3f (Color3 0 0 1)
renderObject Solid (Cube 4)
preservingMatrix $ do
getLightPos Vector3 >>= translate
color3f (Color3 1 1 1)
renderObject Wireframe (Sphere' 0.5 6 6)
when (shadowRender && textureOn == Enabled) $
texture Texture2D $= Enabled
getLightPos :: (GLdouble -> GLdouble -> GLdouble -> a) -> IO a
getLightPos f = do
Vertex4 x y z _ <- get (position (Light 0))
return $ f (realToFrac x) (realToFrac y) (realToFrac z)
generateShadowMap :: GLfloat -> Bool -> IO ()
generateShadowMap torusAngle' showShadow' = do
lightPos' <- getLightPos Vertex3
let (TextureSize2D shadowMapWidth shadowMapHeight) = shadowMapSize
shadowMapSize' = Size shadowMapWidth shadowMapHeight
preservingViewport $ do
viewport $= (Position 0 0, shadowMapSize')
clear [ ColorBuffer, DepthBuffer ]
matrixMode $= Projection
preservingMatrix $ do
loadIdentity
perspective 80 1 10 1000
matrixMode $= Modelview 0
preservingMatrix $ do
loadIdentity
lookAt lightPos' lookat up
drawObjects torusAngle' True
matrixMode $= Projection
matrixMode $= Modelview 0
copyTexImage2D Texture2D 0 DepthComponent' (Position 0 0) shadowMapSize 0
when showShadow' $ do
let numShadowMapPixels = fromIntegral (shadowMapWidth * shadowMapHeight)
allocaArray numShadowMapPixels $ \depthImage -> do
let pixelData fmt = PixelData fmt Float depthImage :: PixelData GLfloat
readPixels (Position 0 0) shadowMapSize' (pixelData DepthComponent)
(_, Size viewPortWidth _) <- get viewport
windowPos (Vertex2 (fromIntegral viewPortWidth / 2 :: GLfloat) 0)
drawPixels shadowMapSize' (pixelData Luminance)
swapBuffers
-- Note: preservingViewport is not exception safe, but it doesn't matter here
preservingViewport :: IO a -> IO a
preservingViewport act = do
v <- get viewport
x <- act
viewport $= v
return x
generateTextureMatrix :: IO ()
generateTextureMatrix = do
-- Set up projective texture matrix. We use the Modelview matrix stack and
-- OpenGL matrix commands to make the matrix.
m <- preservingMatrix $ do
loadIdentity
-- resolve overloading, not needed in "real" programs
let translatef = translate :: Vector3 GLfloat -> IO ()
scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO ()
translatef (Vector3 0.5 0.5 0.0)
scalef 0.5 0.5 1.0
perspective 60 1 1 1000
lightPos' <- getLightPos Vertex3
lookAt lightPos' lookat up
get (matrix (Just (Modelview 0)))
[ sx, sy, sz, sw,
tx, ty, tz, tw,
rx, ry, rz, rw,
qx, qy, qz, qw ] <- getMatrixComponents RowMajor (m :: GLmatrix GLdouble)
textureGenMode S $= Just (ObjectLinear (Plane sx sy sz sw))
textureGenMode T $= Just (ObjectLinear (Plane tx ty tz tw))
textureGenMode R $= Just (ObjectLinear (Plane rx ry rz rw))
textureGenMode Q $= Just (ObjectLinear (Plane qx qy qz qw))
display :: State -> DisplayCallback
display state = do
let radius = 30
torusAngle' <- get (torusAngle state)
showShadow' <- get (showShadow state)
generateShadowMap torusAngle' showShadow'
generateTextureMatrix
unless showShadow' $ do
clear [ ColorBuffer, DepthBuffer ]
preservingMatrix $ do
angle' <- get (angle state)
lookAt (Vertex3 (radius * cos angle') (radius * sin angle') 30) lookat up
drawObjects torusAngle' False
swapBuffers
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ RGBAMode, WithDepthBuffer, DoubleBuffered ]
initialWindowSize $= Size 521 512
initialWindowPosition $= Position 100 100
_ <- createWindow progName
state <- makeState
myInit
displayCallback $= display state
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboard state)
idleCallback $= Just (idle state)
mainLoop