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
|
{-
TexGen.hs (adapted from texgen.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 draws a texture mapped teapot with automatically generated
texture coordinates. The texture is rendered as stripes on the teapot.
Initially, the object is drawn with texture coordinates based upon the
object coordinates of the vertex and distance from the plane x = 0.
Pressing the 'e' key changes the coordinate generation to eye coordinates
of the vertex. Pressing the 'o' key switches it back to the object
coordinates. Pressing the 's' key changes the plane to a slanted one
(x + y + z = 0). Pressing the 'x' key switches it back to x = 0.
-}
import Control.Monad ( when )
import Data.Char ( toLower )
import Data.Maybe ( isJust, listToMaybe )
import Foreign ( withArray )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
stripeImageWidth :: TextureSize1D
stripeImageWidth = TextureSize1D 32
xEqualZero, slanted :: Plane GLdouble
xEqualZero = Plane 1 0 0 0
slanted = Plane 1 1 1 0
withStripeImage :: (PixelData (Color4 GLubyte) -> IO a) -> IO a
withStripeImage act =
withArray [ Color4 (if j <= 4 then 255 else 0)
(if j > 4 then 255 else 0)
0
255
| j <- [ 0 .. w - 1 ] ] $
act . PixelData RGBA UnsignedByte
where TextureSize1D w = stripeImageWidth
myInit :: IO (Maybe TextureObject)
myInit = do
clearColor $= Color4 0 0 0 0
depthFunc $= Just Less
shadeModel $= Smooth
rowAlignment Unpack $= 1
exts <- get glExtensions
mbTexName <- if "GL_EXT_texture_object" `elem` exts
then fmap listToMaybe $ genObjectNames 1
else return Nothing
when (isJust mbTexName) $ textureBinding Texture1D $= mbTexName
textureWrapMode Texture1D S $= (Repeated, Repeat)
textureFilter Texture1D $= ((Linear', Nothing), Linear')
withStripeImage $ texImage1D NoProxy 0 RGBA' stripeImageWidth 0
textureFunction $= Modulate
textureGenMode S $= Just (ObjectLinear xEqualZero)
texture Texture1D $= Enabled
lighting $= Enabled
light (Light 0) $= Enabled
autoNormal $= Enabled
normalize $= Enabled
frontFace $= CW
cullFace $= Just Back
materialShininess Front $= 64
return mbTexName
display :: Maybe TextureObject -> DisplayCallback
display mbTexName = do
clear [ ColorBuffer, DepthBuffer ]
preservingMatrix $ do
rotate (45 :: GLfloat) (Vector3 0 0 1)
when (isJust mbTexName) $ textureBinding Texture1D $= mbTexName
renderObject Solid (Teapot 2)
flush
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 (-3.5) 3.5 (-3.5*hf/wf) (3.5*hf/wf) (-3.5) 3.5
else ortho (-3.5*wf/hf) (3.5*wf/hf) (-3.5) 3.5 (-3.5) 3.5
matrixMode $= Modelview 0
loadIdentity
keyboard :: KeyboardMouseCallback
keyboard (Char c) Down _ _ = case toLower c of
'e' -> setGenMode EyeLinear
'o' -> setGenMode ObjectLinear
's' -> setPlane slanted
'x' -> setPlane xEqualZero
'\27' -> exitWith ExitSuccess
_ -> return ()
keyboard _ _ _ _ = return ()
setGenMode :: (Plane GLdouble -> TextureGenMode) -> IO ()
setGenMode mode = do
currentGenMode <- get (textureGenMode S)
case currentGenMode of
Just (EyeLinear plane) -> textureGenMode S $= Just (mode plane)
Just (ObjectLinear plane) -> textureGenMode S $= Just (mode plane)
_ -> error "setGenMode: should never happen..."
postRedisplay Nothing
setPlane :: Plane GLdouble -> IO ()
setPlane plane = do
currentGenMode <- get (textureGenMode S)
case currentGenMode of
Just (EyeLinear _) -> textureGenMode S $= Just (EyeLinear plane)
Just (ObjectLinear _) -> textureGenMode S $= Just (ObjectLinear plane)
_ -> error "setPlane: should never happen..."
postRedisplay Nothing
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 256 256
initialWindowPosition $= Position 100 100
createWindow progName
mbTexName <- myInit
displayCallback $= display mbTexName
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just keyboard
mainLoop
|
