96 lines
3.6 KiB
Haskell
96 lines
3.6 KiB
Haskell
{-# 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 System.Directory
|
|
import System.Random
|
|
import Control.Lens
|
|
import Control.Monad.State
|
|
import qualified Data.IntMap.Strict as IM
|
|
|
|
generateWorldFromSeed :: Int -> IO World
|
|
generateWorldFromSeed i = do
|
|
createDirectoryIfMissing True "log"
|
|
writeFile "log/attemptedSeeds" ""
|
|
writeFile "log/treeCluster" ""
|
|
writeFile "log/aGeneratedRoomLayout" ""
|
|
(roomList,bounds) <- layoutLevelFromSeed 0 i
|
|
return $ saveLevelStartSlot
|
|
$ generateLevelFromRoomList roomList initialWorld{_randGen=mkStdGen i}
|
|
& roomClipping .~ bounds
|
|
|
|
layoutLevelFromSeed :: Int -> Int -> IO (IM.IntMap Room,[ConvexPoly])
|
|
layoutLevelFromSeed i seed = do
|
|
let i' = i + 1
|
|
putStrLnAppend "log/attemptedSeeds" $ "Generating level with seed " ++ show seed
|
|
appendFile "log/attemptedSeeds" "\n"
|
|
let g = mkStdGen seed
|
|
let treecluster = evalState initialRoomTree (g,0)
|
|
let labts = decomposeSelfTree $ numSelfTree $ combineTree _rmName treecluster
|
|
appendFile "log/treeCluster" ("Seed: "++ show seed ++ "\n")
|
|
mapM_ (putStrLnAppend "log/treeCluster" . smallDrawTree . fmap showIntsString) labts
|
|
let tc = composeTree treecluster
|
|
let rmtree = inorderNumberTree tc
|
|
putStrLn "Room layout (compact): "
|
|
putStrLn $ compactDrawTree $ fmap (show . snd) rmtree
|
|
let nameshow (r,rid) = _rmName r ++ "-" ++ show rid
|
|
appendFile "log/aGeneratedRoomLayout" ("Seed: "++ show seed)
|
|
putStrLnAppend "log/aGeneratedRoomLayout" "Layout with room names:"
|
|
putStrLnAppend "log/aGeneratedRoomLayout" $ smallDrawTree $ fmap nameshow rmtree
|
|
mrs <- positionRoomsFromTree rmtree
|
|
case mrs of
|
|
Just (PosRooms bounds rs) -> do
|
|
putStrLnAppend "log/attemptedSeeds" $ "After " ++ show i'
|
|
++ " attempt(s), Successful generation of level with seed "
|
|
++ show seed
|
|
putStrLnAppend "log/attemptedSeeds" $ show (Prelude.length rs) ++ " rooms in total"
|
|
return (IM.fromList $ map reversePair rs , bounds)
|
|
Nothing -> do
|
|
putStrLnAppend "log/attemptedSeeds" $ "Level generation with seed " ++ show seed ++ " failed: "
|
|
let (seed',_) = random g
|
|
layoutLevelFromSeed i' seed'
|
|
|
|
putStrLnAppend :: FilePath -> String -> IO ()
|
|
putStrLnAppend fp str = appendFile fp (str ++ "\n") >> putStrLn str
|
|
|
|
reversePair :: (a,b) -> (b,a)
|
|
reversePair (a,b) = (b,a)
|
|
|
|
compactDrawTree :: Tree String -> String
|
|
compactDrawTree = unlines . compactDraw
|
|
|
|
smallDrawTree :: Tree String -> String
|
|
smallDrawTree = 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)
|
|
|
|
compactDraw' :: Tree String -> [String]
|
|
compactDraw' (Node x [Node y ts]) = lines x ++ ["|"] ++ compactDraw' (Node 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)
|