validate placement of interior through wayfinding

shell.nix

@@ -61,8 +61,9 @@ let
       hydraPlatforms = pkgs.stdenv.lib.platforms.none;
     }) { };
 
-  f = { mkDerivation, base, containers, ecstasy, linear
-      , matrix, OpenGL, random, sdl2, stdenv, stm, text, vector
+  f = { mkDerivation, astar, base, containers, ecstasy, linear
+      , matrix, OpenGL, random, sdl2, stdenv, stm, text, unordered-containers
+      , vector
       }:
       mkDerivation {
         pname = "tracer-game";
@@ -71,8 +72,8 @@ let
         isLibrary = false;
         isExecutable = true;
         executableHaskellDepends = [
-          affectionNeko base containers ecstasy linear matrix nanovgNeko OpenGL
-          random sdl2 stm text vector
+          affectionNeko astar base containers ecstasy linear matrix nanovgNeko
+          OpenGL random sdl2 stm text unordered-containers vector
         ];
         license = stdenv.lib.licenses.gpl3;
       };

src/Interior.hs

@@ -7,10 +7,14 @@ import qualified Data.Map.Strict as Map
 import Data.List as L
 import Data.Maybe (isNothing, isJust)
 
+import Linear.V2
+
 import System.Random
 
 -- internal imports
 
+import Navigation
+
 import Types.Interior
 import Types.Map
 import Types.UserData
@@ -18,25 +22,26 @@ import Types.UserData
 placeInteriorIO
   :: Matrix TileState
   -> Matrix (Maybe ImgId)
+  -> [ReachPoint]
   -> [Graph]
-  -> IO (Matrix (Maybe ImgId))
-placeInteriorIO imat imgmat graph =
+  -> IO (Matrix (Maybe ImgId), [ReachPoint])
+placeInteriorIO imat imgmat irp graph =
   do
     rnd <- newStdGen
-    let (_, mat) =
+    let (_, matps) =
           foldl
             traverseGraph
-            (rnd, imgmat)
+            (rnd, (imgmat, irp))
             graph
-    return mat
+    return matps
   where
     traverseGraph
-      :: (StdGen, Matrix (Maybe ImgId))
+      :: (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
       -> Graph
-      -> (StdGen, Matrix (Maybe ImgId))
+      -> (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
     traverseGraph acc (GHall sub) =
       foldl traverseGraph acc sub
-    traverseGraph put@(rng, mat) (GRoom _ bnds) =
+    traverseGraph put@(rng, (mat, rp)) (GRoom _ bnds) =
       let applicable =
             reverse (L.sortBy (\a b -> size a `compare` size b) (
               L.filter
@@ -57,8 +62,19 @@ placeInteriorIO imat imgmat graph =
                 )
             )
       in
-        foldl (\(orng, omat) -> placeCluster orng bnds 1 omat) put applicable
-    placeCluster rng bnds try mat appl =
+        foldl
+          (\(orng, (omat, orp)) -> placeCluster orng bnds 1 omat orp)
+          put
+          applicable
+    placeCluster
+      :: StdGen
+      -> Boundaries Int
+      -> Int
+      -> Matrix (Maybe ImgId)
+      -> [ReachPoint]
+      -> Cluster
+      -> (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
+    placeCluster rng bnds try mat rp appl =
       let (pr, g1) = randomR (fst (matmin bnds) - 1, fst (matmax bnds) - 1) rng
           (pc, g2) = randomR (snd (matmin bnds) - 1, snd (matmax bnds) - 1) g1
           freeRoom = foldl
@@ -70,11 +86,25 @@ placeInteriorIO imat imgmat graph =
               mat
               )
           cmat = clusterMat appl
+          newmat = insertMat cmat mat (pr, pc)
+          exits = filter
+            (\p -> pointType p == RoomExit && inBounds (pointCoord p) bnds)
+            rp
+          reaches = map (+ V2 (pr - 1) (pc - 1))
+            (map pointCoord (clusterPoints appl))
+          oldreaches = foldl (\acc p ->
+              if pointType p /= RoomExit && inBounds (pointCoord p) bnds
+              then pointCoord p : acc
+              else acc
+              )
+            []
+            rp
+          newrp = rp ++ map (ReachPoint Table) reaches
       in
         if try > 10 || fromIntegral freeRoom < size appl
-        then (g2, mat)
+        then (g2, (mat, rp))
         else
-          if pr + nrows cmat - 1 > fst (matmax bnds) ||
+          if (pr + nrows cmat - 1 > fst (matmax bnds) ||
              pc + ncols cmat - 1 > snd (matmax bnds) ||
              any (/= clusterRoom appl)
                (M.toList (M.submatrix
@@ -87,10 +117,11 @@ placeInteriorIO imat imgmat graph =
                  pr (pr + nrows cmat - 1)
                  pc (pc + ncols cmat - 1)
                  mat
-                 ))
-          then placeCluster g2 bnds (try + 1) mat appl
+                 ))) ||
+             not (isReachable newmat (oldreaches ++ reaches) exits)
+          then placeCluster g2 bnds (try + 1) mat rp appl
           else placeCluster
-            g2 bnds (try + 1) (insertMat cmat mat (pr, pc)) appl
+            g2 bnds (try + 1) newmat newrp appl
 
 insertMat
   :: Matrix (Maybe a)
@@ -108,3 +139,7 @@ insertMat i into (roffs, coffs) =
       )
     into
     ((,) <$> [1 .. nrows i] <*> [1 .. ncols i])
+
+inBounds :: V2 Int -> Boundaries Int -> Bool
+inBounds (V2 r c) (Boundaries (minr, minc) (maxr, maxc)) =
+  (r >= minr && r <= maxr) && (c >= minc && c <= maxc)

src/Navigation.hs

@@ -0,0 +1,41 @@
+module Navigation where
+
+import Affection as A
+
+import Data.Matrix as M
+import qualified Data.HashSet as HS
+import Data.Graph.AStar
+import Data.Maybe (isJust)
+
+import Linear
+
+-- internal imports
+
+import Types.Map
+import Types.UserData
+import Types.Interior
+
+isReachable :: Matrix (Maybe ImgId) -> [V2 Int] -> [ReachPoint] -> Bool
+isReachable imgmat reaches exits =
+  let astarAppl ex rc = aStar
+        (naviGraph imgmat)
+        (\a b -> distance (fmap fromIntegral a) (fmap fromIntegral b))
+        (\a -> distance (fmap fromIntegral ex) (fmap fromIntegral a))
+        (== ex)
+        rc
+      result =
+        (concatMap
+          (\exit -> map (astarAppl exit) reaches)
+          (map pointCoord exits))
+  in  all isJust result
+
+naviGraph :: Matrix (Maybe ImgId) -> V2 Int -> HS.HashSet (V2 Int)
+naviGraph imgmat (V2 r c) =
+  let list = foldl
+        (\acc (or, oc) -> if null (imgObstacle $ imgmat M.! (r + or, c + oc))
+          then if or == 0 && oc == 0 then acc else V2 (r + or) (c + oc): acc
+          else acc
+          )
+        []
+        [(0, 1), (0, -1), (1, 0), (-1, 0)]
+  in  HS.fromList list

src/Test.hs

@@ -39,7 +39,16 @@ loadMap = do
         (50,75)
       (Subsystems _ m) = subsystems ud
   (mat, gr) <- liftIO $ buildHallFloorIO fc
-  inter <- liftIO $ placeInteriorIO mat (convertTileToImg mat) gr
+  let imgmat = convertTileToImg mat
+      exits = Prelude.foldl
+        (\acc coord@(r, c) -> if imgmat M.! coord == Just ImgEmpty
+          then ReachPoint RoomExit (V2 r c) : acc
+          else acc
+          )
+        []
+        ((,) <$> [1 .. nrows mat] <*> [1 .. ncols mat])
+  -- liftIO $ A.logIO A.Debug (show exits)
+  (inter, _) <- liftIO $ placeInteriorIO mat imgmat exits gr
   (nws, _) <- yieldSystemT (worldState ud) $ do
     void $ newEntity $ defEntity
       { pos = Just (V2 20.5 20.5)

src/Types/Interior.hs

@@ -2,6 +2,8 @@ module Types.Interior where
 
 import Data.Matrix as M
 
+import Linear.V2
+
 -- internal imports
 
 import Types.Map
@@ -22,9 +24,8 @@ clusterMat ClusterBox1 =
     ]
 clusterMat ClusterCornerTable =
   M.fromLists
-    [ [Just ImgEmpty, Just ImgMiscTable2, Just ImgMiscTableCorner]
-    , [Just ImgEmpty, Just ImgEmpty     , Just ImgMiscTable1]
-    , [Just ImgEmpty, Just ImgEmpty     , Just ImgEmpty]
+    [ [Just ImgMiscTable2, Just ImgMiscTableCorner]
+    , [Just ImgEmpty     , Just ImgMiscTable1]
     ]
 clusterMat ClusterTableGroup =
   M.fromLists
@@ -50,10 +51,29 @@ clusterRoom ClusterBox1 = Offi
 clusterRoom ClusterCornerTable = Offi
 clusterRoom ClusterTableGroup = Offi
 
+clusterPoints :: Cluster -> [ReachPoint]
+clusterPoints ClusterBox1 = []
+clusterPoints ClusterCornerTable =
+  [ ReachPoint Table (V2 2 1)
+  ]
+clusterPoints ClusterTableGroup =
+  [ ReachPoint Table (V2 2 2)
+  , ReachPoint Table (V2 2 5)
+  , ReachPoint Table (V2 5 5)
+  ]
+
 instance Size Cluster where
   size c =
     let mat = clusterMat c
     in  fromIntegral ((nrows mat) * (ncols mat))
 
--- class ClusterData c where
---   clusterMat :: c -> Matrix (Maybe ImgId)
+data ReachPoint = ReachPoint
+  { pointType  :: PointType
+  , pointCoord :: V2 Int
+  }
+  deriving (Show)
+
+data PointType
+  = RoomExit
+  | Table
+  deriving (Eq, Show)

src/Util.hs

@@ -84,7 +84,7 @@ convertTileToImg mat = fromLists conversion
         Offi
           | any
             (\(rr, cc) -> M.safeGet (irow + rr) (icol + cc) mat == Just Door)
-            ((,) <$> [-1 .. 1] <*> [-1 .. 1]) ->
+            [(1, 0), (-1, 0), (0, 1), (0, -1)] ->
             Just ImgEmpty
           | otherwise ->
             Nothing

tracer-game.cabal

@@ -26,6 +26,7 @@ executable tracer-game
                      , Interior
                      , Init
                      , Test
+                     , Navigation
                      , Util
   default-extensions:  OverloadedStrings
                      , DeriveGeneric
@@ -44,6 +45,8 @@ executable tracer-game
                      , matrix
                      , random
                      , vector
+                     , astar
+                     , unordered-containers
   hs-source-dirs:      src
   ghc-options:         -Wall -threaded
   default-language:    Haskell2010