From 5d0b48829c4e66cd5f8fa021600848120e7d6f3d Mon Sep 17 00:00:00 2001 From: justin Date: Tue, 16 Nov 2021 21:31:53 +0000 Subject: [PATCH] Cleanup and various bugfixes --- src/Dodge/Floor.hs | 1 + src/Dodge/GameRoom.hs | 1 + src/Dodge/Layout.hs | 36 ++++++++++++-------- src/Dodge/LevelGen/Data.hs | 8 ----- src/Dodge/LevelGen/StaticWalls.hs | 8 +++++ src/Dodge/Path.hs | 1 - src/Dodge/Room/Procedural.hs | 11 +++--- src/Dodge/Room/Start.hs | 56 ++++++++++++++++++++++++++----- src/Dodge/RoomPos.hs | 11 ++++++ src/Dodge/Update/Camera.hs | 5 ++- src/Geometry.hs | 2 +- src/Geometry/LHS.hs | 2 +- 12 files changed, 103 insertions(+), 39 deletions(-) create mode 100644 src/Dodge/RoomPos.hs diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 4fd14002d..9ae44619d 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -17,6 +17,7 @@ import Dodge.LevelGen.Data import Dodge.LevelGen.Switch import Dodge.Item.Weapon.Launcher import Dodge.PlacementSpot +import Dodge.RoomPos import MonadHelp import Data.Tree import Color diff --git a/src/Dodge/GameRoom.hs b/src/Dodge/GameRoom.hs index 88f1c8f8c..b7eacfcab 100644 --- a/src/Dodge/GameRoom.hs +++ b/src/Dodge/GameRoom.hs @@ -10,5 +10,6 @@ data GameRoom = GameRoom , _grViewpointsEx :: [Point2] , _grBound :: [Point2] , _grDir :: Float -- ^ gives direction of room + , _grLinkDirs :: [Float] , _grName :: String } diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index c3ca38356..96db3a5e0 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -149,23 +149,31 @@ wallsFromRooms = where f i (x,y) = (i, defaultWall {_wlLine = (x,y) , _wlID = i}) +-- TODO sort out shifting before or after etc gameRoomsFromRooms :: [Room] -> [GameRoom] -gameRoomsFromRooms = map f +gameRoomsFromRooms = map gameRoomFromRoom + +gameRoomFromRoom :: Room -> GameRoom +gameRoomFromRoom rm = GameRoom + { _grViewpoints = _rmViewpoints rm ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm) +-- ++ map fst (_rmLinks rm) + , _grViewpointsEx = mapMaybe unpos (_rmPos rm) + , _grBound = expandPolyCorners 50 . convexHullSafe . nubBy closePoints + . concat $ _rmBound rm ++ _rmPolys rm + , _grDir = getDir $ _rmPos rm + , _grLinkDirs = mapMaybe undir $ _rmPos rm + , _grName = _rmName rm + } where - f rm = GameRoom - { _grViewpoints = _rmViewpoints rm ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm) - ++ map fst (_rmLinks rm) - , _grViewpointsEx = mapMaybe unpos (_rmPos rm) - , _grBound = expandPolyByFixed 100 . convexHullSafe . nubBy closePoints - . concat $ _rmBound rm ++ _rmPolys rm - , _grDir = getDir $ _rmPos rm - , _grName = _rmName rm - } - closePoints x y = roundPoint2 x == roundPoint2 y - unpos (OutLink _ p _) = Just p - unpos (InLink p _) = Just p + doshift = shiftPointBy (_rmShift rm) + unpos (OutLink _ p _) = Just $ doshift p + unpos (InLink p _) = Just $ doshift p unpos _ = Nothing - getDir (InLink _ a:_) = a + undir (OutLink _ _ a) = Just $ 0.5*pi + a + snd (_rmShift rm) + undir (InLink _ a) = Just $ 0.5*pi + a + snd (_rmShift rm) + undir _ = Nothing + closePoints x y = roundPoint2 x == roundPoint2 y + getDir (InLink _ a:_) = a -- + snd (_rmShift rm) getDir (_:xs) = getDir xs getDir _ = 0 -- fallback diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index 1df1db7e4..13408591e 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -92,14 +92,6 @@ data RoomPos | LabPos Int RoomPos deriving (Eq,Ord,Show) -extractRoomPos :: RoomPos -> (Point2,Float) -extractRoomPos rp = case rp of - OutLink _ p a -> (p,a) - InLink p a -> (p,a) - UnusedLink p a -> (p,a) - PosPl p a -> (p,a) - LabPos _ rp' -> extractRoomPos rp' - makeLenses ''Room makeLenses ''PSType makeLenses ''PlacementSpot diff --git a/src/Dodge/LevelGen/StaticWalls.hs b/src/Dodge/LevelGen/StaticWalls.hs index d25b8b255..f435e3b2a 100644 --- a/src/Dodge/LevelGen/StaticWalls.hs +++ b/src/Dodge/LevelGen/StaticWalls.hs @@ -7,6 +7,7 @@ module Dodge.LevelGen.StaticWalls , removeInverseWalls , expandPolyByFixed , cutPoly + , expandPolyCorners ) where import Geometry @@ -96,6 +97,13 @@ expandPolyByFixed :: Float -> [Point2] -> [Point2] expandPolyByFixed x ps = map f ps where f p = p +.+ x *.* safeNormalizeV (p -.- centroid ps) +-- | Given a value and a poly, pushes points out by a fixed amount along an +-- angle determined by the corner, i.e. by the two other neighbour points +expandPolyCorners :: Float -> [Point2] -> [Point2] +expandPolyCorners d (x:y:z:xs) = zipWith3 f (x:y:z:xs) (y:z:xs++[x]) (z:xs ++ [x,y]) + where + f l c r = c +.+ d *.* normalizeV (normalizeV (c -.- r) +.+ normalizeV (c -.- l)) +expandPolyCorners _ _ = error "trying to expand poly corners of 2 or fewer points" -- | Given a polygon expressed as a list of points and a collection of walls, -- returns: -- fst: points of the polygon's intersection with walls diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs index 10de10306..4df512af5 100644 --- a/src/Dodge/Path.hs +++ b/src/Dodge/Path.hs @@ -1,6 +1,5 @@ module Dodge.Path ( pointTowardsImpulse - --, pointTowardsImpulse' , makePathBetween , makePathBetweenPs , removePathsCrossing diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index 0fb5e477e..5ae31b320 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -66,14 +66,15 @@ roomRect x y xn yn = defaultRoom lnks = nlnks ++ elnks ++ wlnks ++ slnks pth = linksAndPath lnks $ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn) {- 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) roomRectAutoLinks :: Float -> Float -> Room -roomRectAutoLinks x y = (roomRect x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60)) +roomRectAutoLinks x y = (roomRect x y xn yn) {_rmPmnts = plmnts} where - plmnts = - [mntLightLnkCond unusedLnkToPS --- ,sps0 $ PutForeground $ thinHighBarChain 50 $ rectNSWE y 0 0 x - ] + xn = max 1 $ (ceiling x - 40) `div` 60 + yn = max 1 $ (ceiling y - 40) `div` 60 + plmnts = [mntLightLnkCond unusedLnkToPS ] {- Combines two rooms into one room. Mostly involves concatenation. -} combineRooms :: Room -> Room -> Room diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index e92ffbaeb..043b6a7cf 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -1,7 +1,10 @@ module Dodge.Room.Start where import Dodge.LevelGen.Data import Dodge.Data +import Dodge.Layout.Tree.Either +import Dodge.RandomHelp import Dodge.Room.Door +import Dodge.Room.Room import Dodge.Room.Link import Dodge.Room.Procedural import Dodge.Room.Foreground @@ -23,23 +26,38 @@ import System.Random --import qualified Data.IntMap.Strict as IM rezBox :: Room ---rezBox = shiftRoomBy (V2 (-20) (-10),0) $ roomRect 40 20 1 1 rezBox = roomRect 40 60 1 1 - & rmPmnts .~ [ spanColLightI (V3 0 0 0.5) 95 (V2 0 1) (V2 40 1) ] + & rmPmnts .~ [ spanColLightI rezcol 95 (V2 0 1) (V2 40 1) ] + +rezcol :: Point3 +rezcol = V3 0.0 0.1 0.5 rezInvBox :: Room rezInvBox = roomRect 40 60 1 1 - & rmPmnts .~ [ spanColLightI (V3 0 0 0.5) 95 (V2 0 59) (V2 40 59) ] + & rmPmnts .~ [ spanColLightI rezcol 95 (V2 0 59) (V2 40 59) ] crRezBox :: Room -crRezBox = rezInvBox -- & rmPmnts %~ (sPS (V2 20 0) pi randC1 :) +crRezBox = rezInvBox & rmPmnts %~ (sPS (V2 20 50) (1.5*pi) randC1 :) wpRezBox :: Item -> Room wpRezBox wp = rezInvBox & rmPmnts %~ (sPS (V2 15 30) 1 (PutFlIt wp) :) +rezBoxesThenWeaponRoom :: RandomGen g => State g (Tree (Either Room Room)) +rezBoxesThenWeaponRoom = do + rboxes <- rezBoxes + wroom <- weaponRoom + return $ rboxes `appendEitherTree` [wroom] + startRoom :: RandomGen g => State g (Tree (Either Room Room)) -startRoom = do - w <- state $ randomR (100,400) +startRoom = join $ takeOne + [-- rezBoxesWp + rezBoxesThenWeaponRoom + --, rezBoxesWpCrit + ] + +rezBoxesWpCrit :: RandomGen g => State g (Tree (Either Room Room)) +rezBoxesWpCrit = do + w <- state $ randomR (200,400) h <- state $ randomR (40,40) theweapon <- randBlockBreakWeapon let bottomEdgeTest (V2 _ y,_) = y < 1 @@ -63,8 +81,30 @@ startRoom = do adddoor rm = treeFromPost [Left door] (Left rm) onwardtree blcor = treeFromPost [Left door] (Right blcor) -randomRezBoxes :: RandomGen g => State g (Tree (Either Room Room)) -randomRezBoxes = do +rezBoxesWp :: RandomGen g => State g (Tree (Either Room Room)) +rezBoxesWp = do + w <- state $ randomR (100,400) + h <- state $ randomR (40,40) + theweapon <- randBlockBreakWeapon + let bottomEdgeTest (V2 _ y,_) = y < 1 + centralRoom <- randomiseOutLinks =<< changeLinkTo bottomEdgeTest + ((roomRectAutoLinks w h) {_rmPmnts = []}) + blcor <- blockedCorridor' + let n = length $ filter bottomEdgeTest $ _rmLinks centralRoom + let rezrooms = map adddoor + $ wpRezBox theweapon : replicate (n-2) rezInvBox + centralRoom' <- changeLinkFrom bottomEdgeTest centralRoom + return $ treeFromTrunk [Left rezBox + , Left door + ] + (Node (Left centralRoom') (rezrooms ++ [onwardtree blcor])) + where + --dbox = treeFromPost [Left door] (Left rezInvBox) + adddoor rm = treeFromPost [Left door] (Left rm) + onwardtree blcor = treeFromPost [Left door] (Right blcor) + +rezBoxes :: RandomGen g => State g (Tree (Either Room Room)) +rezBoxes = do w <- state $ randomR (100,400) h <- state $ randomR (40,40) let bottomEdgeTest (V2 _ y,_) = y < 1 diff --git a/src/Dodge/RoomPos.hs b/src/Dodge/RoomPos.hs new file mode 100644 index 000000000..16ec2480c --- /dev/null +++ b/src/Dodge/RoomPos.hs @@ -0,0 +1,11 @@ +module Dodge.RoomPos where +import Dodge.LevelGen.Data +import Geometry + +extractRoomPos :: RoomPos -> (Point2,Float) +extractRoomPos rp = case rp of + OutLink _ p a -> (p,a) + InLink p a -> (p,a) + UnusedLink p a -> (p,a) + PosPl p a -> (p,a) + LabPos _ rp' -> extractRoomPos rp' diff --git a/src/Dodge/Update/Camera.hs b/src/Dodge/Update/Camera.hs index e3a11dc62..322111a46 100644 --- a/src/Dodge/Update/Camera.hs +++ b/src/Dodge/Update/Camera.hs @@ -176,9 +176,12 @@ farWallPoints :: Point2 -> World -> [Point2] farWallPoints p w = concatMap _grViewpoints grs ++ linkvps where grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w) - linkvps = map extend (concatMap _grViewpointsEx grs) + linkvps = map extend (concatMap _grViewpointsEx grs + ++ map addDir (concatMap _grLinkDirs grs) + ) extend :: Point2 -> Point2 extend outp = p +.+ maxViewDistance *.* safeNormalizeV (outp -.- p) + addDir a = p +.+ unitVectorAtAngle a maxViewDistance :: Float maxViewDistance = 800 diff --git a/src/Geometry.hs b/src/Geometry.hs index fb22295d5..abe84bdad 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -163,7 +163,7 @@ grahamScan = foldr push [] -- https://codereview.stackexchange.com/questions/206019/graham-scan-algorithm-in-haskell grahamEliminate :: [Point2] -> [Point2] grahamEliminate (x:y:z:xs) - | isRHS x y z = grahamEliminate (x:z:xs) + | not $ isLHS x y z = grahamEliminate (x:z:xs) grahamEliminate xs = xs -- | Return midpoint between two points. diff --git a/src/Geometry/LHS.hs b/src/Geometry/LHS.hs index 1861df854..ce9635edd 100644 --- a/src/Geometry/LHS.hs +++ b/src/Geometry/LHS.hs @@ -22,7 +22,7 @@ isLHS a2 = y' - y b1 = x'' - x b2 = y'' - y --- | Test whether a point is on the LHS of a line. +-- | Test whether a point is on the RHS of a line. -- Returns False if the line is of zero length. isRHS :: Point2 -- ^ First line point.