Personal tools

Gtk2Hs/Demos/GtkGLext/terrain.xpm

From HaskellWiki

< Gtk2Hs(Difference between revisions)
Jump to: navigation, search
(somewhat more involved gtkglext demo)
 
(woops, was supposed to be a neat XPM image)
Line 1: Line 1:
<haskell>
+
<code>
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
+
</code>
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>
 

Revision as of 01:24, 20 June 2008

/* XPM */ static char * lambda_xpm[] = { "64 64 3 1", " c None", ". c #FFFFFF", "+ c #1059FF", "................................................................", "................................................................", "................................................................", "................................................................", "...................+++++........................................", "..................++++++++......................................", ".................++++++++++.....................................", "................+++++++++++.....................................", "...............+++++++++++++....................................", "...............+++++++++++++....................................", "...............+++......+++++...................................", "..............+++........++++...................................", "..............++.........++++...................................", "..............++..........++++..................................", "..............+............+++..................................", "..............+............+++..................................", "..............+............++++.................................", "............................+++.................................", "............................+++.................................", "............................+++.................................", "............................++++................................", ".............................+++................................", ".............................+++................................", ".............................+++................................", ".............................+++................................", "............................+++++...............................", "............................+++++...............................", "...........................++++++...............................", "...........................++++++...............................", "..........................++++++++..............................", "..........................++++++++..............................", ".........................+++++++++..............................", ".........................+++++++++..............................", "........................+++++++++++.............................", "........................+++++++.+++.............................", ".......................+++++++..+++.............................", ".......................+++++++..+++.............................", "......................+++++++...+++.............................", "......................+++++++....+++............................", ".....................++++++++....+++............................", ".....................+++++++.....+++............................", ".....................+++++++.....+++............................", "....................+++++++.......+++...........................", "....................+++++++.......+++...........................", "...................+++++++........+++...........................", "...................+++++++........+++...........................", "..................+++++++.........++++..........................", "..................+++++++..........+++..........................", ".................+++++++...........+++............+.............", ".................+++++++...........++++..........++.............", "................++++++++...........++++..........++.............", "................+++++++.............++++.........++.............", "...............++++++++.............+++++.......+++.............", "...............+++++++..............++++++.....++++.............", "..............++++++++...............+++++++++++++..............", "..............+++++++................+++++++++++++..............", ".............++++++++.................+++++++++++...............", ".............+++++++..................+++++++++++...............", ".............+++++++...................+++++++++................", "............+++++++......................+++++..................", "................................................................", "................................................................", "................................................................", "................................................................"};