Migrated to OpenGL3.x - compiles but renders nothing

- added simple shader
- rewrote map to cater BufferArray
- completele rewrote Main
- Split off stuff into Render-Module
- cleaned up .cabal-file to bare minimum
- created RenderObjects for the purpose of moving rendering there

Pioneers.cabal

@@ -6,26 +6,24 @@ author:         sdressel
 
 executable Pioneers
   hs-source-dirs:  src
-  main-is:         Main.hs
-  build-depends:   
-                  base >= 4,
-                  gtk,
-                  OpenGL >=2.9,
-                  gtkglext >=0.12,
-                  containers >=0.5 && <0.6,
-                  array >=0.4.0 && <0.5,
-                  random >=1.0.1 && <1.1,
-                  random >=1.0.1 && <1.1,
-                  text >=0.11.3 && <0.12,
-                  stm >=2.4.2 && <2.5,
-                  transformers >=0.3.0 && <0.4,
-                  List >=0.5.1 && <0.6,
-                  OpenGLRaw >=1.4.0 && <1.5,
-                  bytestring >=0.10.0 && <0.11
   ghc-options:     -Wall
   other-modules:   
-                   Map.Coordinates,
                    Map.Map,
+                   Render.Misc,
                    Render.Render,
-                   Render.Misc
+                   Render.RenderObject
+  main-is:         Main.hs
+  build-depends:   
+                   base >=4,
+                   OpenGL >=2.9,
+                   bytestring >=0.10,
+                   OpenGLRaw >=1.4,
+                   text >=0.11,
+                   array >=0.4,
+                   random >=1.0.1,
+                   GLFW-b >=1.4.6,
+                   pretty >=1.1,
+                   transformers >=0.3.0 && <0.4,
+                   mtl >=2.1.2,
+                   stm >=2.4.2
 

shaders/fragment.shader

@@ -1,12 +1,13 @@
 #version 140
 
-#color from earlier stages
+//color from earlier stages
 smooth in vec4 fg_SmoothColor;
 
-#color of pixel
+//color of pixel
 out vec4 fg_FragColor;
 
 void main(void)
 {
-   fg_FragColor = fg_SmoothColor; #copy-shader
+//copy-shader
-)
+   fg_FragColor = fg_SmoothColor;
+}

shaders/vertex.shader

@@ -1,14 +1,14 @@
 #version 140
 
-#constant projection matrix
+//constant projection matrix
 uniform mat4 fg_ProjectionMatrix;
 
-#vertex-data
+//vertex-data
 in vec4 fg_Color;
 in vec4 fg_Vertex;
 in vec4 fg_Normal;
 
-#output-data for later stages
+//output-data for later stages
 smooth out vec4 fg_SmoothColor;
 
 void main()

src/Main.deprecated.hs

@@ -0,0 +1,529 @@
+{-# LANGUAGE BangPatterns #-}
+module Main where
+
+import           Graphics.UI.Gtk            (AttrOp ((:=)))
+import qualified Graphics.UI.Gtk            as Gtk
+import qualified Graphics.UI.Gtk.OpenGL     as GtkGL
+
+import qualified Data.Array.IArray          as A
+import           Graphics.Rendering.OpenGL  as GL
+import qualified Graphics.UI.Gtk.Gdk.EventM as Event
+
+import           Map.Coordinates
+import           Map.Map
+
+import           Data.IntSet                as IS
+import           Data.IORef
+import           Data.Maybe                 (fromMaybe)
+import           Debug.Trace
+
+import           Control.Concurrent
+import           Control.Concurrent.STM
+import           Control.Monad
+import           Control.Monad.IO.Class     (liftIO)
+import           Foreign.Ptr                (nullPtr)
+import           GHC.Conc.Sync              (unsafeIOToSTM)
+import           Prelude                    as P
+import           System.IO.Unsafe           (unsafePerformIO)
+import Foreign.Marshal.Array (allocaArray)
+import Render.Misc (dumpInfo)
+
+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
+                       , showShadowMap :: Bool }
+                       deriving (Show)
+
+type RenderObject = (Vector3 GLfloat, Color3 GLfloat, [Vertex3 GLfloat])
+
+(Vertex4 a b c d) .+ (Vertex4 w x y z) = Vertex4 (a+w) (b+x) (c+y) (d+z)
+(Vertex4 a b c d) .* e = Vertex4 (a*e) (b*e) (c*e) (d*e)
+
+animationWaitTime = 3   :: Int
+canvasWidth = 1024      :: Int
+canvasHeight = 768      :: Int
+deltaV = 0.10
+deltaH = 0.5
+deltaP = 0.15
+black = Color3 0 0 0 :: Color3 GLfloat
+shadowMapSize :: TextureSize2D
+shadowMapSize = TextureSize2D 512 512
+
+up :: Vector3 GLdouble
+up = Vector3 0 1 0
+
+origin :: Vertex3 GLdouble
+origin   = Vertex3 0 0 0
+
+sun = Light 0 
+
+-- TODO: Put render-stuff in render-modul
+
+--gets Sun position in given format
+getSunPos :: (GLdouble -> GLdouble -> GLdouble -> a) -> IO a
+getSunPos f = do
+        Vertex4 x y z _ <- get (position sun)
+        return $ f (realToFrac x) (realToFrac y) (realToFrac z)
+
+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)) =
+                        (
+                        Vector3 (1.5 * fromIntegral cx) 0.0
+                                  (if even cx then 2 * fromIntegral cz else
+                                     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 :: RenderObject -> IO ()
+renderTile (coord,c,ts) =
+        preservingMatrix $ do
+                translate coord
+                {-color black
+                lineWidth $= 4.0
+                lineSmooth $= Enabled
+                _ <- renderPrimitive LineLoop $ do
+                        glNormal3f(0.0,0.0,1.0)
+                        mapM vertex ts-}
+                color c
+                _ <- renderPrimitive Polygon $ do
+                        glNormal3f(0.0,1.0,0.0)
+                        mapM vertex ts
+                return ()
+
+drawSphere :: IO ()
+drawSphere = renderQuadric
+  (QuadricStyle (Just Smooth) GenerateTextureCoordinates Outside
+     FillStyle)
+  (Sphere 2.0 48 48)
+
+drawObjects :: [RenderObject] -> [RenderObject] -> Bool -> IO ()
+drawObjects map ent shadowRender = do
+    textureOn <- get (texture Texture2D) --are textures enabled?
+
+    when shadowRender $
+        texture Texture2D $= Disabled --disable textures if we render shadows.
+
+    --draw something throwing shadows
+    preservingMatrix $ do
+        pos <- getSunPos Vector3
+        translate $ fmap (+ (-15.0)) pos
+        drawSphere
+    preservingMatrix $ do
+        pos <- getSunPos Vector3
+        translate $ fmap (+ (-10.0)) pos
+        drawSphere
+    --draw sun-indicator
+    {- preservingMatrix $ do
+        pos <- getSunPos Vector3
+        translate pos
+        color (Color4 1.0 1.0 0.0 1.0 :: Color4 GLfloat)
+        drawSphere
+        --putStrLn $ unwords ["sun at", show pos]
+        -- -}
+    --draw map
+    mapM_ renderTile map
+
+
+    when (shadowRender && textureOn == Enabled) $ --reset texture-rendering
+        texture Texture2D $= Enabled
+
+-- OpenGL polygon-function for drawing stuff.
+display :: MVar ProgramState -> PlayMap -> IO ()
+display state t =
+  let
+     -- Todo: have tiles static somewhere .. dont calculate every frame
+     tiles = P.map (prepareRenderTile t) (A.assocs t)
+  in
+      do
+        ps@PS {
+          px       = px
+        , py       = py
+        , pz       = pz
+        , pitch    = pitch
+        , heading  = heading
+        , showShadowMap = showShadowMap }
+                <- 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)
+
+        generateShadowMap tiles []
+        generateTextureMatrix
+        unless showShadowMap $ do
+                clear [ ColorBuffer, DepthBuffer ]
+                preservingMatrix $ do
+                        drawObjects tiles [] False
+
+        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'
+                           }
+
+-- Note: preservingViewport is not exception safe, but it doesn't matter here
+preservingViewport :: IO a -> IO a
+preservingViewport act = do
+   v <- get viewport
+   x <- act
+   viewport $= v
+   return x
+
+generateTextureMatrix :: IO ()
+generateTextureMatrix = do
+   -- Set up projective texture matrix. We use the Modelview matrix stack and
+   -- OpenGL matrix commands to make the matrix.
+   m <- preservingMatrix $ do
+      loadIdentity
+      -- resolve overloading, not needed in "real" programs
+      let translatef = translate :: Vector3 GLfloat -> IO ()
+          scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO ()
+      translatef (Vector3 0.5 0.5 0.0)
+      scalef 0.5 0.5 1.0
+      ortho (-20) 20 (-20) 20 1 100
+      lightPos' <- getSunPos Vertex3
+      lookAt lightPos' origin up
+      get (matrix (Just (Modelview 0)))
+
+   [ sx, sy, sz, sw,
+     tx, ty, tz, tw,
+     rx, ry, rz, rw,
+     qx, qy, qz, qw ] <- getMatrixComponents RowMajor (m :: GLmatrix GLdouble)
+
+   textureGenMode S $= Just (ObjectLinear (Plane sx sy sz sw))
+   textureGenMode T $= Just (ObjectLinear (Plane tx ty tz tw))
+   textureGenMode R $= Just (ObjectLinear (Plane rx ry rz rw))
+   textureGenMode Q $= Just (ObjectLinear (Plane qx qy qz qw))
+
+generateShadowMap :: [RenderObject] -> [RenderObject] -> IO ()
+generateShadowMap tiles obj = do
+   lightPos' <- getSunPos Vertex3
+   let (TextureSize2D shadowMapWidth shadowMapHeight) = shadowMapSize
+       shadowMapSize' = Size shadowMapWidth shadowMapHeight
+
+   preservingViewport $ do
+      viewport $= (Position 0 0, shadowMapSize')
+
+      clear [ ColorBuffer, DepthBuffer ]
+      
+      cullFace $= Just Front -- only backsides cast shadows -> less polys
+
+      matrixMode $= Projection
+      preservingMatrix $ do
+         loadIdentity
+         ortho (-20) 20 (-20) 20 10 100
+         matrixMode $= Modelview 0
+         preservingMatrix $ do
+            loadIdentity
+            lookAt lightPos' origin up
+            drawObjects tiles obj True
+         matrixMode $= Projection
+      matrixMode $= Modelview 0
+
+      copyTexImage2D Texture2D 0 DepthComponent' (Position 0 0) shadowMapSize 0
+      
+      cullFace $= Just Back
+
+   when True $ do
+      let numShadowMapPixels = fromIntegral (shadowMapWidth * shadowMapHeight)
+      allocaArray numShadowMapPixels $ \depthImage -> do
+        let pixelData fmt = PixelData fmt Float depthImage :: PixelData GLfloat
+        readPixels (Position 0 0) shadowMapSize' (pixelData DepthComponent)
+        (_, Size viewPortWidth _) <- get viewport
+        windowPos (Vertex2 (fromIntegral viewPortWidth / 2 :: GLfloat) 0)
+        drawPixels shadowMapSize' (pixelData Luminance)
+
+--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
+                , showShadowMap = showShadowMap }
+            <- 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 <- return (if not press then
+                                (ps{keysPressed = fromIntegral code `delete` kp})
+                              else
+                                (ps{keysPressed = fromIntegral code `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 }
+                    | code == 42      -> accept $ ps { showShadowMap = not showShadowMap }
+                    | code == 31      -> dumpInfo >> accept ps
+                    | 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
+                             , showShadowMap = False }
+  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
+    --set up shadow-map
+    texImage2D Texture2D NoProxy 0 DepthComponent' shadowMapSize 0
+              (PixelData DepthComponent UnsignedByte nullPtr)
+
+    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  sun $= Color4 0.3 0.3 0.3 1.0
+    diffuse  sun $= Color4 1.0 1.0 1.0 1.0
+    specular sun $= Color4 0.8 0.8 0.8 1.0
+    lightModelAmbient  $= Color4 0.2 0.2 0.2 1.0
+    position sun $= (Vertex4 2.0 1.0 1.3 1.0 :: Vertex4 GLfloat) .* (1/2.5865) .* 45
+    spotDirection sun $= (Normal3 (2.0) (1.0) (1.3) :: Normal3 GLfloat)
+    --spotExponent sun $= 1.0
+    --attenuation sun $= (1.0, 0.0, 0.0)
+
+    lighting        $= Enabled
+    light sun       $= Enabled
+    depthFunc       $= Just Less
+    shadeModel      $= Smooth
+    --lightModelLocalViewer $= Enabled
+    --vertexProgramTwoSide $= Enabled
+
+    clearColor $= Color4 0.0 0.0 0.0 0.0
+    drawBuffer $= BackBuffers
+    colorMaterial $= Just (FrontAndBack, AmbientAndDiffuse)
+
+    frontFace $= CCW
+    cullFace $= Just Back
+
+    texture Texture2D $= Enabled
+    
+    textureWrapMode Texture2D S $= (Repeated, ClampToEdge)
+    textureWrapMode Texture2D T $= (Repeated, ClampToEdge)
+    textureFilter Texture2D $= ((Linear', Nothing), Linear')
+    textureCompareMode Texture2D $= Just Lequal
+    depthTextureMode Texture2D $= Luminance'
+
+    shadeModel $= Smooth
+
+    fog $= Enabled
+    fogMode $= Linear 45.0 50.0
+    fogColor $= Color4 0.5 0.5 0.5 1.0
+    fogDistanceMode $= EyeRadial
+
+
+    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
+

src/Map/Map.hs

@@ -1,13 +1,25 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Map.Map 
 
+(
+mapVertexArrayDescriptor,
+fgColorIndex,
+fgNormalIndex,
+fgVertexIndex,
+mapStride,
+getMapBufferObject
+)
 where
 
 import System.Random
 import Data.Array.IArray
 import Data.Text as T 
 import Prelude as P
-import Graphics.Rendering.OpenGL.Raw.Core31.Types (GLfloat)
+import Graphics.Rendering.OpenGL.GL
+import Foreign.Marshal.Array (withArray)
+import Foreign.Storable (sizeOf)
+import Foreign.Ptr (Ptr, nullPtr, plusPtr)
+import Render.Misc (checkError)
 
 
 data TileType =
@@ -27,25 +39,51 @@ type PlayMap = Array (Int, Int) MapEntry
 lineHeight :: GLfloat
 lineHeight = 0.8660254
 
--- | getMap returns the map as List of Vertices (rendered as triangles).
+numComponents :: Int
---   This promises to hold True for length v == length c == length n in
+numComponents = 4  --color
---   getMap -> (v,c,n) with length v `mod` 3 == 0.
+                +3 --normal
---
+                +3 --vertex
---   v are Vertices, c are Colors and n are Normals. 
+
-getMap :: IO ([GLfloat], [GLfloat], [GLfloat])
+bufferObjectPtr :: Integral a => a -> Ptr b
-getMap = do
+bufferObjectPtr = plusPtr (nullPtr :: Ptr GLchar) . fromIntegral
+
+mapVertexArrayDescriptor :: NumComponents -> NumComponents -> VertexArrayDescriptor a
+mapVertexArrayDescriptor count' offset =
+   VertexArrayDescriptor count' Float mapStride (bufferObjectPtr (fromIntegral numComponents * offset))
+
+fgColorIndex :: (IntegerHandling, VertexArrayDescriptor a)
+fgColorIndex = (ToFloat, mapVertexArrayDescriptor 4 0)  --color first
+
+fgNormalIndex :: (IntegerHandling, VertexArrayDescriptor a)
+fgNormalIndex = (ToFloat, mapVertexArrayDescriptor 3 4) --normal after color
+
+fgVertexIndex :: (IntegerHandling, VertexArrayDescriptor a)
+fgVertexIndex = (ToFloat, mapVertexArrayDescriptor 3 7) --vertex after normal
+
+mapStride :: Stride
+mapStride = fromIntegral (sizeOf (0.0 :: GLfloat)) * fromIntegral numComponents
+
+getMapBufferObject :: IO (BufferObject, NumArrayIndices)
+getMapBufferObject = do
         map' <- testmap
-                return $ unzip3 $ generateTriangles map'
+        map' <- return $ generateTriangles map'
+        len <- return $ fromIntegral $ P.length map' `div` numComponents
+        bo <- genObjectName                     -- create a new buffer
+        bindBuffer ArrayBuffer $= Just bo       -- bind buffer
+        withArray map' $ \buffer ->
+                bufferData ArrayBuffer $= (fromIntegral (sizeOf(P.head map')), buffer, StaticDraw)
+        checkError "initBuffer"
+        return (bo,len)
 
 
-generateTriangles :: PlayMap -> [(GLfloat, GLfloat, GLfloat)] 
+generateTriangles :: PlayMap -> [GLfloat] 
 generateTriangles map' =
                 let ((xl,yl),(xh,yh)) = bounds map' in
                 P.concat [P.concat $ P.map (generateFirstTriLine map' y) [xl .. xh - 2] 
                           ++ P.map (generateSecondTriLine map' (y == yh) y) [xl .. xh - 2]
                          | y <- [yl..yh]]
 
-generateFirstTriLine :: PlayMap -> Int -> Int -> [(GLfloat, GLfloat, GLfloat)]
+generateFirstTriLine :: PlayMap -> Int -> Int -> [GLfloat]
 generateFirstTriLine map' y x =
                 P.concat $
                    if even x then
@@ -59,7 +97,7 @@ generateFirstTriLine map' y x =
                         lookupVertex map' (x + 1) y
                      ]
 
-generateSecondTriLine :: PlayMap -> Bool -> Int -> Int ->  [(GLfloat, GLfloat, GLfloat)]
+generateSecondTriLine :: PlayMap -> Bool -> Int -> Int ->  [GLfloat]
 generateSecondTriLine map' False y x  =
                 P.concat $
                    if even x then
@@ -75,7 +113,7 @@ generateSecondTriLine map' False y x  =
 generateSecondTriLine _ True _ _  = []
 
 
-lookupVertex :: PlayMap -> Int -> Int -> [(GLfloat, GLfloat, GLfloat)]
+lookupVertex :: PlayMap -> Int -> Int -> [GLfloat]
 lookupVertex map' x y = 
                 let 
                         (cr, cg, cb) = colorLookup map' (x,y)
@@ -84,9 +122,9 @@ lookupVertex map' x y =
                         --TODO: calculate normals correctly!
                 in
                 [
-                        (vx, cr, nx),
+                        cr, cg, cb, 1.0,        -- RGBA Color
-                        (vy, cg, ny),
+                        nx, ny, nz,             -- 3 Normal
-                        (vz, cb, nz)
+                        vx, vy, vz              -- 3 Vertex
                 ]
 
 heightLookup :: PlayMap -> (Int,Int) -> GLfloat

src/Render/Misc.hs

@@ -7,8 +7,13 @@ import           Graphics.Rendering.OpenGL.GL.StateVar
 import           Graphics.Rendering.OpenGL.GL.StringQueries
 import           Graphics.Rendering.OpenGL.GLU.Errors
 import           System.IO                                  (hPutStrLn, stderr)
+import Graphics.Rendering.OpenGL.Raw.Core31
+import Foreign.Marshal.Array (allocaArray, pokeArray)
 
 
+up :: (Double, Double, Double)
+up = (0.0, 1.0, 1.0)
+
 checkError :: String -> IO ()
 checkError functionName = get errors >>= mapM_ reportError
    where reportError e =
@@ -51,3 +56,53 @@ createProgramUsing shaders = do
    attachedShaders program $= shaders
    linkAndCheck program
    return program
+
+lookAtUniformMatrix4fv :: (Double, Double, Double)  --origin
+                        -> (Double, Double, Double) --camera-pos
+                        -> (Double, Double, Double) --up
+                        -> GLint -> GLsizei -> IO () --rest of GL-call
+lookAtUniformMatrix4fv o c u num size = allocaArray 16 $ \projMat ->
+                                                do
+                                                        pokeArray projMat $ lookAt o c u
+                                                        glUniformMatrix4fv num size 1 projMat
+
+-- generats 4x4-Projection-Matrix
+lookAt :: (Double, Double, Double) -> (Double, Double, Double) -> (Double, Double, Double) -> [GLfloat]
+lookAt origin eye up = 
+        map (fromRational . toRational) [
+         xx, yx, zx, 0,
+         xy, yy, zy, 0,
+         xz, yz, zz, 0,
+         -(x *. eye), -(y *. eye), -(z *. eye), 1
+        ]
+        where
+                z@(zx,zy,zz) = normal (origin .- eye)
+                x@(xx,xy,xz) = normal (up *.* z)
+                y@(yx,yy,yz) = z *.* x
+
+normal :: (Double, Double, Double) -> (Double, Double, Double)
+normal x = (1.0 / (sqrt (x *. x))) .* x
+
+infixl 5 .*
+--scaling
+(.*) :: Double -> (Double, Double, Double) -> (Double, Double, Double)
+a .* (x,y,z) = (a*x, a*y, a*z)
+
+infixl 5 .-
+--subtraction
+(.-) :: (Double, Double, Double) -> (Double, Double, Double) -> (Double, Double, Double)
+(a,b,c) .- (x,y,z) = (a-x, b-y, c-z)
+
+infixl 5 *.*
+--cross-product for left-hand-system
+(*.*) :: (Double, Double, Double) -> (Double, Double, Double) -> (Double, Double, Double)
+(a,b,c) *.* (x,y,z) = (   c*y - b*z
+                        , a*z - c*x
+                        , b*x - a*y
+                        )
+
+infixl 5 *.
+--dot-product
+(*.) :: (Double, Double, Double) -> (Double, Double, Double) -> Double
+(a,b,c) *. (x,y,z) = a*x + b*y + c*z
+

src/Render/Render.hs

@@ -33,7 +33,7 @@ initBuffer varray =
            checkError "initBuffer"
            return bufferObject
 
-initShader :: IO (UniformLocation, AttribLocation, AttribLocation)
+initShader :: IO (AttribLocation, AttribLocation, AttribLocation, UniformLocation)
 initShader = do
    ! vertexSource <- B.readFile vertexShaderFile
    ! fragmentSource <- B.readFile fragmentShaderFile
@@ -50,8 +50,12 @@ initShader = do
    vertexIndex <- get (attribLocation program "fg_Vertex")
    vertexAttribArray vertexIndex $= Enabled
 
+   normalIndex <- get (attribLocation program "fg_Normal")
+   vertexAttribArray normalIndex $= Enabled
+
+
    checkError "initShader"
-   return (projectionMatrixIndex, colorIndex, vertexIndex)
+   return (colorIndex, normalIndex, vertexIndex, projectionMatrixIndex)
 
 initRendering :: IO ()
 initRendering = do

src/Render/RenderObject.hs

@@ -0,0 +1,2 @@
+module Render.RenderObject where
+