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
|
{-
SurfPoints.hs (adapted from surfpoints.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 is a modification of the earlier Surface.hs program. The
vertex data are not directly rendered, but are instead passed to the
callback function. The values of the tessellated vertices are printed
out there.
This program draws a NURBS surface in the shape of a symmetrical hill.
The 'c' keyboard key allows you to toggle the visibility of the control
points themselves. Note that some of the control points are hidden by
the surface itself.
NOTE: This example does NOT demonstrate the final NURBS API, it's currently
just a test for the internals...
-}
import Control.Monad ( when )
import Data.Char ( toLower )
import Data.IORef ( IORef, newIORef )
import Foreign.Marshal ( withArray )
import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure )
import Graphics.UI.GLUT
data State = State { showPoints :: IORef Bool }
makeState :: IO State
makeState = do
s <- newIORef False
return $ State { showPoints = s }
-- The control points of the surface form a small hill and
-- range from -3 to +3 in x, y, and z.
ctlPoints :: [[Vertex3 GLfloat]]
ctlPoints =
[ [ Vertex3 (2 * u - 3)
(2 * v - 3)
(if (u == 1 || u ==2) && (v == 1 || v == 2) then 3 else -3)
| v <- [ 0 .. 3 ] ]
| u <- [ 0 .. 3 ]]
myInit :: IO ()
myInit = do
clearColor $= Color4 0 0 0 0
materialDiffuse Front $= Color4 0.7 0.7 0.7 1
materialSpecular Front $= Color4 1 1 1 1
materialShininess Front $= 100
lighting $= Enabled
light (Light 0) $= Enabled
depthFunc $= Just Less
autoNormal $= Enabled
normalize $= Enabled
--------------------------------------------------------------------------------
display :: State -> DisplayCallback
display state = do
let knots = [ 0, 0, 0, 0, 1, 1, 1, 1 ] :: [GLfloat]
clear [ ColorBuffer, DepthBuffer ]
preservingMatrix $ do
rotate (330 :: GLfloat) (Vector3 1 0 0)
scale 0.5 0.5 (0.5 :: GLfloat)
withNURBSObj () $ \nurbsObj -> do
setNURBSMode nurbsObj NURBSTessellator
setSamplingMethod nurbsObj (PathLength 25)
setDisplayMode' nurbsObj Fill'
checkForNURBSError nurbsObj $
withNURBSBeginCallback nurbsObj print $
withNURBSVertexCallback nurbsObj print $
withNURBSNormalCallback nurbsObj print $
withNURBSEndCallback nurbsObj (putStrLn "end") $
nurbsBeginEndSurface nurbsObj $
withArray (concat ctlPoints) $ \cBuf ->
withArray knots $ \kBuf ->
nurbsSurface nurbsObj 8 kBuf 8 kBuf (4 * 3) 3 cBuf 4 4
s <- get (showPoints state)
when s $ do
pointSize $= 5
lighting $= Disabled
color (Color3 1 1 (0 :: GLfloat))
renderPrimitive Points $
mapM_ (mapM_ vertex) ctlPoints
lighting $= Enabled
flush
reshape :: ReshapeCallback
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
perspective 45 (fromIntegral w / fromIntegral h) 3 8
matrixMode $= Modelview 0
loadIdentity
translate (Vector3 0 0 (-5 :: GLfloat))
keyboard :: State -> KeyboardMouseCallback
keyboard state (Char c) Down _ _ = case toLower c of
'c' -> do showPoints state $~ not; postRedisplay Nothing
'\27' -> exitWith ExitSuccess
_ -> return ()
keyboard _ _ _ _ _ = return ()
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 500 500
initialWindowPosition $= Position 100 100
createWindow progName
version <- get (majorMinor gluVersion)
when (version < (1,3)) $ do
putStrLn "This program demonstrates a feature which is introduced in the"
putStrLn "OpenGL Utility Library (GLU) Version 1.3."
putStrLn "If your implementation of GLU has the right extensions,"
putStrLn "you may be able to modify this program to make it run."
exitFailure
state <- makeState
myInit
reshapeCallback $= Just reshape
displayCallback $= display state
keyboardMouseCallback $= Just (keyboard state)
mainLoop
|
