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…
	
	Add table
		Add a link
		
	
		Reference in a new issue