refactor(xanthous): Generators -> Generators.Level r/2655

I'm going to start adding generators for things like text soon, so it
makes sense to specifically sequester level generators as their own
thing

Change-Id: I175025375204fab7d75eba67dd06dab9bd2939d3
Reviewed-on: https://cl.tvl.fyi/c/depot/+/3201
Reviewed-by: grfn <grfn@gws.fyi>
Tested-by: BuildkiteCI

6 files changed, 178 insertions, 9 deletions

diff --git a/users/grfn/xanthous/src/Xanthous/Generators/Level.hs b/users/grfn/xanthous/src/Xanthous/Generators/Level.hs
new file mode 100644
index 0000000000..81f21f55ff
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Generators/Level.hs
@@ -0,0 +1,168 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE GADTs           #-}
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Generators.Level
+  ( generate
+  , Generator(..)
+  , SGenerator(..)
+  , GeneratorInput(..)
+  , generateFromInput
+  , parseGeneratorInput
+  , showCells
+  , Level(..)
+  , levelWalls
+  , levelItems
+  , levelCreatures
+  , levelDoors
+  , levelCharacterPosition
+  , levelTutorialMessage
+  , levelExtra
+  , generateLevel
+  , levelToEntityMap
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+import           Data.Array.Unboxed
+import qualified Options.Applicative as Opt
+import           Control.Monad.Random
+--------------------------------------------------------------------------------
+import qualified Xanthous.Generators.Level.CaveAutomata as CaveAutomata
+import qualified Xanthous.Generators.Level.Dungeon as Dungeon
+import           Xanthous.Generators.Level.Util
+import           Xanthous.Generators.Level.LevelContents
+import           Xanthous.Generators.Level.Village as Village
+import           Xanthous.Data (Dimensions, Position'(Position), Position)
+import           Xanthous.Data.EntityMap (EntityMap, _EntityMap)
+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(..))
+import           Linear.V2
+--------------------------------------------------------------------------------
+
+data Generator
+  = CaveAutomata
+  | Dungeon
+  deriving stock (Show, Eq)
+
+data SGenerator (gen :: Generator) where
+  SCaveAutomata :: SGenerator 'CaveAutomata
+  SDungeon :: SGenerator 'Dungeon
+
+type family Params (gen :: Generator) :: Type where
+  Params 'CaveAutomata = CaveAutomata.Params
+  Params 'Dungeon = Dungeon.Params
+
+generate
+  :: RandomGen g
+  => SGenerator gen
+  -> Params gen
+  -> Dimensions
+  -> g
+  -> Cells
+generate SCaveAutomata = CaveAutomata.generate
+generate SDungeon = Dungeon.generate
+
+data GeneratorInput where
+  GeneratorInput :: forall gen. SGenerator gen -> Params gen -> GeneratorInput
+
+generateFromInput :: RandomGen g => GeneratorInput -> Dimensions -> g -> Cells
+generateFromInput (GeneratorInput sg ps) = generate sg ps
+
+parseGeneratorInput :: Opt.Parser GeneratorInput
+parseGeneratorInput = Opt.subparser
+  $ generatorCommand SCaveAutomata
+      "cave"
+      "Cellular-automata based cave generator"
+      CaveAutomata.parseParams
+  <> generatorCommand SDungeon
+      "dungeon"
+      "Classic dungeon map generator"
+      Dungeon.parseParams
+  where
+    generatorCommand sgen name desc parseParams =
+      Opt.command name
+        (Opt.info
+          (GeneratorInput <$> pure sgen <*> parseParams)
+          (Opt.progDesc desc)
+        )
+
+
+showCells :: Cells -> Text
+showCells arr =
+  let (V2 minX minY, V2 maxX maxY) = bounds arr
+      showCellVal True = "x"
+      showCellVal False = " "
+      showCell = showCellVal . (arr !)
+      row r = foldMap (showCell . (`V2` r)) [minX..maxX]
+      rows = row <$> [minY..maxY]
+  in intercalate "\n" rows
+
+cellsToWalls :: Cells -> EntityMap Wall
+cellsToWalls cells = foldl' maybeInsertWall mempty . assocs $ cells
+  where
+    maybeInsertWall em (pos@(V2 x y), True)
+      | not (surroundedOnAllSides pos) =
+        let x' = fromIntegral x
+            y' = fromIntegral y
+        in EntityMap.insertAt (Position x' y') Wall em
+    maybeInsertWall em _ = em
+    surroundedOnAllSides pos = numAliveNeighbors cells pos == 8
+
+--------------------------------------------------------------------------------
+
+data Level = Level
+  { _levelWalls             :: !(EntityMap Wall)
+  , _levelDoors             :: !(EntityMap Door)
+  , _levelItems             :: !(EntityMap Item)
+  , _levelCreatures         :: !(EntityMap Creature)
+  , _levelTutorialMessage   :: !(EntityMap GroundMessage)
+  , _levelStaircases        :: !(EntityMap Staircase)
+  , _levelExtra             :: !(EntityMap SomeEntity) -- ^ TODO this is a bit of a hack...
+  , _levelCharacterPosition :: !Position
+  }
+  deriving stock (Generic)
+  deriving anyclass (NFData)
+makeLenses ''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
+  village <- generateVillage cells gen
+  let _levelExtra = village
+  _levelItems <- randomItems cells
+  _levelCreatures <- randomCreatures cells
+  _levelDoors <- randomDoors cells
+  _levelCharacterPosition <- chooseCharacterPosition cells
+  let upStaircase = _EntityMap # [(_levelCharacterPosition, UpStaircase)]
+  downStaircase <- placeDownStaircase cells
+  let _levelStaircases = upStaircase <> downStaircase
+  _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)
+  <> (SomeEntity <$> level ^. levelStaircases)
+  <> (level ^. levelExtra)
+
+generateVillage
+  :: MonadRandom m
+  => Cells -- ^ Wall positions
+  -> SGenerator gen
+  -> m (EntityMap SomeEntity)
+generateVillage wallPositions SCaveAutomata = Village.fromCave wallPositions
+generateVillage _ _ = pure mempty
diff --git a/users/grfn/xanthous/src/Xanthous/Generators/CaveAutomata.hs b/users/grfn/xanthous/src/Xanthous/Generators/Level/CaveAutomata.hs
index be904662f3..03d534ca39 100644
--- a/users/grfn/xanthous/src/Xanthous/Generators/CaveAutomata.hs
+++ b/users/grfn/xanthous/src/Xanthous/Generators/Level/CaveAutomata.hs
@@ -2,7 +2,7 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TemplateHaskell #-}
 --------------------------------------------------------------------------------
-module Xanthous.Generators.CaveAutomata
+module Xanthous.Generators.Level.CaveAutomata
   ( Params(..)
   , defaultParams
   , parseParams
@@ -18,7 +18,7 @@ import qualified Options.Applicative as Opt
 import           Xanthous.Util (between)
 import           Xanthous.Util.Optparse
 import           Xanthous.Data (Dimensions, width, height)
-import           Xanthous.Generators.Util
+import           Xanthous.Generators.Level.Util
 import           Linear.V2
 --------------------------------------------------------------------------------
 
diff --git a/users/grfn/xanthous/src/Xanthous/Generators/Dungeon.hs b/users/grfn/xanthous/src/Xanthous/Generators/Level/Dungeon.hs
index f30713ce11..4851b02269 100644
--- a/users/grfn/xanthous/src/Xanthous/Generators/Dungeon.hs
+++ b/users/grfn/xanthous/src/Xanthous/Generators/Level/Dungeon.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE TemplateHaskell #-}
 --------------------------------------------------------------------------------
-module Xanthous.Generators.Dungeon
+module Xanthous.Generators.Level.Dungeon
   ( Params(..)
   , defaultParams
   , parseParams
@@ -24,7 +24,7 @@ import qualified Options.Applicative as Opt
 --------------------------------------------------------------------------------
 import           Xanthous.Random
 import           Xanthous.Data hiding (x, y, _x, _y, edges)
-import           Xanthous.Generators.Util
+import           Xanthous.Generators.Level.Util
 import           Xanthous.Util.Graphics (delaunay, straightLine)
 import           Xanthous.Util.Graph (mstSubGraph)
 --------------------------------------------------------------------------------
diff --git a/users/grfn/xanthous/src/Xanthous/Generators/LevelContents.hs b/users/grfn/xanthous/src/Xanthous/Generators/Level/LevelContents.hs
index 8ebcc7f4da..7582ae2758 100644
--- a/users/grfn/xanthous/src/Xanthous/Generators/LevelContents.hs
+++ b/users/grfn/xanthous/src/Xanthous/Generators/Level/LevelContents.hs
@@ -1,5 +1,5 @@
 --------------------------------------------------------------------------------
-module Xanthous.Generators.LevelContents
+module Xanthous.Generators.Level.LevelContents
   ( chooseCharacterPosition
   , randomItems
   , randomCreatures
@@ -16,7 +16,7 @@ import qualified Data.Array.IArray as Arr
 import           Data.Foldable (any, toList)
 import           Linear.V2
 --------------------------------------------------------------------------------
-import           Xanthous.Generators.Util
+import           Xanthous.Generators.Level.Util
 import           Xanthous.Random
 import           Xanthous.Data
                  ( positionFromV2,  Position, _Position
diff --git a/users/grfn/xanthous/src/Xanthous/Generators/Util.hs b/users/grfn/xanthous/src/Xanthous/Generators/Level/Util.hs
index 88aadd5aad..c643778179 100644
--- a/users/grfn/xanthous/src/Xanthous/Generators/Util.hs
+++ b/users/grfn/xanthous/src/Xanthous/Generators/Level/Util.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE AllowAmbiguousTypes #-}
 --------------------------------------------------------------------------------
-module Xanthous.Generators.Util
+module Xanthous.Generators.Level.Util
   ( MCells
   , Cells
   , CellM
diff --git a/users/grfn/xanthous/src/Xanthous/Generators/Village.hs b/users/grfn/xanthous/src/Xanthous/Generators/Level/Village.hs
index cc9c9d963f..ab7de95e68 100644
--- a/users/grfn/xanthous/src/Xanthous/Generators/Village.hs
+++ b/users/grfn/xanthous/src/Xanthous/Generators/Level/Village.hs
@@ -1,4 +1,5 @@
-module Xanthous.Generators.Village
+--------------------------------------------------------------------------------
+module Xanthous.Generators.Level.Village
   ( fromCave
   ) where
 --------------------------------------------------------------------------------
@@ -15,7 +16,7 @@ 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.Generators.Level.Util
 import           Xanthous.Game.State (SomeEntity(..))
 import           Xanthous.Random
 --------------------------------------------------------------------------------