From 6266c5d32f9ff651fcfc3a4cc0c68e89da56ca65 Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Sun, 11 Apr 2021 17:53:27 -0400 Subject: refactor(users/glittershark): Rename to grfn Rename my //users directory and all places that refer to glittershark to grfn, including nix references and documentation. This may require some extra attention inside of gerrit's database after it lands to allow me to actually push things. Change-Id: I4728b7ec2c60024392c1c1fa6e0d4a59b3e266fa Reviewed-on: https://cl.tvl.fyi/c/depot/+/2933 Tested-by: BuildkiteCI Reviewed-by: tazjin Reviewed-by: lukegb Reviewed-by: glittershark --- .../src/Xanthous/Generators/CaveAutomata.hs | 112 +++++++++++ .../xanthous/src/Xanthous/Generators/Dungeon.hs | 190 ++++++++++++++++++ .../src/Xanthous/Generators/LevelContents.hs | 133 +++++++++++++ .../grfn/xanthous/src/Xanthous/Generators/Util.hs | 220 +++++++++++++++++++++ .../xanthous/src/Xanthous/Generators/Village.hs | 125 ++++++++++++ 5 files changed, 780 insertions(+) create mode 100644 users/grfn/xanthous/src/Xanthous/Generators/CaveAutomata.hs create mode 100644 users/grfn/xanthous/src/Xanthous/Generators/Dungeon.hs create mode 100644 users/grfn/xanthous/src/Xanthous/Generators/LevelContents.hs create mode 100644 users/grfn/xanthous/src/Xanthous/Generators/Util.hs create mode 100644 users/grfn/xanthous/src/Xanthous/Generators/Village.hs (limited to 'users/grfn/xanthous/src/Xanthous/Generators') diff --git a/users/grfn/xanthous/src/Xanthous/Generators/CaveAutomata.hs b/users/grfn/xanthous/src/Xanthous/Generators/CaveAutomata.hs new file mode 100644 index 000000000000..be904662f3f7 --- /dev/null +++ b/users/grfn/xanthous/src/Xanthous/Generators/CaveAutomata.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Generators.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.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/grfn/xanthous/src/Xanthous/Generators/Dungeon.hs b/users/grfn/xanthous/src/Xanthous/Generators/Dungeon.hs new file mode 100644 index 000000000000..f30713ce1182 --- /dev/null +++ b/users/grfn/xanthous/src/Xanthous/Generators/Dungeon.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Generators.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) +import Xanthous.Generators.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/grfn/xanthous/src/Xanthous/Generators/LevelContents.hs b/users/grfn/xanthous/src/Xanthous/Generators/LevelContents.hs new file mode 100644 index 000000000000..8ebcc7f4da83 --- /dev/null +++ b/users/grfn/xanthous/src/Xanthous/Generators/LevelContents.hs @@ -0,0 +1,133 @@ +-------------------------------------------------------------------------------- +module Xanthous.Generators.LevelContents + ( chooseCharacterPosition + , randomItems + , randomCreatures + , randomDoors + , placeDownStaircase + , tutorialMessage + ) 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.Util +import Xanthous.Random +import Xanthous.Data + ( positionFromV2, Position, _Position + , rotations, arrayNeighbors, Neighbors(..) + , neighborPositions + ) +import Xanthous.Data.EntityMap (EntityMap, _EntityMap) +import Xanthous.Entities.Raws (rawsWithType, RawType) +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) +-------------------------------------------------------------------------------- + +chooseCharacterPosition :: MonadRandom m => Cells -> m Position +chooseCharacterPosition = randomPosition + +randomItems :: MonadRandom m => Cells -> m (EntityMap Item) +randomItems = randomEntities 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 => Cells -> m (EntityMap Creature) +randomCreatures = randomEntities Creature.newWithType (0.0007, 0.002) + +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. (MonadRandom m, RawType raw) + => (raw -> 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 + raw <- choose raws + let entity = newWithType raw + pure (pos, entity) + pure $ _EntityMap # entities + +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 diff --git a/users/grfn/xanthous/src/Xanthous/Generators/Util.hs b/users/grfn/xanthous/src/Xanthous/Generators/Util.hs new file mode 100644 index 000000000000..88aadd5aadd9 --- /dev/null +++ b/users/grfn/xanthous/src/Xanthous/Generators/Util.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +-------------------------------------------------------------------------------- +module Xanthous.Generators.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 + +numAliveNeighborsM + :: forall a i m + . (MArray a Bool m, Ix i, Integral i) + => a (V2 i) Bool + -> V2 i + -> m Word +numAliveNeighborsM cells (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 (V2 minX minY, V2 maxX maxY) (i, j) + | x <= minX + || y <= minY + || x >= maxX + || y >= maxY + = pure True + | otherwise = + let nx = fromIntegral $ fromIntegral x + i + ny = fromIntegral $ fromIntegral y + j + in readArray cells $ V2 nx ny + +numAliveNeighbors + :: forall a i + . (IArray a Bool, Ix i, Integral i) + => a (V2 i) Bool + -> V2 i + -> Word +numAliveNeighbors cells (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 (V2 minX minY, V2 maxX maxY) (i, j) + | x <= minX + || y <= minY + || x >= maxX + || y >= maxY + = 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/grfn/xanthous/src/Xanthous/Generators/Village.hs b/users/grfn/xanthous/src/Xanthous/Generators/Village.hs new file mode 100644 index 000000000000..cc9c9d963f5c --- /dev/null +++ b/users/grfn/xanthous/src/Xanthous/Generators/Village.hs @@ -0,0 +1,125 @@ +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 # (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 + +-} -- cgit 1.4.1