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 ln <- randomRIO (0, num `div` 10) path . (MMNode (V2 0 0) 0 :) <$> foldM makeVert [] [1 .. ln] ) [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 = calcul where calcul graph = let deltas = calculDelta2 graph in if any (\(_, v) -> len v > 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 :: (Floating a, Metric f) => f a -> a len v = sqrt (v `dot` 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 = ( foldl (\amat (MMNode (V2 r c) i) -> M.setElem (if i == 0 then -2 else i) (floor r + 2, floor c + 2) amat ) emptyFloor 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 }) normGraph emptyFloor = M.matrix 50 50 (const 0) manhattan :: AG.Graph MMNode -> M.Matrix Int -> M.Matrix TileState manhattan graph input = walls intermediate where mandistance :: (Int, Int) -> (Int, Int) -> Int mandistance (r1, c1) (r2, c2) = abs (r1 - r2) + abs (c1 - c2) dmin = M.nrows input + M.ncols input calculate (r, c) = foldl (\acc@(accdmin, _) (MMNode (V2 vr vc) ind) -> let d = mandistance (r, c) (floor vr, floor vc) in if d < accdmin then (d, ind) else acc ) (dmin, 0) verts verts = 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) -> 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 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 len (V2 100 100 * normv deltasum) < len 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