feat(xan): Generate random villages

This algorithm is a little rough around the edges right now, but
generally the idea is we find a relatively closed-off region of the map,
and place rooms randomly on it, expanding them until they run into each
other, then we put doors in the walls of the rooms and a single door
opening into the region. Later on, we'll generate friendly (or
unfriendly!) NPCs to put in those rooms.

Change-Id: Ic989b9905f55ad92a01fdf6db11aa57afb4ce383
Reviewed-on: https://cl.tvl.fyi/c/depot/+/726
Reviewed-by: glittershark <grfn@gws.fyi>
This commit is contained in:
Griffin Smith 2020-06-28 19:33:27 -04:00 committed by glittershark
parent 6c7e14d2dc
commit bf9b09bd8c
12 changed files with 302 additions and 22 deletions

View file

@ -54,6 +54,7 @@ dependencies:
- MonadRandom
- mtl
- optparse-applicative
- parallel
- parser-combinators
- pointed
- random
@ -67,6 +68,7 @@ dependencies:
- stache
- semigroupoids
- tomland
- transformers
- text
- text-zipper
- vector

View file

@ -15,7 +15,6 @@ import Control.Monad.State (get, gets)
import Control.Monad.State.Class (modify)
import Data.Aeson (object, ToJSON)
import qualified Data.Aeson as A
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Vector as V
import System.Exit
import System.Directory (doesFileExist)

View file

@ -79,8 +79,17 @@ module Xanthous.Data
, edges
, neighborDirections
, neighborPositions
, neighborCells
, arrayNeighbors
, rotations
, HasTopLeft(..)
, HasTop(..)
, HasTopRight(..)
, HasLeft(..)
, HasRight(..)
, HasBottomLeft(..)
, HasBottom(..)
, HasBottomRight(..)
-- *
, Hitpoints(..)
@ -439,6 +448,9 @@ neighborDirections = Neighbors
neighborPositions :: Num a => Position' a -> Neighbors (Position' a)
neighborPositions pos = (`move` pos) <$> neighborDirections
neighborCells :: Num a => (a, a) -> Neighbors (a, a)
neighborCells = map (view _Position) . neighborPositions . review _Position
arrayNeighbors
:: (IArray a e, Ix i, Num i)
=> a (i, i) e

View file

@ -6,7 +6,7 @@ module Xanthous.Generators
( generate
, Generator(..)
, SGenerator(..)
, GeneratorInput
, GeneratorInput(..)
, generateFromInput
, parseGeneratorInput
, showCells
@ -17,6 +17,7 @@ module Xanthous.Generators
, levelDoors
, levelCharacterPosition
, levelTutorialMessage
, levelExtra
, generateLevel
, levelToEntityMap
) where
@ -31,6 +32,7 @@ import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
import qualified Xanthous.Generators.Dungeon as Dungeon
import Xanthous.Generators.Util
import Xanthous.Generators.LevelContents
import Xanthous.Generators.Village as Village
import Xanthous.Data (Dimensions, Position'(Position), Position)
import Xanthous.Data.EntityMap (EntityMap, _EntityMap)
import qualified Xanthous.Data.EntityMap as EntityMap
@ -118,6 +120,7 @@ data Level = Level
, _levelCreatures :: !(EntityMap Creature)
, _levelTutorialMessage :: !(EntityMap GroundMessage)
, _levelStaircases :: !(EntityMap Staircase)
, _levelExtra :: !(EntityMap SomeEntity) -- ^ TODO this is a bit of a hack...
, _levelCharacterPosition :: !Position
}
deriving stock (Generic)
@ -134,6 +137,8 @@ generateLevel gen ps dims = do
rand <- mkStdGen <$> getRandom
let cells = generate gen ps dims rand
_levelWalls = cellsToWalls cells
village <- generateVillage cells gen
let _levelExtra = village
_levelItems <- randomItems cells
_levelCreatures <- randomCreatures cells
_levelDoors <- randomDoors cells
@ -152,3 +157,12 @@ levelToEntityMap level
<> (SomeEntity <$> level ^. levelCreatures)
<> (SomeEntity <$> level ^. levelTutorialMessage)
<> (SomeEntity <$> level ^. levelStaircases)
<> (level ^. levelExtra)
generateVillage
:: MonadRandom m
=> Cells -- ^ Wall positions
-> SGenerator gen
-> m (EntityMap SomeEntity)
generateVillage wallPositions SCaveAutomata = Village.fromCave wallPositions
generateVillage _ _ = pure mempty

View file

@ -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)

View file

@ -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)]

View file

@ -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
-}

View file

@ -10,6 +10,7 @@ module Xanthous.Random
, weightedBy
, subRand
, chance
, chooseSubset
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
@ -17,6 +18,7 @@ import Xanthous.Prelude
import Data.List.NonEmpty (NonEmpty(..))
import Control.Monad.Random.Class (MonadRandom(getRandomR, getRandom))
import Control.Monad.Random (Rand, evalRand, mkStdGen, StdGen)
import Data.Functor.Compose
import Data.Random.Shuffle.Weighted
import Data.Random.Distribution
import Data.Random.Distribution.Uniform
@ -66,10 +68,16 @@ instance Choose (a, a) where
choose (x, y) = choose (x :| [y])
newtype Weighted w t a = Weighted (t (w, a))
deriving (Functor, Foldable) via (t `Compose` (,) w)
instance Traversable t => Traversable (Weighted w t) where
traverse f (Weighted twa) = Weighted <$> (traverse . traverse) f twa
evenlyWeighted :: [a] -> Weighted Int [] a
evenlyWeighted = Weighted . itoList
-- | Weight the elements of some functor by a function. Larger values of 'w' per
-- its 'Ord' instance will be more likely to be generated
weightedBy :: Functor t => (a -> w) -> t a -> Weighted w t a
weightedBy weighting xs = Weighted $ (weighting &&& id) <$> xs
@ -96,6 +104,14 @@ chance
-> m Bool
chance n = choose $ weightedBy (bool 1 (n * 2)) bools
-- | Choose a random subset of *about* @w@ of the elements of the given
-- 'Witherable' structure
chooseSubset :: ( Num w, Ord w, Distribution Uniform w, Excludable w
, Witherable t
, MonadRandom m
) => w -> t a -> m (t a)
chooseSubset = filterA . const . chance
--------------------------------------------------------------------------------
bools :: NonEmpty Bool

View file

@ -128,6 +128,8 @@ line pa@(xa, ya) pb@(xb, yb)
(newY, newError) = if (2 * tempError) >= δx
then (yTemp + ystep, tempError - δx)
else (yTemp, tempError)
{-# SPECIALIZE line :: (Int, Int) -> (Int, Int) -> [(Int, Int)] #-}
{-# SPECIALIZE line :: (Word, Word) -> (Word, Word) -> [(Word, Word)] #-}
straightLine :: (Num i, Ord i) => (i, i) -> (i, i) -> [(i, i)]
straightLine pa@(xa, _) pb@(_, yb) = line pa midpoint ++ line midpoint pb

View file

@ -1,11 +1,11 @@
--------------------------------------------------------------------------------
import Test.Prelude
--------------------------------------------------------------------------------
import qualified Xanthous.Data.EntityCharSpec
import qualified Xanthous.Data.EntityMapSpec
import qualified Xanthous.Data.EntityMap.GraphicsSpec
import qualified Xanthous.Data.LevelsSpec
import qualified Xanthous.Data.EntitiesSpec
import qualified Xanthous.Data.EntityCharSpec
import qualified Xanthous.Data.EntityMap.GraphicsSpec
import qualified Xanthous.Data.EntityMapSpec
import qualified Xanthous.Data.LevelsSpec
import qualified Xanthous.Data.NestedMapSpec
import qualified Xanthous.DataSpec
import qualified Xanthous.Entities.RawsSpec
@ -14,8 +14,9 @@ import qualified Xanthous.Generators.UtilSpec
import qualified Xanthous.MessageSpec
import qualified Xanthous.Messages.TemplateSpec
import qualified Xanthous.OrphansSpec
import qualified Xanthous.Util.GraphicsSpec
import qualified Xanthous.RandomSpec
import qualified Xanthous.Util.GraphSpec
import qualified Xanthous.Util.GraphicsSpec
import qualified Xanthous.Util.InflectionSpec
import qualified Xanthous.UtilSpec
--------------------------------------------------------------------------------
@ -25,21 +26,22 @@ main = defaultMain test
test :: TestTree
test = testGroup "Xanthous"
[ Xanthous.Data.EntityCharSpec.test
, Xanthous.Data.EntityMapSpec.test
[ Xanthous.Data.EntitiesSpec.test
, Xanthous.Data.EntityMap.GraphicsSpec.test
, Xanthous.Data.EntitiesSpec.test
, Xanthous.Data.EntityMapSpec.test
, Xanthous.Data.LevelsSpec.test
, Xanthous.Data.NestedMapSpec.test
, Xanthous.DataSpec.test
, Xanthous.Entities.RawsSpec.test
, Xanthous.GameSpec.test
, Xanthous.Generators.UtilSpec.test
, Xanthous.MessageSpec.test
, Xanthous.Messages.TemplateSpec.test
, Xanthous.OrphansSpec.test
, Xanthous.DataSpec.test
, Xanthous.UtilSpec.test
, Xanthous.Util.GraphicsSpec.test
, Xanthous.RandomSpec.test
, Xanthous.Util.GraphSpec.test
, Xanthous.Util.GraphicsSpec.test
, Xanthous.Util.InflectionSpec.test
, Xanthous.UtilSpec.test
, Xanthous.Data.EntityCharSpec.test
]

View file

@ -0,0 +1,25 @@
--------------------------------------------------------------------------------
module Xanthous.RandomSpec (main, test) where
--------------------------------------------------------------------------------
import Test.Prelude
--------------------------------------------------------------------------------
import Control.Monad.Random
--------------------------------------------------------------------------------
import Xanthous.Random
--------------------------------------------------------------------------------
main :: IO ()
main = defaultMain test
test :: TestTree
test = testGroup "Xanthous.Random"
[ testGroup "chooseSubset"
[ testProperty "chooses a subset"
$ \(l :: [Int]) (Positive (r :: Double)) -> randomTest $ do
ss <- chooseSubset r l
pure $ all (`elem` l) ss
]
]
where
randomTest prop = evalRandT prop . mkStdGen =<< arbitrary

View file

@ -4,7 +4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
-- hash: 88019942f93977e08b513ce6991401694c431b7b2b7b1b5d2afccb3f0afb26ed
-- hash: 5f419c8c149f045c818a2fb392b1233a0958e71e92d7a837deabc412e2b5adda
name: xanthous
version: 0.1.0.0
@ -68,6 +68,7 @@ library
Xanthous.Generators.Dungeon
Xanthous.Generators.LevelContents
Xanthous.Generators.Util
Xanthous.Generators.Village
Xanthous.Messages
Xanthous.Messages.Template
Xanthous.Monad
@ -126,6 +127,7 @@ library
, monad-control
, mtl
, optparse-applicative
, parallel
, parser-combinators
, pointed
, quickcheck-instances
@ -142,6 +144,7 @@ library
, text
, text-zipper
, tomland
, transformers
, vector
, vty
, witherable
@ -191,6 +194,7 @@ executable xanthous
Xanthous.Generators.Dungeon
Xanthous.Generators.LevelContents
Xanthous.Generators.Util
Xanthous.Generators.Village
Xanthous.Messages
Xanthous.Messages.Template
Xanthous.Monad
@ -248,6 +252,7 @@ executable xanthous
, monad-control
, mtl
, optparse-applicative
, parallel
, parser-combinators
, pointed
, quickcheck-instances
@ -264,6 +269,7 @@ executable xanthous
, text
, text-zipper
, tomland
, transformers
, vector
, vty
, witherable
@ -290,6 +296,7 @@ test-suite test
Xanthous.Messages.TemplateSpec
Xanthous.MessageSpec
Xanthous.OrphansSpec
Xanthous.RandomSpec
Xanthous.Util.GraphicsSpec
Xanthous.Util.GraphSpec
Xanthous.Util.InflectionSpec
@ -338,6 +345,7 @@ test-suite test
, monad-control
, mtl
, optparse-applicative
, parallel
, parser-combinators
, pointed
, quickcheck-instances
@ -357,6 +365,84 @@ test-suite test
, text
, text-zipper
, tomland
, transformers
, vector
, vty
, witherable
, xanthous
, yaml
, zlib
default-language: Haskell2010
benchmark benchmark
type: exitcode-stdio-1.0
main-is: Bench.hs
other-modules:
Bench.Prelude
Xanthous.Generators.UtilBench
Xanthous.RandomBench
Paths_xanthous
hs-source-dirs:
bench
default-extensions: BlockArguments ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiWayIf NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TupleSections TypeApplications TypeFamilies TypeOperators ViewPatterns
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
build-depends:
JuicyPixels
, MonadRandom
, QuickCheck
, Rasterific
, aeson
, array
, async
, base
, bifunctors
, brick
, checkers
, classy-prelude
, comonad
, comonad-extras
, constraints
, containers
, criterion
, data-default
, deepseq
, directory
, fgl
, fgl-arbitrary
, file-embed
, filepath
, generic-arbitrary
, generic-lens
, generic-monoid
, groups
, hgeometry
, hgeometry-combinatorial
, lens
, lifted-async
, linear
, megaparsec
, mmorph
, monad-control
, mtl
, optparse-applicative
, parallel
, parser-combinators
, pointed
, quickcheck-instances
, quickcheck-text
, random
, random-extras
, random-fu
, random-source
, raw-strings-qq
, reflection
, semigroupoids
, stache
, streams
, text
, text-zipper
, tomland
, transformers
, vector
, vty
, witherable