diff --git a/shell.nix b/shell.nix index a9d8e63..29d8eea 100644 --- a/shell.nix +++ b/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; }; diff --git a/src/MindMap.hs b/src/MindMap.hs new file mode 100644 index 0000000..64b42ba --- /dev/null +++ b/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) diff --git a/src/Types.hs b/src/Types.hs index 13300e8..d1b3feb 100644 --- a/src/Types.hs +++ b/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 diff --git a/src/Types/MindMap.hs b/src/Types/MindMap.hs new file mode 100644 index 0000000..d965ac1 --- /dev/null +++ b/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) diff --git a/tracer-game.cabal b/tracer-game.cabal index 5a6e2c2..1f07ebb 100644 --- a/tracer-game.cabal +++ b/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