tracer/src/MindMap.hs

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