{-
Checker.hs (adapted from checker.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
Checker.hs (adapted from checker.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 texture maps a checkerboard image onto two rectangles.
Texture objects are only used when GL_EXT_texture_object is supported.
-}
-}
import Control.Monad ( when )
import Data.Maybe ( isJust )
import Data.Bits ( (.&.) )
import Foreign ( withArray )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
import Data.Maybe ( isJust )
import Data.Bits ( (.&.) )
import Foreign ( withArray )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
— Create checkerboard image
checkImageSize :: TextureSize2D
checkImageSize = TextureSize2D 64 64
checkImageSize :: TextureSize2D
checkImageSize = TextureSize2D 64 64
withCheckImage :: TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte))
-> (PixelData (Color4 GLubyte) -> IO ()) -> IO ()
withCheckImage (TextureSize2D w h) n f act =
withArray [ f c |
i <- [ 0 .. w – 1 ],
j <- [ 0 .. h – 1 ],
let c | (i .&. n) == (j .&. n) = 0
| otherwise = 255 ] $
act. PixelData RGBA UnsignedByte
-> (PixelData (Color4 GLubyte) -> IO ()) -> IO ()
withCheckImage (TextureSize2D w h) n f act =
withArray [ f c |
i <- [ 0 .. w – 1 ],
j <- [ 0 .. h – 1 ],
let c | (i .&. n) == (j .&. n) = 0
| otherwise = 255 ] $
act. PixelData RGBA UnsignedByte
myInit :: IO (Maybe TextureObject)
myInit = do
clearColor $= Color4 0 0 0 0
shadeModel $= Flat
depthFunc $= Just Less
rowAlignment Unpack $= 1
myInit = do
clearColor $= Color4 0 0 0 0
shadeModel $= Flat
depthFunc $= Just Less
rowAlignment Unpack $= 1
exts <- get glExtensions
mbTexName <- if “GL_EXT_texture_object” `elem` exts
then fmap Just genObjectName
else return Nothing
when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName
mbTexName <- if “GL_EXT_texture_object” `elem` exts
then fmap Just genObjectName
else return Nothing
when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName
textureWrapMode Texture2D S $= (Repeated, Repeat)
textureWrapMode Texture2D T $= (Repeated, Repeat)
textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
withCheckImage checkImageSize 0x8 (\c -> Color4 c c c 255) $
texImage2D Texture2D NoProxy 0 RGBA’ checkImageSize 0
return mbTexName
textureWrapMode Texture2D T $= (Repeated, Repeat)
textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
withCheckImage checkImageSize 0x8 (\c -> Color4 c c c 255) $
texImage2D Texture2D NoProxy 0 RGBA’ checkImageSize 0
return mbTexName
display :: Maybe TextureObject -> DisplayCallback
display mbTexName = do
clear [ ColorBuffer, DepthBuffer ]
texture Texture2D $= Enabled
textureFunction $= Decal
when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName
display mbTexName = do
clear [ ColorBuffer, DepthBuffer ]
texture Texture2D $= Enabled
textureFunction $= Decal
when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName
— resolve overloading, not needed in “real” programs
let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO ()
vertex3f = vertex :: Vertex3 GLfloat -> IO ()
renderPrimitive Quads $ do
texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0) (-1.0) 0.0 )
texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 (-2.0) 1.0 0.0 )
texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 0.0 1.0 0.0 )
texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 0.0 (-1.0) 0.0 )
let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO ()
vertex3f = vertex :: Vertex3 GLfloat -> IO ()
renderPrimitive Quads $ do
texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0) (-1.0) 0.0 )
texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 (-2.0) 1.0 0.0 )
texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 0.0 1.0 0.0 )
texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 0.0 (-1.0) 0.0 )
texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 1.0 (-1.0) 0.0 )
texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 1.0 1.0 0.0 )
texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 2.41421 1.0 (-1.41421))
texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 2.41421 (-1.0) (-1.41421))
flush
texture Texture2D $= Disabled
texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 1.0 1.0 0.0 )
texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 2.41421 1.0 (-1.41421))
texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 2.41421 (-1.0) (-1.41421))
flush
texture Texture2D $= Disabled
reshape :: ReshapeCallback
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
perspective 60 (fromIntegral w / fromIntegral h) 1 30
matrixMode $= Modelview 0
loadIdentity
translate (Vector3 0 0 (-3.6 :: GLfloat))
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
perspective 60 (fromIntegral w / fromIntegral h) 1 30
matrixMode $= Modelview 0
loadIdentity
translate (Vector3 0 0 (-3.6 :: GLfloat))
keyboard :: KeyboardMouseCallback
keyboard (Char ‘\27’) Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ = return ()
keyboard (Char ‘\27’) Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ = return ()
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 250 250
initialWindowPosition $= Position 100 100
_ <- createWindow progName
mbTexName <- myInit
displayCallback $= display mbTexName
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just keyboard
mainLoop
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 250 250
initialWindowPosition $= Position 100 100
_ <- createWindow progName
mbTexName <- myInit
displayCallback $= display mbTexName
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just keyboard
mainLoop
{-
TexSub.hs (adapted from texsub.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
TexSub.hs (adapted from texsub.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 texture maps a checkerboard image onto two rectangles. This
program clamps the texture, if the texture coordinates fall outside 0.0
and 1.0. If the s key is pressed, a texture subimage is used to alter the
original texture. If the r key is pressed, the original texture is restored.
-}
program clamps the texture, if the texture coordinates fall outside 0.0
and 1.0. If the s key is pressed, a texture subimage is used to alter the
original texture. If the r key is pressed, the original texture is restored.
-}
import Control.Monad ( when )
import Data.Char ( toLower )
import Data.Bits ( (.&.) )
import Foreign ( newArray )
import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
import Data.Char ( toLower )
import Data.Bits ( (.&.) )
import Foreign ( newArray )
import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
checkImageSize, subImageSize :: TextureSize2D
checkImageSize = TextureSize2D 64 64
subImageSize = TextureSize2D 16 16
checkImageSize = TextureSize2D 64 64
subImageSize = TextureSize2D 16 16
type Image = PixelData (Color4 GLubyte)
makeCheckImage ::
TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte)) -> IO Image
makeCheckImage (TextureSize2D w h) n f =
fmap (PixelData RGBA UnsignedByte) $
newArray [ f c |
i <- [ 0 .. w – 1 ],
j <- [ 0 .. h – 1 ],
let c | (i .&. n) == (j .&. n) = 0
| otherwise = 255 ]
TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte)) -> IO Image
makeCheckImage (TextureSize2D w h) n f =
fmap (PixelData RGBA UnsignedByte) $
newArray [ f c |
i <- [ 0 .. w – 1 ],
j <- [ 0 .. h – 1 ],
let c | (i .&. n) == (j .&. n) = 0
| otherwise = 255 ]
myInit :: IO (TextureObject, Image, Image)
myInit = do
clearColor $= Color4 0 0 0 0
shadeModel $= Flat
depthFunc $= Just Less
myInit = do
clearColor $= Color4 0 0 0 0
shadeModel $= Flat
depthFunc $= Just Less
checkImage <- makeCheckImage checkImageSize 0x8 (\c -> Color4 c c c 255)
subImage <- makeCheckImage subImageSize 0x4 (\c -> Color4 c 0 0 255)
rowAlignment Unpack $= 1
subImage <- makeCheckImage subImageSize 0x4 (\c -> Color4 c 0 0 255)
rowAlignment Unpack $= 1
texName <- genObjectName
textureBinding Texture2D $= Just texName
textureBinding Texture2D $= Just texName
textureWrapMode Texture2D S $= (Repeated, Repeat)
textureWrapMode Texture2D T $= (Repeated, Repeat)
textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
texImage2D Texture2D NoProxy 0 RGBA’ checkImageSize 0 checkImage
return (texName, checkImage, subImage)
textureWrapMode Texture2D T $= (Repeated, Repeat)
textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
texImage2D Texture2D NoProxy 0 RGBA’ checkImageSize 0 checkImage
return (texName, checkImage, subImage)
display :: TextureObject -> DisplayCallback
display texName = do
clear [ ColorBuffer, DepthBuffer ]
texture Texture2D $= Enabled
textureFunction $= Decal
textureBinding Texture2D $= Just texName
display texName = do
clear [ ColorBuffer, DepthBuffer ]
texture Texture2D $= Enabled
textureFunction $= Decal
textureBinding Texture2D $= Just texName
— resolve overloading, not needed in “real” programs
let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO ()
vertex3f = vertex :: Vertex3 GLfloat -> IO ()
renderPrimitive Quads $ do
texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0) (-1.0) 0.0 )
texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 (-2.0) 1.0 0.0 )
texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 0.0 1.0 0.0 )
texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 0.0 (-1.0) 0.0 )
let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO ()
vertex3f = vertex :: Vertex3 GLfloat -> IO ()
renderPrimitive Quads $ do
texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0) (-1.0) 0.0 )
texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 (-2.0) 1.0 0.0 )
texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 0.0 1.0 0.0 )
texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 0.0 (-1.0) 0.0 )
texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 1.0 (-1.0) 0.0 )
texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 1.0 1.0 0.0 )
texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 2.41421 1.0 (-1.41421))
texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 2.41421 (-1.0) (-1.41421))
flush
texture Texture2D $= Disabled
texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 1.0 1.0 0.0 )
texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 2.41421 1.0 (-1.41421))
texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 2.41421 (-1.0) (-1.41421))
flush
texture Texture2D $= Disabled
reshape :: ReshapeCallback
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
perspective 60 (fromIntegral w / fromIntegral h) 1 30
matrixMode $= Modelview 0
loadIdentity
translate (Vector3 0 0 (-3.6 :: GLfloat))
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
perspective 60 (fromIntegral w / fromIntegral h) 1 30
matrixMode $= Modelview 0
loadIdentity
translate (Vector3 0 0 (-3.6 :: GLfloat))
keyboard :: TextureObject -> Image -> Image -> KeyboardMouseCallback
keyboard texName checkImage subImage (Char c) Down _ _ = case toLower c of
‘s’ -> do
textureBinding Texture2D $= Just texName
texSubImage2D Texture2D 0 (TexturePosition2D 12 44) subImageSize subImage
postRedisplay Nothing
‘r’ -> do
textureBinding Texture2D $= Just texName
texImage2D Texture2D NoProxy 0 RGBA’ checkImageSize 0 checkImage
postRedisplay Nothing
‘\27’ -> exitWith ExitSuccess
_ -> return ()
keyboard _ _ _ _ _ _ _ = return ()
keyboard texName checkImage subImage (Char c) Down _ _ = case toLower c of
‘s’ -> do
textureBinding Texture2D $= Just texName
texSubImage2D Texture2D 0 (TexturePosition2D 12 44) subImageSize subImage
postRedisplay Nothing
‘r’ -> do
textureBinding Texture2D $= Just texName
texImage2D Texture2D NoProxy 0 RGBA’ checkImageSize 0 checkImage
postRedisplay Nothing
‘\27’ -> exitWith ExitSuccess
_ -> return ()
keyboard _ _ _ _ _ _ _ = return ()
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 250 250
initialWindowPosition $= Position 100 100
_ <- 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
(texName, checkImage, subImage) <- myInit
displayCallback $= display texName
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboard texName checkImage subImage)
mainLoop
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 250 250
initialWindowPosition $= Position 100 100
_ <- 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
(texName, checkImage, subImage) <- myInit
displayCallback $= display texName
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboard texName checkImage subImage)
mainLoop
{-
Texture3D.hs (adapted from texture3d.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
Texture3D.hs (adapted from texture3d.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 using a three-dimensional texture. It creates
a 3D texture and then renders two rectangles with different texture
coordinates to obtain different “slices” of the 3D texture.
-}
a 3D texture and then renders two rectangles with different texture
coordinates to obtain different “slices” of the 3D texture.
-}
import Control.Monad ( unless )
import Foreign ( withArray )
import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
import Foreign ( withArray )
import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
— Create checkerboard image
imageSize :: TextureSize3D
imageSize = TextureSize3D 16 16 16
imageSize :: TextureSize3D
imageSize = TextureSize3D 16 16 16
withImage :: (PixelData (Color3 GLubyte) -> IO ()) -> IO ()
withImage act =
withArray [ Color3 (s * 17) (t * 17) (r * 17) |
r <- [ 0 .. fromIntegral d – 1 ],
t <- [ 0 .. fromIntegral h – 1 ],
s <- [ 0 .. fromIntegral w – 1 ] ] $
act . PixelData RGB UnsignedByte
where (TextureSize3D w h d) = imageSize
withImage act =
withArray [ Color3 (s * 17) (t * 17) (r * 17) |
r <- [ 0 .. fromIntegral d – 1 ],
t <- [ 0 .. fromIntegral h – 1 ],
s <- [ 0 .. fromIntegral w – 1 ] ] $
act . PixelData RGB UnsignedByte
where (TextureSize3D w h d) = imageSize
myInit :: IO ()
myInit = do
clearColor $= Color4 0 0 0 0
shadeModel $= Flat
depthFunc $= Just Less
rowAlignment Unpack $= 1
myInit = do
clearColor $= Color4 0 0 0 0
shadeModel $= Flat
depthFunc $= Just Less
rowAlignment Unpack $= 1
texName <- genObjectName
textureBinding Texture3D $= Just texName
textureWrapMode Texture3D S $= (Repeated, Clamp)
textureWrapMode Texture3D T $= (Repeated, Clamp)
textureWrapMode Texture3D R $= (Repeated, Clamp)
textureFilter Texture3D $= ((Nearest, Nothing), Nearest)
withImage $ texImage3D Texture3D NoProxy 0 RGB’ imageSize 0
texture Texture3D $= Enabled
textureBinding Texture3D $= Just texName
textureWrapMode Texture3D S $= (Repeated, Clamp)
textureWrapMode Texture3D T $= (Repeated, Clamp)
textureWrapMode Texture3D R $= (Repeated, Clamp)
textureFilter Texture3D $= ((Nearest, Nothing), Nearest)
withImage $ texImage3D Texture3D NoProxy 0 RGB’ imageSize 0
texture Texture3D $= Enabled
display :: DisplayCallback
display = do
clear [ ColorBuffer, DepthBuffer ]
— resolve overloading, not needed in “real” programs
let texCoord3f = texCoord :: TexCoord3 GLfloat -> IO ()
vertex3f = vertex :: Vertex3 GLfloat -> IO ()
renderPrimitive Quads $ do
texCoord3f (TexCoord3 0 0 0); vertex3f (Vertex3 (-2.25) (-1) 0)
texCoord3f (TexCoord3 0 1 0); vertex3f (Vertex3 (-2.25) 1 0)
texCoord3f (TexCoord3 1 1 1); vertex3f (Vertex3 (-0.25) 1 0)
texCoord3f (TexCoord3 1 0 1); vertex3f (Vertex3 (-0.25) (-1) 0)
display = do
clear [ ColorBuffer, DepthBuffer ]
— resolve overloading, not needed in “real” programs
let texCoord3f = texCoord :: TexCoord3 GLfloat -> IO ()
vertex3f = vertex :: Vertex3 GLfloat -> IO ()
renderPrimitive Quads $ do
texCoord3f (TexCoord3 0 0 0); vertex3f (Vertex3 (-2.25) (-1) 0)
texCoord3f (TexCoord3 0 1 0); vertex3f (Vertex3 (-2.25) 1 0)
texCoord3f (TexCoord3 1 1 1); vertex3f (Vertex3 (-0.25) 1 0)
texCoord3f (TexCoord3 1 0 1); vertex3f (Vertex3 (-0.25) (-1) 0)
texCoord3f (TexCoord3 0 0 1); vertex3f (Vertex3 0.25 (-1) 0)
texCoord3f (TexCoord3 0 1 1); vertex3f (Vertex3 0.25 1 0)
texCoord3f (TexCoord3 1 1 0); vertex3f (Vertex3 2.25 1 0)
texCoord3f (TexCoord3 1 0 0); vertex3f (Vertex3 2.25 (-1) 0)
flush
texCoord3f (TexCoord3 0 1 1); vertex3f (Vertex3 0.25 1 0)
texCoord3f (TexCoord3 1 1 0); vertex3f (Vertex3 2.25 1 0)
texCoord3f (TexCoord3 1 0 0); vertex3f (Vertex3 2.25 (-1) 0)
flush
reshape :: ReshapeCallback
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
perspective 60 (fromIntegral w / fromIntegral h) 1 30
matrixMode $= Modelview 0
loadIdentity
translate (Vector3 0 0 (-4 :: GLfloat))
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
perspective 60 (fromIntegral w / fromIntegral h) 1 30
matrixMode $= Modelview 0
loadIdentity
translate (Vector3 0 0 (-4 :: GLfloat))
keyboard :: KeyboardMouseCallback
keyboard (Char ‘\27’) Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ = return ()
keyboard (Char ‘\27’) Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ = return ()
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 250 250
initialWindowPosition $= Position 100 100
_ <- createWindow progName
— we have to do this *after* createWindow, otherwise we have no OpenGL context
exts <- get glExtensions
unless (“GL_EXT_texture3D” `elem` exts) $ do
putStrLn “Sorry, this demo requires the GL_EXT_texture3D extension.”
exitFailure
myInit
reshapeCallback $= Just reshape
displayCallback $= display
keyboardMouseCallback $= Just keyboard
mainLoop
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 250 250
initialWindowPosition $= Position 100 100
_ <- createWindow progName
— we have to do this *after* createWindow, otherwise we have no OpenGL context
exts <- get glExtensions
unless (“GL_EXT_texture3D” `elem` exts) $ do
putStrLn “Sorry, this demo requires the GL_EXT_texture3D extension.”
exitFailure
myInit
reshapeCallback $= Just reshape
displayCallback $= display
keyboardMouseCallback $= Just keyboard
mainLoop
{-
Mipmap.hs (adapted from mipmap.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
Mipmap.hs (adapted from mipmap.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 using mipmaps for texture maps. To overtly show
the effect of mipmaps, each mipmap reduction level has a solidly colored,
contrasting texture image. Thus, the quadrilateral which is drawn is drawn
with several different colors.
-}
the effect of mipmaps, each mipmap reduction level has a solidly colored,
contrasting texture image. Thus, the quadrilateral which is drawn is drawn
with several different colors.
-}
import Control.Monad ( when )
import Data.Maybe ( isJust )
import Foreign ( withArray )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
import Data.Maybe ( isJust )
import Foreign ( withArray )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
makeImage :: Level -> TextureSize2D -> Color4 GLubyte -> IO ()
makeImage level size@(TextureSize2D w h) col =
withArray (replicate (fromIntegral (w * h)) col) $
texImage2D Texture2D NoProxy level RGBA’ size 0 . PixelData RGBA UnsignedByte
makeImage level size@(TextureSize2D w h) col =
withArray (replicate (fromIntegral (w * h)) col) $
texImage2D Texture2D NoProxy level RGBA’ size 0 . PixelData RGBA UnsignedByte
makeImages :: [Color4 GLubyte] -> IO ()
makeImages colors = sequence_ $ zipWith3 makeImage levels sizes colors
where numLevels = length colors
levels = [ 0 .. fromIntegral numLevels – 1 ]
sizes = reverse (take numLevels [ TextureSize2D s s | s <- iterate (* 2) 1 ])
makeImages colors = sequence_ $ zipWith3 makeImage levels sizes colors
where numLevels = length colors
levels = [ 0 .. fromIntegral numLevels – 1 ]
sizes = reverse (take numLevels [ TextureSize2D s s | s <- iterate (* 2) 1 ])
myInit :: IO (Maybe TextureObject)
myInit = do
depthFunc $= Just Less
shadeModel $= Flat
myInit = do
depthFunc $= Just Less
shadeModel $= Flat
translate (Vector3 0 0 (-3.6 :: GLfloat))
rowAlignment Unpack $= 1
rowAlignment Unpack $= 1
exts <- get glExtensions
mbTexName <- if “GL_EXT_texture_object” `elem` exts
then fmap Just genObjectName
else return Nothing
when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName
mbTexName <- if “GL_EXT_texture_object” `elem` exts
then fmap Just genObjectName
else return Nothing
when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName
textureWrapMode Texture2D S $= (Repeated, Repeat)
textureWrapMode Texture2D T $= (Repeated, Repeat)
textureFilter Texture2D $= ((Nearest, Just Nearest), Nearest)
textureWrapMode Texture2D T $= (Repeated, Repeat)
textureFilter Texture2D $= ((Nearest, Just Nearest), Nearest)
makeImages [ Color4 255 255 0 255,
Color4 255 0 255 255,
Color4 255 0 0 255,
Color4 0 255 0 255,
Color4 0 0 255 255,
Color4 255 255 255 255 ]
Color4 255 0 255 255,
Color4 255 0 0 255,
Color4 0 255 0 255,
Color4 0 0 255 255,
Color4 255 255 255 255 ]
textureFunction $= Decal
texture Texture2D $= Enabled
return mbTexName
texture Texture2D $= Enabled
return mbTexName
display :: Maybe TextureObject -> DisplayCallback
display mbTexName = do
clear [ ColorBuffer, DepthBuffer ]
when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName
— resolve overloading, not needed in “real” programs
let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO ()
vertex3f = vertex :: Vertex3 GLfloat -> IO ()
renderPrimitive Quads $ do
texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 ( -2) (-1) 0 )
texCoord2f (TexCoord2 0 8); vertex3f (Vertex3 ( -2) 1 0 )
texCoord2f (TexCoord2 8 8); vertex3f (Vertex3 2000 1 (-6000))
texCoord2f (TexCoord2 8 0); vertex3f (Vertex3 2000 (-1) (-6000))
flush
display mbTexName = do
clear [ ColorBuffer, DepthBuffer ]
when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName
— resolve overloading, not needed in “real” programs
let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO ()
vertex3f = vertex :: Vertex3 GLfloat -> IO ()
renderPrimitive Quads $ do
texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 ( -2) (-1) 0 )
texCoord2f (TexCoord2 0 8); vertex3f (Vertex3 ( -2) 1 0 )
texCoord2f (TexCoord2 8 8); vertex3f (Vertex3 2000 1 (-6000))
texCoord2f (TexCoord2 8 0); vertex3f (Vertex3 2000 (-1) (-6000))
flush
reshape :: ReshapeCallback
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
perspective 60 (fromIntegral w / fromIntegral h) 1 30000
matrixMode $= Modelview 0
loadIdentity
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
perspective 60 (fromIntegral w / fromIntegral h) 1 30000
matrixMode $= Modelview 0
loadIdentity
keyboard :: KeyboardMouseCallback
keyboard (Char ‘\27’) Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ = return ()
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 50 50
_ <- createWindow progName
texName <- myInit
displayCallback $= display texName
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just keyboard
mainLoop
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 500 500
initialWindowPosition $= Position 50 50
_ <- createWindow progName
texName <- myInit
displayCallback $= display texName
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just keyboard
mainLoop
{-
TexBind.hs (adapted from texbind.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
TexBind.hs (adapted from texbind.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 using textureBinding by creating and managing
two textures.
-}
two textures.
-}
import Control.Monad ( when )
import Data.Bits ( (.&.) )
import Foreign ( withArray )
import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
import Data.Bits ( (.&.) )
import Foreign ( withArray )
import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
— Create checkerboard image
checkImageSize :: TextureSize2D
checkImageSize = TextureSize2D 64 64
checkImageSize :: TextureSize2D
checkImageSize = TextureSize2D 64 64
withCheckImage :: TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte))
-> (PixelData (Color4 GLubyte) -> IO ()) -> IO ()
withCheckImage (TextureSize2D w h) n f act =
withArray [ f c |
i <- [ 0 .. w – 1 ],
j <- [ 0 .. h – 1 ],
let c | (i .&. n) == (j .&. n) = 0
| otherwise = 255 ] $
act . PixelData RGBA UnsignedByte
-> (PixelData (Color4 GLubyte) -> IO ()) -> IO ()
withCheckImage (TextureSize2D w h) n f act =
withArray [ f c |
i <- [ 0 .. w – 1 ],
j <- [ 0 .. h – 1 ],
let c | (i .&. n) == (j .&. n) = 0
| otherwise = 255 ] $
act . PixelData RGBA UnsignedByte
myInit :: IO (TextureObject, TextureObject)
myInit = do
clearColor $= Color4 0 0 0 0
shadeModel $= Flat
depthFunc $= Just Less
rowAlignment Unpack $= 1
myInit = do
clearColor $= Color4 0 0 0 0
shadeModel $= Flat
depthFunc $= Just Less
rowAlignment Unpack $= 1
[texName0, texName1] <- genObjectNames 2
textureBinding Texture2D $= Just texName0
textureWrapMode Texture2D S $= (Repeated, Clamp)
textureWrapMode Texture2D T $= (Repeated, Clamp)
textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
withCheckImage checkImageSize 0x08 (\c -> Color4 c c c 255) $
texImage2D Texture2D NoProxy 0 RGBA’ checkImageSize 0
textureBinding Texture2D $= Just texName0
textureWrapMode Texture2D S $= (Repeated, Clamp)
textureWrapMode Texture2D T $= (Repeated, Clamp)
textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
withCheckImage checkImageSize 0x08 (\c -> Color4 c c c 255) $
texImage2D Texture2D NoProxy 0 RGBA’ checkImageSize 0
textureBinding Texture2D $= Just texName1
textureWrapMode Texture2D S $= (Repeated, Clamp)
textureWrapMode Texture2D T $= (Repeated, Clamp)
textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
textureFunction $= Decal
withCheckImage checkImageSize 0x10 (\c -> Color4 c 0 0 255) $
texImage2D Texture2D NoProxy 0 RGBA’ checkImageSize 0
texture Texture2D $= Enabled
return (texName0, texName1)
textureWrapMode Texture2D S $= (Repeated, Clamp)
textureWrapMode Texture2D T $= (Repeated, Clamp)
textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
textureFunction $= Decal
withCheckImage checkImageSize 0x10 (\c -> Color4 c 0 0 255) $
texImage2D Texture2D NoProxy 0 RGBA’ checkImageSize 0
texture Texture2D $= Enabled
return (texName0, texName1)
display :: (TextureObject, TextureObject) -> DisplayCallback
display (texName0, texName1) = do
clear [ ColorBuffer, DepthBuffer ]
— resolve overloading, not needed in “real” programs
let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO ()
vertex3f = vertex :: Vertex3 GLfloat -> IO ()
textureBinding Texture2D $= Just texName0
renderPrimitive Quads $ do
texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0) (-1.0) 0.0 )
texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 (-2.0) 1.0 0.0 )
texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 0.0 1.0 0.0 )
texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 0.0 (-1.0) 0.0 )
textureBinding Texture2D $= Just texName1
renderPrimitive Quads $ do
texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 1.0 (-1.0) 0.0 )
texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 1.0 1.0 0.0 )
texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 2.41421 1.0 (-1.41421))
texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 2.41421 (-1.0) (-1.41421))
flush
display (texName0, texName1) = do
clear [ ColorBuffer, DepthBuffer ]
— resolve overloading, not needed in “real” programs
let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO ()
vertex3f = vertex :: Vertex3 GLfloat -> IO ()
textureBinding Texture2D $= Just texName0
renderPrimitive Quads $ do
texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0) (-1.0) 0.0 )
texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 (-2.0) 1.0 0.0 )
texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 0.0 1.0 0.0 )
texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 0.0 (-1.0) 0.0 )
textureBinding Texture2D $= Just texName1
renderPrimitive Quads $ do
texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 1.0 (-1.0) 0.0 )
texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 1.0 1.0 0.0 )
texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 2.41421 1.0 (-1.41421))
texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 2.41421 (-1.0) (-1.41421))
flush
reshape :: ReshapeCallback
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
perspective 60 (fromIntegral w / fromIntegral h) 1 30
matrixMode $= Modelview 0
loadIdentity
translate (Vector3 0 0 (-3.6 :: GLfloat))
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
perspective 60 (fromIntegral w / fromIntegral h) 1 30
matrixMode $= Modelview 0
loadIdentity
translate (Vector3 0 0 (-3.6 :: GLfloat))
keyboard :: KeyboardMouseCallback
keyboard (Char ‘\27’) Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ = return ()
keyboard (Char ‘\27’) Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ = return ()
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 250 250
initialWindowPosition $= Position 100 100
_ <- 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
texNames <- myInit
reshapeCallback $= Just reshape
displayCallback $= display texNames
keyboardMouseCallback $= Just keyboard
mainLoop
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 250 250
initialWindowPosition $= Position 100 100
_ <- 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
texNames <- myInit
reshapeCallback $= Just reshape
displayCallback $= display texNames
keyboardMouseCallback $= Just keyboard
mainLoop
{-
TexGen.hs (adapted from texgen.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
TexGen.hs (adapted from texgen.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 texture mapped teapot with automatically generated
texture coordinates. The texture is rendered as stripes on the teapot.
Initially, the object is drawn with texture coordinates based upon the
object coordinates of the vertex and distance from the plane x = 0.
Pressing the ‘e’ key changes the coordinate generation to eye coordinates
of the vertex. Pressing the ‘o’ key switches it back to the object
coordinates. Pressing the ‘s’ key changes the plane to a slanted one
(x + y + z = 0). Pressing the ‘x’ key switches it back to x = 0.
-}
texture coordinates. The texture is rendered as stripes on the teapot.
Initially, the object is drawn with texture coordinates based upon the
object coordinates of the vertex and distance from the plane x = 0.
Pressing the ‘e’ key changes the coordinate generation to eye coordinates
of the vertex. Pressing the ‘o’ key switches it back to the object
coordinates. Pressing the ‘s’ key changes the plane to a slanted one
(x + y + z = 0). Pressing the ‘x’ key switches it back to x = 0.
-}
import Control.Monad ( when )
import Data.Char ( toLower )
import Data.Maybe ( isJust )
import Foreign ( withArray )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
import Data.Char ( toLower )
import Data.Maybe ( isJust )
import Foreign ( withArray )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
stripeImageWidth :: TextureSize1D
stripeImageWidth = TextureSize1D 32
stripeImageWidth = TextureSize1D 32
xEqualZero, slanted :: Plane GLdouble
xEqualZero = Plane 1 0 0 0
slanted = Plane 1 1 1 0
xEqualZero = Plane 1 0 0 0
slanted = Plane 1 1 1 0
withStripeImage :: (PixelData (Color4 GLubyte) -> IO a) -> IO a
withStripeImage act =
withArray [ Color4 (if j <= 4 then 255 else 0)
(if j > 4 then 255 else 0)
0
255
| j <- [ 0 .. w – 1 ] ] $
act . PixelData RGBA UnsignedByte
where TextureSize1D w = stripeImageWidth
withStripeImage act =
withArray [ Color4 (if j <= 4 then 255 else 0)
(if j > 4 then 255 else 0)
0
255
| j <- [ 0 .. w – 1 ] ] $
act . PixelData RGBA UnsignedByte
where TextureSize1D w = stripeImageWidth
myInit :: IO (Maybe TextureObject)
myInit = do
clearColor $= Color4 0 0 0 0
depthFunc $= Just Less
shadeModel $= Smooth
rowAlignment Unpack $= 1
myInit = do
clearColor $= Color4 0 0 0 0
depthFunc $= Just Less
shadeModel $= Smooth
rowAlignment Unpack $= 1
exts <- get glExtensions
mbTexName <- if “GL_EXT_texture_object” `elem` exts
then fmap Just genObjectName
else return Nothing
when (isJust mbTexName) $ textureBinding Texture1D $= mbTexName
mbTexName <- if “GL_EXT_texture_object” `elem` exts
then fmap Just genObjectName
else return Nothing
when (isJust mbTexName) $ textureBinding Texture1D $= mbTexName
textureWrapMode Texture1D S $= (Repeated, Repeat)
textureFilter Texture1D $= ((Linear’, Nothing), Linear’)
withStripeImage $ texImage1D Texture1D NoProxy 0 RGBA’ stripeImageWidth 0
textureFilter Texture1D $= ((Linear’, Nothing), Linear’)
withStripeImage $ texImage1D Texture1D NoProxy 0 RGBA’ stripeImageWidth 0
textureFunction $= Modulate
textureGenMode S $= Just (ObjectLinear xEqualZero)
textureGenMode S $= Just (ObjectLinear xEqualZero)
texture Texture1D $= Enabled
lighting $= Enabled
light (Light 0) $= Enabled
autoNormal $= Enabled
normalize $= Enabled
frontFace $= CW
cullFace $= Just Back
materialShininess Front $= 64
return mbTexName
lighting $= Enabled
light (Light 0) $= Enabled
autoNormal $= Enabled
normalize $= Enabled
frontFace $= CW
cullFace $= Just Back
materialShininess Front $= 64
return mbTexName
display :: Maybe TextureObject -> DisplayCallback
display mbTexName = do
clear [ ColorBuffer, DepthBuffer ]
preservingMatrix $ do
rotate (45 :: GLfloat) (Vector3 0 0 1)
when (isJust mbTexName) $ textureBinding Texture1D $= mbTexName
renderObject Solid (Teapot 2)
flush
display mbTexName = do
clear [ ColorBuffer, DepthBuffer ]
preservingMatrix $ do
rotate (45 :: GLfloat) (Vector3 0 0 1)
when (isJust mbTexName) $ textureBinding Texture1D $= mbTexName
renderObject Solid (Teapot 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 (-3.5) 3.5 (-3.5*hf/wf) (3.5*hf/wf) (-3.5) 3.5
else ortho (-3.5*wf/hf) (3.5*wf/hf) (-3.5) 3.5 (-3.5) 3.5
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 (-3.5) 3.5 (-3.5*hf/wf) (3.5*hf/wf) (-3.5) 3.5
else ortho (-3.5*wf/hf) (3.5*wf/hf) (-3.5) 3.5 (-3.5) 3.5
matrixMode $= Modelview 0
loadIdentity
keyboard :: KeyboardMouseCallback
keyboard (Char c) Down _ _ = case toLower c of
‘e’ -> setGenMode EyeLinear
‘o’ -> setGenMode ObjectLinear
‘s’ -> setPlane slanted
‘x’ -> setPlane xEqualZero
‘\27’ -> exitWith ExitSuccess
_ -> return ()
keyboard _ _ _ _ = return ()
keyboard (Char c) Down _ _ = case toLower c of
‘e’ -> setGenMode EyeLinear
‘o’ -> setGenMode ObjectLinear
‘s’ -> setPlane slanted
‘x’ -> setPlane xEqualZero
‘\27’ -> exitWith ExitSuccess
_ -> return ()
keyboard _ _ _ _ = return ()
setGenMode :: (Plane GLdouble -> TextureGenMode) -> IO ()
setGenMode mode = do
currentGenMode <- get (textureGenMode S)
case currentGenMode of
Just (EyeLinear plane) -> textureGenMode S $= Just (mode plane)
Just (ObjectLinear plane) -> textureGenMode S $= Just (mode plane)
_ -> error “setGenMode: should never happen…”
postRedisplay Nothing
setGenMode mode = do
currentGenMode <- get (textureGenMode S)
case currentGenMode of
Just (EyeLinear plane) -> textureGenMode S $= Just (mode plane)
Just (ObjectLinear plane) -> textureGenMode S $= Just (mode plane)
_ -> error “setGenMode: should never happen…”
postRedisplay Nothing
setPlane :: Plane GLdouble -> IO ()
setPlane plane = do
currentGenMode <- get (textureGenMode S)
case currentGenMode of
Just (EyeLinear _) -> textureGenMode S $= Just (EyeLinear plane)
Just (ObjectLinear _) -> textureGenMode S $= Just (ObjectLinear plane)
_ -> error “setPlane: should never happen…”
postRedisplay Nothing
setPlane plane = do
currentGenMode <- get (textureGenMode S)
case currentGenMode of
Just (EyeLinear _) -> textureGenMode S $= Just (EyeLinear plane)
Just (ObjectLinear _) -> textureGenMode S $= Just (ObjectLinear plane)
_ -> error “setPlane: should never happen…”
postRedisplay Nothing
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 256 256
initialWindowPosition $= Position 100 100
_ <- createWindow progName
mbTexName <- myInit
displayCallback $= display mbTexName
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just keyboard
mainLoop
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 256 256
initialWindowPosition $= Position 100 100
_ <- createWindow progName
mbTexName <- myInit
displayCallback $= display mbTexName
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just keyboard
mainLoop
{-
CubeMap.hs (adapted from CubeMap.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
CubeMap.hs (adapted from CubeMap.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 cube map textures. Six different colored checker
board textures are created and applied to a lit sphere.
board textures are created and applied to a lit sphere.
Pressing the ‘f’ and ‘b’ keys translate the viewer forward and backward.
-}
-}
import Data.Bits ( (.&.) )
import Data.IORef ( IORef, newIORef )
import Foreign ( withArray )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
import Data.IORef ( IORef, newIORef )
import Foreign ( withArray )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
data State = State { zTrans :: IORef GLfloat }
makeState :: IO State
makeState = do
z <- newIORef 0
return $ State { zTrans = z }
makeState = do
z <- newIORef 0
return $ State { zTrans = z }
imageSize :: TextureSize2D
imageSize = TextureSize2D 4 4
imageSize = TextureSize2D 4 4
withCheckImage :: TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte))
-> (PixelData (Color4 GLubyte) -> IO ()) -> IO ()
withCheckImage (TextureSize2D w h) n f act =
withArray [ f c |
i <- [ 0 .. w – 1 ],
j <- [ 0 .. h – 1 ],
let c | (i .&. n) == (j .&. n) = 0
| otherwise = 255 ] $
act. PixelData RGBA UnsignedByte
-> (PixelData (Color4 GLubyte) -> IO ()) -> IO ()
withCheckImage (TextureSize2D w h) n f act =
withArray [ f c |
i <- [ 0 .. w – 1 ],
j <- [ 0 .. h – 1 ],
let c | (i .&. n) == (j .&. n) = 0
| otherwise = 255 ] $
act. PixelData RGBA UnsignedByte
makeImage :: TextureTargetCubeMapFace -> (GLubyte -> (Color4 GLubyte)) -> IO ()
makeImage target f =
withCheckImage imageSize 0x1 f $
texImage2D target NoProxy 0 RGBA’ imageSize 0
makeImage target f =
withCheckImage imageSize 0x1 f $
texImage2D target NoProxy 0 RGBA’ imageSize 0
myInit :: IO ()
myInit = do
clearColor $= Color4 0 0 0 0
depthFunc $= Just Less
shadeModel $= Smooth
myInit = do
clearColor $= Color4 0 0 0 0
depthFunc $= Just Less
shadeModel $= Smooth
rowAlignment Unpack $= 1
textureWrapMode TextureCubeMap S $= (Repeated, Repeat)
textureWrapMode TextureCubeMap T $= (Repeated, Repeat)
textureWrapMode TextureCubeMap R $= (Repeated, Repeat)
textureFilter TextureCubeMap $= ((Nearest, Nothing), Nearest)
textureWrapMode TextureCubeMap S $= (Repeated, Repeat)
textureWrapMode TextureCubeMap T $= (Repeated, Repeat)
textureWrapMode TextureCubeMap R $= (Repeated, Repeat)
textureFilter TextureCubeMap $= ((Nearest, Nothing), Nearest)
makeImage TextureCubeMapPositiveX (\c -> Color4 c c c 255)
makeImage TextureCubeMapNegativeX (\c -> Color4 0 c c 255)
makeImage TextureCubeMapPositiveY (\c -> Color4 c c 0 255)
makeImage TextureCubeMapNegativeY (\c -> Color4 255 c c 255)
makeImage TextureCubeMapPositiveZ (\c -> Color4 c 0 c 255)
makeImage TextureCubeMapNegativeZ (\c -> Color4 c c 255 255)
makeImage TextureCubeMapNegativeX (\c -> Color4 0 c c 255)
makeImage TextureCubeMapPositiveY (\c -> Color4 c c 0 255)
makeImage TextureCubeMapNegativeY (\c -> Color4 255 c c 255)
makeImage TextureCubeMapPositiveZ (\c -> Color4 c 0 c 255)
makeImage TextureCubeMapNegativeZ (\c -> Color4 c c 255 255)
textureGenMode S $= Just NormalMap
textureGenMode T $= Just NormalMap
textureGenMode R $= Just NormalMap
textureGenMode T $= Just NormalMap
textureGenMode R $= Just NormalMap
textureFunction $= Modulate
texture TextureCubeMap $= Enabled
lighting $= Enabled
light (Light 0) $= Enabled
autoNormal $= Enabled
normalize $= Enabled
materialDiffuse Front $= Color4 1 1 1 1
lighting $= Enabled
light (Light 0) $= Enabled
autoNormal $= Enabled
normalize $= Enabled
materialDiffuse Front $= Color4 1 1 1 1
display :: State -> DisplayCallback
display state = do
clear [ ColorBuffer, DepthBuffer ]
preservingMatrix $ do
z <- get (zTrans state)
translate (Vector3 0 0 z)
renderObject Solid (Sphere’ 5 20 10)
swapBuffers
display state = do
clear [ ColorBuffer, DepthBuffer ]
preservingMatrix $ do
z <- get (zTrans state)
translate (Vector3 0 0 z)
renderObject Solid (Sphere’ 5 20 10)
swapBuffers
reshape :: ReshapeCallback
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
perspective 40 (fromIntegral w / fromIntegral h) 1 300
matrixMode $= Modelview 0
loadIdentity
translate (Vector3 0 0 (-20 :: GLfloat))
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
perspective 40 (fromIntegral w / fromIntegral h) 1 300
matrixMode $= Modelview 0
loadIdentity
translate (Vector3 0 0 (-20 :: GLfloat))
keyboard :: State -> KeyboardMouseCallback
keyboard state (Char ‘f’) Down _ _ = move state (-0.2)
keyboard state (Char ‘b’) Down _ _ = move state 0.2
keyboard _ (Char ‘\27’) Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ _ = return ()
keyboard state (Char ‘f’) Down _ _ = move state (-0.2)
keyboard state (Char ‘b’) Down _ _ = move state 0.2
keyboard _ (Char ‘\27’) Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ _ = return ()
move :: State -> GLfloat -> IO ()
move state inc = do
zTrans state $~ (+ inc)
postRedisplay Nothing
move state inc = do
zTrans state $~ (+ inc)
postRedisplay Nothing
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 400 400
initialWindowPosition $= Position 50 50
_ <- createWindow progName
state <- makeState
myInit
displayCallback $= display state
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboard state)
mainLoop
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 400 400
initialWindowPosition $= Position 50 50
_ <- createWindow progName
state <- makeState
myInit
displayCallback $= display state
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboard state)
mainLoop
{-
MultiTex.hs (adapted from multitex.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
-}
MultiTex.hs (adapted from multitex.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
-}
import Control.Monad ( unless )
import Foreign ( withArray )
import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
import Foreign ( withArray )
import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
specifyTexture :: TextureSize2D -> (GLubyte -> GLubyte -> Color4 GLubyte) -> IO ()
specifyTexture size@(TextureSize2D w h) f =
withArray [ f i j | i <- [ 0 .. fromIntegral w – 1 ],
j <- [ 0 .. fromIntegral h – 1] ] $
texImage2D Texture2D NoProxy 0 RGBA’ size 0 . PixelData RGBA UnsignedByte
specifyTexture size@(TextureSize2D w h) f =
withArray [ f i j | i <- [ 0 .. fromIntegral w – 1 ],
j <- [ 0 .. fromIntegral h – 1] ] $
texImage2D Texture2D NoProxy 0 RGBA’ size 0 . PixelData RGBA UnsignedByte
myInit :: IO ()
myInit = do
clearColor $= Color4 0 0 0 0
shadeModel $= Flat
depthFunc $= Just Less
rowAlignment Unpack $= 1
myInit = do
clearColor $= Color4 0 0 0 0
shadeModel $= Flat
depthFunc $= Just Less
rowAlignment Unpack $= 1
[texName0, texName1] <- genObjectNames 2
textureBinding Texture2D $= Just texName0
— Note: We use much brighter colors than in the original example where
— everything was almost black.
specifyTexture (TextureSize2D 32 32) (\i j -> Color4 (i*8) (j*8) ((i*j) `div` 4) 255)
textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
textureWrapMode Texture2D S $= (Repeated, Repeat)
textureWrapMode Texture2D T $= (Repeated, Repeat)
textureBinding Texture2D $= Just texName0
— Note: We use much brighter colors than in the original example where
— everything was almost black.
specifyTexture (TextureSize2D 32 32) (\i j -> Color4 (i*8) (j*8) ((i*j) `div` 4) 255)
textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
textureWrapMode Texture2D S $= (Repeated, Repeat)
textureWrapMode Texture2D T $= (Repeated, Repeat)
textureBinding Texture2D $= Just texName1
specifyTexture (TextureSize2D 16 16) (\i j -> Color4 255 (i*16) (j*16) 255)
textureFilter Texture2D $= ((Linear’, Nothing), Linear’)
textureWrapMode Texture2D S $= (Repeated, ClampToEdge)
textureWrapMode Texture2D T $= (Repeated, ClampToEdge)
— Use the two texture objects to define two texture units
— for use in multitexturing
activeTexture $= TextureUnit 0
texture Texture2D $= Enabled
textureBinding Texture2D $= Just texName0
textureFunction $= Replace
matrixMode $= Texture
loadIdentity
translate (Vector3 0.5 0.5 (0 :: GLfloat))
rotate (45 :: GLfloat) (Vector3 0 0 1)
translate (Vector3 (-0.5) (-0.5) (0 :: GLfloat))
matrixMode $= Modelview 0
activeTexture $= TextureUnit 1
texture Texture2D $= Enabled
textureBinding Texture2D $= Just texName1
textureFunction $= Modulate
specifyTexture (TextureSize2D 16 16) (\i j -> Color4 255 (i*16) (j*16) 255)
textureFilter Texture2D $= ((Linear’, Nothing), Linear’)
textureWrapMode Texture2D S $= (Repeated, ClampToEdge)
textureWrapMode Texture2D T $= (Repeated, ClampToEdge)
— Use the two texture objects to define two texture units
— for use in multitexturing
activeTexture $= TextureUnit 0
texture Texture2D $= Enabled
textureBinding Texture2D $= Just texName0
textureFunction $= Replace
matrixMode $= Texture
loadIdentity
translate (Vector3 0.5 0.5 (0 :: GLfloat))
rotate (45 :: GLfloat) (Vector3 0 0 1)
translate (Vector3 (-0.5) (-0.5) (0 :: GLfloat))
matrixMode $= Modelview 0
activeTexture $= TextureUnit 1
texture Texture2D $= Enabled
textureBinding Texture2D $= Just texName1
textureFunction $= Modulate
display :: DisplayCallback
display = do
clear [ ColorBuffer, DepthBuffer ]
— resolve overloading, not needed in “real” programs
let multiTexCoord2f = multiTexCoord :: TextureUnit -> TexCoord2 GLfloat -> IO ()
vertex2f = vertex :: Vertex2 GLfloat -> IO ()
renderPrimitive Triangles $ do
multiTexCoord2f (TextureUnit 0) (TexCoord2 0 0)
multiTexCoord2f (TextureUnit 1) (TexCoord2 1 0)
vertex2f (Vertex2 0 0)
multiTexCoord2f (TextureUnit 0) (TexCoord2 0.5 1)
multiTexCoord2f (TextureUnit 1) (TexCoord2 0.5 0)
vertex2f (Vertex2 50 100)
multiTexCoord2f (TextureUnit 0) (TexCoord2 1 0)
multiTexCoord2f (TextureUnit 1) (TexCoord2 1 1)
vertex2f (Vertex2 100 0)
flush
display = do
clear [ ColorBuffer, DepthBuffer ]
— resolve overloading, not needed in “real” programs
let multiTexCoord2f = multiTexCoord :: TextureUnit -> TexCoord2 GLfloat -> IO ()
vertex2f = vertex :: Vertex2 GLfloat -> IO ()
renderPrimitive Triangles $ do
multiTexCoord2f (TextureUnit 0) (TexCoord2 0 0)
multiTexCoord2f (TextureUnit 1) (TexCoord2 1 0)
vertex2f (Vertex2 0 0)
multiTexCoord2f (TextureUnit 0) (TexCoord2 0.5 1)
multiTexCoord2f (TextureUnit 1) (TexCoord2 0.5 0)
vertex2f (Vertex2 50 100)
multiTexCoord2f (TextureUnit 0) (TexCoord2 1 0)
multiTexCoord2f (TextureUnit 1) (TexCoord2 1 1)
vertex2f (Vertex2 100 0)
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 100 0 (100*hf/wf)
else ortho2D 0 (100*wf/hf) 0 100
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 0 100 0 (100*hf/wf)
else ortho2D 0 (100*wf/hf) 0 100
matrixMode $= Modelview 0
loadIdentity
keyboard :: KeyboardMouseCallback
keyboard (Char ‘\27’) Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ = return ()
keyboard (Char ‘\27’) Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ = return ()
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 250 250
initialWindowPosition $= Position 100 100
_ <- createWindow progName
— we have to do this *after* createWindow, otherwise we have no OpenGL context
version <- get (majorMinor glVersion)
unless (version >= (1, 3)) $ do
exts <- get glExtensions
unless (“GL_ARB_multitexture” `elem` exts && — part of 1.3 core
“GL_EXT_texture_object” `elem` exts) $ do — part of 1.1 core
putStrLn “Sorry, this demo requires the GL_ARB_multitexture and GL_EXT_texture_object extensions.”
exitFailure
myInit
reshapeCallback $= Just reshape
displayCallback $= display
keyboardMouseCallback $= Just keyboard
mainLoop
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 250 250
initialWindowPosition $= Position 100 100
_ <- createWindow progName
— we have to do this *after* createWindow, otherwise we have no OpenGL context
version <- get (majorMinor glVersion)
unless (version >= (1, 3)) $ do
exts <- get glExtensions
unless (“GL_ARB_multitexture” `elem` exts && — part of 1.3 core
“GL_EXT_texture_object” `elem` exts) $ do — part of 1.1 core
putStrLn “Sorry, this demo requires the GL_ARB_multitexture and GL_EXT_texture_object extensions.”
exitFailure
myInit
reshapeCallback $= Just reshape
displayCallback $= display
keyboardMouseCallback $= Just keyboard
mainLoop
{-
Combiner.hs (adapted from combiner.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
Combiner.hs (adapted from combiner.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 variety of quads showing different effects of
texture combiner functions.
texture combiner functions.
The first row renders an untextured polygon (so you can compare the
fragment colors) and then the 2 textures.
fragment colors) and then the 2 textures.
The second row shows several different combiner functions on a single
texture: replace, modulate, add, add-signed, and subtract.
texture: replace, modulate, add, add-signed, and subtract.
The third row shows the interpolate combiner function on a single texture
with a constant color/alpha value, varying the amount of interpolation.
with a constant color/alpha value, varying the amount of interpolation.
The fourth row uses multitexturing with two textures and different
combiner functions.
combiner functions.
The fifth row are some combiner experiments: using the scaling factor and
reversing the order of subtraction for a combination function.
-}
reversing the order of subtraction for a combination function.
-}
import Data.Bits ( (.&.) )
import Foreign ( withArray )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
import Foreign ( withArray )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
— Create checkerboard image
imageSize :: TextureSize2D
imageSize = TextureSize2D 8 8
imageSize :: TextureSize2D
imageSize = TextureSize2D 8 8
makeImage :: TextureSize2D -> (GLsizei -> GLsizei -> Color4 GLubyte)
-> (PixelData (Color4 GLubyte) -> IO ()) -> IO ()
makeImage (TextureSize2D w h) f act =
withArray [ f i j |
i <- [ 0 .. w – 1 ],
j <- [ 0 .. h – 1 ] ] $
act . PixelData RGBA UnsignedByte
-> (PixelData (Color4 GLubyte) -> IO ()) -> IO ()
makeImage (TextureSize2D w h) f act =
withArray [ f i j |
i <- [ 0 .. w – 1 ],
j <- [ 0 .. h – 1 ] ] $
act . PixelData RGBA UnsignedByte
myInit :: IO (TextureObject, TextureObject, DisplayList)
myInit = do
clearColor $= Color4 0 0 0 0
shadeModel $= Smooth
myInit = do
clearColor $= Color4 0 0 0 0
shadeModel $= Smooth
rowAlignment Unpack $= 1
[texName0, texName1] <- genObjectNames 2
textureBinding Texture2D $= Just texName0
textureWrapMode Texture2D S $= (Repeated, Repeat)
textureWrapMode Texture2D T $= (Repeated, Repeat)
textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
— horiz b & w stripes
makeImage imageSize (\i _ -> let c = if i .&. 2 == 0 then 255 else 0 in Color4 c c c 255) $
texImage2D Texture2D NoProxy 0 RGBA’ imageSize 0
textureWrapMode Texture2D S $= (Repeated, Repeat)
textureWrapMode Texture2D T $= (Repeated, Repeat)
textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
— horiz b & w stripes
makeImage imageSize (\i _ -> let c = if i .&. 2 == 0 then 255 else 0 in Color4 c c c 255) $
texImage2D Texture2D NoProxy 0 RGBA’ imageSize 0
textureBinding Texture2D $= Just texName1
textureWrapMode Texture2D S $= (Repeated, Repeat)
textureWrapMode Texture2D T $= (Repeated, Repeat)
textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
textureFunction $= Decal
— wider vertical 50% cyan and black stripes
makeImage imageSize (\_ j -> let c = if j .&. 4 /= 0 then 128 else 0 in Color4 0 c c 255) $
texImage2D Texture2D NoProxy 0 RGBA’ imageSize 0
textureWrapMode Texture2D S $= (Repeated, Repeat)
textureWrapMode Texture2D T $= (Repeated, Repeat)
textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
textureFunction $= Decal
— wider vertical 50% cyan and black stripes
makeImage imageSize (\_ j -> let c = if j .&. 4 /= 0 then 128 else 0 in Color4 0 c c 255) $
texImage2D Texture2D NoProxy 0 RGBA’ imageSize 0
— smooth-shaded polygon with multiple texture coordinates
let vert :: TexCoord2 GLfloat -> Color3 GLfloat -> Vertex3 GLfloat -> IO ()
vert t c v = do
multiTexCoord (TextureUnit 0) t
multiTexCoord (TextureUnit 1) t
color c
vertex v
let vert :: TexCoord2 GLfloat -> Color3 GLfloat -> Vertex3 GLfloat -> IO ()
vert t c v = do
multiTexCoord (TextureUnit 0) t
multiTexCoord (TextureUnit 1) t
color c
vertex v
dl <- defineNewList Compile $
renderPrimitive Quads $ do
vert (TexCoord2 0 0) (Color3 0.5 1 0.25) (Vertex3 0 0 0)
vert (TexCoord2 0 2) (Color3 1 1 1 ) (Vertex3 0 1 0)
vert (TexCoord2 2 2) (Color3 1 1 1 ) (Vertex3 1 1 0)
vert (TexCoord2 2 0) (Color3 1 0.5 0.25) (Vertex3 1 0 0)
renderPrimitive Quads $ do
vert (TexCoord2 0 0) (Color3 0.5 1 0.25) (Vertex3 0 0 0)
vert (TexCoord2 0 2) (Color3 1 1 1 ) (Vertex3 0 1 0)
vert (TexCoord2 2 2) (Color3 1 1 1 ) (Vertex3 1 1 0)
vert (TexCoord2 2 0) (Color3 1 0.5 0.25) (Vertex3 1 0 0)
return (texName0, texName1, dl)
display :: (TextureObject, TextureObject, DisplayList) -> DisplayCallback
display (texName0, texName1, dl) = do
clear [ ColorBuffer ]
display (texName0, texName1, dl) = do
clear [ ColorBuffer ]
let drawAt :: GLfloat -> GLfloat -> IO ()
drawAt x y = preservingMatrix $ do
translate (Vector3 x y 0)
callList dl
drawAt x y = preservingMatrix $ do
translate (Vector3 x y 0)
callList dl
— untextured polygon — see the “fragment” colors
texture Texture2D $= Disabled
drawAt 0 5
texture Texture2D $= Disabled
drawAt 0 5
texture Texture2D $= Enabled
— draw ordinary textured polys; 1 texture unit; combine mode disabled
textureFunction $= Modulate
textureBinding Texture2D $= Just texName0
drawAt 1 5
— draw ordinary textured polys; 1 texture unit; combine mode disabled
textureFunction $= Modulate
textureBinding Texture2D $= Just texName0
drawAt 1 5
textureBinding Texture2D $= Just texName1
drawAt 2 5
drawAt 2 5
— different combine modes enabled; 1 texture unit
— defaults are:
— argRGB Arg0 $= Arg SrcColor CurrentUnit
— argRGB Arg1 $= Arg SrcColor Previous
— defaults are:
— argRGB Arg0 $= Arg SrcColor CurrentUnit
— argRGB Arg1 $= Arg SrcColor Previous
textureBinding Texture2D $= Just texName0
textureFunction $= Combine
combineRGB $= Replace’
argRGB Arg0 $= Arg SrcColor CurrentUnit
drawAt 1 4
textureFunction $= Combine
combineRGB $= Replace’
argRGB Arg0 $= Arg SrcColor CurrentUnit
drawAt 1 4
combineRGB $= Modulate’
argRGB Arg1 $= Arg SrcColor Previous
drawAt 2 4
argRGB Arg1 $= Arg SrcColor Previous
drawAt 2 4
combineRGB $= AddUnsigned’
drawAt 3 4
drawAt 3 4
combineRGB $= AddSigned
drawAt 4 4
drawAt 4 4
combineRGB $= Subtract
drawAt 5 4
drawAt 5 4
— interpolate combine with constant color; 1 texture unit
— use different alpha values for constant color
— defaults are:
— argRGB Arg0 $= Arg SrcColor CurrentUnit
— argRGB Arg1 $= Arg SrcColor Previous
— argRGB Arg2 $= Arg SrcAlpha Constant
— use different alpha values for constant color
— defaults are:
— argRGB Arg0 $= Arg SrcColor CurrentUnit
— argRGB Arg1 $= Arg SrcColor Previous
— argRGB Arg2 $= Arg SrcAlpha Constant
constantColor $= Color4 0 0 0 0.2
textureBinding Texture2D $= Just texName0
textureFunction $= Combine
combineRGB $= Interpolate
argRGB Arg0 $= Arg SrcColor CurrentUnit
argRGB Arg1 $= Arg SrcColor Previous
argRGB Arg2 $= Arg SrcAlpha Constant
drawAt 1 3
textureBinding Texture2D $= Just texName0
textureFunction $= Combine
combineRGB $= Interpolate
argRGB Arg0 $= Arg SrcColor CurrentUnit
argRGB Arg1 $= Arg SrcColor Previous
argRGB Arg2 $= Arg SrcAlpha Constant
drawAt 1 3
constantColor $= Color4 0 0 0 0.4
drawAt 2 3
drawAt 2 3
constantColor $= Color4 0 0 0 0.6
drawAt 3 3
drawAt 3 3
constantColor $= Color4 0 0 0 0.8
drawAt 4 3
drawAt 4 3
— combine textures 0 & 1
— defaults are:
— argRGB Arg0 $= Arg SrcColor CurrentUnit
— argRGB Arg1 $= Arg SrcColor Previous
— defaults are:
— argRGB Arg0 $= Arg SrcColor CurrentUnit
— argRGB Arg1 $= Arg SrcColor Previous
activeTexture $= TextureUnit 0
texture Texture2D $= Enabled
textureBinding Texture2D $= Just texName0
textureFunction $= Modulate
texture Texture2D $= Enabled
textureBinding Texture2D $= Just texName0
textureFunction $= Modulate
activeTexture $= TextureUnit 1
texture Texture2D $= Enabled
textureBinding Texture2D $= Just texName1
textureFunction $= Combine
combineRGB $= Replace’
drawAt 1 2
texture Texture2D $= Enabled
textureBinding Texture2D $= Just texName1
textureFunction $= Combine
combineRGB $= Replace’
drawAt 1 2
— try different combiner modes of texture unit 1
combineRGB $= Modulate’
drawAt 2 2
combineRGB $= Modulate’
drawAt 2 2
combineRGB $= AddUnsigned’
drawAt 3 2
drawAt 3 2
combineRGB $= AddSigned
drawAt 4 2
drawAt 4 2
combineRGB $= Subtract
drawAt 5 2
drawAt 5 2
— some experiments
— see the effect of rgbScale
rgbScale $= 2
combineRGB $= Replace’
drawAt 1 1
rgbScale $= 2
combineRGB $= Replace’
drawAt 1 1
combineRGB $= Modulate’
drawAt 2 1
rgbScale $= 1
drawAt 2 1
rgbScale $= 1
— reverse the order of subtraction Arg1-Arg0
textureFunction $= Combine
combineRGB $= Subtract
argRGB Arg0 $= Arg SrcColor Previous
argRGB Arg1 $= Arg SrcColor CurrentUnit
drawAt 5 1
combineRGB $= Subtract
argRGB Arg0 $= Arg SrcColor Previous
argRGB Arg1 $= Arg SrcColor CurrentUnit
drawAt 5 1
activeTexture $= TextureUnit 1 — deactivate multitexturing
texture Texture2D $= Disabled
activeTexture $= TextureUnit 0 — activate single texture unit
texture Texture2D $= Disabled
activeTexture $= TextureUnit 0 — activate single texture unit
flush
reshape :: ReshapeCallback
reshape size = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
ortho2D 0 7 0 7
matrixMode $= Modelview 0
loadIdentity
reshape size = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
ortho2D 0 7 0 7
matrixMode $= Modelview 0
loadIdentity
keyboard :: KeyboardMouseCallback
keyboard (Char ‘\27’) Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ = return ()
keyboard (Char ‘\27’) Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ = return ()
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode ]
initialWindowSize $= Size 400 400
initialWindowPosition $= Position 100 100
_ <- createWindow progName
texNamesAndDL <- myInit
displayCallback $= display texNamesAndDL
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just keyboard
mainLoop
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode ]
initialWindowSize $= Size 400 400
initialWindowPosition $= Position 100 100
_ <- createWindow progName
texNamesAndDL <- myInit
displayCallback $= display texNamesAndDL
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just keyboard
mainLoop
{-
ShadowMap.hs (adapted from shadowmap.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
-}
ShadowMap.hs (adapted from shadowmap.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
-}
import Control.Monad ( when, unless )
import Data.IORef ( IORef, newIORef )
import Foreign.Marshal.Array ( allocaArray )
import Foreign.Ptr ( nullPtr )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
import Data.IORef ( IORef, newIORef )
import Foreign.Marshal.Array ( allocaArray )
import Foreign.Ptr ( nullPtr )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
shadowMapSize :: TextureSize2D
shadowMapSize = TextureSize2D 256 256
shadowMapSize = TextureSize2D 256 256
fovy, nearPlane, farPlane :: GLdouble
fovy = 60
nearPlane = 10
farPlane = 100
fovy = 60
nearPlane = 10
farPlane = 100
lightPos :: Vertex4 GLfloat
lightPos = Vertex4 25 25 25 1
lightPos = Vertex4 25 25 25 1
lookat :: Vertex3 GLdouble
lookat = Vertex3 0 0 0
lookat = Vertex3 0 0 0
up :: Vector3 GLdouble
up = Vector3 0 0 1
up = Vector3 0 0 1
data State = State {
angle :: IORef GLdouble,
torusAngle :: IORef GLfloat,
showShadow :: IORef Bool,
animate :: IORef Bool,
funcMode :: IORef ComparisonFunction }
angle :: IORef GLdouble,
torusAngle :: IORef GLfloat,
showShadow :: IORef Bool,
animate :: IORef Bool,
funcMode :: IORef ComparisonFunction }
makeState :: IO State
makeState = do
a <- newIORef 0
t <- newIORef 0
s <- newIORef False
n <- newIORef True
f <- newIORef Lequal
return $ State { angle = a, torusAngle = t, showShadow = s,
animate = n, funcMode = f }
makeState = do
a <- newIORef 0
t <- newIORef 0
s <- newIORef False
n <- newIORef True
f <- newIORef Lequal
return $ State { angle = a, torusAngle = t, showShadow = s,
animate = n, funcMode = f }
myInit :: IO ()
myInit = do
texImage2D Texture2D NoProxy 0 DepthComponent’ shadowMapSize 0
(PixelData DepthComponent UnsignedByte nullPtr)
myInit = do
texImage2D Texture2D NoProxy 0 DepthComponent’ shadowMapSize 0
(PixelData DepthComponent UnsignedByte nullPtr)
position (Light 0) $= lightPos
let white = Color4 1 1 1 1
specular (Light 0) $= white
diffuse (Light 0) $= white
let white = Color4 1 1 1 1
specular (Light 0) $= white
diffuse (Light 0) $= white
textureWrapMode Texture2D S $= (Repeated, ClampToEdge)
textureWrapMode Texture2D T $= (Repeated, ClampToEdge)
textureFilter Texture2D $= ((Linear’, Nothing), Linear’)
textureCompareMode Texture2D $= Just Lequal
depthTextureMode Texture2D $= Luminance’
textureWrapMode Texture2D T $= (Repeated, ClampToEdge)
textureFilter Texture2D $= ((Linear’, Nothing), Linear’)
textureCompareMode Texture2D $= Just Lequal
depthTextureMode Texture2D $= Luminance’
colorMaterial $= Just (FrontAndBack, AmbientAndDiffuse)
cullFace $= Just Back
depthFunc $= Just Less
light (Light 0) $= Enabled
lighting $= Enabled
texture Texture2D $= Enabled
light (Light 0) $= Enabled
lighting $= Enabled
texture Texture2D $= Enabled
reshape :: ReshapeCallback
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
perspective fovy (fromIntegral w / fromIntegral h) nearPlane farPlane
matrixMode $= Modelview 0
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
perspective fovy (fromIntegral w / fromIntegral h) nearPlane farPlane
matrixMode $= Modelview 0
idle :: State -> IdleCallback
idle state = do
angle state $~! (+ (pi / 10000))
torusAngle state $~! (+ 0.1)
postRedisplay Nothing
idle state = do
angle state $~! (+ (pi / 10000))
torusAngle state $~! (+ 0.1)
postRedisplay Nothing
keyboard :: State -> KeyboardMouseCallback
keyboard state (Char c) Down _ _ = do
case c of
‘\27’ -> exitWith ExitSuccess
‘t’ ->
texture Texture2D $~ \cap -> if cap == Enabled then Disabled else Enabled
‘m’ -> do
fm <- get (funcMode state)
textureCompareMode Texture2D $~ maybe (Just fm) (const Nothing)
compareMode <- get (textureCompareMode Texture2D)
putStrLn (“Compare mode ” ++ maybe “Off” (const “On”) compareMode)
‘f’ -> do
funcMode state $~ \fm -> if fm == Lequal then Gequal else Lequal
fm <- get (funcMode state)
putStrLn (“Operator ” ++ show fm)
textureCompareMode Texture2D $~ maybe Nothing (const (Just fm))
‘s’ -> showShadow state $~ not
‘p’ -> do
animate state $~ not
animate’ <- get (animate state)
idleCallback $= if animate’ then Just (idle state) else Nothing
_ -> return ()
postRedisplay Nothing
keyboard _ _ _ _ _ = return ()
keyboard state (Char c) Down _ _ = do
case c of
‘\27’ -> exitWith ExitSuccess
‘t’ ->
texture Texture2D $~ \cap -> if cap == Enabled then Disabled else Enabled
‘m’ -> do
fm <- get (funcMode state)
textureCompareMode Texture2D $~ maybe (Just fm) (const Nothing)
compareMode <- get (textureCompareMode Texture2D)
putStrLn (“Compare mode ” ++ maybe “Off” (const “On”) compareMode)
‘f’ -> do
funcMode state $~ \fm -> if fm == Lequal then Gequal else Lequal
fm <- get (funcMode state)
putStrLn (“Operator ” ++ show fm)
textureCompareMode Texture2D $~ maybe Nothing (const (Just fm))
‘s’ -> showShadow state $~ not
‘p’ -> do
animate state $~ not
animate’ <- get (animate state)
idleCallback $= if animate’ then Just (idle state) else Nothing
_ -> return ()
postRedisplay Nothing
keyboard _ _ _ _ _ = return ()
drawObjects :: GLfloat -> Bool -> IO ()
drawObjects torusAngle’ shadowRender = do
textureOn <- get (texture Texture2D)
drawObjects torusAngle’ shadowRender = do
textureOn <- get (texture Texture2D)
when shadowRender $
texture Texture2D $= Disabled
texture Texture2D $= Disabled
— resolve overloading, not needed in “real” programs
let normal3f = normal :: Normal3 GLfloat -> IO ()
color3f = color :: Color3 GLfloat -> IO ()
rectf = rect :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO ()
translatef = translate :: Vector3 GLfloat -> IO ()
rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO ()
let normal3f = normal :: Normal3 GLfloat -> IO ()
color3f = color :: Color3 GLfloat -> IO ()
rectf = rect :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO ()
translatef = translate :: Vector3 GLfloat -> IO ()
rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO ()
unless shadowRender $ do
normal3f (Normal3 0 0 1)
color3f (Color3 1 1 1)
rectf (Vertex2 (-20) (-20)) (Vertex2 20 20)
normal3f (Normal3 0 0 1)
color3f (Color3 1 1 1)
rectf (Vertex2 (-20) (-20)) (Vertex2 20 20)
preservingMatrix $ do
translatef (Vector3 11 11 11)
rotatef 54.73 (Vector3 (-5) 5 0)
rotate torusAngle’ (Vector3 1 0 0)
color3f (Color3 1 0 0)
renderObject Solid (Torus 1 4 8 36)
translatef (Vector3 11 11 11)
rotatef 54.73 (Vector3 (-5) 5 0)
rotate torusAngle’ (Vector3 1 0 0)
color3f (Color3 1 0 0)
renderObject Solid (Torus 1 4 8 36)
preservingMatrix $ do
translatef (Vector3 2 2 2)
color3f (Color3 0 0 1)
renderObject Solid (Cube 4)
translatef (Vector3 2 2 2)
color3f (Color3 0 0 1)
renderObject Solid (Cube 4)
preservingMatrix $ do
getLightPos Vector3 >>= translate
color3f (Color3 1 1 1)
renderObject Wireframe (Sphere’ 0.5 6 6)
getLightPos Vector3 >>= translate
color3f (Color3 1 1 1)
renderObject Wireframe (Sphere’ 0.5 6 6)
when (shadowRender && textureOn == Enabled) $
texture Texture2D $= Enabled
texture Texture2D $= Enabled
getLightPos :: (GLdouble -> GLdouble -> GLdouble -> a) -> IO a
getLightPos f = do
Vertex4 x y z _ <- get (position (Light 0))
return $ f (realToFrac x) (realToFrac y) (realToFrac z)
getLightPos f = do
Vertex4 x y z _ <- get (position (Light 0))
return $ f (realToFrac x) (realToFrac y) (realToFrac z)
generateShadowMap :: GLfloat -> Bool -> IO ()
generateShadowMap torusAngle’ showShadow’ = do
lightPos’ <- getLightPos Vertex3
let (TextureSize2D shadowMapWidth shadowMapHeight) = shadowMapSize
shadowMapSize’ = Size shadowMapWidth shadowMapHeight
generateShadowMap torusAngle’ showShadow’ = do
lightPos’ <- getLightPos Vertex3
let (TextureSize2D shadowMapWidth shadowMapHeight) = shadowMapSize
shadowMapSize’ = Size shadowMapWidth shadowMapHeight
preservingViewport $ do
viewport $= (Position 0 0, shadowMapSize’)
viewport $= (Position 0 0, shadowMapSize’)
clear [ ColorBuffer, DepthBuffer ]
matrixMode $= Projection
preservingMatrix $ do
loadIdentity
perspective 80 1 10 1000
matrixMode $= Modelview 0
preservingMatrix $ do
loadIdentity
lookAt lightPos’ lookat up
drawObjects torusAngle’ True
matrixMode $= Projection
matrixMode $= Modelview 0
preservingMatrix $ do
loadIdentity
perspective 80 1 10 1000
matrixMode $= Modelview 0
preservingMatrix $ do
loadIdentity
lookAt lightPos’ lookat up
drawObjects torusAngle’ True
matrixMode $= Projection
matrixMode $= Modelview 0
copyTexImage2D Texture2D 0 DepthComponent’ (Position 0 0) shadowMapSize 0
when showShadow’ $ do
let numShadowMapPixels = fromIntegral (shadowMapWidth * shadowMapHeight)
allocaArray numShadowMapPixels $ \depthImage -> do
let pixelData fmt = PixelData fmt Float depthImage :: PixelData GLfloat
readPixels (Position 0 0) shadowMapSize’ (pixelData DepthComponent)
(_, Size viewPortWidth _) <- get viewport
windowPos (Vertex2 (fromIntegral viewPortWidth / 2 :: GLfloat) 0)
drawPixels shadowMapSize’ (pixelData Luminance)
swapBuffers
let numShadowMapPixels = fromIntegral (shadowMapWidth * shadowMapHeight)
allocaArray numShadowMapPixels $ \depthImage -> do
let pixelData fmt = PixelData fmt Float depthImage :: PixelData GLfloat
readPixels (Position 0 0) shadowMapSize’ (pixelData DepthComponent)
(_, Size viewPortWidth _) <- get viewport
windowPos (Vertex2 (fromIntegral viewPortWidth / 2 :: GLfloat) 0)
drawPixels shadowMapSize’ (pixelData Luminance)
swapBuffers
— Note: preservingViewport is not exception safe, but it doesn’t matter here
preservingViewport :: IO a -> IO a
preservingViewport act = do
v <- get viewport
x <- act
viewport $= v
return x
preservingViewport :: IO a -> IO a
preservingViewport act = do
v <- get viewport
x <- act
viewport $= v
return x
generateTextureMatrix :: IO ()
generateTextureMatrix = do
— Set up projective texture matrix. We use the Modelview matrix stack and
— OpenGL matrix commands to make the matrix.
m <- preservingMatrix $ do
loadIdentity
— resolve overloading, not needed in “real” programs
let translatef = translate :: Vector3 GLfloat -> IO ()
scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO ()
translatef (Vector3 0.5 0.5 0.0)
scalef 0.5 0.5 1.0
perspective 60 1 1 1000
lightPos’ <- getLightPos Vertex3
lookAt lightPos’ lookat up
get (matrix (Just (Modelview 0)))
generateTextureMatrix = do
— Set up projective texture matrix. We use the Modelview matrix stack and
— OpenGL matrix commands to make the matrix.
m <- preservingMatrix $ do
loadIdentity
— resolve overloading, not needed in “real” programs
let translatef = translate :: Vector3 GLfloat -> IO ()
scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO ()
translatef (Vector3 0.5 0.5 0.0)
scalef 0.5 0.5 1.0
perspective 60 1 1 1000
lightPos’ <- getLightPos Vertex3
lookAt lightPos’ lookat up
get (matrix (Just (Modelview 0)))
[ sx, sy, sz, sw,
tx, ty, tz, tw,
rx, ry, rz, rw,
qx, qy, qz, qw ] <- getMatrixComponents RowMajor (m :: GLmatrix GLdouble)
tx, ty, tz, tw,
rx, ry, rz, rw,
qx, qy, qz, qw ] <- getMatrixComponents RowMajor (m :: GLmatrix GLdouble)
textureGenMode S $= Just (ObjectLinear (Plane sx sy sz sw))
textureGenMode T $= Just (ObjectLinear (Plane tx ty tz tw))
textureGenMode R $= Just (ObjectLinear (Plane rx ry rz rw))
textureGenMode Q $= Just (ObjectLinear (Plane qx qy qz qw))
textureGenMode T $= Just (ObjectLinear (Plane tx ty tz tw))
textureGenMode R $= Just (ObjectLinear (Plane rx ry rz rw))
textureGenMode Q $= Just (ObjectLinear (Plane qx qy qz qw))
display :: State -> DisplayCallback
display state = do
let radius = 30
torusAngle’ <- get (torusAngle state)
showShadow’ <- get (showShadow state)
generateShadowMap torusAngle’ showShadow’
generateTextureMatrix
unless showShadow’ $ do
clear [ ColorBuffer, DepthBuffer ]
preservingMatrix $ do
angle’ <- get (angle state)
lookAt (Vertex3 (radius * cos angle’) (radius * sin angle’) 30) lookat up
drawObjects torusAngle’ False
swapBuffers
display state = do
let radius = 30
torusAngle’ <- get (torusAngle state)
showShadow’ <- get (showShadow state)
generateShadowMap torusAngle’ showShadow’
generateTextureMatrix
unless showShadow’ $ do
clear [ ColorBuffer, DepthBuffer ]
preservingMatrix $ do
angle’ <- get (angle state)
lookAt (Vertex3 (radius * cos angle’) (radius * sin angle’) 30) lookat up
drawObjects torusAngle’ False
swapBuffers
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ RGBAMode, WithDepthBuffer, DoubleBuffered ]
initialWindowSize $= Size 521 512
initialWindowPosition $= Position 100 100
_ <- createWindow progName
state <- makeState
myInit
displayCallback $= display state
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboard state)
idleCallback $= Just (idle state)
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ RGBAMode, WithDepthBuffer, DoubleBuffered ]
initialWindowSize $= Size 521 512
initialWindowPosition $= Position 100 100
_ <- createWindow progName
state <- makeState
myInit
displayCallback $= display state
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboard state)
idleCallback $= Just (idle state)
mainLoop
{-
Wrap.hs (adapted from wrap.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
Wrap.hs (adapted from wrap.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 texture maps a checkerboard image onto two rectangles. This
program demonstrates the wrapping modes, if the texture coordinates fall
outside 0.0 and 1.0. Interaction: Pressing the ‘s’ and ‘S’ keys switch the
wrapping between clamping and repeating for the s parameter. The ‘t’ and ‘T’
keys control the wrapping for the t parameter.
program demonstrates the wrapping modes, if the texture coordinates fall
outside 0.0 and 1.0. Interaction: Pressing the ‘s’ and ‘S’ keys switch the
wrapping between clamping and repeating for the s parameter. The ‘t’ and ‘T’
keys control the wrapping for the t parameter.
Texture objects are only used when GL_EXT_texture_object is supported.
-}
-}
import Control.Monad ( when )
import Data.Maybe ( isJust )
import Data.Bits ( (.&.) )
import Foreign ( withArray )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
import Data.Maybe ( isJust )
import Data.Bits ( (.&.) )
import Foreign ( withArray )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
— Create checkerboard image
checkImageSize :: TextureSize2D
checkImageSize = TextureSize2D 64 64
checkImageSize :: TextureSize2D
checkImageSize = TextureSize2D 64 64
withCheckImage :: TextureSize2D -> GLsizei -> (GLubyte -> (Color4 GLubyte))
-> (PixelData (Color4 GLubyte) -> IO ()) -> IO ()
withCheckImage (TextureSize2D w h) n f act =
withArray [ f c |
i <- [ 0 .. w – 1 ],
j <- [ 0 .. h – 1 ],
let c | (i .&. n) == (j .&. n) = 0
| otherwise = 255 ] $
act. PixelData RGBA UnsignedByte
-> (PixelData (Color4 GLubyte) -> IO ()) -> IO ()
withCheckImage (TextureSize2D w h) n f act =
withArray [ f c |
i <- [ 0 .. w – 1 ],
j <- [ 0 .. h – 1 ],
let c | (i .&. n) == (j .&. n) = 0
| otherwise = 255 ] $
act. PixelData RGBA UnsignedByte
myInit :: IO (Maybe TextureObject)
myInit = do
clearColor $= Color4 0 0 0 0
shadeModel $= Flat
depthFunc $= Just Less
rowAlignment Unpack $= 1
myInit = do
clearColor $= Color4 0 0 0 0
shadeModel $= Flat
depthFunc $= Just Less
rowAlignment Unpack $= 1
exts <- get glExtensions
mbTexName <- if “GL_EXT_texture_object” `elem` exts
then fmap Just genObjectName
else return Nothing
when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName
mbTexName <- if “GL_EXT_texture_object” `elem` exts
then fmap Just genObjectName
else return Nothing
when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName
textureWrapMode Texture2D S $= (Repeated, Repeat)
textureWrapMode Texture2D T $= (Repeated, Repeat)
textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
withCheckImage checkImageSize 0x8 (\c -> Color4 c c c 255) $
texImage2D Texture2D NoProxy 0 RGBA’ checkImageSize 0
return mbTexName
textureWrapMode Texture2D T $= (Repeated, Repeat)
textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
withCheckImage checkImageSize 0x8 (\c -> Color4 c c c 255) $
texImage2D Texture2D NoProxy 0 RGBA’ checkImageSize 0
return mbTexName
display :: Maybe TextureObject -> DisplayCallback
display mbTexName = do
clear [ ColorBuffer, DepthBuffer ]
texture Texture2D $= Enabled
textureFunction $= Decal
when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName
display mbTexName = do
clear [ ColorBuffer, DepthBuffer ]
texture Texture2D $= Enabled
textureFunction $= Decal
when (isJust mbTexName) $ textureBinding Texture2D $= mbTexName
— resolve overloading, not needed in “real” programs
let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO ()
vertex3f = vertex :: Vertex3 GLfloat -> IO ()
renderPrimitive Quads $ do
texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0) (-1.0) 0.0 )
texCoord2f (TexCoord2 0 3); vertex3f (Vertex3 (-2.0) 1.0 0.0 )
texCoord2f (TexCoord2 3 3); vertex3f (Vertex3 0.0 1.0 0.0 )
texCoord2f (TexCoord2 3 0); vertex3f (Vertex3 0.0 (-1.0) 0.0 )
let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO ()
vertex3f = vertex :: Vertex3 GLfloat -> IO ()
renderPrimitive Quads $ do
texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 (-2.0) (-1.0) 0.0 )
texCoord2f (TexCoord2 0 3); vertex3f (Vertex3 (-2.0) 1.0 0.0 )
texCoord2f (TexCoord2 3 3); vertex3f (Vertex3 0.0 1.0 0.0 )
texCoord2f (TexCoord2 3 0); vertex3f (Vertex3 0.0 (-1.0) 0.0 )
texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 1.0 (-1.0) 0.0 )
texCoord2f (TexCoord2 0 3); vertex3f (Vertex3 1.0 1.0 0.0 )
texCoord2f (TexCoord2 3 3); vertex3f (Vertex3 2.41421 1.0 (-1.41421))
texCoord2f (TexCoord2 3 0); vertex3f (Vertex3 2.41421 (-1.0) (-1.41421))
flush
texture Texture2D $= Disabled
texCoord2f (TexCoord2 0 3); vertex3f (Vertex3 1.0 1.0 0.0 )
texCoord2f (TexCoord2 3 3); vertex3f (Vertex3 2.41421 1.0 (-1.41421))
texCoord2f (TexCoord2 3 0); vertex3f (Vertex3 2.41421 (-1.0) (-1.41421))
flush
texture Texture2D $= Disabled
reshape :: ReshapeCallback
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
perspective 60 (fromIntegral w / fromIntegral h) 1 30
matrixMode $= Modelview 0
loadIdentity
translate (Vector3 0 0 (-3.6 :: GLfloat))
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
perspective 60 (fromIntegral w / fromIntegral h) 1 30
matrixMode $= Modelview 0
loadIdentity
translate (Vector3 0 0 (-3.6 :: GLfloat))
keyboard :: KeyboardMouseCallback
keyboard (Char ‘s’ ) Down _ _ = setClamping S Clamp
keyboard (Char ‘S’ ) Down _ _ = setClamping S Repeat
keyboard (Char ‘t’ ) Down _ _ = setClamping T Clamp
keyboard (Char ‘T’ ) Down _ _ = setClamping T Repeat
keyboard (Char ‘\27’) Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ = return ()
keyboard (Char ‘s’ ) Down _ _ = setClamping S Clamp
keyboard (Char ‘S’ ) Down _ _ = setClamping S Repeat
keyboard (Char ‘t’ ) Down _ _ = setClamping T Clamp
keyboard (Char ‘T’ ) Down _ _ = setClamping T Repeat
keyboard (Char ‘\27’) Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ = return ()
setClamping :: TextureCoordName -> Clamping -> IO ()
setClamping coord clamp = do
textureWrapMode Texture2D coord $= (Repeated, clamp);
postRedisplay Nothing
setClamping coord clamp = do
textureWrapMode Texture2D coord $= (Repeated, clamp);
postRedisplay Nothing
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 250 250
initialWindowPosition $= Position 100 100
_ <- createWindow progName
mbTexName <- myInit
displayCallback $= display mbTexName
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just keyboard
mainLoop
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]
initialWindowSize $= Size 250 250
initialWindowPosition $= Position 100 100
_ <- createWindow progName
mbTexName <- myInit
displayCallback $= display mbTexName
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just keyboard
mainLoop
InfoCad Blog 