Place the chacracter in the level at startup time

Randomly select a position in the largest contiguous region of the
generated level in which to place the character at startup time.

8 files changed, 168 insertions, 33 deletions

diff --git a/src/Main.hs b/src/Main.hs
index d49e082b7c6c..2da277b64071 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,20 +1,23 @@
-module Main where
-
-import Xanthous.Prelude
-import Brick
+module Main ( main ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+import           Brick
 import qualified Options.Applicative as Opt
-import System.Random
-
-import Xanthous.Game (getInitialState)
-import Xanthous.App (makeApp)
-import Xanthous.Generators
+import           System.Random
+--------------------------------------------------------------------------------
+import           Xanthous.Game (getInitialState)
+import           Xanthous.App (makeApp)
+import           Xanthous.Generators
   ( GeneratorInput(..)
   , parseGeneratorInput
   , generateFromInput
   , showCells
   )
-import Xanthous.Data (Dimensions, Dimensions'(Dimensions))
-
+import           Xanthous.Generators.Util (regions)
+import           Xanthous.Generators.LevelContents
+import           Xanthous.Data (Dimensions, Dimensions'(Dimensions))
+import           Data.Array.IArray ( amap )
+--------------------------------------------------------------------------------
 data Command
   = Run
   | Generate GeneratorInput Dimensions
@@ -61,6 +64,13 @@ runGenerate :: GeneratorInput -> Dimensions -> IO ()
 runGenerate input dims = do
   randGen <- getStdGen
   let res = generateFromInput input dims randGen
+      rs = regions $ amap not res
+  putStr "num regions: "
+  print $ length rs
+  putStr "region lengths: "
+  print $ length <$> rs
+  putStr "character position: "
+  print =<< chooseCharacterPosition res
   putStrLn $ showCells res
 
 runCommand :: Command -> IO ()
diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs
index af6b5caf6178..0dc24b9d4165 100644
--- a/src/Xanthous/App.hs
+++ b/src/Xanthous/App.hs
@@ -9,7 +9,13 @@ import           Control.Monad.State (get)
 import           Control.Monad.Random (getRandom)
 --------------------------------------------------------------------------------
 import           Xanthous.Command
-import           Xanthous.Data (move, Position(..), Dimensions'(Dimensions), Dimensions)
+import           Xanthous.Data
+                 ( move
+                 , Position(..)
+                 , Dimensions'(Dimensions)
+                 , Dimensions
+                 , positionFromPair
+                 )
 import qualified Xanthous.Data.EntityMap as EntityMap
 import           Xanthous.Data.EntityMap (EntityMap)
 import           Xanthous.Game
@@ -24,6 +30,7 @@ import           Xanthous.Entities.Raws (raw)
 import           Xanthous.Entities
 import           Xanthous.Generators
 import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
+import           Xanthous.Generators.LevelContents
 --------------------------------------------------------------------------------
 
 type App = Brick.App GameState () Name
@@ -49,10 +56,13 @@ testGormlak =
 startEvent :: AppM ()
 startEvent = do
   say_ ["welcome"]
-  level <- generateLevel SCaveAutomata CaveAutomata.defaultParams
-          $ Dimensions 120 80
+  (level, charPos) <-
+    generateLevel SCaveAutomata CaveAutomata.defaultParams
+    $ Dimensions 80 80
   entities <>= level
-  entities %= EntityMap.insertAt (Position 10 10) (SomeEntity testGormlak)
+  characterPosition .= charPos
+  -- entities %= EntityMap.insertAt (Position 10 10) (SomeEntity testGormlak)
+
 
 handleEvent :: BrickEvent Name () -> AppM (Next GameState)
 handleEvent (VtyEvent (EvKey k mods))
@@ -73,9 +83,15 @@ handleCommand PreviousMessage = do
 
 --------------------------------------------------------------------------------
 
-generateLevel :: SGenerator gen -> Params gen -> Dimensions -> AppM (EntityMap SomeEntity)
+generateLevel
+  :: SGenerator gen
+  -> Params gen
+  -> Dimensions
+  -> AppM (EntityMap SomeEntity, Position)
 generateLevel g ps dims = do
   gen <- use randomGen
   let cells = generate g ps dims gen
   _ <- getRandom @_ @Int -- perturb the generator, so we don't get the same level twice
-  pure $ SomeEntity <$> cellsToWalls cells
+  charPos <- positionFromPair <$> chooseCharacterPosition cells
+  let level = SomeEntity <$> cellsToWalls cells
+  pure (level, charPos)
diff --git a/src/Xanthous/Data.hs b/src/Xanthous/Data.hs
index e4355263846a..468e59217cce 100644
--- a/src/Xanthous/Data.hs
+++ b/src/Xanthous/Data.hs
@@ -15,6 +15,7 @@ module Xanthous.Data
   , position
   , positioned
   , loc
+  , positionFromPair
 
     -- *
   , Dimensions'(..)
@@ -91,6 +92,9 @@ loc = iso hither yon
     hither (Position px py) = Location (px, py)
     yon (Location (lx, ly)) = Position lx ly
 
+positionFromPair :: (Integral i, Integral j) => (i, j) -> Position
+positionFromPair (i, j) = Position (fromIntegral i) (fromIntegral j)
+
 --------------------------------------------------------------------------------
 
 data Dimensions' a = Dimensions
diff --git a/src/Xanthous/Data/EntityMap.hs b/src/Xanthous/Data/EntityMap.hs
index 401e395547e1..e713aff32c6b 100644
--- a/src/Xanthous/Data/EntityMap.hs
+++ b/src/Xanthous/Data/EntityMap.hs
@@ -101,7 +101,7 @@ _EntityMap = iso hither yon
     yon poses = alaf Endo foldMap (uncurry insertAt) poses emptyEntityMap
 
 instance Semigroup (EntityMap a) where
-  em₁ <> em₂ = alaf Endo foldMap (uncurry insertAt) (em₁ ^. _EntityMap) em₂
+  em₁ <> em₂ = alaf Endo foldMap (uncurry insertAt) (em₂ ^. _EntityMap) em₁
 
 instance Monoid (EntityMap a) where
   mempty = emptyEntityMap
diff --git a/src/Xanthous/Generators.hs b/src/Xanthous/Generators.hs
index 740b39c5f082..6e2e89d14a14 100644
--- a/src/Xanthous/Generators.hs
+++ b/src/Xanthous/Generators.hs
@@ -33,13 +33,13 @@ generate
   -> Params gen
   -> Dimensions
   -> g
-  -> UArray (Word, Word) Bool
+  -> Cells
 generate SCaveAutomata = CaveAutomata.generate
 
 data GeneratorInput where
   GeneratorInput :: forall gen. SGenerator gen -> Params gen -> GeneratorInput
 
-generateFromInput :: RandomGen g => GeneratorInput -> Dimensions -> g -> UArray (Word, Word) Bool
+generateFromInput :: RandomGen g => GeneratorInput -> Dimensions -> g -> Cells
 generateFromInput (GeneratorInput sg ps) = generate sg ps
 
 parseGeneratorInput :: Opt.Parser GeneratorInput
@@ -48,7 +48,7 @@ parseGeneratorInput = Opt.subparser $
                       (GeneratorInput <$> pure SCaveAutomata <*> CaveAutomata.parseParams)
                       (Opt.progDesc "cellular-automata based cave generator"))
 
-showCells :: UArray (Word, Word) Bool -> Text
+showCells :: Cells -> Text
 showCells arr =
   let ((minX, minY), (maxX, maxY)) = bounds arr
       showCellVal True = "x"
@@ -58,7 +58,7 @@ showCells arr =
       rows = row <$> [minY..maxY]
   in intercalate "\n" rows
 
-cellsToWalls :: UArray (Word, Word) Bool -> EntityMap Wall
+cellsToWalls :: Cells -> EntityMap Wall
 cellsToWalls cells = foldl' maybeInsertWall mempty . assocs $ cells
   where
     maybeInsertWall em (pos@(x, y), True)
diff --git a/src/Xanthous/Generators/CaveAutomata.hs b/src/Xanthous/Generators/CaveAutomata.hs
index bf37cb3f08e7..a2f0a165e3c1 100644
--- a/src/Xanthous/Generators/CaveAutomata.hs
+++ b/src/Xanthous/Generators/CaveAutomata.hs
@@ -92,7 +92,7 @@ generate params dims gen
   $ flip runRandT gen
   $ generate' params dims
 
-generate' :: RandomGen g => Params -> Dimensions -> CellM g s (Cells s)
+generate' :: RandomGen g => Params -> Dimensions -> CellM g s (MCells s)
 generate' params dims = do
   cells <- randInitialize dims $ params ^. aliveStartChance
   let steps' = params ^. steps
@@ -100,7 +100,7 @@ generate' params dims = do
    $ for_ [0 .. pred steps'] . const $ stepAutomata cells dims params
   pure cells
 
-stepAutomata :: forall s g. Cells s -> Dimensions -> Params -> CellM g s ()
+stepAutomata :: forall s g. MCells s -> Dimensions -> Params -> CellM g s ()
 stepAutomata cells dims params = do
   origCells <- lift $ cloneMArray @_ @(STUArray s) cells
   for_ (range ((0, 0), (dims ^. width, dims ^. height))) $ \pos -> do
diff --git a/src/Xanthous/Generators/LevelContents.hs b/src/Xanthous/Generators/LevelContents.hs
new file mode 100644
index 000000000000..f8d9b8a2045a
--- /dev/null
+++ b/src/Xanthous/Generators/LevelContents.hs
@@ -0,0 +1,26 @@
+--------------------------------------------------------------------------------
+module Xanthous.Generators.LevelContents
+  ( chooseCharacterPosition
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Control.Monad.Random
+import Data.Array.IArray (amap)
+--------------------------------------------------------------------------------
+import Xanthous.Generators.Util
+import Xanthous.Random
+--------------------------------------------------------------------------------
+
+chooseCharacterPosition :: MonadRandom m => Cells -> m (Word, Word)
+chooseCharacterPosition cells = choose $ impureNonNull candidates
+  where
+    -- cells ends up with true = wall, we want true = can put a character here
+    placeableCells = amap not cells
+
+    -- 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
diff --git a/src/Xanthous/Generators/Util.hs b/src/Xanthous/Generators/Util.hs
index 260c41ac6002..47ee81b2931e 100644
--- a/src/Xanthous/Generators/Util.hs
+++ b/src/Xanthous/Generators/Util.hs
@@ -1,28 +1,34 @@
--- |
-
+{-# LANGUAGE ViewPatterns #-}
+--------------------------------------------------------------------------------
 module Xanthous.Generators.Util
-  ( Cells
+  ( MCells
+  , Cells
   , CellM
   , randInitialize
   , numAliveNeighborsM
   , numAliveNeighbors
   , cloneMArray
+  , floodFill
+  , regions
   ) where
-
-import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Xanthous.Prelude hiding (Foldable, toList)
 import Data.Array.ST
 import Data.Array.Unboxed
 import Control.Monad.ST
 import Control.Monad.Random
 import Data.Monoid
-
-import Xanthous.Util (foldlMapM')
+import Data.Foldable (Foldable, toList)
+--------------------------------------------------------------------------------
+import Xanthous.Util (foldlMapM', between)
 import Xanthous.Data (Dimensions, width, height)
+--------------------------------------------------------------------------------
 
-type Cells s = STUArray s (Word, Word) Bool
+type MCells s = STUArray s (Word, Word) Bool
+type Cells = UArray (Word, Word) Bool
 type CellM g s a = RandT g (ST s) a
 
-randInitialize :: RandomGen g => Dimensions -> Double -> CellM g s (Cells s)
+randInitialize :: RandomGen g => Dimensions -> Double -> CellM g s (MCells s)
 randInitialize dims aliveChance = do
   res <- lift $ newArray ((0, 0), (dims ^. width, dims ^. height)) False
   for_ [0..dims ^. width] $ \i ->
@@ -87,6 +93,14 @@ numAliveNeighbors cells (x, y) =
     neighborPositions :: [(Int, Int)]
     neighborPositions = [(i, j) | i <- [-1..1], j <- [-1..1], (i, j) /= (0, 0)]
 
+safeGet :: (IArray a e, Ix i) => a i e -> i -> Maybe e
+safeGet arr idx =
+  let (minIdx, maxIdx) = bounds arr
+  in if idx < minIdx || idx > maxIdx
+     then Nothing
+     else Just $ arr ! idx
+
+
 cloneMArray
   :: forall a a' i e m.
   ( Ix i
@@ -97,3 +111,68 @@ cloneMArray
   => a i e
   -> m (a' i e)
 cloneMArray = thaw @_ @UArray <=< freeze
+
+--------------------------------------------------------------------------------
+
+-- | Flood fill a cell array starting at a point, returning a list of all the
+-- (true) cell locations reachable from that point
+floodFill :: forall a i j.
+            ( IArray a Bool
+            , Ix (i, j)
+            , Enum i , Enum j
+            , Bounded i , Bounded j
+            , Eq i , Eq j
+            , Show i, Show j
+            )
+          => a (i, j) Bool -- ^ array
+          -> (i, j)        -- ^ position
+          -> Set (i, j)
+floodFill = go mempty
+  where
+    go :: Set (i, j) -> a (i, j) Bool -> (i, j) -> Set (i, j)
+    -- TODO pass result in rather than passing seen in, return result
+    go res arr@(bounds -> arrBounds) idx@(x, y)
+      | not (inRange arrBounds idx) =  res
+      | not (arr ! idx) =  res
+      | otherwise =
+        let neighbors
+              = filter (inRange arrBounds)
+              . filter (/= idx)
+              . filter (`notMember` res)
+              $ (,)
+              <$> [(if x == minBound then x else pred x)
+                   ..
+                   (if x == maxBound then x else succ x)]
+              <*> [(if y == minBound then y else pred y)
+                   ..
+                   (if y == maxBound then y else succ y)]
+        in foldl' (\r idx' ->
+                     if arr ! idx'
+                     then r <> go (r & contains idx' .~ True) arr idx'
+                     else r)
+           (res & contains idx .~ True) neighbors
+
+-- | Gives a list of all the disconnected regions in a cell array, represented
+-- each as lists of points
+regions :: forall a i j.
+          ( IArray a Bool
+          , Ix (i, j)
+          , Enum i , Enum j
+          , Bounded i , Bounded j
+          , Eq i , Eq j
+          , Show i, Show j
+          )
+        => a (i, j) Bool
+        -> [Set (i, j)]
+regions arr
+  | Just firstPoint <- findFirstPoint arr =
+      let region = floodFill arr firstPoint
+          arr' = fillAll region arr
+      in region : regions arr'
+  | otherwise = []
+  where
+    findFirstPoint :: a (i, j) Bool -> Maybe (i, j)
+    findFirstPoint = fmap fst . headMay . filter snd . assocs
+
+    fillAll :: Foldable f => f (i, j) -> a (i, j) Bool -> a (i, j) Bool
+    fillAll ixes a = accum (const fst) a $ (, (False, ())) <$> toList ixes