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

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)