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

3 files changed, 91 insertions, 26 deletions

diff --git a/src/Xanthous/Data.hs b/src/Xanthous/Data.hs
index 5e45169582..1874b45e90 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 748afa96da..117860405a 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)
diff --git a/test/Xanthous/DataSpec.hs b/test/Xanthous/DataSpec.hs
index a2fcdbba15..91dc6cea1b 100644
--- a/test/Xanthous/DataSpec.hs
+++ b/test/Xanthous/DataSpec.hs
@@ -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
+      ]
+    ]
   ]