pioneers/src/Map/Map.hs

{-# 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.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
numComponents = 7

mapStride :: Stride
mapStride = fromIntegral (sizeOf (0.0 :: GLfloat) * numComponents)

bufferObjectPtr :: Integral a => a -> Ptr GLfloat
bufferObjectPtr = plusPtr (nullPtr :: Ptr GLfloat) . fromIntegral

mapVertexArrayDescriptor :: NumComponents -> NumComponents -> VertexArrayDescriptor GLfloat
mapVertexArrayDescriptor count' offset =
   VertexArrayDescriptor count' Float mapStride (bufferObjectPtr offset ) --(fromIntegral numComponents * offset))

fgColorIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat)
fgColorIndex = (ToFloat, mapVertexArrayDescriptor 4 3)  --color first

fgNormalIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat)
fgNormalIndex = (ToFloat, mapVertexArrayDescriptor 3 4) --normal after color

fgVertexIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat)
fgVertexIndex = (ToFloat, mapVertexArrayDescriptor 3 0) --vertex after normal

getMapBufferObject :: IO (BufferObject, NumArrayIndices)
getMapBufferObject = do
        map' <- testmap
        map' <- return $ P.map (*1) (generateTriangles map')
        putStrLn $ P.unlines $ P.map show (prettyMap map')
        len <- return $ fromIntegral $ P.length map' `div` numComponents
        putStrLn $ P.unwords ["num verts",show len]
        bo <- genObjectName                     -- create a new buffer
        bindBuffer ArrayBuffer $= Just bo       -- bind buffer
        withArray map' $ \buffer ->
                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 _ = []

generateCube :: [GLfloat]
generateCube = [  -- lower plane
                  -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,
                  -- upper plane
                  -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,
                   -- left plane
                  -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,
                   -- right plane
                  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,
                   -- front plane
                  -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,
                   -- back plane
                  -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
                  ]

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
                [
                        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
                        (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 [
                "~~~~~~~~~~~~",
                "~SSSSSSSSSS~"
                ]

testmap :: IO PlayMap
testmap = do
                g <- getStdGen
                rawMap <- return $ parseTemplate (randoms g) (T.concat testMapTemplate2)
                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.."