integrate mind map into game

src/Load.hs

@@ -20,7 +20,7 @@ import NanoVG hiding (V2(..))
 -- internal imports
 
 import Types
-import MainGame
+import MainGame.WorldMap
 import Util
 
 loadLoad :: Affection UserData ()
@@ -157,7 +157,7 @@ updateLoad _ = do
       putAffection ud
         { assetImages     = loadAssetImages ld
         , assetAnimations = loadAssetAnims ld
-        , state           = Main
+        , state           = Main WorldMap
         , stateData       = None
         }
       loadMap

src/MainGame/MindMap.hs

@@ -0,0 +1,324 @@
+module MainGame.MindMap where
+
+import Affection as A
+
+import Linear hiding (E(..))
+
+import qualified Data.Map.Strict as Map
+import Data.Matrix as M
+import qualified Data.Set as S
+import qualified Data.Text as T
+import Data.List as L
+import Data.Ecstasy as E
+import Data.Maybe
+
+import Control.Monad (when)
+
+import NanoVG hiding (V2(..))
+
+import SDL hiding (E(..))
+
+import Foreign.C.Types
+
+-- internal imports
+
+import Types
+
+import MainGame.WorldMap (checkBoundsCollision2)
+
+updateMind :: Double -> Affection UserData ()
+updateMind dt = do
+ ud <- getAffection
+ let direction :: V2 Double -> Direction -> Direction
+     direction vel'@(V2 vr _) rot' = if sqrt (vel' `dot` vel') > 0
+       then
+         let xuu =
+               acos ((vel' `dot` V2 0 1) /
+                 sqrt (vel' `dot` vel')) / pi * 180
+             xu = if vr < 0 then 360 - xuu else xuu
+             d
+               |               xu < 22.5  = NE
+               | xu > 22.5  && xu < 67.5  = E
+               | xu > 67.5  && xu < 112.5 = SE
+               | xu > 112.5 && xu < 157.5 = S
+               | xu > 157.5 && xu < 202.5 = SW
+               | xu > 202.5 && xu < 247.5 = W
+               | xu > 247.5 && xu < 292.5 = NW
+               | xu > 292.5 && xu < 337.5 = N
+               | xu > 337.5               = NE
+               | otherwise                = NE
+         in d
+       else rot'
+ (nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do
+   emap allEnts $ do
+     with anim
+     with mmpos
+     stat <- query anim
+     let an = assetAnimations ud Map.! asId stat
+         ntime = asElapsedTime stat + dt
+         nstate = if ntime > fromIntegral (asCurrentFrame stat) *
+           (animDuration an / fromIntegral (length $ animSprites an))
+           then
+             let nframe = asCurrentFrame stat + 1
+             in  case animPlay an of
+                   APLoop ->
+                     let (nnframe, nntime) =
+                           if nframe >= length (animSprites an)
+                           then (0, 0)
+                           else (nframe, ntime)
+                     in  stat
+                           { asCurrentFrame = nnframe
+                           , asElapsedTime  = nntime
+                           }
+                   APOnce ->
+                     let nnframe = if nframe >= length (animSprites an)
+                           then nframe - 1
+                           else nframe
+                     in  stat
+                           { asCurrentFrame = nnframe
+                           , asElapsedTime  = ntime
+                           }
+           else
+             stat
+               { asElapsedTime = ntime
+               }
+     return $ unchanged
+       { anim = Set nstate
+       }
+   emap allEnts $ do
+     with player
+     with mmvel
+     with mmpos
+     with mmrot
+     with anim
+     pos'@(V2 pr pc) <- query mmpos
+     vel' <- query vel
+     rot' <- query rot
+     stat <- query anim
+     let npos = pos' + fmap (* dt) vel'
+         dpos@(V2 dpr dpc) = npos - pos'
+         aId = asId stat
+         nstat = case aiName aId of
+           "walking"
+             | sqrt (colldpos `dot` colldpos) > 0 ->
+               stat
+                 { asId = aId
+                   { aiDirection = direction vel' rot'
+                   }
+                 }
+             | otherwise ->
+               stat
+                 { asId = aId
+                   { aiDirection = direction vel' rot'
+                   , aiName = "standing"
+                   }
+                 , asCurrentFrame = 0
+                 }
+           "standing"
+             | sqrt (colldpos `dot` colldpos) > 0 ->
+               stat
+                 { asId = aId
+                   { aiDirection = direction vel' rot'
+                   , aiName = "walking"
+                   }
+                 , asCurrentFrame = 0
+                 }
+             | otherwise ->
+               stat
+                 { asId = aId
+                   { aiDirection = direction vel' rot'
+                   }
+                 }
+           x -> error ("unknown animation name" ++ x)
+         len = sqrt (dpos `dot` dpos)
+         lll = (,)
+           <$> (
+             if dpr < 0
+             then [(floor dpr :: Int) .. 0]
+             else [0 .. (ceiling dpr :: Int)])
+           <*> (
+             if dpc < 0
+             then [(floor dpc :: Int) .. 0]
+             else [0 .. (ceiling dpc :: Int)])
+         colldpos = dpos * Prelude.foldl
+           (\acc a -> let ret = checkBoundsCollision2 pos' npos dt acc a
+             in A.log A.Verbose (show ret) ret)
+           (V2 1 1)
+           (
+             concatMap
+             (\(dr, dc) ->
+               let bs = fromMaybe [] (imgObstacle <$> M.safeGet
+                     (fromIntegral $ floor pr + dr)
+                     (fromIntegral $ floor pc + dc)
+                     (mmImgMat (stateData ud)))
+               in  Prelude.map (\(Boundaries (minr, minc) (maxr, maxc))->
+                     Boundaries
+                       (minr + fromIntegral dr, minc + fromIntegral dc)
+                       (maxr + fromIntegral dr, maxc + fromIntegral dc)
+                     ) bs
+               )
+             lll -- (A.log A.Verbose (show lll ++ " " ++ show len) lll)
+             )
+         ent = unchanged
+           { mmpos = Set $ pos' + colldpos
+           , rot = Set (direction vel' rot')
+           , anim = Set nstat
+           }
+     return ent
+ putAffection ud
+   { worldState = nws
+   }
+
+drawMind :: Affection UserData ()
+drawMind = do
+  ud <- getAffection
+  let ctx = nano ud
+  dt <- getDelta
+  (_, (playerPos, posanims)) <- liftIO $ yieldSystemT (worldState ud) $ do
+    pc <- fmap head $ efor allEnts $ do
+      with player
+      with mmpos
+      query mmpos
+    posanims <- efor allEnts $ do
+      with anim
+      with mmpos
+      stat <- query anim
+      pos' <- query mmpos
+      return (pos', stat)
+    return (pc, posanims)
+  let V2 pr pc = playerPos
+      mat = mmImgMat (stateData ud)
+      cols = fromIntegral (ncols mat)
+      rows = fromIntegral (nrows mat)
+      tileWidth = 64 :: Double
+      tileHeight = 32 :: Double
+      x = realToFrac $ 640 + ((1 - pc) + (1 - pr)) * (tileWidth / 2)
+      y = realToFrac $ 360 + ((1 - pr) - (1 - pc)) * (tileHeight / 2)
+      partposanims = M.fromList
+        (nrows $ mapMat $ stateData ud)
+        (ncols $ mapMat $ stateData ud)
+        ((reverse . fst)
+          (Prelude.foldl
+            (\(done, proc) coord ->
+              let (ndone, nproc) = processList proc coord
+              in  (ndone : done, nproc)
+              )
+            ([], posanims)
+            ((,)
+              <$> [1 .. (nrows $ mapMat $ stateData ud)]
+              <*> [1 .. (ncols $ mapMat $ stateData ud)]
+              )
+            )
+          )
+      processList
+        :: [(V2 Double, AnimState)]
+        -> (Int, Int)
+        -> ([(V2 Double, AnimState)], [(V2 Double, AnimState)])
+      processList list coord@(r, c) =
+        let delimiter (V2 nr nc, _) =
+              floor nr == r && floor nc == c
+        in  L.partition delimiter list
+  liftIO $ do -- draw floor
+    beginPath ctx
+    moveTo ctx (x + realToFrac tileWidth / 2) y
+    lineTo ctx
+      (x + cols * (realToFrac tileWidth / 2))
+      (y - (realToFrac tileHeight / 2) * (cols - 1))
+    lineTo ctx
+      (x + (realToFrac tileWidth / 2) * (cols + rows - 1))
+      (y + (rows - cols) * (realToFrac tileHeight / 2))
+    lineTo ctx
+      (x + (realToFrac tileWidth / 2) * rows)
+      (y + (realToFrac tileHeight / 2) * (rows - 1))
+    closePath ctx
+    fillColor ctx (rgb 255 255 255)
+    fill ctx
+    mapM_ (\(i, ls) -> mapM_
+        (\(j, t) -> drawTile ud ctx (partposanims M.! (i, j)) pr pc i j t)
+        (reverse $ zip [1..] ls))
+      (zip [1..] (toLists mat))
+    fontSize ctx 20
+    fontFace ctx (assetFonts ud Map.! FontBedstead)
+    textAlign ctx (S.fromList [AlignCenter,AlignTop])
+    fillColor ctx (rgb 255 128 0)
+    textBox ctx 0 0 200 ("FPS: " `T.append` T.pack (Prelude.take 5 $ show (1/dt)))
+
+drawTile
+  :: UserData
+  -> Context
+  -> [(V2 Double, AnimState)]
+  -> Double
+  -> Double
+  -> Int
+  -> Int
+  -> Maybe ImgId
+  -> IO ()
+drawTile ud ctx posanims pr pc row col img =
+  when ((realToFrac x > -tileWidth && realToFrac y > -tileHeight) &&
+    ((realToFrac x :: Double) < 1280 &&
+    (realToFrac (y - (74 - (realToFrac tileHeight :: CFloat))) :: Double) < 720)) $
+      do
+        let (bef, beh) = L.partition delimiter sorted
+        save ctx
+        mapM_ drawAnim beh
+        when (isJust img) drawImage
+        mapM_ drawAnim bef
+        restore ctx
+  where
+    delimiter (V2 nr nc, _) =
+      all delimit mb
+      where
+        delimit b
+          | nnr > fst (matmin b) && nnr < fst (matmax b) =
+            nnc < snd (matmin b)
+          | nnc > snd (matmin b) && nnc < snd (matmax b) =
+            nnr > fst (matmax b)
+          | otherwise =
+            True
+        nnr = nr - fromIntegral (floor nr)
+        nnc = nc - fromIntegral (floor nc)
+      -- any (\m -> nr < fromIntegral (floor nr :: Int) + m) maxrs &&
+      -- any (\m -> nc > fromIntegral (floor nc :: Int) + m) mincs
+    ai = assetImages ud
+    anims = assetAnimations ud
+    tileWidth = 64 :: Double
+    tileHeight = 32 :: Double
+    sorted = sortOn (\(V2 sr sc, _) -> sc + sr * fromIntegral col) posanims
+    minrs = Prelude.map (fst . matmin) mb
+    maxrs = Prelude.map (fst . matmax) mb
+    mincs = Prelude.map (snd . matmin) mb
+    maxcs = Prelude.map (snd . matmax) mb
+    x = realToFrac $ 640 + ((fromIntegral col - pc) +
+      (fromIntegral row - pr)) * (tileWidth / 2) :: CFloat
+    y = realToFrac $ 360 - (tileHeight / 2) + ((fromIntegral row - pr) -
+      (fromIntegral col - pc)) * (tileHeight / 2) :: CFloat
+    dist = distance (V2 (fromIntegral row) (fromIntegral col))
+      (V2 (realToFrac pr - 1) (realToFrac pc)) / 4
+    fact =
+      if (pr <= fromIntegral row + minimum maxrs &&
+         pc >= fromIntegral col + maximum mincs) &&
+         isWall (fromJust img)
+      then min 1 dist
+      else 1
+    mb = imgObstacle img
+    drawAnim (V2 nr nc, as) = do
+      let ax = realToFrac $ 640 + ((nc - pc) + (nr - pr)) * 32
+          ay = realToFrac $ 360 + ((nr - pr) - (nc - pc)) * 16
+          a = anims Map.! asId as
+      beginPath ctx
+      paint <- imagePattern ctx (ax - 32) (ay - 58) 64 74 0
+        (animSprites a !! asCurrentFrame as) 1
+      rect ctx (ax - 32) (ay - 58) 64 74
+      fillPaint ctx paint
+      fill ctx
+    drawImage = do
+      beginPath ctx
+      paint <- imagePattern
+        ctx x (y - (74 - realToFrac tileHeight))
+        (realToFrac tileWidth) 74
+        0
+        (ai Map.! fromJust img)
+        fact
+      rect ctx x (y - (74 - realToFrac tileHeight)) (realToFrac tileWidth) 74
+      fillPaint ctx paint
+      fill ctx

src/MainGame/WorldMap.hs

@@ -1,7 +1,9 @@
-module MainGame where
+module MainGame.WorldMap where
 
 import Affection as A
 
+import Algebra.Graph as AG
+
 import qualified SDL
 import NanoVG hiding (V2(..))
 
@@ -16,7 +18,7 @@ import qualified Data.Text as T
 import Data.Matrix as M
 import Data.Ecstasy as E
 import Data.Maybe
-import Data.List as L (sortOn, partition)
+import Data.List as L (sortOn, partition, find)
 
 import System.Random (randomRIO)
 
@@ -30,6 +32,7 @@ import Interior
 import Util
 import Types
 import Floorplan
+import MindMap
 import NPC
 
 loadMap :: Affection UserData ()
@@ -37,24 +40,40 @@ loadMap = do
   ud <- getAffection
   let (Subsystems _ m k) = subsystems ud
       ctx = nano ud
-  uu <- partSubscribe m movePlayer
+  uu1 <- partSubscribe m movePlayer
+  uu2 <- partSubscribe k changeMaps
   future <- liftIO $ newEmptyMVar
   progress <- liftIO $ newMVar 0
   _ <- liftIO $ forkIO $ loadMapFork ud future progress
   putAffection ud
     { stateData = None
-    , uuid = [uu]
+    , uuid = [uu1, uu2]
     , stateMVar = future
     , stateProgress = progress
     }
 
+changeMaps :: KeyboardMessage -> Affection UserData ()
+changeMaps (MsgKeyboardEvent _ _ SDL.Pressed False sym)
+  | SDL.keysymKeycode sym == SDL.KeycodeF1 = do
+    ud <- getAffection
+    putAffection ud
+      { state = Main WorldMap
+      }
+  | SDL.keysymKeycode sym == SDL.KeycodeF2 = do
+    ud <- getAffection
+    putAffection ud
+      { state = Main MindMap
+      }
+  | otherwise = return ()
+changeMaps _ = return ()
+
 loadMapFork
   :: UserData
   -> MVar (SystemState Entity IO, StateData)
   -> MVar Float
   -> IO ()
 loadMapFork ud future progress = do
-  let loadSteps = 16
+  let loadSteps = 18
       fc = FloorConfig
         (10, 10)
         [(5, 5), (5, 45)]
@@ -78,15 +97,35 @@ loadMapFork ud future progress = do
   npcposs <- placeNPCs inter mat rps gr 50 -- (length nnex)
   _ <- liftIO $ swapMVar progress (14 / loadSteps)
   A.logIO A.Debug $ "number of placed NPCs: " ++ show (length npcposs)
+  (mmintmat, mmgraph) <- buildFloorMap <$> springField <$>
+    buildMindMap (length npcposs) 3
+  _ <- liftIO $ swapMVar progress (15 / loadSteps)
+  let mmimgmat = convertTileToImg $ manhattan mmgraph mmintmat
+  _ <- liftIO $ swapMVar progress (16 / loadSteps)
   (nws, _) <- yieldSystemT (worldState ud) $ do
+    let pmmpos = ((+ 0.5) . fromIntegral . floor) <$> mmPos
+          (fromJust $ find (\a -> mmId a == 0) (vertexList mmgraph))
+        delta = [(0, 0)] ++
+          Prelude.filter (/= (0,0)) ((,) <$> [-1 .. 1] <*> [-1 .. 1]) :: [(Int, Int)]
+        mmpos = Prelude.foldl (\acc (dr, dc) ->
+          let (V2 pmr pmc) = floor <$> pmmpos
+              seekpos = (pmr + fromIntegral dr, pmc + fromIntegral dc)
+          in  if mmimgmat M.! seekpos == Nothing && mmintmat M.! seekpos == 0
+              && acc == Nothing
+            then Just (pmmpos + (fromIntegral <$> V2 dr dc))
+            else acc
+          ) Nothing delta
     void $ createEntity $ newEntity
       { pos           = Just (V2 10.5 10.5)
+      , mmpos         = mmpos
       , vel           = Just (V2 0 0)
+      , mmvel         = Just (V2 0 0)
       , player        = Just ()
       , rot           = Just SE
+      , mmrot         = Just SE
       , anim          = Just $ AnimState (AnimId 0 "standing" SE) 0 0
       }
-    void $ liftIO $ swapMVar progress (15 / loadSteps)
+    void $ liftIO $ swapMVar progress (17 / loadSteps)
     void $ mapM_ (\npcpos@(V2 nr nc) -> do
       fact <- liftIO $ randomRIO (0.5, 1.5)
       future <- liftIO newEmptyMVar
@@ -100,7 +139,7 @@ loadMapFork ud future progress = do
         , anim          = Just $ AnimState (AnimId 1 "standing" SE) 0 0
         }
       ) npcposs
-    void $ liftIO $ swapMVar progress (16 / loadSteps)
+    void $ liftIO $ swapMVar progress (18 / loadSteps)
   putMVar future (nws, MainData
       { mapMat = mat
       , imgMat = M.fromList (nrows inter) (ncols inter) $
@@ -108,6 +147,7 @@ loadMapFork ud future progress = do
           (\a -> if a == Just ImgEmpty then Nothing else a)
           (M.toList inter)
       , reachPoints = rps
+      , mmImgMat = mmimgmat
       })
 
 mouseToPlayer :: V2 Int32 -> Affection UserData ()
@@ -338,6 +378,7 @@ updateMap dt = do
     (nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do
       emap allEnts $ do
         with anim
+        with pos
         stat <- query anim
         let an = assetAnimations ud Map.! asId stat
             ntime = asElapsedTime stat + dt

src/MindMap.hs

@@ -72,7 +72,7 @@ springField inGraph =
       in  (mmId node, fmap (* friction) accel)
     calcul graph =
       let deltas = map (calculDelta graph) (vertexList graph)
-      in  if any (\(_, v) -> len v > 0.05)
+      in  if any (\(_, v) -> len v > 0.1)
             (A.log A.Debug ("deltas: " ++ show deltas) deltas)
             -- deltas
         then
@@ -87,14 +87,16 @@ springField inGraph =
     normv v@(V2 0 0) = v
     normv v          = signorm v
 
-buildFloorMap :: AG.Graph MMNode -> M.Matrix Int
+buildFloorMap :: AG.Graph MMNode -> (M.Matrix Int, AG.Graph MMNode)
 buildFloorMap inGraph =
-  foldl
+  ( foldl
-    (\amat (MMNode (V2 r c) i) -> M.setElem (if i == 0 then -2 else i)
+      (\amat (MMNode (V2 r c) i) -> M.setElem (if i == 0 then -2 else i)
-      (floor r + 2, floor c + 2) amat
+        (floor r + 2, floor c + 2) amat
-      )
+        )
-    emptyFloor
+      emptyFloor
-    (A.log A.Debug ("floorGraph: " ++ show floorGraph) floorGraph)
+      (A.log A.Debug ("floorGraph: " ++ show floorGraph) floorGraph)
+  , fmap (\n -> n { mmPos = (+ 2) <$> mmPos n} ) floorGraph
+  )
   where
     normGraph =
       let minVert = V2
@@ -109,3 +111,41 @@ buildFloorMap inGraph =
       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

src/StateMachine.hs

@@ -7,18 +7,21 @@ import Affection
 import Types
 
 import Load
-import MainGame
+import MainGame.WorldMap
+import MainGame.MindMap
 
 instance StateMachine State UserData where
-  smLoad Main = loadMap
+  smLoad (Main _) = loadMap
 
   smLoad Load = loadLoad
 
-  smUpdate Main = updateMap
+  smUpdate (Main WorldMap) = updateMap
+  smUpdate (Main MindMap) = updateMind
 
   smUpdate Load = updateLoad
 
-  smDraw Main = drawMap
+  smDraw (Main WorldMap) = drawMap
+  smDraw (Main MindMap) = drawMind
 
   smDraw Load = drawLoad
 

src/Types/StateData.hs

@@ -22,5 +22,6 @@ data StateData
     { mapMat      :: Matrix TileState
     , imgMat      :: Matrix (Maybe ImgId)
     , reachPoints :: [ReachPoint]
+    , mmImgMat    :: Matrix (Maybe ImgId)
     }
   deriving (Eq)

src/Types/UserData.hs

@@ -44,15 +44,22 @@ data UserData = UserData
 
 data State
   = Load
-  | Main
+  | Main SubMain
   | Test
 
+data SubMain
+  = WorldMap
+  | MindMap
+
 data Entity f = Entity
   { pos           :: Component f 'Field (V2 Double)
+  , mmpos         :: Component f 'Field (V2 Double)
   , gridPos       :: Component f 'Field (V2 Int)
   , vel           :: Component f 'Field (V2 Double)
+  , mmvel           :: Component f 'Field (V2 Double)
   , velFact       :: Component f 'Field Double
   , rot           :: Component f 'Field Direction
+  , mmrot           :: Component f 'Field Direction
   , obstacle      :: Component f 'Field (Boundaries Double)
   , player        :: Component f 'Unique ()
   , npcMoveState  :: Component f 'Field NPCMoveState

tracer-game.cabal

@@ -33,7 +33,8 @@ executable tracer-game
                      , Interior
                      , Init
                      , Load
-                     , MainGame
+                     , MainGame.WorldMap
+                     , MainGame.MindMap
                      , Navigation
                      , MindMap
                      , NPC