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
|
{-
Surface.hs (adapted from surface.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 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) )
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
setSamplingMethod nurbsObj (PathLength 25)
setDisplayMode' nurbsObj Fill'
checkForNURBSError nurbsObj $
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
state <- makeState
myInit
reshapeCallback $= Just reshape
displayCallback $= display state
keyboardMouseCallback $= Just (keyboard state)
mainLoop
|
