pioneers/src/Map/Map.hs

257 lines
9.0 KiB
Haskell
Raw Normal View History

{-# 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
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
import Foreign.Marshal.Array (withArray)
import Foreign.Storable (sizeOf)
import Foreign.Ptr (Ptr, nullPtr, plusPtr)
import Render.Misc (checkError)
data TileType =
Grass
| Sand
| Water
| Mountain
deriving (Show, Eq)
type MapEntry = (
Float, -- ^ Height
TileType
)
type PlayMap = Array (Int, Int) MapEntry
lineHeight :: GLfloat
lineHeight = 0.8660254
numComponents :: Int
2014-01-04 14:09:42 +01:00
numComponents = 7
mapStride :: Stride
2014-01-04 14:09:42 +01:00
mapStride = fromIntegral (sizeOf (0.0 :: GLfloat) * numComponents)
2014-01-04 14:09:42 +01:00
bufferObjectPtr :: Integral a => a -> Ptr GLfloat
bufferObjectPtr = plusPtr (nullPtr :: Ptr GLfloat) . fromIntegral
2014-01-04 14:09:42 +01:00
mapVertexArrayDescriptor :: NumComponents -> NumComponents -> VertexArrayDescriptor GLfloat
mapVertexArrayDescriptor count' offset =
2014-01-04 14:09:42 +01:00
VertexArrayDescriptor count' Float mapStride (bufferObjectPtr offset ) --(fromIntegral numComponents * offset))
2014-01-04 14:09:42 +01:00
fgColorIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat)
fgColorIndex = (ToFloat, mapVertexArrayDescriptor 4 3) --color first
2014-01-04 14:09:42 +01:00
fgNormalIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat)
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
getMapBufferObject :: IO (BufferObject, NumArrayIndices)
getMapBufferObject = do
map' <- testmap
2014-01-04 14:09:42 +01:00
map' <- return $ P.map (*1) (generateTriangles map')
putStrLn $ P.unlines $ P.map show (prettyMap map')
len <- return $ fromIntegral $ P.length map' `div` numComponents
2014-01-03 22:31:01 +01:00
putStrLn $ P.unwords ["num verts",show len]
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)
checkError "initBuffer"
return (bo,len)
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-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
]
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]
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]
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]
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)
--TODO: calculate normals correctly!
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
]
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,z) y =
if even x then
(fromIntegral $ x `div` 2, y, fromIntegral (2 * z) * lineHeight)
else
2014-01-04 14:09:42 +01:00
(fromIntegral (x `div` 2) + 0.5, y, fromIntegral (2 * z + 1) * lineHeight)
-- if writing in ASCII-Format transpose so i,j -> y,x
-- row-minor -> row-major
testMapTemplate :: [Text]
testMapTemplate = T.transpose [
"~~~~~~~~~~~~~~~~~~~~",
"~~SSSSSSSSSSSSSS~~~~",
"~SSGGGGGGGSGSGGS~~~~",
"~SSGGGGGGMSGSGMS~~~~",
"~SGGGGGGMMMGGGS~~~S~",
"~SGGGMGMMMMMGGS~~~SS",
"~GGGGGGGGGGGGGGS~~~~",
"~SGGGGGGGGGGGGGS~~~~",
"~~SSSSGGGSSSSS~~~~~~",
"~~~~~SGGGGS~~~~~~~~~",
"~~~~SSGGGGSS~~~~~~~~",
"~~SSSGGGGGGSSSSS~~~~",
"~SSGSGSGGGSGSGGS~~~~",
"~SSGSGSGGMSGSGMS~~~~",
"~SGGMMMMGGGGGGS~~~~~",
"~SGMMMMMGGGGSSS~~~~~",
"~GGMMMMMGGGSSSSS~~~~",
"~SGGGGGGGSSSSSSS~~~~",
"~~SSSSSSSSSSSS~~~~~~",
"~~~~~~~~~~~~~~~~~~~~"
]
testMapTemplate2 :: [Text]
testMapTemplate2 = T.transpose [
2014-01-04 14:09:42 +01:00
"~~~~~~~~~~~~",
"~SSSSSSSSSS~"
]
testmap :: IO PlayMap
testmap = do
g <- getStdGen
rawMap <- return $ parseTemplate (randoms g) (T.concat testMapTemplate2)
2014-01-04 14:09:42 +01:00
return $ listArray ((0,0),(9,1)) rawMap
parseTemplate :: [Int] -> Text -> [MapEntry]
parseTemplate (r:rs) t =
(case T.head t of
'~' -> (0, Water)
'S' -> (0, Sand)
'G' -> (fromIntegral (r `mod` 3)/2.0,Grass)
'M' -> (fromIntegral (r `mod` 3 + 2)/2.0, Mountain)
_ -> error "invalid template format for map"
):parseTemplate rs (T.tail t)
parseTemplate [] _ = error "out of randoms.."