From 9ebdc6fbb446fea5e505172a6b3dd459beaf3552 Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Mon, 9 Sep 2019 20:54:33 -0400 Subject: 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 | 2 +- src/Xanthous/App.hs | 29 +++++++++--- src/Xanthous/Data.hs | 87 +++++++++++++++++++++++++----------- src/Xanthous/Data/EntityMap.hs | 13 +++++- src/Xanthous/Entities.hs | 80 +++++++++++++++++++++++++++++---- src/Xanthous/Entities/Arbitrary.hs | 19 ++++++++ src/Xanthous/Entities/Character.hs | 8 ++-- src/Xanthous/Entities/Draw/Util.hs | 31 +++++++++++++ src/Xanthous/Entities/Environment.hs | 26 +++++++++++ src/Xanthous/Entities/RawTypes.hs | 2 +- src/Xanthous/Entities/SomeEntity.hs | 34 -------------- src/Xanthous/Game.hs | 12 +++-- src/Xanthous/Game/Draw.hs | 12 +++-- src/Xanthous/Generators.hs | 30 ++++++++++--- src/Xanthous/Generators/Util.hs | 29 ++++++++++++ src/Xanthous/Monad.hs | 4 ++ src/Xanthous/Orphans.hs | 28 ++++++------ test/Xanthous/GameSpec.hs | 2 +- test/Xanthous/Generators/UtilSpec.hs | 13 +++++- xanthous.cabal | 10 +++-- 20 files changed, 356 insertions(+), 115 deletions(-) create mode 100644 src/Xanthous/Entities/Arbitrary.hs create mode 100644 src/Xanthous/Entities/Draw/Util.hs create mode 100644 src/Xanthous/Entities/Environment.hs delete mode 100644 src/Xanthous/Entities/SomeEntity.hs 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 -- cgit 1.4.1