[HOpenGL] Textures in Haskell OpenGL
Sven Panne
Sven.Panne at aedion.de
Sat May 15 18:54:23 EDT 2004
Hugh Rayner wrote:
> Hi, I'm using ghc OpenGL on a MacOS X box,
Which Haskell system are you using exactly (GHC or Hugs? Which version? Did you
build it for yourself?)
> and everything is working fine,
> except that I have no idea
> how to load textures,
Alas, the OpenGL binding shipped with GHC 6.2.1 (built from GHC's STABLE CVS branch)
doesn't support any texturing.
> and I can't find any examples anywhere on the internet
> that load textures except ones using the old API.
>
> Does anyone have an example I could look at?
The main branch of the fptools CVS repository, where the next major versions of GHC,
Hugs and NHC get their libraries from, has complete support for OpenGL 1.5 (only NURBS
support is still missing). All texturing examples from the Red Book have been ported,
too, I've attached a few to this mail to provide a feeling of the "flavour" of the
binding. Haddock docs of the libraries in the main branch are available at:
http://haskell.org/HOpenGL/newAPI/
I don't have access to a MacOS box, so I can't provide you with a binary snapshot
of the bleeding edge versions of GHC and/or Hugs. Perhaps somebody on this list
can help (Wolfgang?). Another route would be building GHC and/or Hugs for yourself,
just add "--enable-hopengl" at the configuration stage. Perhaps the stuff at
http://darwinports.opendarwin.org./
might be of some help, too.
Cheers,
S.
-------------- next part --------------
{-
Checker.hs (adapted from checker.c which is (c) Silicon Graphics, Inc)
Copyright (c) Sven Panne 2002-2004 <sven.panne at aedion.de>
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 ( liftM, when )
import Data.Maybe ( isJust, listToMaybe )
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
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
myInit :: IO (Maybe TextureObject)
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 liftM listToMaybe $ genObjectNames 1
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 Nothing 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
-- 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 )
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
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))
keyboard :: KeyboardMouseCallback
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
-------------- next part --------------
{-
Texture3D.hs (adapted from texture3d.c which is (c) Silicon Graphics, Inc)
Copyright (c) Sven Panne 2002-2004 <sven.panne at aedion.de>
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.
-}
import Control.Monad ( unless )
import Foreign ( withArray )
import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
-- Create checkerboard image
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
myInit :: IO ()
myInit = do
clearColor $= Color4 0 0 0 0
shadeModel $= Flat
depthFunc $= Just Less
rowAlignment Unpack $= 1
[texName] <- genObjectNames 1
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 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)
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
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))
keyboard :: KeyboardMouseCallback
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
-------------- next part --------------
{-
Combiner.hs (adapted from combiner.c which is (c) Silicon Graphics, Inc)
Copyright (c) Sven Panne 2002-2004 <sven.panne at aedion.de>
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.
The first row renders an untextured polygon (so you can compare the
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.
The third row shows the interpolate combiner function on a single texture
with a constant color/alpha value, varying the amount of interpolation.
The fourth row uses multitexturing with two textures and different
combiner functions.
The fifth row are some combiner experiments: using the scaling factor and
reversing the order of subtraction for a combination function.
-}
import Control.Monad ( liftM )
import Data.Bits ( (.&.) )
import Data.Maybe ( fromJust )
import Foreign ( withArray )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
-- Create checkerboard image
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
myInit :: IO (TextureObject, TextureObject, DisplayList)
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 Nothing 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 Nothing 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
dl <- liftM fromJust $ 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)
return (texName0, texName1, dl)
display :: (TextureObject, TextureObject, DisplayList) -> DisplayCallback
display (texName0, texName1, dl) = do
clear [ ColorBuffer ]
let drawAt :: GLfloat -> GLfloat -> IO ()
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 $= Enabled
-- 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
-- different combine modes enabled; 1 texture unit
-- 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
combineRGB $= Modulate'
argRGB Arg1 $= Arg SrcColor Previous
drawAt 2 4
combineRGB $= AddUnsigned'
drawAt 3 4
combineRGB $= AddSigned
drawAt 4 4
combineRGB $= Subtract
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
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
constantColor $= Color4 0 0 0 0.4
drawAt 2 3
constantColor $= Color4 0 0 0 0.6
drawAt 3 3
constantColor $= Color4 0 0 0 0.8
drawAt 4 3
-- combine textures 0 & 1
-- defaults are:
-- argRGB Arg0 $= Arg SrcColor CurrentUnit
-- argRGB Arg1 $= Arg SrcColor Previous
activeTexture $= TextureUnit 0
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
-- try different combiner modes of texture unit 1
combineRGB $= Modulate'
drawAt 2 2
combineRGB $= AddUnsigned'
drawAt 3 2
combineRGB $= AddSigned
drawAt 4 2
combineRGB $= Subtract
drawAt 5 2
-- some experiments
-- see the effect of rgbScale
rgbScale $= 2
combineRGB $= Replace'
drawAt 1 1
combineRGB $= Modulate'
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
activeTexture $= TextureUnit 1 -- deactivate multitexturing
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
keyboard :: KeyboardMouseCallback
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
More information about the HOpenGL
mailing list