diff options
Diffstat (limited to 'users/glittershark/xanthous/src/Xanthous/Generators')
3 files changed, 130 insertions, 8 deletions
diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs b/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs index 83740fe4b73d..ada201ef3d6c 100644 --- a/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs +++ b/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs @@ -70,6 +70,7 @@ parseParams = Params <> Opt.help "Number of generations to run the automata for" <> Opt.metavar "STEPS" ) + <**> Opt.helper where parseChance = readWithGuard (between 0 1) diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs b/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs index 70d94860dc68..e1e367007e65 100644 --- a/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs +++ b/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs @@ -75,9 +75,6 @@ numAliveNeighborsM cells (x, y) = do ny = fromIntegral $ fromIntegral y + j in readArray cells (nx, ny) - neighborPositions :: [(Int, Int)] - neighborPositions = [(i, j) | i <- [-1..1], j <- [-1..1], (i, j) /= (0, 0)] - numAliveNeighbors :: forall a i j . (IArray a Bool, Ix (i, j), Integral i, Integral j) @@ -103,8 +100,8 @@ numAliveNeighbors cells (x, y) = ny = fromIntegral $ fromIntegral y + j in cells ! (nx, ny) - neighborPositions :: [(Int, Int)] - neighborPositions = [(i, j) | i <- [-1..1], j <- [-1..1], (i, j) /= (0, 0)] +neighborPositions :: [(Int, Int)] +neighborPositions = [(i, j) | i <- [-1..1], j <- [-1..1], (i, j) /= (0, 0)] fillOuterEdgesM :: (MArray a Bool m, Ix i, Ix j) => a (i, j) Bool -> m () fillOuterEdgesM arr = do @@ -137,7 +134,6 @@ floodFill :: forall a i j. , Enum i , Enum j , Bounded i , Bounded j , Eq i , Eq j - , Show i, Show j ) => a (i, j) Bool -- ^ array -> (i, j) -- ^ position @@ -145,7 +141,6 @@ floodFill :: forall a i j. floodFill = go mempty where go :: Set (i, j) -> a (i, j) Bool -> (i, j) -> Set (i, j) - -- TODO pass result in rather than passing seen in, return result go res arr@(bounds -> arrBounds) idx@(x, y) | not (inRange arrBounds idx) = res | not (arr ! idx) = res @@ -177,7 +172,6 @@ regions :: forall a i j. , Enum i , Enum j , Bounded i , Bounded j , Eq i , Eq j - , Show i, Show j ) => a (i, j) Bool -> [Set (i, j)] diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/Village.hs b/users/glittershark/xanthous/src/Xanthous/Generators/Village.hs new file mode 100644 index 000000000000..52f26dcde018 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Generators/Village.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module Xanthous.Generators.Village + -- ( fromCave + -- ) + where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (any, failing, toList) +-------------------------------------------------------------------------------- +import Control.Monad.Random (MonadRandom) +import Control.Monad.State (execStateT, MonadState, modify) +import Control.Monad.Trans.Maybe +import Control.Parallel.Strategies +import Data.Array.IArray +import Data.Foldable (any, toList) +-------------------------------------------------------------------------------- +import Xanthous.Data +import Xanthous.Data.EntityMap (EntityMap) +import qualified Xanthous.Data.EntityMap as EntityMap +import Xanthous.Entities.Environment +import Xanthous.Generators.Util +import Xanthous.Game.State (SomeEntity(..)) +import Xanthous.Random +-------------------------------------------------------------------------------- + +fromCave :: MonadRandom m + => Cells -- ^ The positions of all the walls + -> m (EntityMap SomeEntity) +fromCave wallPositions = execStateT (fromCave' wallPositions) mempty + +fromCave' :: forall m. (MonadRandom m, MonadState (EntityMap SomeEntity) m) + => Cells + -> m () +fromCave' wallPositions = failing (pure ()) $ do + Just villageRegion <- + choose + . (`using` parTraversable rdeepseq) + . weightedBy (\reg -> let circSize = length $ circumference reg + in if circSize == 50 + then (1.0 :: Double) + else 1.0 / (fromIntegral . abs $ circSize - 50)) + $ regions closedHallways + + let circ = setFromList . circumference $ villageRegion + + centerPoints <- chooseSubset (0.1 :: Double) $ toList circ + + roomTiles <- foldM + (flip $ const $ stepOut circ) + (map pure centerPoints) + [0 :: Int ..2] + + let roomWalls = circumference . setFromList @(Set _) <$> roomTiles + allWalls = join roomWalls + + doorPositions <- fmap join . for roomWalls $ \room -> + let candidates = filter (`notMember` circ) room + in fmap toList . choose $ ChooseElement candidates + + let entryways = + filter (\pt -> + let ncs = neighborCells pt + in any ((&&) <$> (not . (wallPositions !)) + <*> (`notMember` villageRegion)) ncs + && any ((&&) <$> (`member` villageRegion) + <*> (`notElem` allWalls)) ncs) + $ toList villageRegion + + Just entryway <- choose $ ChooseElement entryways + + for_ (filter ((&&) <$> (`notElem` doorPositions) <*> (/= entryway)) allWalls) + $ insertEntity Wall + for_ (filter (/= entryway) doorPositions) $ insertEntity unlockedDoor + insertEntity unlockedDoor entryway + + + where + insertEntity e pt = modify $ EntityMap.insertAt (ptToPos pt) $ SomeEntity e + ptToPos pt = _Position # (pt & both %~ fromIntegral) + + stepOut :: Set (Word, Word) -> [[(Word, Word)]] -> MaybeT m [[(Word, Word)]] + stepOut circ rooms = for rooms $ \room -> + let nextLevels = hashNub $ toList . neighborCells =<< room + in pure + . (<> room) + $ filter ((&&) <$> (`notMember` circ) <*> (`notElem` join rooms)) + nextLevels + + circumference pts = + filter (any (`notMember` pts) . neighborCells) $ toList pts + closedHallways = closeHallways livePositions + livePositions = amap not wallPositions + +-------------------------------------------------------------------------------- + +closeHallways :: Cells -> Cells +closeHallways livePositions = + livePositions // mapMaybe closeHallway (assocs livePositions) + where + closeHallway (_, False) = Nothing + closeHallway (pos, _) + | isHallway pos = Just (pos, False) + | otherwise = Nothing + isHallway pos = any ((&&) <$> not . view left <*> not . view right) + . rotations + . fmap (fromMaybe False) + $ arrayNeighbors livePositions pos + +failing :: Monad m => m a -> MaybeT m a -> m a +failing result = (maybe result pure =<<) . runMaybeT + +{- + +import Xanthous.Generators.Village +import Xanthous.Generators +import Xanthous.Data +import System.Random +import qualified Data.Text +import qualified Xanthous.Generators.CaveAutomata as CA +let gi = GeneratorInput SCaveAutomata CA.defaultParams +wallPositions <- generateFromInput gi (Dimensions 80 50) <$> getStdGen +putStrLn . Data.Text.unpack $ showCells wallPositions + +import Data.Array.IArray +let closedHallways = closeHallways . amap not $ wallPositions +putStrLn . Data.Text.unpack . showCells $ amap not closedHallways + +-} |