Personal tools

Gtk2Hs/Demos/GtkGLext/terrain.hs

From HaskellWiki

< Gtk2Hs
Revision as of 01:23, 20 June 2008 by Mrd (Talk | contribs)

(diff) ← Older revision | Latest revision (diff) | Newer revision → (diff)
Jump to: navigation, search

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"