From d6285c45b3caeba72464a453aeed62b423385a4f Mon Sep 17 00:00:00 2001 From: justin Date: Mon, 21 Mar 2022 07:43:27 +0000 Subject: [PATCH] Fix bug determining max radius of convex polys, fixes bugs in room positioning --- src/Dodge/Config/Data.hs | 2 ++ src/Dodge/Data.hs | 2 ++ src/Dodge/Default/World.hs | 1 + src/Dodge/Initialisation.hs | 6 ++++- src/Dodge/LevelGen.hs | 16 ++++++++------ src/Dodge/Menu.hs | 1 + src/Dodge/Reloading.hs | 15 ++++++++----- src/Dodge/Render/ShapePicture.hs | 20 +++++++++++++++-- src/Dodge/Room/LongRoom.hs | 3 ++- src/Dodge/Room/Procedural.hs | 6 ++++- src/Dodge/Tree/Shift.hs | 38 +++++++++++++++++++++----------- src/Geometry/ConvexPoly.hs | 2 +- 12 files changed, 80 insertions(+), 32 deletions(-) diff --git a/src/Dodge/Config/Data.hs b/src/Dodge/Config/Data.hs index 704eb5e4d..8b9745af0 100644 --- a/src/Dodge/Config/Data.hs +++ b/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 } diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 6c60b996e..f5e8b04cf 100644 --- a/src/Dodge/Data.hs +++ b/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 diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index d32d56637..81d903db8 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -85,6 +85,7 @@ defaultWorld = World , _foregroundShape = mempty , _distortions = [] , _gameRooms = [] + , _roomClipping = [] , _worldClock = 0 , _worldBounds = defaultBounds , _maybeWorld = Nothing' diff --git a/src/Dodge/Initialisation.hs b/src/Dodge/Initialisation.hs index e350b2e66..79652ce74 100644 --- a/src/Dodge/Initialisation.hs +++ b/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 diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 8e7b1d0c9..ceee9a2d3 100644 --- a/src/Dodge/LevelGen.hs +++ b/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 - return $ saveLevelStartSlot $ _gWorld $ generateLevelFromRoomList roomList - initialWorld{_randGen=mkStdGen i} + (roomList,bounds) <- layoutLevelFromSeed 0 i + return $ saveLevelStartSlot $ (_gWorld $ generateLevelFromRoomList roomList + 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 diff --git a/src/Dodge/Menu.hs b/src/Dodge/Menu.hs index 7d772a36d..4fc0c586d 100644 --- a/src/Dodge/Menu.hs +++ b/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 diff --git a/src/Dodge/Reloading.hs b/src/Dodge/Reloading.hs index b84f7c53a..56c088b60 100644 --- a/src/Dodge/Reloading.hs +++ b/src/Dodge/Reloading.hs @@ -16,13 +16,16 @@ startReloadingWeapon cr = (creatures . ix (_crID cr) . crInv . ix (_crInvSel cr) icTryStartReloading :: Item -> Maybe Item icTryStartReloading it = do - am <- it ^? itConsumption - amloaded <- am ^? ammoLoaded - ammax <- am ^? ammoBaseMax - rstate <- am ^? reloadState + am <- it ^? itConsumption + amloaded <- am ^? ammoLoaded + ammax <- am ^? ammoBaseMax + rstate <- am ^? reloadState if amloaded < ammax && rstate == Nothing' - then Just $ it & itConsumption . reloadState .~ Just' (_reloadTime am) - & if _reloadType am == ActiveClear then itConsumption . ammoLoaded .~ 0 else id + then Just $ it + & itConsumption . reloadState .~ Just' (_reloadTime am) + & if _reloadType am == ActiveClear + then itConsumption . ammoLoaded .~ 0 + else id else Nothing crStopReloading :: Creature -> Creature diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index f49ac02a6..7c7b70cd1 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/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 diff --git a/src/Dodge/Room/LongRoom.hs b/src/Dodge/Room/LongRoom.hs index ce025dfd6..f6e6286e2 100644 --- a/src/Dodge/Room/LongRoom.hs +++ b/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) ] ) diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index a4aff0b73..aee27bd37 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/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 diff --git a/src/Dodge/Tree/Shift.hs b/src/Dodge/Tree/Shift.hs index fea5f51f0..c2327924b 100644 --- a/src/Dodge/Tree/Shift.hs +++ b/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)) - (posRms (map pointsToPoly $ _rmBound r') (r',i) (zipCount ts) Empty) + >> fmap (fmap (prRooms %~ (map $ first createUnusedLinkPos))) + (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) - -> IO (Maybe [RoomInt]) -posRms bounds roomi [] st = case st of - Empty -> return $ Just [roomi] - Node nextroomi ts :<| tseq -> fmap (roomi:) <$> posRms bounds nextroomi (zipCount ts) tseq -posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do + -> Seq.Seq (Tree RoomInt) + -> IO (Maybe PosRooms) +posRms prs roomi [] st = case st of + Empty -> return $ Just $ prs & prRooms .:~ roomi + Node nextroomi ts Seq.:<| tseq -> posRms (prs & prRooms .:~ roomi) nextroomi (zipCount ts) tseq + _ -> 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 diff --git a/src/Geometry/ConvexPoly.hs b/src/Geometry/ConvexPoly.hs index a35a585b9..fac84d472 100644 --- a/src/Geometry/ConvexPoly.hs +++ b/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