refactor(users/glittershark): Rename to grfn r/2485

Rename my //users directory and all places that refer to glittershark to
grfn, including nix references and documentation.

This may require some extra attention inside of gerrit's database after
it lands to allow me to actually push things.

Change-Id: I4728b7ec2c60024392c1c1fa6e0d4a59b3e266fa
Reviewed-on: https://cl.tvl.fyi/c/depot/+/2933
Tested-by: BuildkiteCI
Reviewed-by: tazjin <mail@tazj.in>
Reviewed-by: lukegb <lukegb@tvl.fyi>
Reviewed-by: glittershark <grfn@gws.fyi>

1 files changed, 168 insertions, 0 deletions

diff --git a/users/grfn/xanthous/src/Xanthous/Generators.hs b/users/grfn/xanthous/src/Xanthous/Generators.hs
new file mode 100644
index 000000000000..ef37070b6ede
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Generators.hs
@@ -0,0 +1,168 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE GADTs           #-}
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Generators
+  ( 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.CaveAutomata as CaveAutomata
+import qualified Xanthous.Generators.Dungeon as Dungeon
+import           Xanthous.Generators.Util
+import           Xanthous.Generators.LevelContents
+import           Xanthous.Generators.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