diff options
Diffstat (limited to 'users/glittershark/xanthous/src/Xanthous/Generators')
5 files changed, 0 insertions, 780 deletions
diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs b/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs deleted file mode 100644 index be904662f3f7..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# 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/glittershark/xanthous/src/Xanthous/Generators/Dungeon.hs b/users/glittershark/xanthous/src/Xanthous/Generators/Dungeon.hs deleted file mode 100644 index f30713ce1182..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Generators/Dungeon.hs +++ /dev/null @@ -1,190 +0,0 @@ -{-# 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/glittershark/xanthous/src/Xanthous/Generators/LevelContents.hs b/users/glittershark/xanthous/src/Xanthous/Generators/LevelContents.hs deleted file mode 100644 index 8ebcc7f4da83..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Generators/LevelContents.hs +++ /dev/null @@ -1,133 +0,0 @@ --------------------------------------------------------------------------------- -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/glittershark/xanthous/src/Xanthous/Generators/Util.hs b/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs deleted file mode 100644 index 88aadd5aadd9..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs +++ /dev/null @@ -1,220 +0,0 @@ -{-# 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/glittershark/xanthous/src/Xanthous/Generators/Village.hs b/users/glittershark/xanthous/src/Xanthous/Generators/Village.hs deleted file mode 100644 index cc9c9d963f5c..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Generators/Village.hs +++ /dev/null @@ -1,125 +0,0 @@ -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 - --} |