Stop bullets when they hit walls

src/Dodge/Base.hs

@@ -82,7 +82,7 @@ wallNormal wl = normalizeV . vNormal $ a -.- b
 wallsOnLine :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall]
 wallsOnLine p1 p2 ws = hitWalls
   where 
-    hitPoint w = uncurry (intersectSegSeg p1 p2) (_wlLine w)
+    hitPoint = uncurry (intersectSegSeg p1 p2) . _wlLine
     hitWalls = filter (isJust . hitPoint) (IM.elems ws)
 
 wallsOnLine3D :: Point3 -> Point3 -> IM.IntMap Wall -> [Wall]

src/Dodge/Particle/Bullet/Update.hs

@@ -15,13 +15,13 @@ import Control.Lens
 {- Update for a generic bullet.  -}
 mvBullet :: World -> Particle -> (World, Maybe Particle)
 mvBullet w bt' 
-    | t <= 0 || magV (_btVel' bt) < 1 = wAnd Nothing
+    | t <= 0 || magV (_btVel' bt) < 1 = (w,Nothing)
-    | otherwise = second (fmap dodrag) $ hiteff bt (thingsHitExceptCr mcr p (p +.+ vel) w) w
+    | otherwise = second (fmap dodrag) $ 
+        hiteff bt (thingsHitExceptCr mcr p (p +.+ vel) w) w
   where
     bt = foldr (\mg b -> _mgField mg mg b) bt' $ _magnets w
     dodrag = btVel' %~ (drag *.*)
     drag = _btDrag bt
-    wAnd    = (w,)
     mcr     = _btPassThrough' bt
     (p:_)  = _btTrail' bt
     vel     = _btVel' bt

src/Dodge/Placement/Instance/Turret.hs

@@ -36,8 +36,8 @@ putLasTurret rotSpeed = sps0 $ PutMachine blue (reverse $ square wdth) defaultMa
     }
 lasTurret :: MachineType
 lasTurret = Turret
-    --{ _tuWeapon = lasGun
     { _tuWeapon = lasGun
+    --{ _tuWeapon = autoRifle
     , _tuTurnSpeed = 0.1
     , _tuFireTime = 0
     , _tuMCrID = Nothing

src/Dodge/WorldEvent/HitEffect.hs

@@ -51,9 +51,18 @@ mvPt pt = Just $ pt
 
 destroyAt :: Point2 -> Particle -> Maybe Particle
 destroyAt hitp pt = Just $ pt 
+    & ptUpdate .~ killBulletUpdate
     & btTrail' %~ (hitp :)
     & btTimer' %~ (\t -> min 3 (t-1))
 
+killBulletUpdate :: World -> Particle -> (World,Maybe Particle)
+killBulletUpdate w pt 
+    | _btTimer' pt <= 0 = (w,Nothing)
+    | otherwise = (w
+        ,Just $ pt & btTimer' -~ 1
+            & btTrail' %~ (\(x:xs) -> (x:x:xs))
+        )
+
 penWalls 
     :: HitCreatureEffect 
     -> HitWallEffect 

src/Dodge/WorldEvent/ThingsHit.hs

@@ -31,12 +31,13 @@ thingsHit sp ep w
   where 
     hitCrs = IM.elems 
         $ IM.filter (\cr -> circOnSeg sp ep (_crPos cr) (_crRad cr))
-        $ _creatures w
+    --    $ _creatures w
-    --    $ creaturesAlongLine sp ep w
+        $ creaturesAlongLine sp ep w
     crPs  = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs
     crs   = zip crPs (map Left hitCrs)
     hitWls   = wallsOnLine sp ep (IM.unions [f b $ f a $ _znObjects $ _wallsZone w | a<-[x-1,x,x+1]
                                                                       , b<-[y-1,y,y+1]])
+    --hitWls = wallsOnLine sp ep $ _walls w
     (x,y) = zoneOfPoint (0.5 *.* (sp +.+ ep))
     f i m = case IM.lookup i m of 
         Just val -> val

src/Geometry.hs

@@ -182,24 +182,19 @@ pHalf !a !b = 0.5 *.* (a +.+ b)
 -- segment.
 circOnSegNoEndpoints :: Point2 -> Point2 -> Point2 -> Float -> Bool
 {-# INLINE circOnSegNoEndpoints #-}
-circOnSegNoEndpoints !p1 !p2 !c !rad = isJustTrue (fmap (\p -> magV (p -.- c) < rad) y)
+circOnSegNoEndpoints !p1 !p2 !c !rad = intersectSegSegTest p1 p2 (c -.- thenormal) (c +.+ thenormal)
   where 
-    y = intersectSegLine p1 p2 c (c +.+ vNormal (p1 -.- p2))
+    thenormal = rad *.* vNormal (normalizeV $ p1 -.- p2)
-    isJustTrue (Just True) = True
+
-    isJustTrue _           = False
 -- | Test whether a circle is on a segment by intersecting a normal and testing
 -- the distance to the endpoints of the segment.
 circOnSeg :: Point2 -> Point2 -> Point2 -> Float -> Bool
 {-# INLINE circOnSeg #-}
 circOnSeg !p1 !p2 !c !rad = magV (p1 -.- c) <= rad 
     || magV (p2 -.- c) <= rad
---    || isJustTrue (fmap (\p -> magV (p -.- c) < rad) y)
     || intersectSegSegTest p1 p2 (c -.- thenormal) (c +.+ thenormal)
   where 
     thenormal = rad *.* vNormal (normalizeV $ p1 -.- p2)
-    y = intersectSegLine p1 p2 c (c +.+ vNormal (p1 -.- p2))
-    isJustTrue (Just True) = True
-    isJustTrue _           = False
 cylinderOnSeg :: Point3 -> Point3 -> Point3 -> Float -> Bool
 {-# INLINE cylinderOnSeg #-}
 cylinderOnSeg = undefined

src/Geometry/Intersect.hs

@@ -2,9 +2,9 @@
 {-
 Testing for and finding intersection points.
 -}
-module Geometry.Intersect
+module Geometry.Intersect where
-    where
 import Geometry.Data
+import Geometry.Vector
 import Geometry.LHS
 import Control.Applicative
 
@@ -18,10 +18,21 @@ intersectLineLine' (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
   where 
     den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
     t'  = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
+intersectSegSegErrorTest :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
+{-# INLINE intersectSegSegErrorTest #-}
+intersectSegSegErrorTest a b c d = case intersectSegSeg a b c d of
+    Nothing | intersectSegSegFullTest a b c d -> 
+            error $ "intersectSegSeg did not intersect"++show a ++ show b ++ show c++ show d
+    Just x | not $ intersectSegSegFullTest a b c d -> 
+            error $ "intersectSegSeg did intersect"++show a ++ show b ++ show c++ show d
+                ++ " at " ++ show x
+    m -> m
+
 -- | If two segments intersect, return 'Just' that point.
 intersectSegSeg :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
 {-# INLINE intersectSegSeg #-}
 intersectSegSeg (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
+    | V2 x1 y1 == V2 x2 y2 || V2 x3 y3 == V2 x4 y4 = Nothing
     | den == 0 = Nothing
     | den > 0 && (t' < 0 || u' < 0 || t' > den || u' > den)
         = Nothing
@@ -75,9 +86,23 @@ intersectSegLine (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)
     --u'  = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
+-- | A test that should align with Just values from intersectSegSeg.
+intersectSegSegFullTest
+    :: Point2
+    -> Point2
+    -> Point2
+    -> Point2
+    -> Bool
+{-# INLINE intersectSegSegFullTest #-}
+intersectSegSegFullTest x y z w
+    = f x y z w && f z w x y && x /= y && z /= w 
+        && normalizeV (x -.- y) /= normalizeV (z -.- w)
+        && normalizeV (y -.- x) /= normalizeV (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) )
 -- | It is not always necessary to find a point of intersection, sometimes a
 -- test may suffice.
--- IS THIS CORRECT? -- TODO tests
 intersectSegSegTest
     :: Point2
     -> Point2
@@ -86,7 +111,7 @@ intersectSegSegTest
     -> Bool
 {-# INLINE intersectSegSegTest #-}
 intersectSegSegTest x y z w
-    = f x y z w && f z w x y
+    = 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) )

test/Spec.hs

@@ -1,12 +1,13 @@
 --import Test.HUnit
 import Test.Tasty
-import Test.Tasty.QuickCheck
+import qualified Test.Tasty.QuickCheck as QC
 import Test.Tasty.HUnit
 import Dodge.Room.CheckConsistency
 import Geometry
 
 import Dodge.LevelGen.StaticWalls
 import Geometry
+import Data.Maybe
 
 main :: IO ()
 main = defaultMain $
@@ -14,6 +15,11 @@ main = defaultMain $
         [testGroup "Geometry tests" geometryTests]
 
 geometryTests =
+    [ testGroup "(HUnit)" geometryUnitTests
+    , testGroup "(QuickCheck)" geometryQuickCheckTests
+    ]
+
+geometryUnitTests =
     [ testCase "intersectSegSegTest cross intersect" $
         intersectSegSegTest (V2 1 0) (V2 1 2) (V2 0 1) (V2 2 1) 
             @?= True
@@ -46,6 +52,13 @@ geometryTests =
             @?= False
     ]
 
+geometryQuickCheckTests = 
+    [ QC.testProperty "intersectSegSeg--intersectSegSegTest" $
+        \(x1,y1,x2,y2,x3,y3,x4,y4) -> 
+            isJust (intersectSegSeg (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)) 
+                == intersectSegSegTest (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
+    ]
+
 --nextPair :: Eq a => (a,a) -> [(a,a)] -> [(a,a)]
 --nextPair (_,y) = filter (\(x,_) -> x == y)
 --