diff options
Diffstat (limited to 'users/aspen/xanthous/src/Xanthous/Generators/Level')
5 files changed, 846 insertions, 0 deletions
diff --git a/users/aspen/xanthous/src/Xanthous/Generators/Level/CaveAutomata.hs b/users/aspen/xanthous/src/Xanthous/Generators/Level/CaveAutomata.hs new file mode 100644 index 000000000000..03d534ca39b3 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Generators/Level/CaveAutomata.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Generators.Level.CaveAutomata + ( Params(..) + , defaultParams + , parseParams + , generate + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +import Control.Monad.Random (RandomGen, runRandT) +import Data.Array.ST +import Data.Array.Unboxed +import qualified Options.Applicative as Opt +-------------------------------------------------------------------------------- +import Xanthous.Util (between) +import Xanthous.Util.Optparse +import Xanthous.Data (Dimensions, width, height) +import Xanthous.Generators.Level.Util +import Linear.V2 +-------------------------------------------------------------------------------- + +data Params = Params + { _aliveStartChance :: Double + , _birthLimit :: Word + , _deathLimit :: Word + , _steps :: Word + } + deriving stock (Show, Eq, Generic) +makeLenses ''Params + +defaultParams :: Params +defaultParams = Params + { _aliveStartChance = 0.6 + , _birthLimit = 3 + , _deathLimit = 4 + , _steps = 4 + } + +parseParams :: Opt.Parser Params +parseParams = Params + <$> Opt.option parseChance + ( Opt.long "alive-start-chance" + <> Opt.value (defaultParams ^. aliveStartChance) + <> Opt.showDefault + <> Opt.help ( "Chance for each cell to start alive at the beginning of " + <> "the cellular automata" + ) + <> Opt.metavar "CHANCE" + ) + <*> Opt.option parseNeighbors + ( Opt.long "birth-limit" + <> Opt.value (defaultParams ^. birthLimit) + <> Opt.showDefault + <> Opt.help "Minimum neighbor count required for birth of a cell" + <> Opt.metavar "NEIGHBORS" + ) + <*> Opt.option parseNeighbors + ( Opt.long "death-limit" + <> Opt.value (defaultParams ^. deathLimit) + <> Opt.showDefault + <> Opt.help "Maximum neighbor count required for death of a cell" + <> Opt.metavar "NEIGHBORS" + ) + <*> Opt.option Opt.auto + ( Opt.long "steps" + <> Opt.value (defaultParams ^. steps) + <> Opt.showDefault + <> Opt.help "Number of generations to run the automata for" + <> Opt.metavar "STEPS" + ) + <**> Opt.helper + where + parseChance = readWithGuard + (between 0 1) + $ \res -> "Chance must be in the range [0,1], got: " <> show res + + parseNeighbors = readWithGuard + (between 0 8) + $ \res -> "Neighbors must be in the range [0,8], got: " <> show res + +generate :: RandomGen g => Params -> Dimensions -> g -> Cells +generate params dims gen + = runSTUArray + $ fmap fst + $ flip runRandT gen + $ generate' params dims + +generate' :: RandomGen g => Params -> Dimensions -> CellM g s (MCells s) +generate' params dims = do + cells <- randInitialize dims $ params ^. aliveStartChance + let steps' = params ^. steps + when (steps' > 0) + $ for_ [0 .. pred steps'] . const $ stepAutomata cells dims params + -- Remove all but the largest contiguous region of unfilled space + (_: smallerRegions) <- lift $ regions @UArray . amap not <$> freeze cells + lift $ fillAllM (fold smallerRegions) cells + lift $ fillOuterEdgesM cells + pure cells + +stepAutomata :: forall s g. MCells s -> Dimensions -> Params -> CellM g s () +stepAutomata cells dims params = do + origCells <- lift $ cloneMArray @_ @(STUArray s) cells + for_ (range (0, V2 (dims ^. width) (dims ^. height))) $ \pos -> do + neighs <- lift $ numAliveNeighborsM origCells pos + origValue <- lift $ readArray origCells pos + lift . writeArray cells pos + $ if origValue + then neighs >= params ^. deathLimit + else neighs > params ^. birthLimit diff --git a/users/aspen/xanthous/src/Xanthous/Generators/Level/Dungeon.hs b/users/aspen/xanthous/src/Xanthous/Generators/Level/Dungeon.hs new file mode 100644 index 000000000000..0be7c0435c5a --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Generators/Level/Dungeon.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Generators.Level.Dungeon + ( Params(..) + , defaultParams + , parseParams + , generate + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding ((:>)) +-------------------------------------------------------------------------------- +import Control.Monad.Random +import Data.Array.ST +import Data.Array.IArray (amap) +import Data.Stream.Infinite (Stream(..)) +import qualified Data.Stream.Infinite as Stream +import qualified Data.Graph.Inductive.Graph as Graph +import Data.Graph.Inductive.PatriciaTree +import qualified Data.List.NonEmpty as NE +import Data.Maybe (fromJust) +import Linear.V2 +import Linear.Metric +import qualified Options.Applicative as Opt +-------------------------------------------------------------------------------- +import Xanthous.Random +import Xanthous.Data hiding (x, y, _x, _y, edges, distance) +import Xanthous.Generators.Level.Util +import Xanthous.Util.Graphics (delaunay, straightLine) +import Xanthous.Util.Graph (mstSubGraph) +-------------------------------------------------------------------------------- + +data Params = Params + { _numRoomsRange :: (Word, Word) + , _roomDimensionRange :: (Word, Word) + , _connectednessRatioRange :: (Double, Double) + } + deriving stock (Show, Eq, Ord, Generic) +makeLenses ''Params + +defaultParams :: Params +defaultParams = Params + { _numRoomsRange = (6, 8) + , _roomDimensionRange = (3, 12) + , _connectednessRatioRange = (0.1, 0.15) + } + +parseParams :: Opt.Parser Params +parseParams = Params + <$> parseRange + "num-rooms" + "number of rooms to generate in the dungeon" + "ROOMS" + (defaultParams ^. numRoomsRange) + <*> parseRange + "room-size" + "size in tiles of one of the sides of a room" + "TILES" + (defaultParams ^. roomDimensionRange) + <*> parseRange + "connectedness-ratio" + ( "ratio of edges from the delaunay triangulation to re-add to the " + <> "minimum-spanning-tree") + "RATIO" + (defaultParams ^. connectednessRatioRange) + <**> Opt.helper + where + parseRange name desc metavar (defMin, defMax) = + (,) + <$> Opt.option Opt.auto + ( Opt.long ("min-" <> name) + <> Opt.value defMin + <> Opt.showDefault + <> Opt.help ("Minimum " <> desc) + <> Opt.metavar metavar + ) + <*> Opt.option Opt.auto + ( Opt.long ("max-" <> name) + <> Opt.value defMax + <> Opt.showDefault + <> Opt.help ("Maximum " <> desc) + <> Opt.metavar metavar + ) + +generate :: RandomGen g => Params -> Dimensions -> g -> Cells +generate params dims gen + = amap not + $ runSTUArray + $ fmap fst + $ flip runRandT gen + $ generate' params dims + +-------------------------------------------------------------------------------- + +generate' :: RandomGen g => Params -> Dimensions -> CellM g s (MCells s) +generate' params dims = do + cells <- initializeEmpty dims + rooms <- genRooms params dims + for_ rooms $ fillRoom cells + + let fullRoomGraph = delaunayRoomGraph rooms + mst = mstSubGraph fullRoomGraph + mstEdges = Graph.edges mst + nonMSTEdges = filter (\(n₁, n₂, _) -> (n₁, n₂) `notElem` mstEdges) + $ Graph.labEdges fullRoomGraph + + reintroEdgeCount <- floor . (* fromIntegral (length nonMSTEdges)) + <$> getRandomR (params ^. connectednessRatioRange) + let reintroEdges = take reintroEdgeCount nonMSTEdges + corridorGraph = Graph.insEdges reintroEdges mst + + corridors <- traverse + ( uncurry corridorBetween + . over both (fromJust . Graph.lab corridorGraph) + ) $ Graph.edges corridorGraph + + for_ (join corridors) $ \pt -> lift $ writeArray cells pt True + + pure cells + +type Room = Box Word + +genRooms :: MonadRandom m => Params -> Dimensions -> m [Room] +genRooms params dims = do + numRooms <- fromIntegral <$> getRandomR (params ^. numRoomsRange) + subRand . fmap (Stream.take numRooms . removeIntersecting []) . infinitely $ do + roomWidth <- getRandomR $ params ^. roomDimensionRange + roomHeight <- getRandomR $ params ^. roomDimensionRange + xPos <- getRandomR (0, dims ^. width - roomWidth) + yPos <- getRandomR (0, dims ^. height - roomHeight) + pure Box + { _topLeftCorner = V2 xPos yPos + , _dimensions = V2 roomWidth roomHeight + } + where + removeIntersecting seen (room :> rooms) + | any (boxIntersects room) seen + = removeIntersecting seen rooms + | otherwise + = room :> removeIntersecting (room : seen) rooms + streamRepeat x = x :> streamRepeat x + infinitely = sequence . streamRepeat + +delaunayRoomGraph :: [Room] -> Gr Room Double +delaunayRoomGraph rooms = + Graph.insEdges edges . Graph.insNodes nodes $ Graph.empty + where + edges = map (\((n₁, room₁), (n₂, room₂)) -> (n₁, n₂, roomDist room₁ room₂)) + . over (mapped . both) snd + . delaunay @Double + . NE.fromList + . map (\p@(_, room) -> (boxCenter $ fromIntegral <$> room, p)) + $ nodes + nodes = zip [0..] rooms + roomDist = distance `on` (boxCenter . fmap fromIntegral) + +fillRoom :: MCells s -> Room -> CellM g s () +fillRoom cells room = + let V2 posx posy = room ^. topLeftCorner + V2 dimx dimy = room ^. dimensions + in for_ [posx .. posx + dimx] $ \x -> + for_ [posy .. posy + dimy] $ \y -> + lift $ writeArray cells (V2 x y) True + +corridorBetween :: MonadRandom m => Room -> Room -> m [V2 Word] +corridorBetween originRoom destinationRoom + = straightLine <$> origin <*> destination + where + origin = choose . NE.fromList =<< originEdge + destination = choose . NE.fromList =<< destinationEdge + originEdge = pickEdge originRoom originCorner + destinationEdge = pickEdge destinationRoom destinationCorner + pickEdge room corner = choose . over both (boxEdge room) $ cornerEdges corner + originCorner = + case ( compare (originRoom ^. topLeftCorner . _x) + (destinationRoom ^. topLeftCorner . _x) + , compare (originRoom ^. topLeftCorner . _y) + (destinationRoom ^. topLeftCorner . _y) + ) of + (LT, LT) -> BottomRight + (LT, GT) -> TopRight + (GT, LT) -> BottomLeft + (GT, GT) -> TopLeft + + (EQ, LT) -> BottomLeft + (EQ, GT) -> TopRight + (GT, EQ) -> TopLeft + (LT, EQ) -> BottomRight + (EQ, EQ) -> TopLeft -- should never happen + + destinationCorner = opposite originCorner diff --git a/users/aspen/xanthous/src/Xanthous/Generators/Level/LevelContents.hs b/users/aspen/xanthous/src/Xanthous/Generators/Level/LevelContents.hs new file mode 100644 index 000000000000..4f8a2f42ee16 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Generators/Level/LevelContents.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE RecordWildCards #-} +-------------------------------------------------------------------------------- +module Xanthous.Generators.Level.LevelContents + ( chooseCharacterPosition + , randomItems + , randomCreatures + , randomDoors + , placeDownStaircase + , tutorialMessage + , entityFromRaw + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (any, toList) +-------------------------------------------------------------------------------- +import Control.Monad.Random +import Data.Array.IArray (amap, bounds, rangeSize, (!)) +import qualified Data.Array.IArray as Arr +import Data.Foldable (any, toList) +import Linear.V2 +-------------------------------------------------------------------------------- +import Xanthous.Generators.Level.Util +import Xanthous.Random hiding (chance) +import qualified Xanthous.Random as Random +import Xanthous.Data + ( positionFromV2, Position, _Position + , rotations, arrayNeighbors, Neighbors(..) + , neighborPositions + ) +import Xanthous.Data.EntityMap (EntityMap, _EntityMap) +import Xanthous.Entities.Raws (rawsWithType, RawType, raw) +import qualified Xanthous.Entities.Item as Item +import Xanthous.Entities.Item (Item) +import qualified Xanthous.Entities.Creature as Creature +import Xanthous.Entities.Creature (Creature) +import Xanthous.Entities.Environment + (GroundMessage(..), Door(..), unlockedDoor, Staircase(..)) +import Xanthous.Messages (message_) +import Xanthous.Util.Graphics (circle) +import Xanthous.Entities.RawTypes +import Xanthous.Entities.Creature.Hippocampus (initialHippocampus) +import Xanthous.Entities.Common (inRightHand, asWieldedItem, wielded) +import Xanthous.Game.State (SomeEntity(SomeEntity)) +-------------------------------------------------------------------------------- + +chooseCharacterPosition :: MonadRandom m => Cells -> m Position +chooseCharacterPosition = randomPosition + +randomItems :: MonadRandom m => Cells -> m (EntityMap Item) +randomItems = randomEntities (fmap Identity . Item.newWithType) (0.0004, 0.001) + +placeDownStaircase :: MonadRandom m => Cells -> m (EntityMap Staircase) +placeDownStaircase cells = do + pos <- randomPosition cells + pure $ _EntityMap # [(pos, DownStaircase)] + +randomDoors :: MonadRandom m => Cells -> m (EntityMap Door) +randomDoors cells = do + doorRatio <- getRandomR subsetRange + let numDoors = floor $ doorRatio * fromIntegral (length candidateCells) + doorPositions = + removeAdjacent . fmap positionFromV2 . take numDoors $ candidateCells + doors = zip doorPositions $ repeat unlockedDoor + pure $ _EntityMap # doors + where + removeAdjacent = + foldr (\pos acc -> + if pos `elem` (acc >>= toList . neighborPositions) + then acc + else pos : acc + ) [] + candidateCells = filter doorable $ Arr.indices cells + subsetRange = (0.8 :: Double, 1.0) + doorable pos = + not (fromMaybe True $ cells ^? ix pos) + && any (teeish . fmap (fromMaybe True)) + (rotations $ arrayNeighbors cells pos) + -- only generate doors at the *ends* of hallways, eg (where O is walkable, + -- X is a wall, and D is a door): + -- + -- O O O + -- X D X + -- O + teeish (fmap not -> (Neighbors tl t tr l r _ b _ )) = + and [tl, t, tr, b] && (and . fmap not) [l, r] + +randomCreatures + :: MonadRandom m + => Word -- ^ Level number, starting at 0 + -> Cells + -> m (EntityMap Creature) +randomCreatures levelNumber + = randomEntities maybeNewCreature (0.0007, 0.002) + where + maybeNewCreature cType + | maybe True (canGenerate levelNumber) $ cType ^. generateParams + = Just <$> newCreatureWithType cType + | otherwise + = pure Nothing + +newCreatureWithType :: MonadRandom m => CreatureType -> m Creature +newCreatureWithType _creatureType = do + let _hitpoints = _creatureType ^. maxHitpoints + _hippocampus = initialHippocampus + + equipped <- fmap join + . traverse genEquipped + $ _creatureType + ^.. generateParams . _Just . equippedItem . _Just + let _inventory = maybe id (\ei -> wielded .~ inRightHand ei) (headMay equipped) mempty + pure Creature.Creature {..} + where + genEquipped cei = do + doGen <- Random.chance $ cei ^. chance + let entName = cei ^. entityName + itemType = + fromMaybe (error $ "raw \"" <> unpack entName <> "\" not of type Item") + . preview _Item + . fromMaybe (error $ "Could not find raw: " <> unpack entName) + $ raw entName + item <- Item.newWithType itemType + if doGen + then pure [fromMaybe (error $ "raw \"" <> unpack entName <> "\" not wieldable") + $ preview asWieldedItem item] + else pure [] + + +tutorialMessage :: MonadRandom m + => Cells + -> Position -- ^ CharacterPosition + -> m (EntityMap GroundMessage) +tutorialMessage cells characterPosition = do + let distance = 2 + pos <- fmap (fromMaybe (error "No valid positions for tutorial message?")) + . choose . ChooseElement + $ accessiblePositionsWithin distance cells characterPosition + msg <- message_ ["tutorial", "message1"] + pure $ _EntityMap # [(pos, GroundMessage msg)] + where + accessiblePositionsWithin :: Int -> Cells -> Position -> [Position] + accessiblePositionsWithin dist valid pos = + review _Position + <$> filter + (\pt -> not $ valid ! (fromIntegral <$> pt)) + (circle (pos ^. _Position) dist) + +randomEntities + :: forall entity raw m t. (MonadRandom m, RawType raw, Functor t, Foldable t) + => (raw -> m (t entity)) + -> (Float, Float) + -> Cells + -> m (EntityMap entity) +randomEntities newWithType sizeRange cells = + case fromNullable $ rawsWithType @raw of + Nothing -> pure mempty + Just raws -> do + let len = rangeSize $ bounds cells + (numEntities :: Int) <- + floor . (* fromIntegral len) <$> getRandomR sizeRange + entities <- for [0..numEntities] $ const $ do + pos <- randomPosition cells + r <- choose raws + entities <- newWithType r + pure $ (pos, ) <$> entities + pure $ _EntityMap # (entities >>= toList) + +randomPosition :: MonadRandom m => Cells -> m Position +randomPosition = fmap positionFromV2 . choose . impureNonNull . cellCandidates + +-- cellCandidates :: Cells -> Cells +cellCandidates :: Cells -> Set (V2 Word) +cellCandidates + -- find the largest contiguous region of cells in the cave. + = maximumBy (compare `on` length) + . fromMaybe (error "No regions generated! this should never happen.") + . fromNullable + . regions + -- cells ends up with true = wall, we want true = can put an item here + . amap not + +entityFromRaw :: MonadRandom m => EntityRaw -> m SomeEntity +entityFromRaw (Creature ct) = SomeEntity <$> newCreatureWithType ct +entityFromRaw (Item it) = SomeEntity <$> Item.newWithType it diff --git a/users/aspen/xanthous/src/Xanthous/Generators/Level/Util.hs b/users/aspen/xanthous/src/Xanthous/Generators/Level/Util.hs new file mode 100644 index 000000000000..0008eb965c42 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Generators/Level/Util.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +-------------------------------------------------------------------------------- +module Xanthous.Generators.Level.Util + ( MCells + , Cells + , CellM + , randInitialize + , initializeEmpty + , numAliveNeighborsM + , numAliveNeighbors + , fillOuterEdgesM + , cloneMArray + , floodFill + , regions + , fillAll + , fillAllM + , fromPoints + , fromPointsM + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (Foldable, toList, for_) +-------------------------------------------------------------------------------- +import Data.Array.ST +import Data.Array.Unboxed +import Control.Monad.ST +import Control.Monad.Random +import Data.Monoid +import Data.Foldable (Foldable, toList, for_) +import qualified Data.Set as Set +import Data.Semigroup.Foldable +import Linear.V2 +-------------------------------------------------------------------------------- +import Xanthous.Util (foldlMapM', maximum1, minimum1) +import Xanthous.Data (Dimensions, width, height) +-------------------------------------------------------------------------------- + +type MCells s = STUArray s (V2 Word) Bool +type Cells = UArray (V2 Word) Bool +type CellM g s a = RandT g (ST s) a + +randInitialize :: RandomGen g => Dimensions -> Double -> CellM g s (MCells s) +randInitialize dims aliveChance = do + res <- initializeEmpty dims + for_ [0..dims ^. width] $ \i -> + for_ [0..dims ^. height] $ \j -> do + val <- (>= aliveChance) <$> getRandomR (0, 1) + lift $ writeArray res (V2 i j) val + pure res + +initializeEmpty :: RandomGen g => Dimensions -> CellM g s (MCells s) +initializeEmpty dims = + lift $ newArray (0, V2 (dims ^. width) (dims ^. height)) False + +-- | Returns the number of neighbors of the given point in the given array that +-- are True. +-- +-- Behavior if point is out-of-bounds for the array is undefined, but will not +-- error +numAliveNeighborsM + :: forall a i m + . (MArray a Bool m, Ix i, Integral i) + => a (V2 i) Bool + -> V2 i + -> m Word +numAliveNeighborsM cells pt@(V2 x y) = do + cellBounds <- getBounds cells + getSum <$> foldlMapM' + (fmap (Sum . fromIntegral . fromEnum) . boundedGet cellBounds) + neighborPositions + + where + boundedGet :: (V2 i, V2 i) -> (Int, Int) -> m Bool + boundedGet bnds _ + | not (inRange bnds pt) + = pure True + boundedGet (V2 minX minY, V2 maxX maxY) (i, j) + | (x <= minX && i < 0) + || (y <= minY && j < 0) + || (x >= maxX && i > 0) + || (y >= maxY && j > 0) + = pure True + | otherwise = + let nx = fromIntegral $ fromIntegral x + i + ny = fromIntegral $ fromIntegral y + j + in readArray cells $ V2 nx ny + +-- | Returns the number of neighbors of the given point in the given array that +-- are True. +-- +-- Behavior if point is out-of-bounds for the array is undefined, but will not +-- error +numAliveNeighbors + :: forall a i + . (IArray a Bool, Ix i, Integral i) + => a (V2 i) Bool + -> V2 i + -> Word +numAliveNeighbors cells pt@(V2 x y) = + let cellBounds = bounds cells + in getSum $ foldMap + (Sum . fromIntegral . fromEnum . boundedGet cellBounds) + neighborPositions + + where + boundedGet :: (V2 i, V2 i) -> (Int, Int) -> Bool + boundedGet bnds _ + | not (inRange bnds pt) + = True + boundedGet (V2 minX minY, V2 maxX maxY) (i, j) + | (x <= minX && i < 0) + || (y <= minY && j < 0) + || (x >= maxX && i > 0) + || (y >= maxY && j > 0) + = True + | otherwise = + let nx = fromIntegral $ fromIntegral x + i + ny = fromIntegral $ fromIntegral y + j + in cells ! V2 nx ny + +neighborPositions :: [(Int, Int)] +neighborPositions = [(i, j) | i <- [-1..1], j <- [-1..1], (i, j) /= (0, 0)] + +fillOuterEdgesM :: (MArray a Bool m, Ix i) => a (V2 i) Bool -> m () +fillOuterEdgesM arr = do + (V2 minX minY, V2 maxX maxY) <- getBounds arr + for_ (range (minX, maxX)) $ \x -> do + writeArray arr (V2 x minY) True + writeArray arr (V2 x maxY) True + for_ (range (minY, maxY)) $ \y -> do + writeArray arr (V2 minX y) True + writeArray arr (V2 maxX y) True + +cloneMArray + :: forall a a' i e m. + ( Ix i + , MArray a e m + , MArray a' e m + , IArray UArray e + ) + => a i e + -> m (a' i e) +cloneMArray = thaw @_ @UArray <=< freeze + +-------------------------------------------------------------------------------- + +-- | Flood fill a cell array starting at a point, returning a list of all the +-- (true) cell locations reachable from that point +floodFill :: forall a i. + ( IArray a Bool + , Ix i + , Enum i + , Bounded i + , Eq i + ) + => a (V2 i) Bool -- ^ array + -> (V2 i) -- ^ position + -> Set (V2 i) +floodFill = go mempty + where + go :: Set (V2 i) -> a (V2 i) Bool -> (V2 i) -> Set (V2 i) + go res arr@(bounds -> arrBounds) idx@(V2 x y) + | not (inRange arrBounds idx) = res + | not (arr ! idx) = res + | otherwise = + let neighbors + = filter (inRange arrBounds) + . filter (/= idx) + . filter (`notMember` res) + $ V2 + <$> [(if x == minBound then x else pred x) + .. + (if x == maxBound then x else succ x)] + <*> [(if y == minBound then y else pred y) + .. + (if y == maxBound then y else succ y)] + in foldl' (\r idx' -> + if arr ! idx' + then r <> (let r' = r & contains idx' .~ True + in r' `seq` go r' arr idx') + else r) + (res & contains idx .~ True) neighbors +{-# SPECIALIZE floodFill :: UArray (V2 Word) Bool -> (V2 Word) -> Set (V2 Word) #-} + +-- | Gives a list of all the disconnected regions in a cell array, represented +-- each as lists of points +regions :: forall a i. + ( IArray a Bool + , Ix i + , Enum i + , Bounded i + , Eq i + ) + => a (V2 i) Bool + -> [Set (V2 i)] +regions arr + | Just firstPoint <- findFirstPoint arr = + let region = floodFill arr firstPoint + arr' = fillAll region arr + in region : regions arr' + | otherwise = [] + where + findFirstPoint :: a (V2 i) Bool -> Maybe (V2 i) + findFirstPoint = fmap fst . headMay . filter snd . assocs +{-# SPECIALIZE regions :: UArray (V2 Word) Bool -> [Set (V2 Word)] #-} + +fillAll :: (IArray a Bool, Ix i, Foldable f) => f i -> a i Bool -> a i Bool +fillAll ixes a = accum (const fst) a $ (, (False, ())) <$> toList ixes + +fillAllM :: (MArray a Bool m, Ix i, Foldable f) => f i -> a i Bool -> m () +fillAllM ixes a = for_ ixes $ \i -> writeArray a i False + +fromPoints + :: forall a f i. + ( IArray a Bool + , Ix i + , Functor f + , Foldable1 f + ) + => f (i, i) + -> a (i, i) Bool +fromPoints points = + let pts = Set.fromList $ toList points + dims = ( (minimum1 $ fst <$> points, minimum1 $ snd <$> points) + , (maximum1 $ fst <$> points, maximum1 $ snd <$> points) + ) + in array dims $ range dims <&> \i -> (i, i `member` pts) + +fromPointsM + :: (MArray a Bool m, Ix i, Element f ~ i, MonoFoldable f) + => NonNull f + -> m (a i Bool) +fromPointsM points = do + arr <- newArray (minimum points, maximum points) False + fillAllM (otoList points) arr + pure arr diff --git a/users/aspen/xanthous/src/Xanthous/Generators/Level/Village.hs b/users/aspen/xanthous/src/Xanthous/Generators/Level/Village.hs new file mode 100644 index 000000000000..ab7de95e6806 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Generators/Level/Village.hs @@ -0,0 +1,126 @@ +-------------------------------------------------------------------------------- +module Xanthous.Generators.Level.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.Level.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 # (fromIntegral <$> pt) + + stepOut :: Set (V2 Word) -> [[V2 Word]] -> MaybeT m [[V2 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 + +-} |