Gtk2Hs/Demos/GtkGLext/terrain.hs
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"