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
|
{-
Alpha3D.hs (adapted from alpha3D.c which is (c) Silicon Graphics, Inc.)
Copyright (c) Sven Panne 2002-2006 <sven.panne@aedion.de>
This file is part of HOpenGL and distributed under a BSD-style license
See the file libraries/GLUT/LICENSE
This program demonstrates how to intermix opaque and alpha blended polygons
in the same scene, by using depthMask. Press the 'a' key to animate moving
the transparent object through the opaque object. Press the 'r' key to reset
the scene.
-}
import Data.Char ( toLower )
import Data.IORef ( IORef, newIORef )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
maxZ, minZ, zInc :: GLfloat
maxZ = 8
minZ = -8
zInc = 0.4
-- We don't animate via the idle callback, because this is way too fast on
-- modern computers. A timer with the delay below is used instead for redraw.
delay :: Timeout
delay = 100
data State = State { solidZ, transparentZ :: IORef GLfloat }
makeState :: IO State
makeState = do
s <- newIORef maxZ
t <- newIORef minZ
return $ State { solidZ = s, transparentZ = t }
data DisplayLists = DisplayLists { sphereList, cubeList :: DisplayList }
myInit :: IO DisplayLists
myInit = do
materialSpecular Front $= Color4 1 1 1 0.15
materialShininess Front $= 100
position (Light 0) $= Vertex4 0.5 0.5 1 0
lighting $= Enabled
light (Light 0) $= Enabled
depthFunc $= Just Less
s <- defineNewList Compile $ renderObject Solid (Sphere' 0.4 16 16)
c <- defineNewList Compile $ renderObject Solid (Cube 0.6)
return $ DisplayLists { sphereList = s, cubeList = c }
display :: State -> DisplayLists -> DisplayCallback
display state displayLists = do
clear [ ColorBuffer, DepthBuffer ]
preservingMatrix $ do
s <- get (solidZ state)
translate (Vector3 (-0.15) (-0.15) s)
materialEmission Front $= Color4 0 0 0 1
materialDiffuse Front $= Color4 0.75 0.75 0 1
callList (sphereList displayLists)
preservingMatrix $ do
t <- get (transparentZ state)
translate (Vector3 (0.15) (0.15) t)
rotate (15 :: GLfloat) (Vector3 1 1 0)
rotate (30 :: GLfloat) (Vector3 0 1 0)
materialEmission Front $= Color4 0 0.3 0.3 0.6
materialDiffuse Front $= Color4 0 0.8 0.8 0.6
blend $= Enabled
depthMask $= Disabled
blendFunc $= (SrcAlpha, One)
callList (cubeList displayLists)
depthMask $= Enabled
blend $= Disabled
swapBuffers
reshape :: ReshapeCallback
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
let wf = fromIntegral w
hf = fromIntegral h
if w <= h
then ortho (-1.5) 1.5 (-1.5*hf/wf) (1.5*hf/wf) (-10) 10
else ortho (-1.5*wf/hf) (1.5*wf/hf) (-1.5) 1.5 (-10) 10
matrixMode $= Modelview 0
loadIdentity
animate :: State -> TimerCallback
animate state = do
s <- get (solidZ state)
t <- get (transparentZ state)
if (s <= minZ || t >= maxZ)
then idleCallback $= Nothing
else do
solidZ state $~ (+ (- zInc))
transparentZ state $~ (+ zInc)
addTimerCallback delay (animate state)
postRedisplay Nothing
keyboard :: State -> KeyboardMouseCallback
keyboard state (Char c) Down _ _ = case toLower c of
'a' -> do solidZ state $= maxZ; transparentZ state $= minZ; addTimerCallback delay (animate state)
'r' -> do solidZ state $= maxZ; transparentZ state $= minZ; postRedisplay Nothing
'\27' -> exitWith ExitSuccess
_ -> return ()
keyboard _ _ _ _ _ = return ()
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
-- The original C example uses single buffering, which flickers a lot.
initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 500 500
createWindow progName
state <- makeState
displayLists <- myInit
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboard state)
displayCallback $= display state displayLists
mainLoop
|
