path: root/Final.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
module Main where

import Graphics.Rendering.OpenGL as GL
import Graphics.UI.SDL.Image as SDLImg
import Graphics.UI.SDL as SDL
import Graphics.SDL.SDLHelp
import Graphics.Glyph.Util
import Graphics.Glyph.ExtendedGL
import Control.Monad

import Graphics.Glyph.BufferBuilder
import Graphics.Glyph.ObjLoader

import qualified Data.Map as Map
import Data.Word
import Data.Array
import Data.Array.IO

import Data.Sequence as Seq
import Prelude as P

import Debug.Trace
import Data.Bits

import TileShow
import Resources
import System.Random
import Debug.Trace



data TileType = Forest | Beach | Water | Grass | Jungle | Mountains | 
                Tundra | Unknown deriving (Enum,Eq)
$(makeShow ''TileType)


data Tile = Tile {
    tileType :: TileType,
    elevation :: Int
} deriving Show

buildArray :: SDL.Surface -> SDL.Surface -> IO (Array (Int,Int) Tile)
buildArray terrain height = 
    let w = min (SDL.surfaceGetWidth terrain) $ SDL.surfaceGetWidth height
        h = min (SDL.surfaceGetHeight terrain) $ SDL.surfaceGetHeight height
        conv (x,y) = 
                let terrainVal = fromIntegral $ getPixelUnsafe x y terrain
                    sumit word =
                                ((word `shiftR` 8) .&. 0xFF) +
                                ((word `shiftR`16) .&. 0xFF) +
                                ((word `shiftR`24) .&. 0xFF)
                    heightVal  = (fromIntegral.sumit) (getPixelUnsafe x y height)
                    terrainVal' = Map.findWithDefault Main.Unknown terrainVal tileMap in
                Tile terrainVal' heightVal
        list = map conv [(x,y) | x <- [0..w-1], y <- [0..h-1]]

        in do
            putStrLn $ show (head list)
            return $ listArray ((0,0),(w-1,h-1)) list

-- colors regions of water in the array
colorArray :: Array (Int,Int) Tile -> IO (IOArray (Int,Int) Int)
colorArray marr = do
    let pollseq (Seq.viewl -> (head :< tail)) = (head,tail)
    let bnd@(_,(w,h)) = bounds marr
    ret <- newArray bnd 0
    let myfunction place = do
            val <- readArray ret place
            case marr ! place of
                (Tile Water _) -> return $ val==0
                _ -> return False
    let floodfill :: (Int,Int) -> ((Int,Int) -> IO Bool) -> Int -> IO ()
        floodfill start func' val = do
            let func t@(x,y) = if not (x <= w && x >= 0 && y <= h && y >= 0) then return False else func' t
            _ <- untilM2 (return . Seq.null) (Seq.singleton start) $ \queue -> do
                    let (head',tail') = pollseq queue
                    bool <- func head'
                    if not bool then return tail' else do
                        (_,tail2) <- untilM2 (liftM not . func . fst) (head',tail') $ \((x,y),queue') -> do
                            (ret <!> (x,y)) $= val
                            return ((x+1,y),queue' |> (x,y-1) |> (x,y+1))
                        (_,tail3) <- untilM2 (liftM not . func . fst) (head',tail2) $ \((x,y),queue') -> do
                            (ret <!> (x,y)) $= val
                            return ((x-1,y), queue' |> (x,y-1) |> (x,y+1))
                        return tail3
            return ()
    foldM_ (\val place -> do
        bool <- myfunction place
        if bool then do
            floodfill place myfunction val
            return $ val+1
            else return val
        ) 1 [(x,y) | x <- [0..w], y <- [0..h]]
    return ret

-- elevation quad is corner verticices
getWaterQuads :: Array (Int,Int) Tile -> IOArray (Int,Int) Int -> IO ( BuilderM GLfloat () )
getWaterQuads marr arr = do
    let (_,(w,h)) = bounds marr
    let elevationCacheIO :: IO (Map.Map Int (Int,Int,Int,Int,Int))
        elevationCacheIO = do
            let tup = (min,max,max,min,min)
            foldM (\themap (x,y) -> do
                    bodyID <- readArray arr (x,y)
                    if bodyID == 0 then return themap else do
                        let valid (x,y) = x >= 0 && x <= w && y >= 0 && y <= h
                        let neighbors (x,y) = P.filter valid $ map (zipWithT2 (+) (x,y))
                                                [      (1,0),       
                                                 (0,1),      (0,-1),
                                                       (-1,0)      ]
                        let toelev x = 
                             let tile = marr ! x in
                             (tileType tile == Water) ? 1000000000000 $ elevation tile
                        let elev = minimum $ map toelev (neighbors (x,y))
                        let newmap = Map.insertWith (\old->
                                            zipWithT5 (P.$) (zipWithT5 (P.$) tup old)
                                        ) bodyID (elev,x,y,x,y) themap
                        return newmap
                ) (Map.empty::Map.Map Int (Int,Int,Int,Int,Int)) [(x,y) | x <- [0..w], y <- [0..h]]

    dat <- (liftM Map.toList elevationCacheIO)
    return . sequence_ $ for dat $ \(_, (elev,maxx,maxy,minx,miny)) -> do
        let mxx = fromIntegral maxx + 1
            mnx = fromIntegral minx - 1
            mxy = fromIntegral maxy + 1
            mny = fromIntegral miny - 1
            relev = fromIntegral elev / 10 in
            mapM_ bVertex3 $ trianglesFromQuads
                [(mxx,relev,mxy),
                 (mxx,relev,mny),
                 (mnx,relev,mny),
                 (mnx,relev,mxy)] 


printArray :: Array (Int,Int) Tile -> IO ()
printArray arr = do
    let (_,(w,h)) = bounds arr
    putStrLn $ "w=" ++! (w+1)
    putStrLn $ "h=" ++! (h+1)
    forM_ [0..h] $ \y -> do
        forM_ [0..w] $ \x -> do
            let next = arr ! (x,y)
            putStr $ (show $ tileType next) 
        putStr "    "
        forM_ [0..w] $ \x -> do
            let next = arr ! (x,y)
            putStr $ (elevShow $ elevation next) 
        putStrLn ""
    where elevShow x = 
            let len = P.length elevMap
                nx = x `div` 5 in
            if nx >= len then "=" else [elevMap !! nx]
          elevMap = "`.,-~*<:!;%&#@0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

printShowArray arr = do
    (_,(w,h)) <- getBounds arr
    putStrLn $ "w=" ++! (w+1)
    putStrLn $ "h=" ++! (h+1)
    forM_ [0..h] $ \y -> do
        forM_ [0..w] $ \x -> do
            next <- readArray arr (x,y)
            putStr $ (show $ next) 
        putStrLn ""

toColor :: TileType -> (GLfloat,GLfloat,GLfloat,GLfloat)
toColor Tundra = (0.5,0.5,0.5,1.0)
toColor Mountains = (0.5,0.4,0.03,1.0)
toColor Grass = (0,0.3,0.0,1.0)
toColor Jungle = (0,1.0,0.0,1.0)
toColor Forest = (0,0.2,0.0,1.0)
toColor Beach = (0.7,0.7,0.6,1.0)
toColor Water = (0,0,1.0,1.0)

tileMap :: Map.Map Word32 TileType
tileMap =
    let c = rgbToWord in
    Map.insert    (c 100 100 100) Tundra  $
    Map.insert    (c 128 100 20) Mountains  $
    Map.insert    (c 0 100 0) Grass  $
    Map.insert    (c 0 255 0) Jungle $
    Map.insert    (c 0 50 0) Forest $
    Map.insert    (c 255 255 255) Beach  $
    Map.singleton (c 0 0 255) Water

createBuilder :: Array (Int,Int) Tile -> BuilderM GLfloat ()
createBuilder arr = do
    let (_,(w,h)) = bounds arr

    let lst = concatMap (\(x,y) ->
            let g (x',z',w') = (x', fromIntegral (elevation $ arr ! (x',z')) / 10.0, z', w') in

            [g (x,  y  ,1::Int),
             g (x-1,y  ,1),
             g (x-1,y-1,1),
             g (x,  y-1,1)] )

            [(x,y) | x <- [1..w], y <- [1..h]]

    inferingNormals $ do
        forM_ (trianglesFromQuads lst) $ \(x,y,z,_) -> do
            let f = fromIntegral
            let bUseTexture a = bColor4 (0,0,0,f a)
            -- TODO un hardcode these
            bUseTexture $ fromEnum (tileType $ arr ! (x,z))
            bTexture2 (f x / 10.0, f z / 10.0)
            bVertex3 (f x, y,f z)
            
createLocations :: Array (Int,Int) Tile -> StdGen -> Int -> TileType -> MonadPlusBuilder (Seq.Seq GLfloat) ()
createLocations arr gen density typ = do
    let (_,(w,h)) = bounds arr
    let getElev x y = if x >= w || y >= h || x < 0 || y < 0 then 0 else fromIntegral (elevation $ arr ! (x,y)) /10.0

    let run :: [Int] -> (Int,Int) -> MonadPlusBuilder ( Seq.Seq GLfloat ) [Int]
        run rs (x,y) = do
            let ((_:he), t) = P.splitAt (head rs `mod` density + 1) rs
            let signum' = floor.signum

            when (isType x y typ) $ do
                forM_ he $ \rand -> do
                    let (a',b',c) = toTup rand
                    let (a,b) = (f a', f b')
                    let [sx,sy,sz,rot,noise] = (P.take 5 $ randomRs (0.0,1.0) $ mkStdGen c)

                    let elev = getElev x y
                    let elev_dx = getElev (x + signum' a) y
                    let elev_dy = getElev x (y + signum' b)
                    let realelev =
                         ((elev * (1-abs a) + elev_dx * (abs a)) +
                          (elev * (1-abs b) + elev_dy * (abs b))) / 2.0

                    when (elev_dx > 0 && elev_dy > 0) $
                            plusM $ Seq.fromList [
                                    -- translation
                                    fromIntegral x+a,realelev,fromIntegral y+b,
                                    -- scale
                                    sx+0.5,sy+0.5,sz+0.5,
                                    -- rotation
                                    sin (rot*6.4), cos(rot*6.4),
                                    -- noise
                                    noise*6.4
                                ]
            return t

    foldM_ run (randoms gen) [(x,y) | x <- [1..w], y <- [1..h]]

    return ()
    where isType x y t =
            (tileType $ arr ! (x,y)) == t
          f x = (fromIntegral x - 128) / 128 * (sqrt 2 / 2)
          toTup x = ( (x .&. 0xFF),
                      (x `shiftR` 8) .&. 0xFF,
                      (x `shiftR` 16) .&. 0xFF)
        

main :: IO ()
main = do
    putStrLn "Loading..."
    terrain <- SDLImg.load "terrain.png"
    height <- SDLImg.load "height.png"
    putStrLn "Done Loading ..."

    arr <- buildArray terrain height
    putStrLn "Array Built"
    printArray arr
    coloredArr <- colorArray arr
    printShowArray coloredArr

    surface <- simpleStartup "Spectical" (640,480)
    stgen <- newStdGen
    stgen2 <- newStdGen

--    (log',file) <- loadObjFile "tree.obj"
--    mapM_ putStrLn log'

    let !forestLocations = runMonadPlusBuilder $ createLocations arr stgen 7 Forest
    let !jungleLocations = runMonadPlusBuilder $ createLocations arr stgen2 2 Jungle

    water <- getWaterQuads arr coloredArr
--  putStrLn $ "ForestLocations :" ++! forestLocations
    makeResources surface (createBuilder arr) forestLocations jungleLocations water
        >>= startPipeline reshape eventHandle displayHandle updateHandle;