Use menus for combat and picking up items

Refactor a bunch of stuff around to allow for polymorphically surfacing
an EntityChar for all entities, and use this to write a generic
`entityMenu` function, which generates a menu from the chars of a list
of entities - and use that to fully implement (removing `undefined`)
menus for both attacking and picking things up when there are multiple
entities on the relevant tile.
This commit is contained in:
Griffin Smith 2019-11-29 22:59:15 -05:00
parent 7d8ce026a2
commit 8a1235c3dc
26 changed files with 232 additions and 212 deletions

View file

@ -25,6 +25,7 @@ dependencies:
- brick
- checkers
- classy-prelude
- comonad
- constraints
- containers
- data-default

View file

@ -24,8 +24,7 @@ import Xanthous.Entities.Creature
import Xanthous.Entities.Character (Character)
import qualified Xanthous.Entities.Character as Character
import qualified Xanthous.Entities.RawTypes as Raw
import Xanthous.Entities (Entity(..), Brain(..), brainVia)
import Xanthous.Game.State (entities, GameState, entityIs)
import Xanthous.Game.State
import Xanthous.Game.Lenses
( Collision(..), entityCollision, collisionAt
, character, characterPosition
@ -99,3 +98,4 @@ instance Brain Creature where step = brainVia GormlakBrain
instance Entity Creature where
blocksVision _ = False
description = view $ Creature.creatureType . Raw.description
entityChar = view $ Creature.creatureType . char

View file

@ -1,7 +1,7 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Xanthous.AI.Gormlak where
import Xanthous.Entities
import Xanthous.Game.State
import Xanthous.Entities.Creature
instance Entity Creature

View file

@ -30,6 +30,7 @@ import Xanthous.Data
import Xanthous.Data.EntityMap (EntityMap)
import qualified Xanthous.Data.EntityMap as EntityMap
import Xanthous.Game
import Xanthous.Game.State
import Xanthous.Game.Draw (drawGame)
import Xanthous.Game.Prompt
import Xanthous.Monad
@ -38,8 +39,7 @@ import qualified Xanthous.Messages as Messages
import Xanthous.Util.Inflection (toSentence)
--------------------------------------------------------------------------------
import qualified Xanthous.Entities.Character as Character
import Xanthous.Entities.Character
import Xanthous.Entities
import Xanthous.Entities.Character hiding (pickUpItem)
import Xanthous.Entities.Item (Item)
import qualified Xanthous.Entities.Item as Item
import Xanthous.Entities.Creature (Creature)
@ -138,16 +138,19 @@ handleCommand (Move dir) = do
handleCommand PickUp = do
pos <- use characterPosition
items <- uses entities $ entitiesAtPositionWithType @Item pos
case items of
[] -> say_ ["items", "nothingToPickUp"]
[(itemID, item)] -> do
uses entities (entitiesAtPositionWithType @Item pos) >>= \case
[] -> say_ ["pickUp", "nothingToPickUp"]
[item] -> pickUpItem item
items ->
menu_ ["pickUp", "menu"] Cancellable (entityMenu_ items)
$ \(MenuResult item) -> pickUpItem item
continue
where
pickUpItem (itemID, item) = do
character %= Character.pickUpItem item
entities . at itemID .= Nothing
say ["items", "pickUp"] $ object [ "item" A..= item ]
say ["pickUp", "pickUp"] $ object [ "item" A..= item ]
stepGameBy 100 -- TODO
_ -> undefined
continue
handleCommand PreviousMessage = do
messageHistory %= previousMessage
@ -188,6 +191,7 @@ handleCommand Eat = do
let foodMenuItem idx (item, edibleItem)
= ( item ^. Item.itemType . char . char
, MenuOption (description item) (idx, item, edibleItem))
-- TODO refactor to use entityMenu_
menuItems = mkMenuItems $ imap foodMenuItem food
in menu_ ["eat", "menuPrompt"] Cancellable menuItems
$ \(MenuResult (idx, item, edibleItem)) -> do
@ -265,6 +269,8 @@ handlePromptEvent
>> continue
handlePromptEvent _ (Prompt _ SPointOnMap _ _ _) _ = continue
handlePromptEvent _ _ _ = continue
clearPrompt :: AppM (Next GameState)
clearPrompt = promptState .= NoPrompt >> continue
@ -330,7 +336,6 @@ menu_ :: forall (a :: Type).
-> AppM ()
menu_ msgPath = menu msgPath $ object []
--------------------------------------------------------------------------------
entitiesAtPositionWithType
@ -374,7 +379,9 @@ attackAt pos =
uses entities (entitiesAtPositionWithType @Creature pos) >>= \case
Empty -> say_ ["combat", "nothingToAttack"]
(creature :< Empty) -> attackCreature creature
creatures -> undefined
creatures ->
menu_ ["combat", "menu"] Cancellable (entityMenu_ creatures)
$ \(MenuResult creature) -> attackCreature creature
where
attackCreature (creatureID, creature) = do
charDamage <- use $ character . characterDamage
@ -388,3 +395,21 @@ attackAt pos =
say ["combat", "hit"] msgParams
entities . ix creatureID . positioned .= SomeEntity creature'
stepGame -- TODO
entityMenu_
:: (Comonad w, Entity entity)
=> [w entity]
-> Map Char (MenuOption (w entity))
entityMenu_ = mkMenuItems @[_] . map entityMenuItem
where
entityMenuItem wentity
= let entity = extract wentity
in (entityMenuChar entity, MenuOption (description entity) wentity)
entityMenuChar entity
= let ec = entityChar entity ^. char
in if ec `elem` (['a'..'z'] ++ ['A'..'Z'])
then ec
else 'a'
entityMenu :: Entity entity => [entity] -> Map Char (MenuOption entity)
entityMenu = map (map runIdentity) . entityMenu_ . fmap Identity

View file

@ -0,0 +1,56 @@
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
module Xanthous.Data.EntityChar
( EntityChar(..)
, HasChar(..)
, HasStyle(..)
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude hiding ((.=))
--------------------------------------------------------------------------------
import qualified Graphics.Vty.Attributes as Vty
import Test.QuickCheck
import Data.Aeson
--------------------------------------------------------------------------------
import Xanthous.Orphans ()
import Xanthous.Util.QuickCheck (GenericArbitrary(..))
--------------------------------------------------------------------------------
class HasChar s a | s -> a where
char :: Lens' s a
{-# MINIMAL char #-}
data EntityChar = EntityChar
{ _char :: Char
, _style :: Vty.Attr
}
deriving stock (Show, Eq, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving Arbitrary via GenericArbitrary EntityChar
makeFieldsNoPrefix ''EntityChar
instance FromJSON EntityChar where
parseJSON (String (chr :< Empty)) = pure $ EntityChar chr Vty.defAttr
parseJSON (Object o) = do
(EntityChar _char _) <- o .: "char"
_style <- o .:? "style" .!= Vty.defAttr
pure EntityChar {..}
parseJSON _ = fail "Invalid type, expected string or object"
instance ToJSON EntityChar where
toJSON (EntityChar chr styl)
| styl == Vty.defAttr = String $ chr <| Empty
| otherwise = object
[ "char" .= chr
, "style" .= styl
]
instance IsString EntityChar where
fromString [ch] = EntityChar ch Vty.defAttr
fromString _ = error "Entity char must only be a single character"

View file

@ -12,7 +12,7 @@ import Xanthous.Prelude hiding (lines)
import Xanthous.Util (takeWhileInclusive)
import Xanthous.Data
import Xanthous.Data.EntityMap
import Xanthous.Entities
import Xanthous.Game.State
import Xanthous.Util.Graphics (circle, line)
--------------------------------------------------------------------------------

View file

@ -1,146 +0,0 @@
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
module Xanthous.Entities
( Draw(..)
, DrawCharacter(..)
, DrawStyledCharacter(..)
, DrawRawChar(..)
, DrawRawCharPriority(..)
, Entity(..)
, SomeEntity(..)
, downcastEntity
, entityIs
, _SomeEntity
, Color(..)
, KnownColor(..)
, EntityChar(..)
, HasChar(..)
, HasStyle(..)
, Brain(..)
, Brainless(..)
, brainVia
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude hiding ((.=))
--------------------------------------------------------------------------------
import Brick
import qualified Graphics.Vty.Attributes as Vty
import qualified Graphics.Vty.Image as Vty
import Data.Aeson
import Data.Typeable (Proxy(..))
import Data.Generics.Product.Fields
import Test.QuickCheck
import Test.QuickCheck.Arbitrary.Generic
--------------------------------------------------------------------------------
import Xanthous.Orphans ()
import Xanthous.Game.State
--------------------------------------------------------------------------------
newtype DrawCharacter (char :: Symbol) (a :: Type) where
DrawCharacter :: a -> DrawCharacter char a
instance KnownSymbol char => Draw (DrawCharacter char a) where
draw _ = str $ symbolVal @char Proxy
--------------------------------------------------------------------------------
data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White
class KnownColor (color :: Color) where
colorVal :: forall proxy. proxy color -> Vty.Color
instance KnownColor 'Black where colorVal _ = Vty.black
instance KnownColor 'Red where colorVal _ = Vty.red
instance KnownColor 'Green where colorVal _ = Vty.green
instance KnownColor 'Yellow where colorVal _ = Vty.yellow
instance KnownColor 'Blue where colorVal _ = Vty.blue
instance KnownColor 'Magenta where colorVal _ = Vty.magenta
instance KnownColor 'Cyan where colorVal _ = Vty.cyan
instance KnownColor 'White where colorVal _ = Vty.white
newtype DrawStyledCharacter (fg :: Color) (bg :: Color) (char :: Symbol) (a :: Type) where
DrawStyledCharacter :: a -> DrawStyledCharacter fg bg char a
instance
( KnownColor fg
, KnownColor bg
, KnownSymbol char
)
=> Draw (DrawStyledCharacter fg bg char a) where
draw _ = raw $ Vty.string attr $ symbolVal @char Proxy
where attr = Vty.Attr
{ Vty.attrStyle = Vty.Default
, Vty.attrForeColor = Vty.SetTo $ colorVal @fg Proxy
, Vty.attrBackColor = Vty.SetTo $ colorVal @bg Proxy
, Vty.attrURL = Vty.Default
}
--------------------------------------------------------------------------------
class HasChar s a | s -> a where
char :: Lens' s a
{-# MINIMAL char #-}
newtype DrawRawChar (rawField :: Symbol) (a :: Type) = DrawRawChar a
instance
forall rawField a raw.
( HasField rawField a a raw raw
, HasChar raw EntityChar
) => Draw (DrawRawChar rawField a) where
draw (DrawRawChar e) = draw $ e ^. field @rawField . char
newtype DrawRawCharPriority
(rawField :: Symbol)
(priority :: Nat)
(a :: Type)
= DrawRawCharPriority a
instance
forall rawField priority a raw.
( HasField rawField a a raw raw
, KnownNat priority
, HasChar raw EntityChar
) => Draw (DrawRawCharPriority rawField priority a) where
draw (DrawRawCharPriority e) = draw $ e ^. field @rawField . char
drawPriority = const . fromIntegral $ natVal @priority Proxy
--------------------------------------------------------------------------------
data EntityChar = EntityChar
{ _char :: Char
, _style :: Vty.Attr
}
deriving stock (Show, Eq, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
makeFieldsNoPrefix ''EntityChar
instance Arbitrary EntityChar where
arbitrary = genericArbitrary
instance FromJSON EntityChar where
parseJSON (String (chr :< Empty)) = pure $ EntityChar chr Vty.defAttr
parseJSON (Object o) = do
(EntityChar _char _) <- o .: "char"
_style <- o .:? "style" .!= Vty.defAttr
pure EntityChar {..}
parseJSON _ = fail "Invalid type, expected string or object"
instance ToJSON EntityChar where
toJSON (EntityChar chr styl)
| styl == Vty.defAttr = String $ chr <| Empty
| otherwise = object
[ "char" .= chr
, "style" .= styl
]
instance Draw EntityChar where
draw EntityChar{..} = raw $ Vty.string _style [_char]

View file

@ -27,7 +27,7 @@ import Data.Aeson.Generic.DerivingVia
import Data.Aeson (ToJSON, FromJSON)
import Data.Coerce (coerce)
--------------------------------------------------------------------------------
import Xanthous.Entities
import Xanthous.Game.State
import Xanthous.Entities.Item
import Xanthous.Data (TicksPerTile, Hitpoints, Per, Ticks, (|*|), positioned)
--------------------------------------------------------------------------------
@ -68,6 +68,7 @@ instance Brain Character where
instance Entity Character where
blocksVision _ = False
description _ = "yourself"
entityChar _ = "@"
instance Arbitrary Character where
arbitrary = genericArbitrary

View file

@ -35,7 +35,7 @@ import Data.Aeson.Generic.DerivingVia
import Data.Aeson (ToJSON, FromJSON)
--------------------------------------------------------------------------------
import Xanthous.Entities.RawTypes hiding (Creature, description)
import Xanthous.Entities (Draw(..), DrawRawCharPriority(..))
import Xanthous.Game.State
import Xanthous.Data
--------------------------------------------------------------------------------

View file

@ -9,7 +9,6 @@ import Test.QuickCheck
import qualified Test.QuickCheck.Gen as Gen
import Data.Aeson
--------------------------------------------------------------------------------
import Xanthous.Entities (Entity(..), SomeEntity(..))
import Xanthous.Entities.Character
import Xanthous.Entities.Item
import Xanthous.Entities.Creature
@ -46,6 +45,7 @@ deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameState
instance Entity SomeEntity where
blocksVision (SomeEntity ent) = blocksVision ent
description (SomeEntity ent) = description ent
entityChar (SomeEntity ent) = entityChar ent
instance Function SomeEntity where
function = functionJSON

View file

@ -14,17 +14,9 @@ import Brick.Widgets.Border.Style (unicode)
import Brick.Types (Edges(..))
import Data.Aeson
--------------------------------------------------------------------------------
import Xanthous.Entities
( Draw(..)
, entityIs
, Entity(..)
, SomeEntity
, Brain(..)
, Brainless(..)
, brainVia
)
import Xanthous.Entities.Draw.Util
import Xanthous.Data
import Xanthous.Game.State
--------------------------------------------------------------------------------
data Wall = Wall
@ -45,6 +37,7 @@ instance Brain Wall where step = brainVia Brainless
instance Entity Wall where
blocksVision _ = True
description _ = "a wall"
entityChar _ = ""
instance Arbitrary Wall where
arbitrary = pure Wall
@ -90,3 +83,4 @@ instance Brain Door where step = brainVia Brainless
instance Entity Door where
blocksVision = not . view open
description _ = "a door"
entityChar _ = "d"

View file

@ -15,14 +15,7 @@ import Data.Aeson.Generic.DerivingVia
--------------------------------------------------------------------------------
import Xanthous.Entities.RawTypes hiding (Item, description, isEdible)
import qualified Xanthous.Entities.RawTypes as Raw
import Xanthous.Entities
( Draw(..)
, Entity(..)
, DrawRawChar(..)
, Brain(..)
, Brainless(..)
, brainVia
)
import Xanthous.Game.State
--------------------------------------------------------------------------------
data Item = Item
@ -47,6 +40,7 @@ instance Arbitrary Item where
instance Entity Item where
blocksVision _ = False
description = view $ itemType . Raw.description
entityChar = view $ itemType . Raw.char
newWithType :: ItemType -> Item
newWithType = Item

View file

@ -10,6 +10,7 @@ module Xanthous.Entities.RawTypes
, _Creature
-- * Lens classes
, HasChar(..)
, HasName(..)
, HasDescription(..)
, HasLongDescription(..)
@ -27,9 +28,9 @@ import Test.QuickCheck.Arbitrary.Generic
import Data.Aeson.Generic.DerivingVia
import Data.Aeson (ToJSON, FromJSON)
--------------------------------------------------------------------------------
import Xanthous.Entities (EntityChar, HasChar(..))
import Xanthous.Messages (Message(..))
import Xanthous.Data (TicksPerTile, Hitpoints)
import Xanthous.Data.EntityChar
--------------------------------------------------------------------------------
data CreatureType = CreatureType
{ _name :: !Text

View file

@ -14,7 +14,7 @@ import Xanthous.Prelude
import System.FilePath.Posix
--------------------------------------------------------------------------------
import Xanthous.Entities.RawTypes
import Xanthous.Entities
import Xanthous.Game.State
import qualified Xanthous.Entities.Creature as Creature
import qualified Xanthous.Entities.Item as Item
import Xanthous.AI.Gormlak ()

View file

@ -18,11 +18,11 @@ import qualified Xanthous.Data.EntityMap as EntityMap
instance Arbitrary GameState where
arbitrary = do
char <- arbitrary @Character
chr <- arbitrary @Character
charPos <- arbitrary
_messageHistory <- arbitrary
(_characterEntityID, _entities) <- arbitrary <&>
EntityMap.insertAtReturningID charPos (SomeEntity char)
EntityMap.insertAtReturningID charPos (SomeEntity chr)
_revealedPositions <- fmap setFromList . sublistOf $ EntityMap.positions _entities
_randomGen <- mkStdGen <$> arbitrary
let _promptState = NoPrompt -- TODO

View file

@ -12,7 +12,7 @@ import Brick.Widgets.Edit
import Xanthous.Data
import Xanthous.Data.EntityMap (EntityMap, atPosition)
import qualified Xanthous.Data.EntityMap as EntityMap
import Xanthous.Entities
import Xanthous.Game.State
import Xanthous.Entities.Character
import Xanthous.Game
( GameState(..)

View file

@ -37,11 +37,11 @@ getInitialState = initialStateFromSeed <$> getRandom
initialStateFromSeed :: Int -> GameState
initialStateFromSeed seed =
let _randomGen = mkStdGen seed
char = mkCharacter
chr = mkCharacter
(_characterEntityID, _entities)
= EntityMap.insertAtReturningID
(Position 0 0)
(SomeEntity char)
(SomeEntity chr)
mempty
_messageHistory = mempty
_revealedPositions = mempty
@ -56,10 +56,10 @@ positionedCharacter :: Lens' GameState (Positioned Character)
positionedCharacter = lens getPositionedCharacter setPositionedCharacter
where
setPositionedCharacter :: GameState -> Positioned Character -> GameState
setPositionedCharacter game char
setPositionedCharacter game chr
= game
& entities . at (game ^. characterEntityID)
?~ fmap SomeEntity char
?~ fmap SomeEntity chr
getPositionedCharacter :: GameState -> Positioned Character
getPositionedCharacter game

View file

@ -1,6 +1,8 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DeriveFunctor #-}
--------------------------------------------------------------------------------
module Xanthous.Game.Prompt
( PromptType(..)
@ -25,6 +27,7 @@ import Xanthous.Prelude
import Brick.Widgets.Edit (Editor, editorText, getEditContents)
import Test.QuickCheck
import Test.QuickCheck.Arbitrary.Generic
import Control.Comonad
--------------------------------------------------------------------------------
import Xanthous.Util (smallestNotIn)
import Xanthous.Data (Direction, Position)
@ -159,9 +162,13 @@ instance CoArbitrary (PromptState ('Menu a)) where
deriving stock instance Show (PromptState pt)
data MenuOption a = MenuOption Text a
deriving stock (Eq, Generic)
deriving stock (Eq, Generic, Functor)
deriving anyclass (NFData, CoArbitrary, Function)
instance Comonad MenuOption where
extract (MenuOption _ x) = x
extend cok mo@(MenuOption text _) = MenuOption text (cok mo)
mkMenuItems :: (MonoFoldable f, Element f ~ (Char, MenuOption a))
=> f
-> Map Char (MenuOption a)

View file

@ -1,3 +1,4 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE GADTs #-}
@ -36,6 +37,13 @@ module Xanthous.Game.State
, downcastEntity
, _SomeEntity
, entityIs
, DrawRawChar(..)
, DrawRawCharPriority(..)
, DrawCharacter(..)
, DrawStyledCharacter(..)
-- ** Field classes
, HasChar(..)
, HasStyle(..)
-- * Debug State
, DebugState(..)
@ -55,13 +63,18 @@ import Test.QuickCheck.Arbitrary.Generic
import Control.Monad.State.Class
import Control.Monad.State
import Control.Monad.Random.Class
import Brick (EventM, Widget)
import Brick (EventM, Widget, raw, str)
import Data.Aeson (ToJSON(..), FromJSON(..), Value(Null))
import qualified Data.Aeson as JSON
import Data.Aeson.Generic.DerivingVia
import Data.Generics.Product.Fields
import qualified Graphics.Vty.Attributes as Vty
import qualified Graphics.Vty.Image as Vty
import Control.Comonad
--------------------------------------------------------------------------------
import Xanthous.Data.EntityMap (EntityMap, EntityID)
import Xanthous.Data
import Xanthous.Data.EntityMap (EntityMap, EntityID)
import Xanthous.Data.EntityChar
import Xanthous.Orphans ()
import Xanthous.Game.Prompt
import Xanthous.Resource
@ -181,6 +194,73 @@ instance Draw a => Draw (Positioned a) where
drawWithNeighbors ns (Positioned _ a) = drawWithNeighbors ns a
draw (Positioned _ a) = draw a
newtype DrawCharacter (char :: Symbol) (a :: Type) where
DrawCharacter :: a -> DrawCharacter char a
instance KnownSymbol char => Draw (DrawCharacter char a) where
draw _ = str $ symbolVal @char Proxy
data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White
class KnownColor (color :: Color) where
colorVal :: forall proxy. proxy color -> Vty.Color
instance KnownColor 'Black where colorVal _ = Vty.black
instance KnownColor 'Red where colorVal _ = Vty.red
instance KnownColor 'Green where colorVal _ = Vty.green
instance KnownColor 'Yellow where colorVal _ = Vty.yellow
instance KnownColor 'Blue where colorVal _ = Vty.blue
instance KnownColor 'Magenta where colorVal _ = Vty.magenta
instance KnownColor 'Cyan where colorVal _ = Vty.cyan
instance KnownColor 'White where colorVal _ = Vty.white
newtype DrawStyledCharacter (fg :: Color) (bg :: Color) (char :: Symbol) (a :: Type) where
DrawStyledCharacter :: a -> DrawStyledCharacter fg bg char a
instance
( KnownColor fg
, KnownColor bg
, KnownSymbol char
)
=> Draw (DrawStyledCharacter fg bg char a) where
draw _ = raw $ Vty.string attr $ symbolVal @char Proxy
where attr = Vty.Attr
{ Vty.attrStyle = Vty.Default
, Vty.attrForeColor = Vty.SetTo $ colorVal @fg Proxy
, Vty.attrBackColor = Vty.SetTo $ colorVal @bg Proxy
, Vty.attrURL = Vty.Default
}
instance Draw EntityChar where
draw EntityChar{..} = raw $ Vty.string _style [_char]
--------------------------------------------------------------------------------
newtype DrawRawChar (rawField :: Symbol) (a :: Type) = DrawRawChar a
instance
forall rawField a raw.
( HasField rawField a a raw raw
, HasChar raw EntityChar
) => Draw (DrawRawChar rawField a) where
draw (DrawRawChar e) = draw $ e ^. field @rawField . char
newtype DrawRawCharPriority
(rawField :: Symbol)
(priority :: Nat)
(a :: Type)
= DrawRawCharPriority a
instance
forall rawField priority a raw.
( HasField rawField a a raw raw
, KnownNat priority
, HasChar raw EntityChar
) => Draw (DrawRawCharPriority rawField priority a) where
draw (DrawRawCharPriority e) = draw $ e ^. field @rawField . char
drawPriority = const . fromIntegral $ natVal @priority Proxy
--------------------------------------------------------------------------------
class Brain a where
@ -208,6 +288,7 @@ class ( Show a, Eq a, NFData a
) => Entity a where
blocksVision :: a -> Bool
description :: a -> Text
entityChar :: a -> EntityChar
data SomeEntity where
SomeEntity :: forall a. (Entity a, Typeable a) => a -> SomeEntity

View file

@ -21,7 +21,6 @@ import Data.Text.Zipper.Generic (GenericTextZipper)
import Brick.Widgets.Core (getName)
import System.Random (StdGen)
import Test.QuickCheck
import Test.QuickCheck.Arbitrary.Generic
import Text.Megaparsec (errorBundlePretty)
import Text.Megaparsec.Pos
import Text.Mustache

View file

@ -1,3 +1,4 @@
--------------------------------------------------------------------------------
module Xanthous.Prelude
( module ClassyPrelude
, Type
@ -5,11 +6,14 @@ module Xanthous.Prelude
, module GHC.TypeLits
, module Control.Lens
, module Data.Void
, module Control.Comonad
) where
--------------------------------------------------------------------------------
import ClassyPrelude hiding
(return, (<|), unsnoc, uncons, cons, snoc, index, (<.>), Index, say)
import Data.Kind
import GHC.TypeLits hiding (Text)
import Control.Lens
import Data.Void
import Control.Comonad
--------------------------------------------------------------------------------

View file

@ -12,7 +12,8 @@ save:
entities:
description: You see here {{entityDescriptions}}
items:
pickUp:
menu: What would you like to pick up?
pickUp: You pick up the {{item.itemType.name}}
nothingToPickUp: "There's nothing here to pick up"
@ -31,6 +32,7 @@ character:
combat:
nothingToAttack: There's nothing to attack there.
menu: Which creature would you like to attack?
hit:
- You hit the {{creature.creatureType.name}}.
- You attack the {{creature.creatureType.name}}.

View file

@ -1,23 +1,23 @@
import Test.Prelude
import qualified Xanthous.Data.EntityCharSpec
import qualified Xanthous.Data.EntityMapSpec
import qualified Xanthous.DataSpec
import qualified Xanthous.EntitiesSpec
import qualified Xanthous.Entities.RawsSpec
import qualified Xanthous.GameSpec
import qualified Xanthous.Generators.UtilSpec
import qualified Xanthous.MessageSpec
import qualified Xanthous.OrphansSpec
import qualified Xanthous.UtilSpec
import qualified Xanthous.Util.GraphicsSpec
import qualified Xanthous.Util.InflectionSpec
import qualified Xanthous.UtilSpec
main :: IO ()
main = defaultMain test
test :: TestTree
test = testGroup "Xanthous"
[ Xanthous.Data.EntityMapSpec.test
, Xanthous.EntitiesSpec.test
[ Xanthous.Data.EntityCharSpec.test
, Xanthous.Data.EntityMapSpec.test
, Xanthous.Entities.RawsSpec.test
, Xanthous.GameSpec.test
, Xanthous.Generators.UtilSpec.test

View file

@ -1,20 +1,18 @@
--------------------------------------------------------------------------------
module Xanthous.EntitiesSpec where
module Xanthous.Data.EntityCharSpec where
--------------------------------------------------------------------------------
import Test.Prelude
--------------------------------------------------------------------------------
import qualified Data.Aeson as JSON
--------------------------------------------------------------------------------
import Xanthous.Entities
import Xanthous.Data.EntityChar
--------------------------------------------------------------------------------
main :: IO ()
main = defaultMain test
test :: TestTree
test = testGroup "Xanthous.Entities"
[ testGroup "EntityChar"
[ testProperty "JSON round-trip" $ \(ec :: EntityChar) ->
JSON.decode (JSON.encode ec) === Just ec
]
test = testGroup "Xanthous.Data.EntityChar"
[ testProperty "JSON round-trip" $ \(ec :: EntityChar) ->
JSON.decode (JSON.encode ec) === Just ec
]

View file

@ -2,10 +2,10 @@ module Xanthous.GameSpec where
import Test.Prelude hiding (Down)
import Xanthous.Game
import Xanthous.Game.State
import Control.Lens.Properties
import Xanthous.Data (move, Direction(Down))
import Xanthous.Data.EntityMap (atPosition)
import Xanthous.Entities (SomeEntity(SomeEntity))
main :: IO ()
main = defaultMain test

View file

@ -4,7 +4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
-- hash: 0ec32d45d89e30640d8d59137c5eaa80e5eed7eb31cb553d9b251db94ed1ba36
-- hash: 2f93900ad18d56709eb363a7f8dd251a9474dd7092b1aef956389f32c036a121
name: xanthous
version: 0.1.0.0
@ -34,9 +34,9 @@ library
Xanthous.App
Xanthous.Command
Xanthous.Data
Xanthous.Data.EntityChar
Xanthous.Data.EntityMap
Xanthous.Data.EntityMap.Graphics
Xanthous.Entities
Xanthous.Entities.Character
Xanthous.Entities.Creature
Xanthous.Entities.Draw.Util
@ -81,6 +81,7 @@ library
, brick
, checkers
, classy-prelude
, comonad
, constraints
, containers
, data-default
@ -120,9 +121,9 @@ executable xanthous
Xanthous.App
Xanthous.Command
Xanthous.Data
Xanthous.Data.EntityChar
Xanthous.Data.EntityMap
Xanthous.Data.EntityMap.Graphics
Xanthous.Entities
Xanthous.Entities.Character
Xanthous.Entities.Creature
Xanthous.Entities.Draw.Util
@ -166,6 +167,7 @@ executable xanthous
, brick
, checkers
, classy-prelude
, comonad
, constraints
, containers
, data-default
@ -203,10 +205,10 @@ test-suite test
main-is: Spec.hs
other-modules:
Test.Prelude
Xanthous.Data.EntityCharSpec
Xanthous.Data.EntityMapSpec
Xanthous.DataSpec
Xanthous.Entities.RawsSpec
Xanthous.EntitiesSpec
Xanthous.GameSpec
Xanthous.Generators.UtilSpec
Xanthous.MessageSpec
@ -228,6 +230,7 @@ test-suite test
, brick
, checkers
, classy-prelude
, comonad
, constraints
, containers
, data-default