diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index 5efdae37c..e7daca711 100644 --- a/src/Dodge/Base.hs +++ b/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] diff --git a/src/Dodge/Particle/Bullet/Update.hs b/src/Dodge/Particle/Bullet/Update.hs index 2c048746b..f49db782c 100644 --- a/src/Dodge/Particle/Bullet/Update.hs +++ b/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 - | otherwise = second (fmap dodrag) $ hiteff bt (thingsHitExceptCr mcr p (p +.+ vel) w) w + | t <= 0 || magV (_btVel' bt) < 1 = (w,Nothing) + | 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 diff --git a/src/Dodge/Placement/Instance/Turret.hs b/src/Dodge/Placement/Instance/Turret.hs index cefa5cde1..dc56d1437 100644 --- a/src/Dodge/Placement/Instance/Turret.hs +++ b/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 diff --git a/src/Dodge/WorldEvent/HitEffect.hs b/src/Dodge/WorldEvent/HitEffect.hs index fc54836b8..c8b0b98e0 100644 --- a/src/Dodge/WorldEvent/HitEffect.hs +++ b/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 diff --git a/src/Dodge/WorldEvent/ThingsHit.hs b/src/Dodge/WorldEvent/ThingsHit.hs index 84cd7c780..465c2d754 100644 --- a/src/Dodge/WorldEvent/ThingsHit.hs +++ b/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 - -- $ creaturesAlongLine sp ep w - crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs + -- $ _creatures 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 diff --git a/src/Geometry.hs b/src/Geometry.hs index 94ee2976b..a3b37e58c 100644 --- a/src/Geometry.hs +++ b/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)) - isJustTrue (Just True) = True - isJustTrue _ = False + thenormal = 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. 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 diff --git a/src/Geometry/Intersect.hs b/src/Geometry/Intersect.hs index faa33038b..23e23f1d6 100644 --- a/src/Geometry/Intersect.hs +++ b/src/Geometry/Intersect.hs @@ -2,9 +2,9 @@ {- Testing for and finding intersection points. -} -module Geometry.Intersect - where +module Geometry.Intersect 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) ) diff --git a/test/Spec.hs b/test/Spec.hs index 003e25247..cf2bd770a 100644 --- a/test/Spec.hs +++ b/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) --