{-
BlendEqn.hs (adapted from blendeqn.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
BlendEqn.hs (adapted from blendeqn.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
Demonstrate the different blending functions available with the OpenGL
imaging subset. This program demonstrates use of blendEquation.
imaging subset. This program demonstrates use of blendEquation.
The following keys change the selected blend equation function:
‘a’ -> FuncAdd
‘s’ -> FuncSubtract
‘r’ -> FuncReverseSubtract
‘m’ -> Min
‘x’ -> Max
-}
‘s’ -> FuncSubtract
‘r’ -> FuncReverseSubtract
‘m’ -> Min
‘x’ -> Max
-}
import Data.Char ( toLower )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
myInit :: IO ()
myInit = do
clearColor $= Color4 1 1 0 0
blendFunc $= (One, One)
blend $= Enabled
myInit = do
clearColor $= Color4 1 1 0 0
blendFunc $= (One, One)
blend $= Enabled
display :: DisplayCallback
display = do
clear [ ColorBuffer ]
display = do
clear [ ColorBuffer ]
color (Color3 0 0 (1 :: GLfloat))
rect (Vertex2 (-0.5) (-0.5)) (Vertex2 0.5 (0.5 :: GLfloat))
rect (Vertex2 (-0.5) (-0.5)) (Vertex2 0.5 (0.5 :: GLfloat))
flush
reshape :: ReshapeCallback
reshape size@(Size w h) = do
let aspect = fromIntegral w / fromIntegral h
reshape size@(Size w h) = do
let aspect = fromIntegral w / fromIntegral h
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
if aspect < 1
then let aspect’ = recip aspect
in ortho (-aspect’) aspect’ (-1) 1 (-1) 1
else ortho (-1) 1 (-aspect) aspect (-1) 1
matrixMode $= Modelview 0
matrixMode $= Projection
loadIdentity
if aspect < 1
then let aspect’ = recip aspect
in ortho (-aspect’) aspect’ (-1) 1 (-1) 1
else ortho (-1) 1 (-aspect) aspect (-1) 1
matrixMode $= Modelview 0
keyboard :: KeyboardMouseCallback
keyboard (Char c) Down _ _ = case toLower c of
— Colors are added as: (0, 0, 1) + (1, 1, 0) = (1, 1, 1)
— which will produce a white square on a yellow background.
‘a’ -> setBlendEquation FuncAdd
keyboard (Char c) Down _ _ = case toLower c of
— Colors are added as: (0, 0, 1) + (1, 1, 0) = (1, 1, 1)
— which will produce a white square on a yellow background.
‘a’ -> setBlendEquation FuncAdd
— Colors are subtracted as: (0, 0, 1) – (1, 1, 0) = (-1, -1, 1)
— which is clamped to (0, 0, 1), producing a blue square on a
— yellow background
‘s’ -> setBlendEquation FuncSubtract
— which is clamped to (0, 0, 1), producing a blue square on a
— yellow background
‘s’ -> setBlendEquation FuncSubtract
— Colors are subtracted as: (1, 1, 0) – (0, 0, 1) = (1, 1, -1)
— which is clamed to (1, 1, 0). This produces yellow for both
— the square and the background.
‘r’ -> setBlendEquation FuncReverseSubtract
— which is clamed to (1, 1, 0). This produces yellow for both
— the square and the background.
‘r’ -> setBlendEquation FuncReverseSubtract
— The minimum of each component is computed, as
— [min(0, 1), min(0, 1), min(1, 0)] which equates to (0, 0, 0).
— This will produce a black square on the yellow background.
‘m’ -> setBlendEquation Min
— [min(0, 1), min(0, 1), min(1, 0)] which equates to (0, 0, 0).
— This will produce a black square on the yellow background.
‘m’ -> setBlendEquation Min
— The minimum of each component is computed, as
— [max(0, 1), max(0, 1), max(1, 0)] which equates to (1, 1, 1)
— This will produce a white square on the yellow background.
‘x’ -> setBlendEquation Max
— [max(0, 1), max(0, 1), max(1, 0)] which equates to (1, 1, 1)
— This will produce a white square on the yellow background.
‘x’ -> setBlendEquation Max
‘\27’ -> exitWith ExitSuccess
_ -> return ()
where setBlendEquation e = do
blendEquation $= e
postRedisplay Nothing
keyboard _ _ _ _ = return ()
_ -> return ()
where setBlendEquation e = do
blendEquation $= e
postRedisplay Nothing
keyboard _ _ _ _ = return ()
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode ]
initialWindowSize $= Size 512 512
initialWindowPosition $= Position 100 100
_ <- createWindow progName
myInit
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just keyboard
displayCallback $= display
mainLoop
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode ]
initialWindowSize $= Size 512 512
initialWindowPosition $= Position 100 100
_ <- createWindow progName
myInit
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just keyboard
displayCallback $= display
mainLoop
{-
Alpha.hs (adapted from alpha.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
Alpha.hs (adapted from alpha.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 several overlapping filled polygons to demonstrate the
effect order has on alpha blending results. Use the ‘t’ key to toggle the
order of drawing polygons.
-}
effect order has on alpha blending results. Use the ‘t’ key to toggle the
order of drawing polygons.
-}
import Data.Char ( toLower )
import Data.IORef ( IORef, newIORef )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
import Data.IORef ( IORef, newIORef )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
data State = State { leftFirst :: IORef Bool }
makeState :: IO State
makeState = do
l <- newIORef True
return $ State { leftFirst = l }
makeState = do
l <- newIORef True
return $ State { leftFirst = l }
— Initialize alpha blending function.
myInit :: IO ()
myInit = do
blend $= Enabled
blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
shadeModel $= Flat
clearColor $= Color4 0 0 0 0
myInit :: IO ()
myInit = do
blend $= Enabled
blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
shadeModel $= Flat
clearColor $= Color4 0 0 0 0
drawLeftTriangle :: IO ()
drawLeftTriangle =
— draw yellow triangle on LHS of screen
renderPrimitive Triangles $ do
color (Color4 1 1 0 (0.75 :: GLfloat))
vertex (Vertex3 0.1 0.9 (0 :: GLfloat))
vertex (Vertex3 0.1 0.1 (0 :: GLfloat))
vertex (Vertex3 0.7 0.5 (0 :: GLfloat))
drawLeftTriangle =
— draw yellow triangle on LHS of screen
renderPrimitive Triangles $ do
color (Color4 1 1 0 (0.75 :: GLfloat))
vertex (Vertex3 0.1 0.9 (0 :: GLfloat))
vertex (Vertex3 0.1 0.1 (0 :: GLfloat))
vertex (Vertex3 0.7 0.5 (0 :: GLfloat))
drawRightTriangle :: IO ()
drawRightTriangle =
— draw cyan triangle on RHS of screen
renderPrimitive Triangles $ do
color (Color4 0 1 1 (0.75 :: GLfloat))
vertex (Vertex3 0.9 0.9 (0 :: GLfloat))
vertex (Vertex3 0.3 0.5 (0 :: GLfloat))
vertex (Vertex3 0.9 0.1 (0 :: GLfloat))
drawRightTriangle =
— draw cyan triangle on RHS of screen
renderPrimitive Triangles $ do
color (Color4 0 1 1 (0.75 :: GLfloat))
vertex (Vertex3 0.9 0.9 (0 :: GLfloat))
vertex (Vertex3 0.3 0.5 (0 :: GLfloat))
vertex (Vertex3 0.9 0.1 (0 :: GLfloat))
display :: State -> DisplayCallback
display state = do
clear [ ColorBuffer ]
l <- get (leftFirst state)
if l
then do drawLeftTriangle; drawRightTriangle
else do drawRightTriangle; drawLeftTriangle
flush
display state = do
clear [ ColorBuffer ]
l <- get (leftFirst state)
if l
then do drawLeftTriangle; drawRightTriangle
else do drawRightTriangle; drawLeftTriangle
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 ortho2D 0 1 0 (hf/wf)
else ortho2D 0 (wf/hf) 0 1
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 1 0 (hf/wf)
else ortho2D 0 (wf/hf) 0 1
keyboard :: State -> KeyboardMouseCallback
keyboard state (Char c) Down _ _ = case toLower c of
‘t’ -> do leftFirst state $~ not; postRedisplay Nothing
‘\27’ -> exitWith ExitSuccess — Escape key
_ -> return ()
keyboard _ _ _ _ _ = return ()
keyboard state (Char c) Down _ _ = case toLower c of
‘t’ -> do leftFirst state $~ not; postRedisplay Nothing
‘\27’ -> exitWith ExitSuccess — Escape key
_ -> return ()
keyboard _ _ _ _ _ = return ()
— Main Loop
— Open window with initial window size, title bar, RGBA display mode, and
— handle input events.
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode ]
initialWindowSize $= Size 200 200
_ <- createWindow progName
state <- makeState
myInit
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboard state)
displayCallback $= display state
mainLoop
— Open window with initial window size, title bar, RGBA display mode, and
— handle input events.
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode ]
initialWindowSize $= Size 200 200
_ <- createWindow progName
state <- makeState
myInit
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboard state)
displayCallback $= display state
mainLoop
{-
Alpha3D.hs (adapted from alpha3D.c which is (c) Silicon Graphics, Inc.)
Copyright (c) Sven Panne 2002-2006 <svenpanne@gmail.com>
This file is part of HOpenGL and distributed under a BSD-style license
See the file libraries/GLUT/LICENSE
Alpha3D.hs (adapted from alpha3D.c which is (c) Silicon Graphics, Inc.)
Copyright (c) Sven Panne 2002-2006 <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 how to intermix opaque and alpha blended polygons
in the same scene, by using depthMask. Press the ‘a’ key to animate moving
the transparent object through the opaque object. Press the ‘r’ key to reset
the scene.
-}
in the same scene, by using depthMask. Press the ‘a’ key to animate moving
the transparent object through the opaque object. Press the ‘r’ key to reset
the scene.
-}
import Data.Char ( toLower )
import Data.IORef ( IORef, newIORef )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
import Data.IORef ( IORef, newIORef )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
maxZ, minZ, zInc :: GLfloat
maxZ = 8
minZ = -8
zInc = 0.4
maxZ = 8
minZ = -8
zInc = 0.4
— We don’t animate via the idle callback, because this is way too fast on
— modern computers. A timer with the delay below is used instead for redraw.
delay :: Timeout
delay = 100
— modern computers. A timer with the delay below is used instead for redraw.
delay :: Timeout
delay = 100
data State = State { solidZ, transparentZ :: IORef GLfloat }
makeState :: IO State
makeState = do
s <- newIORef maxZ
t <- newIORef minZ
return $ State { solidZ = s, transparentZ = t }
makeState = do
s <- newIORef maxZ
t <- newIORef minZ
return $ State { solidZ = s, transparentZ = t }
data DisplayLists = DisplayLists { sphereList, cubeList :: DisplayList }
myInit :: IO DisplayLists
myInit = do
materialSpecular Front $= Color4 1 1 1 0.15
materialShininess Front $= 100
position (Light 0) $= Vertex4 0.5 0.5 1 0
myInit = do
materialSpecular Front $= Color4 1 1 1 0.15
materialShininess Front $= 100
position (Light 0) $= Vertex4 0.5 0.5 1 0
lighting $= Enabled
light (Light 0) $= Enabled
depthFunc $= Just Less
light (Light 0) $= Enabled
depthFunc $= Just Less
s <- defineNewList Compile $ renderObject Solid (Sphere’ 0.4 16 16)
c <- defineNewList Compile $ renderObject Solid (Cube 0.6)
return $ DisplayLists { sphereList = s, cubeList = c }
c <- defineNewList Compile $ renderObject Solid (Cube 0.6)
return $ DisplayLists { sphereList = s, cubeList = c }
display :: State -> DisplayLists -> DisplayCallback
display state displayLists = do
clear [ ColorBuffer, DepthBuffer ]
display state displayLists = do
clear [ ColorBuffer, DepthBuffer ]
preservingMatrix $ do
s <- get (solidZ state)
translate (Vector3 (-0.15) (-0.15) s)
materialEmission Front $= Color4 0 0 0 1
materialDiffuse Front $= Color4 0.75 0.75 0 1
callList (sphereList displayLists)
s <- get (solidZ state)
translate (Vector3 (-0.15) (-0.15) s)
materialEmission Front $= Color4 0 0 0 1
materialDiffuse Front $= Color4 0.75 0.75 0 1
callList (sphereList displayLists)
preservingMatrix $ do
t <- get (transparentZ state)
translate (Vector3 (0.15) (0.15) t)
rotate (15 :: GLfloat) (Vector3 1 1 0)
rotate (30 :: GLfloat) (Vector3 0 1 0)
materialEmission Front $= Color4 0 0.3 0.3 0.6
materialDiffuse Front $= Color4 0 0.8 0.8 0.6
blend $= Enabled
depthMask $= Disabled
blendFunc $= (SrcAlpha, One)
callList (cubeList displayLists)
depthMask $= Enabled
blend $= Disabled
t <- get (transparentZ state)
translate (Vector3 (0.15) (0.15) t)
rotate (15 :: GLfloat) (Vector3 1 1 0)
rotate (30 :: GLfloat) (Vector3 0 1 0)
materialEmission Front $= Color4 0 0.3 0.3 0.6
materialDiffuse Front $= Color4 0 0.8 0.8 0.6
blend $= Enabled
depthMask $= Disabled
blendFunc $= (SrcAlpha, One)
callList (cubeList displayLists)
depthMask $= Enabled
blend $= Disabled
swapBuffers
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 (-1.5) 1.5 (-1.5*hf/wf) (1.5*hf/wf) (-10) 10
else ortho (-1.5*wf/hf) (1.5*wf/hf) (-1.5) 1.5 (-10) 10
matrixMode $= Modelview 0
loadIdentity
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 (-1.5) 1.5 (-1.5*hf/wf) (1.5*hf/wf) (-10) 10
else ortho (-1.5*wf/hf) (1.5*wf/hf) (-1.5) 1.5 (-10) 10
matrixMode $= Modelview 0
loadIdentity
animate :: State -> TimerCallback
animate state = do
s <- get (solidZ state)
t <- get (transparentZ state)
if (s <= minZ || t >= maxZ)
then idleCallback $= Nothing
else do
solidZ state $~ (+ (- zInc))
transparentZ state $~ (+ zInc)
addTimerCallback delay (animate state)
postRedisplay Nothing
animate state = do
s <- get (solidZ state)
t <- get (transparentZ state)
if (s <= minZ || t >= maxZ)
then idleCallback $= Nothing
else do
solidZ state $~ (+ (- zInc))
transparentZ state $~ (+ zInc)
addTimerCallback delay (animate state)
postRedisplay Nothing
keyboard :: State -> KeyboardMouseCallback
keyboard state (Char c) Down _ _ = case toLower c of
‘a’ -> do solidZ state $= maxZ; transparentZ state $= minZ; addTimerCallback delay (animate state)
‘r’ -> do solidZ state $= maxZ; transparentZ state $= minZ; postRedisplay Nothing
‘\27’ -> exitWith ExitSuccess
_ -> return ()
keyboard _ _ _ _ _ = return ()
keyboard state (Char c) Down _ _ = case toLower c of
‘a’ -> do solidZ state $= maxZ; transparentZ state $= minZ; addTimerCallback delay (animate state)
‘r’ -> do solidZ state $= maxZ; transparentZ state $= minZ; postRedisplay Nothing
‘\27’ -> exitWith ExitSuccess
_ -> return ()
keyboard _ _ _ _ _ = return ()
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
— The original C example uses single buffering, which flickers a lot.
initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 500 500
_ <- createWindow progName
state <- makeState
displayLists <- myInit
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboard state)
displayCallback $= display state displayLists
mainLoop
main = do
(progName, _args) <- getArgsAndInitialize
— The original C example uses single buffering, which flickers a lot.
initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 500 500
_ <- createWindow progName
state <- makeState
displayLists <- myInit
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboard state)
displayCallback $= display state displayLists
mainLoop
{-
AARGB.hs (adapted from aargb.c which is (c) Silicon Graphics, Inc.)
Copyright (c) Sven Panne 2002-2006 <svenpanne@gmail.com>
This file is part of HOpenGL and distributed under a BSD-style license
See the file libraries/GLUT/LICENSE
AARGB.hs (adapted from aargb.c which is (c) Silicon Graphics, Inc.)
Copyright (c) Sven Panne 2002-2006 <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 shows how to draw anti-aliased lines. It draws two
diagonal lines to form an X; when ‘r’ is typed in the window, the lines are
rotated in opposite directions.
-}
diagonal lines to form an X; when ‘r’ is typed in the window, the lines are
rotated in opposite directions.
-}
import Data.Char ( toLower )
import Data.IORef ( IORef, newIORef )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
import Data.IORef ( IORef, newIORef )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
data State = State { rotAngle :: IORef Int }
makeState :: IO State
makeState = do
r <- newIORef 0
return $ State { rotAngle = r }
makeState = do
r <- newIORef 0
return $ State { rotAngle = r }
— Initialize antialiasing for RGBA mode, including alpha blending, hint, and
— line width. Print out implementation specific info on line width granularity
— and width.
myInit :: IO ()
myInit = do
g <- get smoothLineWidthGranularity
putStrLn (“smoothLineWidthGranularity is ” ++ show g)
— line width. Print out implementation specific info on line width granularity
— and width.
myInit :: IO ()
myInit = do
g <- get smoothLineWidthGranularity
putStrLn (“smoothLineWidthGranularity is ” ++ show g)
r <- get smoothLineWidthRange
putStrLn (“smoothLineWidthRange is ” ++ show r)
putStrLn (“smoothLineWidthRange is ” ++ show r)
lineSmooth $= Enabled
blend $= Enabled
blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
hint LineSmooth $= DontCare
lineWidth $= 1.5
blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
hint LineSmooth $= DontCare
lineWidth $= 1.5
clearColor $= Color4 0 0 0 0
— Draw 2 diagonal lines to form an X
display :: State -> DisplayCallback
display state = do
r <- get (rotAngle state)
clear [ ColorBuffer ]
display :: State -> DisplayCallback
display state = do
r <- get (rotAngle state)
clear [ ColorBuffer ]
— resolve overloading, not needed in “real” programs
let color3f = color :: Color3 GLfloat -> IO ()
vertex2f = vertex :: Vertex2 GLfloat -> IO ()
let color3f = color :: Color3 GLfloat -> IO ()
vertex2f = vertex :: Vertex2 GLfloat -> IO ()
color3f (Color3 0 1 0)
preservingMatrix $ do
rotate (-(fromIntegral r :: GLfloat)) (Vector3 0 0 0.1)
renderPrimitive Lines $ do
vertex2f (Vertex2 (-0.5) 0.5)
vertex2f (Vertex2 0.5 (-0.5))
preservingMatrix $ do
rotate (-(fromIntegral r :: GLfloat)) (Vector3 0 0 0.1)
renderPrimitive Lines $ do
vertex2f (Vertex2 (-0.5) 0.5)
vertex2f (Vertex2 0.5 (-0.5))
color3f (Color3 0 0 1)
preservingMatrix $ do
rotate (fromIntegral r :: GLfloat) (Vector3 0 0 0.1)
renderPrimitive Lines $ do
vertex2f (Vertex2 0.5 0.5)
vertex2f (Vertex2 (-0.5) (-0.5))
preservingMatrix $ do
rotate (fromIntegral r :: GLfloat) (Vector3 0 0 0.1)
renderPrimitive Lines $ do
vertex2f (Vertex2 0.5 0.5)
vertex2f (Vertex2 (-0.5) (-0.5))
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 ortho2D (-1) 1 (-1*hf/wf) (1*hf/wf)
else ortho2D (-1*wf/hf) (1*wf/hf) (-1) 1
matrixMode $= Modelview 0
loadIdentity
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 (-1) 1 (-1*hf/wf) (1*hf/wf)
else ortho2D (-1*wf/hf) (1*wf/hf) (-1) 1
matrixMode $= Modelview 0
loadIdentity
keyboard :: State -> KeyboardMouseCallback
keyboard state (Char c) Down _ _ = case toLower c of
‘r’ -> do rotAngle state $~ ((`mod` 360) . (+ 30)); postRedisplay Nothing
‘\27’ -> exitWith ExitSuccess
_ -> return ()
keyboard _ _ _ _ _ = return ()
keyboard state (Char c) Down _ _ = case toLower c of
‘r’ -> do rotAngle state $~ ((`mod` 360) . (+ 30)); postRedisplay Nothing
‘\27’ -> exitWith ExitSuccess
_ -> return ()
keyboard _ _ _ _ _ = return ()
— Main Loop
— Open window with initial window size, title bar,
— RGBA display mode, and handle input events.
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode ]
initialWindowSize $= Size 200 200
_ <- createWindow progName
state <- makeState
myInit
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboard state)
displayCallback $= display state
mainLoop
— Open window with initial window size, title bar,
— RGBA display mode, and handle input events.
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode ]
initialWindowSize $= Size 200 200
_ <- createWindow progName
state <- makeState
myInit
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboard state)
displayCallback $= display state
mainLoop
{-
AAIndex.hs (adapted from aaindex.c which is (c) Silicon Graphics, Inc.)
Copyright (c) Sven Panne 2002-2006 <svenpanne@gmail.com>
This file is part of HOpenGL and distributed under a BSD-style license
See the file libraries/GLUT/LICENSE
AAIndex.hs (adapted from aaindex.c which is (c) Silicon Graphics, Inc.)
Copyright (c) Sven Panne 2002-2006 <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 shows how to draw anti-aliased lines in color index
mode. It draws two diagonal lines to form an X; when ‘r’ is typed in the
window, the lines are rotated in opposite directions.
-}
mode. It draws two diagonal lines to form an X; when ‘r’ is typed in the
window, the lines are rotated in opposite directions.
-}
import Data.Char ( toLower )
import Data.IORef ( IORef, newIORef )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
import Data.IORef ( IORef, newIORef )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
data State = State { rotAngle :: IORef Int }
makeState :: IO State
makeState = do
r <- newIORef 0
return $ State { rotAngle = r }
makeState = do
r <- newIORef 0
return $ State { rotAngle = r }
rampSize, ramp1Start, ramp2Start :: GLint
rampSize = 16
ramp1Start = 32
ramp2Start = 48
rampSize = 16
ramp1Start = 32
ramp2Start = 48
— Initialize antialiasing for color index mode, including loading a green color
— ramp starting at ramp1Start, and a blue color ramp starting at ramp2Start.
— The ramps must be a multiple of 16.
myInit :: IO ()
myInit = do
flip mapM_ [ 0 .. rampSize – 1 ] $ \i -> do
let shade = fromIntegral i / fromIntegral rampSize
colorMapEntry (Index1 (ramp1Start + i)) $= Color3 0 shade 0
colorMapEntry (Index1 (ramp2Start + i)) $= Color3 0 0 shade
— ramp starting at ramp1Start, and a blue color ramp starting at ramp2Start.
— The ramps must be a multiple of 16.
myInit :: IO ()
myInit = do
flip mapM_ [ 0 .. rampSize – 1 ] $ \i -> do
let shade = fromIntegral i / fromIntegral rampSize
colorMapEntry (Index1 (ramp1Start + i)) $= Color3 0 shade 0
colorMapEntry (Index1 (ramp2Start + i)) $= Color3 0 0 shade
lineSmooth $= Enabled
hint LineSmooth $= DontCare
lineWidth $= 1.5
hint LineSmooth $= DontCare
lineWidth $= 1.5
clearIndex $= Index1 (fromIntegral ramp1Start)
— Draw 2 diagonal lines to form an X
display :: State -> DisplayCallback
display state = do
r <- get (rotAngle state)
clear [ ColorBuffer ]
display :: State -> DisplayCallback
display state = do
r <- get (rotAngle state)
clear [ ColorBuffer ]
— resolve overloading, not needed in “real” programs
let vertex2f = vertex :: Vertex2 GLfloat -> IO ()
let vertex2f = vertex :: Vertex2 GLfloat -> IO ()
index (Index1 ramp1Start)
preservingMatrix $ do
rotate (-(fromIntegral r :: GLfloat)) (Vector3 0 0 0.1)
renderPrimitive Lines $ do
vertex2f (Vertex2 (-0.5) 0.5)
vertex2f (Vertex2 0.5 (-0.5))
preservingMatrix $ do
rotate (-(fromIntegral r :: GLfloat)) (Vector3 0 0 0.1)
renderPrimitive Lines $ do
vertex2f (Vertex2 (-0.5) 0.5)
vertex2f (Vertex2 0.5 (-0.5))
index (Index1 ramp2Start)
preservingMatrix $ do
rotate (fromIntegral r :: GLfloat) (Vector3 0 0 0.1)
renderPrimitive Lines $ do
vertex2f (Vertex2 0.5 0.5)
vertex2f (Vertex2 (-0.5) (-0.5))
preservingMatrix $ do
rotate (fromIntegral r :: GLfloat) (Vector3 0 0 0.1)
renderPrimitive Lines $ do
vertex2f (Vertex2 0.5 0.5)
vertex2f (Vertex2 (-0.5) (-0.5))
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 ortho2D (-1) 1 (-1*hf/wf) (1*hf/wf)
else ortho2D (-1*wf/hf) (1*wf/hf) (-1) 1
matrixMode $= Modelview 0
loadIdentity
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 (-1) 1 (-1*hf/wf) (1*hf/wf)
else ortho2D (-1*wf/hf) (1*wf/hf) (-1) 1
matrixMode $= Modelview 0
loadIdentity
keyboard :: State -> KeyboardMouseCallback
keyboard state (Char c) Down _ _ = case toLower c of
‘r’ -> do rotAngle state $~ ((`mod` 360) . (+ 30)); postRedisplay Nothing
‘\27’ -> exitWith ExitSuccess
_ -> return ()
keyboard _ _ _ _ _ = return ()
keyboard state (Char c) Down _ _ = case toLower c of
‘r’ -> do rotAngle state $~ ((`mod` 360) . (+ 30)); postRedisplay Nothing
‘\27’ -> exitWith ExitSuccess
_ -> return ()
keyboard _ _ _ _ _ = return ()
— Main Loop
— Open window with initial window size, title bar,
— color index display mode, and handle input events.
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, IndexMode ]
initialWindowSize $= Size 200 200
_ <- createWindow progName
state <- makeState
myInit
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboard state)
displayCallback $= display state
mainLoop
— Open window with initial window size, title bar,
— color index display mode, and handle input events.
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, IndexMode ]
initialWindowSize $= Size 200 200
_ <- createWindow progName
state <- makeState
myInit
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboard state)
displayCallback $= display state
mainLoop
{-
Multisamp.hs (adapted from multisamp.c which is (c) Silicon Graphics, Inc.)
Copyright (c) Sven Panne 2002-2006 <svenpanne@gmail.com>
This file is part of HOpenGL and distributed under a BSD-style license
See the file libraries/GLUT/LICENSE
Multisamp.hs (adapted from multisamp.c which is (c) Silicon Graphics, Inc.)
Copyright (c) Sven Panne 2002-2006 <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 shows how to use multisampling to draw anti-aliased
geometric primitives. The same display list, a pinwheel of triangles and
lines of varying widths, is rendered twice. Multisampling is enabled when the
left side is drawn. Multisampling is disabled when the right side is drawn.
geometric primitives. The same display list, a pinwheel of triangles and
lines of varying widths, is rendered twice. Multisampling is enabled when the
left side is drawn. Multisampling is disabled when the right side is drawn.
Pressing the ‘b’ key toggles drawing of the checkerboard background.
Antialiasing is sometimes easier to see when objects are rendered over a
contrasting background.
-}
Antialiasing is sometimes easier to see when objects are rendered over a
contrasting background.
-}
import Control.Monad ( when )
import Data.Char ( toLower )
import Data.IORef ( IORef, newIORef )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
import Data.Char ( toLower )
import Data.IORef ( IORef, newIORef )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
data State = State { bgToggle :: IORef Bool }
makeState :: IO State
makeState = do
b <- newIORef True
return $ State { bgToggle = b }
makeState = do
b <- newIORef True
return $ State { bgToggle = b }
data DisplayLists = DisplayLists { pinwheelList, backgroundList :: DisplayList }
— Print out state values related to multisampling. Create display list with
— “pinwheel” of lines and triangles.
myInit :: IO DisplayLists
myInit = do
clearColor $= Color4 0 0 0 0
sb <- get sampleBuffers
putStrLn (“number of sample buffers is ” ++ show sb)
s <- get samples
putStrLn (“number of samples is ” ++ show s)
— “pinwheel” of lines and triangles.
myInit :: IO DisplayLists
myInit = do
clearColor $= Color4 0 0 0 0
sb <- get sampleBuffers
putStrLn (“number of sample buffers is ” ++ show sb)
s <- get samples
putStrLn (“number of samples is ” ++ show s)
— resolve overloading, not needed in “real” programs
let color3f = color :: Color3 GLfloat -> IO ()
vertex2f = vertex :: Vertex2 GLfloat -> IO ()
let color3f = color :: Color3 GLfloat -> IO ()
vertex2f = vertex :: Vertex2 GLfloat -> IO ()
p <- defineNewList Compile $ do
flip mapM_ [ 0 .. 18 ] $ \i ->
preservingMatrix $ do
rotate (360 * fromIntegral i / 19 :: GLfloat) (Vector3 0 0 1)
color3f (Color3 1 1 1)
lineWidth $= fromIntegral ((i `mod` 3 :: Int) + 1)
renderPrimitive Lines $ do
vertex2f (Vertex2 0.25 0.05)
vertex2f (Vertex2 0.9 0.2)
color3f (Color3 0 1 1)
renderPrimitive Triangles $ do
vertex2f (Vertex2 0.25 0)
vertex2f (Vertex2 0.9 0)
vertex2f (Vertex2 0.875 0.1)
flip mapM_ [ 0 .. 18 ] $ \i ->
preservingMatrix $ do
rotate (360 * fromIntegral i / 19 :: GLfloat) (Vector3 0 0 1)
color3f (Color3 1 1 1)
lineWidth $= fromIntegral ((i `mod` 3 :: Int) + 1)
renderPrimitive Lines $ do
vertex2f (Vertex2 0.25 0.05)
vertex2f (Vertex2 0.9 0.2)
color3f (Color3 0 1 1)
renderPrimitive Triangles $ do
vertex2f (Vertex2 0.25 0)
vertex2f (Vertex2 0.9 0)
vertex2f (Vertex2 0.875 0.1)
b <- defineNewList Compile $ do
color3f (Color3 1 0.5 0)
renderPrimitive Quads $
flip mapM_ [ 0 .. 15 ] $ \i ->
flip mapM_ [ 0 .. 15 ] $ \j ->
when (((i + j) `mod` 2 :: Int) == 0) $ do
let ii = fromIntegral i * 0.25
jj = fromIntegral j * 0.25
vertex2f (Vertex2 (-2.0 + ii) (-2.0 + jj))
vertex2f (Vertex2 (-2.0 + ii) (-1.75 + jj))
vertex2f (Vertex2 (-1.75 + ii) (-1.75 + jj))
vertex2f (Vertex2 (-1.75 + ii) (-2.0 + jj))
color3f (Color3 1 0.5 0)
renderPrimitive Quads $
flip mapM_ [ 0 .. 15 ] $ \i ->
flip mapM_ [ 0 .. 15 ] $ \j ->
when (((i + j) `mod` 2 :: Int) == 0) $ do
let ii = fromIntegral i * 0.25
jj = fromIntegral j * 0.25
vertex2f (Vertex2 (-2.0 + ii) (-2.0 + jj))
vertex2f (Vertex2 (-2.0 + ii) (-1.75 + jj))
vertex2f (Vertex2 (-1.75 + ii) (-1.75 + jj))
vertex2f (Vertex2 (-1.75 + ii) (-2.0 + jj))
return $ DisplayLists { pinwheelList = p, backgroundList = b }
— Draw two sets of primitives, so that you can compare the user of
— multisampling against its absence.
—
— This code enables antialiasing and draws one display list and disables and
— draws the other display list
display :: State -> DisplayLists -> DisplayCallback
display state displayLists = do
clear [ ColorBuffer ]
— multisampling against its absence.
—
— This code enables antialiasing and draws one display list and disables and
— draws the other display list
display :: State -> DisplayLists -> DisplayCallback
display state displayLists = do
clear [ ColorBuffer ]
t <- get (bgToggle state)
when t $
callList (backgroundList displayLists)
when t $
callList (backgroundList displayLists)
— resolve overloading, not needed in “real” programs
let translatef = translate :: Vector3 GLfloat -> IO ()
let translatef = translate :: Vector3 GLfloat -> IO ()
multisample $= Enabled
preservingMatrix $ do
translatef (Vector3 (-1) 0 0)
callList (pinwheelList displayLists)
preservingMatrix $ do
translatef (Vector3 (-1) 0 0)
callList (pinwheelList displayLists)
multisample $= Disabled
preservingMatrix $ do
translatef (Vector3 1 0 0)
callList (pinwheelList displayLists)
preservingMatrix $ do
translatef (Vector3 1 0 0)
callList (pinwheelList displayLists)
swapBuffers
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 <= 2 * h
then ortho2D (-2) 2 (-2*hf/wf) (2*hf/wf)
else ortho2D (-2*wf/hf) (2*wf/hf) (-2) 2
matrixMode $= Modelview 0
loadIdentity
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
let wf = fromIntegral w
hf = fromIntegral h
if w <= 2 * h
then ortho2D (-2) 2 (-2*hf/wf) (2*hf/wf)
else ortho2D (-2*wf/hf) (2*wf/hf) (-2) 2
matrixMode $= Modelview 0
loadIdentity
keyboard :: State -> KeyboardMouseCallback
keyboard state (Char c) Down _ _ = case toLower c of
‘b’ -> do bgToggle state $~ not; postRedisplay Nothing
‘\27’ -> exitWith ExitSuccess
_ -> return ()
keyboard _ _ _ _ _ = return ()
keyboard state (Char c) Down _ _ = case toLower c of
‘b’ -> do bgToggle state $~ not; postRedisplay Nothing
‘\27’ -> exitWith ExitSuccess
_ -> return ()
keyboard _ _ _ _ _ = return ()
— Main Loop: Open window with initial window size, title bar, RGBA display
— mode, and handle input events.
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ DoubleBuffered, RGBMode, Multisampling ]
initialWindowSize $= Size 600 300
_ <- createWindow progName
state <- makeState
displayLists <- myInit
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboard state)
displayCallback $= display state displayLists
mainLoop
— mode, and handle input events.
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ DoubleBuffered, RGBMode, Multisampling ]
initialWindowSize $= Size 600 300
_ <- createWindow progName
state <- makeState
displayLists <- myInit
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboard state)
displayCallback $= display state displayLists
mainLoop
{-
Fog.hs (adapted from fog.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
Fog.hs (adapted from fog.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 5 red spheres, each at a different z distance from the
eye, in different types of fog. Pressing the f key chooses between 3 types
of fog: exponential, exponential squared, and linear. In this program, there
is a fixed density value, as well as fixed start and end values for the
linear fog.
-}
eye, in different types of fog. Pressing the f key chooses between 3 types
of fog: exponential, exponential squared, and linear. In this program, there
is a fixed density value, as well as fixed start and end values for the
linear fog.
-}
import Data.Char ( toLower )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
myInit :: IO ()
myInit = do
depthFunc $= Just Less
myInit = do
depthFunc $= Just Less
position (Light 0) $= Vertex4 0.5 0.5 3.0 0.0
lighting $= Enabled
light (Light 0) $= Enabled
lighting $= Enabled
light (Light 0) $= Enabled
— NOTE: The alpha values are missing from fog.c!
materialAmbient Front $= Color4 0.1745 0.01175 0.01175 1.0
materialDiffuse Front $= Color4 0.61424 0.04136 0.04136 1.0
materialSpecular Front $= Color4 0.727811 0.626959 0.626959 1.0
materialShininess Front $= 0.6 * 128
materialAmbient Front $= Color4 0.1745 0.01175 0.01175 1.0
materialDiffuse Front $= Color4 0.61424 0.04136 0.04136 1.0
materialSpecular Front $= Color4 0.727811 0.626959 0.626959 1.0
materialShininess Front $= 0.6 * 128
fog $= Enabled
let c = Color4 0.5 0.5 0.5 1.0
fogMode $= Exp 0.35
fogColor $= c
hint Fog $= DontCare
clearColor $= c
let c = Color4 0.5 0.5 0.5 1.0
fogMode $= Exp 0.35
fogColor $= c
hint Fog $= DontCare
clearColor $= c
renderSpehere :: Vector3 GLfloat -> IO ()
renderSpehere xyz =
preservingMatrix $ do
translate xyz
renderObject Solid (Sphere’ 0.4 16 16)
renderSpehere xyz =
preservingMatrix $ do
translate xyz
renderObject Solid (Sphere’ 0.4 16 16)
— display draws 5 spheres at different z positions.
display :: DisplayCallback
display = do
clear [ ColorBuffer, DepthBuffer ]
mapM_ renderSpehere [ Vector3 x (-0.5) (-3 – x) | x <- [-2 .. 2] ]
flush
display :: DisplayCallback
display = do
clear [ ColorBuffer, DepthBuffer ]
mapM_ renderSpehere [ Vector3 x (-0.5) (-3 – x) | x <- [-2 .. 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 (-2.5) 2.5 (-2.5*hf/wf) (2.5*hf/wf) (-10.0) 10.0
else ortho (-2.5*wf/hf) (2.5*wf/hf) (-2.5) 2.5 (-10.0) 10.0
matrixMode $= Modelview 0
loadIdentity
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.0) 10.0
else ortho (-2.5*wf/hf) (2.5*wf/hf) (-2.5) 2.5 (-10.0) 10.0
matrixMode $= Modelview 0
loadIdentity
keyboard :: KeyboardMouseCallback
keyboard (Char c) Down _ _ = case toLower c of
‘f’ -> do
mode <- get fogMode
case mode of
Linear _ _ -> do fogMode $= Exp 0.35; putStrLn “Fog mode is Exp”
Exp _ -> do fogMode $= Exp2 0.35; putStrLn “Fog mode is Exp2”
Exp2 _ -> do fogMode $= Linear 1 5; putStrLn “Fog mode is Linear”
postRedisplay Nothing
‘\27’ -> exitWith ExitSuccess
_ -> return ()
keyboard _ _ _ _ = return ()
keyboard (Char c) Down _ _ = case toLower c of
‘f’ -> do
mode <- get fogMode
case mode of
Linear _ _ -> do fogMode $= Exp 0.35; putStrLn “Fog mode is Exp”
Exp _ -> do fogMode $= Exp2 0.35; putStrLn “Fog mode is Exp2”
Exp2 _ -> do fogMode $= Linear 1 5; putStrLn “Fog mode is Linear”
postRedisplay Nothing
‘\27’ -> exitWith ExitSuccess
_ -> return ()
keyboard _ _ _ _ = return ()
— Main Loop: Open window with initial window size, title bar, RGBA display
— mode, depth buffer, and handle input events.
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 500 500
_ <- createWindow progName
myInit
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just keyboard
displayCallback $= display
mainLoop
— mode, depth buffer, and handle input events.
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 500 500
_ <- createWindow progName
myInit
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just keyboard
displayCallback $= display
mainLoop
{-
FogIndex.hs (adapted from fogindex.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
FogIndex.hs (adapted from fogindex.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 5 wireframe spheres, each at a different z distance from
the eye, in linear fog.
-}
the eye, in linear fog.
-}
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
import Graphics.UI.GLUT
— Initialize color map and fog. Set screen clear color to end of color ramp.
numColors, rampStart :: GLint
numColors = 32
rampStart = 16
numColors, rampStart :: GLint
numColors = 32
rampStart = 16
myInit :: IO ()
myInit = do
depthFunc $= Just Less
myInit = do
depthFunc $= Just Less
flip mapM_ [ 0 .. numColors – 1 ] $ \i -> do
let shade = fromIntegral (numColors – i) / fromIntegral numColors
colorMapEntry (Index1 (rampStart + i)) $= Color3 shade shade shade
fog $= Enabled
let shade = fromIntegral (numColors – i) / fromIntegral numColors
colorMapEntry (Index1 (rampStart + i)) $= Color3 shade shade shade
fog $= Enabled
fogMode $= Linear 1 6
fogIndex $= Index1 numColors
hint Fog $= Nicest
clearIndex $= Index1 (fromIntegral (numColors + rampStart – 1))
fogIndex $= Index1 numColors
hint Fog $= Nicest
clearIndex $= Index1 (fromIntegral (numColors + rampStart – 1))
renderSpehere :: Vector3 GLfloat -> IO ()
renderSpehere xyz =
preservingMatrix $ do
translate xyz
renderObject Wireframe (Sphere’ 0.4 16 16)
renderSpehere xyz =
preservingMatrix $ do
translate xyz
renderObject Wireframe (Sphere’ 0.4 16 16)
— display draws 5 spheres at different z positions.
display :: DisplayCallback
display = do
clear [ ColorBuffer, DepthBuffer ]
index (Index1 rampStart)
mapM_ renderSpehere [ Vector3 x (-0.5) (-3 – x) | x <- [-2 .. 2] ]
flush
display :: DisplayCallback
display = do
clear [ ColorBuffer, DepthBuffer ]
index (Index1 rampStart)
mapM_ renderSpehere [ Vector3 x (-0.5) (-3 – x) | x <- [-2 .. 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 (-2.5) 2.5 (-2.5*hf/wf) (2.5*hf/wf) (-10.0) 10.0
else ortho (-2.5*wf/hf) (2.5*wf/hf) (-2.5) 2.5 (-10.0) 10.0
matrixMode $= Modelview 0
loadIdentity
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.0) 10.0
else ortho (-2.5*wf/hf) (2.5*wf/hf) (-2.5) 2.5 (-10.0) 10.0
matrixMode $= Modelview 0
loadIdentity
keyboard :: KeyboardMouseCallback
keyboard (Char ‘\27’) Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ = return ()
keyboard (Char ‘\27’) Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ = return ()
— Main Loop: Open window with initial window size, title bar, color index
— display mode, depth buffer, and handle input events.
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, IndexMode, WithDepthBuffer ]
initialWindowSize $= Size 500 500
_ <- createWindow progName
myInit
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just keyboard
displayCallback $= display
mainLoop
— display mode, depth buffer, and handle input events.
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, IndexMode, WithDepthBuffer ]
initialWindowSize $= Size 500 500
_ <- createWindow progName
myInit
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just keyboard
displayCallback $= display
mainLoop
{-
FogCoord.hs (adapted from fogcoord.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
FogCoord.hs (adapted from fogcoord.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 explicit fog coordinates. You can press
the keyboard and change the fog coordinate value at any vertex. You can also
switch between using explicit fog coordinates and the default fog generation
mode.
the keyboard and change the fog coordinate value at any vertex. You can also
switch between using explicit fog coordinates and the default fog generation
mode.
Pressing the ‘f’ and ‘b’ keys move the viewer forward and backwards. Pressing
‘c’ initiates the default fog generation. Pressing capital ‘C’ restores
explicit fog coordinates. Pressing ‘1’, ‘2’, ‘3’, ‘8’, ‘9’, and ‘0’ add or
subtract from the fog coordinate values at one of the three vertices of the
triangle.
-}
‘c’ initiates the default fog generation. Pressing capital ‘C’ restores
explicit fog coordinates. Pressing ‘1’, ‘2’, ‘3’, ‘8’, ‘9’, and ‘0’ add or
subtract from the fog coordinate values at one of the three vertices of the
triangle.
-}
import Control.Monad ( when )
import Data.IORef ( IORef, newIORef )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
import Data.IORef ( IORef, newIORef )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
data State = State { f1, f2, f3 :: IORef (FogCoord1 GLfloat) }
makeState :: IO State
makeState = do
f1′ <- newIORef (FogCoord1 1)
f2′ <- newIORef (FogCoord1 5)
f3′ <- newIORef (FogCoord1 10)
return $ State { f1 = f1′, f2 = f2′, f3 = f3′ }
makeState = do
f1′ <- newIORef (FogCoord1 1)
f2′ <- newIORef (FogCoord1 5)
f3′ <- newIORef (FogCoord1 10)
return $ State { f1 = f1′, f2 = f2′, f3 = f3′ }
— Initialize fog
myInit :: IO ()
myInit = do
let theFogColor = Color4 0 0.25 0.25 1
fog $= Enabled
fogMode $= Exp 0.25
fogColor $= theFogColor
hint Fog $= DontCare
fogCoordSrc $= FogCoord
clearColor $= theFogColor
myInit :: IO ()
myInit = do
let theFogColor = Color4 0 0.25 0.25 1
fog $= Enabled
fogMode $= Exp 0.25
fogColor $= theFogColor
hint Fog $= DontCare
fogCoordSrc $= FogCoord
clearColor $= theFogColor
drawTriangle :: State -> (State -> IORef (FogCoord1 GLfloat)) -> Vertex3 GLfloat -> IO ()
drawTriangle state f v = do
fc <- get (f state)
fogCoord fc
vertex v
drawTriangle state f v = do
fc <- get (f state)
fogCoord fc
vertex v
— display draws a triangle at an angle.
display :: State -> DisplayCallback
display state = do
clear [ ColorBuffer ]
display :: State -> DisplayCallback
display state = do
clear [ ColorBuffer ]
color (Color3 1 0.75 (0 :: GLfloat))
renderPrimitive Triangles $ do
drawTriangle state f1 (Vertex3 2 (-2) 0 )
drawTriangle state f2 (Vertex3 (-2) 0 (-5))
drawTriangle state f3 (Vertex3 0 2 (-10))
renderPrimitive Triangles $ do
drawTriangle state f1 (Vertex3 2 (-2) 0 )
drawTriangle state f2 (Vertex3 (-2) 0 (-5))
drawTriangle state f3 (Vertex3 0 2 (-10))
swapBuffers
reshape :: ReshapeCallback
reshape size = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
perspective 45 1 0.25 25
matrixMode $= Modelview 0
loadIdentity
translate (Vector3 0 0 (-5 :: GLfloat))
reshape size = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
perspective 45 1 0.25 25
matrixMode $= Modelview 0
loadIdentity
translate (Vector3 0 0 (-5 :: GLfloat))
keyboard :: State -> KeyboardMouseCallback
keyboard state (Char c) Down _ _ = case c of
‘c’ -> setSrc FragmentDepth
‘C’ -> setSrc FogCoord
‘1’ -> inc f1 0.25
‘2’ -> inc f2 0.25
‘3’ -> inc f3 0.25
‘8’ -> inc f1 (-0.25)
‘9’ -> inc f2 (-0.25)
‘0’ -> inc f3 (-0.25)
‘b’ -> trans (-0.25)
‘f’ -> trans 0.25
‘\27’ -> exitWith ExitSuccess
_ -> return ()
where setSrc :: FogCoordSrc -> IO ()
setSrc s = do
fogCoordSrc $= s
postRedisplay Nothing
keyboard state (Char c) Down _ _ = case c of
‘c’ -> setSrc FragmentDepth
‘C’ -> setSrc FogCoord
‘1’ -> inc f1 0.25
‘2’ -> inc f2 0.25
‘3’ -> inc f3 0.25
‘8’ -> inc f1 (-0.25)
‘9’ -> inc f2 (-0.25)
‘0’ -> inc f3 (-0.25)
‘b’ -> trans (-0.25)
‘f’ -> trans 0.25
‘\27’ -> exitWith ExitSuccess
_ -> return ()
where setSrc :: FogCoordSrc -> IO ()
setSrc s = do
fogCoordSrc $= s
postRedisplay Nothing
inc :: (State -> IORef (FogCoord1 GLfloat)) -> GLfloat -> IO ()
inc f x = do
FogCoord1 oldValue <- get (f state)
let newValue = oldValue + x
when (newValue > 0) $ do
f state $= FogCoord1 newValue
postRedisplay Nothing
inc f x = do
FogCoord1 oldValue <- get (f state)
let newValue = oldValue + x
when (newValue > 0) $ do
f state $= FogCoord1 newValue
postRedisplay Nothing
trans :: GLfloat -> IO ()
trans x = do
matrixMode $= Modelview 0
translate (Vector3 0 0 x)
postRedisplay Nothing
keyboard _ _ _ _ _ = return ()
trans x = do
matrixMode $= Modelview 0
translate (Vector3 0 0 x)
postRedisplay Nothing
keyboard _ _ _ _ _ = return ()
— Main Loop: Open window with initial window size, title bar, RGBA display
— mode, and handle input events.
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ DoubleBuffered, RGBMode ]
initialWindowSize $= Size 500 500
_ <- createWindow progName
state <- makeState
myInit
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboard state)
displayCallback $= display state
mainLoop
— mode, and handle input events.
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ DoubleBuffered, RGBMode ]
initialWindowSize $= Size 500 500
_ <- createWindow progName
state <- makeState
myInit
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboard state)
displayCallback $= display state
mainLoop
{-
PointP.hs (adapted from pointp.c which is (c) Silicon Graphics, Inc.)
Copyright (c) Sven Panne 2002-2006 <svenpanne@gmail.com>
This file is part of HOpenGL and distributed under a BSD-style license
See the file libraries/GLUT/LICENSE
PointP.hs (adapted from pointp.c which is (c) Silicon Graphics, Inc.)
Copyright (c) Sven Panne 2002-2006 <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 point parameters and their effect on point
primitives. 250 points are randomly generated within a 10 by 10 by 40 region,
centered at the origin. In some modes (including the default), points that
are closer to the viewer will appear larger.
primitives. 250 points are randomly generated within a 10 by 10 by 40 region,
centered at the origin. In some modes (including the default), points that
are closer to the viewer will appear larger.
Pressing the ‘c’, ‘l’, and ‘q’ keys switch the point parameters attenuation
mode to constant, linear, or quadratic, respectively.
mode to constant, linear, or quadratic, respectively.
Pressing the ‘f’ and ‘b’ keys move the viewer forward and backwards. In
either linear or quadratic attenuation mode, the distance from the viewer to
the point will change the size of the point primitive.
either linear or quadratic attenuation mode, the distance from the viewer to
the point will change the size of the point primitive.
Pressing the ‘+’ and ‘-‘ keys will change the current point size. In this
program, the point size is bounded, so it will not get less than 2, nor
greater than the maximum returned by pointSizeRange.
-}
program, the point size is bounded, so it will not get less than 2, nor
greater than the maximum returned by pointSizeRange.
-}
import Control.Monad ( when, unless )
import Data.IORef ( IORef, newIORef )
import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure )
import System.Random ( randomRIO )
import Graphics.UI.GLUT
import Data.IORef ( IORef, newIORef )
import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure )
import System.Random ( randomRIO )
import Graphics.UI.GLUT
type Attenuation = (GLfloat,GLfloat,GLfloat)
constant, linear, quadratic :: Attenuation
constant = (1, 0, 0 )
linear = (0, 0.12, 0 )
quadratic = (0, 0, 0.01)
constant = (1, 0, 0 )
linear = (0, 0.12, 0 )
quadratic = (0, 0, 0.01)
data State = State { distance :: IORef GLfloat }
makeState :: IO State
makeState = do
d <- newIORef (-10)
return $ State { distance = d }
makeState = do
d <- newIORef (-10)
return $ State { distance = d }
— CFloat has no Random instance, so we go via Float
randomGLfloat :: (GLfloat, GLfloat) -> IO GLfloat
randomGLfloat = fmap floatToGLfloat . randomRIO . fmapPair glFloatToFloat
where fmapPair f (x, y) = (f x, f y)
floatToGLfloat = realToFrac :: Float -> GLfloat
glFloatToFloat = realToFrac :: GLfloat -> Float
randomGLfloat :: (GLfloat, GLfloat) -> IO GLfloat
randomGLfloat = fmap floatToGLfloat . randomRIO . fmapPair glFloatToFloat
where fmapPair f (x, y) = (f x, f y)
floatToGLfloat = realToFrac :: Float -> GLfloat
glFloatToFloat = realToFrac :: GLfloat -> Float
randomColor :: IO (Color3 GLfloat)
randomColor = do
g <- randomGLfloat (0.5, 1)
b <- randomGLfloat (0, 1)
return $ Color3 1 g b
randomColor = do
g <- randomGLfloat (0.5, 1)
b <- randomGLfloat (0, 1)
return $ Color3 1 g b
randomVertex :: IO (Vertex3 GLfloat)
randomVertex = do
x <- randomGLfloat (-5, 5)
y <- randomGLfloat (-5, 5)
z <- randomGLfloat (-5, -45)
return $ Vertex3 x y z
randomVertex = do
x <- randomGLfloat (-5, 5)
y <- randomGLfloat (-5, 5)
z <- randomGLfloat (-5, -45)
return $ Vertex3 x y z
myInit :: IO DisplayList
myInit = do
pointList <- defineNewList Compile $
renderPrimitive Points $
sequence_ $ replicate 250 $ do
color =<< randomColor
vertex =<< randomVertex
myInit = do
pointList <- defineNewList Compile $
renderPrimitive Points $
sequence_ $ replicate 250 $ do
color =<< randomColor
vertex =<< randomVertex
depthFunc $= Just Less
pointSmooth $= Enabled
blend $= Enabled
blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
pointSize $= 7
pointSmooth $= Enabled
blend $= Enabled
blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
pointSize $= 7
pointDistanceAttenuation $= linear
pointFadeThresholdSize $= 2
pointFadeThresholdSize $= 2
return pointList
display :: State -> DisplayList -> DisplayCallback
display state pointList = do
clear [ ColorBuffer, DepthBuffer ]
d <- get (distance state)
loadIdentity
translate (Vector3 0 0 d)
callList pointList
swapBuffers
display state pointList = do
clear [ ColorBuffer, DepthBuffer ]
d <- get (distance state)
loadIdentity
translate (Vector3 0 0 d)
callList pointList
swapBuffers
reshape :: ReshapeCallback
reshape size = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
perspective 35 1 0.25 200
matrixMode $= Modelview 0
reshape size = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
perspective 35 1 0.25 200
matrixMode $= Modelview 0
setPointDistanceAttenuation :: Attenuation -> IO ()
setPointDistanceAttenuation att = do
pointDistanceAttenuation $= att
postRedisplay Nothing
setPointDistanceAttenuation att = do
pointDistanceAttenuation $= att
postRedisplay Nothing
incDistance :: State -> GLfloat -> IO ()
incDistance state inc = do
distance state $~ (+ inc)
postRedisplay Nothing
incDistance state inc = do
distance state $~ (+ inc)
postRedisplay Nothing
incPointSize :: GLfloat -> IO ()
incPointSize inc = do
newPointSize <- fmap (+ inc) $ get pointSize
(_,maxPointSize) <- get pointSizeRange
when (2 <= newPointSize && newPointSize <= maxPointSize) $ do
pointSize $= newPointSize
postRedisplay Nothing
incPointSize inc = do
newPointSize <- fmap (+ inc) $ get pointSize
(_,maxPointSize) <- get pointSizeRange
when (2 <= newPointSize && newPointSize <= maxPointSize) $ do
pointSize $= newPointSize
postRedisplay Nothing
keyboard :: State -> KeyboardMouseCallback
keyboard state (Char c) Down _ _ = case c of
‘c’ -> setPointDistanceAttenuation constant
‘l’ -> setPointDistanceAttenuation linear
‘q’ -> setPointDistanceAttenuation quadratic
‘b’ -> incDistance state (-0.5)
‘f’ -> incDistance state 0.5
‘+’ -> incPointSize 1
‘-‘ -> incPointSize (-1)
‘\27’ -> exitWith ExitSuccess
_ -> return ()
keyboard _ _ _ _ _ = return ()
keyboard state (Char c) Down _ _ = case c of
‘c’ -> setPointDistanceAttenuation constant
‘l’ -> setPointDistanceAttenuation linear
‘q’ -> setPointDistanceAttenuation quadratic
‘b’ -> incDistance state (-0.5)
‘f’ -> incDistance state 0.5
‘+’ -> incPointSize 1
‘-‘ -> incPointSize (-1)
‘\27’ -> exitWith ExitSuccess
_ -> return ()
keyboard _ _ _ _ _ = return ()
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ RGBMode, DoubleBuffered, WithDepthBuffer, Multisampling ]
initialWindowSize $= Size 500 500
initialWindowPosition $= Position 100 100
_ <- createWindow progName
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ RGBMode, DoubleBuffered, WithDepthBuffer, Multisampling ]
initialWindowSize $= Size 500 500
initialWindowPosition $= Position 100 100
_ <- createWindow progName
— We have to do this *after* createWindow, otherwise we have no OpenGL
— context. Note that the original C example simply tests for OpenGL 1.4 at
— compile time, we do a runtime check for the needed extension.
extensions <- get glExtensions
unless (“GL_ARB_point_parameters” `elem` extensions) $ do
putStrLn “Sorry, this demo requires the GL_ARB_point_parameters extension.”
exitFailure
— context. Note that the original C example simply tests for OpenGL 1.4 at
— compile time, we do a runtime check for the needed extension.
extensions <- get glExtensions
unless (“GL_ARB_point_parameters” `elem` extensions) $ do
putStrLn “Sorry, this demo requires the GL_ARB_point_parameters extension.”
exitFailure
state <- makeState
pointList <- myInit
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboard state)
displayCallback $= display state pointList
mainLoop
pointList <- myInit
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboard state)
displayCallback $= display state pointList
mainLoop
{-
PolyOff.hs (adapted from polyoff.c which is (c) Silicon Graphics, Inc.)
Copyright (c) Sven Panne 2002-2006 <svenpanne@gmail.com>
This file is part of HOpenGL and distributed under a BSD-style license
See the file libraries/GLUT/LICENSE
PolyOff.hs (adapted from polyoff.c which is (c) Silicon Graphics, Inc.)
Copyright (c) Sven Panne 2002-2006 <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 offset to draw a shaded polygon and its
wireframe counterpart without ugly visual artifacts (“stitching”).
-}
wireframe counterpart without ugly visual artifacts (“stitching”).
-}
import Control.Monad ( when )
import Data.IORef ( IORef, newIORef )
import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure )
import Graphics.UI.GLUT
import Data.IORef ( IORef, newIORef )
import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure )
import Graphics.UI.GLUT
data State = State {
spinX, spinY :: IORef GLfloat,
tDist :: IORef GLfloat,
polyFactor :: IORef GLfloat,
polyUnits :: IORef GLfloat
}
spinX, spinY :: IORef GLfloat,
tDist :: IORef GLfloat,
polyFactor :: IORef GLfloat,
polyUnits :: IORef GLfloat
}
makeState :: IO State
makeState = do
x <- newIORef 0
y <- newIORef 0
t <- newIORef 0
f <- newIORef 1
u <- newIORef 1
return $ State { spinX = x, spinY = y, tDist = t, polyFactor = f, polyUnits = u }
makeState = do
x <- newIORef 0
y <- newIORef 0
t <- newIORef 0
f <- newIORef 1
u <- newIORef 1
return $ State { spinX = x, spinY = y, tDist = t, polyFactor = f, polyUnits = u }
— display draws two spheres, one with a gray, diffuse material, the other
— sphere with a magenta material with a specular highlight.
display :: State -> DisplayList -> DisplayCallback
display state sphereList = do
clear [ ColorBuffer, DepthBuffer ]
preservingMatrix $ do
t <- get (tDist state)
translate (Vector3 0 0 t)
x <- get (spinX state)
rotate x (Vector3 1 0 0)
y <- get (spinY state)
rotate y (Vector3 0 1 0)
— sphere with a magenta material with a specular highlight.
display :: State -> DisplayList -> DisplayCallback
display state sphereList = do
clear [ ColorBuffer, DepthBuffer ]
preservingMatrix $ do
t <- get (tDist state)
translate (Vector3 0 0 t)
x <- get (spinX state)
rotate x (Vector3 1 0 0)
y <- get (spinY state)
rotate y (Vector3 0 1 0)
materialAmbientAndDiffuse Front $= Color4 0.8 0.8 0.8 1
materialSpecular Front $= Color4 0 0 0 1
materialShininess Front $= 0
lighting $= Enabled
light (Light 0) $= Enabled
polygonOffsetFill $= Enabled
f <- get (polyFactor state)
u <- get (polyUnits state)
polygonOffset $= (f, u)
callList sphereList
polygonOffsetFill $= Disabled
materialSpecular Front $= Color4 0 0 0 1
materialShininess Front $= 0
lighting $= Enabled
light (Light 0) $= Enabled
polygonOffsetFill $= Enabled
f <- get (polyFactor state)
u <- get (polyUnits state)
polygonOffset $= (f, u)
callList sphereList
polygonOffsetFill $= Disabled
lighting $= Disabled
light (Light 0) $= Disabled
color (Color3 1 1 (1 :: GLfloat))
polygonMode $= (Line, Line)
callList sphereList
polygonMode $= (Fill, Fill)
light (Light 0) $= Disabled
color (Color3 1 1 (1 :: GLfloat))
polygonMode $= (Line, Line)
callList sphereList
polygonMode $= (Fill, Fill)
flush
— specify initial properties
— create display list with sphere
— initialize lighting and depth buffer
gfxinit :: IO DisplayList
gfxinit = do
clearColor $= Color4 0 0 0 1
— create display list with sphere
— initialize lighting and depth buffer
gfxinit :: IO DisplayList
gfxinit = do
clearColor $= Color4 0 0 0 1
sphereList <- defineNewList Compile $
renderObject Solid (Sphere’ 1 20 12)
renderObject Solid (Sphere’ 1 20 12)
depthFunc $= Just Less
ambient (Light 0) $= Color4 0 0 0 1
diffuse (Light 0) $= Color4 1 1 1 1
specular (Light 0) $= Color4 1 1 1 1
position (Light 0) $= Vertex4 1 1 1 0
lightModelAmbient $= Color4 0.2 0.2 0.2 1
diffuse (Light 0) $= Color4 1 1 1 1
specular (Light 0) $= Color4 1 1 1 1
position (Light 0) $= Vertex4 1 1 1 0
lightModelAmbient $= Color4 0.2 0.2 0.2 1
return sphereList
reshape :: ReshapeCallback
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
perspective 45 (fromIntegral w / fromIntegral h) 1 10
matrixMode $= Modelview 0
loadIdentity
lookAt (Vertex3 0 0 5) (Vertex3 0 0 0) (Vector3 0 1 0)
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
perspective 45 (fromIntegral w / fromIntegral h) 1 10
matrixMode $= Modelview 0
loadIdentity
lookAt (Vertex3 0 0 5) (Vertex3 0 0 0) (Vector3 0 1 0)
incSpin :: IORef GLfloat -> IO ()
incSpin spinRef = do
let wrap n s = if s > n then s – n else s
spinRef $~ (wrap 360 . (+ 5))
postRedisplay Nothing
incSpin spinRef = do
let wrap n s = if s > n then s – n else s
spinRef $~ (wrap 360 . (+ 5))
postRedisplay Nothing
incDist :: State -> GLfloat -> IO ()
incDist state inc = do
newDist <- fmap (+ inc) $ get (tDist state)
when (-5 <= newDist && newDist <= 4) $ do
tDist state $= newDist
postRedisplay Nothing
incDist state inc = do
newDist <- fmap (+ inc) $ get (tDist state)
when (-5 <= newDist && newDist <= 4) $ do
tDist state $= newDist
postRedisplay Nothing
incPoly :: String -> IORef GLfloat -> GLfloat -> IO ()
incPoly name polyRef inc = do
polyRef $~ (+ inc)
p <- get polyRef
putStrLn (name ++ ” is ” ++ show p)
postRedisplay Nothing
incPoly name polyRef inc = do
polyRef $~ (+ inc)
p <- get polyRef
putStrLn (name ++ ” is ” ++ show p)
postRedisplay Nothing
keyboardMouse :: State -> KeyboardMouseCallback
keyboardMouse state k Down _ _ = case k of
(MouseButton LeftButton) -> incSpin (spinX state)
(MouseButton MiddleButton) -> incSpin (spinY state)
(MouseButton RightButton) -> exitWith ExitSuccess
(Char ‘t’) -> incDist state 0.5
(Char ‘T’) -> incDist state (-0.5)
(Char ‘F’) -> incPoly “polyFactor” (polyFactor state) 0.1
(Char ‘f’) -> incPoly “polyFactor” (polyFactor state) (-0.1)
(Char ‘U’) -> incPoly “polyUnits” (polyUnits state) 1
(Char ‘u’) -> incPoly “polyUnits” (polyUnits state) (-1)
_ -> return ()
keyboardMouse _ _ _ _ _ = return ()
keyboardMouse state k Down _ _ = case k of
(MouseButton LeftButton) -> incSpin (spinX state)
(MouseButton MiddleButton) -> incSpin (spinY state)
(MouseButton RightButton) -> exitWith ExitSuccess
(Char ‘t’) -> incDist state 0.5
(Char ‘T’) -> incDist state (-0.5)
(Char ‘F’) -> incPoly “polyFactor” (polyFactor state) 0.1
(Char ‘f’) -> incPoly “polyFactor” (polyFactor state) (-0.1)
(Char ‘U’) -> incPoly “polyUnits” (polyUnits state) 1
(Char ‘u’) -> incPoly “polyUnits” (polyUnits state) (-1)
_ -> return ()
keyboardMouse _ _ _ _ _ = return ()
— Main Loop: Open window with initial window size, title bar, RGBA display
— mode, and handle input events.
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]
_ <- createWindow progName
— mode, and handle input events.
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]
_ <- createWindow progName
— we have to do this *after* createWindow, otherwise we have no OpenGL context
version <- get (majorMinor glVersion)
when (version == (1,0)) $ do
putStrLn “This program demonstrates a feature which is not in OpenGL Version 1.0.”
putStrLn “If your implementation of OpenGL Version 1.0 has the right extensions,”
putStrLn “you may be able to modify this program to make it run.”
exitFailure
version <- get (majorMinor glVersion)
when (version == (1,0)) $ do
putStrLn “This program demonstrates a feature which is not in OpenGL Version 1.0.”
putStrLn “If your implementation of OpenGL Version 1.0 has the right extensions,”
putStrLn “you may be able to modify this program to make it run.”
exitFailure
state <- makeState
sphereList <- gfxinit
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboardMouse state)
displayCallback $= display state sphereList
mainLoop
sphereList <- gfxinit
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboardMouse state)
displayCallback $= display state sphereList
mainLoop
InfoCad Blog 