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:
parent
0f79a06733
commit
b6f170c02c
3 changed files with 91 additions and 26 deletions
|
@ -79,6 +79,8 @@ module Xanthous.Data
|
||||||
, edges
|
, edges
|
||||||
, neighborDirections
|
, neighborDirections
|
||||||
, neighborPositions
|
, neighborPositions
|
||||||
|
, arrayNeighbors
|
||||||
|
, rotations
|
||||||
|
|
||||||
-- *
|
-- *
|
||||||
, Hitpoints(..)
|
, Hitpoints(..)
|
||||||
|
@ -88,11 +90,13 @@ import Xanthous.Prelude hiding (Left, Down, Right, (.=))
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Linear.V2 hiding (_x, _y)
|
import Linear.V2 hiding (_x, _y)
|
||||||
import qualified Linear.V2 as L
|
import qualified Linear.V2 as L
|
||||||
|
import Linear.V4 hiding (_x, _y)
|
||||||
import Test.QuickCheck (Arbitrary, CoArbitrary, Function)
|
import Test.QuickCheck (Arbitrary, CoArbitrary, Function)
|
||||||
import Test.QuickCheck.Arbitrary.Generic
|
import Test.QuickCheck.Arbitrary.Generic
|
||||||
import Data.Group
|
import Data.Group
|
||||||
import Brick (Location(Location), Edges(..))
|
import Brick (Location(Location), Edges(..))
|
||||||
import Data.Monoid (Product(..), Sum(..))
|
import Data.Monoid (Product(..), Sum(..))
|
||||||
|
import Data.Array.IArray
|
||||||
import Data.Aeson.Generic.DerivingVia
|
import Data.Aeson.Generic.DerivingVia
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
( ToJSON(..), FromJSON(..), object, (.=), (.:), withObject)
|
( ToJSON(..), FromJSON(..), object, (.=), (.:), withObject)
|
||||||
|
@ -280,7 +284,7 @@ instance Opposite Direction where
|
||||||
opposite DownRight = UpLeft
|
opposite DownRight = UpLeft
|
||||||
opposite Here = Here
|
opposite Here = Here
|
||||||
|
|
||||||
move :: Direction -> Position -> Position
|
move :: Num a => Direction -> Position' a -> Position' a
|
||||||
move Up = y -~ 1
|
move Up = y -~ 1
|
||||||
move Down = y +~ 1
|
move Down = y +~ 1
|
||||||
move Left = x -~ 1
|
move Left = x -~ 1
|
||||||
|
@ -375,7 +379,8 @@ data Neighbors a = Neighbors
|
||||||
, _bottomRight :: a
|
, _bottomRight :: a
|
||||||
}
|
}
|
||||||
deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
|
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
|
makeFieldsNoPrefix ''Neighbors
|
||||||
|
|
||||||
instance Applicative Neighbors where
|
instance Applicative Neighbors where
|
||||||
|
@ -420,9 +425,39 @@ neighborDirections = Neighbors
|
||||||
, _bottomRight = DownRight
|
, _bottomRight = DownRight
|
||||||
}
|
}
|
||||||
|
|
||||||
neighborPositions :: Position -> Neighbors Position
|
neighborPositions :: Num a => Position' a -> Neighbors (Position' a)
|
||||||
neighborPositions pos = (`move` pos) <$> neighborDirections
|
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
|
newtype Per a b = Rate Double
|
||||||
|
|
|
@ -1,3 +1,4 @@
|
||||||
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
module Xanthous.Generators.LevelContents
|
module Xanthous.Generators.LevelContents
|
||||||
( chooseCharacterPosition
|
( chooseCharacterPosition
|
||||||
|
@ -8,15 +9,19 @@ module Xanthous.Generators.LevelContents
|
||||||
, tutorialMessage
|
, tutorialMessage
|
||||||
) where
|
) where
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Xanthous.Prelude
|
import Xanthous.Prelude hiding (any, toList)
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Control.Monad.Random
|
import Control.Monad.Random
|
||||||
import Data.Array.IArray (amap, bounds, rangeSize, (!))
|
import Data.Array.IArray (amap, bounds, rangeSize, (!))
|
||||||
import qualified Data.Array.IArray as Arr
|
import qualified Data.Array.IArray as Arr
|
||||||
|
import Data.Foldable (any, toList)
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Xanthous.Generators.Util
|
import Xanthous.Generators.Util
|
||||||
import Xanthous.Random
|
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.Data.EntityMap (EntityMap, _EntityMap)
|
||||||
import Xanthous.Entities.Raws (rawsWithType, RawType)
|
import Xanthous.Entities.Raws (rawsWithType, RawType)
|
||||||
import qualified Xanthous.Entities.Item as Item
|
import qualified Xanthous.Entities.Item as Item
|
||||||
|
@ -44,22 +49,31 @@ randomDoors :: MonadRandom m => Cells -> m (EntityMap Door)
|
||||||
randomDoors cells = do
|
randomDoors cells = do
|
||||||
doorRatio <- getRandomR subsetRange
|
doorRatio <- getRandomR subsetRange
|
||||||
let numDoors = floor $ doorRatio * fromIntegral (length candidateCells)
|
let numDoors = floor $ doorRatio * fromIntegral (length candidateCells)
|
||||||
doorPositions = positionFromPair <$> take numDoors candidateCells
|
doorPositions =
|
||||||
|
removeAdjacent . fmap positionFromPair . take numDoors $ candidateCells
|
||||||
doors = zip doorPositions $ repeat unlockedDoor
|
doors = zip doorPositions $ repeat unlockedDoor
|
||||||
pure $ _EntityMap # doors
|
pure $ _EntityMap # doors
|
||||||
where
|
where
|
||||||
|
removeAdjacent =
|
||||||
|
foldr (\pos acc ->
|
||||||
|
if pos `elem` (acc >>= toList . neighborPositions)
|
||||||
|
then acc
|
||||||
|
else pos : acc
|
||||||
|
) []
|
||||||
candidateCells = filter doorable $ Arr.indices cells
|
candidateCells = filter doorable $ Arr.indices cells
|
||||||
subsetRange = (0.8 :: Double, 1.0)
|
subsetRange = (0.8 :: Double, 1.0)
|
||||||
doorable (x, y) =
|
doorable pos =
|
||||||
not (fromMaybe True $ cells ^? ix (x, y))
|
not (fromMaybe True $ cells ^? ix pos)
|
||||||
&&
|
&& any (teeish . fmap (fromMaybe True))
|
||||||
( fromMaybe True $ cells ^? ix (x - 1, y) -- left
|
(rotations $ arrayNeighbors cells pos)
|
||||||
, fromMaybe True $ cells ^? ix (x, y - 1) -- top
|
-- only generate doors at the *ends* of hallways, eg (where O is walkable,
|
||||||
, fromMaybe True $ cells ^? ix (x + 1, y) -- right
|
-- X is a wall, and D is a door):
|
||||||
, fromMaybe True $ cells ^? ix (x, y + 1) -- bottom
|
--
|
||||||
) `elem` [ (True, False, True, False)
|
-- O O O
|
||||||
, (False, True, False, True)
|
-- 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 :: MonadRandom m => Cells -> m (EntityMap Creature)
|
||||||
randomCreatures = randomEntities Creature.newWithType (0.0007, 0.003)
|
randomCreatures = randomEntities Creature.newWithType (0.0007, 0.003)
|
||||||
|
|
|
@ -1,9 +1,11 @@
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
module Xanthous.DataSpec (main, test) where
|
module Xanthous.DataSpec (main, test) where
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Test.Prelude hiding (Right, Left, Down)
|
import Test.Prelude hiding (Right, Left, Down, toList, all)
|
||||||
import Xanthous.Data
|
|
||||||
import Data.Group
|
import Data.Group
|
||||||
|
import Data.Foldable (toList, all)
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
import Xanthous.Data
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
|
@ -44,14 +46,14 @@ test = testGroup "Xanthous.Data"
|
||||||
, testProperty "asPosition isUnit" $ \dir ->
|
, testProperty "asPosition isUnit" $ \dir ->
|
||||||
dir /= Here ==> isUnit (asPosition dir)
|
dir /= Here ==> isUnit (asPosition dir)
|
||||||
, testGroup "Move"
|
, testGroup "Move"
|
||||||
[ testCase "Up" $ move Up mempty @?= Position 0 (-1)
|
[ testCase "Up" $ move Up mempty @?= Position @Int 0 (-1)
|
||||||
, testCase "Down" $ move Down mempty @?= Position 0 1
|
, testCase "Down" $ move Down mempty @?= Position @Int 0 1
|
||||||
, testCase "Left" $ move Left mempty @?= Position (-1) 0
|
, testCase "Left" $ move Left mempty @?= Position @Int (-1) 0
|
||||||
, testCase "Right" $ move Right mempty @?= Position 1 0
|
, testCase "Right" $ move Right mempty @?= Position @Int 1 0
|
||||||
, testCase "UpLeft" $ move UpLeft mempty @?= Position (-1) (-1)
|
, testCase "UpLeft" $ move UpLeft mempty @?= Position @Int (-1) (-1)
|
||||||
, testCase "UpRight" $ move UpRight mempty @?= Position 1 (-1)
|
, testCase "UpRight" $ move UpRight mempty @?= Position @Int 1 (-1)
|
||||||
, testCase "DownLeft" $ move DownLeft mempty @?= Position (-1) 1
|
, testCase "DownLeft" $ move DownLeft mempty @?= Position @Int (-1) 1
|
||||||
, testCase "DownRight" $ move DownRight mempty @?= Position 1 1
|
, testCase "DownRight" $ move DownRight mempty @?= Position @Int 1 1
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
|
|
||||||
|
@ -79,4 +81,18 @@ test = testGroup "Xanthous.Data"
|
||||||
(Box (V2 4 2) dims)
|
(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