feat(xan): Generate random villages r/1111

This algorithm is a little rough around the edges right now, but
generally the idea is we find a relatively closed-off region of the map,
and place rooms randomly on it, expanding them until they run into each
other, then we put doors in the walls of the rooms and a single door
opening into the region. Later on, we'll generate friendly (or
unfriendly!) NPCs to put in those rooms.

Change-Id: Ic989b9905f55ad92a01fdf6db11aa57afb4ce383
Reviewed-on: https://cl.tvl.fyi/c/depot/+/726
Reviewed-by: glittershark <grfn@gws.fyi>

3 files changed, 130 insertions, 8 deletions

diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs b/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs
index 83740fe4b73d..ada201ef3d6c 100644
--- a/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs
+++ b/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs
@@ -70,6 +70,7 @@ parseParams = Params
       <> Opt.help "Number of generations to run the automata for"
       <> Opt.metavar "STEPS"
       )
+  <**> Opt.helper
   where
     parseChance = readWithGuard
       (between 0 1)
diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs b/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs
index 70d94860dc68..e1e367007e65 100644
--- a/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs
+++ b/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs
@@ -75,9 +75,6 @@ numAliveNeighborsM cells (x, y) = do
             ny = fromIntegral $ fromIntegral y + j
         in readArray cells (nx, ny)
 
-    neighborPositions :: [(Int, Int)]
-    neighborPositions = [(i, j) | i <- [-1..1], j <- [-1..1], (i, j) /= (0, 0)]
-
 numAliveNeighbors
   :: forall a i j
   . (IArray a Bool, Ix (i, j), Integral i, Integral j)
@@ -103,8 +100,8 @@ numAliveNeighbors cells (x, y) =
             ny = fromIntegral $ fromIntegral y + j
         in cells ! (nx, ny)
 
-    neighborPositions :: [(Int, Int)]
-    neighborPositions = [(i, j) | i <- [-1..1], j <- [-1..1], (i, j) /= (0, 0)]
+neighborPositions :: [(Int, Int)]
+neighborPositions = [(i, j) | i <- [-1..1], j <- [-1..1], (i, j) /= (0, 0)]
 
 fillOuterEdgesM :: (MArray a Bool m, Ix i, Ix j) => a (i, j) Bool -> m ()
 fillOuterEdgesM arr = do
@@ -137,7 +134,6 @@ floodFill :: forall a 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
@@ -145,7 +141,6 @@ floodFill :: forall a 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
@@ -177,7 +172,6 @@ regions :: forall a 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)]
diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/Village.hs b/users/glittershark/xanthous/src/Xanthous/Generators/Village.hs
new file mode 100644
index 000000000000..52f26dcde018
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Generators/Village.hs
@@ -0,0 +1,127 @@
+{-# LANGUAGE PartialTypeSignatures #-}
+module Xanthous.Generators.Village
+  -- ( fromCave
+  -- )
+  where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding (any, failing, toList)
+--------------------------------------------------------------------------------
+import           Control.Monad.Random (MonadRandom)
+import           Control.Monad.State (execStateT, MonadState, modify)
+import           Control.Monad.Trans.Maybe
+import           Control.Parallel.Strategies
+import           Data.Array.IArray
+import           Data.Foldable (any, toList)
+--------------------------------------------------------------------------------
+import           Xanthous.Data
+import           Xanthous.Data.EntityMap (EntityMap)
+import qualified Xanthous.Data.EntityMap as EntityMap
+import           Xanthous.Entities.Environment
+import           Xanthous.Generators.Util
+import           Xanthous.Game.State (SomeEntity(..))
+import           Xanthous.Random
+--------------------------------------------------------------------------------
+
+fromCave :: MonadRandom m
+         => Cells -- ^ The positions of all the walls
+         -> m (EntityMap SomeEntity)
+fromCave wallPositions = execStateT (fromCave' wallPositions) mempty
+
+fromCave' :: forall m. (MonadRandom m, MonadState (EntityMap SomeEntity) m)
+          => Cells
+          -> m ()
+fromCave' wallPositions = failing (pure ()) $ do
+  Just villageRegion <-
+    choose
+    . (`using` parTraversable rdeepseq)
+    . weightedBy (\reg -> let circSize = length $ circumference reg
+                         in if circSize == 50
+                            then (1.0 :: Double)
+                            else 1.0 / (fromIntegral . abs $ circSize - 50))
+    $ regions closedHallways
+
+  let circ = setFromList . circumference $ villageRegion
+
+  centerPoints <- chooseSubset (0.1 :: Double) $ toList circ
+
+  roomTiles <- foldM
+              (flip $ const $ stepOut circ)
+              (map pure centerPoints)
+              [0 :: Int ..2]
+
+  let roomWalls = circumference . setFromList @(Set _) <$> roomTiles
+      allWalls = join roomWalls
+
+  doorPositions <- fmap join . for roomWalls $ \room ->
+    let candidates = filter (`notMember` circ) room
+    in fmap toList . choose $ ChooseElement candidates
+
+  let entryways =
+        filter (\pt ->
+                  let ncs = neighborCells pt
+                  in any ((&&) <$> (not . (wallPositions !))
+                              <*> (`notMember` villageRegion)) ncs
+                   && any ((&&) <$> (`member` villageRegion)
+                              <*> (`notElem` allWalls)) ncs)
+                  $ toList villageRegion
+
+  Just entryway <- choose $ ChooseElement entryways
+
+  for_ (filter ((&&) <$> (`notElem` doorPositions) <*> (/= entryway)) allWalls)
+    $ insertEntity Wall
+  for_ (filter (/= entryway) doorPositions) $ insertEntity unlockedDoor
+  insertEntity unlockedDoor entryway
+
+
+  where
+    insertEntity e pt = modify $ EntityMap.insertAt (ptToPos pt) $ SomeEntity e
+    ptToPos pt = _Position # (pt & both %~ fromIntegral)
+
+    stepOut :: Set (Word, Word) -> [[(Word, Word)]] -> MaybeT m [[(Word, Word)]]
+    stepOut circ rooms = for rooms $ \room ->
+      let nextLevels = hashNub $ toList . neighborCells =<< room
+      in pure
+         . (<> room)
+         $ filter ((&&) <$> (`notMember` circ) <*> (`notElem` join rooms))
+         nextLevels
+
+    circumference pts =
+      filter (any (`notMember` pts) . neighborCells) $ toList pts
+    closedHallways = closeHallways livePositions
+    livePositions = amap not wallPositions
+
+--------------------------------------------------------------------------------
+
+closeHallways :: Cells -> Cells
+closeHallways livePositions =
+  livePositions // mapMaybe closeHallway (assocs livePositions)
+  where
+    closeHallway (_, False) = Nothing
+    closeHallway (pos, _)
+      | isHallway pos = Just (pos, False)
+      | otherwise     = Nothing
+    isHallway pos = any ((&&) <$> not . view left <*> not . view right)
+      . rotations
+      . fmap (fromMaybe False)
+      $ arrayNeighbors livePositions pos
+
+failing :: Monad m => m a -> MaybeT m a -> m a
+failing result = (maybe result pure =<<) . runMaybeT
+
+{-
+
+import Xanthous.Generators.Village
+import Xanthous.Generators
+import Xanthous.Data
+import System.Random
+import qualified Data.Text
+import qualified Xanthous.Generators.CaveAutomata as CA
+let gi = GeneratorInput SCaveAutomata CA.defaultParams
+wallPositions <- generateFromInput gi (Dimensions 80 50) <$> getStdGen
+putStrLn . Data.Text.unpack $ showCells wallPositions
+
+import Data.Array.IArray
+let closedHallways = closeHallways . amap not $ wallPositions
+putStrLn . Data.Text.unpack . showCells $ amap not closedHallways
+
+-}