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.

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)

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

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           Brick (Location(Location), Edges(..))
-import           Graphics.Vty.Attributes
-import qualified Graphics.Vty.Image as Vty
-import           Data.Aeson
 --------------------------------------------------------------------------------
 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
+data Neighbors a = Neighbors
-  { _char :: Char
+  { _topLeft
-  , _style :: Attr
+  , _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 FromJSON EntityChar where
+instance Applicative Neighbors where
-  parseJSON (String (chr :< Empty)) = pure $ EntityChar chr defAttr
+  pure α = Neighbors
-  parseJSON (Object o) = do
+    { _topLeft     = α
-    (EntityChar _char _) <- o .: "char"
+    , _top         = α
-    _style <- o .:? "style" >>= \case
+    , _topRight    = α
-      Just styleO -> do
+    , _left        = α
-        let attrStyle = Default -- TODO
+    , _right       = α
-            attrURL = Default
+    , _bottomLeft  = α
-        attrForeColor <- styleO .:? "foreground" .!= Default
+    , _bottom      = α
-        attrBackColor <- styleO .:? "background" .!= Default
+    , _bottomRight = α
-        pure Attr {..}
+    }
-      Nothing -> pure defAttr
+  nf <*> nx = Neighbors
-    pure EntityChar {..}
+    { _topLeft     = nf ^. topLeft     $ nx ^. topLeft
-  parseJSON _ = fail "Invalid type, expected string or object"
+    , _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
+    }
 
-instance Draw EntityChar where
+edges :: Neighbors a -> Edges a
-  draw EntityChar{..} = raw $ Vty.string _style [_char]
+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
+  }
+
+neighborPositions :: Position -> Neighbors Position
+neighborPositions pos = (`move` pos) <$> neighborDirections

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

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
 
+  , 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)
+
+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]
 
 --------------------------------------------------------------------------------
-
-class (Show a, Eq a, Draw a) => Entity a
-instance (Show a, Eq a, Draw a) => Entity a

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
+    ]

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
+data Character = Character
-  Character :: Character
   deriving stock (Show, Eq, Ord, Generic)
   deriving anyclass (CoArbitrary, Function)
   deriving Draw via (DrawCharacter "@" Character)

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

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

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

src/Xanthous/Entities/SomeEntity.hs

@@ -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

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

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

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 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

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

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

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.Aeson
-import Data.Text.Arbitrary ()
-import Text.Megaparsec (errorBundlePretty)
-import Text.Megaparsec.Pos
-import Text.Mustache.Type ( showKey )
 import           Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.List.NonEmpty as NonEmpty
-import Data.Aeson
+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
+

test/Xanthous/GameSpec.hs

@@ -5,7 +5,7 @@ import Xanthous.Game
 import Control.Lens.Properties
 import Xanthous.Data (move, Direction(Down))
 import Xanthous.Data.EntityMap (atPosition)
-import Xanthous.Entities.SomeEntity
+import Xanthous.Entities (SomeEntity(SomeEntity))
 
 main :: IO ()
 main = defaultMain test

test/Xanthous/Generators/UtilSpec.hs

@@ -41,7 +41,7 @@ test = testGroup "Xanthous.Generators.Util"
                 $ randInitialize dims aliveChance
         in bounds res === ((0, 0), (dims ^. width, dims ^. height))
     ]
-  , testGroup "numAliveNeighbors"
+  , testGroup "numAliveNeighborsM"
     [ testProperty "maxes out at 8" $ \(GenArray (arr :: Array (Word, Word) Bool)) loc ->
         let
           act :: forall s. ST s Word
@@ -51,6 +51,17 @@ test = testGroup "Xanthous.Generators.Util"
           res = runST act
         in counterexample (show res) $ between 0 8 res
     ]
+  , testGroup "numAliveNeighbors"
+    [ testProperty "is equivalient to runST . numAliveNeighborsM . thaw" $
+      \(GenArray (arr :: Array (Word, Word) Bool)) loc ->
+        let
+          act :: forall s. ST s Word
+          act = do
+            mArr <- thaw @_ @_ @_ @(STUArray s) arr
+            numAliveNeighborsM mArr loc
+          res = runST act
+        in numAliveNeighbors arr loc === res
+    ]
   , testGroup "cloneMArray"
       [ testCase "clones the array" $ runST $
           let

xanthous.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: e01963f3bf85136fe2b6993775d225999898d4c478efef6f917056f726d72e33
+-- hash: 3fbeb53b2706e3f0186fa3c80619a166f64eb52cf045006ac993074fa7f3e9d1
 
 name:           xanthous
 version:        0.1.0.0
@@ -35,11 +35,13 @@ library
       Xanthous.Data
       Xanthous.Data.EntityMap
       Xanthous.Entities
+      Xanthous.Entities.Arbitrary
       Xanthous.Entities.Character
       Xanthous.Entities.Creature
+      Xanthous.Entities.Draw.Util
+      Xanthous.Entities.Environment
       Xanthous.Entities.Raws
       Xanthous.Entities.RawTypes
-      Xanthous.Entities.SomeEntity
       Xanthous.Game
       Xanthous.Game.Draw
       Xanthous.Generators
@@ -100,11 +102,13 @@ executable xanthous
       Xanthous.Data
       Xanthous.Data.EntityMap
       Xanthous.Entities
+      Xanthous.Entities.Arbitrary
       Xanthous.Entities.Character
       Xanthous.Entities.Creature
+      Xanthous.Entities.Draw.Util
+      Xanthous.Entities.Environment
       Xanthous.Entities.Raws
       Xanthous.Entities.RawTypes
-      Xanthous.Entities.SomeEntity
       Xanthous.Game
       Xanthous.Game.Draw
       Xanthous.Generators