building maps of the mind

shell.nix

@@ -79,7 +79,7 @@ let
 
   f = { mkDerivation, astar, base, containers, linear
       , matrix, OpenGL, random, sdl2, stdenv, stm, text, unordered-containers
-      , vector, JuicyPixels, JuicyPixels-extra, bytestring, monad-loops
+      , vector, JuicyPixels, JuicyPixels-extra, bytestring, algebraic-graphs
       }:
       mkDerivation {
         pname = "tracer-game";
@@ -91,7 +91,7 @@ let
         executableHaskellDepends = [
           affectionNeko astar base containers ecstasyNeko linear matrix nanovgNeko
           OpenGL random sdl2 stm text unordered-containers vector JuicyPixels
-          JuicyPixels-extra bytestring
+          JuicyPixels-extra bytestring algebraic-graphs
         ];
         license = stdenv.lib.licenses.gpl3;
       };

src/MindMap.hs

@@ -0,0 +1,145 @@
+module MindMap where
+
+import Affection as A
+
+import Algebra.Graph as AG
+
+import System.Random (randomRIO)
+
+import Control.Monad (foldM)
+
+import Linear
+
+import qualified Data.Matrix as M
+import Data.Maybe (fromJust)
+import Data.List (find)
+
+-- internal imports
+
+import Types
+
+repKonst = 0.03
+friction = 0.05 :: Double
+eqRep    = 96
+l0 = 1 :: Double
+springKonst = 0.8 -- N/m
+gravKonst = 1/2 -- 6.67408e-11
+
+buildMindMap :: Int -> Word -> IO (AG.Graph MMNode)
+buildMindMap num difficulty = do
+  mainPath <- (return . path . (MMNode (V2 0 0) 0 :)) =<< foldM
+    makeVert
+    [MMNode (V2 10 10) (-1)]
+    [1 .. (1 + fromIntegral difficulty)]
+  aux <- randomRIO (0, floor (fromIntegral num * 5 / 8)) :: IO Int
+  auxPaths <- mapM (\_ -> do
+    len <- randomRIO (0, num `div` 10)
+    (path . (MMNode (V2 0 0) 0 :)) <$> foldM makeVert [] [1 .. len]
+    )
+    [0 .. aux]
+  return $ overlays (mainPath : auxPaths)
+  where
+    makeVert :: [MMNode] -> Int -> IO [MMNode]
+    makeVert acc a = do
+      vert <- randomRIO (1, num)
+      x <- randomRIO (4.5, 5.5) :: IO Double
+      y <- randomRIO (4.5, 5.5) :: IO Double
+      A.logIO A.Debug ("pos: " ++ show (x, y))
+      let node = MMNode (V2 x y) vert
+      if node `elem` acc
+      then makeVert acc a
+      else return (node : acc)
+
+springField :: AG.Graph MMNode -> AG.Graph MMNode
+springField inGraph =
+  calcul inGraph
+  where
+    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 (* (1000 / (len (mmPos a - mmPos node)) ^ 2))
+              --   (signorm (mmPos a - mmPos node))
+              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 (* (1000 / (len (mmPos a - mmPos node)) ^ 2))
+              --   (signorm (mmPos a - mmPos node))
+              acc - fmap (* (springKonst * (distance (mmPos a) (mmPos node) - l0)))
+                (normv (mmPos node - mmPos a))
+            | otherwise =
+              -- acc - V2 0 0
+              acc - fmap (* (1 / ((distance (mmPos node) (mmPos a)) ^ 2)))
+                (normv (mmPos a - mmPos node))
+              -- acc - fmap (* (springKonst * (len (mmPos a - mmPos node))))
+              --   (signorm (mmPos a - mmPos node))
+      in  (mmId node, fmap (* friction) accel)
+    calcul graph =
+      let deltas = foldl (\acc a -> calculDelta graph a : acc) [] (vertexList graph)
+      in  if any (\(_, v) -> len v > 0.1)
+            (A.log A.Debug ("deltas: " ++ show deltas) deltas)
+            -- deltas
+        then
+          let deltaNodes = map
+                (\n -> n { mmPos = mmPos n + snd (fromJust (find ((== mmId n) . fst) deltas))})
+                (vertexList graph)
+              ngraph = fmap (\n -> fromJust (find ((== mmId n) . mmId) deltaNodes)) graph
+          in  -- A.log A.Debug "\n\nRECURSING\n"
+                (calcul ngraph)
+        else graph
+    len v = sqrt (v `dot` v)
+    normv v@(V2 0 0) = v
+    normv v          = signorm v
+
+forceField :: AG.Graph MMNode -> AG.Graph MMNode
+forceField input =
+  calcul input
+  where
+    calculDelta :: AG.Graph MMNode -> MMNode -> V2 Double
+    calculDelta inGraph n =
+      let accel :: V2 Double
+          accel =
+            foldl (\acc a ->
+              acc +
+                (if n == a || distance (mmPos n) (mmPos a) > eqRep
+                  then V2 0 0
+                  else fmap
+                    (* (repKonst * (dist a - eqRep) / dist a))
+                    (mmPos n - mmPos a)
+                  )
+              )
+            (V2 0 0 :: V2 Double)
+            inGraph
+          dist :: MMNode -> Double
+          dist a = distance (mmPos n) (mmPos a)
+      in  fmap (* friction) accel
+    calcul inGraph =
+      let deltaSum = foldl (\acc a -> acc + (calculDelta inGraph a)) (V2 0 0) inGraph
+      in  if sqrt (deltaSum `dot` deltaSum) > 1e-15
+        then A.log A.Verbose (show deltaSum)
+          (calcul ((\n -> n { mmPos = mmPos n + calculDelta inGraph n }) <$> inGraph))
+        else A.log A.Verbose (show deltaSum) inGraph
+
+buildFloorMap :: AG.Graph MMNode -> M.Matrix Int
+buildFloorMap inGraph =
+  foldl
+    (\amat (MMNode (V2 r c) id) -> M.setElem (if id == 0 then -2 else id) (floor r + 2, floor c + 2) amat)
+    emptyFloor
+    (A.log A.Debug ("floorGraph: " ++ show floorGraph) floorGraph)
+  where
+    normGraph =
+      let minVert = V2
+            ( minimum $ map ((\(V2 r _) -> r) . mmPos) (vertexList inGraph))
+            ( minimum $ map ((\(V2 _ c) -> c) . mmPos) (vertexList inGraph))
+          maxVert = V2
+            ( maximum $ map ((\(V2 r _) -> r) . mmPos) (vertexList redGraph))
+            ( maximum $ map ((\(V2 _ c) -> c) . mmPos) (vertexList redGraph))
+          redGraph = fmap (\n -> n { mmPos = mmPos n - minVert }) inGraph
+      in  fmap (\n -> n { mmPos = mmPos n / maxVert }) redGraph
+    floorGraph =
+      fmap (\n -> n { mmPos = (* 45) <$> mmPos n} )
+        (A.log A.Verbose ("normGraph: " ++ (show $ vertexList normGraph)) normGraph)
+    emptyFloor = M.matrix 50 50 (const 0)

src/Types.hs

@@ -11,3 +11,4 @@ import Types.FontId as T
 import Types.Direction as T
 import Types.StateData as T
 import Types.Animation as T
+import Types.MindMap as T

src/Types/MindMap.hs

@@ -0,0 +1,15 @@
+module Types.MindMap where
+
+import Linear (V2(..))
+
+data MMNode = MMNode
+  { mmPos :: V2 Double
+  , mmId  :: Int
+  }
+  deriving (Show)
+
+instance Eq MMNode where
+  n1 == n2 = mmId n1 == mmId n2
+
+instance Ord MMNode where
+  compare n1 n2 = compare (mmId n1) (mmId n2)

tracer-game.cabal

@@ -58,6 +58,7 @@ executable tracer-game
                      , JuicyPixels
                      , JuicyPixels-extra
                      , bytestring
+                     , algebraic-graphs
   hs-source-dirs:      src
   ghc-options:         -Wall -threaded
   default-language:    Haskell2010