Dump some info to sdout when generating level

src/Dodge/Floor.hs

@@ -3,6 +3,7 @@
 The tree of rooms that make up a level. -}
 module Dodge.Floor
     ( levx
+    , layoutLevel
     ) where
 import Geometry.Data
 import Dodge.Data
@@ -23,17 +24,19 @@ import Dodge.Creature
 import Dodge.LevelGen.Data
 import Dodge.Item.Weapon.Launcher
 import MonadHelp
+import Data.Tree
 
 import Control.Lens
 import Control.Monad.State
 import Control.Monad.Loops
 import System.Random
-{- | A test level tree. -}
-initialRoomTree :: RandomGen g => State g (Maybe [Room])
-initialRoomTree = do
+import Data.Sequence hiding (zipWith)
+import Data.Maybe
+initialAnoTree :: RandomGen g => Tree [Annotation g]
+initialAnoTree =
     let struct = treeFromPost [[Corridor,SpecificRoom $ fmap (pure . Right) randomFourCornerRoom]] [EndRoom]
-    let t' = padCorridors struct
-        t = treeFromTrunk 
+        t' = padWithCorridors struct
+    in treeFromTrunk 
             [[StartRoom]
             ,[SpecificRoom spawnerRoom]
             ,[Corridor]
@@ -95,9 +98,30 @@ initialRoomTree = do
             ,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]]
             ] 
             t'
-    shiftExpandTree . expandTreeBy id <$> mapM annoToRoomTree t
+
+{- | A test level tree. -}
+initialRoomTree :: RandomGen g => State g (Tree Room)
+initialRoomTree = do
+    expandTreeBy id <$> mapM annoToRoomTree initialAnoTree
 
 levx :: RandomGen g => Int -> State g ([Room] , Int)
-levx _ = untilJustCount initialRoomTree
+levx _ = untilJustCount $ shiftExpandTree <$> initialRoomTree
 
-        
+layoutLevel :: Int -> IO [Room]
+layoutLevel seed = do
+    putStrLn $ "Generating level with seed: " ++ show seed
+    let g = mkStdGen seed
+    let rmtree = evalState initialRoomTree g
+    mrs <- shiftRoomSearchIO [] (singleton rmtree)
+    case mrs of
+        Just rs -> return (fmap setLastLinkToUsed rs)
+        Nothing -> do
+            putStrLn "Level generation failed"
+            let (seed',_) = random g
+            layoutLevel seed'
+  where
+    setLastLinkToUsed rm = case _rmLinks rm of
+        (_:_) -> rm
+            & rmLinks %~ init
+            & rmUsedLinks %~ (last (_rmLinks rm) :)
+        _ -> rm

src/Dodge/Initialisation.hs

@@ -24,11 +24,12 @@ firstWorld :: IO World
 firstWorld = do
 --    i <- randomRIO (0,5000)
     let i = 3
-    putStrLn $ "Seed for level generation: " ++ show ( i :: Int)
-    let g = mkStdGen i
-    (roomList,n) <- f g
-    putStrLn $ "Had to go through "++ show n ++ " random generators"
-    return $ generateLevelFromRoomList roomList $ initialWorld {_randGen = g}
+    --putStrLn $ "Seed for level generation: " ++ show ( i :: Int)
+--    let g = mkStdGen i
+--    (roomList,n) <- f g
+--    putStrLn $ "Had to go through "++ show n ++ " random generators"
+    roomList <- layoutLevel i
+    return $ generateLevelFromRoomList roomList $ initialWorld -- note this uses a random generator defined elsewhere
   where
     f :: StdGen -> IO ([Room],Int)
     f g = do

src/Dodge/Layout/Tree/Annotate.hs

@@ -47,8 +47,8 @@ addLock i t = do
     newBefore <- applyToRandomNode (Key i :) beforeLock
     return $ addToTrunk newBefore [Node [Lock i] afterLock]
 {- | Add one corridor between each parent-child link of a tree of annotations.  -}
-padCorridors :: Tree [Annotation g] -> Tree [Annotation g]
-padCorridors (Node x xs) = Node [Corridor] [Node x (map padCorridors xs)]
+padWithCorridors :: Tree [Annotation g] -> Tree [Annotation g]
+padWithCorridors (Node x xs) = Node [Corridor] [Node x (map padWithCorridors xs)]
 {- Add one to three corridors between each parent-child link of a tree of annotations.  -}
 randomPadCorridors :: RandomGen g => Tree [Annotation g] -> State g (Tree [Annotation g])
 randomPadCorridors  (Node x xs) = do

src/Dodge/Layout/Tree/Shift.hs

@@ -6,17 +6,20 @@ Returns a list; after this step the structure is determined by the actual positi
 module Dodge.Layout.Tree.Shift
     ( shiftRoomTreeSearchAll
     , shiftExpandTree
+    , shiftRoomSearchIO
     ) where
 import Dodge.Room.Data
 import Dodge.Room.Link
 import Dodge.Layout.Tree.Polymorphic
 import Geometry.ConvexPoly
+import Geometry
 
 import Data.Tree
 import Data.Sequence hiding (zipWith)
 import Data.List (delete)
 import Data.Maybe (listToMaybe)
 import Control.Lens hiding (Empty, (<|) , (|>))
+
 {- | All: Depth first search of trees of rooms, produces a list of lists of rooms that are not clipping.  -}
 shiftRoomTreeSearchAll 
     :: [ConvexPoly]       -- ^ Clipping bounds
@@ -40,6 +43,43 @@ shiftRoomTreeSearchAll bs (Node r ts :<| tseq)
     useLink l = r & rmLinks %~ delete l
         & rmUsedLinks %~ (l :)
     f l = applyToRoot (shiftRoomToLink l)
+shiftRoomSearchIO
+    :: [ConvexPoly]
+    -> Seq (Tree Room)
+    -> IO (Maybe [Room])
+shiftRoomSearchIO _ Empty = return (Just [])
+shiftRoomSearchIO bs (Node r ts :<| tseq) 
+    | roomIsClipping = do
+        putStrLn "Room clipping"
+        return Nothing
+    | otherwise      = fmap (fmap (r:)) $ placeLinkedRooms newBounds r ts tseq
+  where
+    convexBounds = map pointsToPoly $ _rmBound r
+    newBounds = convexBounds ++ bs
+    roomIsClipping = or (convexPolysOverlap <$> convexBounds <*> bs)
+placeLinkedRooms :: [ConvexPoly] -> Room -> [Tree Room] -> (Seq (Tree Room)) -> IO (Maybe [Room])
+placeLinkedRooms bs _ [] tseq
+    = shiftRoomSearchIO bs tseq
+placeLinkedRooms bs r (t:ts) tseq
+    = tryLinks ls bs r t ts tseq
+  where
+    ls = init $ _rmLinks r
+
+tryLinks :: [(Point2,Float)] -> [ConvexPoly] -> Room -> Tree Room -> [Tree Room] -> (Seq (Tree Room))
+    -> IO (Maybe [Room])
+tryLinks [] _ _ _ _ _ = do
+    putStrLn "Tried all links"
+    return Nothing
+tryLinks (l:ls) bs r t ts tseq = do
+    branch <- placeLinkedRooms bs useLink ts (tseq |> shiftedt)
+    case branch of
+        Nothing -> tryLinks ls bs r t ts tseq
+        Just rs -> return $ Just rs
+  where
+    useLink = r & rmLinks %~ delete l
+        & rmUsedLinks %~ (l :)
+    shiftedt = applyToRoot (shiftRoomToLink l) t
+
 {- |
 Depth first search of trees of rooms, maybe produces a list rooms that are not clipping.
  -}

src/Dodge/Menu.hs

@@ -12,15 +12,13 @@ import Dodge.Config.Data
 import Dodge.Config.Update
 import SDL
 import SDL.Internal.Numbered
---import Dodge.Layout
---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"
@@ -53,7 +51,8 @@ debugMenuOptions =
     , doption ScancodeP debug_pathing "SHOW PATHING" _debug_pathing
     ]
   where
-    doption scode l t rec = Toggle scode (Just . (config . l %~ not)) (\w -> t ++ ":" ++ show (rec $ _config w))
+    doption scode l t rec 
+        = Toggle scode (Just . (config . l %~ not)) (\w -> t ++ ":" ++ show (rec $ _config w))
 gameplayMenu :: ScreenLayer
 gameplayMenu  = OptionScreen
     { _scTitle = const "OPTIONS:GAMEPLAY"
@@ -160,7 +159,6 @@ pauseMenuOptions =
 startNewGame :: World -> Maybe World
 startNewGame w = Just $ w
     & menuLayers .~ [WaitScreen (const "GENERATING...") 1]
---    & worldEvents .~ const aNewGame
     & sideEffects .~ const (firstWorld <&> keyConfig .~ _keyConfig w <&> config .~ _config w
         <&> preloadData .~ _preloadData w) -- this kills save games etc...