Personal tools

Gtk2Hs/Demos/GtkGLext/terrain.xpm

From HaskellWiki

< Gtk2Hs(Difference between revisions)
Jump to: navigation, search
(somewhat more involved gtkglext demo)
Current revision (01:25, 20 June 2008) (edit) (undo)
(fix misformatted code)
 
(One intermediate revision not shown.)
Line 1: Line 1:
<haskell>
<haskell>
-
module Main (main) where
+
/* XPM */
-
 
+
static char * lambda_xpm[] = {
-
import qualified Graphics.UI.Gtk as Gtk
+
"64 64 3 1",
-
import Graphics.UI.Gtk (AttrOp((:=)))
+
" c None",
-
import qualified Graphics.UI.Gtk.OpenGL as GtkGL
+
". c #FFFFFF",
-
 
+
"+ c #1059FF",
-
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"
+
</haskell>
</haskell>

Current revision

/* XPM */
static char * lambda_xpm[] = {
"64 64 3 1",
" 	c None",
".	c #FFFFFF",
"+	c #1059FF",
"................................................................",
"................................................................",
"................................................................",
"................................................................",
"...................+++++........................................",
"..................++++++++......................................",
".................++++++++++.....................................",
"................+++++++++++.....................................",
"...............+++++++++++++....................................",
"...............+++++++++++++....................................",
"...............+++......+++++...................................",
"..............+++........++++...................................",
"..............++.........++++...................................",
"..............++..........++++..................................",
"..............+............+++..................................",
"..............+............+++..................................",
"..............+............++++.................................",
"............................+++.................................",
"............................+++.................................",
"............................+++.................................",
"............................++++................................",
".............................+++................................",
".............................+++................................",
".............................+++................................",
".............................+++................................",
"............................+++++...............................",
"............................+++++...............................",
"...........................++++++...............................",
"...........................++++++...............................",
"..........................++++++++..............................",
"..........................++++++++..............................",
".........................+++++++++..............................",
".........................+++++++++..............................",
"........................+++++++++++.............................",
"........................+++++++.+++.............................",
".......................+++++++..+++.............................",
".......................+++++++..+++.............................",
"......................+++++++...+++.............................",
"......................+++++++....+++............................",
".....................++++++++....+++............................",
".....................+++++++.....+++............................",
".....................+++++++.....+++............................",
"....................+++++++.......+++...........................",
"....................+++++++.......+++...........................",
"...................+++++++........+++...........................",
"...................+++++++........+++...........................",
"..................+++++++.........++++..........................",
"..................+++++++..........+++..........................",
".................+++++++...........+++............+.............",
".................+++++++...........++++..........++.............",
"................++++++++...........++++..........++.............",
"................+++++++.............++++.........++.............",
"...............++++++++.............+++++.......+++.............",
"...............+++++++..............++++++.....++++.............",
"..............++++++++...............+++++++++++++..............",
"..............+++++++................+++++++++++++..............",
".............++++++++.................+++++++++++...............",
".............+++++++..................+++++++++++...............",
".............+++++++...................+++++++++................",
"............+++++++......................+++++..................",
"................................................................",
"................................................................",
"................................................................",
"................................................................"};
Retrieved from "http://www.haskell.org/haskellwiki/Gtk2Hs/Demos/GtkGLext/terrain.xpm"