tracer/src/MindMap.hs
2018-06-28 21:07:58 +02:00

152 lines
5.7 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
friction :: Double
friction = 0.1
l0 :: Double
l0 = 1
springKonst :: Double
springKonst = 0.8 -- N/m
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 :: Double)) :: 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 (* (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)
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
buildFloorMap :: AG.Graph MMNode -> (M.Matrix Int, AG.Graph MMNode)
buildFloorMap inGraph =
( foldl
(\amat (MMNode (V2 r c) i) -> M.setElem (if i == 0 then -2 else i)
(floor r + 2, floor c + 2) amat
)
emptyFloor
(A.log A.Debug ("floorGraph: " ++ show floorGraph) floorGraph)
, fmap (\n -> n { mmPos = (+ 2) <$> mmPos n} ) 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)
manhattan :: AG.Graph MMNode -> M.Matrix Int -> M.Matrix TileState
manhattan graph input =
walls intermediate
where
distance :: (Int, Int) -> (Int, Int) -> Int
distance (r1, c1) (r2, c2) = abs (r1 - r2) + abs (c1 - c2)
dmin = M.nrows input + M.ncols input
calculate (r, c) = foldl (\acc@(accdmin, accind) (MMNode (V2 vr vc) ind) ->
let d = distance (r, c) (floor vr, floor vc)
in if d < accdmin
then (d, ind)
else acc
) (dmin, 0) vertices
vertices = vertexList graph
coords = (,) <$> [1 .. M.nrows input] <*> [1 .. M.ncols input]
intermediate = M.matrix (M.nrows input) (M.ncols input) (snd . calculate)
walls inter = foldl (\accmat (r, c) ->
let neighbNodes d = map (\(rr, cc) -> M.safeGet (r + rr) (c + cc) inter) d
neighbWalls d = map (\(rr, cc) -> M.safeGet (r + rr) (c + cc) accmat) d
cross = [(0, 1), (0, -1), (1, 0), (-1, 0)]
deltas = ((,) <$> [(-1) .. 1] <*> [(-1) .. 1])
in wallnotwall inter accmat r c
) emptyMM coords
emptyMM = M.matrix (M.nrows input) (M.ncols input) (const Offi)
wallnotwall inter mat r c
| M.safeGet (r - 1) (c - 1) mat /= Just Wall &&
M.safeGet r (c - 1) mat == Just Wall &&
M.safeGet (r - 1) c mat == Just Wall = M.setElem Wall (r, c) mat
| (M.safeGet r (c - 1) inter /= M.safeGet r c inter) &&
(M.safeGet r (c - 1) mat /= Just Wall) = M.setElem Wall (r, c) mat
| (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
| (M.safeGet r (c + 1) inter /= M.safeGet r c inter) &&
(M.safeGet r (c + 1) mat /= Just Wall) = M.setElem Wall (r, c) mat
| (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