4 files changed, 62 insertions, 17 deletions
diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs
index 2bdf6142f9fd..5fb70bd075b6 100644
--- a/src/Xanthous/App.hs
+++ b/src/Xanthous/App.hs
@@ -90,11 +90,7 @@ initLevel = do
     generateLevel SCaveAutomata CaveAutomata.defaultParams
     $ Dimensions 80 80
 
-  entities <>= (SomeEntity <$> level ^. levelWalls)
-  entities <>= (SomeEntity <$> level ^. levelItems)
-  entities <>= (SomeEntity <$> level ^. levelCreatures)
-  entities <>= (SomeEntity <$> level ^. levelTutorialMessage)
-
+  entities <>= levelToEntityMap level
   characterPosition .= level ^. levelCharacterPosition
 
 --------------------------------------------------------------------------------
diff --git a/src/Xanthous/Entities/Environment.hs b/src/Xanthous/Entities/Environment.hs
index 0690e47e5441..c34f2e0634d6 100644
--- a/src/Xanthous/Entities/Environment.hs
+++ b/src/Xanthous/Entities/Environment.hs
@@ -7,6 +7,7 @@ module Xanthous.Entities.Environment
   , Door(..)
   , open
   , locked
+  , unlockedDoor
     -- * Messages
   , GroundMessage(..)
   ) where
@@ -88,6 +89,13 @@ instance Entity Door where
   description _ = "a door"
   entityChar _ = "d"
 
+-- | A closed, unlocked door
+unlockedDoor :: Door
+unlockedDoor = Door
+  { _open = False
+  , _locked = False
+  }
+
 --------------------------------------------------------------------------------
 
 newtype GroundMessage = GroundMessage Text
diff --git a/src/Xanthous/Generators.hs b/src/Xanthous/Generators.hs
index 592bf73c0007..8c0372ed538c 100644
--- a/src/Xanthous/Generators.hs
+++ b/src/Xanthous/Generators.hs
@@ -13,9 +13,11 @@ module Xanthous.Generators
   , levelWalls
   , levelItems
   , levelCreatures
+  , levelDoors
   , levelCharacterPosition
   , levelTutorialMessage
   , generateLevel
+  , levelToEntityMap
   ) where
 --------------------------------------------------------------------------------
 import           Xanthous.Prelude hiding (Level)
@@ -34,6 +36,7 @@ import qualified Xanthous.Data.EntityMap as EntityMap
 import           Xanthous.Entities.Environment
 import           Xanthous.Entities.Item (Item)
 import           Xanthous.Entities.Creature (Creature)
+import           Xanthous.Game.State (SomeEntity(..))
 --------------------------------------------------------------------------------
 
 data Generator
@@ -109,6 +112,7 @@ cellsToWalls cells = foldl' maybeInsertWall mempty . assocs $ cells
 
 data Level = Level
   { _levelWalls             :: !(EntityMap Wall)
+  , _levelDoors             :: !(EntityMap Door)
   , _levelItems             :: !(EntityMap Item)
   , _levelCreatures         :: !(EntityMap Creature)
   , _levelTutorialMessage   :: !(EntityMap GroundMessage)
@@ -116,13 +120,27 @@ data Level = Level
   }
 makeLenses ''Level
 
-generateLevel :: MonadRandom m => SGenerator gen -> Params gen -> Dimensions -> m Level
+generateLevel
+  :: MonadRandom m
+  => SGenerator gen
+  -> Params gen
+  -> Dimensions
+  -> m Level
 generateLevel gen ps dims = do
   rand <- mkStdGen <$> getRandom
   let cells = generate gen ps dims rand
       _levelWalls = cellsToWalls cells
   _levelItems <- randomItems cells
   _levelCreatures <- randomCreatures cells
+  _levelDoors <- randomDoors cells
   _levelCharacterPosition <- chooseCharacterPosition cells
   _levelTutorialMessage <- tutorialMessage cells _levelCharacterPosition
   pure Level {..}
+
+levelToEntityMap :: Level -> EntityMap SomeEntity
+levelToEntityMap level
+  = (SomeEntity <$> level ^. levelWalls)
+  <> (SomeEntity <$> level ^. levelDoors)
+  <> (SomeEntity <$> level ^. levelItems)
+  <> (SomeEntity <$> level ^. levelCreatures)
+  <> (SomeEntity <$> level ^. levelTutorialMessage)
diff --git a/src/Xanthous/Generators/LevelContents.hs b/src/Xanthous/Generators/LevelContents.hs
index 91a7d38019c8..aaeb4a77fdda 100644
--- a/src/Xanthous/Generators/LevelContents.hs
+++ b/src/Xanthous/Generators/LevelContents.hs
@@ -3,6 +3,7 @@ module Xanthous.Generators.LevelContents
   ( chooseCharacterPosition
   , randomItems
   , randomCreatures
+  , randomDoors
   , tutorialMessage
   ) where
 --------------------------------------------------------------------------------
@@ -10,6 +11,7 @@ import           Xanthous.Prelude
 --------------------------------------------------------------------------------
 import           Control.Monad.Random
 import           Data.Array.IArray (amap, bounds, rangeSize, (!))
+import qualified Data.Array.IArray as Arr
 --------------------------------------------------------------------------------
 import           Xanthous.Generators.Util
 import           Xanthous.Random
@@ -20,7 +22,8 @@ import qualified Xanthous.Entities.Item as Item
 import           Xanthous.Entities.Item (Item)
 import qualified Xanthous.Entities.Creature as Creature
 import           Xanthous.Entities.Creature (Creature)
-import           Xanthous.Entities.Environment (GroundMessage(..))
+import           Xanthous.Entities.Environment
+                 (GroundMessage(..), Door(..), unlockedDoor)
 import           Xanthous.Messages (message_)
 import           Xanthous.Util.Graphics (circle)
 --------------------------------------------------------------------------------
@@ -31,6 +34,25 @@ chooseCharacterPosition = randomPosition
 randomItems :: MonadRandom m => Cells -> m (EntityMap Item)
 randomItems = randomEntities Item.newWithType (0.0004, 0.001)
 
+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
+      doors = zip doorPositions $ repeat unlockedDoor
+  pure $ _EntityMap # doors
+  where
+    candidateCells = filter doorable $ Arr.indices cells
+    subsetRange = (0.8 :: Double, 1.0)
+    doorable (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)
+          ]
+
 randomCreatures :: MonadRandom m => Cells -> m (EntityMap Creature)
 randomCreatures = randomEntities Creature.newWithType (0.0007, 0.003)
 
@@ -73,14 +95,15 @@ randomEntities newWithType sizeRange cells =
       pure $ _EntityMap # entities
 
 randomPosition :: MonadRandom m => Cells -> m Position
-randomPosition cells = fmap positionFromPair . choose $ impureNonNull candidates
-  where
-    -- cells ends up with true = wall, we want true = can put an item here
-    placeableCells = amap not cells
+randomPosition = fmap positionFromPair . choose . impureNonNull . cellCandidates
 
-    -- find the largest contiguous region of cells in the cave.
-    candidates
-      = maximumBy (compare `on` length)
-      $ fromMaybe (error "No regions generated! this should never happen.")
-      $ fromNullable
-      $ regions placeableCells
+-- cellCandidates :: Cells -> Cells
+cellCandidates :: Cells -> Set (Word, Word)
+cellCandidates
+  -- find the largest contiguous region of cells in the cave.
+  = maximumBy (compare `on` length)
+  . fromMaybe (error "No regions generated! this should never happen.")
+  . fromNullable
+  . regions
+  -- cells ends up with true = wall, we want true = can put an item here
+  . amap not