Move toward better info display during level generation

src/Dodge/Data.hs

@@ -82,7 +82,6 @@ data World = World
     , _pathGraph            :: ~(Gr Point2 Float)
     , _pathGraphP           :: ~[(Point2,Point2)]
     , _pathPoints           :: ~(IM.IntMap (IM.IntMap [(Int,Point2)]))
-    , _savedWorlds          :: M.Map SaveSlot World
     , _menuLayers           :: [ScreenLayer]
     , _worldFlags           :: S.Set WorldFlag
     , _carteDisplay         :: !Bool
@@ -94,16 +93,17 @@ data World = World
     , _closeActiveObjects   :: [Either FloorItem Button]
     , _seenLocations        :: IM.IntMap (World -> Point2,String)
     , _selLocation          :: Int
-    , _keyConfig            :: KeyConfigSDL
-    , _config               :: Configuration
     , _sideEffects          :: World -> IO World
     , _inventoryMode        :: InventoryMode
     , _lClickHammer         :: HammerPosition
     , _radDistortion        :: [(Point2,Point2,Point2,Float)]
-    , _gameRooms            :: [GameRoom]
-    , _preloadData          :: PreloadData
-    , _frameClock           :: Int
     , _worldBounds          :: Bounds
+    , _gameRooms            :: [GameRoom]
+    , _keyConfig            :: KeyConfigSDL
+    , _config               :: Configuration
+    , _preloadData          :: PreloadData
+    , _savedWorlds          :: M.Map SaveSlot World
+    , _frameClock           :: Int
     }
 data SaveSlot = QuicksaveSlot | LevelStartSlot
   deriving (Eq,Ord)

src/Dodge/Floor.hs

@@ -22,6 +22,7 @@ import Dodge.Layout.Tree.Shift
 import Dodge.Creature
 import Dodge.LevelGen.Data
 import Dodge.Item.Weapon.Launcher
+import MonadHelp
 
 import Control.Lens
 import Control.Monad.State
@@ -34,21 +35,18 @@ initialRoomTree = do
     let t' = padCorridors struct
         t = treeFromTrunk 
             [[StartRoom]
+            ,[SpecificRoom spawnerRoom]
             ,[Corridor]
             ,[Corridor]
-            ,[SpecificRoom $ fmap connectRoom pistolerRoom]
             ,[Corridor]
             ,[Corridor]
---            ,[Corridor]
---            ,[Corridor]
---            ,[Corridor]
             ,[SpecificRoom $ return $ connectRoom lasTunnel ]
             ,[Corridor]
             ,[SpecificRoom $ fmap connectRoom slowDoorRoom ]
             ,[Corridor]
             ,[Corridor]
             ,[Corridor]
-            ,[SpecificRoom roomCCrits]
+            ,[SpecificRoom $ fmap connectRoom roomCCrits]
             ,[Corridor]
             ,[AirlockAno]
             ,[Corridor]
@@ -99,5 +97,7 @@ initialRoomTree = do
             t'
     shiftExpandTree . expandTreeBy id <$> mapM annoToRoomTree t
 
-levx :: RandomGen g => Int -> State g [Room]
+levx :: RandomGen g => Int -> State g ([Room] , Int)
-levx _ = untilJust initialRoomTree
+levx _ = untilJustCount initialRoomTree
+
+        

src/Dodge/Initialisation.hs

@@ -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.Room.Data
---import Dodge.Render.Shape
---import Picture
---import Dodge.GameRoom
---import Geometry
 
 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 Control.Monad.State
---import Data.Maybe
 
 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

src/Dodge/Item/Weapon/TriggerType.hs

@@ -48,6 +48,7 @@ import Dodge.Default
 import Sound.Data
 import Geometry
 import Geometry.Vector3D
+--import Data.Preload
 
 import System.Random
 import Control.Lens

src/Dodge/Layout.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TupleSections #-}
+--{-# LANGUAGE TupleSections #-}
 module Dodge.Layout 
     where
 import Dodge.Data
@@ -27,7 +27,7 @@ import Polyhedra
 import Polyhedra.Data
 
 import Data.List (nubBy)
-import Control.Monad.State
+--import Control.Monad.State
 import Control.Lens
 import System.Random
 import Data.Tree
@@ -37,7 +37,7 @@ import Data.Foldable
 import qualified Control.Foldl as L
 import Data.Maybe
 
-generateLevelFromRoomList :: State StdGen [Room] -> World -> World
+generateLevelFromRoomList :: [Room] -> World -> World
 generateLevelFromRoomList gr w 
     = initWallZoning 
     . setupWorldBounds
@@ -51,7 +51,7 @@ generateLevelFromRoomList gr w
   where
     path = pairsToGraph dist pairPath
     pairPath = concatMap _rmPath rs
-    rs = zipWith addTile zs . evalState gr $ _randGen w
+    rs = zipWith addTile zs gr
     zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w
 
 doRoomPlacements :: World -> Room -> World

src/Dodge/Layout/Tree/Shift.hs

@@ -24,14 +24,14 @@ shiftRoomTreeSearchAll
     -> [[Room]]
 shiftRoomTreeSearchAll _ Empty = [[]]
 shiftRoomTreeSearchAll bs (Node r ts :<| tseq)
-    | roomIsClipping = [] -- this is called too often--might get memoized?
+--    | roomIsClipping = [] -- this is called too often--might get memoized?
-    | otherwise = case ts of
+--    | otherwise = case ts of
-        [] -> (r :) <$> shiftRoomTreeSearchAll newBounds tseq
-        (s:ss) -> concatMap (\l -> shiftRoomTreeSearchAll bs (Node (useLink l) ss <| (tseq |> f l s))) ls
---    = case ts of
---        [] | roomIsClipping -> []
 --        [] -> (r :) <$> shiftRoomTreeSearchAll newBounds tseq
 --        (s:ss) -> concatMap (\l -> shiftRoomTreeSearchAll bs (Node (useLink l) ss <| (tseq |> f l s))) ls
+    = case ts of
+        [] | roomIsClipping -> []
+        [] -> (r :) <$> shiftRoomTreeSearchAll newBounds tseq
+        (s:ss) -> concatMap (\l -> shiftRoomTreeSearchAll bs (Node (useLink l) ss <| (tseq |> f l s))) ls
   where
     convexBounds = map pointsToPoly $ _rmBound r
     ls = init $ _rmLinks r

src/Dodge/Menu.hs

@@ -12,14 +12,15 @@ import Dodge.Config.Data
 import Dodge.Config.Update
 import SDL
 import SDL.Internal.Numbered
-import Dodge.Layout
+--import Dodge.Layout
-import Dodge.Floor
+--import Dodge.Floor
 import Dodge.Initialisation
 import Preload.Update
 import Dodge.Base.Window
 import Dodge.SoundLogic
 
 import Control.Lens
+--import Control.Monad.State
 optionMenu :: ScreenLayer
 optionMenu = OptionScreen
     { _scTitle = const "OPTIONS"
@@ -159,13 +160,9 @@ pauseMenuOptions =
 startNewGame :: World -> Maybe World
 startNewGame w = Just $ w
     & menuLayers .~ [WaitScreen (const "GENERATING...") 1]
-    & worldEvents .~ const aNewGame
+--    & worldEvents .~ const aNewGame
-  where
+    & sideEffects .~ const (firstWorld <&> keyConfig .~ _keyConfig w <&> config .~ _config w
-    aNewGame :: World
+        <&> preloadData .~ _preloadData w) -- this kills save games etc...
-    aNewGame = updateFramebufferSize $ generateLevelFromRoomList (levx 1) $ initialWorld 
-        & randGen .~ _randGen w
-        & config .~ _config w
-        & preloadData .~ _preloadData w
 
 -- | hacky
 scodeToChar :: Scancode -> Char

src/Dodge/Room.hs

@@ -34,26 +34,22 @@ import System.Random
 import Data.Tree
 import Data.Bifunctor
 
-roomC :: Float -> Float -> Room
+roomC :: RandomGen g => Float -> Float -> State g Room
-roomC x y = defaultRoom
+roomC w h = do
-    { _rmPolys = [rectNSWE y 0 0 x]
+    wl <- takeOne 
-    , _rmLinks = lnks
+            [ sPS (V2 0 0) 0 $ PutWall (rectNSWE (h-60) 0 (w/2-10) (w/2+10)) defaultCrystalWall
-    , _rmPath  = pth
+            , windowLine (V2 (w/2) 0) (V2 (w/2) (h-60))
-    , _rmPS    = [windowLine (V2 (x/2) 0) (V2 (x/2) (y-60))
+            ]
-                 ]
+    changeLinkFrom fromCond $ roomRectAutoLinks w h
-    , _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
+        & rmPS %~ (wl : )
-    }
+        & rmRandPSs .~ [farside]
-  where 
+  where
-    lnks = map (first toV2)
+    fromCond (V2 x _,_) = x < w / 2 - 10
-        [( (x-20,  0),pi)
+    farside = do
-        ,( (  20,  0),pi)
+        x <- state $ randomR (5, w/2 - 20)
-        ,( (   0, 20),pi/2)
+        y <- state $ randomR (5, h - 70)
-        ]
+        a <- state $ randomR (0, 2*pi)
-    xn = 4
+        return (V2 x y,a)
-    yn = 4
-    yd = (y - 40) / fromIntegral yn
-    xd = (x - 40) / fromIntegral xn
-    pth  = linksAndPath lnks $ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn)
 
 roomPadCut :: [Point2] -> Point2 -> Room
 roomPadCut ps p = defaultRoom
@@ -355,14 +351,9 @@ weaponRoom = join $ takeOne
     , weaponLongCorridor
     ]
 
-roomCCrits :: RandomGen g => State g (Tree (Either Room Room))
+roomCCrits :: RandomGen g => State g Room
-roomCCrits = do
+roomCCrits = roomC 200 200
-    ps <- replicateM 20 $ randInCirc 9
+    <&> rmPS %~ (replicate 20 (Placement (PSRoomRand 0) randC1 (const Nothing)) ++ )
-    let plmnts = map (\p -> sPS p 0 randC1) 
-                       $ zipWith (+.+) [V2 x y | x<-[110,130,150,170,190], y<- [70,90,110,130,150]] ps
-        lamps = [sPS (V2 50 100) 0 putLamp , sPS (V2 175 100) 0 putLamp]
-    return $ connectRoom $ over rmPS ((lamps ++) . (plmnts ++)) $ roomC 200 200
-
 
 longRoom :: RandomGen g => State g Room
 longRoom = do
@@ -410,18 +401,16 @@ shootersRoom' = do
     x1 <- state $ randomR (20,w/3-20)
     x2 <- state $ randomR (w/3+20,2*w/3-20)
     x3 <- state $ randomR (2*w/3+20,w-20)
-    y1 <- state $ randomR (250,550)
+    y1 <- state $ randomR (280,550)
-    y2 <- state $ randomR (250,550)
+    y2 <- state $ randomR (280,550)
-    y3 <- iterateWhile (\y' -> abs (y1 - y2) < 60 && abs (y2 - y') < 60) $ state $ randomR (250,560)
+    y3 <- iterateWhile (\y' -> abs (y1 - y2) < 60 && abs (y2 - y') < 60) $ state $ randomR (280,560)
     x4 <- state $ randomR (60,w-60)
-    y4 <- state $ randomR (40,180)
+    y4 <- state $ randomR (40,150)
-    --p <- takeOne [V2 x1 y1,V2 x2 y2,V2 x3 y3]
     let bln x y = putBlockN (x+25) (x-25) (y+20) (y+10)
         blv x y = putBlockV (x+25) (x-25) (y+20) (y+10)
         plmnts = bln x1 y1 ++ bln x2 y2 ++ bln x3 y3 ++ blv x4 y4
-                  ++ [spanLightI (V2 0 200) (V2 w 200)
+                  ++ [spanLightI (V2 (-10) 200) (V2 (w/2) 200)
-                    , mntLightLnkCond (\(V2 _ y,_) -> y < 50)
+                    ,spanLightI (V2 (w/2) 200) (V2 (w+10) 200)
-                    , mntLightLnkCond (\(V2 _ y,_) -> y > 550)
                      ]
         toPS x y = return (V2 x y,-0.5*pi)
     return $ set rmPS plmnts $ roomRectAutoLinks w 600
@@ -460,7 +449,10 @@ pillarGrid = do
             y <- takeOne ys
             a <- state $ randomR (0,2*pi)
             return (V2 (x+gap) y,a)
-    let plmnts = replicate 30 (mntLightLnkCond (const True))
+        cornerRestrict (V2 x y,_)
+             = (x > 40 && x < h - 40)
+            || (y > 40 && y < h - 40)
+    let plmnts = replicate 8 (mntLightLnkCond cornerRestrict)
                   ++ 
                  concat [f x y | x<-xs,y<-ys]
     return $ roomRect w h (max i 2) (max i 2)
@@ -480,31 +472,26 @@ pistolerRoom = pillarGrid
 shootingRange :: RandomGen g => State g (Tree (Either Room Room))
 shootingRange = do
     rm1 <- shootersRoom1 >>= changeLinkTo (\(V2 _ y,_) -> y < 40)
-                        >>= filterLinks  (\(V2 _ y,r) -> y > 200 && r /= 0)
+                        >>= changeLinkFrom  (\(V2 _ y,r) -> y > 200 && r /= 0)
     rm2 <- shootersRoom >>= changeLinkTo (\(V2 x y,_) -> y < 10 && x > 20 && x < 180)
-                        >>= filterLinks  (\(V2 _ y,r) -> y > 200 && r /= 0)
+                        >>= changeLinkFrom  (\(V2 _ y,r) -> y > 200 && r /= 0)
     rm3 <- shootersRoom >>= changeLinkTo (\(V2 x y,_) -> y < 10 && x > 20 && x < 180)
-                        >>= filterLinks  (\(_,r) -> r == 0)
+                        >>= changeLinkFrom  (\(_,r) -> r == 0)
-    return $ treeFromPost [Left rm1
+    return $ treeFromPost 
-                      ,Left $ roomPadCut (rectNSWE 20 (-20) (-80) 80) (V2 0 20)
+        [Left rm1
-                      ,Left rm2
+        ,Left $ roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20)
-                      ,Left $ roomPadCut (rectNSWE 20 (-20) (-80) 80) (V2 0 20)
+            & rmPS %~ (spanLightI (V2 (-80) 10) (V2 80 10) :)
-                      ] 
+        ,Left rm2
-                      (Right rm3)
+        ,Left $ roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20)
+            & rmPS %~ (spanLightI (V2 (-80) 10) (V2 80 10) :)
+        ] 
+        (Right rm3)
 
 spawnerRoom :: RandomGen g => State g (Tree (Either Room Room))
 spawnerRoom = do
     x <- state $ randomR (250,300)
     y <- state $ randomR (300,400)
-    wl <- takeOne [sPS (V2 0 0) 0 $ PutWall (rectNSWE (y-60) 0 (x/2-10) (x/2+10)) 
+    roomWithSpawner <- roomC x y <&> 
-                              defaultCrystalWall
+        rmPS %~ (Placement (PSRoomRand 0) (PutCrit spawnerCrit) (const Nothing) :)
-                  ,windowLine (V2 (x/2) 0) (V2 (x/2) (y-60))
-                  ]
-    let plmnts = [sPS (V2 (x/4) ( y/4)) (pi/2) $ PutCrit spawnerCrit
-                 ,wl
-                 ,sPS (V2 (x/2) ( y-10)) 0 putLamp
-                 ]
-    let f (V2 lx _,_) = lx < x/2-5 
-    roomWithSpawner <- (fmap connectRoom . randomiseOutLinks) =<< filterLinks f (set rmPS plmnts $ roomRect x y 2 2) 
     aRoom <- airlock
-    return $ treeFromTrunk [Left aRoom] roomWithSpawner
+    return $ treeFromTrunk [Left aRoom,Left corridor] $ connectRoom roomWithSpawner

src/Dodge/Room/Airlock.hs

@@ -18,8 +18,8 @@ import System.Random
 import Control.Monad.State
 {- | A passage with a switch that opens forward access while closing backwards access. -}
 airlock :: RandomGen g => State g Room
---airlock = takeOne [airlock0,airlock90,airlockCrystal,airlockZ]
+airlock = takeOne [airlock0,airlock90,airlockCrystal,airlockZ]
-airlock = takeOne [airlockZ]
+--airlock = takeOne [airlockZ]
 {- | Straight airlock -}
 airlock0 :: Room
 airlock0 = defaultRoom

src/Dodge/Room/Foreground.hs

@@ -51,6 +51,9 @@ diagonalLinesRect pa pb w d ang = zip lhsPoints $ map findDiPoint lhsPoints
 thinHighBar :: Float -> Point2 -> Point2 -> Shape
 thinHighBar = highBar 3
 
+thinHighBarChain :: Float -> [Point2] -> Shape
+thinHighBarChain h = foldMap (uncurry $ thinHighBar h) . loopPairs
+
 thickHighBar :: Float -> Point2 -> Point2 -> Shape
 thickHighBar = highBar 5
 

src/Dodge/Room/Procedural.hs

@@ -71,7 +71,10 @@ roomRectAutoLinks :: Float -> Float -> Room
 roomRectAutoLinks x y = (roomRect x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60))
     {_rmPS = plmnts}
   where
-    plmnts = [mntLightLnkCond (const True)]
+    plmnts = 
+        [mntLightLnkCond (const True)
+--        ,sps0 $ PutForeground $ thinHighBarChain 50 $ rectNSWE y 0 0 x
+        ]
 {- Combines two rooms into one room.
 Mostly involves concatenation.  -}
 combineRooms :: Room -> Room -> Room

src/Dodge/Room/Start.hs

@@ -30,7 +30,8 @@ startRoom = do
             girderV 40 20 10 (V2  0    (h/2)) (V2  w    (h/2))
     treeFromPost [Left rezBox, Left door] . Right 
         <$> randomiseOutLinks (shiftRoomBy (V2 (-20) (-20),0) 
-            $ roomRectAutoLinks w h & rmPS .~ 
+            $ roomRectAutoLinks w h & rmPS %~ 
+            (
             [ fground
             , mountLightJ (V2 0 (h/3)) (V3 40 (h/3) 70)
             , tankSquareEmboss4 (dim orange) 50 (h-60)
@@ -39,5 +40,6 @@ startRoom = do
             , lightSensor (V2 (0.8*w) (0.25*h)) 0
             , putLasTurret & placementSpot .~ PS (V2 (0.8*w) (0.8*h)) 0
             , sps0 $ PutForeground $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25)
-            ]
+            ] ++
+            ) 
             )

src/MonadHelp.hs

@@ -0,0 +1,17 @@
+module MonadHelp where
+
+untilJust :: Monad m => m (Maybe a) -> m a
+untilJust m = go
+  where
+    go = do
+        mayx <- m
+        maybe go return mayx
+
+untilJustCount :: Monad m => m (Maybe a) -> m (a, Int)
+untilJustCount m = go 0
+  where
+    go i = do
+        mayx <- m
+        case mayx of
+            Nothing -> go (i+1)
+            Just x  -> return (x,i)