justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Stop intersectSegSegTest returning True for collinear line pairs

Browse Source
This commit is contained in:
justin
2026-03-12 13:37:56 +00:00
parent cdc21c9fb1
commit 65383e2303
15 changed files with 326 additions and 223 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/Config.hs
+2 -1
View File
@@ -84,7 +84,8 @@ data DebugBool
| Cr_status
| Cr_awareness
| Mouse_position
| View_boundaries
| View_gr_boundaries
| View_rm_boundaries
| Walls_info
| Pathing
| Remove_LOS
src/Dodge/Debug.hs
+4 -2
View File
@@ -57,7 +57,8 @@ debugItem = \case
Close_shape_culling -> mempty
Bound_box_screen -> mempty
Show_ms_frame -> mempty
View_boundaries -> mempty
View_gr_boundaries -> mempty
View_rm_boundaries -> mempty
Show_bound_box -> mempty
Show_wall_search_rays -> mempty
Show_dda_test -> mempty
@@ -227,7 +228,8 @@ drawDebug u = \case
Close_shape_culling -> mempty
Bound_box_screen -> mempty
Show_ms_frame -> mempty
View_boundaries -> viewBoundaries $ _uvWorld u
View_gr_boundaries -> viewGameRoomBoundaries $ _uvWorld u
View_rm_boundaries -> viewRoomBoundaries $ _uvWorld u
Show_bound_box -> drawBoundingBox $ _uvWorld u
Show_wall_search_rays -> drawWallSearchRays $ _uvWorld u
Show_dda_test -> drawDDATest $ _uvWorld u
src/Dodge/Debug/Picture.hs
+11 -2
View File
@@ -329,8 +329,8 @@ drawWallSearchRays w = foldMap (f . fst) $ allVisibleWalls w
uncurryV translate p (circle 5)
<> line [w ^. wCam . camViewFrom, p]
viewBoundaries :: World -> Picture
viewBoundaries w =
viewGameRoomBoundaries :: World -> Picture
viewGameRoomBoundaries w =
setLayer DebugLayer $
color green (foldMap (polygonWire . _grBound) grs)
<> color yellow (foldMap (\q -> line [p, q]) $ getViewpoints p (_cWorld w))
@@ -338,6 +338,15 @@ viewBoundaries w =
p = w ^. wCam . camViewFrom
grs = filter (pointInOrOnPolygon p . _grBound) (_cwgGameRooms $ _cwGen $ _cWorld w)
viewRoomBoundaries :: World -> Picture
viewRoomBoundaries w =
setLayer DebugLayer $
color green (foldMap (foldMap polygonWire . _grRmBounds) grs)
-- <> color yellow (foldMap (\q -> line [p, q]) $ getViewpoints p (_cWorld w))
where
p = w ^. wCam . camViewFrom
grs = filter (pointInOrOnPolygon p . _grBound) (_cwgGameRooms $ _cwGen $ _cWorld w)
viewClipBounds :: Config -> World -> Picture
viewClipBounds cfig w
| _debug_view_clip_bounds cfig == AllRoomClipBoundaries =
src/Dodge/Floor.hs
+1 -1
View File
@@ -24,7 +24,7 @@ initialRoomTree :: State LayoutVars MTRS
initialRoomTree =
foldMTRS $
intersperse
(zoom lyGen corDoor)
(zoom lyGen doorCor)
[ intAnno startRoom
, passthroughLockKeyLists
[(sensorRoomRunPast ElectricSensor, takeOne
src/Dodge/GameRoom.hs
+1
View File
@@ -13,6 +13,7 @@ data GameRoom = GameRoom
{ _grViewpoints :: [Point2]
, _grViewpointsEx :: [Point2]
, _grBound :: [Point2]
, _grRmBounds :: [[Point2]]
, -- | gives direction of room
_grDir :: Float
, _grLinkDirs :: [Float]
src/Dodge/Layout.hs
+1
View File
@@ -162,6 +162,7 @@ gameRoomFromRoom rm =
expandPolyCorners 50 . convexHullSafe . nubBy closePoints
. concat
$ _rmBound rm ++ _rmPolys rm
, _grRmBounds = map (map doshift) $ _rmBound rm
, _grDir = getDir $ _rmPos rm
, _grLinkDirs = mapMaybe undir $ _rmPos rm
, _grName = _rmName rm
src/Dodge/Room/Corridor.hs
+4 -3
View File
@@ -20,10 +20,11 @@ corridor =
{ _rmPolys = [poly]
, _rmLinks = lnks'
, --, _rmPath = foldMap (doublePairSet . (,) (V2 20 60) . fst) lnks
_rmPath = foldMap (doublePairSet . (,) (V2 20 60)) [V2 20 70, V2 20 10]
_rmPath = foldMap (doublePairSet . (,) (V2 20 60)) [V2 20 70, V2 20 5]
--, _rmPmnts = [spanLightI (V2 0 39.5) (V2 40 39.5)]
, _rmPmnts = []
, _rmBound = [rectNSWE 50 30 (-5) 45]
, _rmBound = [rectNSWE 45 35 (-5) 45]
-- , _rmBound = [rectNSWE 50 40 (-5) 45]
, _rmFloor = Tiled [makeTileFromPoly poly 5]
, _rmRandPSs = [psRandRanges (10, 30) (30, 60) (0, 2 * pi)]
, _rmName = "Corridor"
@@ -38,7 +39,7 @@ corridor =
, outLink (V2 20 70) (negate $ pi / 4)
, outLink (V2 20 70) (pi / 6)
, outLink (V2 20 70) (negate $ pi / 6)
, inLink (V2 20 10) pi
, inLink (V2 20 5) pi
]
keyholeCorridor :: Room
src/Dodge/Room/Door.hs
+1
View File
@@ -19,6 +19,7 @@ door =
, -- door extends into side walls (for shadows as rendered 12/03)
_rmPmnts = [putAutoDoor (V2 0 20) (V2 40 20)]
, _rmName = "autoDoor"
-- , _rmBound = [rectNSWE 21 19 0 40]
, _rmBound = [rectNSWE 21 19 0 40]
}
where
src/Dodge/Room/LasTurret.hs
+28 -2
View File
@@ -11,6 +11,7 @@ module Dodge.Room.LasTurret (
lasCenRunClose,
) where
import Dodge.Room.Procedural
import qualified Data.Set as S
import Dodge.Cleat
import Dodge.Data.GenWorld
@@ -141,8 +142,8 @@ lasCenSensEdge n = do
, treePost [door, cleatLabel 0 corridor]
]
lasCenRunClose :: (RandomGen g) => State g (MetaTree Room String)
lasCenRunClose = do
lasCenRunClose' :: (RandomGen g) => State g (MetaTree Room String)
lasCenRunClose' = do
thelight <- mntLightLnkCond $ rprBool $ const . isInLnk
thelight1 <- mntLightLnkCond $ rprBool $ const . isOutLnk
r <-
@@ -169,6 +170,31 @@ lasCenRunClose = do
inlinkwall = linkwall isInLnk
outlinkwall = linkwall isOutLnk
lasCenRunClose :: (RandomGen g) => State g (MetaTree Room String)
lasCenRunClose = do
r <-
roomRectAutoLights 250 250
<&> rmPmnts
<>~ [ putLasTurret 0.02 & plSpot .~ PS (V2 220 20) 0
, inlinkwall 70 (rectNSWE 10 (-10) (-10) 30)
, inlinkwall 125 (rectNSWE 55 (-55) (-10) 10)
, inlinkwall 180 (rectNSWE 10 (-10) (-30) 10)
, outlinkwall 70 (rectNSWE 10 (-10) (-30) 10)
, outlinkwall 125 (rectNSWE 55 (-55) (-10) 10)
, outlinkwall 180 (rectNSWE 10 (-10) (-10) 30)
]
<&> rmLinks %~ setInLinks (memtest (FromEdge West 0) (OnEdge South))
<&> rmLinks %~ setOutLinks (memtest (FromEdge East 0) (OnEdge North))
rToOnward "lasCenRunClose" $ return $ cleatOnward r
where
memtest a b x = let y = _rlType x
in a `S.member` y && b `S.member` y
linkwall f x = heightWallPS
(resetPLUse $ rprBoolShift (const . f) (shiftInBy x <&> (,S.singleton UsedPosLow)))
30
inlinkwall = linkwall isInLnk
outlinkwall = linkwall isOutLnk
lasTunnel :: (RandomGen g) => Float -> State g Room
lasTunnel y = do
extraPlmnts <-
src/Dodge/Room/Room.hs
+10 -2
View File
@@ -8,6 +8,7 @@ module Dodge.Room.Room (
pistolerRoom,
spawnerRoom,
corDoor,
doorCor,
weaponBehindPillar,
critsRoom,
distributerRoom,
@@ -395,10 +396,15 @@ spawnerRoom = do
aRoom <- airlock
return $ treeFromTrunk [aRoom, corridor] $ pure $ cleatOnward roomWithSpawner
doorCor :: RandomGen g => State g (MetaTree Room String)
doorCor = do
cor <- shuffleLinks (cleatOnward corridor) <&> rmPmnts .~ []
return $ tToBTree "doorCor" $ treePost [door, cor]
corDoor :: RandomGen g => State g (MetaTree Room String)
corDoor = do
cor <- shuffleLinks (cleatOnward corridor) <&> rmPmnts .~ []
return $ tToBTree "corDoor" $ treePost [door, cor]
cor <- shuffleLinks corridor <&> rmPmnts .~ []
return $ tToBTree "corDoor" $ treePost [cor,cor, cleatOnward door]
critsPillarRoom :: Int -> State LayoutVars Room
critsPillarRoom i = do
@@ -452,6 +458,8 @@ distributerRoom atype aamount = do
)
return $ r & rmPmnts .:~ store
& rmInPmnt <>~ [(0,dst),(1,thepipe)]
& rmLinks %~ setInLinksByType (OnEdge South)
& rmLinks %~ setOutLinks (not . S.member (OnEdge South) . _rlType)
tmDistributeLines :: [TerminalLine]
tmDistributeLines = [TLine 1 [TerminalLineConst "ATTEMPTING TO DISTRIBUTE MATERIAL..." white] TmDistributeAmmo]
src/Dodge/Room/Tutorial.hs
+36 -35
View File
@@ -52,43 +52,44 @@ tutAnoTree :: State LayoutVars MTRS
tutAnoTree = do
foldMTRS
[ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
-- , return . tToBTree "door" $ treePost [corridor, cleatOnward door]
, corDoor
, tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
, lasCenRunClose
-- , passthroughLockKeyLists lockRoomKeyItems itemRooms
, tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
-- , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
-- , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
-- , passthroughLockKeyLists
-- [(sensorRoomRunPast ElectricSensor, takeOne
-- [-- CRAFT (ENERGYBALLCRAFT TeslaBall) ,
-- HELD SPARKGUN])]
-- itemRooms
-- , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
-- , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
, tToBTree "sdr" . return . cleatOnward <$>
(shuffleLinks =<< distributerRoom BulletAmmo 100000)
-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
-- --, tToBTree "sdr" . return . cleatOnward <$> slowDoorRoom
---- , tToBTree "sr" . return . cleatOnward <$> tanksRoom [] []
-- , return $ tToBTree "door" $ return $ cleatOnward door
-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
-- , tToBTree "sdr" . return . cleatOnward <$>
-- (shuffleLinks =<< tanksPipesRoom)
-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
, return $ tToBTree "cor" $ return $ cleatOnward corridor
, return $ tToBTree "cor" $ return $ cleatOnward corridor
, return $ tToBTree "cor" $ return $ cleatOnward corridor
, return $ tToBTree "door" $ return $ cleatOnward door
, tutHub
, chasmSpitTerminal
, tutLight
, tutDrop
, return $ tToBTree "cor" $ return $ cleatOnward corridor
---- , AnTree $ pickupTut
---- , AnTree $ weaponTut
--aaa , lasCenRunClose
--aaa-- , passthroughLockKeyLists lockRoomKeyItems itemRooms
--aaa , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
--aaa-- , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
--aaa-- , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
--aaa-- , passthroughLockKeyLists
--aaa-- [(sensorRoomRunPast ElectricSensor, takeOne
--aaa-- [-- CRAFT (ENERGYBALLCRAFT TeslaBall) ,
--aaa-- HELD SPARKGUN])]
--aaa-- itemRooms
--aaa-- , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
--aaa-- , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
--aaa , tToBTree "sdr" . return . cleatOnward <$>
--aaa (shuffleLinks =<< distributerRoom BulletAmmo 100000)
--aaa-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
--aaa-- --, tToBTree "sdr" . return . cleatOnward <$> slowDoorRoom
--aaa---- , tToBTree "sr" . return . cleatOnward <$> tanksRoom [] []
--aaa-- , return $ tToBTree "door" $ return $ cleatOnward door
--aaa-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
--aaa-- , tToBTree "sdr" . return . cleatOnward <$>
--aaa-- (shuffleLinks =<< tanksPipesRoom)
--aaa-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
--aaa-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
--aaa-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
--aaa , return $ tToBTree "cor" $ return $ cleatOnward corridor
--aaa , return $ tToBTree "cor" $ return $ cleatOnward corridor
--aaa , return $ tToBTree "cor" $ return $ cleatOnward corridor
--aaa , return $ tToBTree "door" $ return $ cleatOnward door
--aaa , tutHub
--aaa , chasmSpitTerminal
--aaa , tutLight
--aaa , tutDrop
--aaa , return $ tToBTree "cor" $ return $ cleatOnward corridor
--aaa ---- , AnTree $ pickupTut
--aaa ---- , AnTree $ weaponTut
]
foldMTRS ::
src/Dodge/Tree/Shift.hs
+5 -1
View File
@@ -10,6 +10,7 @@ module Dodge.Tree.Shift (
PosRooms (..),
) where
import Data.Monoid
import Control.Lens
import Data.Bifunctor
import Data.List (delete)
@@ -66,7 +67,9 @@ posRms prs parenti@(parent, _) ((numChild, t@(Node childi _)) : its) tseq = do
where
tryChildLinks [] = tryParentLinks ls
tryChildLinks ((numinlink, il) : ils)
| clipping = tryChildLinks ils
| Just xs <- clipping' = do
putStrLn $ show xs
tryChildLinks ils
| otherwise = do
putStrLn $ show j ++ "-" ++ show numinlink
mayrs <-
@@ -83,6 +86,7 @@ posRms prs parenti@(parent, _) ((numChild, t@(Node childi _)) : its) tseq = do
where
newBounds = map pointsToPoly . _rmBound . doRoomShift . fst $ rootLabel shiftedt
clipping = or (convexPolysOverlap <$> newBounds <*> _prBounds prs)
clipping' = getFirst . foldMap First $ convexPolysOverlapWitness <$> newBounds <*> _prBounds prs
updateparent rm =
_rmLinkEff rm il child numChild outlnk rm
& rmLinks %~ delete outlnk
src/Geometry/ConvexPoly.hs
+37
View File
@@ -9,6 +9,7 @@ module Geometry.ConvexPoly (
-- , centroid
pointsToPoly,
convexPolysOverlap,
convexPolysOverlapWitness,
) where
import Control.Lens
@@ -18,6 +19,7 @@ import Geometry.Data
import Geometry.Intersect
import Geometry.Polygon
import Geometry.Vector
import Control.Applicative
--import qualified Control.Foldl as L
data ConvexPoly = ConvexPoly
@@ -48,6 +50,13 @@ convexPolysOverlap cp1 cp2 =
dist (_cpCen cp1) (_cpCen cp2) < _cpRad cp1 + _cpRad cp2
&& polyPointsOverlap (_cpPoints cp1) (_cpPoints cp2)
-- | Test whether two polygons intersect or if one is contained in the other,
-- with witness.
convexPolysOverlapWitness :: ConvexPoly -> ConvexPoly -> Maybe (ConvexPoly, ConvexPoly,String)
convexPolysOverlapWitness cp1 cp2
| Just s <- polyPointsOverlapWitness (_cpPoints cp1) (_cpPoints cp2) = Just (cp1,cp2,s)
| otherwise = Nothing
-- | Test whether two polygons intersect or if one is contained in the other.
polyPointsOverlap :: [Point2] -> [Point2] -> Bool
@@ -57,6 +66,14 @@ polyPointsOverlap (p : ps) (q : qs) =
|| polyPointsIntersect (p : ps) (q : qs)
polyPointsOverlap _ _ = False
-- | Test whether two polygons intersect or if one is contained in the other.
polyPointsOverlapWitness :: [Point2] -> [Point2] -> Maybe String
polyPointsOverlapWitness (p : ps) (q : qs)
| pointInPoly p (q : qs) = Just $ "Contained: "<> show p <> " in " <> show (q:qs)
| pointInPoly q (p : ps) = Just $ "Contained: "<> show p <> " in " <> show (q:qs)
| otherwise = polyPointsIntersectWitness (p : ps) (q : qs)
polyPointsOverlapWitness _ _ = Nothing
polyPointsIntersect :: [Point2] -> [Point2] -> Bool
polyPointsIntersect (a : b : xs) ps = go a (a : b : xs) ps
where
@@ -65,6 +82,14 @@ polyPointsIntersect (a : b : xs) ps = go a (a : b : xs) ps
go _ _ _ = False
polyPointsIntersect _ _ = False
polyPointsIntersectWitness :: [Point2] -> [Point2] -> Maybe String
polyPointsIntersectWitness (a : b : xs) ps = go a (a : b : xs) ps
where
go x' (a' : b' : xs') ps' = pairPolyPointsIntersectWitness a' b' ps' <|> go x' (b' : xs') ps'
go b' [a'] ps' = pairPolyPointsIntersectWitness a' b' ps'
go _ _ _ = Nothing
polyPointsIntersectWitness _ _ = Nothing
pairPolyPointsIntersect :: Point2 -> Point2 -> [Point2] -> Bool
pairPolyPointsIntersect a' b' (c' : d' : xs') = go c' a' b' (c' : d' : xs')
where
@@ -73,5 +98,17 @@ pairPolyPointsIntersect a' b' (c' : d' : xs') = go c' a' b' (c' : d' : xs')
go _ _ _ _ = False
pairPolyPointsIntersect _ _ _ = False
pairPolyPointsIntersectWitness :: Point2 -> Point2 -> [Point2] -> Maybe String
pairPolyPointsIntersectWitness a' b' (c' : d' : xs') = go c' a' b' (c' : d' : xs')
where
go x a b (c : d : xs)
| intersectSegSegTest a b c d = Just $ show a <> " " <> show b <> " " <> show c <> " " <> show d
| otherwise = go x a b (d : xs)
go d a b [c]
| intersectSegSegTest a b c d = Just $ show a <> " " <> show b <> " " <> show c <> " " <> show d
| otherwise = Nothing
go _ _ _ _ = Nothing
pairPolyPointsIntersectWitness _ _ _ = Nothing
makeLenses ''ConvexPoly
deriveJSON defaultOptions ''ConvexPoly
src/Geometry/Intersect.hs
+4 -2
View File
@@ -151,8 +151,10 @@ intersectSegSegTest x y z w =
f x y z w && f z w x y && x /= y && z /= w
where
f a b c d =
(not (isRHS a b c) && not (isLHS a b d))
|| (not (isLHS a b c) && not (isRHS a b d))
-- (not (isRHS a b c) && not (isLHS a b d))
-- || (not (isLHS a b c) && not (isRHS a b d))
(isRHS a b c && isLHS a b d)
|| (isLHS a b c && isRHS a b d)
intersectSegSegPreTest ::
Point2 ->