/usr/share/doc/libghc-glut-doc/examples/RedBook/Image.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 | {-
Image.hs (adapted from image.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 demonstrates drawing pixels and shows the effect of
drawPixels, copyPixels, and pixelZoom.
Interaction: moving the mouse while pressing the mouse button will copy
the image in the lower-left corner of the window to the mouse position,
using the current pixel zoom factors. There is no attempt to prevent you
from drawing over the original image. If you press the 'r' key, the
original image and zoom factors are reset. If you press the 'z' or 'Z'
keys, you change the zoom factors.
-}
import Data.Bits ( (.&.) )
import Data.IORef ( IORef, newIORef )
import Foreign ( newArray )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
data State = State { zoomFactor :: IORef GLfloat }
makeState :: IO State
makeState = do
z <- newIORef 1
return $ State { zoomFactor = z }
-- Create checkerboard image
checkImageSize :: Size
checkImageSize = Size 64 64
type Image = PixelData (Color3 GLubyte)
makeCheckImage :: Size -> GLsizei -> (GLubyte -> (Color3 GLubyte)) -> IO Image
makeCheckImage (Size w h) n f =
fmap (PixelData RGB UnsignedByte) $
newArray [ f c |
i <- [ 0 .. w - 1 ],
j <- [ 0 .. h - 1 ],
let c | (i .&. n) == (j .&. n) = 0
| otherwise = 255 ]
myInit :: IO Image
myInit = do
clearColor $= Color4 0 0 0 0
shadeModel $= Flat
rowAlignment Unpack $= 1
makeCheckImage checkImageSize 0x8 (\c -> Color3 c c c)
display :: Image -> DisplayCallback
display pixelData = do
clear [ ColorBuffer ]
-- resolve overloading, not needed in "real" programs
let rasterPos2i = rasterPos :: Vertex2 GLint -> IO ()
rasterPos2i (Vertex2 0 0)
drawPixels checkImageSize pixelData
flush
reshape :: ReshapeCallback
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
ortho2D 0 (fromIntegral w) 0 (fromIntegral h)
matrixMode $= Modelview 0
loadIdentity
motion :: State -> MotionCallback
motion state (Position x y) = do
Size _ height <- get windowSize
let screenY = fromIntegral height - y
-- resolve overloading, not needed in "real" programs
let rasterPos2i = rasterPos :: Vertex2 GLint -> IO ()
rasterPos2i (Vertex2 x screenY)
z <- get (zoomFactor state)
pixelZoom $= (z, z)
copyPixels (Position 0 0) checkImageSize CopyColor
pixelZoom $= (1, 1)
flush
resetZoomFactor :: State -> IO ()
resetZoomFactor state = do
zoomFactor state $= 1.0
postRedisplay Nothing
putStrLn "zoomFactor reset to 1.0"
incZoomFactor :: State -> GLfloat -> IO ()
incZoomFactor state inc = do
zoomFactor state $~! (max 0.5 . min 3.0 . (+ inc))
get (zoomFactor state) >>= putStrLn . ("zoomFactor is now " ++) . show
keyboard :: State -> KeyboardMouseCallback
keyboard state (Char 'r') Down _ _ = resetZoomFactor state
keyboard state (Char 'R') Down _ _ = resetZoomFactor state
keyboard state (Char 'z') Down _ _ = incZoomFactor state 0.5
keyboard state (Char 'Z') Down _ _ = incZoomFactor state (-0.5)
keyboard _ (Char '\27') Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ _ = return ()
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode ]
initialWindowSize $= Size 250 250
initialWindowPosition $= Position 100 100
createWindow progName
state <- makeState
checkImage <- myInit
displayCallback $= display checkImage
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboard state)
motionCallback $= Just (motion state)
mainLoop
|