67 lines
2.3 KiB
Haskell
67 lines
2.3 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 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
|
|
roomList <- layoutLevelFromSeed 0 i
|
|
return $ saveLevelStartSlot $ _gWorld $ generateLevelFromRoomList roomList
|
|
initialWorld{_randGen=mkStdGen i}
|
|
|
|
layoutLevelFromSeed :: Int -> Int -> IO (IM.IntMap Room)
|
|
layoutLevelFromSeed i seed = do
|
|
let i' = i + 1
|
|
putStrLn $ "Generating level with seed " ++ show seed
|
|
let g = mkStdGen seed
|
|
let rmtree = inorderNumberTree $ evalState initialRoomTree g
|
|
putStrLn "Abstract layout: "
|
|
putStrLn $ compactDrawTree $ fmap (show . snd) rmtree
|
|
let nameshow (r,rid) = _rmName r ++ "-" ++ show rid
|
|
writeFile "aGeneratedRoomLayout" $ drawTree $ fmap nameshow rmtree
|
|
putStrLn "Layout with room names written to aGeneratedRoomLayout"
|
|
mrs <- positionRoomsFromTree rmtree
|
|
case mrs of
|
|
Just 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
|
|
Nothing -> do
|
|
putStr $ "Level generation with seed " ++ show seed ++ " failed: "
|
|
let (seed',_) = random g
|
|
layoutLevelFromSeed i' seed'
|
|
|
|
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)
|