Curbe și Suprafețe Bezier

Cod Sursa Haskell

{-
BezCurve.hs (adapted from bezcurve.c which is (c) Silicon Graphics, Inc)
Copyright (c) Sven Panne 2002-2005 <svenpanne@gmail.com>
This file is part of HOpenGL and distributed under a BSD-style license
See the file libraries/GLUT/LICENSE

This program uses evaluators to draw a Bezier curve.
-}

import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT

ctrlPoints :: [Vertex3 GLfloat]
ctrlPoints = [ Vertex3 (-4)(-4) 0, Vertex3 (-2) 4 0,
Vertex3 2 (-4) 0, Vertex3 4 4 0 ]

myInit :: IO ()
myInit = do
clearColor $= Color4 0 0 0 0
shadeModel $= Flat
m <- newMap1 (0, 1) ctrlPoints
map1 $= Just (m :: GLmap1 Vertex3 GLfloat)

display :: DisplayCallback
display = do
clear [ ColorBuffer ]
— resolve overloading, not needed in “real” programs
let color3f = color :: Color3 GLfloat -> IO ()
color3f (Color3 1 1 1)
renderPrimitive LineStrip $
mapM_ evalCoord1 [ i/30.0 :: GLfloat | i <- [0..30] ]
— The following code displays the control points as dots.
pointSize $= 5
color3f (Color3 1 1 0)
renderPrimitive Points $
mapM_ vertex ctrlPoints
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 (-5.0) 5.0 (-5.0*hf/wf) (5.0*hf/wf) (-5.0) 5.0
else ortho (-5.0*wf/hf) (5.0*wf/hf) (-5.0) 5.0 (-5.0) 5.0
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 500 500
initialWindowPosition $= Position 100 100
_ <- createWindow progName
myInit
displayCallback $= display
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just keyboard
mainLoop

---

Cod Sursa Haskell

{-
BezSurf.hs (adapted from bezsurf.c which is (c) Silicon Graphics, Inc)
Copyright (c) Sven Panne 2002-2005 <svenpanne@gmail.com>
This file is part of HOpenGL and distributed under a BSD-style license
See the file libraries/GLUT/LICENSE

This program renders a wireframe Bezier surface, using two-dimensional
evaluators.
-}

import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT

ctrlPoints :: [[Vertex3 GLfloat]]
ctrlPoints = [
[ Vertex3 (-1.5) (-1.5) 4.0, Vertex3 (-0.5) (-1.5) 2.0,
Vertex3 0.5 (-1.5) (-1.0), Vertex3 1.5 (-1.5) 2.0 ],
[ Vertex3 (-1.5) (-0.5) 1.0, Vertex3 (-0.5) (-0.5) 3.0,
Vertex3 0.5 (-0.5) 0.0, Vertex3 1.5 (-0.5) (-1.0) ],
[ Vertex3 (-1.5) 0.5 4.0, Vertex3 (-0.5) 0.5 0.0,
Vertex3 0.5 0.5 3.0, Vertex3 1.5 0.5 4.0 ],
[ Vertex3 (-1.5) 1.5 (-2.0), Vertex3 (-0.5) 1.5 (-2.0),
Vertex3 0.5 1.5 0.0, Vertex3 1.5 1.5 (-1.0) ]]

— Hey mom, look, it’s C! 😉
for :: GLfloat -> GLfloat -> (GLfloat -> IO ()) -> IO ()
for s e f = mapM_ f [ i | i <- [ s, if s <= e then s + 1 else s – 1 .. e ] ]

display :: DisplayCallback
display = do
clear [ ColorBuffer, DepthBuffer ]
color (Color3 1 1 1 :: Color3 GLfloat)
preservingMatrix $ do
rotate (85 :: GLfloat) (Vector3 1 1 1)
for 0 8 $ \j -> do
renderPrimitive LineStrip $ do
for 0 30 $ \i -> evalCoord2 (i/30, j/ 8)
renderPrimitive LineStrip $ do
for 0 30 $ \i -> evalCoord2 (j/ 8, i/30)
flush

myInit :: IO ()
myInit = do
clearColor $= Color4 0 0 0 0
m <- newMap2 (0, 1) (0, 1) ctrlPoints
map2 $= Just (m :: GLmap2 Vertex3 GLfloat)
mapGrid2 $= ((20, (0, 1)), (20, (0, 1 :: GLfloat)))
depthFunc $= Just Less
shadeModel $= Flat

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 (-4.0) 4.0 (-4.0*hf/wf) (4.0*hf/wf) (-4.0) 4.0
else ortho (-4.0*wf/hf) (4.0*wf/hf) (-4.0) 4.0 (-4.0) 4.0
matrixMode $= Modelview 0
loadIdentity

keyboard :: KeyboardMouseCallback
keyboard (Char ‘\27’) Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ = return ()

main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 500 500
initialWindowPosition $= Position 100 100
_ <- createWindow progName
myInit
displayCallback $= display
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just keyboard
mainLoop

---

Cod Sursa Haskell

{-
BezMesh.hs (adapted from bezmesh.c which is (c) Silicon Graphics, Inc)
Copyright (c) Sven Panne 2002-2005 <svenpanne@gmail.com>
This file is part of HOpenGL and distributed under a BSD-style license
See the file libraries/GLUT/LICENSE

This program renders a lighted, filled Bezier surface, using two-dimensional
evaluators.
-}

import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Data.List ( transpose )
import Graphics.UI.GLUT

ctrlPoints :: [[Vertex3 GLfloat]]
ctrlPoints = [
[ Vertex3 (-1.5) (-1.5) 4.0, Vertex3 (-0.5) (-1.5) 2.0,
Vertex3 0.5 (-1.5) (-1.0), Vertex3 1.5 (-1.5) 2.0 ],
[ Vertex3 (-1.5) (-0.5) 1.0, Vertex3 (-0.5) (-0.5) 3.0,
Vertex3 0.5 (-0.5) 0.0, Vertex3 1.5 (-0.5) (-1.0) ],
[ Vertex3 (-1.5) 0.5 4.0, Vertex3 (-0.5) 0.5 0.0,
Vertex3 0.5 0.5 3.0, Vertex3 1.5 0.5 4.0 ],
[ Vertex3 (-1.5) 1.5 (-2.0), Vertex3 (-0.5) 1.5 (-2.0),
Vertex3 0.5 1.5 0.0, Vertex3 1.5 1.5 (-1.0) ]]

initlights :: IO ()
initlights = do
lighting $= Enabled
light (Light 0) $= Enabled

ambient (Light 0) $= Color4 0.2 0.2 0.2 1.0
position (Light 0) $= Vertex4 0 0 2 1

materialDiffuse Front $= Color4 0.6 0.6 0.6 1.0
materialSpecular Front $= Color4 1.0 1.0 1.0 1.0
materialShininess Front $= 50

display :: DisplayCallback
display = do
clear [ ColorBuffer, DepthBuffer ]
preservingMatrix $ do
rotate (85 :: GLfloat) (Vector3 1 1 1)
evalMesh2 Fill (0, 20) (0, 20)
flush

myInit :: IO ()
myInit = do
clearColor $= Color4 0 0 0 0
depthFunc $= Just Less
m <- newMap2 (0, 1) (0, 1) (transpose ctrlPoints)
map2 $= Just (m :: GLmap2 Vertex3 GLfloat)
autoNormal $= Enabled
mapGrid2 $= ((20, (0, 1)), (20, (0, 1 :: GLfloat)))
initlights — for lighted version only

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 (-4.0) 4.0 (-4.0*hf/wf) (4.0*hf/wf) (-4.0) 4.0
else ortho (-4.0*wf/hf) (4.0*wf/hf) (-4.0) 4.0 (-4.0) 4.0
matrixMode $= Modelview 0
loadIdentity

keyboard :: KeyboardMouseCallback
keyboard (Char ‘\27’) Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ = return ()

main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 500 500
initialWindowPosition $= Position 100 100
_ <- createWindow progName
myInit
reshapeCallback $= Just reshape
displayCallback $= display
keyboardMouseCallback $= Just keyboard
mainLoop

---

Cod Sursa Haskell

{-
TextureSurf.hs (adapted from texturesurf.c which is (c) Silicon Graphics, Inc)
Copyright (c) Sven Panne 2002-2005 <svenpanne@gmail.com>
This file is part of HOpenGL and distributed under a BSD-style license
See the file libraries/GLUT/LICENSE

This program uses evaluators to generate a curved surface and automatically
generated texture coordinates.
-}

import Data.List ( transpose )
import Foreign ( withArray )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT

ctrlPoints :: [[Vertex3 GLfloat]]
ctrlPoints = [
[ Vertex3 (-1.5) (-1.5) 4.0, Vertex3 (-0.5) (-1.5) 2.0,
Vertex3 0.5 (-1.5) (-1.0), Vertex3 1.5 (-1.5) 2.0 ],
[ Vertex3 (-1.5) (-0.5) 1.0, Vertex3 (-0.5) (-0.5) 3.0,
Vertex3 0.5 (-0.5) 0.0, Vertex3 1.5 (-0.5) (-1.0) ],
[ Vertex3 (-1.5) 0.5 4.0, Vertex3 (-0.5) 0.5 0.0,
Vertex3 0.5 0.5 3.0, Vertex3 1.5 0.5 4.0 ],
[ Vertex3 (-1.5) 1.5 (-2.0), Vertex3 (-0.5) 1.5 (-2.0),
Vertex3 0.5 1.5 0.0, Vertex3 1.5 1.5 (-1.0) ]]

texPts :: [[TexCoord2 GLfloat]]
texPts = [
[ TexCoord2 0 0, TexCoord2 0 1 ],
[ TexCoord2 1 0, TexCoord2 1 1 ]]

display :: DisplayCallback
display = do
clear [ ColorBuffer, DepthBuffer ]
color (Color3 1 1 1 :: Color3 GLfloat)
evalMesh2 Fill (0, 20) (0, 20)
flush

imageSize :: TextureSize2D
imageSize = TextureSize2D 64 64

withImage :: (PixelData (Color3 GLubyte) -> IO ()) -> IO ()
withImage act =
withArray [ Color3 (s (sin ti)) (s (cos (2 * tj))) (s (cos (ti + tj))) |
i <- [ 0 .. fromIntegral w – 1 ],
let ti = 2 * pi * i / fromIntegral w,
j <- [ 0 .. fromIntegral h – 1 ],
let tj = 2 * pi * j / fromIntegral h ] $
act . PixelData RGB UnsignedByte
where (TextureSize2D w h) = imageSize
s :: Double -> GLubyte
s x = truncate (127 * (1 + x))

myInit :: IO ()
myInit = do
m <- newMap2 (0, 1) (0, 1) (transpose ctrlPoints)
map2 $= Just (m :: GLmap2 Vertex3 GLfloat)
t <- newMap2 (0, 1) (0, 1) (transpose texPts)
map2 $= Just (t :: GLmap2 TexCoord2 GLfloat)
mapGrid2 $= ((20, (0, 1)), (20, (0, 1 :: GLfloat)))
textureFunction $= Decal
textureWrapMode Texture2D S $= (Repeated, Repeat)
textureWrapMode Texture2D T $= (Repeated, Repeat)
textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
withImage $ texImage2D Texture2D NoProxy 0 RGB’ imageSize 0
texture Texture2D $= Enabled
depthFunc $= Just Less
shadeModel $= Flat

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 (-4.0) 4.0 (-4.0*hf/wf) (4.0*hf/wf) (-4.0) 4.0
else ortho (-4.0*wf/hf) (4.0*wf/hf) (-4.0) 4.0 (-4.0) 4.0
matrixMode $= Modelview 0
loadIdentity
rotate (85 :: GLfloat) (Vector3 1 1 1)

keyboard :: KeyboardMouseCallback
keyboard (Char ‘\27’) Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ = return ()

main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 500 500
initialWindowPosition $= Position 100 100
_ <- createWindow progName
myInit
displayCallback $= display
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just keyboard
mainLoop

---

Cod Sursa Haskell

{-
Surface.hs (adapted from surface.c which is (c) Silicon Graphics, Inc.)
Copyright (c) Sven Panne 2002-2005 <svenpanne@gmail.com>
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

---

Cod Sursa Haskell

{-
SurfPoints.hs (adapted from surfpoints.c which is (c) Silicon Graphics, Inc.)
Copyright (c) Sven Panne 2002-2005 <svenpanne@gmail.com>
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) )
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.”
putStrLn “Continuing anyway…”
state <- makeState
myInit
reshapeCallback $= Just reshape
displayCallback $= display state
keyboardMouseCallback $= Just (keyboard state)
mainLoop

---

Cod Sursa Haskell

{-
Trim.hs (adapted from trim.c which is (c) Silicon Graphics, Inc.)
Copyright (c) Sven Panne 2002-2005 <svenpanne@gmail.com>
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,
using both a NURBS curve and pwl (piecewise linear) curve to trim part
of the surface.

NOTE: This example does NOT demonstrate the final NURBS API, it’s currently
just a test for the internals…
-}

import Foreign.Marshal ( withArray )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT

— 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 :: DisplayCallback
display = do
let knots = [ 0, 0, 0, 0, 1, 1, 1, 1 ] :: [GLfloat]
edgePt = — counter clockwise
[ Vertex2 0 0, Vertex2 1 0, Vertex2 1 1, Vertex2 0 1, Vertex2 0 0 ] :: [Vertex2 GLfloat]
curvePt = — clockwise
[ Vertex2 0.25 0.5, Vertex2 0.25 0.75, Vertex2 0.75 0.75, Vertex2 0.75 0.5 ] :: [Vertex2 GLfloat]
curveKnots =
[ 0, 0, 0, 0, 1, 1, 1, 1 ] :: [GLfloat]
pwlPt = — clockwise
[Vertex2 0.75 0.5, Vertex2 0.5 0.25, Vertex2 0.25 0.5 ] :: [Vertex2 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 -> do
nurbsSurface nurbsObj 8 kBuf 8 kBuf (4 * 3) 3 cBuf 4 4
nurbsBeginEndTrim nurbsObj $
withArray edgePt $ \edgePtBuf ->
pwlCurve nurbsObj 5 edgePtBuf 2
nurbsBeginEndTrim nurbsObj $ do
withArray curveKnots $ \curveKnotsBuf ->
withArray curvePt $ \curvePtBuf ->
trimmingCurve nurbsObj 8 curveKnotsBuf 2 curvePtBuf 4
withArray pwlPt $ \pwlPtBuf ->
pwlCurve nurbsObj 3 pwlPtBuf 2

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 :: KeyboardMouseCallback
keyboard (Char ‘\27’) Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ = return ()

— Main Loop
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 500 500
initialWindowPosition $= Position 100 100
_ <- createWindow progName
myInit
reshapeCallback $= Just reshape
displayCallback $= display
keyboardMouseCallback $= Just keyboard
mainLoop