optimizing MindMap generation

src/MindMap.hs

@@ -55,25 +55,10 @@ springField =
   calcul
   where
     -- This could be optimized in such a way, that you update both computation partners at once.
-    calculDelta :: AG.Graph MMNode -> MMNode -> (Int, V2 Double)
+    -- Limit the force
-    calculDelta graph node =
-      let accel = foldl sproing (V2 0 0 :: V2 Double) (vertexList graph)
-          sproing acc a
-            | mmId a == mmId node =
-              acc + V2 0 0
-            | a `elem` map snd (filter ((== node) . fst) $ edgeList graph) =
-              acc + fmap (* (springKonst * (distance (mmPos a) (mmPos node) - l0)))
-                (normv (mmPos a - mmPos node))
-            | node `elem` map snd (filter ((== a) . fst) $ edgeList graph) =
-              acc - fmap (* (springKonst * (distance (mmPos a) (mmPos node) - l0)))
-                (normv (mmPos node - mmPos a))
-            | otherwise =
-              acc - fmap (* (1000 / ((distance (mmPos node) (mmPos a)) ^ (2 :: Int))))
-                (normv (mmPos a - mmPos node))
-      in  (mmId node, fmap (* friction) accel)
     calcul graph =
-      let deltas = map (calculDelta graph) (vertexList graph)
+      let deltas = calculDelta2 graph -- map (calculDelta graph) (vertexList graph)
-      in  if any (\(_, v) -> len v > 0.1)
+      in  if any (\(_, v) -> len v > 1)
             (A.log A.Debug ("deltas: " ++ show deltas) deltas)
             -- deltas
         then
@@ -85,8 +70,10 @@ springField =
                 (calcul ngraph)
         else graph
     len v = sqrt (v `dot` v)
-    normv v@(V2 0 0) = v
+
-    normv v          = signorm v
+normv :: (Eq a, Floating a) => V2 a -> V2 a
+normv v@(V2 0 0) = v
+normv v          = signorm v
 
 buildFloorMap :: AG.Graph MMNode -> (M.Matrix Int, AG.Graph MMNode)
 buildFloorMap inGraph =
@@ -146,3 +133,52 @@ manhattan graph input =
       | (M.safeGet (r + 1) c inter /= M.safeGet r c inter) &&
         (M.safeGet (r + 1) c mat /= Just Wall) = M.setElem Wall (r, c) mat
       | otherwise = mat
+
+calculDelta :: AG.Graph MMNode -> MMNode -> (Int, V2 Double)
+calculDelta graph node =
+  let accel = foldl sproing (V2 0 0 :: V2 Double) (vertexList graph)
+      sproing acc a
+        | mmId a == mmId node =
+          acc + V2 0 0
+        | a `elem` map snd (filter ((== node) . fst) $ edgeList graph) =
+          acc + fmap (* (springKonst * (distance (mmPos a) (mmPos node) - l0)))
+            (normv (mmPos a - mmPos node))
+        | node `elem` map snd (filter ((== a) . fst) $ edgeList graph) =
+          acc - fmap (* (springKonst * (distance (mmPos a) (mmPos node) - l0)))
+            (normv (mmPos node - mmPos a))
+        | otherwise =
+          acc - fmap (* (1000 / ((distance (mmPos node) (mmPos a)) ^ (2 :: Int))))
+            (normv (mmPos a - mmPos node))
+  in  (mmId node, fmap (* friction) accel)
+
+calculDelta2 :: AG.Graph MMNode -> [(Int, V2 Double)]
+calculDelta2 graph =
+  let accel2 = sproing2 (zip (vertexList graph) (repeat $ V2 0 0))
+      sproing2 [] = []
+      sproing2 ((cnode, cacc):nodeaccs) =
+        ( mmId cnode
+        , if (distance (V2 0 0) (V2 100 100 * normv deltasum)) < distance (V2 0 0) deltasum
+          then V2 100 100 * normv deltasum
+          else deltasum
+        ) : sproing2 dnodeaccs
+        where
+          deltasum = cacc + sum deltas
+          deltas = map ((fmap (* friction)) . doForce) (map fst nodeaccs)
+          doForce n
+            -- are the nodes identic? (unlikely)
+            | mmId cnode == mmId n =
+              V2 0 0
+            -- Is the cnode pointing to the currently mapped node?
+            | n `elem` map snd (filter ((== cnode) . fst) $ edgeList graph) =
+              fmap (* (springKonst * (distance (mmPos n) (mmPos cnode) - l0)))
+                (normv (mmPos n - mmPos cnode))
+            -- Is the cnode being pointed to from the currently mapped node?
+            | cnode `elem` map snd (filter ((== n) . fst) $ edgeList graph) =
+              - fmap (* (springKonst * (distance (mmPos n) (mmPos cnode) - l0)))
+                (normv (mmPos cnode - mmPos n))
+            -- Do gravitational push in all other cases
+            | otherwise =
+              - fmap (* (1000 / ((distance (mmPos cnode) (mmPos n)) ^ (2 :: Int))))
+                (normv (mmPos n - mmPos cnode))
+          dnodeaccs = zipWith (\(n, a) d -> (n, a - d)) nodeaccs deltas
+  in  accel2