Move toward better info display during level generation

2021-11-10 23:40:04 +00:00
parent 9aefc11e17
commit a195157e54
13 changed files with 122 additions and 118 deletions
@@ -4,34 +4,41 @@ import Dodge.Save
 import Dodge.Data
 import Dodge.Data.SoundOrigin
 import Dodge.Creature
--import Dodge.Zone
 import Dodge.Floor
 import Dodge.Layout
 import Dodge.Story
 import Dodge.WorldEvent.Cloud
 import Dodge.SoundLogic
 import Dodge.SoundLogic.LoadSound
--import Dodge.Creature.Perception
 import Geometry.Data
--import Shape.Data
--import Dodge.Render.Shape
--import Picture
--import Dodge.GameRoom
--import Geometry
+import Dodge.Room.Data

 import System.Random
+import System.Timeout
 import qualified Data.Set as S
 import qualified Data.IntMap.Strict as IM
 import qualified Data.Map as M
--import Control.Lens
--import Data.Maybe
+import Control.Monad.State

 firstWorld :: IO World
 firstWorld = do
 --    i <- randomRIO (0,5000)
-    let i = 2
+    let i = 3
    putStrLn $ "Seed for level generation: " ++ show ( i :: Int)
-    return $ generateLevelFromRoomList (levx 1) $ initialWorld {_randGen = mkStdGen i}
+    let g = mkStdGen i
+    (roomList,n) <- f g
+    putStrLn $ "Had to go through "++ show n ++ " random generators"
+    return $ generateLevelFromRoomList roomList $ initialWorld {_randGen = g}
+  where
+    f :: StdGen -> IO ([Room],Int)
+    f g = do
+        mayrs <- timeout 10000000 . return $ evalState (levx 1) g
+        case mayrs of
+            Nothing -> do
+                let i = fst $ random g
+                putStrLn $ "Timeout; trying new seed: " ++ show i
+                f (mkStdGen i)
+            Just rs -> return rs

 initialWorld :: World
 initialWorld = defaultWorld
@@ -58,16 +65,3 @@ initialWorld = defaultWorld

 testStringInit :: World -> [String]
 testStringInit _ = []
--testStringInit = mapMaybe f . IM.elems . flattenIMIMIM . _znObjects . _wallsZone
--  where
--    f dr | _wlColor dr == V4 0 1 0 1 = Just . show $ _wlLine dr
--         | otherwise = Nothing
--testStringInit _ = []
--testStringInit w = [show . length $ newSounds w]
--testStringInit w = (show . _crPos $ _creatures w IM.! 0) 
--    : (map show . _grBound . last $ sortOn _grName grs) 
--    ++ closeRooms
--  where
--    closeRooms = map _grName $ filter (pointInOrOnPolygon p . _grBound) grs
--    grs = _gameRooms w
--    p = _cameraViewFrom w