diff --git a/src/Main.hs b/src/Main.hs index 4d6ccfd4a..d49e082b7 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 6cf22135a..af6b5caf6 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 6e779a450..e43552638 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 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 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 + } -instance Draw EntityChar where - draw EntityChar{..} = raw $ Vty.string _style [_char] +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 + } + +neighborPositions :: Position -> Neighbors Position +neighborPositions pos = (`move` pos) <$> neighborDirections diff --git a/src/Xanthous/Data/EntityMap.hs b/src/Xanthous/Data/EntityMap.hs index e3ceb6f65..401e39554 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 6851a7a5d..bd52ae62b 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) + +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 diff --git a/src/Xanthous/Entities/Arbitrary.hs b/src/Xanthous/Entities/Arbitrary.hs new file mode 100644 index 000000000..9153722d9 --- /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 5cf397e82..faa9964a3 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 000000000..aa6c5fa4f --- /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 000000000..f5301f94a --- /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 e82cb0c89..88087a5da 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 029247de9..000000000 --- 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 dffd0a9c6..e96709801 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 36abe1611..4d3cb15dc 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 c266742b0..740b39c5f 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 3f0d691b7..260c41ac6 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 fb790d5f9..acf7775ed 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 3efe1f126..c84756eb1 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 9319399ac..dbd1677f7 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 a1c2f79d6..c82c38598 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 36a560880..c3307864f 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