GLUT-2.1.2.1: examples/RedBook/Combiner.hs
{-
Combiner.hs (adapted from combiner.c which is (c) Silicon Graphics, Inc)
Copyright (c) Sven Panne 2002-2005 <sven.panne@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 Data.Bits ( (.&.) )
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 <- 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