diff --git a/shell.nix b/shell.nix index 7bb36cb..c29408c 100644 --- a/shell.nix +++ b/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; }; diff --git a/src/Interior.hs b/src/Interior.hs index a954c33..8bf1231 100644 --- a/src/Interior.hs +++ b/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) diff --git a/src/Navigation.hs b/src/Navigation.hs new file mode 100644 index 0000000..13b6c38 --- /dev/null +++ b/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 diff --git a/src/Test.hs b/src/Test.hs index e6dc656..ed92022 100644 --- a/src/Test.hs +++ b/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) diff --git a/src/Types/Interior.hs b/src/Types/Interior.hs index b07eff6..b83ddb8 100644 --- a/src/Types/Interior.hs +++ b/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) diff --git a/src/Util.hs b/src/Util.hs index ad1d6d1..c5f4f73 100644 --- a/src/Util.hs +++ b/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 diff --git a/tracer-game.cabal b/tracer-game.cabal index 757351c..dc09cff 100644 --- a/tracer-game.cabal +++ b/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