/usr/share/doc/libghc-glut-doc/examples/RedBook4/TexGen.hs is in libghc-glut-doc 2.7.0.12-1build5.
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 121 122 123 124 125 126 127 128 129 130 131 132 | {-
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.
-}
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
stripeImageWidth :: TextureSize1D
stripeImageWidth = TextureSize1D 32
xEqualZero, slanted :: Plane GLdouble
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
myInit :: IO (Maybe TextureObject)
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
textureWrapMode Texture1D S $= (Repeated, Repeat)
textureFilter Texture1D $= ((Linear', Nothing), Linear')
withStripeImage $ texImage1D Texture1D NoProxy 0 RGBA' stripeImageWidth 0
textureFunction $= Modulate
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
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
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
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 ()
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
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
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
|