Fix bug determining max radius of convex polys, fixes bugs in room positioning

src/Dodge/Config/Data.hs

@@ -22,6 +22,7 @@ data Configuration = Configuration
     , _debug_noclip         :: Bool
     , _debug_cr_status      :: Bool
     , _debug_view_boundaries :: Bool
+    , _debug_view_clip_bounds :: Bool
     , _debug_pathing        :: Bool
     }
   deriving (Generic, Show)
@@ -61,5 +62,6 @@ defaultConfig = Configuration
     , _debug_noclip         = False
     , _debug_cr_status      = False
     , _debug_view_boundaries = False
+    , _debug_view_clip_bounds = False
     , _debug_pathing    = False
     }

src/Dodge/Data.hs

@@ -38,6 +38,7 @@ import Data.Preload
 import Picture.Data
 import ShapePicture
 import Geometry.Data
+import Geometry.ConvexPoly
 import Sound.Data
 import Dodge.GameRoom
 import Color
@@ -120,6 +121,7 @@ data World = World
     , _distortions          :: [Distortion]
     , _worldBounds          :: Bounds
     , _gameRooms            :: [GameRoom] -- consider using an IntMap
+    , _roomClipping         :: [ConvexPoly]
     , _maybeWorld           :: Maybe' World
     , _rewindWorlds         :: [World]
     , _timeFlow             :: TimeFlowStatus

src/Dodge/Default/World.hs

@@ -85,6 +85,7 @@ defaultWorld = World
     , _foregroundShape = mempty
     , _distortions     = []
     , _gameRooms = []
+    , _roomClipping = []
     , _worldClock = 0
     , _worldBounds = defaultBounds
     , _maybeWorld = Nothing'

src/Dodge/Initialisation.hs

@@ -10,6 +10,7 @@ import Dodge.Creature
 import Dodge.WorldEvent.Cloud
 import Dodge.SoundLogic
 import Geometry.Data
+import Geometry.ConvexPoly
 
 import System.Random
 import qualified Data.Set as S
@@ -42,4 +43,7 @@ initialWorld = defaultWorld
 
 testStringInit :: World -> [String]
 --testStringInit = map (concatMap $ \(_,ct,_,_) -> show ct) . invertListInvMult . yourInv
-testStringInit = const []
+testStringInit w = [show $ f $ _roomClipping w]
+  where
+    f (x:xs) = any (convexPolysOverlap x) xs || f xs
+    f [] = False

src/Dodge/LevelGen.hs

@@ -9,21 +9,23 @@ import Dodge.Initialisation
 --import Dodge.RandomHelp
 import Dodge.LevelGen.Data
 import Dodge.Tree
+import Geometry.ConvexPoly
 --import Dodge.LevelGen.LevelStructure
 
 import Data.Tree
 import System.Random
---import Control.Lens
+import Control.Lens
 import Control.Monad.State
 import qualified Data.IntMap.Strict as IM
 
 generateWorldFromSeed :: Int -> IO World
 generateWorldFromSeed i = do
-    roomList <- layoutLevelFromSeed 0 i
+    (roomList,bounds) <- layoutLevelFromSeed 0 i
-    return $ saveLevelStartSlot $ _gWorld $ generateLevelFromRoomList roomList 
+    return $ saveLevelStartSlot $ (_gWorld $ generateLevelFromRoomList roomList 
-         initialWorld{_randGen=mkStdGen i}
+         initialWorld{_randGen=mkStdGen i})
+        & roomClipping .~ bounds
 
-layoutLevelFromSeed :: Int -> Int -> IO (IM.IntMap Room)
+layoutLevelFromSeed :: Int -> Int -> IO (IM.IntMap Room,[ConvexPoly])
 layoutLevelFromSeed i seed = do
     let i' = i + 1
     putStrLn $ "Generating level with seed " ++ show seed
@@ -36,13 +38,13 @@ layoutLevelFromSeed i seed = do
     putStrLn "Layout with room names written to aGeneratedRoomLayout"
     mrs <- positionRoomsFromTree rmtree
     case mrs of
-        Just rs -> do
+        Just (PosRooms bounds rs) -> do
             putStrLn $ "After " ++ show i' 
                 ++ " attempt(s), Successful generation of level with seed " 
                 ++ show seed
             --return (fmap setLastLinkToUsed rs)
             putStrLn $ show (Prelude.length rs) ++ " rooms in total"
-            return . IM.fromList $ map reversePair rs
+            return (IM.fromList $ map reversePair rs , bounds)
         Nothing -> do
             putStr $ "Level generation with seed " ++ show seed ++ " failed: "
             let (seed',_) = random g

src/Dodge/Menu.hs

@@ -79,6 +79,7 @@ debugMenuOptions =
     , doption ScancodeC debug_noclip "NOCLIP" _debug_noclip
     , doption ScancodeS debug_cr_status "SHOW CREATURE STATUS" _debug_cr_status
     , doption ScancodeV debug_view_boundaries "SHOW VIEW BOUNDARIES" _debug_view_boundaries
+    , doption ScancodeB debug_view_clip_bounds "SHOW ROOM CLIP BOUNDARIES" _debug_view_clip_bounds
     , doption ScancodeP debug_pathing "SHOW PATHING" _debug_pathing
     ]
   where

src/Dodge/Reloading.hs

@@ -21,8 +21,11 @@ icTryStartReloading it = do
     ammax       <- am ^? ammoBaseMax
     rstate      <- am ^? reloadState
     if amloaded < ammax && rstate == Nothing'
-        then Just $ it & itConsumption . reloadState .~ Just' (_reloadTime am)
+        then Just $ it 
-                    & if _reloadType am == ActiveClear then itConsumption . ammoLoaded .~ 0 else id
+                & itConsumption . reloadState .~ Just' (_reloadTime am)
+                & if _reloadType am == ActiveClear 
+                    then itConsumption . ammoLoaded .~ 0 
+                    else id
         else Nothing
 
 crStopReloading :: Creature -> Creature

src/Dodge/Render/ShapePicture.hs

@@ -1,7 +1,6 @@
 module Dodge.Render.ShapePicture
     ( worldSPic
-    )
+    ) where
-    where
 import Dodge.Config.Data
 --import Dodge.Debug.Picture
 import Dodge.Picture.SizeInvariant
@@ -19,6 +18,7 @@ import ShapePicture
 import Shape
 import Picture
 import Sound.Data
+import Geometry.ConvexPoly
 
 import qualified Data.IntMap.Strict as IM -- Lazy?
 import qualified Data.Map.Strict as M
@@ -52,6 +52,7 @@ extraPics cfig w = pictures (_decorations w)
     <> concatMapPic ppDraw (_pressPlates w )
     <> soundPics cfig w
     <> viewBoundaries cfig w
+    <> viewClipBounds cfig w
     <> drawPathing cfig w
 
 testPic :: World -> Picture
@@ -110,6 +111,21 @@ viewBoundaries cfig w
     p = _crPos $ you w
     grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w)
 
+viewClipBounds :: Configuration -> World -> Picture
+viewClipBounds cfig w
+    | _debug_view_clip_bounds cfig 
+--         = setLayer 5 $ color green $ concatMap (polygonWire . _cpPoints) (_roomClipping w)
+        = setLayer 5 $ f (_roomClipping w)
+    | otherwise = []
+  where
+    f (x:xs) = g x xs <> f xs
+    f [] = mempty
+    g x (y:ys) | convexPolysOverlap x y = color green (polygonWire $ _cpPoints x) 
+                    <> color yellow (polygonWire $ _cpPoints y)
+                    <> g x ys
+        | otherwise = g x ys
+    g _ [] = mempty
+
 --wallFloorsToDraw :: World -> [Wall]
 --wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w
 --  where 

src/Dodge/Room/LongRoom.hs

@@ -55,7 +55,8 @@ longRoomRunPast = do
         (Node (PassDown r)
             [ singleUseAll door
             --, return (UseLabel 0 $ door & rmConnectsTo .~ S.singleton InLink)
-            , treeFromPost [PassDown $ corridor & rmConnectsTo .~ S.member InLink, PassDown corridor] 
+            --, treeFromPost [PassDown $ corridor & rmConnectsTo .~ S.member InLink, PassDown corridor] 
+            , treeFromPost [PassDown $ corridor & rmConnectsTo .~ S.member InLink] 
                 (UseLabel 0 door)
             ]
         )

src/Dodge/Room/Procedural.hs

@@ -170,6 +170,8 @@ quarterRoomTri w = do
             ]
         , _rmBound  = [[V2 0 0,V2 w w,V2 (-w) w]]
         }
+--  where
+--    w' = w -10
 
 quarterRoomSquare :: RandomGen g => Float -> State g Room
 quarterRoomSquare w = do
@@ -207,8 +209,10 @@ quarterRoomSquare w = do
         , _rmPos = [ RoomPos p pi S.empty NotLink 0 
                     | p <- [V2 20 (2*w-40),V2 25 (2*w-45)] ]
         --, _rmBound = [map toV2 [(w,w),(0,2*w),(-w,w)]]
-        , _rmBound = thepoly
+        , _rmBound = [ map toV2 [(0,0),(w,w),(0,2*w),(-w,w)] ]
         }
+--  where
+--    w' = w - 10
 {- | Randomise the ordering of placements in a room.
 Useful for randomising the position of generic placements such as 'PutNothing'. -}
 shufflePlacements :: RandomGen g => Room -> State g Room

src/Dodge/Tree/Shift.hs

@@ -1,8 +1,11 @@
 {- | Given a tree of rooms, tries to shift them into place in such a way that their
 links connect and that none of them clip.
 Creates a list of rooms; after this step the structure is determined by the actual positions of rooms.  -}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StrictData #-}
 module Dodge.Tree.Shift
     ( positionRoomsFromTree
+    , PosRooms (..)
     ) where
 import Dodge.LevelGen.Data
 import Dodge.Room.Link
@@ -16,28 +19,37 @@ import LensHelp hiding (Empty, (<|) , (|>))
 
 import qualified Data.Set as S
 import Data.Tree
-import Data.Sequence hiding (zipWith)
+import qualified Data.Sequence as Seq
 import Data.List (delete)
 import Data.Bifunctor
+import Control.Lens
 
 type RoomInt = (Room,Int)
 
-positionRoomsFromTree :: Tree RoomInt -> IO (Maybe [RoomInt])
+data PosRooms = PosRooms
+    { _prBounds :: [ConvexPoly]
+    , _prRooms  :: [RoomInt]
+    }
+makeLenses ''PosRooms
+
+
+positionRoomsFromTree :: Tree RoomInt -> IO (Maybe PosRooms)
 positionRoomsFromTree (Node (r,i) ts) = printColumnTitles 
-    >> fmap (fmap (map $ first createUnusedLinkPos))
+    >> fmap (fmap (prRooms %~ (map $ first createUnusedLinkPos)))
-        (posRms (map pointsToPoly $ _rmBound r') (r',i) (zipCount ts) Empty)
+        (posRms (PosRooms (map pointsToPoly $ _rmBound r') []) (r',i) (zipCount ts) Empty)
   where
     r' = r & rmMID ?~ 0
 
-posRms :: [ConvexPoly]
+posRms :: PosRooms
     -> RoomInt
     -> [(Int,Tree RoomInt)]     -- the list of children, with indices
-    -> Seq (Tree RoomInt)
+    -> Seq.Seq (Tree RoomInt)
-    -> IO (Maybe [RoomInt])
+    -> IO (Maybe PosRooms)
-posRms bounds roomi [] st = case st of
+posRms prs roomi [] st = case st of
-    Empty                   -> return $ Just [roomi]
+    Empty                   -> return $ Just $ prs & prRooms .:~ roomi
-    Node nextroomi ts :<| tseq -> fmap (roomi:) <$> posRms bounds nextroomi (zipCount ts) tseq
+    Node nextroomi ts Seq.:<| tseq -> posRms (prs & prRooms .:~ roomi) nextroomi (zipCount ts) tseq
-posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
+    _ -> error "unexpected outcome in posRms"
+posRms prs parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
     printInfoCheckNum parenti numChild childi
     tryParentLinks outlinks
   where
@@ -54,7 +66,7 @@ posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
             | otherwise = do
                 putStrLn $ show j ++ "-" ++ show numinlink
                 mayrs <- posRms 
-                    (newBounds ++ bounds)
+                    (prs & prBounds .++~ newBounds)
                     (first updateparent parenti) 
                     its 
                     (tseq |> shiftedt)
@@ -64,7 +76,7 @@ posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
                         >> tryChildLinks ils
           where
             newBounds = map pointsToPoly . _rmBound . doRoomShift . fst $ rootLabel shiftedt
-            clipping = or (convexPolysOverlap <$> newBounds <*> bounds)
+            clipping = or (convexPolysOverlap <$> newBounds <*> _prBounds prs)
             updateparent rm = doLnkEff (lnkPosDir outlnk) $ rm 
                 & rmLinks    %~ delete outlnk 
                 & rmPos      .:~ RoomPos

src/Geometry/ConvexPoly.hs

@@ -27,7 +27,7 @@ pointsToPoly :: [Point2] -> ConvexPoly
 pointsToPoly xs = ConvexPoly
     { _cpPoints = xs
     , _cpCen    = cen
-    , _cpRad    = minimum $ map (dist cen) xs
+    , _cpRad    = maximum $ map (dist cen) xs
     }
   where
     cen = centroid xs