validate placement of interior through wayfinding

This commit is contained in:
nek0 2018-04-02 16:29:35 +02:00
parent e150be9e77
commit f28f06adf3
7 changed files with 135 additions and 26 deletions

View file

@ -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;
};

View file

@ -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)

41
src/Navigation.hs Normal file
View file

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

View file

@ -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)

View file

@ -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)

View file

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

View file

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