use relation graph for collision detection

this prevents collision a b from being called
more than one time.

3 files changed, 25 insertions, 11 deletions

diff --git a/lib/Grav2ty/Control.hs b/lib/Grav2ty/Control.hs
index 78f6c26..2a620e0 100644
--- a/lib/Grav2ty/Control.hs
+++ b/lib/Grav2ty/Control.hs
@@ -13,6 +13,7 @@ module Grav2ty.Control
   ) where
 
 import Grav2ty.Simulation
+import Grav2ty.Util.UGraph
 
 import Control.Lens
 import Data.Foldable
@@ -101,10 +102,10 @@ updateState t extract state =
   where oldWorld = state^.world
         (newWorld, updateState') = foldl' updateAndExtract (S.empty, Nothing) oldWorld
         updateAndExtract acc@(seq, f) x =
-          if coll x
+          if isDynamic x && (anyU relColl x objectRel == Just True)
              then acc
              else (updateObject' x >< seq, (.) <$> extract x <*> f)
-        coll obj = isDynamic obj && collisionWithWorld oldWorld obj
+        objectRel = objectRelGraph oldWorld
         scaledT = state^.control^.ctrlTimeScale * t
         updateObject' obj =
           fmap (updateObject scaledT (gravitationForces oldWorld obj))
diff --git a/lib/Grav2ty/Simulation.hs b/lib/Grav2ty/Simulation.hs
index f23b134..7a7af42 100644
--- a/lib/Grav2ty/Simulation.hs
+++ b/lib/Grav2ty/Simulation.hs
@@ -8,6 +8,8 @@ module Grav2ty.Simulation
   , World (..)
   , updateObject
   , gravitationForces
+  , ObjRel (..)
+  , objectRelGraph
   -- * Hitboxes
   , Hitbox (..)
   , shipHitbox
@@ -15,11 +17,13 @@ module Grav2ty.Simulation
   , translateHitbox
   , rotateHitbox
   , collision
-  , collisionWithWorld
+  , objectCollision
   -- * Exposed Utilities
   , rotateV2
   ) where
 
+import Grav2ty.Util.UGraph
+
 import Control.Lens
 import Data.Complex
 import Data.Foldable
@@ -146,12 +150,10 @@ collision (HLine a1 b1) (HLine a2 b2) =
 collision (HCombined as) b = any (collision b) as
 collision a b@(HCombined _) = collision b a
 
-collisionWithWorld :: (Ord a, RealFloat a) => World a -> Object a -> Bool
-collisionWithWorld world obj = any
-  (\obj' ->
-    obj /= obj' &&
-    (objectLoc obj == objectLoc obj'
-      ||  collision (realHitbox obj) (realHitbox obj'))) world
+objectCollision :: RealFloat a => Object a -> Object a -> Bool
+objectCollision a b = a /= b &&
+  ((objectLoc a == objectLoc b)
+    || collision (realHitbox a) (realHitbox b))
 
 data Modifier
   = NoMod            -- ^ Not modified, purely physics based.
@@ -214,6 +216,13 @@ gravitationForces world obj = foldl' calcSum (pure 0) world
                              then force + gravitationForce obj x
                              else force
 
+data ObjRel a = ObjRel
+  { relColl :: Bool
+  } deriving (Show, Eq, Ord)
+
+objectRelGraph :: (RealFloat a, Ord a) => World a -> UGraph (Object a) (ObjRel a)
+objectRelGraph = insertSeq (\a b -> ObjRel $ objectCollision a b) emptyU
+
 updateObject :: Fractional a =>  a -> V2 a -> Object a -> Object a
 updateObject _ _ obj@Static {} = obj
 updateObject timeStep force obj@Dynamic {} = obj
diff --git a/lib/Grav2ty/Util/UGraph.hs b/lib/Grav2ty/Util/UGraph.hs
index 7d29b41..72c48d7 100644
--- a/lib/Grav2ty/Util/UGraph.hs
+++ b/lib/Grav2ty/Util/UGraph.hs
@@ -6,6 +6,7 @@ module Grav2ty.Util.UGraph
   , insertU
   , insertSeq
   , lookupU
+  , anyU
   -- * Props
   , prop_undirected
   , prop_undirected'
@@ -27,14 +28,17 @@ insertU x y v = UGraph . M.alter (alterOuter x) y . M.alter (alterOuter y) x . u
   where alterOuter i Nothing  = Just $ M.singleton i v
         alterOuter i (Just m) = Just $ M.insert i v m
 
-insertSeq :: Ord a => Seq a -> (a -> a -> v) -> UGraph a v -> UGraph a v
-insertSeq seq f g = ins seq g
+insertSeq :: Ord a => (a -> a -> v) -> UGraph a v -> Seq a -> UGraph a v
+insertSeq f g seq = ins seq g
   where ins (x :<| s) acc = ins s (foldl' (\g el -> insertU x el (f x el) g) acc s)
         ins mempty acc = acc
 
 lookupU :: Ord a => a -> a -> UGraph a v -> Maybe v
 lookupU x y = (>>= (M.lookup y)) . M.lookup x . unUGraph
 
+anyU :: Ord a => (v -> Bool) -> a -> UGraph a v -> Maybe Bool
+anyU f x = fmap (foldl (\b x -> b || f x) False) . M.lookup x . unUGraph
+
 prop_undirected' :: (Ord a, Eq v) => UGraph a v -> a -> a -> Bool
 prop_undirected' g x y = lookupU x y g == lookupU y x g