about summary refs log tree commit diff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Main.hs2
-rw-r--r--src/Xanthous/App.hs29
-rw-r--r--src/Xanthous/Data.hs87
-rw-r--r--src/Xanthous/Data/EntityMap.hs13
-rw-r--r--src/Xanthous/Entities.hs80
-rw-r--r--src/Xanthous/Entities/Arbitrary.hs19
-rw-r--r--src/Xanthous/Entities/Character.hs8
-rw-r--r--src/Xanthous/Entities/Draw/Util.hs31
-rw-r--r--src/Xanthous/Entities/Environment.hs26
-rw-r--r--src/Xanthous/Entities/RawTypes.hs2
-rw-r--r--src/Xanthous/Entities/SomeEntity.hs34
-rw-r--r--src/Xanthous/Game.hs12
-rw-r--r--src/Xanthous/Game/Draw.hs12
-rw-r--r--src/Xanthous/Generators.hs30
-rw-r--r--src/Xanthous/Generators/Util.hs29
-rw-r--r--src/Xanthous/Monad.hs4
-rw-r--r--src/Xanthous/Orphans.hs28
-rw-r--r--test/Xanthous/GameSpec.hs2
-rw-r--r--test/Xanthous/Generators/UtilSpec.hs13
-rw-r--r--xanthous.cabal10
20 files changed, 356 insertions, 115 deletions
diff --git a/src/Main.hs b/src/Main.hs
index 4d6ccfd4af..d49e082b7c 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 6cf22135a7..af6b5caf61 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 6e779a4505..e435526384 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 e3ceb6f651..401e395547 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 6851a7a5d5..bd52ae62b2 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 0000000000..9153722d9b
--- /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 5cf397e822..faa9964a38 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 0000000000..aa6c5fa4fc
--- /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 0000000000..f5301f94ad
--- /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 e82cb0c890..88087a5dab 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 029247de9b..0000000000
--- 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 dffd0a9c6a..e967098015 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 36abe16119..4d3cb15dca 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 c266742b05..740b39c5f0 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 3f0d691b7f..260c41ac60 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 fb790d5f9c..acf7775ede 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 3efe1f1264..c84756eb1e 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
+
diff --git a/test/Xanthous/GameSpec.hs b/test/Xanthous/GameSpec.hs
index 9319399ac2..dbd1677f7e 100644
--- a/test/Xanthous/GameSpec.hs
+++ b/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
diff --git a/test/Xanthous/Generators/UtilSpec.hs b/test/Xanthous/Generators/UtilSpec.hs
index a1c2f79d60..c82c385987 100644
--- a/test/Xanthous/Generators/UtilSpec.hs
+++ b/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
diff --git a/xanthous.cabal b/xanthous.cabal
index 36a5608805..c3307864fa 100644
--- a/xanthous.cabal
+++ b/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
generated by cgit-pink 1.4.1 (git 2.44.0) at 2024-05-27T14·24+0000