Gtk2Hs/Demos/GtkGLext/terrain.hs
< Gtk2Hs
Jump to navigation
Jump to search
The printable version is no longer supported and may have rendering errors. Please update your browser bookmarks and please use the default browser print function instead.
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"