Work on gibs and chasms

data/dodge.config.json

@@ -1,7 +1,8 @@
 {
   "_debug_booleans": [
     "Show_ms_frame",
-    "Mouse_position"
+    "Mouse_position",
+    "Collision_test"
   ],
   "_debug_view_clip_bounds": "NoRoomClipBoundaries",
   "_gameplay_rotate_to_wall": true,

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 ::
+collidePoint :: Point2 -> Point2 -> [Wall] -> (Point2, Maybe Wall)
-    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 ::
+overlapSegCrs :: Point2 -> Point2 -> [Creature] -> [(Point2, Creature)]
-    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 =
+collidePointWallsFilter t sp ep = collidePoint sp ep . filter t . wlsNearSeg sp ep
-    collidePoint sp ep
-        . filter t
-        . wlsNearSeg sp ep
 
 --overlapSegWalls :: Point2 -> Point2 -> StreamOf Wall
 --    -> StreamOf (Point2,Wall)

src/Dodge/Block/Debris.hs

@@ -145,7 +145,6 @@ stoneDebris =
         , _prUpdate = PropFallSmallBounceDamage
         , _prPosZ = 10
         , _prVelZ = 5
-        , _prTimer = 20
         , _prQuat = Q.axisAngle (V3 1 0 0) 0
         , _prQuatSpin = Q.axisAngle (V3 1 1 0) 0.1
         , _prColor = greyN 0.5

src/Dodge/Creature/Damage.hs

@@ -24,7 +24,7 @@ applyPiercingDamage cr dm
     | crIsArmouredFrom p cr = f . makeSpark NormalSpark p1 (argV (p1 - p))
     | otherwise = f . damageHP cr (_dmAmount dm)
   where
-    f = cWorld . lWorld . creatures . ix (_crID cr) . crPos -~ _dmVector dm
+    f = cWorld . lWorld . creatures . ix (_crID cr) . crPos +~ _dmVector dm
             / V2 x x
     x = crMass (_crType cr)
     p = _dmPos dm

src/Dodge/Creature/Update.hs

@@ -2,13 +2,10 @@ module Dodge.Creature.Update (
     updateCreature,
 ) where
 
-import Picture.Base
 import LensHelp
 import Geometry
 import Dodge.SoundLogic
 import Dodge.Creature.Radius
-import Geometry.Polygon
-import Control.Lens
 import Dodge.Creature.YourControl
 import Dodge.Creature.State
 import Dodge.Barreloid
@@ -24,12 +21,12 @@ updateCreature cr = chasmTest cr . case _crType cr of
     LampCrit{} -> updateLampoid cr
     BarrelCrit bt -> updateBarreloid bt cr
     AvatarDead -> id
-    _ -> updateHumanoid cr
+    _ -> crUpdate updateHumanoid cr
 
 chasmTest :: Creature -> World -> World
 chasmTest cr w
     | _crZVel cr < 0 = w & cWorld . lWorld . creatures . ix (_crID cr) . crZVel -~ 1
-        & cWorld . lWorld . creatures . ix (_crID cr) . crZ +~ (_crZVel cr)
+        & cWorld . lWorld . creatures . ix (_crID cr) . crZ +~ _crZVel cr
     | Just (x,y) <- List.find g (foldMap loopPairs $ w ^. cWorld . chasms) = w
         & soundContinue (CrChasm (_crID cr)) (_crPos cr) debrisS (Just 100)
         & cWorld . lWorld . creatures . ix (_crID cr) . crPos -~ normalizeV (vNormal (x-y))

src/Dodge/Data/LWorld.hs

@@ -104,6 +104,7 @@ data LWorld = LWorld
     , _dusts :: [Dust]
     , _gusts :: IM.IntMap Gust
     , _props :: IM.IntMap Prop
+    , _debris :: [Debris]
     , _projectiles :: IM.IntMap Projectile
     , _bullets :: [Bullet]
     , _radarSweeps :: [RadarSweep]

src/Dodge/Data/Prop.hs

@@ -5,6 +5,7 @@
 
 module Dodge.Data.Prop where
 
+import Dodge.Data.Material
 import Color
 import Control.Lens
 import Data.Aeson
@@ -25,7 +26,6 @@ data Prop
         , _prID :: Int
         , _prPosZ :: Float
         , _prVelZ :: Float
-        , _prTimer :: Int
         , _prQuat :: Q.Quaternion Float
         , _prQuatSpin :: Q.Quaternion Float
         , _prColor :: Color
@@ -40,6 +40,21 @@ data Prop
         }
     --deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
+data DebrisType =
+    Gib {_gibSize :: Float
+        ,_gibColor :: Color
+        }
+
+data Debris = DebrisChunk
+        { _dbPos :: Point3
+        , _dbType :: DebrisType
+        , _dbVel :: Point3
+        , _dbRot :: Q.Quaternion Float
+        , _dbSpin :: Q.Quaternion Float
+        }
+
+data PropType = FallingBlock Material
+
 data PropDraw
     = PropDrawSPic SPic
     | PropDrawMovingShapeCol Shape
@@ -73,6 +88,10 @@ data PrWdLsLs
     --deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 makeLenses ''Prop
+makeLenses ''Debris
+makeLenses ''DebrisType
+deriveJSON defaultOptions ''DebrisType
+deriveJSON defaultOptions ''Debris
 deriveJSON defaultOptions ''PropDraw
 deriveJSON defaultOptions ''PrWdLsLs
 deriveJSON defaultOptions ''PropUpdate

src/Dodge/Debug/Picture.hs

@@ -106,7 +106,12 @@ drawCollisionTest w = concat $ do
     b <- w ^. input . heldWorldPos . at ButtonRight
     return $
         setLayer DebugLayer (color orange $ line [a, b])
-            <> foldMap (drawCrossCol red . fst) (thingHit a b w)
+            <> foldMap (drawCrossCol red 
+--                  . xyV3
+                    . fst) 
+--                (collide3 (v2z a 0) (v2z b 0) w)
+--                (collide3Floors (v2z a 10) (v2z b (-10)) $ w ^. cWorld . chasms)
+                (thingHit a b w)
 
 drawCircCollisionTest :: World -> Picture
 drawCircCollisionTest w = concat $ do

src/Dodge/Default/World.hs

@@ -108,6 +108,7 @@ defaultLWorld =
         , _gusts = IM.empty
         , _itemLocations = IM.empty
         , _props = IM.empty
+        , _debris = mempty
         , _projectiles = IM.empty
         , _bullets = []
         , _flames = []

src/Dodge/Humanoid.hs

@@ -185,7 +185,7 @@ humanoidAIList ::
     World ->
     World
 humanoidAIList
-    = crUpdate . impulsiveAIBefore . chainCreatureUpdates
+    = impulsiveAIBefore . chainCreatureUpdates
 
 -- bit of a hack to get new random generators after each creature's update
 defaultImpulsive ::

src/Dodge/Prop/Draw.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE LambdaCase #-}
 module Dodge.Prop.Draw (
     propSPic,
+    debrisSPic,
 ) where
 
 import Control.Lens
@@ -15,6 +16,11 @@ import ShapePicture
 propSPic :: Prop -> SPic
 propSPic pr = drawProp (_prDraw pr) pr
 
+debrisSPic :: Debris -> SPic
+debrisSPic db = translateSP (_dbPos db) . overPosSP (Q.rotate (_dbRot db)) $
+     case db ^. dbType of
+        Gib x col -> noPic $ drawGib' x col
+
 drawProp :: PropDraw -> Prop -> SPic
 drawProp = \case
     PropDrawSPic spic -> const spic
@@ -39,6 +45,17 @@ drawGib x pr = flesh <> skin
             translateSH (V3 1 1 (1 - x)) baseCube
     baseCube = upperPrismPoly Small Typical (2 * x) $ square x
 
+drawGib' :: Float -> Color -> Shape
+drawGib' x col = flesh <> skin
+  where
+    flesh =
+        colorSH (dark $ dark red) $
+            translateSHz (negate x) (baseCube & each . sfShadowImportance .~ Superfluous)
+    skin =
+        colorSH col $
+            translateSH (V3 1 1 (1 - x)) baseCube
+    baseCube = upperPrismPoly Small Typical (2 * x) $ square x
+
 propDrawToggle :: PropDraw -> Prop -> SPic
 propDrawToggle pd pr
     | not (_prToggle pr) = mempty

src/Dodge/Prop/Gib.hs

@@ -26,7 +26,6 @@ aGib =
         , _prUpdate = PropFallSmallBounce
         , _prPosZ = 10
         , _prVelZ = 5
-        , _prTimer = 20
         , _prQuat = Q.axisAngle (V3 1 0 0) 0
         , _prQuatSpin = Q.axisAngle (V3 1 1 0) 0.1
         , _prColor = white
@@ -73,13 +72,18 @@ addGibsAtDir dir minh maxh col p w =
     quats :: [Q.Quaternion Float]
     quats = replicateM 4 (Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere) & evalState $ _randGen w
 
-addGib4 ::
+addGib4 :: Point2 -> Color -> (Point2, Float, QFloat, Float) -> World -> World
-    Point2 ->
+addGib4 p col (v, zs, q, h) = cWorld . lWorld . debris
-    Color ->
+        .:~ DebrisChunk
-    (Point2, Float, Q.Quaternion Float, Float) ->
+            { _dbPos = p `v2z` h
-    World ->
+            , _dbType = Gib 3 col
-    World
+            , _dbVel = v `v2z` zs
-addGib4 p col (v, zs, q, h) =
+            , _dbRot = q
+            , _dbSpin = Q.axisAngle (vNormal v `v2z` 0) (-0.1)
+            }
+            
+addGib4' :: Point2 -> Color -> (Point2, Float, QFloat, Float) -> World -> World
+addGib4' p col (v, zs, q, h) =
     plNew
         (cWorld . lWorld . props)
         prID
@@ -93,7 +97,25 @@ addGib4 p col (v, zs, q, h) =
         )
 
 addGibAt :: Float -> Color -> Point2 -> World -> World
-addGibAt h col p w =
+addGibAt h col p w = addGibAtDir d h col p (w & randGen .~ newg)
+  where
+    (d, newg) = randomR (0, 2 * pi) $ _randGen w
+--    f = do
+--        s <- state $ randomR (1, 4)
+--        dir <- unitVectorAtAngle <$> state (randomR (0, 2 * pi))
+--        zs <- state $ randomR (-8, 8)
+--        q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere
+--        let v = s *.* dir
+--        return $ DebrisChunk
+--            { _dbPos = p `v2z` h
+--            , _dbType = Gib 3 col
+--            , _dbVel = v `v2z` zs
+--            , _dbRot = q
+--            , _dbSpin = Q.axisAngle (vNormal v `v2z` 0) (-0.1)
+--            }
+
+addGibAt' :: Float -> Color -> Point2 -> World -> World
+addGibAt' h col p w =
     w
         & plNew (cWorld . lWorld . props) prID gib
         & randGen .~ newg
@@ -117,6 +139,26 @@ addGibAt h col p w =
 
 addGibAtDir :: Float -> Float -> Color -> Point2 -> World -> World
 addGibAtDir dir h col p w =
+    w
+        & cWorld . lWorld . debris .:~ gib
+        & randGen .~ newg
+  where
+    (gib, newg) = runState f $ _randGen w
+    f = do
+        s <- state $ randomR (1, 4)
+        zs <- state $ randomR (-4, 4)
+        q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere
+        let v = s *.* unitVectorAtAngle dir
+        return $ DebrisChunk
+            { _dbPos = (p +.+ (5 *.* normalizeV v)) `v2z` h
+            , _dbType = Gib 3 col
+            , _dbVel = v `v2z` zs
+            , _dbRot = q
+            , _dbSpin = Q.axisAngle (vNormal v `v2z` 0) (-0.1)
+            }
+
+addGibAtDir' :: Float -> Float -> Color -> Point2 -> World -> World
+addGibAtDir' dir h col p w =
     w
         & plNew (cWorld . lWorld . props) prID gib
         & randGen .~ newg

src/Dodge/Prop/Moving.hs

@@ -1,13 +1,37 @@
 module Dodge.Prop.Moving (
     fallSmallBounceDamage,
     fallSmallBounce,
+    updateDebrisChunk,
 ) where
 
+import Linear.Metric
+import Linear.V3
 import Dodge.Damage
 import Dodge.Base
 import Dodge.Data.World
 import Geometry
 import LensHelp
+import Control.Monad
+
+updateDebrisChunk :: World -> Debris -> (World, Maybe Debris)
+updateDebrisChunk w db = (w, mdb)
+  where
+    cdb' 
+        | norm sv < 0.5 && abs (sp ^. _z) < 0.5 = db
+        | otherwise = cdb
+    sv = db ^. dbVel
+    sp = _dbPos db
+    np = sp + sv
+    cdb = case collide3 sp np w of
+        (p,Nothing) -> db & dbPos .~ p
+            & dbVel -~ V3 0 0 1
+            & dbRot %~ dospin
+        (p,Just n) -> db & dbPos .~ p + (0.0001 * normalize n)
+            & dbVel .~ (0.7 * reflectInNormal n sv) - V3 0 0 1
+    dospin = (_dbSpin db *)
+    mdb = do
+        guard (np > -100)
+        return $ cdb'
 
 fallSmallBounceDamage :: Prop -> World -> World
 fallSmallBounceDamage pr w =

src/Dodge/Render/ShapePicture.hs

@@ -22,6 +22,7 @@ worldSPic :: Configuration -> Universe -> SPic
 worldSPic cfig u =
     (mempty :!: extraPics cfig u)
         <> foldup propSPic (filtOn _prPos _props)
+        <> foldMap' debrisSPic (filtOn' (xyV3 . _dbPos) _debris)
         <> foldup drawProjectile (filtOn _pjPos _projectiles)
         <> foldup drawPulseBall (filtOn _pbPos _pulseBalls)
         <> foldup (shiftDraw _blPos _blDir (drawBlock . _blDraw)) (filtOn _blPos _blocks)
@@ -36,6 +37,7 @@ worldSPic cfig u =
     w = _uvWorld u
     foldup = foldMap'
     filtOn f g = IM.filter (pointIsClose . f) (g (_lWorld (_cWorld w)))
+    filtOn' f g = filter (pointIsClose . f) (g (_lWorld (_cWorld w)))
     pointIsClose = cullPoint cfig w
 
 drawChasm :: [Point2] -> SPic

src/Dodge/TestString.hs

@@ -1,6 +1,8 @@
 {-# OPTIONS_GHC -Wno-unused-imports #-}
 module Dodge.TestString where
 
+import ShortShow
+import Geometry
 import qualified SDL
 import Linear
 import Dodge.ListDisplayParams
@@ -26,7 +28,12 @@ import qualified IntMapHelp as IM
 import qualified Data.Map.Strict as M
 
 testStringInit :: Universe -> [String]
-testStringInit u = map show (M.elems $ u ^. uvWorld . input . pressedKeys)
+testStringInit u = map shortShow (u ^.. uvWorld . cWorld . lWorld . debris . each . to g)
+  where
+    g db = (pz,z,norm v)
+      where
+        v@(V3 _ _ z) = db ^. dbVel
+        (V3 _ _ pz) = db ^. dbPos
         --return . foldMap (prettyLDT (show . (^. _1 . itType))) . invLDT $ _crInv cr
 --  where
 --    idp = invDisplayParams $ u ^. uvWorld

src/Dodge/Update.hs

@@ -7,6 +7,7 @@ Description : Simulation update
 -}
 module Dodge.Update (updateUniverse) where
 
+import Dodge.Prop.Moving
 import Dodge.WorldEvent.Explosion
 import Dodge.Data.Object
 import Color
@@ -278,6 +279,7 @@ functionalUpdate u =
         . over uvWorld updateFlames
         . over uvWorld updateShockwaves
         . over uvWorld updateBullets
+        . over uvWorld updateDebris
         . over uvWorld updateEnergyBalls -- energybs can be created by bullets,
         -- so should probably be updated before bullets
         . over uvWorld updateRadarBlips
@@ -598,6 +600,13 @@ updateBullets w = w' & cWorld . lWorld . bullets <>~ catMaybes ps
         mapAccumR updateBullet (w & cWorld . lWorld . bullets .~ []) $
             w ^. cWorld . lWorld . bullets
 
+updateDebris :: World -> World
+updateDebris w = w' & cWorld . lWorld . debris <>~ catMaybes xs
+  where
+    (w', xs) =
+        mapAccumR updateDebrisChunk (w & cWorld . lWorld . debris .~ []) $
+            w ^. cWorld . lWorld . debris
+
 updateTeslaArcs :: World -> World
 updateTeslaArcs = updateObjCatMaybes teslaArcs updateTeslaArc
 

src/Geometry.hs

@@ -32,6 +32,7 @@ import Geometry.Triangulate
 import Geometry.Vector
 import Geometry.Vector3D
 import ListHelp
+import Linear.Metric
 
 {- | Return a point a distance away from a first point towards a second point.
  Does not go past the second point.
@@ -90,9 +91,9 @@ midPoint !a !b = 0.5 *.* (a +.+ b)
 -}
 circOnSegNoEndpoints :: Point2 -> Point2 -> Point2 -> Float -> Bool
 {-# INLINE circOnSegNoEndpoints #-}
-circOnSegNoEndpoints !p1 !p2 !c !rad = intersectSegSegTest p1 p2 (c -.- norm) (c +.+ norm)
+circOnSegNoEndpoints !p1 !p2 !c !rad = intersectSegSegTest p1 p2 (c -.- n) (c +.+ n)
   where
-    norm = rad *.* vNormal (normalizeV $ p1 -.- p2)
+    n = rad *.* vNormal (normalizeV $ p1 -.- p2)
 
 {- | Test whether a circle is on a segment by intersecting a normal and testing
  the distance to the endpoints of the segment.
@@ -103,9 +104,9 @@ circOnSeg :: Point2 -> Float -> Point2 -> Point2 -> Bool
 circOnSeg !c !rad !p1 !p2 =
     magV (p1 -.- c) <= rad
         || magV (p2 -.- c) <= rad
-        || intersectSegSegTest p1 p2 (c -.- norm) (c +.+ norm)
+        || intersectSegSegTest p1 p2 (c -.- n) (c +.+ n)
   where
-    norm = rad *.* vNormal (normalizeV $ p1 -.- p2)
+    n = rad *.* vNormal (normalizeV $ p1 -.- p2)
 
 {- | Test whether a segment intersects a circle by intersecting a normal and testing
  the distance to the endpoints of the segment.
@@ -115,9 +116,9 @@ segOnCirc :: Point2 -> Point2 -> Point2 -> Float -> Bool
 segOnCirc !p1 !p2 !c !rad =
     magV (p1 -.- c) <= rad
         || magV (p2 -.- c) <= rad
-        || intersectSegSegTest p1 p2 (c -.- norm) (c +.+ norm)
+        || intersectSegSegTest p1 p2 (c -.- n) (c +.+ n)
   where
-    norm = rad *.* vNormal (normalizeV $ p1 -.- p2)
+    n = rad *.* vNormal (normalizeV $ p1 -.- p2)
 
 cylinderOnSeg :: Point3 -> Point3 -> Point3 -> Float -> Bool
 {-# INLINE cylinderOnSeg #-}
@@ -136,6 +137,9 @@ difference x y
 reflectIn :: Point2 -> Point2 -> Point2
 reflectIn line vec = rotateV (2 * angleBetween line vec) vec
 
+reflectInNormal :: Point3 -> Point3 -> Point3
+reflectInNormal n v = v - (2 * project n v)
+
 -- takes an angle of entry (measured from x axis) and two wall points and gives a
 -- reflected angle (from x axis)
 reflectAngle :: Float -> Point2 -> Point2 -> Float

src/Geometry/Intersect.hs

@@ -10,6 +10,9 @@ import Data.Maybe
 import Geometry.Data
 import Geometry.LHS
 import Geometry.Vector
+import Geometry.Vector3D
+import Linear.Metric
+import Control.Monad
 
 -- | If two lines intersect, return 'Just' that point.
 intersectLineLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
@@ -21,6 +24,33 @@ intersectLineLine' (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
     den = (x1 - x2) * (y3 - y4) - (y1 - y2) * (x3 - x4)
     t' = (x1 - x3) * (y3 - y4) - (y1 - y3) * (x3 - x4)
 
+-- note that the second argument is a vector, not the second point of the line
+intersectLinePlane :: Point3 -> Point3 -> Point3 -> Point3 -> Maybe Point3
+intersectLinePlane l v p n = case dot v n of
+    0 -> Nothing
+    x -> Just $ l + ((dot (p - l) n) / x) *.*.* v
+
+-- this needs to be checked
+intersectSegPlane :: Point3 -> Point3 -> Point3 -> Point3 -> Maybe Point3
+intersectSegPlane sp ep p n = case dot v n of
+    0 -> Nothing
+    x -> case dot (p - sp) n / x of
+        d | d >= 0 && d <= 1 -> Just $ sp + d *.*.* v
+        _ -> Nothing
+  where
+    v = ep - sp
+
+intersectSegSurface :: Point3 -> Point3 -> Point3 -> Point3 
+    -> [(Point3,Point3)] -> Maybe Point3
+intersectSegSurface sp ep p n ss = do
+    xp <- intersectSegPlane sp ep p n
+    let f (a,b) = isNHS a b xp
+    guard $ all f ss
+    return xp
+
+isNHS :: Point3 -> Point3 -> Point3 -> Bool
+isNHS p n x = 0 < dot n (x - p)
+
 intersectSegSegErrorTest :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
 {-# INLINE intersectSegSegErrorTest #-}
 intersectSegSegErrorTest a b c d = case intersectSegSeg a b c d of

src/ShortShow.hs

@@ -40,3 +40,7 @@ p = 10 ^ (15 :: Int)
 
 instance (ShortShow a, ShortShow b) => ShortShow (a, b) where
     shortShow (a, b) = '(' : shortShow a ++ "," ++ shortShow b ++ ")"
+
+instance (ShortShow a, ShortShow b, ShortShow c) => ShortShow (a, b, c) where
+    shortShow (a, b, c)
+        = '(' : shortShow a ++ "," ++ shortShow b ++ "," ++ shortShow c ++ ")"