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