diff --git a/Pioneers.cabal b/Pioneers.cabal index 84ca44c..479efb0 100644 --- a/Pioneers.cabal +++ b/Pioneers.cabal @@ -19,7 +19,8 @@ executable Pioneers text >=0.11.3 && <0.12, stm >=2.4.2 && <2.5, transformers >=0.3.0 && <0.4, - List >=0.5.1 && <0.6 + List >=0.5.1 && <0.6, + OpenGLRaw >=1.4.0 && <1.5 ghc-options: -Wall other-modules: Map.Coordinates, diff --git a/src/Main.hs b/src/Main.hs index 14e09aa..985847d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -124,6 +124,10 @@ drawObjects map ent shadowRender = 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 @@ -259,7 +263,7 @@ generateShadowMap tiles obj = do clear [ ColorBuffer, DepthBuffer ] - --cullFace $= Just Front -- only backsides cast shadows -> less polys + cullFace $= Just Front -- only backsides cast shadows -> less polys matrixMode $= Projection preservingMatrix $ do @@ -275,7 +279,7 @@ generateShadowMap tiles obj = do copyTexImage2D Texture2D 0 DepthComponent' (Position 0 0) shadowMapSize 0 - --cullFace $= Just Back + cullFace $= Just Back when True $ do let numShadowMapPixels = fromIntegral (shadowMapWidth * shadowMapHeight) @@ -441,15 +445,15 @@ main = do clearColor $= Color4 0.0 0.0 0.0 0.0 drawBuffer $= BackBuffers - colorMaterial $= Just (Front, Diffuse) + colorMaterial $= Just (FrontAndBack, AmbientAndDiffuse) frontFace $= CCW cullFace $= Just Back texture Texture2D $= Enabled - --textureWrapMode Texture2D S $= (Repeated, ClampToEdge) - --textureWrapMode Texture2D T $= (Repeated, ClampToEdge) + textureWrapMode Texture2D S $= (Repeated, ClampToEdge) + textureWrapMode Texture2D T $= (Repeated, ClampToEdge) textureFilter Texture2D $= ((Linear', Nothing), Linear') textureCompareMode Texture2D $= Just Lequal depthTextureMode Texture2D $= Luminance' diff --git a/src/Map/Coordinates.hs b/src/Map/Coordinates.hs index 21e6f31..29673a2 100644 --- a/src/Map/Coordinates.hs +++ b/src/Map/Coordinates.hs @@ -10,19 +10,14 @@ Tile where import Graphics.Rendering.OpenGL as GL -import Data.Map as M hiding ((!)) -import qualified Data.Map as M ((!)) -import Data.Maybe import Prelude as P import Data.Array.IArray as A -import Map.Map as PMap -import Debug.Trace +import Map.Map as PMap hiding (heightLookup) type Coordinates = (Int, Int) type Pos = (Float, Float) --- | a Tile is 1 unit in size. Due to hexagonality the real rendered Area is less. type Tile = Coordinates instance Num Tile where @@ -52,7 +47,7 @@ data Neighbours = | SouthWest deriving (Show, Eq) --- | Ordered Vertice-List for rendering (clockwise) +-- | Ordered Vertice-List for rendering (Counterclockwise) data TileVertex = VertexNW | VertexNE diff --git a/src/Map/Map.hs b/src/Map/Map.hs index 4566f1a..2066e45 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -7,6 +7,8 @@ import System.Random import Data.Array.IArray import Data.Text as T import Prelude as P +import Graphics.Rendering.OpenGL.Raw.Core31.Types (GLfloat) + data TileType = Grass @@ -22,6 +24,93 @@ type MapEntry = ( type PlayMap = Array (Int, Int) MapEntry +lineHeight :: GLfloat +lineHeight = 0.8660254 + +-- | getMap returns the map as List of Vertices (rendered as triangles). +-- This promises to hold True for length v == length c == length n in +-- getMap -> (v,c,n) with length v `mod` 3 == 0. +-- +-- v are Vertices, c are Colors and n are Normals. +getMap :: IO ([GLfloat], [GLfloat], [GLfloat]) +getMap = do + map' <- testmap + return $ unzip3 $ generateTriangles map' + + +generateTriangles :: PlayMap -> [(GLfloat, GLfloat, 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 map' y x = + P.concat $ + if even x then + [ lookupVertex map' x y, + lookupVertex map' (x + 1) y, + lookupVertex map' (x + 2) y + ] + else + [ lookupVertex map' x y, + lookupVertex map' (x + 2) y, + lookupVertex map' (x + 1) y + ] + +generateSecondTriLine :: PlayMap -> Bool -> Int -> Int -> [(GLfloat, GLfloat, GLfloat)] +generateSecondTriLine map' False y x = + P.concat $ + if even x then + [ lookupVertex map' x (y + 1), + lookupVertex map' (x + 2) (y + 1), + lookupVertex map' (x + 1) y + ] + else + [ lookupVertex map' x y, + lookupVertex map' (x + 1) (y + 1), + lookupVertex map' (x + 2) y + ] +generateSecondTriLine _ True _ _ = [] + + +lookupVertex :: PlayMap -> Int -> Int -> [(GLfloat, GLfloat, GLfloat)] +lookupVertex map' x y = + let + (cr, cg, cb) = colorLookup map' (x,y) + (vx, vy, vz) = coordLookup (x,y) $ heightLookup map' (x,y) + (nx, ny, nz) = (0.0, 1.0, 0.0) :: (GLfloat, GLfloat, GLfloat) + in + [ + (vx, cr, nx), + (vy, cg, ny), + (vz, cb, nz) + ] + +heightLookup :: PlayMap -> (Int,Int) -> GLfloat +heightLookup hs t = if inRange (bounds hs) t then fromRational $ toRational h else 0.0 + where + (h,_) = hs ! t + +colorLookup :: PlayMap -> (Int,Int) -> (GLfloat, GLfloat, GLfloat) +colorLookup hs t = if inRange (bounds hs) t then c else (0.0, 0.0, 0.0) + where + (_,tp) = hs ! t + c = case tp of + Water -> (0.5, 0.5, 1) + Sand -> (0.9, 0.85, 0.7) + Grass -> (0.3, 0.9, 0.1) + Mountain -> (0.5, 0.5, 0.5) + +coordLookup :: (Int,Int) -> GLfloat -> (GLfloat, GLfloat, GLfloat) +coordLookup (x,y) h = + if even x then + (fromIntegral $ x `div` 2, fromIntegral (2 * y) * lineHeight, h) + else + (fromIntegral (x `div` 2) / 2.0, fromIntegral (2 * y + 1) * lineHeight, h) + + -- if writing in ASCII-Format transpose so i,j -> y,x -- row-minor -> row-major testMapTemplate :: [Text]