Gtk2Hs/Demos/GtkGLext/terrain.hs

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"