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", "................................................................", "................................................................", "................................................................", "................................................................", "...................+++++........................................", "..................++++++++......................................", ".................++++++++++.....................................", "................+++++++++++.....................................", "...............+++++++++++++....................................", "...............+++++++++++++....................................", "...............+++......+++++...................................", "..............+++........++++...................................", "..............++.........++++...................................", "..............++..........++++..................................", "..............+............+++..................................", "..............+............+++..................................", "..............+............++++.................................", "............................+++.................................", "............................+++.................................", "............................+++.................................", "............................++++................................", ".............................+++................................", ".............................+++................................", ".............................+++................................", ".............................+++................................", "............................+++++...............................", "............................+++++...............................", "...........................++++++...............................", "...........................++++++...............................", "..........................++++++++..............................", "..........................++++++++..............................", ".........................+++++++++..............................", ".........................+++++++++..............................", "........................+++++++++++.............................", "........................+++++++.+++.............................", ".......................+++++++..+++.............................", ".......................+++++++..+++.............................", "......................+++++++...+++.............................", "......................+++++++....+++............................", ".....................++++++++....+++............................", ".....................+++++++.....+++............................", ".....................+++++++.....+++............................", "....................+++++++.......+++...........................", "....................+++++++.......+++...........................", "...................+++++++........+++...........................", "...................+++++++........+++...........................", "..................+++++++.........++++..........................", "..................+++++++..........+++..........................", ".................+++++++...........+++............+.............", ".................+++++++...........++++..........++.............", "................++++++++...........++++..........++.............", "................+++++++.............++++.........++.............", "...............++++++++.............+++++.......+++.............", "...............+++++++..............++++++.....++++.............", "..............++++++++...............+++++++++++++..............", "..............+++++++................+++++++++++++..............", ".............++++++++.................+++++++++++...............", ".............+++++++..................+++++++++++...............", ".............+++++++...................+++++++++................", "............+++++++......................+++++..................", "................................................................", "................................................................", "................................................................", "................................................................"};