Difference between revisions of "Gtk2Hs/Demos/GtkGLext/terrain.xpm"
(somewhat more involved gtkglext demo) |
(woops, was supposed to be a neat XPM image) |
||
Line 1: | Line 1: | ||
− | < |
+ | <code> |
+ | /* XPM */ |
||
− | module Main (main) where |
||
+ | static char * lambda_xpm[] = { |
||
− | |||
+ | "64 64 3 1", |
||
− | import qualified Graphics.UI.Gtk as Gtk |
||
+ | " c None", |
||
− | import Graphics.UI.Gtk (AttrOp((:=))) |
||
+ | ". c #FFFFFF", |
||
− | import qualified Graphics.UI.Gtk.OpenGL as GtkGL |
||
+ | "+ 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 |
||
+ | </code> |
||
− | 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> |
Revision as of 01:24, 20 June 2008
/* XPM */
static char * lambda_xpm[] = {
"64 64 3 1",
" c None",
". c #FFFFFF",
"+ c #1059FF",
"................................................................",
"................................................................",
"................................................................",
"................................................................",
"...................+++++........................................",
"..................++++++++......................................",
".................++++++++++.....................................",
"................+++++++++++.....................................",
"...............+++++++++++++....................................",
"...............+++++++++++++....................................",
"...............+++......+++++...................................",
"..............+++........++++...................................",
"..............++.........++++...................................",
"..............++..........++++..................................",
"..............+............+++..................................",
"..............+............+++..................................",
"..............+............++++.................................",
"............................+++.................................",
"............................+++.................................",
"............................+++.................................",
"............................++++................................",
".............................+++................................",
".............................+++................................",
".............................+++................................",
".............................+++................................",
"............................+++++...............................",
"............................+++++...............................",
"...........................++++++...............................",
"...........................++++++...............................",
"..........................++++++++..............................",
"..........................++++++++..............................",
".........................+++++++++..............................",
".........................+++++++++..............................",
"........................+++++++++++.............................",
"........................+++++++.+++.............................",
".......................+++++++..+++.............................",
".......................+++++++..+++.............................",
"......................+++++++...+++.............................",
"......................+++++++....+++............................",
".....................++++++++....+++............................",
".....................+++++++.....+++............................",
".....................+++++++.....+++............................",
"....................+++++++.......+++...........................",
"....................+++++++.......+++...........................",
"...................+++++++........+++...........................",
"...................+++++++........+++...........................",
"..................+++++++.........++++..........................",
"..................+++++++..........+++..........................",
".................+++++++...........+++............+.............",
".................+++++++...........++++..........++.............",
"................++++++++...........++++..........++.............",
"................+++++++.............++++.........++.............",
"...............++++++++.............+++++.......+++.............",
"...............+++++++..............++++++.....++++.............",
"..............++++++++...............+++++++++++++..............",
"..............+++++++................+++++++++++++..............",
".............++++++++.................+++++++++++...............",
".............+++++++..................+++++++++++...............",
".............+++++++...................+++++++++................",
"............+++++++......................+++++..................",
"................................................................",
"................................................................",
"................................................................",
"................................................................"};