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
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
|
{-
Combiner.hs (adapted from combiner.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
This program renders a variety of quads showing different effects of
texture combiner functions.
The first row renders an untextured polygon (so you can compare the
fragment colors) and then the 2 textures.
The second row shows several different combiner functions on a single
texture: replace, modulate, add, add-signed, and subtract.
The third row shows the interpolate combiner function on a single texture
with a constant color/alpha value, varying the amount of interpolation.
The fourth row uses multitexturing with two textures and different
combiner functions.
The fifth row are some combiner experiments: using the scaling factor and
reversing the order of subtraction for a combination function.
-}
import Data.Bits ( (.&.) )
import Foreign ( withArray )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
-- Create checkerboard image
imageSize :: TextureSize2D
imageSize = TextureSize2D 8 8
makeImage :: TextureSize2D -> (GLsizei -> GLsizei -> Color4 GLubyte)
-> (PixelData (Color4 GLubyte) -> IO ()) -> IO ()
makeImage (TextureSize2D w h) f act =
withArray [ f i j |
i <- [ 0 .. w - 1 ],
j <- [ 0 .. h - 1 ] ] $
act . PixelData RGBA UnsignedByte
myInit :: IO (TextureObject, TextureObject, DisplayList)
myInit = do
clearColor $= Color4 0 0 0 0
shadeModel $= Smooth
rowAlignment Unpack $= 1
[texName0, texName1] <- genObjectNames 2
textureBinding Texture2D $= Just texName0
textureWrapMode Texture2D S $= (Repeated, Repeat)
textureWrapMode Texture2D T $= (Repeated, Repeat)
textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
-- horiz b & w stripes
makeImage imageSize (\i _ -> let c = if i .&. 2 == 0 then 255 else 0 in Color4 c c c 255) $
texImage2D Nothing NoProxy 0 RGBA' imageSize 0
textureBinding Texture2D $= Just texName1
textureWrapMode Texture2D S $= (Repeated, Repeat)
textureWrapMode Texture2D T $= (Repeated, Repeat)
textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
textureFunction $= Decal
-- wider vertical 50% cyan and black stripes
makeImage imageSize (\_ j -> let c = if j .&. 4 /= 0 then 128 else 0 in Color4 0 c c 255) $
texImage2D Nothing NoProxy 0 RGBA' imageSize 0
-- smooth-shaded polygon with multiple texture coordinates
let vert :: TexCoord2 GLfloat -> Color3 GLfloat -> Vertex3 GLfloat -> IO ()
vert t c v = do
multiTexCoord (TextureUnit 0) t
multiTexCoord (TextureUnit 1) t
color c
vertex v
dl <- defineNewList Compile $
renderPrimitive Quads $ do
vert (TexCoord2 0 0) (Color3 0.5 1 0.25) (Vertex3 0 0 0)
vert (TexCoord2 0 2) (Color3 1 1 1 ) (Vertex3 0 1 0)
vert (TexCoord2 2 2) (Color3 1 1 1 ) (Vertex3 1 1 0)
vert (TexCoord2 2 0) (Color3 1 0.5 0.25) (Vertex3 1 0 0)
return (texName0, texName1, dl)
display :: (TextureObject, TextureObject, DisplayList) -> DisplayCallback
display (texName0, texName1, dl) = do
clear [ ColorBuffer ]
let drawAt :: GLfloat -> GLfloat -> IO ()
drawAt x y = preservingMatrix $ do
translate (Vector3 x y 0)
callList dl
-- untextured polygon -- see the "fragment" colors
texture Texture2D $= Disabled
drawAt 0 5
texture Texture2D $= Enabled
-- draw ordinary textured polys; 1 texture unit; combine mode disabled
textureFunction $= Modulate
textureBinding Texture2D $= Just texName0
drawAt 1 5
textureBinding Texture2D $= Just texName1
drawAt 2 5
-- different combine modes enabled; 1 texture unit
-- defaults are:
-- argRGB Arg0 $= Arg SrcColor CurrentUnit
-- argRGB Arg1 $= Arg SrcColor Previous
textureBinding Texture2D $= Just texName0
textureFunction $= Combine
combineRGB $= Replace'
argRGB Arg0 $= Arg SrcColor CurrentUnit
drawAt 1 4
combineRGB $= Modulate'
argRGB Arg1 $= Arg SrcColor Previous
drawAt 2 4
combineRGB $= AddUnsigned'
drawAt 3 4
combineRGB $= AddSigned
drawAt 4 4
combineRGB $= Subtract
drawAt 5 4
-- interpolate combine with constant color; 1 texture unit
-- use different alpha values for constant color
-- defaults are:
-- argRGB Arg0 $= Arg SrcColor CurrentUnit
-- argRGB Arg1 $= Arg SrcColor Previous
-- argRGB Arg2 $= Arg SrcAlpha Constant
constantColor $= Color4 0 0 0 0.2
textureBinding Texture2D $= Just texName0
textureFunction $= Combine
combineRGB $= Interpolate
argRGB Arg0 $= Arg SrcColor CurrentUnit
argRGB Arg1 $= Arg SrcColor Previous
argRGB Arg2 $= Arg SrcAlpha Constant
drawAt 1 3
constantColor $= Color4 0 0 0 0.4
drawAt 2 3
constantColor $= Color4 0 0 0 0.6
drawAt 3 3
constantColor $= Color4 0 0 0 0.8
drawAt 4 3
-- combine textures 0 & 1
-- defaults are:
-- argRGB Arg0 $= Arg SrcColor CurrentUnit
-- argRGB Arg1 $= Arg SrcColor Previous
activeTexture $= TextureUnit 0
texture Texture2D $= Enabled
textureBinding Texture2D $= Just texName0
textureFunction $= Modulate
activeTexture $= TextureUnit 1
texture Texture2D $= Enabled
textureBinding Texture2D $= Just texName1
textureFunction $= Combine
combineRGB $= Replace'
drawAt 1 2
-- try different combiner modes of texture unit 1
combineRGB $= Modulate'
drawAt 2 2
combineRGB $= AddUnsigned'
drawAt 3 2
combineRGB $= AddSigned
drawAt 4 2
combineRGB $= Subtract
drawAt 5 2
-- some experiments
-- see the effect of rgbScale
rgbScale $= 2
combineRGB $= Replace'
drawAt 1 1
combineRGB $= Modulate'
drawAt 2 1
rgbScale $= 1
-- reverse the order of subtraction Arg1-Arg0
textureFunction $= Combine
combineRGB $= Subtract
argRGB Arg0 $= Arg SrcColor Previous
argRGB Arg1 $= Arg SrcColor CurrentUnit
drawAt 5 1
activeTexture $= TextureUnit 1 -- deactivate multitexturing
texture Texture2D $= Disabled
activeTexture $= TextureUnit 0 -- activate single texture unit
flush
reshape :: ReshapeCallback
reshape size = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
ortho2D 0 7 0 7
matrixMode $= Modelview 0
loadIdentity
keyboard :: KeyboardMouseCallback
keyboard (Char '\27') Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ = return ()
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode ]
initialWindowSize $= Size 400 400
initialWindowPosition $= Position 100 100
createWindow progName
texNamesAndDL <- myInit
displayCallback $= display texNamesAndDL
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just keyboard
mainLoop
|
