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.

1 files changed, 60 insertions, 27 deletions

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