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:
parent
7d8ce026a2
commit
8a1235c3dc
26 changed files with 232 additions and 212 deletions
|
@ -25,6 +25,7 @@ dependencies:
|
|||
- brick
|
||||
- checkers
|
||||
- classy-prelude
|
||||
- comonad
|
||||
- constraints
|
||||
- containers
|
||||
- data-default
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
56
src/Xanthous/Data/EntityChar.hs
Normal file
56
src/Xanthous/Data/EntityChar.hs
Normal 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"
|
|
@ -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)
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
|
@ -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]
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ()
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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(..)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
@ -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}}.
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
]
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue