Convert generated levels to walls

Add support for converting generated levels to walls, and merge one into
the entity map at the beginning of the game.

There's nothing here that guarantees the character ends up *inside* the
level though (they almost always don't) so that'll have to be slotted
into the level generation process.

17 files changed, 336 insertions, 110 deletions

diff --git a/src/Main.hs b/src/Main.hs
index 4d6ccfd4afc6..d49e082b7c6c 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -31,7 +31,7 @@ parseDimensions = Dimensions
        )
 
 parseCommand :: Opt.Parser Command
-parseCommand = Opt.subparser
+parseCommand = (<|> pure Run) $ Opt.subparser
   $ Opt.command "run"
       (Opt.info
        (pure Run)
diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs
index 6cf22135a7a4..af6b5caf6178 100644
--- a/src/Xanthous/App.hs
+++ b/src/Xanthous/App.hs
@@ -1,25 +1,30 @@
 module Xanthous.App (makeApp) where
-
+--------------------------------------------------------------------------------
 import           Xanthous.Prelude
 import           Brick hiding (App, halt, continue, raw)
 import qualified Brick
 import           Graphics.Vty.Attributes (defAttr)
 import           Graphics.Vty.Input.Events (Event(EvKey))
 import           Control.Monad.State (get)
-
+import           Control.Monad.Random (getRandom)
+--------------------------------------------------------------------------------
 import           Xanthous.Command
-import           Xanthous.Data (move, Position(..))
+import           Xanthous.Data (move, Position(..), Dimensions'(Dimensions), Dimensions)
 import qualified Xanthous.Data.EntityMap as EntityMap
+import           Xanthous.Data.EntityMap (EntityMap)
 import           Xanthous.Game
 import           Xanthous.Game.Draw (drawGame)
 import           Xanthous.Monad
 import           Xanthous.Resource (Name)
-
+--------------------------------------------------------------------------------
 import           Xanthous.Entities.Creature (Creature)
 import qualified Xanthous.Entities.Creature as Creature
 import           Xanthous.Entities.RawTypes (EntityRaw(..))
 import           Xanthous.Entities.Raws (raw)
-import           Xanthous.Entities.SomeEntity
+import           Xanthous.Entities
+import           Xanthous.Generators
+import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
+--------------------------------------------------------------------------------
 
 type App = Brick.App GameState () Name
 type AppM a = AppT (EventM Name) a
@@ -43,7 +48,10 @@ testGormlak =
 
 startEvent :: AppM ()
 startEvent = do
-  () <- say ["welcome"]
+  say_ ["welcome"]
+  level <- generateLevel SCaveAutomata CaveAutomata.defaultParams
+          $ Dimensions 120 80
+  entities <>= level
   entities %= EntityMap.insertAt (Position 10 10) (SomeEntity testGormlak)
 
 handleEvent :: BrickEvent Name () -> AppM (Next GameState)
@@ -62,3 +70,12 @@ handleCommand (Move dir) = do
 handleCommand PreviousMessage = do
   messageHistory %= popMessage
   continue
+
+--------------------------------------------------------------------------------
+
+generateLevel :: SGenerator gen -> Params gen -> Dimensions -> AppM (EntityMap SomeEntity)
+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
diff --git a/src/Xanthous/Data.hs b/src/Xanthous/Data.hs
index 6e779a450525..e4355263846a 100644
--- a/src/Xanthous/Data.hs
+++ b/src/Xanthous/Data.hs
@@ -29,21 +29,20 @@ module Xanthous.Data
   , asPosition
 
     -- *
-  , EntityChar(..)
+  , Neighbors(..)
+  , edges
+  , neighborDirections
+  , neighborPositions
   ) where
 --------------------------------------------------------------------------------
 import           Xanthous.Prelude hiding (Left, Down, Right)
 import           Test.QuickCheck (Arbitrary, CoArbitrary, Function)
 import           Test.QuickCheck.Arbitrary.Generic
 import           Data.Group
-import           Brick (Location(Location), raw)
-import           Graphics.Vty.Attributes
-import qualified Graphics.Vty.Image as Vty
-import           Data.Aeson
+import           Brick (Location(Location), Edges(..))
 --------------------------------------------------------------------------------
 import           Xanthous.Util (EqEqProp(..), EqProp)
 import           Xanthous.Orphans ()
-import           Xanthous.Entities (Draw(..))
 --------------------------------------------------------------------------------
 
 data Position where
@@ -149,27 +148,61 @@ asPosition dir = move dir mempty
 
 --------------------------------------------------------------------------------
 
-data EntityChar = EntityChar
-  { _char :: Char
-  , _style :: Attr
+data Neighbors a = Neighbors
+  { _topLeft
+  , _top
+  , _topRight
+  , _left
+  , _right
+  , _bottomLeft
+  , _bottom
+  , _bottomRight :: a
   }
-  deriving stock (Show, Eq, Generic)
+  deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
   deriving anyclass (NFData)
+makeLenses ''Neighbors
+
+instance Applicative Neighbors where
+  pure α = Neighbors
+    { _topLeft     = α
+    , _top         = α
+    , _topRight    = α
+    , _left        = α
+    , _right       = α
+    , _bottomLeft  = α
+    , _bottom      = α
+    , _bottomRight = α
+    }
+  nf <*> nx = Neighbors
+    { _topLeft     = nf ^. topLeft     $ nx ^. topLeft
+    , _top         = nf ^. top         $ nx ^. top
+    , _topRight    = nf ^. topRight    $ nx ^. topRight
+    , _left        = nf ^. left        $ nx ^. left
+    , _right       = nf ^. right       $ nx ^. right
+    , _bottomLeft  = nf ^. bottomLeft  $ nx ^. bottomLeft
+    , _bottom      = nf ^. bottom      $ nx ^. bottom
+    , _bottomRight = nf ^. bottomRight $ nx ^. bottomRight
+    }
+
+edges :: Neighbors a -> Edges a
+edges neighs = Edges
+  { eTop = neighs ^. top
+  , eBottom = neighs ^. bottom
+  , eLeft = neighs ^. left
+  , eRight = neighs ^. right
+  }
+
+neighborDirections :: Neighbors Direction
+neighborDirections = Neighbors
+  { _topLeft     = UpLeft
+  , _top         = Up
+  , _topRight    = UpRight
+  , _left        = Left
+  , _right       = Right
+  , _bottomLeft  = DownLeft
+  , _bottom      = Down
+  , _bottomRight = DownRight
+  }
 
-instance FromJSON EntityChar where
-  parseJSON (String (chr :< Empty)) = pure $ EntityChar chr defAttr
-  parseJSON (Object o) = do
-    (EntityChar _char _) <- o .: "char"
-    _style <- o .:? "style" >>= \case
-      Just styleO -> do
-        let attrStyle = Default -- TODO
-            attrURL = Default
-        attrForeColor <- styleO .:? "foreground" .!= Default
-        attrBackColor <- styleO .:? "background" .!= Default
-        pure Attr {..}
-      Nothing -> pure defAttr
-    pure EntityChar {..}
-  parseJSON _ = fail "Invalid type, expected string or object"
-
-instance Draw EntityChar where
-  draw EntityChar{..} = raw $ Vty.string _style [_char]
+neighborPositions :: Position -> Neighbors Position
+neighborPositions pos = (`move` pos) <$> neighborDirections
diff --git a/src/Xanthous/Data/EntityMap.hs b/src/Xanthous/Data/EntityMap.hs
index e3ceb6f65182..401e395547e1 100644
--- a/src/Xanthous/Data/EntityMap.hs
+++ b/src/Xanthous/Data/EntityMap.hs
@@ -15,6 +15,7 @@ module Xanthous.Data.EntityMap
   , lookup
   , lookupWithPosition
   -- , positionedEntities
+  , neighbors
   ) where
 
 import Data.Monoid (Endo(..))
@@ -22,7 +23,14 @@ import Test.QuickCheck (Arbitrary(..))
 import Test.QuickCheck.Checkers (EqProp)
 
 import Xanthous.Prelude hiding (lookup)
-import Xanthous.Data (Position, Positioned(..), positioned, position)
+import Xanthous.Data
+  ( Position
+  , Positioned(..)
+  , positioned
+  , position
+  , Neighbors(..)
+  , neighborPositions
+  )
 import Xanthous.Orphans ()
 import Xanthous.Util (EqEqProp(..))
 
@@ -139,3 +147,6 @@ lookup eid = fmap (view positioned) . lookupWithPosition eid
 -- unlawful :(
 -- positionedEntities :: IndexedTraversal EntityID (EntityMap a) (EntityMap b) (Positioned a) (Positioned b)
 -- positionedEntities = byID . itraversed
+
+neighbors :: Position -> EntityMap a -> Neighbors (Vector a)
+neighbors pos em = (\p -> view (atPosition p) em) <$> neighborPositions pos
diff --git a/src/Xanthous/Entities.hs b/src/Xanthous/Entities.hs
index 6851a7a5d506..bd52ae62b29f 100644
--- a/src/Xanthous/Entities.hs
+++ b/src/Xanthous/Entities.hs
@@ -1,23 +1,65 @@
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE UndecidableInstances #-}
-
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+--------------------------------------------------------------------------------
 module Xanthous.Entities
   ( Draw(..)
   , DrawCharacter(..)
   , DrawStyledCharacter(..)
   , Entity
+  , SomeEntity(..)
+  , downcastEntity
+  , entityIs
 
   , Color(..)
   , KnownColor(..)
-  ) where
 
-import Xanthous.Prelude
-import Brick
-import Data.Typeable
+  , EntityChar(..)
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Brick
+import           Data.Typeable
 import qualified Graphics.Vty.Attributes as Vty
 import qualified Graphics.Vty.Image as Vty
+import           Data.Aeson
+--------------------------------------------------------------------------------
+import           Xanthous.Data
+--------------------------------------------------------------------------------
+
+class (Show a, Eq a, Draw a) => Entity a
+instance (Show a, Eq a, Draw a) => Entity a
+
+--------------------------------------------------------------------------------
+data SomeEntity where
+  SomeEntity :: forall a. (Entity a, Typeable a) => a -> SomeEntity
+
+instance Show SomeEntity where
+  show (SomeEntity e) = "SomeEntity (" <> show e <> ")"
+
+instance Eq SomeEntity where
+  (SomeEntity (a :: ea)) == (SomeEntity (b :: eb)) = case eqT @ea @eb of
+    Just Refl -> a == b
+    _ -> False
+
+instance Draw SomeEntity where
+  drawWithNeighbors ns (SomeEntity ent) = drawWithNeighbors ns ent
+
+downcastEntity :: (Entity a, Typeable a) => SomeEntity -> Maybe a
+downcastEntity (SomeEntity e) = cast e
+
+entityIs :: forall a. (Entity a, Typeable a) => SomeEntity -> Bool
+entityIs = isJust . downcastEntity @a
+--------------------------------------------------------------------------------
 
 class Draw a where
+  drawWithNeighbors :: Neighbors (Vector SomeEntity) -> a -> Widget n
+  drawWithNeighbors = const draw
+
   draw :: a -> Widget n
+  draw = drawWithNeighbors $ pure mempty
 
 newtype DrawCharacter (char :: Symbol) (a :: Type) where
   DrawCharacter :: a -> DrawCharacter char a
@@ -57,8 +99,30 @@ instance
             , Vty.attrBackColor = Vty.SetTo $ colorVal @bg Proxy
             , Vty.attrURL = Vty.Default
             }
-
 --------------------------------------------------------------------------------
+data EntityChar = EntityChar
+  { _char :: Char
+  , _style :: Vty.Attr
+  }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData)
 
-class (Show a, Eq a, Draw a) => Entity a
-instance (Show a, Eq a, Draw a) => Entity a
+instance FromJSON EntityChar where
+  parseJSON (String (chr :< Empty)) = pure $ EntityChar chr Vty.defAttr
+  parseJSON (Object o) = do
+    (EntityChar _char _) <- o .: "char"
+    _style <- o .:? "style" >>= \case
+      Just styleO -> do
+        let attrStyle = Vty.Default -- TODO
+            attrURL = Vty.Default
+        attrForeColor <- styleO .:? "foreground" .!= Vty.Default
+        attrBackColor <- styleO .:? "background" .!= Vty.Default
+        pure Vty.Attr {..}
+      Nothing -> pure Vty.defAttr
+    pure EntityChar {..}
+  parseJSON _ = fail "Invalid type, expected string or object"
+
+instance Draw EntityChar where
+  draw EntityChar{..} = raw $ Vty.string _style [_char]
+
+--------------------------------------------------------------------------------
diff --git a/src/Xanthous/Entities/Arbitrary.hs b/src/Xanthous/Entities/Arbitrary.hs
new file mode 100644
index 000000000000..9153722d9b12
--- /dev/null
+++ b/src/Xanthous/Entities/Arbitrary.hs
@@ -0,0 +1,19 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Arbitrary () where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Test.QuickCheck
+import qualified Test.QuickCheck.Gen as Gen
+--------------------------------------------------------------------------------
+import           Xanthous.Entities (SomeEntity(..))
+import           Xanthous.Entities.Character
+import           Xanthous.Entities.Environment
+--------------------------------------------------------------------------------
+
+instance Arbitrary SomeEntity where
+  arbitrary = Gen.oneof
+    [ pure $ SomeEntity Character
+    , pure $ SomeEntity Wall
+    ]
diff --git a/src/Xanthous/Entities/Character.hs b/src/Xanthous/Entities/Character.hs
index 5cf397e82232..faa9964a3833 100644
--- a/src/Xanthous/Entities/Character.hs
+++ b/src/Xanthous/Entities/Character.hs
@@ -2,14 +2,14 @@ module Xanthous.Entities.Character
   ( Character(..)
   , mkCharacter
   ) where
-
+--------------------------------------------------------------------------------
 import Xanthous.Prelude
 import Test.QuickCheck
-
+--------------------------------------------------------------------------------
 import Xanthous.Entities
+--------------------------------------------------------------------------------
 
-data Character where
-  Character :: Character
+data Character = Character
   deriving stock (Show, Eq, Ord, Generic)
   deriving anyclass (CoArbitrary, Function)
   deriving Draw via (DrawCharacter "@" Character)
diff --git a/src/Xanthous/Entities/Draw/Util.hs b/src/Xanthous/Entities/Draw/Util.hs
new file mode 100644
index 000000000000..aa6c5fa4fc47
--- /dev/null
+++ b/src/Xanthous/Entities/Draw/Util.hs
@@ -0,0 +1,31 @@
+module Xanthous.Entities.Draw.Util where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Brick.Widgets.Border.Style
+import Brick.Types (Edges(..))
+--------------------------------------------------------------------------------
+
+borderFromEdges :: BorderStyle -> Edges Bool -> Char
+borderFromEdges bstyle edges = ($ bstyle) $ case edges of
+  Edges False False  False False -> const '☐'
+
+  Edges True  False  False False -> bsVertical
+  Edges False True   False False -> bsVertical
+  Edges False False  True  False -> bsHorizontal
+  Edges False False  False True  -> bsHorizontal
+
+  Edges True  True   False False -> bsVertical
+  Edges True  False  True  False -> bsCornerBR
+  Edges True  False  False True  -> bsCornerBL
+
+  Edges False True   True  False -> bsCornerTR
+  Edges False True   False True  -> bsCornerTL
+  Edges False False  True  True  -> bsHorizontal
+
+  Edges False True   True  True  -> bsIntersectT
+  Edges True  False  True  True  -> bsIntersectB
+  Edges True  True   False True  -> bsIntersectL
+  Edges True  True   True  False -> bsIntersectR
+
+  Edges True  True   True  True  -> bsIntersectFull
diff --git a/src/Xanthous/Entities/Environment.hs b/src/Xanthous/Entities/Environment.hs
new file mode 100644
index 000000000000..f5301f94adf2
--- /dev/null
+++ b/src/Xanthous/Entities/Environment.hs
@@ -0,0 +1,26 @@
+module Xanthous.Entities.Environment
+  ( Wall(..)
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+import Test.QuickCheck
+import Brick (str)
+import Brick.Widgets.Border.Style (unicode)
+--------------------------------------------------------------------------------
+import Xanthous.Entities (Draw(..), entityIs)
+import Xanthous.Entities.Draw.Util
+import Xanthous.Data
+--------------------------------------------------------------------------------
+
+data Wall = Wall
+  deriving stock (Show, Eq, Ord, Generic, Enum)
+  deriving anyclass (CoArbitrary, Function)
+
+instance Arbitrary Wall where
+  arbitrary = pure Wall
+
+instance Draw Wall where
+  drawWithNeighbors neighs _wall =
+    str . pure . borderFromEdges unicode $ wallEdges
+    where
+      wallEdges = any (entityIs @Wall) <$> edges neighs
diff --git a/src/Xanthous/Entities/RawTypes.hs b/src/Xanthous/Entities/RawTypes.hs
index e82cb0c890c7..88087a5dab61 100644
--- a/src/Xanthous/Entities/RawTypes.hs
+++ b/src/Xanthous/Entities/RawTypes.hs
@@ -20,7 +20,7 @@ import Data.Aeson.Generic.DerivingVia
 import Data.Aeson (FromJSON)
 import Data.Word
 
-import Xanthous.Data
+import Xanthous.Entities (EntityChar)
 
 data CreatureType = CreatureType
   { _name :: Text
diff --git a/src/Xanthous/Entities/SomeEntity.hs b/src/Xanthous/Entities/SomeEntity.hs
deleted file mode 100644
index 029247de9b7f..000000000000
--- a/src/Xanthous/Entities/SomeEntity.hs
+++ /dev/null
@@ -1,34 +0,0 @@
-{-# LANGUAGE GADTs #-}
-module Xanthous.Entities.SomeEntity
-  ( SomeEntity(..)
-  , downcastEntity
-  ) where
-
-import Xanthous.Prelude
-import Test.QuickCheck (Arbitrary(..))
-import qualified Test.QuickCheck.Gen as Gen
-
-import Xanthous.Entities (Draw(..), Entity)
-import Data.Typeable
-import Xanthous.Entities.Character
-
-data SomeEntity where
-  SomeEntity :: forall a. (Entity a, Typeable a) => a -> SomeEntity
-
-instance Show SomeEntity where
-  show (SomeEntity x) = "SomeEntity (" <> show x <> ")"
-
-instance Eq SomeEntity where
-  (SomeEntity (a :: ea)) == (SomeEntity (b :: eb)) = case eqT @ea @eb of
-    Just Refl -> a == b
-    _ -> False
-
-instance Arbitrary SomeEntity where
-  arbitrary = Gen.oneof
-    [pure $ SomeEntity Character]
-
-instance Draw SomeEntity where
-  draw (SomeEntity ent) = draw ent
-
-downcastEntity :: (Entity a, Typeable a) => SomeEntity -> Maybe a
-downcastEntity (SomeEntity e) = cast e
diff --git a/src/Xanthous/Game.hs b/src/Xanthous/Game.hs
index dffd0a9c6a6d..e967098015af 100644
--- a/src/Xanthous/Game.hs
+++ b/src/Xanthous/Game.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE RecordWildCards #-}
+--------------------------------------------------------------------------------
 module Xanthous.Game
   ( GameState(..)
   , entities
@@ -17,20 +18,23 @@ module Xanthous.Game
   , popMessage
   , hideMessage
   ) where
-
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
 import           Data.List.NonEmpty ( NonEmpty((:|)))
 import qualified Data.List.NonEmpty as NonEmpty
 import           System.Random
 import           Test.QuickCheck
 import           Test.QuickCheck.Arbitrary.Generic
-import           Xanthous.Prelude
-
+--------------------------------------------------------------------------------
 import           Xanthous.Data.EntityMap (EntityMap, EntityID)
 import qualified Xanthous.Data.EntityMap as EntityMap
 import           Xanthous.Data (Positioned, Position(..), positioned, position)
-import           Xanthous.Entities.SomeEntity
+import           Xanthous.Entities (SomeEntity(..), downcastEntity)
 import           Xanthous.Entities.Character
+import           Xanthous.Entities.Arbitrary ()
 import           Xanthous.Orphans ()
+--------------------------------------------------------------------------------
 
 data MessageHistory
   = NoMessageHistory
diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs
index 36abe161198e..4d3cb15dca4a 100644
--- a/src/Xanthous/Game/Draw.hs
+++ b/src/Xanthous/Game/Draw.hs
@@ -11,7 +11,8 @@ import Brick.Widgets.Border.Style
 import Data.List.NonEmpty(NonEmpty((:|)))
 
 import Xanthous.Data (Position(Position), x, y, loc)
-import Xanthous.Data.EntityMap
+import Xanthous.Data.EntityMap (EntityMap, atPosition)
+import qualified Xanthous.Data.EntityMap as EntityMap
 import Xanthous.Entities
 import Xanthous.Game
   ( GameState(..)
@@ -34,16 +35,19 @@ drawMessages (MessageHistory (lastMessage :| _) True) = txt lastMessage
 --   (MessageHistory _ False) -> padTop (Pad 2) $ str " "
 --   (MessageHistory (lastMessage :| _) True) -> txt lastMessage
 
-drawEntities :: (Draw a, Show a) => EntityMap a -> Widget Name
+drawEntities :: EntityMap SomeEntity -> Widget Name
 drawEntities em
   = vBox rows
   where
-    entityPositions = positions em
+    entityPositions = EntityMap.positions em
     maxY = fromMaybe 0 $ maximumOf (folded . y) entityPositions
     maxX = fromMaybe 0 $ maximumOf (folded . x) entityPositions
     rows = mkRow <$> [0..maxY]
     mkRow rowY = hBox $ renderEntityAt . flip Position rowY <$> [0..maxX]
-    renderEntityAt pos = maybe (str " ") draw $ em ^? atPosition pos . folded
+    renderEntityAt pos =
+      let neighbors = EntityMap.neighbors pos em
+      in maybe (str " ") (drawWithNeighbors neighbors)
+         $ em ^? atPosition pos . folded
 
 drawMap :: GameState -> Widget Name
 drawMap game
diff --git a/src/Xanthous/Generators.hs b/src/Xanthous/Generators.hs
index c266742b0590..740b39c5f082 100644
--- a/src/Xanthous/Generators.hs
+++ b/src/Xanthous/Generators.hs
@@ -1,14 +1,19 @@
 {-# LANGUAGE GADTs #-}
-
+--------------------------------------------------------------------------------
 module Xanthous.Generators where
-
-import Xanthous.Prelude
-import Data.Array.Unboxed
-import System.Random (RandomGen)
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+import           Data.Array.Unboxed
+import           System.Random (RandomGen)
 import qualified Options.Applicative as Opt
-
+--------------------------------------------------------------------------------
 import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
-import Xanthous.Data (Dimensions)
+import           Xanthous.Generators.Util
+import           Xanthous.Data (Dimensions, Position(Position))
+import           Xanthous.Data.EntityMap (EntityMap)
+import qualified Xanthous.Data.EntityMap as EntityMap
+import           Xanthous.Entities.Environment
+--------------------------------------------------------------------------------
 
 data Generator = CaveAutomata
   deriving stock (Show, Eq)
@@ -52,3 +57,14 @@ showCells arr =
       row r = foldMap (showCell . (, r)) [minX..maxX]
       rows = row <$> [minY..maxY]
   in intercalate "\n" rows
+
+cellsToWalls :: UArray (Word, Word) Bool -> EntityMap Wall
+cellsToWalls cells = foldl' maybeInsertWall mempty . assocs $ cells
+  where
+    maybeInsertWall em (pos@(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
diff --git a/src/Xanthous/Generators/Util.hs b/src/Xanthous/Generators/Util.hs
index 3f0d691b7fac..260c41ac6002 100644
--- a/src/Xanthous/Generators/Util.hs
+++ b/src/Xanthous/Generators/Util.hs
@@ -5,6 +5,7 @@ module Xanthous.Generators.Util
   , CellM
   , randInitialize
   , numAliveNeighborsM
+  , numAliveNeighbors
   , cloneMArray
   ) where
 
@@ -58,6 +59,34 @@ numAliveNeighborsM cells (x, y) = do
     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)
+  => a (i, j) Bool
+  -> (i, j)
+  -> Word
+numAliveNeighbors cells (x, y) =
+  let cellBounds = bounds cells
+  in getSum $ foldMap
+      (Sum . fromIntegral . fromEnum . boundedGet cellBounds)
+      neighborPositions
+
+  where
+    boundedGet :: ((i, j), (i, j)) -> (Int, Int) -> Bool
+    boundedGet ((minX, minY), (maxX, maxY)) (i, j)
+      | x <= minX
+        || y <= minY
+        || x >= maxX
+        || y >= maxY
+      = True
+      | otherwise =
+        let nx = fromIntegral $ fromIntegral x + i
+            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)]
+
 cloneMArray
   :: forall a a' i e m.
   ( Ix i
diff --git a/src/Xanthous/Monad.hs b/src/Xanthous/Monad.hs
index fb790d5f9cb2..acf7775ede41 100644
--- a/src/Xanthous/Monad.hs
+++ b/src/Xanthous/Monad.hs
@@ -4,6 +4,7 @@ module Xanthous.Monad
   , continue
   , halt
   , say
+  , say_
   ) where
 
 import Xanthous.Prelude
@@ -56,3 +57,6 @@ instance (Monad m, ToJSON params) => SayR (params -> AppT m ()) where
   say msgPath params = do
     msg <- message msgPath params
     messageHistory %= pushMessage msg
+
+say_ :: Monad m => [Text] -> AppT m ()
+say_ = say
diff --git a/src/Xanthous/Orphans.hs b/src/Xanthous/Orphans.hs
index 3efe1f1264c2..c84756eb1e67 100644
--- a/src/Xanthous/Orphans.hs
+++ b/src/Xanthous/Orphans.hs
@@ -2,23 +2,24 @@
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE UndecidableInstances, PatternSynonyms #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
--- |
-
+--------------------------------------------------------------------------------
 module Xanthous.Orphans
   ( ppTemplate
   ) where
-
-import Xanthous.Prelude hiding (elements)
-import Text.Mustache
-import Test.QuickCheck
-import Data.Text.Arbitrary ()
-import Text.Megaparsec (errorBundlePretty)
-import Text.Megaparsec.Pos
-import Text.Mustache.Type ( showKey )
-import Data.List.NonEmpty (NonEmpty(..))
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding (elements)
+--------------------------------------------------------------------------------
+import           Data.Aeson
+import           Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.List.NonEmpty as NonEmpty
-import Data.Aeson
-import Graphics.Vty.Attributes
+import           Data.Text.Arbitrary ()
+import           Graphics.Vty.Attributes
+import           Test.QuickCheck
+import           Text.Megaparsec (errorBundlePretty)
+import           Text.Megaparsec.Pos
+import           Text.Mustache
+import           Text.Mustache.Type ( showKey )
+--------------------------------------------------------------------------------
 
 instance forall s a.
   ( Cons s s a a
@@ -181,3 +182,4 @@ instance ToJSON Color where
 instance (Eq a, Show a, Read a, FromJSON a) => FromJSON (MaybeDefault a) where
   parseJSON Null = pure Default
   parseJSON x    = SetTo <$> parseJSON x
+