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; hydraPlatforms = pkgs.stdenv.lib.platforms.none;
}) { }; }) { };
f = { mkDerivation, base, containers, ecstasy, linear f = { mkDerivation, astar, base, containers, ecstasy, linear
, matrix, OpenGL, random, sdl2, stdenv, stm, text, vector , matrix, OpenGL, random, sdl2, stdenv, stm, text, unordered-containers
, vector
}: }:
mkDerivation { mkDerivation {
pname = "tracer-game"; pname = "tracer-game";
@ -71,8 +72,8 @@ let
isLibrary = false; isLibrary = false;
isExecutable = true; isExecutable = true;
executableHaskellDepends = [ executableHaskellDepends = [
affectionNeko base containers ecstasy linear matrix nanovgNeko OpenGL affectionNeko astar base containers ecstasy linear matrix nanovgNeko
random sdl2 stm text vector OpenGL random sdl2 stm text unordered-containers vector
]; ];
license = stdenv.lib.licenses.gpl3; 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.List as L
import Data.Maybe (isNothing, isJust) import Data.Maybe (isNothing, isJust)
import Linear.V2
import System.Random import System.Random
-- internal imports -- internal imports
import Navigation
import Types.Interior import Types.Interior
import Types.Map import Types.Map
import Types.UserData import Types.UserData
@ -18,25 +22,26 @@ import Types.UserData
placeInteriorIO placeInteriorIO
:: Matrix TileState :: Matrix TileState
-> Matrix (Maybe ImgId) -> Matrix (Maybe ImgId)
-> [ReachPoint]
-> [Graph] -> [Graph]
-> IO (Matrix (Maybe ImgId)) -> IO (Matrix (Maybe ImgId), [ReachPoint])
placeInteriorIO imat imgmat graph = placeInteriorIO imat imgmat irp graph =
do do
rnd <- newStdGen rnd <- newStdGen
let (_, mat) = let (_, matps) =
foldl foldl
traverseGraph traverseGraph
(rnd, imgmat) (rnd, (imgmat, irp))
graph graph
return mat return matps
where where
traverseGraph traverseGraph
:: (StdGen, Matrix (Maybe ImgId)) :: (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
-> Graph -> Graph
-> (StdGen, Matrix (Maybe ImgId)) -> (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
traverseGraph acc (GHall sub) = traverseGraph acc (GHall sub) =
foldl traverseGraph acc sub foldl traverseGraph acc sub
traverseGraph put@(rng, mat) (GRoom _ bnds) = traverseGraph put@(rng, (mat, rp)) (GRoom _ bnds) =
let applicable = let applicable =
reverse (L.sortBy (\a b -> size a `compare` size b) ( reverse (L.sortBy (\a b -> size a `compare` size b) (
L.filter L.filter
@ -57,8 +62,19 @@ placeInteriorIO imat imgmat graph =
) )
) )
in in
foldl (\(orng, omat) -> placeCluster orng bnds 1 omat) put applicable foldl
placeCluster rng bnds try mat appl = (\(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 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 (pc, g2) = randomR (snd (matmin bnds) - 1, snd (matmax bnds) - 1) g1
freeRoom = foldl freeRoom = foldl
@ -70,11 +86,25 @@ placeInteriorIO imat imgmat graph =
mat mat
) )
cmat = clusterMat appl 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 in
if try > 10 || fromIntegral freeRoom < size appl if try > 10 || fromIntegral freeRoom < size appl
then (g2, mat) then (g2, (mat, rp))
else else
if pr + nrows cmat - 1 > fst (matmax bnds) || if (pr + nrows cmat - 1 > fst (matmax bnds) ||
pc + ncols cmat - 1 > snd (matmax bnds) || pc + ncols cmat - 1 > snd (matmax bnds) ||
any (/= clusterRoom appl) any (/= clusterRoom appl)
(M.toList (M.submatrix (M.toList (M.submatrix
@ -87,10 +117,11 @@ placeInteriorIO imat imgmat graph =
pr (pr + nrows cmat - 1) pr (pr + nrows cmat - 1)
pc (pc + ncols cmat - 1) pc (pc + ncols cmat - 1)
mat 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 else placeCluster
g2 bnds (try + 1) (insertMat cmat mat (pr, pc)) appl g2 bnds (try + 1) newmat newrp appl
insertMat insertMat
:: Matrix (Maybe a) :: Matrix (Maybe a)
@ -108,3 +139,7 @@ insertMat i into (roffs, coffs) =
) )
into into
((,) <$> [1 .. nrows i] <*> [1 .. ncols i]) ((,) <$> [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) (50,75)
(Subsystems _ m) = subsystems ud (Subsystems _ m) = subsystems ud
(mat, gr) <- liftIO $ buildHallFloorIO fc (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 (nws, _) <- yieldSystemT (worldState ud) $ do
void $ newEntity $ defEntity void $ newEntity $ defEntity
{ pos = Just (V2 20.5 20.5) { pos = Just (V2 20.5 20.5)

View file

@ -2,6 +2,8 @@ module Types.Interior where
import Data.Matrix as M import Data.Matrix as M
import Linear.V2
-- internal imports -- internal imports
import Types.Map import Types.Map
@ -22,9 +24,8 @@ clusterMat ClusterBox1 =
] ]
clusterMat ClusterCornerTable = clusterMat ClusterCornerTable =
M.fromLists M.fromLists
[ [Just ImgEmpty, Just ImgMiscTable2, Just ImgMiscTableCorner] [ [Just ImgMiscTable2, Just ImgMiscTableCorner]
, [Just ImgEmpty, Just ImgEmpty , Just ImgMiscTable1] , [Just ImgEmpty , Just ImgMiscTable1]
, [Just ImgEmpty, Just ImgEmpty , Just ImgEmpty]
] ]
clusterMat ClusterTableGroup = clusterMat ClusterTableGroup =
M.fromLists M.fromLists
@ -50,10 +51,29 @@ clusterRoom ClusterBox1 = Offi
clusterRoom ClusterCornerTable = Offi clusterRoom ClusterCornerTable = Offi
clusterRoom ClusterTableGroup = 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 instance Size Cluster where
size c = size c =
let mat = clusterMat c let mat = clusterMat c
in fromIntegral ((nrows mat) * (ncols mat)) in fromIntegral ((nrows mat) * (ncols mat))
-- class ClusterData c where data ReachPoint = ReachPoint
-- clusterMat :: c -> Matrix (Maybe ImgId) { 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 Offi
| any | any
(\(rr, cc) -> M.safeGet (irow + rr) (icol + cc) mat == Just Door) (\(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 Just ImgEmpty
| otherwise -> | otherwise ->
Nothing Nothing

View file

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