2013-12-29 14:39:01 +01:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
2013-12-29 06:03:32 +01:00
|
|
|
module Map.Map
|
|
|
|
|
2014-01-03 03:01:54 +01:00
|
|
|
(
|
|
|
|
mapVertexArrayDescriptor,
|
|
|
|
fgColorIndex,
|
|
|
|
fgNormalIndex,
|
|
|
|
fgVertexIndex,
|
|
|
|
mapStride,
|
|
|
|
getMapBufferObject
|
|
|
|
)
|
2013-12-29 06:03:32 +01:00
|
|
|
where
|
|
|
|
|
|
|
|
import System.Random
|
|
|
|
import Data.Array.IArray
|
2013-12-29 14:39:01 +01:00
|
|
|
import Data.Text as T
|
|
|
|
import Prelude as P
|
2014-01-03 23:25:59 +01:00
|
|
|
--import Graphics.Rendering.OpenGL.GL
|
|
|
|
import Graphics.Rendering.OpenGL.GL.BufferObjects
|
|
|
|
import Graphics.Rendering.OpenGL.GL.ObjectName
|
|
|
|
import Graphics.Rendering.OpenGL.GL.StateVar
|
|
|
|
import Graphics.Rendering.OpenGL.GL.VertexArrays
|
|
|
|
import Graphics.Rendering.OpenGL.GL.VertexSpec
|
|
|
|
import Graphics.Rendering.OpenGL.Raw.Core31
|
|
|
|
|
2014-01-03 03:01:54 +01:00
|
|
|
import Foreign.Marshal.Array (withArray)
|
|
|
|
import Foreign.Storable (sizeOf)
|
|
|
|
import Foreign.Ptr (Ptr, nullPtr, plusPtr)
|
|
|
|
import Render.Misc (checkError)
|
2014-01-02 03:05:35 +01:00
|
|
|
|
2013-12-29 06:03:32 +01:00
|
|
|
|
|
|
|
data TileType =
|
|
|
|
Grass
|
|
|
|
| Sand
|
|
|
|
| Water
|
|
|
|
| Mountain
|
|
|
|
deriving (Show, Eq)
|
|
|
|
|
|
|
|
type MapEntry = (
|
|
|
|
Float, -- ^ Height
|
|
|
|
TileType
|
|
|
|
)
|
|
|
|
|
|
|
|
type PlayMap = Array (Int, Int) MapEntry
|
|
|
|
|
2014-01-02 03:05:35 +01:00
|
|
|
lineHeight :: GLfloat
|
|
|
|
lineHeight = 0.8660254
|
|
|
|
|
2014-01-03 03:01:54 +01:00
|
|
|
numComponents :: Int
|
2014-01-04 14:09:42 +01:00
|
|
|
numComponents = 7
|
2014-01-02 03:05:35 +01:00
|
|
|
|
2014-01-03 17:46:41 +01:00
|
|
|
mapStride :: Stride
|
2014-01-04 14:09:42 +01:00
|
|
|
mapStride = fromIntegral (sizeOf (0.0 :: GLfloat) * numComponents)
|
2014-01-03 17:46:41 +01:00
|
|
|
|
2014-01-04 14:09:42 +01:00
|
|
|
bufferObjectPtr :: Integral a => a -> Ptr GLfloat
|
|
|
|
bufferObjectPtr = plusPtr (nullPtr :: Ptr GLfloat) . fromIntegral
|
2014-01-02 03:05:35 +01:00
|
|
|
|
2014-01-04 14:09:42 +01:00
|
|
|
mapVertexArrayDescriptor :: NumComponents -> NumComponents -> VertexArrayDescriptor GLfloat
|
2014-01-03 03:01:54 +01:00
|
|
|
mapVertexArrayDescriptor count' offset =
|
2014-01-04 14:09:42 +01:00
|
|
|
VertexArrayDescriptor count' Float mapStride (bufferObjectPtr offset ) --(fromIntegral numComponents * offset))
|
2014-01-03 03:01:54 +01:00
|
|
|
|
2014-01-04 14:09:42 +01:00
|
|
|
fgColorIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat)
|
|
|
|
fgColorIndex = (ToFloat, mapVertexArrayDescriptor 4 3) --color first
|
2014-01-03 03:01:54 +01:00
|
|
|
|
2014-01-04 14:09:42 +01:00
|
|
|
fgNormalIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat)
|
2014-01-03 03:01:54 +01:00
|
|
|
fgNormalIndex = (ToFloat, mapVertexArrayDescriptor 3 4) --normal after color
|
|
|
|
|
2014-01-04 14:09:42 +01:00
|
|
|
fgVertexIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat)
|
|
|
|
fgVertexIndex = (ToFloat, mapVertexArrayDescriptor 3 0) --vertex after normal
|
2014-01-03 03:01:54 +01:00
|
|
|
|
|
|
|
getMapBufferObject :: IO (BufferObject, NumArrayIndices)
|
|
|
|
getMapBufferObject = do
|
|
|
|
map' <- testmap
|
2014-01-04 14:09:42 +01:00
|
|
|
map' <- return $ P.map (*1) (generateTriangles map')
|
2014-01-03 17:46:41 +01:00
|
|
|
putStrLn $ P.unlines $ P.map show (prettyMap map')
|
2014-01-03 03:01:54 +01:00
|
|
|
len <- return $ fromIntegral $ P.length map' `div` numComponents
|
2014-01-03 22:31:01 +01:00
|
|
|
putStrLn $ P.unwords ["num verts",show len]
|
2014-01-03 03:01:54 +01:00
|
|
|
bo <- genObjectName -- create a new buffer
|
|
|
|
bindBuffer ArrayBuffer $= Just bo -- bind buffer
|
|
|
|
withArray map' $ \buffer ->
|
2014-01-04 02:53:12 +01:00
|
|
|
bufferData ArrayBuffer $= (fromIntegral (P.length map' * sizeOf(P.head map')), buffer, StaticDraw)
|
2014-01-03 03:01:54 +01:00
|
|
|
checkError "initBuffer"
|
|
|
|
return (bo,len)
|
|
|
|
|
2014-01-03 17:46:41 +01:00
|
|
|
prettyMap :: [GLfloat] -> [(GLfloat,GLfloat,GLfloat,GLfloat,GLfloat,GLfloat,GLfloat,GLfloat,GLfloat,GLfloat)]
|
|
|
|
prettyMap (a:b:c:d:x:y:z:u:v:w:ms) = (a,b,c,d,x,y,z,u,v,w):(prettyMap ms)
|
|
|
|
prettyMap _ = []
|
2014-01-03 03:01:54 +01:00
|
|
|
|
2014-01-04 02:53:12 +01:00
|
|
|
generateCube :: [GLfloat]
|
|
|
|
generateCube = [ -- lower plane
|
2014-01-04 03:14:44 +01:00
|
|
|
-3.0,-3.0,-3.0,
|
|
|
|
3.0,-3.0,3.0,
|
|
|
|
3.0,-3.0,-3.0,
|
|
|
|
-3.0,-3.0,-3.0,
|
|
|
|
-3.0,-3.0,3.0,
|
|
|
|
3.0,-3.0,3.0,
|
2014-01-04 02:53:12 +01:00
|
|
|
-- upper plane
|
2014-01-04 03:14:44 +01:00
|
|
|
-3.0,3.0,-3.0,
|
|
|
|
3.0,3.0,3.0,
|
|
|
|
3.0,3.0,-3.0,
|
|
|
|
-3.0,3.0,-3.0,
|
|
|
|
-3.0,3.0,3.0,
|
|
|
|
3.0,3.0,3.0,
|
2014-01-04 02:53:12 +01:00
|
|
|
-- left plane
|
2014-01-04 03:14:44 +01:00
|
|
|
-3.0,-3.0,-3.0,
|
|
|
|
-3.0,3.0,3.0,
|
|
|
|
-3.0,-3.0,3.0,
|
|
|
|
-3.0,-3.0,-3.0,
|
|
|
|
-3.0,3.0,3.0,
|
|
|
|
-3.0,3.0,-3.0,
|
2014-01-04 02:53:12 +01:00
|
|
|
-- right plane
|
2014-01-04 03:14:44 +01:00
|
|
|
3.0,-3.0,-3.0,
|
|
|
|
3.0,3.0,3.0,
|
|
|
|
3.0,-3.0,3.0,
|
|
|
|
3.0,-3.0,-3.0,
|
|
|
|
3.0,3.0,3.0,
|
|
|
|
3.0,3.0,-3.0,
|
2014-01-04 02:53:12 +01:00
|
|
|
-- front plane
|
2014-01-04 03:14:44 +01:00
|
|
|
-3.0,-3.0,-3.0,
|
|
|
|
3.0,3.0,-3.0,
|
|
|
|
3.0,-3.0,-3.0,
|
|
|
|
-3.0,-3.0,-3.0,
|
|
|
|
3.0,3.0,-3.0,
|
|
|
|
-3.0,3.0,-3.0,
|
2014-01-04 02:53:12 +01:00
|
|
|
-- back plane
|
2014-01-04 03:14:44 +01:00
|
|
|
-3.0,-3.0,3.0,
|
|
|
|
3.0,3.0,3.0,
|
|
|
|
3.0,-3.0,3.0,
|
|
|
|
-3.0,-3.0,3.0,
|
|
|
|
3.0,3.0,3.0,
|
|
|
|
-3.0,3.0,3.0
|
2014-01-04 02:53:12 +01:00
|
|
|
]
|
|
|
|
|
2014-01-03 03:01:54 +01:00
|
|
|
generateTriangles :: PlayMap -> [GLfloat]
|
2014-01-02 03:05:35 +01:00
|
|
|
generateTriangles map' =
|
|
|
|
let ((xl,yl),(xh,yh)) = bounds map' in
|
|
|
|
P.concat [P.concat $ P.map (generateFirstTriLine map' y) [xl .. xh - 2]
|
2014-01-03 03:01:54 +01:00
|
|
|
++ P.map (generateSecondTriLine map' (y == yh) y) [xl .. xh - 2]
|
2014-01-02 03:05:35 +01:00
|
|
|
| y <- [yl..yh]]
|
|
|
|
|
2014-01-03 03:01:54 +01:00
|
|
|
generateFirstTriLine :: PlayMap -> Int -> Int -> [GLfloat]
|
2014-01-02 03:05:35 +01:00
|
|
|
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
|
|
|
|
]
|
|
|
|
|
2014-01-03 03:01:54 +01:00
|
|
|
generateSecondTriLine :: PlayMap -> Bool -> Int -> Int -> [GLfloat]
|
2014-01-02 03:05:35 +01:00
|
|
|
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 _ _ = []
|
|
|
|
|
|
|
|
|
2014-01-03 03:01:54 +01:00
|
|
|
lookupVertex :: PlayMap -> Int -> Int -> [GLfloat]
|
2014-01-02 03:05:35 +01:00
|
|
|
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)
|
2014-01-02 03:35:38 +01:00
|
|
|
--TODO: calculate normals correctly!
|
2014-01-02 03:05:35 +01:00
|
|
|
in
|
|
|
|
[
|
2014-01-04 14:09:42 +01:00
|
|
|
vx, vy, vz, -- 3 Vertex
|
|
|
|
cr, cg, cb, 1.0 -- RGBA Color
|
|
|
|
--nx, ny, nz, -- 3 Normal
|
2014-01-02 03:05:35 +01:00
|
|
|
]
|
|
|
|
|
|
|
|
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)
|
2014-01-02 13:02:01 +01:00
|
|
|
coordLookup (x,z) y =
|
2014-01-02 03:05:35 +01:00
|
|
|
if even x then
|
2014-01-02 13:02:01 +01:00
|
|
|
(fromIntegral $ x `div` 2, y, fromIntegral (2 * z) * lineHeight)
|
2014-01-02 03:05:35 +01:00
|
|
|
else
|
2014-01-04 14:09:42 +01:00
|
|
|
(fromIntegral (x `div` 2) + 0.5, y, fromIntegral (2 * z + 1) * lineHeight)
|
2014-01-02 03:05:35 +01:00
|
|
|
|
|
|
|
|
2013-12-29 14:39:01 +01:00
|
|
|
-- if writing in ASCII-Format transpose so i,j -> y,x
|
|
|
|
-- row-minor -> row-major
|
|
|
|
testMapTemplate :: [Text]
|
|
|
|
testMapTemplate = T.transpose [
|
2014-01-01 20:32:35 +01:00
|
|
|
"~~~~~~~~~~~~~~~~~~~~",
|
|
|
|
"~~SSSSSSSSSSSSSS~~~~",
|
|
|
|
"~SSGGGGGGGSGSGGS~~~~",
|
|
|
|
"~SSGGGGGGMSGSGMS~~~~",
|
|
|
|
"~SGGGGGGMMMGGGS~~~S~",
|
|
|
|
"~SGGGMGMMMMMGGS~~~SS",
|
|
|
|
"~GGGGGGGGGGGGGGS~~~~",
|
|
|
|
"~SGGGGGGGGGGGGGS~~~~",
|
|
|
|
"~~SSSSGGGSSSSS~~~~~~",
|
|
|
|
"~~~~~SGGGGS~~~~~~~~~",
|
|
|
|
"~~~~SSGGGGSS~~~~~~~~",
|
|
|
|
"~~SSSGGGGGGSSSSS~~~~",
|
|
|
|
"~SSGSGSGGGSGSGGS~~~~",
|
|
|
|
"~SSGSGSGGMSGSGMS~~~~",
|
|
|
|
"~SGGMMMMGGGGGGS~~~~~",
|
|
|
|
"~SGMMMMMGGGGSSS~~~~~",
|
|
|
|
"~GGMMMMMGGGSSSSS~~~~",
|
|
|
|
"~SGGGGGGGSSSSSSS~~~~",
|
|
|
|
"~~SSSSSSSSSSSS~~~~~~",
|
|
|
|
"~~~~~~~~~~~~~~~~~~~~"
|
2013-12-29 06:03:32 +01:00
|
|
|
]
|
|
|
|
|
2014-01-03 17:46:41 +01:00
|
|
|
testMapTemplate2 :: [Text]
|
|
|
|
testMapTemplate2 = T.transpose [
|
2014-01-04 14:09:42 +01:00
|
|
|
"~~~~~~~~~~~~",
|
|
|
|
"~SSSSSSSSSS~"
|
2014-01-03 17:46:41 +01:00
|
|
|
]
|
|
|
|
|
2013-12-29 06:03:32 +01:00
|
|
|
testmap :: IO PlayMap
|
|
|
|
testmap = do
|
|
|
|
g <- getStdGen
|
2014-01-03 17:46:41 +01:00
|
|
|
rawMap <- return $ parseTemplate (randoms g) (T.concat testMapTemplate2)
|
2014-01-04 14:09:42 +01:00
|
|
|
return $ listArray ((0,0),(9,1)) rawMap
|
2013-12-29 06:03:32 +01:00
|
|
|
|
|
|
|
|
2013-12-29 14:39:01 +01:00
|
|
|
parseTemplate :: [Int] -> Text -> [MapEntry]
|
|
|
|
parseTemplate (r:rs) t =
|
|
|
|
(case T.head t of
|
2013-12-29 06:03:32 +01:00
|
|
|
'~' -> (0, Water)
|
|
|
|
'S' -> (0, Sand)
|
2013-12-29 18:18:18 +01:00
|
|
|
'G' -> (fromIntegral (r `mod` 3)/2.0,Grass)
|
|
|
|
'M' -> (fromIntegral (r `mod` 3 + 2)/2.0, Mountain)
|
2013-12-29 06:03:32 +01:00
|
|
|
_ -> error "invalid template format for map"
|
2013-12-29 14:39:01 +01:00
|
|
|
):parseTemplate rs (T.tail t)
|
|
|
|
parseTemplate [] _ = error "out of randoms.."
|