Improve segment intersection test, tweak room bounding

src/Dodge/Room/Corridor.hs

@@ -23,8 +23,8 @@ corridor =
           _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 45 35 (-5) 45]
+--        , _rmBound = [rectNSWE 45 35 (-5) 45]
---        , _rmBound = [rectNSWE 50 40 (-5) 45]
+        , _rmBound = [rectNSWE 60 15 (-5) 45]
         , _rmFloor = Tiled [makeTileFromPoly poly 5]
         , _rmRandPSs = [psRandRanges (10, 30) (30, 60) (0, 2 * pi)]
         , _rmName = "Corridor"

src/Dodge/Room/Room.hs

@@ -404,6 +404,7 @@ doorCor = do
 corDoor :: RandomGen g => State g (MetaTree Room String)
 corDoor = do
     cor <- shuffleLinks corridor <&> rmPmnts .~ []
+--    let cor = corridorN
     return $ tToBTree "corDoor" $ treePost [cor,cor, cleatOnward door]
 
 critsPillarRoom :: Int -> State LayoutVars Room

src/Dodge/Room/Tutorial.hs

@@ -55,20 +55,21 @@ tutAnoTree = do
 --        , return . tToBTree "door" $ treePost [corridor, cleatOnward door]
         , corDoor
 --        , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
---aaa        , lasCenRunClose
+        , lasCenRunClose
---aaa--        , passthroughLockKeyLists lockRoomKeyItems itemRooms
+--        , passthroughLockKeyLists lockRoomKeyItems itemRooms
---aaa        , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
+        , tToBTree "door" . return <$> return (cleatOnward door)
---aaa--        , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
+        , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
---aaa--        , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
+--        , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
---aaa--            , passthroughLockKeyLists
+--        , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
---aaa--                    [(sensorRoomRunPast ElectricSensor, takeOne 
+--            , passthroughLockKeyLists
---aaa--                        [-- CRAFT (ENERGYBALLCRAFT TeslaBall) , 
+--                    [(sensorRoomRunPast ElectricSensor, takeOne 
---aaa--                        HELD SPARKGUN])]
+--                        [-- CRAFT (ENERGYBALLCRAFT TeslaBall) , 
---aaa--                    itemRooms
+--                        HELD SPARKGUN])]
---aaa--        , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
+--                    itemRooms
---aaa--        , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
+--        , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
---aaa        , tToBTree "sdr" . return . cleatOnward <$> 
+--        , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
---aaa                (shuffleLinks =<< distributerRoom BulletAmmo 100000)
+        , tToBTree "sdr" . return . cleatOnward <$> 
+                (shuffleLinks =<< distributerRoom BulletAmmo 100000)
 --aaa--        , return $ tToBTree "cor" $ return $ cleatOnward corridor
 --aaa--        --, tToBTree "sdr" . return . cleatOnward <$> slowDoorRoom
 --aaa----        , tToBTree "sr" . return . cleatOnward <$> tanksRoom [] []

src/Dodge/Tree/Shift.hs

@@ -10,7 +10,7 @@ module Dodge.Tree.Shift (
     PosRooms (..),
 ) where
 
-import Data.Monoid
+--import Data.Monoid
 import Control.Lens
 import Data.Bifunctor
 import Data.List (delete)
@@ -67,9 +67,10 @@ posRms prs parenti@(parent, _) ((numChild, t@(Node childi _)) : its) tseq = do
       where
         tryChildLinks [] = tryParentLinks ls
         tryChildLinks ((numinlink, il) : ils)
-            | Just xs <- clipping' = do
+--            | Just xs <- clipping' = do
-                putStrLn $ show xs
+--                putStrLn $ show xs
-                tryChildLinks ils
+--                tryChildLinks ils
+            | clipping = tryChildLinks ils
             | otherwise = do
                 putStrLn $ show j ++ "-" ++ show numinlink
                 mayrs <-
@@ -86,7 +87,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
+--            clipping' = getFirst . foldMap First $ convexPolysOverlapWitness <$> newBounds <*> _prBounds prs
             updateparent rm =
                 _rmLinkEff rm il child numChild outlnk rm
                     & rmLinks %~ delete outlnk

src/Geometry/Intersect.hs

@@ -139,22 +139,18 @@ intersectSegSegFullTest x y z w =
 
 {- | It is not always necessary to find a point of intersection, sometimes a
  test may suffice.
+This should intersect on endpoints.
 -}
-intersectSegSegTest ::
+intersectSegSegTest :: Point2 -> Point2 -> Point2 -> Point2 -> Bool
-    Point2 ->
-    Point2 ->
-    Point2 ->
-    Point2 ->
-    Bool
 {-# INLINE intersectSegSegTest #-}
 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 =
+    f a b c d = compareLHS a b c /= compareLHS 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)
+--        (isRHS a b c && isLHS a b d)
-            || (isLHS a b c && isRHS a b d)
+--            || (isLHS a b c && isRHS a b d)
 
 intersectSegSegPreTest ::
     Point2 ->

src/Geometry/LHS.hs

@@ -1,6 +1,7 @@
 module Geometry.LHS (
     isLHS,
     isRHS,
+    compareLHS,
 ) where
 
 import Geometry.Data
@@ -26,6 +27,17 @@ isLHS (V2 x y) (V2 x' y') (V2 x'' y'')
     b1 = x'' - x
     b2 = y'' - y
 
+compareLHS :: Point2 -> Point2 -> Point2 -> Ordering
+{-# INLINE compareLHS #-}
+compareLHS (V2 x y) (V2 x' y') (V2 x'' y'')
+    | (x, y) == (x', y') = EQ
+    | otherwise = compare (a1 * b2 - a2 * b1) 0
+  where
+    a1 = x' - x
+    a2 = y' - y
+    b1 = x'' - x
+    b2 = y'' - y
+
 {- | Test whether a point is on the RHS of a line.
  Returns False if the line is of zero length.
 -}