115 lines
4.5 KiB
Haskell
115 lines
4.5 KiB
Haskell
module Dodge.LevelGen (generateWorldFromSeed) where
|
|
|
|
import Control.Lens
|
|
import Control.Monad.State
|
|
import Data.Foldable
|
|
import Data.Preload.Render
|
|
import Dodge.Data.GenWorld
|
|
import Dodge.Floor
|
|
import Dodge.Initialisation
|
|
import Dodge.Layout
|
|
import Dodge.Tree
|
|
import Geometry.ConvexPoly
|
|
import qualified IntMapHelp as IM
|
|
import System.Directory
|
|
import System.Random
|
|
|
|
generateWorldFromSeed :: RenderData -> Int -> IO World
|
|
generateWorldFromSeed rdata i = do
|
|
createDirectoryIfMissing True "generated/log"
|
|
writeFile "generated/log/attemptedSeeds" ""
|
|
writeFile "generated/log/treeCluster" ""
|
|
writeFile "generated/log/aGeneratedRoomLayout" ""
|
|
(roomList, bounds) <- layoutLevelFromSeed 0 i
|
|
postGenerationProcessing rdata
|
|
$! generateLevelFromRoomList roomList
|
|
$ initialWorld{_randGen = mkStdGen i}
|
|
& cWorld . cwGen . cwgRoomClipping .~ bounds
|
|
& cWorld . cwGen . cwgSeed .~ i
|
|
|
|
postGenerationProcessing :: RenderData -> GenWorld -> IO World
|
|
postGenerationProcessing _ gw = do
|
|
let w = _gwWorld gw & cWorld . cwTiles .~ (tilesFromRooms . IM.elems $ _genRooms gw)
|
|
return $ foldl' assignPushDoors w (w ^. cWorld . lWorld . doors)
|
|
|
|
assignPushDoors :: World -> Door -> World
|
|
assignPushDoors w dr = case dr ^?! drPushedBy of
|
|
PushedBy i -> w & cWorld . lWorld . doors . ix i . drPushes ?~ _drID dr
|
|
_ -> w
|
|
|
|
layoutLevelFromSeed :: Int -> Int -> IO (IM.IntMap Room, [ConvexPoly])
|
|
layoutLevelFromSeed i seed = do
|
|
let i' = i + 1
|
|
createDirectoryIfMissing True "generated/log"
|
|
putStrLnAppend "generated/log/attemptedSeeds" $
|
|
"Generating level with seed " ++ show seed
|
|
appendFile "generated/log/attemptedSeeds" "\n"
|
|
let g = mkStdGen seed
|
|
let treecluster = evalState tutRoomTree (LayVars g 0)
|
|
-- let treecluster = evalState initialRoomTree (LayVars g 0)
|
|
let labts = decomposeSelfTree $ numSelfTree $ combineTree _rmName treecluster
|
|
appendFile "generated/log/treeCluster" ("Seed: " ++ show seed ++ "\n")
|
|
putStrLn "MetaTree clusters:"
|
|
mapM_
|
|
(putStrLnAppend "generated/log/treeCluster" . smallDrawTree . fmap showIntsString)
|
|
labts
|
|
let tc = composeTree treecluster
|
|
let rmtree = inorderNumberTree tc
|
|
appendFile "generated/log/aGeneratedRoomLayout" ("Seed: " ++ show seed ++ "\n")
|
|
putStrLnAppend "generated/log/aGeneratedRoomLayout" "Room layout (compact): "
|
|
putStrLnAppend "generated/log/aGeneratedRoomLayout"
|
|
$ compactDrawTree $ fmap (show . snd) rmtree
|
|
let nameshow (r, rid) = _rmName r ++ "-" ++ show rid
|
|
putStrLnAppend "generated/log/aGeneratedRoomLayout" "Layout with room names:"
|
|
putStrLnAppend "generated/log/aGeneratedRoomLayout"
|
|
$ smallDrawTree $ fmap nameshow rmtree
|
|
mrs <- positionRoomsFromTree rmtree
|
|
case mrs of
|
|
Just (PosRooms bounds rs) -> do
|
|
putStrLnAppend "generated/log/attemptedSeeds" $
|
|
"After " ++ show i'
|
|
++ " attempt(s), Successful generation of level with seed "
|
|
++ show seed
|
|
putStrLnAppend "generated/log/attemptedSeeds"
|
|
$ show (Prelude.length rs) ++ " rooms in total"
|
|
return (IM.fromList $ map reversePair rs, bounds)
|
|
Nothing -> do
|
|
putStrLnAppend "generated/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)
|