Gtk2Hs/Demos/GtkGLext/terrain.hs
< Gtk2Hs
Jump to navigation
Jump to search
module Main (main) where
import qualified Graphics.UI.Gtk as Gtk
import Graphics.UI.Gtk (AttrOp((:=)))
import qualified Graphics.UI.Gtk.OpenGL as GtkGL
import Graphics.Rendering.OpenGL as GL
import Data.Maybe (fromMaybe)
import Data.Array
import Data.Array.Base (unsafeRead)
import Data.Array.Storable
import Data.Word
import Data.IntSet as IS
import Data.IORef
import Control.Monad (forM_)
data ProgramState = PS { keysPressed :: IntSet
, px :: GLfloat
, py :: GLfloat
, pz :: GLfloat
, heading :: GLfloat
, pitch :: GLfloat
, dx :: GLfloat
, dz :: GLfloat
, dheading :: GLfloat
, dpitch :: GLfloat }
main :: IO ()
main = do
Gtk.initGUI
-- Initialise the Gtk+ OpenGL extension
-- (including reading various command line parameters)
GtkGL.initGL
state <- newIORef $ PS { keysPressed = IS.empty
, px = 0
, py = 0
, pz = 5.0
, heading = 0
, pitch = 0
, dx = 0
, dz = 0
, dheading = 0
, dpitch = 0 }
-- Load the image data and flip it.
pb' <- loadImage
pb <- Gtk.pixbufFlipVertically pb'
-- We need a OpenGL frame buffer configuration to be able to create other
-- OpenGL objects.
glconfig <- GtkGL.glConfigNew [GtkGL.GLModeRGBA,
GtkGL.GLModeDepth,
GtkGL.GLModeDouble]
-- Create an OpenGL drawing area widget
canvas <- GtkGL.glDrawingAreaNew glconfig
Gtk.widgetSetSizeRequest canvas canvasWidth canvasHeight
-- Initialise some GL setting just before the canvas first gets shown
-- (We can't initialise these things earlier since the GL resources that
-- we are using wouldn't heve been setup yet)
Gtk.onRealize canvas $ GtkGL.withGLDrawingArea canvas $ \_ -> do
initialize pb
reconfigure canvasWidth canvasHeight
return ()
-- Set the repaint handler
Gtk.onExpose canvas $ \_ -> do
GtkGL.withGLDrawingArea canvas $ \glwindow -> do
GL.clear [GL.DepthBuffer, GL.ColorBuffer]
display state
GtkGL.glDrawableSwapBuffers glwindow
return True
-- Setup the animation
Gtk.timeoutAddFull (do
update state
Gtk.widgetQueueDraw canvas
return True)
Gtk.priorityDefaultIdle animationWaitTime
--------------------------------
-- Setup the rest of the GUI:
--
window <- Gtk.windowNew
Gtk.onDestroy window Gtk.mainQuit
Gtk.set window [ Gtk.containerBorderWidth := 8,
Gtk.windowTitle := "Gtk2Hs + HOpenGL demo" ]
vbox <- Gtk.vBoxNew False 4
Gtk.set window [ Gtk.containerChild := vbox ]
label <- Gtk.labelNew (Just "Gtk2Hs using OpenGL via HOpenGL!")
button <- Gtk.buttonNewWithLabel "Close"
Gtk.onClicked button Gtk.mainQuit
Gtk.set vbox [ Gtk.containerChild := canvas,
Gtk.containerChild := label,
Gtk.containerChild := button ]
-- "reshape" event handler
Gtk.onConfigure canvas $ \ (Gtk.Configure _ _ _ w h) -> do
(w', h') <- reconfigure w h
texW <- Gtk.pixbufGetWidth pb
texH <- Gtk.pixbufGetHeight pb
texBPS <- Gtk.pixbufGetBitsPerSample pb
texRS <- Gtk.pixbufGetRowstride pb
texNCh <- Gtk.pixbufGetNChannels pb
Gtk.labelSetText label $ unwords ["Width:",show w',"Height:",show h',
"TexW:",show texW,"TexH:",show texH,
"BPS:",show texBPS,"RS:",show texRS,
"NCh:",show texNCh]
return True
Gtk.onKeyPress window $ \ (Gtk.Key rel _ _ mods _ _ _ val name char) -> do
keyEvent state rel mods val name char
Gtk.onKeyRelease window $ \ (Gtk.Key rel _ _ mods _ _ _ val name char) -> do
keyEvent state rel mods val name char
Gtk.widgetShowAll window
Gtk.mainGUI
update :: IORef ProgramState -> IO ()
update state = do
ps@PS { dx = dx
, dz = dz
, px = px
, py = py
, pz = pz
, pitch = pitch
, heading = heading
, dpitch = dpitch
, dheading = dheading }
<- readIORef state
preservingMatrix $ do
loadIdentity
-- rotate to current heading and pitch
GL.rotate pitch (Vector3 1.0 0.0 0.0 :: Vector3 GLfloat)
GL.rotate heading (Vector3 0.0 1.0 0.0 :: Vector3 GLfloat)
-- perform motion
translate (Vector3 (-dx) 0 (-dz))
-- get changes in location components
mat <- get (matrix Nothing) :: IO (GLmatrix GLfloat)
comps <- getMatrixComponents ColumnMajor mat
let [dx, dy, dz, _] = drop 12 comps
(heading', pitch') = (heading + dheading, pitch + dpitch)
writeIORef state $
ps { px = px + dx
, py = py + dy
, pz = pz + dz
, pitch = pitch'
, heading = heading' }
return ()
display :: IORef ProgramState -> IO ()
display state = do
ps@PS { px = px
, py = py
, pz = pz
, pitch = pitch
, heading = heading
, dpitch = dpitch
, dheading = dheading }
<- readIORef state
loadIdentity
GL.rotate (-pitch) (Vector3 1.0 0.0 0.0 :: Vector3 GLfloat)
GL.rotate (-heading) (Vector3 0.0 1.0 0.0 :: Vector3 GLfloat)
translate (Vector3 (-px) (-py) (-pz))
position (Light 0) $= Vertex4 0.0 0.0 (2.0) 1.0
texture Texture2D $= Enabled
color (Color4 1 1 1 1 :: Color4 GLfloat)
preservingMatrix $ do
translate (Vector3 (-10.0) (-1.0) 10.0 :: Vector3 GLfloat)
GL.rotate (-90.0) (Vector3 1.0 0.0 0.0 :: Vector3 GLfloat)
drawTerrain 20 20
preservingMatrix $ do
translate (Vector3 0.0 0.0 (-1.0) :: Vector3 GLfloat)
drawPlane
texture Texture2D $= Disabled
color (Color4 0.0 0.0 1.0 1.0 :: Color4 GLfloat)
preservingMatrix $ do
translate (Vector3 0.0 2.0 0.0 :: Vector3 GLfloat)
drawSphere
-- GLU Quadric example.
drawSphere = do
renderQuadric (QuadricStyle
(Just Smooth)
GenerateTextureCoordinates
Outside
FillStyle)
(Sphere 1.0 48 48)
drawPlane = do
renderPrimitive Quads $ do
glNormal3f(0.0,0.0,1.0)
glTexCoord2f(0.0, 0.0); glVertex3f(-1.0, -1.0, 0.0);
glTexCoord2f(1.0, 0.0); glVertex3f(1.0, -1.0, 0.0);
glTexCoord2f(1.0, 1.0); glVertex3f(1.0, 1.0, 0.0);
glTexCoord2f(0.0, 1.0); glVertex3f(-1.0, 1.0, 0.0);
drawTerrain :: GLfloat -> GLfloat -> IO ()
drawTerrain w h = do
forM_ [0 .. h - 1] $ \ j ->
renderPrimitive TriangleStrip $ do
glNormal3f(0.0,0.0,1.0)
glTexCoord2f(0.0,1.0+j); glVertex3f(0.0,1.0+j,0.0)
glTexCoord2f(0.0,0.0+j); glVertex3f(0.0,0.0+j,0.0)
forM_ [0 .. w - 1] $ \ i -> do
glTexCoord2f(1.0+i,1.0+j); glVertex3f(1.0+i,1.0+j,0.0)
glTexCoord2f(1.0+i,0.0+j); glVertex3f(1.0+i,0.0+j,0.0)
glTexCoord2f (x,y) = texCoord (TexCoord2 x y :: TexCoord2 GLfloat)
glVertex3f (x,y,z) = vertex (Vertex3 x y z :: Vertex3 GLfloat)
glNormal3f (x,y,z) = normal (Normal3 x y z :: Normal3 GLfloat)
reconfigure :: Int -> Int -> IO (Int, Int)
reconfigure w h = do
-- maintain aspect ratio
let aspectRatio = (fromIntegral canvasWidth) / (fromIntegral canvasHeight)
(w1, h1) = (fromIntegral w, (fromIntegral w) / aspectRatio)
(w2, h2) = ((fromIntegral h) * aspectRatio, fromIntegral h)
(w', h') = if h1 <= fromIntegral h
then (floor w1, floor h1)
else (floor w2, floor h2)
reshape $ Just (w', h')
return (w', h')
-- Called by reconfigure to fix the OpenGL viewport according to the
-- dimensions of the widget, appropriately.
reshape :: Maybe (Int, Int) -> IO ()
reshape dims = do
let (width, height) = fromMaybe (canvasWidth, canvasHeight) dims
viewport $= (Position 0 0, Size (fromIntegral width) (fromIntegral height))
matrixMode $= Projection
loadIdentity
let (w, h) = if width <= height
then (fromIntegral height, fromIntegral width )
else (fromIntegral width, fromIntegral height)
perspective 60.0 (fromIntegral canvasWidth / fromIntegral canvasHeight) 1.0 20.0
matrixMode $= Modelview 0
loadIdentity
initialize :: Gtk.Pixbuf -> IO ()
initialize pb = do
materialAmbient Front $= Color4 0.4 0.4 0.4 1.0
materialDiffuse Front $= Color4 0.4 0.4 0.4 1.0
materialSpecular Front $= Color4 0.8 0.8 0.8 1.0
materialShininess Front $= 25.0
ambient (Light 0) $= Color4 0.3 0.3 0.3 1.0
diffuse (Light 0) $= Color4 1.0 1.0 1.0 1.0
specular (Light 0) $= Color4 0.8 0.8 0.8 1.0
lightModelAmbient $= Color4 0.2 0.2 0.2 1.0
lighting $= Enabled
light (Light 0) $= Enabled
depthFunc $= Just Less
clearColor $= Color4 0.0 0.0 0.0 0.0
drawBuffer $= BackBuffers
colorMaterial $= Just (Front, Diffuse)
textureWrapMode Texture2D S $= (Repeated, Repeat)
textureWrapMode Texture2D T $= (Repeated, Repeat)
textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
uploadTexture pb
texture Texture2D $= Enabled
shadeModel $= Smooth
-- A somewhat ugly function. Sorry. Gtk hands me the texture data as
-- a PixbufData, but I need a C-style array to hand to OpenGL. So,
-- this function reads the data byte by byte out of the PixbufData
-- into a Storable array, and then can hand that address off to
-- OpenGL as a GHC.Ptr.
uploadTexture :: Gtk.Pixbuf -> IO ()
uploadTexture pb = do
pbd <- Gtk.pixbufGetPixels pb :: IO (Gtk.PixbufData Int Word8)
(l,u) <- getBounds pbd
storray <- newArray (l,u) 0 :: IO (StorableArray Int Word8)
forM_ [l .. u] $ \ i -> do
x <- unsafeRead pbd (i - l)
writeArray storray i x
withStorableArray storray $ \ texPtr ->
texImage2D
Nothing NoProxy 0 RGBA'
(TextureSize2D 64 64) 0
(PixelData RGBA UnsignedByte texPtr)
loadImage :: IO Gtk.Pixbuf
loadImage = do
putStrLn $ "Loading " ++ texFileName
Gtk.pixbufNewFromFile texFileName
keyEvent state rel mods val name char = do
ps@PS { keysPressed = kp
, dx = dx
, dz = dz
, px = px
, py = py
, pz = pz
, pitch = pitch
, heading = heading
, dpitch = dpitch
, dheading = dheading }
<- readIORef state
-- Only process the key event if it is not a repeat
if (fromIntegral val `member` kp && rel) ||
(fromIntegral val `notMember` kp && not rel)
then do
let return' ps' b = do
-- maintain list of currently pressed keys
writeIORef state $!
if rel
then ps' { keysPressed = fromIntegral val `IS.delete` kp }
else ps' { keysPressed = fromIntegral val `IS.insert` kp }
return b
-- accept/decline to handle the key event
accept ps' = return' ps' True
decline ps' = return' ps' False
-- putStrLn $ unwords [name , show rel] -- debugging
-- process keys
case rel of
-- on PRESS only
False
| name == "Escape" -> Gtk.mainQuit >> accept ps
| name == "e" -> accept $ ps { dz = dz + deltaV }
| name == "d" -> accept $ ps { dz = dz - deltaV }
| name == "w" -> accept $ ps { dx = dx + deltaV }
| name == "r" -> accept $ ps { dx = dx - deltaV }
| name == "s" -> accept $ ps { dheading = dheading + deltaH }
| name == "f" -> accept $ ps { dheading = dheading - deltaH }
| otherwise -> decline ps
-- on RELEASE only
True
| name == "e" -> accept $ ps { dz = dz - deltaV }
| name == "d" -> accept $ ps { dz = dz + deltaV }
| name == "w" -> accept $ ps { dx = dx - deltaV }
| name == "r" -> accept $ ps { dx = dx + deltaV }
| name == "s" -> accept $ ps { dheading = dheading - deltaH }
| name == "f" -> accept $ ps { dheading = dheading + deltaH }
| otherwise -> decline ps
else return True
animationWaitTime, canvasWidth, canvasHeight :: Int
animationWaitTime = 3
canvasWidth = 640
canvasHeight = 480
deltaV = 0.02
deltaH = 0.35
deltaP = 0.04
texFileName = "terrain.xpm"