{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
module Dodge.LevelGen where
import Dodge.Data
import Dodge.Floor
import Dodge.Save
import Dodge.Layout
import Dodge.Initialisation
--import Dodge.RandomHelp
--import Dodge.LevelGen.Data
import Dodge.Tree
import Geometry.ConvexPoly
--import Dodge.LevelGen.LevelStructure

import Data.Tree
import System.Random
import Control.Lens
import Control.Monad.State
import qualified Data.IntMap.Strict as IM

generateWorldFromSeed :: Int -> IO World
generateWorldFromSeed i = do
    writeFile "attemptedSeeds" ""
    (roomList,bounds) <- layoutLevelFromSeed 0 i
    return $ saveLevelStartSlot $ _gWorld (generateLevelFromRoomList roomList 
         initialWorld{_randGen=mkStdGen i})
        & roomClipping .~ bounds

layoutLevelFromSeed :: Int -> Int -> IO (IM.IntMap Room,[ConvexPoly])
layoutLevelFromSeed i seed = do
    let i' = i + 1
    putStrLn $ "Generating level with seed " ++ show seed
    appendFile "attemptedSeeds" $ show seed ++ "\n"
    let g = mkStdGen seed
    let treecluster = evalState initialRoomTree g
    putStrLn "Room cluster layout:"
    putStrLn $ drawTreeSubLabelling $ fmap snd treecluster
    let rmtree = inorderNumberTree $ expandTree $ fmap fst treecluster
    putStrLn "Room layout (compact): "
    putStrLn $ compactDrawTree $ fmap (show . snd) rmtree
    let nameshow (r,rid) = _rmName r ++ "-" ++ show rid
    appendFile "aGeneratedRoomLayout" $ drawTree $ fmap nameshow rmtree
    putStrLn "Layout with room names (also written to aGeneratedRoomLayout):"
    mrs <- positionRoomsFromTree rmtree
    case mrs of
        Just (PosRooms bounds rs) -> do
            putStrLn $ "After " ++ show i' 
                ++ " attempt(s), Successful generation of level with seed " 
                ++ show seed
            --return (fmap setLastLinkToUsed rs)
            putStrLn $ show (Prelude.length rs) ++ " rooms in total"
            return (IM.fromList $ map reversePair rs , bounds)
        Nothing -> do
            putStr $ "Level generation with seed " ++ show seed ++ " failed: "
            let (seed',_) = random g
            layoutLevelFromSeed i' seed'

drawTreeSubLabelling :: Tree TreeSubLabelling -> String
drawTreeSubLabelling t = drawTree (fmap _topLabel t)
    ++ concatMap f (flatten t)
  where
    f (TreeSubLabelling _ Nothing) = ""
    f (TreeSubLabelling l (Just t')) = l ++ ":\n" ++ drawTreeSubLabelling t'

reversePair :: (a,b) -> (b,a)
reversePair (a,b) = (b,a)

compactDrawTree :: Tree String -> String
compactDrawTree = unlines . compactDraw

compactDraw :: Tree String -> [String]
compactDraw (Node x [Node y ts]) = compactDraw (Node (x++","++y) ts)
compactDraw (Node x ts0) = lines x ++ drawSubTrees ts0
  where
    drawSubTrees [] = []
    drawSubTrees [t] =
        "|" : compactDraw t
    drawSubTrees (t:ts) =
        "|" : shift "+- " "|  " (compactDraw t) ++ drawSubTrees ts
    shift first other = zipWith (++) (first : repeat other)