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"