pioneers/src/Main.hs

{-# LANGUAGE BangPatterns #-}
module 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 qualified Graphics.UI.Gtk.Gdk.EventM as Event
import qualified Data.Array.IArray as A

import Map.Coordinates
import Map.Map

import Data.Maybe (fromMaybe)
import Debug.Trace
import Data.IntSet as IS
import Data.IORef

import Prelude as P
import Control.Monad
import Control.Concurrent
import Control.Concurrent.STM
import System.IO.Unsafe (unsafePerformIO)
import GHC.Conc.Sync (unsafeIOToSTM)
import Control.Monad.IO.Class (liftIO)

data ProgramState = PS { keysPressed :: IntSet
                       , px          :: GLfloat
                       , py          :: GLfloat
                       , pz          :: GLfloat
                       , heading     :: GLfloat
                       , pitch       :: GLfloat
                       , dx          :: GLfloat
                       , dy          :: GLfloat
                       , dz          :: GLfloat
                       , dheading    :: GLfloat
                       , dpitch      :: GLfloat }
                       deriving (Show)

animationWaitTime = 3   :: Int
canvasWidth = 1024      :: Int
canvasHeight = 768      :: Int
deltaV = 0.10
deltaH = 0.5
deltaP = 0.15

-- TODO: Put render-stuff in render-module 

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)


prepareRenderTile :: PlayMap -> ((Int,Int),MapEntry) -> (Vector3 GLfloat, Color3 GLfloat, [Vertex3 GLfloat])
prepareRenderTile m (c@(cx,cz),(_,t)) = 
                        (
                        if even cx then
                                Vector3 (1.5*(fromIntegral cx)) 0.0 (2*(fromIntegral cz))
                        else
                                Vector3 (1.5*(fromIntegral cx)) 0.0 (2*(fromIntegral cz)-1)
                        ,
                        case t of
                                Water -> Color3 0.5 0.5 1 :: Color3 GLfloat 
                                Grass -> Color3 0.3 0.9 0.1 :: Color3 GLfloat 
                                Sand -> Color3 0.9 0.85 0.7 :: Color3 GLfloat 
                                Mountain -> Color3 0.5 0.5 0.5 :: Color3 GLfloat 
                        ,getTileVertices m c)

renderTile :: (Vector3 GLfloat, Color3 GLfloat, [Vertex3 GLfloat]) -> IO ()
renderTile (coord,c,ts) =
        preservingMatrix $ do
                color c
                translate coord
                _ <- renderPrimitive Polygon $ do
                        glNormal3f(0.0,0.0,1.0)
                        mapM vertex ts
                return ()

drawSphere = do
  renderQuadric (QuadricStyle 
                  (Just Smooth)
                  GenerateTextureCoordinates
                  Outside
                  FillStyle)
                (Sphere 1.0 48 48)
                
-- OpenGL polygon-function for drawing stuff.
display :: MVar ProgramState -> PlayMap -> IO ()
display state t =
  let 
     tiles = P.map (prepareRenderTile t) (A.assocs t)
  in
      do
        ps@PS { 
          px       = px
        , py       = py
        , pz       = pz
        , pitch    = pitch
        , heading  = heading }
                <- readMVar 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)::Vector3 GLfloat)

        position (Light 0) $= Vertex4 0.0 0.0 (20.0) 1.0

        -- Instead of glBegin ... glEnd there is renderPrimitive.
        --trace (show tiles) $ 
        mapM_ renderTile tiles
        return ()

updateCamera :: MVar ProgramState -> IO ()
updateCamera state = do
        ps@PS { dx       = dx
        , dy       = dy
        , dz       = dz
        , px       = px
        , py       = py
        , pz       = pz
        , pitch    = pitch
        , heading  = heading
        , dpitch   = dpitch
        , dheading = dheading }
                <- takeMVar state

        d@((dx,dy,dz),(heading',pitch')) <- 
          if any (/= 0.0) [dx,dy,dz,dpitch,dheading] then
            preservingMatrix $ do
                putStrLn $ unwords $ P.map show [dx,dy,dz,dpitch,dheading]
                loadIdentity
 
                -- in direction of current heading and pitch
                rotate (-heading) (Vector3 0.0 1.0 0.0 :: Vector3 GLfloat)
                rotate (-pitch)   (Vector3 1.0 0.0 0.0 :: Vector3 GLfloat)

                -- perform motion
                translate (Vector3 (-dx) (-dy) (-dz))
 
 
                -- get changes in location components
                mat   <- get (matrix Nothing) :: IO (GLmatrix GLfloat)
                comps <- getMatrixComponents ColumnMajor mat
                putStrLn $ show $ comps
                let [dx', dy', dz', _] = drop 12 comps
                    (heading', pitch') = (heading + dheading, pitch + dpitch)
                return ((dx',dy',dz'),(heading',pitch'))
          else
            return ((0,0,0),(heading, pitch))
        putMVar state ps { px         = px + dx
                           , py         = py + dy
                           , pz         = pz + dz
                           , pitch      = pitch'
                           , heading    = heading'
                           }

--Adjust size to given dimensions
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)
  -- open, aspect-ratio, near-plane, far-plane
  perspective 60.0 (fromIntegral canvasWidth / fromIntegral canvasHeight) 1.0 100.0
  matrixMode $= Modelview 0
  loadIdentity

keyEvent state press = do
  code <- Event.eventHardwareKeycode
  val  <- Event.eventKeyVal
  mods <- Event.eventModifier
  name <- Event.eventKeyName
  liftIO $ do
          ps@PS { keysPressed = kp
                , dx          = dx
                , dy          = dy
                , dz          = dz
                , px          = px
                , py          = py
                , pz          = pz
                , pitch       = pitch
                , heading     = heading
                , dpitch      = dpitch
                , dheading    = dheading }
            <- takeMVar state
          -- Only process the key event if it is not a repeat
          (ps',ret) <- if (fromIntegral code `member` kp && not press) ||
             (fromIntegral code `notMember` kp && press)
             then let 
                      accept a = return (a, True)
                      deny   a = return (a, False)
                in do
                -- keep list of pressed keys up2date
                ps <- if not press
                  then return ps { keysPressed = fromIntegral code `IS.delete` kp }
                  else return ps { keysPressed = fromIntegral code `IS.insert` kp }
                putStrLn $ unwords [name , show val, show code, show ps] -- trace (unwords [name , show val]) -- debugging
                -- process keys
                case press of
                  -- on PRESS only
                  True
                    | code ==  9      -> Gtk.mainQuit >> deny ps
                    | code == 26      -> accept $ ps { dz = dz + deltaV }
                    | code == 40      -> accept $ ps { dz = dz - deltaV }
                    | code == 39      -> accept $ ps { dx = dx + deltaV }
                    | code == 41      -> accept $ ps { dx = dx - deltaV }
                    | code == 65      -> accept $ ps { dy = dy - deltaV }
                    | code == 66      -> accept $ ps { dy = dy + deltaV }
                    | code == 25      -> accept $ ps { dheading = dheading - deltaH }
                    | code == 27      -> accept $ ps { dheading = dheading + deltaH }
                    | otherwise       -> deny ps
                  -- on RELEASE only
                  False
                    | code == 26      -> accept $ ps { dz = dz - deltaV }
                    | code == 40      -> accept $ ps { dz = dz + deltaV }
                    | code == 39      -> accept $ ps { dx = dx - deltaV }
                    | code == 41      -> accept $ ps { dx = dx + deltaV }
                    | code == 65      -> accept $ ps { dy = dy + deltaV }
                    | code == 66      -> accept $ ps { dy = dy - deltaV }
                    | code == 25      -> accept $ ps { dheading = dheading + deltaH }
                    | code == 27      -> accept $ ps { dheading = dheading - deltaH }
                    | otherwise       -> deny ps
             else return (ps, False)
          putMVar state ps'
          return ret

main :: IO ()
main = do
  ! terrain <- testmap
  -- create TVar using unsafePerformIO -> currently no other thread -> OK
  state <- newMVar $ PS {    keysPressed = IS.empty
                             , px          = 7.5
                             , py          = 20
                             , pz          = 15
                             , heading     = 0
                             , pitch       = 60
                             , dx          = 0
                             , dy          = 0
                             , dz          = 0
                             , dheading    = 0
                             , dpitch      = 0}
  trace (show terrain) Gtk.initGUI
  -- Initialise the Gtk+ OpenGL extension
  -- (including reading various command line parameters)
  GtkGL.initGL

  -- 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
    reconfigure canvasWidth canvasHeight
    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)

    texture Texture2D $= Enabled

    shadeModel $= Smooth
    return ()
    {-clearColor $= (Color4 0.0 0.0 0.0 0.0)
    matrixMode $= Projection
    loadIdentity
    ortho 0.0 1.0 0.0 1.0 (-1.0) 1.0
    depthFunc $= Just Less
    drawBuffer $= BackBuffers-}
 
  -- Set the repaint handler
  Gtk.onExpose canvas $ \_ -> do
    GtkGL.withGLDrawingArea canvas $ \glwindow -> do
      GL.clear [GL.DepthBuffer, GL.ColorBuffer]
      display state terrain
      GtkGL.glDrawableSwapBuffers glwindow
    return True
 
  -- Setup the animation
  Gtk.timeoutAddFull (do
      updateCamera state
      Gtk.widgetQueueDraw canvas
      return True)
    Gtk.priorityDefaultIdle animationWaitTime
 
  --------------------------------
  -- Setup the rest of the GUI:
  --
  -- Objects
  window <- Gtk.windowNew
  button <- Gtk.buttonNew
  exitButton <- Gtk.buttonNew
  label <- Gtk.labelNew (Just "Gtk2Hs using OpenGL via HOpenGL!")
  vbox <- Gtk.vBoxNew False 4

  --Wrench them together

  Gtk.set window [ Gtk.containerBorderWidth := 10,
                   Gtk.containerChild := canvas,
                   Gtk.windowTitle := "Pioneer" ]

  ------
  -- Events
  --
  Gtk.afterClicked button (putStrLn "Hello World")
  Gtk.afterClicked exitButton Gtk.mainQuit
  Gtk.onDestroy window Gtk.mainQuit

  Gtk.on window Gtk.keyPressEvent $ keyEvent state True
 
  Gtk.on window Gtk.keyReleaseEvent $ keyEvent state False

 -- "reshape" event handler
  Gtk.on canvas Gtk.configureEvent $ Event.tryEvent $ do
    (w, h)   <- Event.eventSize
    (w', h') <- liftIO $ reconfigure w h
    liftIO $ Gtk.labelSetText label $ unwords ["Width:",show w',"Height:",show h']


  Gtk.widgetShowAll window
  Gtk.mainGUI