From 8a1235c3dcf7fe69b2e2ea3eea326858d26d38b9 Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Fri, 29 Nov 2019 22:59:15 -0500 Subject: 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. --- package.yaml | 1 + src/Xanthous/AI/Gormlak.hs | 4 +- src/Xanthous/AI/Gormlak.hs-boot | 2 +- src/Xanthous/App.hs | 47 +++++++--- src/Xanthous/Data/EntityChar.hs | 56 ++++++++++++ src/Xanthous/Data/EntityMap/Graphics.hs | 2 +- src/Xanthous/Entities.hs | 146 -------------------------------- src/Xanthous/Entities/Character.hs | 3 +- src/Xanthous/Entities/Creature.hs | 2 +- src/Xanthous/Entities/Entities.hs | 2 +- src/Xanthous/Entities/Environment.hs | 12 +-- src/Xanthous/Entities/Item.hs | 10 +-- src/Xanthous/Entities/RawTypes.hs | 3 +- src/Xanthous/Entities/Raws.hs | 2 +- src/Xanthous/Game/Arbitrary.hs | 4 +- src/Xanthous/Game/Draw.hs | 2 +- src/Xanthous/Game/Lenses.hs | 8 +- src/Xanthous/Game/Prompt.hs | 9 +- src/Xanthous/Game/State.hs | 85 ++++++++++++++++++- src/Xanthous/Orphans.hs | 1 - src/Xanthous/Prelude.hs | 6 +- src/Xanthous/messages.yaml | 4 +- test/Spec.hs | 8 +- test/Xanthous/Data/EntityCharSpec.hs | 18 ++++ test/Xanthous/EntitiesSpec.hs | 20 ----- test/Xanthous/GameSpec.hs | 2 +- xanthous.cabal | 11 ++- 27 files changed, 245 insertions(+), 225 deletions(-) create mode 100644 src/Xanthous/Data/EntityChar.hs delete mode 100644 src/Xanthous/Entities.hs create mode 100644 test/Xanthous/Data/EntityCharSpec.hs delete mode 100644 test/Xanthous/EntitiesSpec.hs diff --git a/package.yaml b/package.yaml index a54d3075b7..cadfd04d8d 100644 --- a/package.yaml +++ b/package.yaml @@ -25,6 +25,7 @@ dependencies: - brick - checkers - classy-prelude +- comonad - constraints - containers - data-default diff --git a/src/Xanthous/AI/Gormlak.hs b/src/Xanthous/AI/Gormlak.hs index 268e33ad6c..8b30bc2c9d 100644 --- a/src/Xanthous/AI/Gormlak.hs +++ b/src/Xanthous/AI/Gormlak.hs @@ -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 diff --git a/src/Xanthous/AI/Gormlak.hs-boot b/src/Xanthous/AI/Gormlak.hs-boot index 391a8a807f..47e62f6249 100644 --- a/src/Xanthous/AI/Gormlak.hs-boot +++ b/src/Xanthous/AI/Gormlak.hs-boot @@ -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 diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs index 13c4af1246..76e03e8609 100644 --- a/src/Xanthous/App.hs +++ b/src/Xanthous/App.hs @@ -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 diff --git a/src/Xanthous/Data/EntityChar.hs b/src/Xanthous/Data/EntityChar.hs new file mode 100644 index 0000000000..7aeb5fdf86 --- /dev/null +++ b/src/Xanthous/Data/EntityChar.hs @@ -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" diff --git a/src/Xanthous/Data/EntityMap/Graphics.hs b/src/Xanthous/Data/EntityMap/Graphics.hs index ace5ae49e8..30c6d09673 100644 --- a/src/Xanthous/Data/EntityMap/Graphics.hs +++ b/src/Xanthous/Data/EntityMap/Graphics.hs @@ -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) -------------------------------------------------------------------------------- diff --git a/src/Xanthous/Entities.hs b/src/Xanthous/Entities.hs deleted file mode 100644 index 7f4efb71d1..0000000000 --- a/src/Xanthous/Entities.hs +++ /dev/null @@ -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] diff --git a/src/Xanthous/Entities/Character.hs b/src/Xanthous/Entities/Character.hs index cc04340f6e..22589252ac 100644 --- a/src/Xanthous/Entities/Character.hs +++ b/src/Xanthous/Entities/Character.hs @@ -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 diff --git a/src/Xanthous/Entities/Creature.hs b/src/Xanthous/Entities/Creature.hs index 11cad1ce6b..de9122746b 100644 --- a/src/Xanthous/Entities/Creature.hs +++ b/src/Xanthous/Entities/Creature.hs @@ -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 -------------------------------------------------------------------------------- diff --git a/src/Xanthous/Entities/Entities.hs b/src/Xanthous/Entities/Entities.hs index 410a6514ae..7e41fc8b7b 100644 --- a/src/Xanthous/Entities/Entities.hs +++ b/src/Xanthous/Entities/Entities.hs @@ -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 diff --git a/src/Xanthous/Entities/Environment.hs b/src/Xanthous/Entities/Environment.hs index 8119199631..8baa07650f 100644 --- a/src/Xanthous/Entities/Environment.hs +++ b/src/Xanthous/Entities/Environment.hs @@ -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" diff --git a/src/Xanthous/Entities/Item.hs b/src/Xanthous/Entities/Item.hs index ddd387af8c..465110069c 100644 --- a/src/Xanthous/Entities/Item.hs +++ b/src/Xanthous/Entities/Item.hs @@ -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 diff --git a/src/Xanthous/Entities/RawTypes.hs b/src/Xanthous/Entities/RawTypes.hs index 09b250fb31..f715f8743a 100644 --- a/src/Xanthous/Entities/RawTypes.hs +++ b/src/Xanthous/Entities/RawTypes.hs @@ -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 diff --git a/src/Xanthous/Entities/Raws.hs b/src/Xanthous/Entities/Raws.hs index 9b7d63c6c4..d4cae7ccc2 100644 --- a/src/Xanthous/Entities/Raws.hs +++ b/src/Xanthous/Entities/Raws.hs @@ -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 () diff --git a/src/Xanthous/Game/Arbitrary.hs b/src/Xanthous/Game/Arbitrary.hs index e8f9ae22c4..090eba634d 100644 --- a/src/Xanthous/Game/Arbitrary.hs +++ b/src/Xanthous/Game/Arbitrary.hs @@ -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 diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs index 2f7ccf29f7..ab0e31f8a0 100644 --- a/src/Xanthous/Game/Draw.hs +++ b/src/Xanthous/Game/Draw.hs @@ -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(..) diff --git a/src/Xanthous/Game/Lenses.hs b/src/Xanthous/Game/Lenses.hs index cd7148442a..7dbd602901 100644 --- a/src/Xanthous/Game/Lenses.hs +++ b/src/Xanthous/Game/Lenses.hs @@ -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 diff --git a/src/Xanthous/Game/Prompt.hs b/src/Xanthous/Game/Prompt.hs index 6c3629f310..8e9ec04ccb 100644 --- a/src/Xanthous/Game/Prompt.hs +++ b/src/Xanthous/Game/Prompt.hs @@ -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) diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs index 92c68a3f65..16d93c61ba 100644 --- a/src/Xanthous/Game/State.hs +++ b/src/Xanthous/Game/State.hs @@ -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 diff --git a/src/Xanthous/Orphans.hs b/src/Xanthous/Orphans.hs index 6714a3bc56..bb6b0d024e 100644 --- a/src/Xanthous/Orphans.hs +++ b/src/Xanthous/Orphans.hs @@ -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 diff --git a/src/Xanthous/Prelude.hs b/src/Xanthous/Prelude.hs index 756642440b..b17fd2897b 100644 --- a/src/Xanthous/Prelude.hs +++ b/src/Xanthous/Prelude.hs @@ -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 +-------------------------------------------------------------------------------- diff --git a/src/Xanthous/messages.yaml b/src/Xanthous/messages.yaml index 71f08f2631..ae9ca060bf 100644 --- a/src/Xanthous/messages.yaml +++ b/src/Xanthous/messages.yaml @@ -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}}. diff --git a/test/Spec.hs b/test/Spec.hs index bd31867294..cd2827e58b 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 diff --git a/test/Xanthous/Data/EntityCharSpec.hs b/test/Xanthous/Data/EntityCharSpec.hs new file mode 100644 index 0000000000..9e8024c9d2 --- /dev/null +++ b/test/Xanthous/Data/EntityCharSpec.hs @@ -0,0 +1,18 @@ +-------------------------------------------------------------------------------- +module Xanthous.Data.EntityCharSpec where +-------------------------------------------------------------------------------- +import Test.Prelude +-------------------------------------------------------------------------------- +import qualified Data.Aeson as JSON +-------------------------------------------------------------------------------- +import Xanthous.Data.EntityChar +-------------------------------------------------------------------------------- + +main :: IO () +main = defaultMain test + +test :: TestTree +test = testGroup "Xanthous.Data.EntityChar" + [ testProperty "JSON round-trip" $ \(ec :: EntityChar) -> + JSON.decode (JSON.encode ec) === Just ec + ] diff --git a/test/Xanthous/EntitiesSpec.hs b/test/Xanthous/EntitiesSpec.hs deleted file mode 100644 index 14b03f7293..0000000000 --- a/test/Xanthous/EntitiesSpec.hs +++ /dev/null @@ -1,20 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.EntitiesSpec where --------------------------------------------------------------------------------- -import Test.Prelude --------------------------------------------------------------------------------- -import qualified Data.Aeson as JSON --------------------------------------------------------------------------------- -import Xanthous.Entities --------------------------------------------------------------------------------- - -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 - ] - ] diff --git a/test/Xanthous/GameSpec.hs b/test/Xanthous/GameSpec.hs index f9a9c543b9..75e9f6215a 100644 --- a/test/Xanthous/GameSpec.hs +++ b/test/Xanthous/GameSpec.hs @@ -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 diff --git a/xanthous.cabal b/xanthous.cabal index 7204dc0f0f..a5fbe9b4dc 100644 --- a/xanthous.cabal +++ b/xanthous.cabal @@ -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 -- cgit 1.4.1