{-# LANGUAGE OverloadedStrings, BangPatterns #-} 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) import Linear 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 = 10 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 ((fromIntegral offset)*sizeOf (0 :: GLfloat)) ) --(fromIntegral numComponents * offset)) fgColorIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat) fgColorIndex = (ToFloat, mapVertexArrayDescriptor 4 0) --color first fgNormalIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat) fgNormalIndex = (ToFloat, mapVertexArrayDescriptor 3 4) --normal after color fgVertexIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat) fgVertexIndex = (ToFloat, mapVertexArrayDescriptor 3 7) --vertex after normal getMapBufferObject :: IO (BufferObject, NumArrayIndices) getMapBufferObject = do map' <- testmap ! map' <- return $ generateTriangles map' --putStrLn $ P.unlines $ P.map show (prettyMap map') len <- return $ fromIntegral $ P.length map' `div` numComponents putStrLn $ P.unwords ["num verts in map:",show len] bo <- genObjectName -- create a new buffer bindBuffer ArrayBuffer $= Just bo -- bind buffer withArray map' $ \buffer -> bufferData ArrayBuffer $= (fromIntegral $ sizeOf (0 :: GLfloat)*P.length 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 _ = [] 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) (V3 vx vy vz) = coordLookup (x,y) $ heightLookup map' (x,y) (V3 nx ny nz) = normalLookup map' x y --TODO: calculate normals correctly! in [ cr, cg, cb, 1.0, -- RGBA Color nx, ny, nz, -- 3 Normal vx, vy, vz -- 3 Vertex ] normalLookup :: PlayMap -> Int -> Int -> V3 GLfloat normalLookup map' x y = normalize $ normN + normNE + normSE + normS + normSW + normNW where --Face Normals normN = cross (vNE-vC) (vNW-vC) normNE = cross (vE -vC) (vNE-vC) normSE = cross (vSE-vC) (vE -vC) normS = cross (vSW-vC) (vSE-vC) normSW = cross (vW -vC) (vSW-vC) normNW = cross (vNW-vC) (vW -vC) --Vertex Normals vC = coordLookup (x,y) $ heightLookup map' (x,y) --TODO: kill guards with eo vNW | even x = coordLookup (x-1,y-1) $ heightLookup map' (x-1,y-1) | otherwise = coordLookup (x-1,y ) $ heightLookup map' (x-1,y ) vNE | even x = coordLookup (x+1,y-1) $ heightLookup map' (x+1,y-1) | otherwise = coordLookup (x+1,y ) $ heightLookup map' (x+1,y ) vE | even x = coordLookup (x+2,y ) $ heightLookup map' (x+2,y ) | otherwise = coordLookup (x+2,y ) $ heightLookup map' (x+2,y ) vSE | even x = coordLookup (x+1,y ) $ heightLookup map' (x+1,y ) | otherwise = coordLookup (x+1,y+1) $ heightLookup map' (x+1,y+1) vSW | even x = coordLookup (x-1,y ) $ heightLookup map' (x-1,y ) | otherwise = coordLookup (x-1,y+1) $ heightLookup map' (x-1,y+1) vW | even x = coordLookup (x-2,y ) $ heightLookup map' (x-2,y ) | otherwise = coordLookup (x-2,y ) $ heightLookup map' (x-2,y ) eo = if even x then 1 else -1 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 -> V3 GLfloat coordLookup (x,z) y = if even x then V3 (fromIntegral $ x `div` 2) y (fromIntegral (2 * z) * lineHeight) else V3 (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 = repText 2 $ T.transpose [ "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~", "~~~SSSSSSSSSSSSSS~~~~~SSSSSSSSSSSSSS~~~~", "~~SSGGGGGGGSGSGGS~~~~SSGGGGGGGSGSGGS~~~~", "~~SSGGGGGGMSGSGGS~~~~SSGGGGGGMSGSGGS~~~~", "~~SGGGGGGMMMGGGS~~~S~SGGGGGGMMMGGGS~~~S~", "~~SGGGMGMMMMMGGS~~~SSSGGGMGMMMMMGGS~~~SS", "~~GGGGGGGGGGGGGGS~~~~GGGGGGGGGGGGGGS~~~~", "~~SGGGGGGGGGGGGGS~~~~SGGGGGGGGGGGGGS~~~~", "~~~SSSSGGGSSSSS~~~~~~~SSSSGGGSSSSS~~~~~~", "~~~~~~SGGGGS~~~~~~~~~~~~~SGGGGS~~~~~~~~~", "~~~~~SSGGGGSS~~~~~~~~~~~SSGGGGSS~~~~~~~~", "~~~SSSGGGGGGSSSSS~~~~~SSSGGGGGGSSSSS~~~~", "~~SSGSGSGGGSGSGGS~~~~SSGSGSGGGSGSGGS~~~~", "~~SSGSGSGGMSGSGMS~~~~SSGSGSGMMMMMSSS~~~~", "~~SGGMMMMGGGGGGS~~~~~SGGGGGGMMMMMSS~~~~~", "~~SGMMMMMGGGGSSS~~~~~SGGGGGGMMMMMSS~~~~~", "~~GGMMMMMGGGSSSSS~~~~GGGGGGGGGGSSSSS~~~~", "~~SGGGGGGGSSSSSSS~~~~SGGGGGGGSSSSSSS~~~~", "~~~SSSSSSSSSSSS~~~~~~~SSSSSSSSSSSS~~~~~~", "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" ] repText :: Int -> [a] -> [a] repText a (t:[]) = P.replicate a t repText a ts = P.concat $ P.map (repText' a) ts where repText' :: Int -> a -> [a] repText' a x = repText a [x] testMapTemplate2 :: [Text] testMapTemplate2 = T.transpose [ "~~~~~~~~~~~~" ] testmap :: IO PlayMap testmap = do g <- getStdGen rawMap <- return $ parseTemplate (randoms g) (T.concat testMapTemplate) return $ listArray ((0,0),(79,19)) rawMap testmap2 :: IO PlayMap testmap2 = do g <- getStdGen rawMap <- return $ parseTemplate (randoms g) (T.concat testMapTemplate2) return $ listArray ((0,0),(9,0)) rawMap parseTemplate :: [Int] -> Text -> [MapEntry] parseTemplate (r:rs) t = (case T.head t of '~' -> (0, Water) 'S' -> (0, Sand) 'G' -> (fromIntegral (r `mod` 10)/10.0,Grass) 'M' -> (fromIntegral ((r `mod` 10) + 20)/10.0, Mountain) _ -> error "invalid template format for map" ):parseTemplate rs (T.tail t) parseTemplate [] _ = error "out of randoms.."