diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Xanthous/Data.hs | 41 | ||||
| -rw-r--r-- | src/Xanthous/Generators/LevelContents.hs | 40 |
2 files changed, 65 insertions, 16 deletions
diff --git a/src/Xanthous/Data.hs b/src/Xanthous/Data.hs index 5e451695825f..1874b45e9047 100644 --- a/src/Xanthous/Data.hs +++ b/src/Xanthous/Data.hs @@ -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 diff --git a/src/Xanthous/Generators/LevelContents.hs b/src/Xanthous/Generators/LevelContents.hs index 748afa96da72..117860405ac3 100644 --- a/src/Xanthous/Generators/LevelContents.hs +++ b/src/Xanthous/Generators/LevelContents.hs @@ -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) |