building maps of the mind

This commit is contained in:
nek0 2018-06-24 00:41:51 +02:00
parent 373daaa2c0
commit 21461ade1f
5 changed files with 164 additions and 2 deletions

View file

@ -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;
};

145
src/MindMap.hs Normal file
View file

@ -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)

View file

@ -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

15
src/Types/MindMap.hs Normal file
View file

@ -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)

View file

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