From 329fcc237b0c8c3841916c7cb64ef1775224fcb2 Mon Sep 17 00:00:00 2001 From: justin Date: Mon, 27 Oct 2025 17:08:16 +0000 Subject: [PATCH] Work on grid for room placements --- src/Dodge/Data/CardinalPoint.hs | 8 ++++ src/Dodge/Room/Procedural.hs | 68 +++++++++------------------------ src/Dodge/Room/Tutorial.hs | 3 ++ 3 files changed, 30 insertions(+), 49 deletions(-) diff --git a/src/Dodge/Data/CardinalPoint.hs b/src/Dodge/Data/CardinalPoint.hs index e51dfcdc5..8cfebfe24 100644 --- a/src/Dodge/Data/CardinalPoint.hs +++ b/src/Dodge/Data/CardinalPoint.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} module Dodge.Data.CardinalPoint where import Control.Lens @@ -9,6 +10,13 @@ data CardinalPoint | West deriving (Eq, Ord, Show, Bounded, Enum) +revCard :: CardinalPoint -> CardinalPoint +revCard = \case + North -> South + East -> West + South -> North + West -> East + data CardinalPointBetween = NorthEast | SouthEast diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index f0b9fdc6a..03f05b7ec 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -10,6 +10,7 @@ module Dodge.Room.Procedural ( -- makeGrid, ) where +import Linear import Grid import Dodge.Door.PutSlideDoor import Dodge.Default.Wall @@ -45,7 +46,8 @@ roomRect x y xn yn = , _rmLinks = lnks , _rmName = "rect" , _rmPath = pth - , _rmPos = map makeonpos posps ++ map makeoffpos interposps + , _rmPos = map makeonpos (grid xs ys) + <> map makeoffpos (grid (mids xs) (mids ys)) , _rmPmnts = [] , _rmBound = [rectNSWE (y + 5) (-5) (-5) (x + 5)] , _rmFloor = @@ -75,36 +77,20 @@ roomRect x y xn yn = yd = (y - 40) / fromIntegral yn xd = (x - 40) / fromIntegral xn pth = linksDAGToPath lnks $ latticeXsYs xs ys - hls y' a e = xs <&> \x' -> RoomLink (rlt e) (V2 x' y') a - vls x' a e = ys <&> \y' -> RoomLink (rlt e) (V2 x' y') a + horilnks y' a e = xs <&> \x' -> RoomLink (rlt e) (V2 x' y') a + vertlnks x' a e = ys <&> \y' -> RoomLink (rlt e) (V2 x' y') a rlt e = S.fromList [OnEdge e, InLink, OutLink] - somelnks poffset ps a = zip (map (+.+ poffset) ps) (repeat a) - wlnks = vls 0 (pi/2) West - elnks = vls x (-pi/2) East - nlnks = hls y 0 North --somelnks (V2 20 y) (gridPoints xd (xn + 1) 0 1) 0 - slnks = hls 0 pi South --somelnks (V2 20 0) (gridPoints xd (xn + 1) 0 1) pi - lnks = zipWith g nlnks [0..] - <> zipWith g slnks [0..] - <> zipWith g' elnks [0..] - <> zipWith g' wlnks [0..] - g ln xi = ln & rlType <>~ S.fromList [FromEdge West xi,FromEdge East (xn - xi)] - g' ln xi = ln & rlType <>~ S.fromList [FromEdge South xi,FromEdge North (xn - xi)] --- lnks= m North (FromEdge West) (FromEdge East) nlnks --- ++ m East (FromEdge South) (FromEdge North) elnks --- ++ m West (FromEdge South) (FromEdge North) wlnks --- ++ m South (FromEdge West) (FromEdge East) slnks - --wlnks = somelnks (V2 0 20) (gridPoints 0 1 yd (yn + 1)) (pi / 2) - --elnks = somelnks (V2 x 20) (gridPoints 0 1 yd (yn + 1)) (- pi / 2) - --nlnks = somelnks (V2 20 y) (gridPoints xd (xn + 1) 0 1) 0 - --slnks = somelnks (V2 20 0) (gridPoints xd (xn + 1) 0 1) pi - --lnks = - -- m North (FromEdge West) (FromEdge East) nlnks - -- ++ m East (FromEdge South) (FromEdge North) elnks - -- ++ m West (FromEdge South) (FromEdge North) wlnks - -- ++ m South (FromEdge West) (FromEdge East) slnks - m edge edgefrom1 edgefrom2 = - zipWith (lnkBothAnd (OnEdge edge) edgefrom1 edgefrom2) [0 ..] - . zipCountDown + wlnks = vertlnks 0 (pi/2) West + elnks = vertlnks x (-pi/2) East + nlnks = horilnks y 0 North + slnks = horilnks 0 pi South + lnks = imap (g West) nlnks + <> imap (g West) slnks + <> imap (g South) elnks + <> imap (g South) wlnks + g c xi ln = ln + & rlType <>~ S.fromList [FromEdge c xi,FromEdge (revCard c) (xn - xi)] + grid as bs = [(V2 x' y', (xi,yi)) | (x',xi) <- zip as [0..], (y',yi) <- zip bs [0..]] makeonpos (p, a) = RoomPos p 0 (S.singleton $ RoomPosOnGrid $ makerpedges a) (NotLink True) mempty makerpedges (a, b) = @@ -114,8 +100,9 @@ roomRect x y xn yn = , PathFromEdge East (xn - a) , PathFromEdge West a ] - posps = map (over _1 (+.+ V2 20 20)) $ gridPoints'' xd (xn + 1) yd (yn + 1) - interposps = map (over _1 (+.+ V2 (20 + xd / 2) (20 + yd / 2))) $ gridPoints'' xd xn yd yn + --posps = grid -- map (over _1 (+.+ V2 20 20)) $ gridPoints'' xd (xn + 1) yd (yn + 1) + mids zs = zipWith (\a b -> 0.5 * (a + b)) zs $ tail zs + --interposps = map (over _1 (+.+ V2 (20 + xd / 2) (20 + yd / 2))) $ gridPoints'' xd xn yd yn makeoffpos (p, a) = RoomPos p 0 (S.singleton $ RoomPosOffGrid $ makerpedges' a) (NotLink False) mempty makerpedges' (a, b) = @@ -126,23 +113,6 @@ roomRect x y xn yn = , PathFromEdge West a ] -zipCountDown :: [a] -> [(Int, a)] -zipCountDown xs = zip [length xs - 1, length xs - 2 ..] xs - -lnkBothAnd :: - RoomLinkType -> - (Int -> RoomLinkType) -> - (Int -> RoomLinkType) -> - Int -> - (Int, (Point2, Float)) -> - RoomLink -lnkBothAnd rlt ltcon ltcon2 i (j, (p, a)) = - RoomLink - { _rlType = S.fromList [OutLink, InLink, rlt, ltcon i, ltcon2 j] - , _rlPos = p - , _rlDir = a - } - {- Creates a rectangular room, automatically creates links and pathfinding graph at a sensible size. -} -- it is not clear to me that this works for very small rooms (but it does seem -- to do so) diff --git a/src/Dodge/Room/Tutorial.hs b/src/Dodge/Room/Tutorial.hs index 8eef9b6b6..493188aaa 100644 --- a/src/Dodge/Room/Tutorial.hs +++ b/src/Dodge/Room/Tutorial.hs @@ -1,6 +1,7 @@ {-# OPTIONS_GHC -Wno-unused-imports #-} module Dodge.Room.Tutorial where +import Dodge.Room.Pillar import Dodge.Room.Boss import Dodge.Room.Tanks import Dodge.Room.LongDoor @@ -46,6 +47,8 @@ tutAnoTree = do foldMTRS [ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox , corDoor + , tToBTree "cor" . return . cleatOnward <$> roomPillarsSquare + , corDoor -- , return $ tToBTree "cor" $ return $ cleatOnward $ corridor & rmPmnts .~ mempty -- , return $ tToBTree "cor" $ return $ cleatOnward $ roomGlassOctogon 200 -- , corDoor