146 lines
5.2 KiB
Haskell
146 lines
5.2 KiB
Haskell
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)
|