added primitive map-render
- added primitive map-template - window now renders correctly - height-calculation is still a bit off
This commit is contained in:
parent
8bca5a82df
commit
65934809d5
@ -13,7 +13,11 @@ executable Pioneers
|
||||
OpenGL >=2.8.0 && <2.9,
|
||||
gtkglext >=0.12,
|
||||
containers >=0.5 && <0.6,
|
||||
array >=0.4.0 && <0.5
|
||||
array >=0.4.0 && <0.5,
|
||||
random >=1.0.1 && <1.1,
|
||||
random >=1.0.1 && <1.1
|
||||
ghc-options: -Wall
|
||||
other-modules: Map.Coordinates
|
||||
other-modules:
|
||||
Map.Coordinates,
|
||||
Map.Map
|
||||
|
||||
|
||||
79
src/Main.hs
79
src/Main.hs
@ -6,26 +6,80 @@ import qualified Graphics.UI.Gtk.OpenGL as GtkGL
|
||||
|
||||
import Graphics.Rendering.OpenGL as GL
|
||||
import qualified Graphics.UI.Gtk.Gdk.Events as Event
|
||||
import qualified Data.Array.IArray as A
|
||||
|
||||
import Map.Coordinates
|
||||
import Map.Map
|
||||
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Debug.Trace
|
||||
|
||||
animationWaitTime = 3
|
||||
canvasWidth = 640
|
||||
canvasHeight = 480
|
||||
animationWaitTime = 3 :: Int
|
||||
canvasWidth = 640 :: Int
|
||||
canvasHeight = 480 :: Int
|
||||
|
||||
|
||||
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 cz then
|
||||
Vector3 (3*(fromIntegral cx)) 0.0 ((fromIntegral cz))
|
||||
else
|
||||
Vector3 (3*(fromIntegral cx)+1.5) 0.0 ((fromIntegral cz))
|
||||
,
|
||||
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 :: IO ()
|
||||
display = do
|
||||
display :: PlayMap -> IO ()
|
||||
display t =
|
||||
let
|
||||
tiles = map (prepareRenderTile t) (A.assocs t)
|
||||
in
|
||||
do
|
||||
loadIdentity
|
||||
GL.rotate (60) (Vector3 1.0 0.0 0.0 :: Vector3 GLfloat)
|
||||
--GL.rotate (-20) (Vector3 0.0 1.0 0.0 :: Vector3 GLfloat)
|
||||
translate (Vector3 (-15) (-10) (-15)::Vector3 GLfloat)
|
||||
position (Light 0) $= Vertex4 0.0 0.0 (2.0) 1.0
|
||||
|
||||
-- Instead of glBegin ... glEnd there is renderPrimitive.
|
||||
color (Color3 1 1 1 :: Color3 GLfloat)
|
||||
renderPrimitive Polygon $ do
|
||||
--trace (show tiles) $
|
||||
mapM_ renderTile tiles
|
||||
return ()
|
||||
{- color (Color3 1 1 1 :: Color3 GLfloat)
|
||||
renderPrimitive LineLoop $ do
|
||||
vertex (Vertex3 0.25 0.25 0.0 :: Vertex3 GLfloat)
|
||||
vertex (Vertex3 0.75 0.25 0.0 :: Vertex3 GLfloat)
|
||||
vertex (Vertex3 0.75 0.75 0.0 :: Vertex3 GLfloat)
|
||||
vertex (Vertex3 0.25 0.75 0.0 :: Vertex3 GLfloat)
|
||||
vertex (Vertex3 0.25 0.75 0.0 :: Vertex3 GLfloat) -}
|
||||
|
||||
--Adjust size to given dimensions
|
||||
reconfigure :: Int -> Int -> IO (Int, Int)
|
||||
@ -57,6 +111,7 @@ reshape dims = do
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
terrain <- testmap
|
||||
Gtk.initGUI
|
||||
-- Initialise the Gtk+ OpenGL extension
|
||||
-- (including reading various command line parameters)
|
||||
@ -77,18 +132,20 @@ main = do
|
||||
-- (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
|
||||
clearColor $= (Color4 0.0 0.0 0.0 0.0)
|
||||
reconfigure canvasWidth canvasHeight
|
||||
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
|
||||
drawBuffer $= BackBuffers-}
|
||||
|
||||
-- Set the repaint handler
|
||||
Gtk.onExpose canvas $ \_ -> do
|
||||
GtkGL.withGLDrawingArea canvas $ \glwindow -> do
|
||||
GL.clear [GL.DepthBuffer, GL.ColorBuffer]
|
||||
display
|
||||
display terrain
|
||||
GtkGL.glDrawableSwapBuffers glwindow
|
||||
return True
|
||||
|
||||
|
||||
@ -2,7 +2,10 @@
|
||||
module Map.Coordinates
|
||||
|
||||
--exports..
|
||||
(getTileVertices)
|
||||
(
|
||||
getTileVertices,
|
||||
Tile
|
||||
)
|
||||
|
||||
where
|
||||
|
||||
@ -12,16 +15,15 @@ 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
|
||||
|
||||
|
||||
|
||||
type Coordinates = (Integer, Integer)
|
||||
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
|
||||
-- | The heights of a Map in a random accessible way.
|
||||
type MapHeights = Map Coordinates Int
|
||||
|
||||
instance Num Tile where
|
||||
(i,j) + (x,y) = (i+x, j+y)
|
||||
@ -30,7 +32,7 @@ instance Num Tile where
|
||||
negate (x,y) = (negate x, negate y)
|
||||
abs (x,y) = (abs x, abs y)
|
||||
signum (_,_) = undefined
|
||||
fromInteger a = (a,a)
|
||||
fromInteger a = (fromIntegral a,fromIntegral a)
|
||||
|
||||
instance Num Pos where
|
||||
(i,j) + (x,y) = (i+x, j+y)
|
||||
@ -41,9 +43,6 @@ instance Num Pos where
|
||||
signum (_,_) = undefined
|
||||
fromInteger a = (fromIntegral a, fromIntegral a)
|
||||
|
||||
tileToPos :: Tile -> Pos
|
||||
tileToPos (x,y) = (fromIntegral x, fromIntegral y)
|
||||
|
||||
data Neighbours =
|
||||
North
|
||||
| South
|
||||
@ -63,67 +62,66 @@ data TileVertex =
|
||||
| VertexW
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
--getGrid :: Coordinates -> Coordinates -> []
|
||||
|
||||
getTileVertices :: MapHeights -> Tile -> [Vertex3 GLfloat]
|
||||
getTileVertices heights t = let p = (listArray (0,5) $ P.map (+ tileToPos t) hexagon)::Array Int (Float,Float) in
|
||||
getTileVertices :: PlayMap -> Tile -> [Vertex3 GLfloat]
|
||||
getTileVertices heights t = let p = (listArray (0,5) hexagon)
|
||||
::Array Int (Float,Float) in
|
||||
P.map floatToVertex $
|
||||
[
|
||||
(fst $ p ! 0, snd $ p ! 0,fromMaybe 0.0 $ getHeight heights VertexNW t),
|
||||
(fst $ p ! 1, snd $ p ! 1,fromMaybe 0.0 $ getHeight heights VertexNW t),
|
||||
(fst $ p ! 2, snd $ p ! 2,fromMaybe 0.0 $ getHeight heights VertexNW t),
|
||||
(fst $ p ! 3, snd $ p ! 3,fromMaybe 0.0 $ getHeight heights VertexNW t),
|
||||
(fst $ p ! 4, snd $ p ! 4,fromMaybe 0.0 $ getHeight heights VertexNW t),
|
||||
(fst $ p ! 5, snd $ p ! 5,fromMaybe 0.0 $ getHeight heights VertexNW t)
|
||||
(fst $ p ! 0, getHeight heights VertexNW t, snd $ p ! 0),
|
||||
(fst $ p ! 1, getHeight heights VertexNE t, snd $ p ! 1),
|
||||
(fst $ p ! 2, getHeight heights VertexE t, snd $ p ! 2),
|
||||
(fst $ p ! 3, getHeight heights VertexSE t, snd $ p ! 3),
|
||||
(fst $ p ! 4, getHeight heights VertexSW t, snd $ p ! 4),
|
||||
(fst $ p ! 5, getHeight heights VertexW t, snd $ p ! 5)
|
||||
]
|
||||
|
||||
getHeight :: MapHeights -> TileVertex -> Tile -> Maybe Float
|
||||
getHeight h v t@(_,ty) =
|
||||
getHeight :: PlayMap -> TileVertex -> Tile -> Float
|
||||
getHeight pm v t@(_,ty) =
|
||||
let
|
||||
! tileheight = fmap fromIntegral $ M.lookup t h
|
||||
! y = if even ty then -1 else 0
|
||||
h = heightLookup pm
|
||||
! tileheight = h t
|
||||
! y = if even ty then 1 else 0
|
||||
in
|
||||
case v of
|
||||
VertexNW -> do
|
||||
c <- tileheight
|
||||
n <- M.lookup (t+(0,-1)) h
|
||||
nw <- M.lookup (t+(-1,y)) h
|
||||
return $ (fromIntegral $ n+nw+c) / 3.0
|
||||
VertexNE -> do
|
||||
c <- tileheight
|
||||
n <- M.lookup (t+(0,-1)) h
|
||||
ne <- M.lookup (t+(1,y)) h
|
||||
return $ (fromIntegral $ n+ne+c) / 3.0
|
||||
VertexE -> do
|
||||
c <- tileheight
|
||||
ne <- M.lookup (t+(1,y)) h
|
||||
se <- M.lookup (t+(1,y+1)) h
|
||||
return $ (fromIntegral $ ne+se+c) / 3.0
|
||||
VertexSE -> do
|
||||
c <- tileheight
|
||||
s <- M.lookup (t+(0,1)) h
|
||||
se <- M.lookup (t+(1,y+1)) h
|
||||
return $ (fromIntegral $ s+se+c) / 3.0
|
||||
VertexSW -> do
|
||||
c <- tileheight
|
||||
s <- M.lookup (t+(0,1)) h
|
||||
sw <- M.lookup (t+(-1,y+1)) h
|
||||
return $ (fromIntegral $ s+sw+c) / 3.0
|
||||
VertexW -> do
|
||||
c <- tileheight
|
||||
sw <- M.lookup (t+(-1,y+1)) h
|
||||
nw <- M.lookup (t+(-1,y)) h
|
||||
return $ (fromIntegral $ sw+nw+c) / 3.0
|
||||
VertexNW -> let
|
||||
n = h (t+(0,-1))
|
||||
nw = h (t+(-1,y))
|
||||
in (n + nw + tileheight) / 3.0
|
||||
VertexNE -> let
|
||||
n = h (t+(0,-1))
|
||||
ne = h (t+(1,y))
|
||||
in (n + ne + tileheight) / 3.0
|
||||
VertexE -> let
|
||||
ne = h (t+(1,y))
|
||||
se = h (t+(1,y+1))
|
||||
in (ne + se + tileheight) / 3.0
|
||||
VertexSE -> let
|
||||
s = h (t+(0,1))
|
||||
se = h (t+(1,y+1))
|
||||
in (s + se + tileheight) / 3.0
|
||||
VertexSW -> let
|
||||
s = h (t+(0,1))
|
||||
sw = h (t+(-1,y+1))
|
||||
in (s + sw + tileheight) / 3.0
|
||||
VertexW -> let
|
||||
sw = h (t+(-1,y+1))
|
||||
nw = h(t+(-1,y))
|
||||
in (sw + nw + tileheight) / 3.0
|
||||
|
||||
heightLookup :: PlayMap -> Tile -> Float
|
||||
heightLookup hs t@(x,y) = if inRange (bounds hs) t then h else 0
|
||||
where
|
||||
(h,_) = hs ! t
|
||||
|
||||
hexagon :: [(Float,Float)]
|
||||
hexagon = [
|
||||
(0.2,0),
|
||||
(0.6,0),
|
||||
(-0.5,-1),
|
||||
(0.5,-1),
|
||||
(1,0),
|
||||
(0.5,1),
|
||||
(1,0.6),
|
||||
(1,0.2),
|
||||
(0.5,0)
|
||||
(-0.5,1),
|
||||
(-1,0)
|
||||
]
|
||||
|
||||
|
||||
|
||||
51
src/Map/Map.hs
Normal file
51
src/Map/Map.hs
Normal file
@ -0,0 +1,51 @@
|
||||
module Map.Map
|
||||
|
||||
where
|
||||
|
||||
import System.Random
|
||||
import Data.Array.IArray
|
||||
|
||||
data TileType =
|
||||
Grass
|
||||
| Sand
|
||||
| Water
|
||||
| Mountain
|
||||
deriving (Show, Eq)
|
||||
|
||||
type MapEntry = (
|
||||
Float, -- ^ Height
|
||||
TileType
|
||||
)
|
||||
|
||||
type PlayMap = Array (Int, Int) MapEntry
|
||||
|
||||
testMapTemplate :: [[String]]
|
||||
testMapTemplate = [
|
||||
["~~~~~~~~~~"],
|
||||
["~~SSSSSS~~"],
|
||||
["~SSGGGGS~~"],
|
||||
["~SSGGMMS~~"],
|
||||
["~SGGMMS~~~"],
|
||||
["~SGMMMS~~~"],
|
||||
["~GGGGGGS~~"],
|
||||
["~SGGGGGS~~"],
|
||||
["~~SSSS~~~~"],
|
||||
["~~~~~~~~~~"]
|
||||
]
|
||||
|
||||
testmap :: IO PlayMap
|
||||
testmap = do
|
||||
g <- getStdGen
|
||||
rawMap <- return $ map (parseTemplate (randoms g)) (concat $ concat testMapTemplate)
|
||||
return $ listArray ((0,0),(9,9)) rawMap
|
||||
|
||||
|
||||
parseTemplate :: [Int] -> Char -> MapEntry
|
||||
parseTemplate (r:_) t =
|
||||
case t of
|
||||
'~' -> (0, Water)
|
||||
'S' -> (0, Sand)
|
||||
'G' -> ((fromIntegral $ r `mod` 3)/3,Grass)
|
||||
'M' -> ((fromIntegral $ r `mod` 3 + 2)/3, Mountain)
|
||||
_ -> error "invalid template format for map"
|
||||
parseTemplate [] _ = error "out of randoms..."
|
||||
Loading…
Reference in New Issue
Block a user