Caroiaje

Cod Sursa Haskell

{-
Tess.hs (adapted from tess.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 demonstrates polygon tessellation. Two tesselated objects are
drawn. The first is a rectangle with a triangular hole. The second is a
smooth shaded, self-intersecting star.

Note the exterior rectangle is drawn with its vertices in counter-clockwise
order, but its interior clockwise. Note the combineCallback is needed for the
self-intersecting star. Also note that removing the TessProperty for the
star will make the interior unshaded (TessWindingOdd).
-}

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

display :: [DisplayList] -> DisplayCallback
display displayLists = do
clear [ ColorBuffer ]
— resolve overloading, not needed in “real” programs
let color3f = color :: Color3 GLfloat -> IO ()
color3f (Color3 1 1 1)
mapM_ callList displayLists
flush

— ‘Float’ is a dummy, any marshalable type would do
type DontCare = Float

rectangle :: ComplexContour DontCare
rectangle = ComplexContour [
AnnotatedVertex (Vertex3 50 50 0) 0,
AnnotatedVertex (Vertex3 200 50 0) 0,
AnnotatedVertex (Vertex3 200 200 0) 0,
AnnotatedVertex (Vertex3 50 200 0) 0 ]

tri :: ComplexContour DontCare
tri = ComplexContour [
AnnotatedVertex (Vertex3 75 75 0) 0,
AnnotatedVertex (Vertex3 125 175 0) 0,
AnnotatedVertex (Vertex3 175 75 0) 0 ]

rectAndTri :: ComplexPolygon DontCare
rectAndTri = ComplexPolygon [ rectangle, tri ]

noOpCombiner :: Combiner DontCare
noOpCombiner _newVertex _weightedProperties = 0

star :: ComplexPolygon (Color3 GLfloat)
star = ComplexPolygon [
ComplexContour [
AnnotatedVertex (Vertex3 250 50 0) (Color3 1 0 1),
AnnotatedVertex (Vertex3 325 200 0) (Color3 1 1 0),
AnnotatedVertex (Vertex3 400 50 0) (Color3 0 1 1),
AnnotatedVertex (Vertex3 250 150 0) (Color3 1 0 0),
AnnotatedVertex (Vertex3 400 150 0) (Color3 0 1 0) ] ]

combineColors :: Combiner (Color3 GLfloat)
combineColors
_newVertex
(WeightedProperties
(w0, Color3 r0 g0 b0)
(w1, Color3 r1 g1 b1)
(w2, Color3 r2 g2 b2)
(w3, Color3 r3 g3 b3)) =
Color3 (w0*r0 + w1*r1 + w2*r2 + w3*r3)
(w0*g0 + w1*g1 + w2*g2 + w3*g3)
(w0*b0 + w1*b1 + w2*b2 + w3*b3)

myInit :: IO [DisplayList]
myInit = do
clearColor $= Color4 0 0 0 0

rectAndTriList <- defineNewList Compile $
drawSimplePolygon (\_ -> return ()) =<<
tessellate TessWindingOdd 0 (Normal3 0 0 0) noOpCombiner rectAndTri

starList <- defineNewList Compile $
drawSimplePolygon color =<<
tessellate TessWindingPositive 0 (Normal3 0 0 0) combineColors star

return [ rectAndTriList, starList ]

drawSimplePolygon :: (v -> IO ()) -> SimplePolygon v -> IO ()
drawSimplePolygon colorHandler (SimplePolygon primitives) =
flip mapM_ primitives $ \(Primitive primitiveMode vertices) ->
renderPrimitive primitiveMode $
flip mapM_ vertices $ \(AnnotatedVertex plainVertex col) -> do
colorHandler col
vertex plainVertex

reshape :: ReshapeCallback
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
ortho2D 0 (fromIntegral w) 0 (fromIntegral h)
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
_ <- createWindow progName
displayLists <- myInit
displayCallback $= display displayLists
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just keyboard
mainLoop

---

Cod Sursa Haskell

{-
TessWind.hs (adapted from tesswind.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 demonstrates the winding rule polygon tessellation property.
Four tessellated objects are drawn, each with very different contours. When
the w key is pressed, the objects are drawn with a different winding rule.
-}

import Data.Char ( toLower )
import Data.IORef ( IORef, newIORef )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT

data State = State { currentWindingRule :: IORef TessWinding }

makeState :: IO State
makeState = do
c <- newIORef TessWindingOdd
return $ State { currentWindingRule = c }

type DisplayLists = (DisplayList, DisplayList, DisplayList, DisplayList)

— ‘Float’ is a dummy, any marshalable type would do
type DontCare = Float

rect1 :: ComplexContour DontCare
rect1 = ComplexContour [
AnnotatedVertex (Vertex3 50 50 0) 0,
AnnotatedVertex (Vertex3 300 50 0) 0,
AnnotatedVertex (Vertex3 300 300 0) 0,
AnnotatedVertex (Vertex3 50 300 0) 0 ]

rect2 :: ComplexContour DontCare
rect2 = ComplexContour [
AnnotatedVertex (Vertex3 100 100 0) 0,
AnnotatedVertex (Vertex3 250 100 0) 0,
AnnotatedVertex (Vertex3 250 250 0) 0,
AnnotatedVertex (Vertex3 100 250 0) 0 ]

rect3 :: ComplexContour DontCare
rect3 = ComplexContour [
AnnotatedVertex (Vertex3 150 150 0) 0,
AnnotatedVertex (Vertex3 200 150 0) 0,
AnnotatedVertex (Vertex3 200 200 0) 0,
AnnotatedVertex (Vertex3 150 200 0) 0 ]

rects1 :: ComplexPolygon DontCare
rects1 = ComplexPolygon [ rect1, rect2, rect3 ]

rects2 :: ComplexPolygon DontCare
rects2 = ComplexPolygon [
rect1, reverseComplexContour rect2, reverseComplexContour rect3 ]

spiral :: ComplexPolygon DontCare
spiral = ComplexPolygon [
ComplexContour [
AnnotatedVertex (Vertex3 400 250 0) 0,
AnnotatedVertex (Vertex3 400 50 0) 0,
AnnotatedVertex (Vertex3 50 50 0) 0,
AnnotatedVertex (Vertex3 50 400 0) 0,
AnnotatedVertex (Vertex3 350 400 0) 0,
AnnotatedVertex (Vertex3 350 100 0) 0,
AnnotatedVertex (Vertex3 100 100 0) 0,
AnnotatedVertex (Vertex3 100 350 0) 0,
AnnotatedVertex (Vertex3 300 350 0) 0,
AnnotatedVertex (Vertex3 300 150 0) 0,
AnnotatedVertex (Vertex3 150 150 0) 0,
AnnotatedVertex (Vertex3 150 300 0) 0,
AnnotatedVertex (Vertex3 250 300 0) 0,
AnnotatedVertex (Vertex3 250 200 0) 0,
AnnotatedVertex (Vertex3 200 200 0) 0,
AnnotatedVertex (Vertex3 200 250 0) 0 ] ]

quad1 :: ComplexContour DontCare
quad1 = ComplexContour [
AnnotatedVertex (Vertex3 50 150 0) 0,
AnnotatedVertex (Vertex3 350 150 0) 0,
AnnotatedVertex (Vertex3 350 200 0) 0,
AnnotatedVertex (Vertex3 50 200 0) 0 ]

quad2 :: ComplexContour DontCare
quad2 = ComplexContour [
AnnotatedVertex (Vertex3 100 100 0) 0,
AnnotatedVertex (Vertex3 300 100 0) 0,
AnnotatedVertex (Vertex3 300 350 0) 0,
AnnotatedVertex (Vertex3 100 350 0) 0 ]

tri :: ComplexContour DontCare
tri = ComplexContour [
AnnotatedVertex (Vertex3 200 50 0) 0,
AnnotatedVertex (Vertex3 250 300 0) 0,
AnnotatedVertex (Vertex3 150 300 0) 0 ]

quadsAndTri :: ComplexPolygon DontCare
quadsAndTri = ComplexPolygon [ quad1, quad2, tri ]

reverseComplexContour :: ComplexContour DontCare -> ComplexContour DontCare
reverseComplexContour (ComplexContour avs) = ComplexContour (reverse avs)

makeNewLists :: State -> DisplayLists -> IO ()
makeNewLists state (dl1, dl2, dl3, dl4) = do
windingRule <- get (currentWindingRule state)
print windingRule — not in original program, but useful
compileList windingRule dl1 rects1
compileList windingRule dl2 rects2
compileList windingRule dl3 spiral
compileList windingRule dl4 quadsAndTri

compileList :: TessWinding -> DisplayList -> ComplexPolygon DontCare -> IO ()
compileList windingRule displayList complexPolygon =
defineList displayList Compile $
drawSimplePolygon =<<
tessellate windingRule 0 (Normal3 0 0 0) noOpCombiner complexPolygon

noOpCombiner :: Combiner DontCare
noOpCombiner _newVertex _weightedProperties = 0

drawSimplePolygon :: SimplePolygon DontCare -> IO ()
drawSimplePolygon (SimplePolygon primitives) =
flip mapM_ primitives $ \(Primitive primitiveMode vertices) ->
renderPrimitive primitiveMode $
flip mapM_ vertices $ \(AnnotatedVertex plainVertex _) ->
vertex plainVertex

display :: DisplayLists -> DisplayCallback
display (dl1, dl2, dl3, dl4) = do
clear [ ColorBuffer ]
— resolve overloading, not needed in “real” programs
let color3f = color :: Color3 GLfloat -> IO ()
translatef = translate :: Vector3 GLfloat -> IO ()
color3f (Color3 1 1 1)
preservingMatrix $ do
callList dl1
translatef (Vector3 0 500 0)
callList dl2
translatef (Vector3 500 (-500) 0)
callList dl3
translatef (Vector3 0 500 0)
callList dl4
flush

myInit :: State -> IO DisplayLists
myInit state = do
clearColor $= Color4 0 0 0 0
shadeModel $= Flat
[dl1, dl2, dl3, dl4] <- genObjectNames 4
let displayLists = (dl1, dl2, dl3, dl4)
makeNewLists state displayLists
return displayLists

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

keyboard :: State -> DisplayLists -> KeyboardMouseCallback
keyboard state displayLists (Char c) Down _ _ = case toLower c of
‘w’ -> do currentWindingRule state $~ nextWindingRule
makeNewLists state displayLists
postRedisplay Nothing
‘\27’ -> exitWith ExitSuccess
_ -> return ()
keyboard _ _ _ _ _ _ = return ()

nextWindingRule :: TessWinding -> TessWinding
nextWindingRule r = case r of
TessWindingOdd -> TessWindingNonzero
TessWindingNonzero -> TessWindingPositive
TessWindingPositive -> TessWindingNegative
TessWindingNegative -> TessWindingAbsGeqTwo
TessWindingAbsGeqTwo -> TessWindingOdd

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

---

Cod Sursa Haskell

{-
Quadric.hs (adapted from quadric.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 demonstrates the use of the renderQuadric routine. Quadric
objects are created with some quadric properties and errors are reported.
Note that the cylinder has no top or bottom and the circle has a hole in it.
-}

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

myInit :: IO (DisplayList, DisplayList, DisplayList, DisplayList)
myInit = do
clearColor $= Color4 0 0 0 0

materialAmbient Front $= Color4 0.5 0.5 0.5 1
materialSpecular Front $= Color4 1 1 1 1
materialShininess Front $= 50
position (Light 0) $= Vertex4 1 1 1 0
lightModelAmbient $= Color4 0.5 0.5 0.5 1

lighting $= Enabled
light (Light 0) $= Enabled
depthFunc $= Just Less

— Create 4 display lists, each with a different quadric object.
— Different drawing styles and surface normal specifications
— are demonstrated.
— smooth shaded
dl1 <- newQuadricDL (Just Smooth) FillStyle (Sphere 0.75 15 10)
— flat shaded
dl2 <- newQuadricDL (Just Flat) FillStyle (Cylinder 0.5 0.3 1 15 5)
— all polygons wireframe
dl3 <- newQuadricDL Nothing LineStyle (Disk 0.25 1 20 4)
— boundary only
dl4 <- newQuadricDL Nothing SilhouetteStyle (PartialDisk 0 1 20 4 0 225)
return (dl1, dl2, dl3, dl4)

newQuadricDL :: QuadricNormal -> QuadricDrawStyle -> QuadricPrimitive -> IO DisplayList
newQuadricDL n s p =
defineNewList Compile $ do
renderQuadric (QuadricStyle n NoTextureCoordinates Outside s) p
reportErrors

display :: (DisplayList, DisplayList, DisplayList, DisplayList) -> DisplayCallback
display (dl1, dl2, dl3, dl4) = do
clear [ ColorBuffer, DepthBuffer ]
preservingMatrix $ do
— resolve overloading, not needed in “real” programs
let translatef = translate :: Vector3 GLfloat -> IO ()
rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO ()
color3f = color :: Color3 GLfloat -> IO ()

lighting $= Enabled
shadeModel $= Smooth
translatef (Vector3 (-1) (-1) 0)
callList dl1

shadeModel $= Flat
translatef (Vector3 0 2 0)
preservingMatrix $ do
rotatef 300 (Vector3 1 0 0)
callList dl2

lighting $= Disabled
color3f (Color3 0 1 1)
translatef (Vector3 2 (-2) 0)
callList dl3

color3f (Color3 1 1 0)
translatef (Vector3 0 2 0)
callList dl4

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

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
displayLists <- myInit
displayCallback $= display displayLists
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just keyboard
mainLoop