109 lines
4.1 KiB
Haskell
109 lines
4.1 KiB
Haskell
module Dodge.LevelGen where
|
|
|
|
import Control.Lens
|
|
import Control.Monad.State
|
|
import Data.Foldable
|
|
import qualified Data.Text.IO as TIO
|
|
import Dodge.Combine.Graph
|
|
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 :: Int -> IO World
|
|
generateWorldFromSeed i = do
|
|
createDirectoryIfMissing True "log"
|
|
createDirectoryIfMissing True "graph"
|
|
writeFile "log/attemptedSeeds" ""
|
|
writeFile "log/treeCluster" ""
|
|
writeFile "log/aGeneratedRoomLayout" ""
|
|
generateGraphs
|
|
(roomList, bounds) <- layoutLevelFromSeed 0 i
|
|
return $!
|
|
postGenerationProcessing $!
|
|
_gwWorld (generateLevelFromRoomList roomList initialWorld{_randGen = mkStdGen i})
|
|
& cWorld . cwGen . cwgRoomClipping .~ bounds
|
|
& cWorld . cwGen . cwgSeed .~ i
|
|
|
|
postGenerationProcessing :: World -> World
|
|
postGenerationProcessing w = foldl' assignPushDoors w (w ^. cWorld . lWorld . doors)
|
|
|
|
generateGraphs :: IO ()
|
|
generateGraphs = TIO.writeFile "graph/itemCombinations.gv" combinationsDotGraph
|
|
|
|
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
|
|
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)
|