{-# 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.."
