Work on gibs and chasms

src/Dodge/Base/Collide.hs

@@ -33,9 +33,11 @@ module Dodge.Base.Collide (
     canSeeIndirect,
     isWalkable,
     anythingHitCirc,
+    collide3,
 ) where
 
 --import qualified Data.IntMap.Strict as IM
+import Control.Monad
 import Dodge.Creature.Radius
 import Control.Lens
 import qualified Data.IntSet as IS
@@ -47,21 +49,13 @@ import Dodge.Zoning
 import FoldableHelp
 import Geometry
 
-collidePoint ::
-    Point2 ->
-    Point2 ->
-    [Wall] ->
-    (Point2, Maybe Wall)
+collidePoint :: Point2 -> Point2 -> [Wall] -> (Point2, Maybe Wall)
 {-# INLINE collidePoint #-}
 collidePoint sp ep = foldl' findPoint (ep, Nothing)
   where
     findPoint (p, mwl) wl = maybe (p, mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl
 
-overlapSegCrs ::
-    Point2 ->
-    Point2 ->
-    [Creature] ->
-    [(Point2, Creature)]
+overlapSegCrs :: Point2 -> Point2 -> [Creature] -> [(Point2, Creature)]
 {-# INLINE overlapSegCrs #-}
 overlapSegCrs sp ep =
     mapMaybe
@@ -89,6 +83,37 @@ bouncePoint :: (Wall -> Bool) -> Float -> Point2 -> Point2 -> World -> Maybe (Po
 {-# INLINE bouncePoint #-}
 bouncePoint t x sp ep = doBounce x sp ep . collidePointWallsFilter t sp ep
 
+collide3 :: Point3 -> Point3 -> World -> (Point3, Maybe Point3)
+collide3 sp ep w = collide3Floors sp (w ^. cWorld . chasms) 
+    $ collide3Walls sp w (ep,Nothing)
+
+-- Just (hitpoint,normaltosurface)
+collide3Walls :: Point3 -> World -> (Point3, Maybe Point3) -> (Point3, Maybe Point3)
+collide3Walls sp w (ep,mn) = collide3Part sp wsfs (ep,mn)
+  where
+    wsfs = fmap f $ wlsNearSeg (xyV3 sp) (xyV3 ep) w
+    f wl = (g x, g $ vNormal (y-x), [(g x,g (y-x)),(g y,g (x-y))])
+      where
+        g = (`v2z` 0)
+        (x,y) = _wlLine wl
+
+collide3Floors :: Point3 -> [[Point2]] -> (Point3, Maybe Point3) -> (Point3, Maybe Point3)
+collide3Floors sp cs (ep,mn) = maybe (ep,mn) (,Just (V3 0 0 1)) mp
+  where
+    mp = do
+        V3 x y z <- intersectSegPlane sp ep (V3 0 0 0) (V3 0 0 1)
+        let g (a,b) = isRHS a b (V2 x y)
+            f = any g
+        guard (all f $ map loopPairs cs)
+        return $ V3 x y z
+
+collide3Part :: Point3 -> [(Point3,Point3,[(Point3,Point3)])] 
+    -> (Point3, Maybe Point3)
+    -> (Point3, Maybe Point3)
+collide3Part sp = flip $ foldl' findPoint
+  where
+    findPoint (x,mn) (p,n,ss) = maybe (x,mn) (,Just n) $ intersectSegSurface sp x p n ss
+
 -- this COULD be written in terms of collidePointWallsFilterStream, TODO test
 -- whether this is actually faster
 collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> [Wall] -> Bool
@@ -107,10 +132,7 @@ collidePointTestFilter t sp ep =
 
 collidePointWallsFilter :: (Wall -> Bool) -> Point2 -> Point2 -> World -> (Point2, Maybe Wall)
 {-# INLINE collidePointWallsFilter #-}
-collidePointWallsFilter t sp ep =
-    collidePoint sp ep
-        . filter t
-        . wlsNearSeg sp ep
+collidePointWallsFilter t sp ep = collidePoint sp ep . filter t . wlsNearSeg sp ep
 
 --overlapSegWalls :: Point2 -> Point2 -> StreamOf Wall
 --    -> StreamOf (Point2,Wall)