/usr/share/doc/libghc-glut-doc/examples/RedBook/TexSub.hs is in libghc-glut-doc 2.4.0.0-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 | {-
TexSub.hs (adapted from texsub.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 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.
-}
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
checkImageSize, subImageSize :: TextureSize2D
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 ]
myInit :: IO (TextureObject, Image, Image)
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
[texName] <- genObjectNames 1
textureBinding Texture2D $= Just texName
textureWrapMode Texture2D S $= (Repeated, Repeat)
textureWrapMode Texture2D T $= (Repeated, Repeat)
textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
texImage2D Nothing 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
-- 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 :: TextureObject -> Image -> Image -> KeyboardMouseCallback
keyboard texName checkImage subImage (Char c) Down _ _ = case toLower c of
's' -> do
textureBinding Texture2D $= Just texName
texSubImage2D Nothing 0 (TexturePosition2D 12 44) subImageSize subImage
postRedisplay Nothing
'r' -> do
textureBinding Texture2D $= Just texName
texImage2D Nothing 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
|