Generate more reasonable doors
Generate doors at more reasonable positions, by: - Only generating doors at the *ends* of hallways, where there's a tee-shaped opening - Never generating two doors adjacent to each other
This commit is contained in:
Griffin Smith
parent
0f79a06733
commit
b6f170c02c
3 changed files with 91 additions and 26 deletions
|
|
@ -79,6 +79,8 @@ module Xanthous.Data
|
|||
, edges
|
||||
, neighborDirections
|
||||
, neighborPositions
|
||||
, arrayNeighbors
|
||||
, rotations
|
||||
|
||||
-- *
|
||||
, Hitpoints(..)
|
||||
|
|
@ -88,11 +90,13 @@ import Xanthous.Prelude hiding (Left, Down, Right, (.=))
|
|||
--------------------------------------------------------------------------------
|
||||
import Linear.V2 hiding (_x, _y)
|
||||
import qualified Linear.V2 as L
|
||||
import Linear.V4 hiding (_x, _y)
|
||||
import Test.QuickCheck (Arbitrary, CoArbitrary, Function)
|
||||
import Test.QuickCheck.Arbitrary.Generic
|
||||
import Data.Group
|
||||
import Brick (Location(Location), Edges(..))
|
||||
import Data.Monoid (Product(..), Sum(..))
|
||||
import Data.Array.IArray
|
||||
import Data.Aeson.Generic.DerivingVia
|
||||
import Data.Aeson
|
||||
( ToJSON(..), FromJSON(..), object, (.=), (.:), withObject)
|
||||
|
|
@ -280,7 +284,7 @@ instance Opposite Direction where
|
|||
opposite DownRight = UpLeft
|
||||
opposite Here = Here
|
||||
|
||||
move :: Direction -> Position -> Position
|
||||
move :: Num a => Direction -> Position' a -> Position' a
|
||||
move Up = y -~ 1
|
||||
move Down = y +~ 1
|
||||
move Left = x -~ 1
|
||||
|
|
@ -375,7 +379,8 @@ data Neighbors a = Neighbors
|
|||
, _bottomRight :: a
|
||||
}
|
||||
deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
|
||||
deriving anyclass (NFData)
|
||||
deriving anyclass (NFData, CoArbitrary, Function)
|
||||
deriving Arbitrary via GenericArbitrary (Neighbors a)
|
||||
makeFieldsNoPrefix ''Neighbors
|
||||
|
||||
instance Applicative Neighbors where
|
||||
|
|
@ -420,9 +425,39 @@ neighborDirections = Neighbors
|
|||
, _bottomRight = DownRight
|
||||
}
|
||||
|
||||
neighborPositions :: Position -> Neighbors Position
|
||||
neighborPositions :: Num a => Position' a -> Neighbors (Position' a)
|
||||
neighborPositions pos = (`move` pos) <$> neighborDirections
|
||||
|
||||
arrayNeighbors
|
||||
:: (IArray a e, Ix i, Num i)
|
||||
=> a (i, i) e
|
||||
-> (i, i)
|
||||
-> Neighbors (Maybe e)
|
||||
arrayNeighbors arr center = arrLookup <$> neighborPositions (_Position # center)
|
||||
where
|
||||
arrLookup (view _Position -> pos)
|
||||
| inRange (bounds arr) pos = Just $ arr ! pos
|
||||
| otherwise = Nothing
|
||||
|
||||
-- | Returns a list of all 4 90-degree rotations of the given neighbors
|
||||
rotations :: Neighbors a -> V4 (Neighbors a)
|
||||
rotations orig@(Neighbors tl t tr l r bl b br) = V4
|
||||
orig -- tl t tr
|
||||
-- l r
|
||||
-- bl b br
|
||||
|
||||
(Neighbors bl l tl b t br r tr) -- bl l tl
|
||||
-- b t
|
||||
-- br r tr
|
||||
|
||||
(Neighbors br b bl r l tr t tl) -- br b bl
|
||||
-- r l
|
||||
-- tr t tl
|
||||
|
||||
(Neighbors tr r br t b tl l bl) -- tr r br
|
||||
-- t b
|
||||
-- tl l bl
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
newtype Per a b = Rate Double
|
||||
|
|
|
|||
|
|
@ -1,3 +1,4 @@
|
|||
{-# LANGUAGE ViewPatterns #-}
|
||||
--------------------------------------------------------------------------------
|
||||
module Xanthous.Generators.LevelContents
|
||||
( chooseCharacterPosition
|
||||
|
|
@ -8,15 +9,19 @@ module Xanthous.Generators.LevelContents
|
|||
, tutorialMessage
|
||||
) where
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Prelude
|
||||
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 Xanthous.Generators.Util
|
||||
import Xanthous.Random
|
||||
import Xanthous.Data (Position, _Position, positionFromPair)
|
||||
import Xanthous.Data ( Position, _Position, positionFromPair
|
||||
, rotations, arrayNeighbors, Neighbors(..)
|
||||
, neighborPositions
|
||||
)
|
||||
import Xanthous.Data.EntityMap (EntityMap, _EntityMap)
|
||||
import Xanthous.Entities.Raws (rawsWithType, RawType)
|
||||
import qualified Xanthous.Entities.Item as Item
|
||||
|
|
@ -44,22 +49,31 @@ randomDoors :: MonadRandom m => Cells -> m (EntityMap Door)
|
|||
randomDoors cells = do
|
||||
doorRatio <- getRandomR subsetRange
|
||||
let numDoors = floor $ doorRatio * fromIntegral (length candidateCells)
|
||||
doorPositions = positionFromPair <$> take numDoors candidateCells
|
||||
doorPositions =
|
||||
removeAdjacent . fmap positionFromPair . 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 (x, y) =
|
||||
not (fromMaybe True $ cells ^? ix (x, y))
|
||||
&&
|
||||
( fromMaybe True $ cells ^? ix (x - 1, y) -- left
|
||||
, fromMaybe True $ cells ^? ix (x, y - 1) -- top
|
||||
, fromMaybe True $ cells ^? ix (x + 1, y) -- right
|
||||
, fromMaybe True $ cells ^? ix (x, y + 1) -- bottom
|
||||
) `elem` [ (True, False, True, False)
|
||||
, (False, True, False, True)
|
||||
]
|
||||
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.003)
|
||||
|
|
|
|||
|
|
@ -1,9 +1,11 @@
|
|||
--------------------------------------------------------------------------------
|
||||
module Xanthous.DataSpec (main, test) where
|
||||
--------------------------------------------------------------------------------
|
||||
import Test.Prelude hiding (Right, Left, Down)
|
||||
import Xanthous.Data
|
||||
import Test.Prelude hiding (Right, Left, Down, toList, all)
|
||||
import Data.Group
|
||||
import Data.Foldable (toList, all)
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Data
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
main :: IO ()
|
||||
|
|
@ -44,14 +46,14 @@ test = testGroup "Xanthous.Data"
|
|||
, testProperty "asPosition isUnit" $ \dir ->
|
||||
dir /= Here ==> isUnit (asPosition dir)
|
||||
, testGroup "Move"
|
||||
[ testCase "Up" $ move Up mempty @?= Position 0 (-1)
|
||||
, testCase "Down" $ move Down mempty @?= Position 0 1
|
||||
, testCase "Left" $ move Left mempty @?= Position (-1) 0
|
||||
, testCase "Right" $ move Right mempty @?= Position 1 0
|
||||
, testCase "UpLeft" $ move UpLeft mempty @?= Position (-1) (-1)
|
||||
, testCase "UpRight" $ move UpRight mempty @?= Position 1 (-1)
|
||||
, testCase "DownLeft" $ move DownLeft mempty @?= Position (-1) 1
|
||||
, testCase "DownRight" $ move DownRight mempty @?= Position 1 1
|
||||
[ testCase "Up" $ move Up mempty @?= Position @Int 0 (-1)
|
||||
, testCase "Down" $ move Down mempty @?= Position @Int 0 1
|
||||
, testCase "Left" $ move Left mempty @?= Position @Int (-1) 0
|
||||
, testCase "Right" $ move Right mempty @?= Position @Int 1 0
|
||||
, testCase "UpLeft" $ move UpLeft mempty @?= Position @Int (-1) (-1)
|
||||
, testCase "UpRight" $ move UpRight mempty @?= Position @Int 1 (-1)
|
||||
, testCase "DownLeft" $ move DownLeft mempty @?= Position @Int (-1) 1
|
||||
, testCase "DownRight" $ move DownRight mempty @?= Position @Int 1 1
|
||||
]
|
||||
]
|
||||
|
||||
|
|
@ -79,4 +81,18 @@ test = testGroup "Xanthous.Data"
|
|||
(Box (V2 4 2) dims)
|
||||
]
|
||||
]
|
||||
|
||||
, testGroup "Neighbors"
|
||||
[ testGroup "rotations"
|
||||
[ testProperty "always has the same members"
|
||||
$ \(neighs :: Neighbors Int) ->
|
||||
all (\ns -> sort (toList ns) == sort (toList neighs))
|
||||
$ rotations neighs
|
||||
, testProperty "all rotations have the same rotations"
|
||||
$ \(neighs :: Neighbors Int) ->
|
||||
let rots = rotations neighs
|
||||
in all (\ns -> sort (toList $ rotations ns) == sort (toList rots))
|
||||
rots
|
||||
]
|
||||
]
|
||||
]
|
||||
|
|
|
|||
Loading…
Reference in a new issue