justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Cleanup

Browse Source
This commit is contained in:
justin
2025-10-04 12:30:03 +01:00
parent 993f00ada1
commit b3924fb8b8
1 changed files with 20 additions and 15 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/LevelGen.hs
+20 -15
View File
@@ -1,13 +1,13 @@
module Dodge.LevelGen (generateWorldFromSeed) where
import Dodge.Layout
import Data.Preload.Render
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
@@ -17,20 +17,19 @@ import System.Random
generateWorldFromSeed :: RenderData -> Int -> IO World
generateWorldFromSeed rdata i = do
createDirectoryIfMissing True "generated/log"
-- createDirectoryIfMissing True "generated/graph"
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
$! 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
let w = w' & cWorld . cwTiles .~ (tilesFromRooms . IM.elems $ _genRooms gw)
let w = _gwWorld gw & cWorld . cwTiles .~ (tilesFromRooms . IM.elems $ _genRooms gw)
return $ foldl' assignPushDoors w (w ^. cWorld . lWorld . doors)
assignPushDoors :: World -> Door -> World
@@ -42,24 +41,28 @@ 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
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 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)
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
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
putStrLnAppend "generated/log/aGeneratedRoomLayout"
$ smallDrawTree $ fmap nameshow rmtree
mrs <- positionRoomsFromTree rmtree
case mrs of
Just (PosRooms bounds rs) -> do
@@ -67,10 +70,12 @@ layoutLevelFromSeed i seed = do
"After " ++ show i'
++ " attempt(s), Successful generation of level with seed "
++ show seed
putStrLnAppend "generated/log/attemptedSeeds" $ show (Prelude.length rs) ++ " rooms in total"
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: "
putStrLnAppend "generated/log/attemptedSeeds"
$ "Level generation with seed " ++ show seed ++ " failed: "
let (seed', _) = random g
layoutLevelFromSeed i' seed'