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 | - brick | ||||||
| - checkers | - checkers | ||||||
| - classy-prelude | - classy-prelude | ||||||
|  | - comonad | ||||||
| - constraints | - constraints | ||||||
| - containers | - containers | ||||||
| - data-default | - data-default | ||||||
|  |  | ||||||
|  | @ -24,8 +24,7 @@ import           Xanthous.Entities.Creature | ||||||
| import           Xanthous.Entities.Character (Character) | import           Xanthous.Entities.Character (Character) | ||||||
| import qualified Xanthous.Entities.Character as Character | import qualified Xanthous.Entities.Character as Character | ||||||
| import qualified Xanthous.Entities.RawTypes as Raw | import qualified Xanthous.Entities.RawTypes as Raw | ||||||
| import           Xanthous.Entities (Entity(..), Brain(..), brainVia) | import           Xanthous.Game.State | ||||||
| import           Xanthous.Game.State (entities, GameState, entityIs) |  | ||||||
| import           Xanthous.Game.Lenses | import           Xanthous.Game.Lenses | ||||||
|                  ( Collision(..), entityCollision, collisionAt |                  ( Collision(..), entityCollision, collisionAt | ||||||
|                  , character, characterPosition |                  , character, characterPosition | ||||||
|  | @ -99,3 +98,4 @@ instance Brain Creature where step = brainVia GormlakBrain | ||||||
| instance Entity Creature where | instance Entity Creature where | ||||||
|   blocksVision _ = False |   blocksVision _ = False | ||||||
|   description = view $ Creature.creatureType . Raw.description |   description = view $ Creature.creatureType . Raw.description | ||||||
|  |   entityChar = view $ Creature.creatureType . char | ||||||
|  |  | ||||||
|  | @ -1,7 +1,7 @@ | ||||||
| {-# OPTIONS_GHC -fno-warn-orphans #-} | {-# OPTIONS_GHC -fno-warn-orphans #-} | ||||||
| module Xanthous.AI.Gormlak where | module Xanthous.AI.Gormlak where | ||||||
| 
 | 
 | ||||||
| import Xanthous.Entities | import Xanthous.Game.State | ||||||
| import Xanthous.Entities.Creature | import Xanthous.Entities.Creature | ||||||
| 
 | 
 | ||||||
| instance Entity Creature | instance Entity Creature | ||||||
|  |  | ||||||
|  | @ -30,6 +30,7 @@ import           Xanthous.Data | ||||||
| import           Xanthous.Data.EntityMap (EntityMap) | import           Xanthous.Data.EntityMap (EntityMap) | ||||||
| import qualified Xanthous.Data.EntityMap as EntityMap | import qualified Xanthous.Data.EntityMap as EntityMap | ||||||
| import           Xanthous.Game | import           Xanthous.Game | ||||||
|  | import           Xanthous.Game.State | ||||||
| import           Xanthous.Game.Draw (drawGame) | import           Xanthous.Game.Draw (drawGame) | ||||||
| import           Xanthous.Game.Prompt | import           Xanthous.Game.Prompt | ||||||
| import           Xanthous.Monad | import           Xanthous.Monad | ||||||
|  | @ -38,8 +39,7 @@ import qualified Xanthous.Messages as Messages | ||||||
| import           Xanthous.Util.Inflection (toSentence) | import           Xanthous.Util.Inflection (toSentence) | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| import qualified Xanthous.Entities.Character as Character | import qualified Xanthous.Entities.Character as Character | ||||||
| import           Xanthous.Entities.Character | import           Xanthous.Entities.Character hiding (pickUpItem) | ||||||
| import           Xanthous.Entities |  | ||||||
| import           Xanthous.Entities.Item (Item) | import           Xanthous.Entities.Item (Item) | ||||||
| import qualified Xanthous.Entities.Item as Item | import qualified Xanthous.Entities.Item as Item | ||||||
| import           Xanthous.Entities.Creature (Creature) | import           Xanthous.Entities.Creature (Creature) | ||||||
|  | @ -138,16 +138,19 @@ handleCommand (Move dir) = do | ||||||
| 
 | 
 | ||||||
| handleCommand PickUp = do | handleCommand PickUp = do | ||||||
|   pos <- use characterPosition |   pos <- use characterPosition | ||||||
|   items <- uses entities $ entitiesAtPositionWithType @Item pos |   uses entities (entitiesAtPositionWithType @Item pos) >>= \case | ||||||
|   case items of |     [] -> say_ ["pickUp", "nothingToPickUp"] | ||||||
|     [] -> say_ ["items", "nothingToPickUp"] |     [item] -> pickUpItem item | ||||||
|     [(itemID, item)] -> do |     items -> | ||||||
|  |       menu_ ["pickUp", "menu"] Cancellable (entityMenu_ items) | ||||||
|  |       $ \(MenuResult item) -> pickUpItem item | ||||||
|  |   continue | ||||||
|  |   where | ||||||
|  |     pickUpItem (itemID, item) = do | ||||||
|       character %= Character.pickUpItem item |       character %= Character.pickUpItem item | ||||||
|       entities . at itemID .= Nothing |       entities . at itemID .= Nothing | ||||||
|       say ["items", "pickUp"] $ object [ "item" A..= item ] |       say ["pickUp", "pickUp"] $ object [ "item" A..= item ] | ||||||
|       stepGameBy 100 -- TODO |       stepGameBy 100 -- TODO | ||||||
|     _ -> undefined |  | ||||||
|   continue |  | ||||||
| 
 | 
 | ||||||
| handleCommand PreviousMessage = do | handleCommand PreviousMessage = do | ||||||
|   messageHistory %= previousMessage |   messageHistory %= previousMessage | ||||||
|  | @ -188,6 +191,7 @@ handleCommand Eat = do | ||||||
|         let foodMenuItem idx (item, edibleItem) |         let foodMenuItem idx (item, edibleItem) | ||||||
|               = ( item ^. Item.itemType . char . char |               = ( item ^. Item.itemType . char . char | ||||||
|                 , MenuOption (description item) (idx, item, edibleItem)) |                 , MenuOption (description item) (idx, item, edibleItem)) | ||||||
|  |                 -- TODO refactor to use entityMenu_ | ||||||
|             menuItems = mkMenuItems $ imap foodMenuItem food |             menuItems = mkMenuItems $ imap foodMenuItem food | ||||||
|         in menu_ ["eat", "menuPrompt"] Cancellable menuItems |         in menu_ ["eat", "menuPrompt"] Cancellable menuItems | ||||||
|           $ \(MenuResult (idx, item, edibleItem)) -> do |           $ \(MenuResult (idx, item, edibleItem)) -> do | ||||||
|  | @ -265,6 +269,8 @@ handlePromptEvent | ||||||
|        >> continue |        >> continue | ||||||
| handlePromptEvent _ (Prompt _ SPointOnMap _ _ _) _ = continue | handlePromptEvent _ (Prompt _ SPointOnMap _ _ _) _ = continue | ||||||
| 
 | 
 | ||||||
|  | handlePromptEvent _ _ _ = continue | ||||||
|  | 
 | ||||||
| clearPrompt :: AppM (Next GameState) | clearPrompt :: AppM (Next GameState) | ||||||
| clearPrompt = promptState .= NoPrompt >> continue | clearPrompt = promptState .= NoPrompt >> continue | ||||||
| 
 | 
 | ||||||
|  | @ -330,7 +336,6 @@ menu_ :: forall (a :: Type). | ||||||
|       -> AppM () |       -> AppM () | ||||||
| menu_ msgPath = menu msgPath $ object [] | menu_ msgPath = menu msgPath $ object [] | ||||||
| 
 | 
 | ||||||
| 
 |  | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| 
 | 
 | ||||||
| entitiesAtPositionWithType | entitiesAtPositionWithType | ||||||
|  | @ -374,7 +379,9 @@ attackAt pos = | ||||||
|   uses entities (entitiesAtPositionWithType @Creature pos) >>= \case |   uses entities (entitiesAtPositionWithType @Creature pos) >>= \case | ||||||
|     Empty               -> say_ ["combat", "nothingToAttack"] |     Empty               -> say_ ["combat", "nothingToAttack"] | ||||||
|     (creature :< Empty) -> attackCreature creature |     (creature :< Empty) -> attackCreature creature | ||||||
|     creatures           -> undefined |     creatures -> | ||||||
|  |       menu_ ["combat", "menu"] Cancellable (entityMenu_ creatures) | ||||||
|  |       $ \(MenuResult creature) -> attackCreature creature | ||||||
|  where |  where | ||||||
|   attackCreature (creatureID, creature) = do |   attackCreature (creatureID, creature) = do | ||||||
|     charDamage <- use $ character . characterDamage |     charDamage <- use $ character . characterDamage | ||||||
|  | @ -388,3 +395,21 @@ attackAt pos = | ||||||
|         say ["combat", "hit"] msgParams |         say ["combat", "hit"] msgParams | ||||||
|         entities . ix creatureID . positioned .= SomeEntity creature' |         entities . ix creatureID . positioned .= SomeEntity creature' | ||||||
|     stepGame -- TODO |     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.Util (takeWhileInclusive) | ||||||
| import Xanthous.Data | import Xanthous.Data | ||||||
| import Xanthous.Data.EntityMap | import Xanthous.Data.EntityMap | ||||||
| import Xanthous.Entities | import Xanthous.Game.State | ||||||
| import Xanthous.Util.Graphics (circle, line) | 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.Aeson (ToJSON, FromJSON) | ||||||
| import Data.Coerce (coerce) | import Data.Coerce (coerce) | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| import Xanthous.Entities | import Xanthous.Game.State | ||||||
| import Xanthous.Entities.Item | import Xanthous.Entities.Item | ||||||
| import Xanthous.Data (TicksPerTile, Hitpoints, Per, Ticks, (|*|), positioned) | import Xanthous.Data (TicksPerTile, Hitpoints, Per, Ticks, (|*|), positioned) | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
|  | @ -68,6 +68,7 @@ instance Brain Character where | ||||||
| instance Entity Character where | instance Entity Character where | ||||||
|   blocksVision _ = False |   blocksVision _ = False | ||||||
|   description _ = "yourself" |   description _ = "yourself" | ||||||
|  |   entityChar _ = "@" | ||||||
| 
 | 
 | ||||||
| instance Arbitrary Character where | instance Arbitrary Character where | ||||||
|   arbitrary = genericArbitrary |   arbitrary = genericArbitrary | ||||||
|  |  | ||||||
|  | @ -35,7 +35,7 @@ import           Data.Aeson.Generic.DerivingVia | ||||||
| import           Data.Aeson (ToJSON, FromJSON) | import           Data.Aeson (ToJSON, FromJSON) | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| import           Xanthous.Entities.RawTypes hiding (Creature, description) | import           Xanthous.Entities.RawTypes hiding (Creature, description) | ||||||
| import           Xanthous.Entities (Draw(..), DrawRawCharPriority(..)) | import           Xanthous.Game.State | ||||||
| import           Xanthous.Data | import           Xanthous.Data | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| 
 | 
 | ||||||
|  |  | ||||||
|  | @ -9,7 +9,6 @@ import           Test.QuickCheck | ||||||
| import qualified Test.QuickCheck.Gen as Gen | import qualified Test.QuickCheck.Gen as Gen | ||||||
| import           Data.Aeson | import           Data.Aeson | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| import           Xanthous.Entities (Entity(..), SomeEntity(..)) |  | ||||||
| import           Xanthous.Entities.Character | import           Xanthous.Entities.Character | ||||||
| import           Xanthous.Entities.Item | import           Xanthous.Entities.Item | ||||||
| import           Xanthous.Entities.Creature | import           Xanthous.Entities.Creature | ||||||
|  | @ -46,6 +45,7 @@ deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameState | ||||||
| instance Entity SomeEntity where | instance Entity SomeEntity where | ||||||
|   blocksVision (SomeEntity ent) = blocksVision ent |   blocksVision (SomeEntity ent) = blocksVision ent | ||||||
|   description (SomeEntity ent) = description ent |   description (SomeEntity ent) = description ent | ||||||
|  |   entityChar (SomeEntity ent) = entityChar ent | ||||||
| 
 | 
 | ||||||
| instance Function SomeEntity where | instance Function SomeEntity where | ||||||
|   function = functionJSON |   function = functionJSON | ||||||
|  |  | ||||||
|  | @ -14,17 +14,9 @@ import Brick.Widgets.Border.Style (unicode) | ||||||
| import Brick.Types (Edges(..)) | import Brick.Types (Edges(..)) | ||||||
| import Data.Aeson | import Data.Aeson | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| import Xanthous.Entities |  | ||||||
|        ( Draw(..) |  | ||||||
|        , entityIs |  | ||||||
|        , Entity(..) |  | ||||||
|        , SomeEntity |  | ||||||
|        , Brain(..) |  | ||||||
|        , Brainless(..) |  | ||||||
|        , brainVia |  | ||||||
|        ) |  | ||||||
| import Xanthous.Entities.Draw.Util | import Xanthous.Entities.Draw.Util | ||||||
| import Xanthous.Data | import Xanthous.Data | ||||||
|  | import Xanthous.Game.State | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| 
 | 
 | ||||||
| data Wall = Wall | data Wall = Wall | ||||||
|  | @ -45,6 +37,7 @@ instance Brain Wall where step = brainVia Brainless | ||||||
| instance Entity Wall where | instance Entity Wall where | ||||||
|   blocksVision _ = True |   blocksVision _ = True | ||||||
|   description _ = "a wall" |   description _ = "a wall" | ||||||
|  |   entityChar _ = "┼" | ||||||
| 
 | 
 | ||||||
| instance Arbitrary Wall where | instance Arbitrary Wall where | ||||||
|   arbitrary = pure Wall |   arbitrary = pure Wall | ||||||
|  | @ -90,3 +83,4 @@ instance Brain Door where step = brainVia Brainless | ||||||
| instance Entity Door where | instance Entity Door where | ||||||
|   blocksVision = not . view open |   blocksVision = not . view open | ||||||
|   description _ = "a door" |   description _ = "a door" | ||||||
|  |   entityChar _ = "d" | ||||||
|  |  | ||||||
|  | @ -15,14 +15,7 @@ import           Data.Aeson.Generic.DerivingVia | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| import           Xanthous.Entities.RawTypes hiding (Item, description, isEdible) | import           Xanthous.Entities.RawTypes hiding (Item, description, isEdible) | ||||||
| import qualified Xanthous.Entities.RawTypes as Raw | import qualified Xanthous.Entities.RawTypes as Raw | ||||||
| import           Xanthous.Entities | import           Xanthous.Game.State | ||||||
|                  ( Draw(..) |  | ||||||
|                  , Entity(..) |  | ||||||
|                  , DrawRawChar(..) |  | ||||||
|                  , Brain(..) |  | ||||||
|                  , Brainless(..) |  | ||||||
|                  , brainVia |  | ||||||
|                  ) |  | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| 
 | 
 | ||||||
| data Item = Item | data Item = Item | ||||||
|  | @ -47,6 +40,7 @@ instance Arbitrary Item where | ||||||
| instance Entity Item where | instance Entity Item where | ||||||
|   blocksVision _ = False |   blocksVision _ = False | ||||||
|   description = view $ itemType . Raw.description |   description = view $ itemType . Raw.description | ||||||
|  |   entityChar = view $ itemType . Raw.char | ||||||
| 
 | 
 | ||||||
| newWithType :: ItemType -> Item | newWithType :: ItemType -> Item | ||||||
| newWithType = Item | newWithType = Item | ||||||
|  |  | ||||||
|  | @ -10,6 +10,7 @@ module Xanthous.Entities.RawTypes | ||||||
| 
 | 
 | ||||||
|   , _Creature |   , _Creature | ||||||
|     -- * Lens classes |     -- * Lens classes | ||||||
|  |   , HasChar(..) | ||||||
|   , HasName(..) |   , HasName(..) | ||||||
|   , HasDescription(..) |   , HasDescription(..) | ||||||
|   , HasLongDescription(..) |   , HasLongDescription(..) | ||||||
|  | @ -27,9 +28,9 @@ import Test.QuickCheck.Arbitrary.Generic | ||||||
| import Data.Aeson.Generic.DerivingVia | import Data.Aeson.Generic.DerivingVia | ||||||
| import Data.Aeson (ToJSON, FromJSON) | import Data.Aeson (ToJSON, FromJSON) | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| import Xanthous.Entities (EntityChar, HasChar(..)) |  | ||||||
| import Xanthous.Messages (Message(..)) | import Xanthous.Messages (Message(..)) | ||||||
| import Xanthous.Data (TicksPerTile, Hitpoints) | import Xanthous.Data (TicksPerTile, Hitpoints) | ||||||
|  | import Xanthous.Data.EntityChar | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| data CreatureType = CreatureType | data CreatureType = CreatureType | ||||||
|   { _name         :: !Text |   { _name         :: !Text | ||||||
|  |  | ||||||
|  | @ -14,7 +14,7 @@ import           Xanthous.Prelude | ||||||
| import           System.FilePath.Posix | import           System.FilePath.Posix | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| import           Xanthous.Entities.RawTypes | import           Xanthous.Entities.RawTypes | ||||||
| import           Xanthous.Entities | import           Xanthous.Game.State | ||||||
| import qualified Xanthous.Entities.Creature as Creature | import qualified Xanthous.Entities.Creature as Creature | ||||||
| import qualified Xanthous.Entities.Item as Item | import qualified Xanthous.Entities.Item as Item | ||||||
| import           Xanthous.AI.Gormlak () | import           Xanthous.AI.Gormlak () | ||||||
|  |  | ||||||
|  | @ -18,11 +18,11 @@ import qualified Xanthous.Data.EntityMap as EntityMap | ||||||
| 
 | 
 | ||||||
| instance Arbitrary GameState where | instance Arbitrary GameState where | ||||||
|   arbitrary = do |   arbitrary = do | ||||||
|     char <- arbitrary @Character |     chr <- arbitrary @Character | ||||||
|     charPos <- arbitrary |     charPos <- arbitrary | ||||||
|     _messageHistory <- arbitrary |     _messageHistory <- arbitrary | ||||||
|     (_characterEntityID, _entities) <- arbitrary <&> |     (_characterEntityID, _entities) <- arbitrary <&> | ||||||
|       EntityMap.insertAtReturningID charPos (SomeEntity char) |       EntityMap.insertAtReturningID charPos (SomeEntity chr) | ||||||
|     _revealedPositions <- fmap setFromList . sublistOf $ EntityMap.positions _entities |     _revealedPositions <- fmap setFromList . sublistOf $ EntityMap.positions _entities | ||||||
|     _randomGen <- mkStdGen <$> arbitrary |     _randomGen <- mkStdGen <$> arbitrary | ||||||
|     let _promptState = NoPrompt -- TODO |     let _promptState = NoPrompt -- TODO | ||||||
|  |  | ||||||
|  | @ -12,7 +12,7 @@ import           Brick.Widgets.Edit | ||||||
| import           Xanthous.Data | import           Xanthous.Data | ||||||
| import           Xanthous.Data.EntityMap (EntityMap, atPosition) | import           Xanthous.Data.EntityMap (EntityMap, atPosition) | ||||||
| import qualified Xanthous.Data.EntityMap as EntityMap | import qualified Xanthous.Data.EntityMap as EntityMap | ||||||
| import           Xanthous.Entities | import           Xanthous.Game.State | ||||||
| import           Xanthous.Entities.Character | import           Xanthous.Entities.Character | ||||||
| import           Xanthous.Game | import           Xanthous.Game | ||||||
|                  ( GameState(..) |                  ( GameState(..) | ||||||
|  |  | ||||||
|  | @ -37,11 +37,11 @@ getInitialState = initialStateFromSeed <$> getRandom | ||||||
| initialStateFromSeed :: Int -> GameState | initialStateFromSeed :: Int -> GameState | ||||||
| initialStateFromSeed seed = | initialStateFromSeed seed = | ||||||
|   let _randomGen = mkStdGen seed |   let _randomGen = mkStdGen seed | ||||||
|       char = mkCharacter |       chr = mkCharacter | ||||||
|       (_characterEntityID, _entities) |       (_characterEntityID, _entities) | ||||||
|         = EntityMap.insertAtReturningID |         = EntityMap.insertAtReturningID | ||||||
|           (Position 0 0) |           (Position 0 0) | ||||||
|           (SomeEntity char) |           (SomeEntity chr) | ||||||
|           mempty |           mempty | ||||||
|       _messageHistory = mempty |       _messageHistory = mempty | ||||||
|       _revealedPositions = mempty |       _revealedPositions = mempty | ||||||
|  | @ -56,10 +56,10 @@ positionedCharacter :: Lens' GameState (Positioned Character) | ||||||
| positionedCharacter = lens getPositionedCharacter setPositionedCharacter | positionedCharacter = lens getPositionedCharacter setPositionedCharacter | ||||||
|   where |   where | ||||||
|     setPositionedCharacter :: GameState -> Positioned Character -> GameState |     setPositionedCharacter :: GameState -> Positioned Character -> GameState | ||||||
|     setPositionedCharacter game char |     setPositionedCharacter game chr | ||||||
|       = game |       = game | ||||||
|       &  entities . at (game ^. characterEntityID) |       &  entities . at (game ^. characterEntityID) | ||||||
|       ?~ fmap SomeEntity char |       ?~ fmap SomeEntity chr | ||||||
| 
 | 
 | ||||||
|     getPositionedCharacter :: GameState -> Positioned Character |     getPositionedCharacter :: GameState -> Positioned Character | ||||||
|     getPositionedCharacter game |     getPositionedCharacter game | ||||||
|  |  | ||||||
|  | @ -1,6 +1,8 @@ | ||||||
|  | {-# LANGUAGE DeriveFunctor #-} | ||||||
| {-# LANGUAGE UndecidableInstances #-} | {-# LANGUAGE UndecidableInstances #-} | ||||||
| {-# LANGUAGE StandaloneDeriving #-} | {-# LANGUAGE StandaloneDeriving #-} | ||||||
| {-# LANGUAGE GADTs #-} | {-# LANGUAGE GADTs #-} | ||||||
|  | {-# LANGUAGE DeriveFunctor #-} | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| module Xanthous.Game.Prompt | module Xanthous.Game.Prompt | ||||||
|   ( PromptType(..) |   ( PromptType(..) | ||||||
|  | @ -25,6 +27,7 @@ import Xanthous.Prelude | ||||||
| import           Brick.Widgets.Edit (Editor, editorText, getEditContents) | import           Brick.Widgets.Edit (Editor, editorText, getEditContents) | ||||||
| import           Test.QuickCheck | import           Test.QuickCheck | ||||||
| import           Test.QuickCheck.Arbitrary.Generic | import           Test.QuickCheck.Arbitrary.Generic | ||||||
|  | import           Control.Comonad | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| import           Xanthous.Util (smallestNotIn) | import           Xanthous.Util (smallestNotIn) | ||||||
| import           Xanthous.Data (Direction, Position) | import           Xanthous.Data (Direction, Position) | ||||||
|  | @ -159,9 +162,13 @@ instance CoArbitrary (PromptState ('Menu a)) where | ||||||
| deriving stock instance Show (PromptState pt) | deriving stock instance Show (PromptState pt) | ||||||
| 
 | 
 | ||||||
| data MenuOption a = MenuOption Text a | data MenuOption a = MenuOption Text a | ||||||
|   deriving stock (Eq, Generic) |   deriving stock (Eq, Generic, Functor) | ||||||
|   deriving anyclass (NFData, CoArbitrary, Function) |   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)) | mkMenuItems :: (MonoFoldable f, Element f ~ (Char, MenuOption a)) | ||||||
|             => f |             => f | ||||||
|             -> Map Char (MenuOption a) |             -> Map Char (MenuOption a) | ||||||
|  |  | ||||||
|  | @ -1,3 +1,4 @@ | ||||||
|  | {-# LANGUAGE RecordWildCards #-} | ||||||
| {-# LANGUAGE UndecidableInstances #-} | {-# LANGUAGE UndecidableInstances #-} | ||||||
| {-# LANGUAGE TemplateHaskell     #-} | {-# LANGUAGE TemplateHaskell     #-} | ||||||
| {-# LANGUAGE GADTs               #-} | {-# LANGUAGE GADTs               #-} | ||||||
|  | @ -36,6 +37,13 @@ module Xanthous.Game.State | ||||||
|   , downcastEntity |   , downcastEntity | ||||||
|   , _SomeEntity |   , _SomeEntity | ||||||
|   , entityIs |   , entityIs | ||||||
|  |   , DrawRawChar(..) | ||||||
|  |   , DrawRawCharPriority(..) | ||||||
|  |   , DrawCharacter(..) | ||||||
|  |   , DrawStyledCharacter(..) | ||||||
|  |     -- ** Field classes | ||||||
|  |   , HasChar(..) | ||||||
|  |   , HasStyle(..) | ||||||
| 
 | 
 | ||||||
|     -- * Debug State |     -- * Debug State | ||||||
|   , DebugState(..) |   , DebugState(..) | ||||||
|  | @ -55,13 +63,18 @@ import           Test.QuickCheck.Arbitrary.Generic | ||||||
| import           Control.Monad.State.Class | import           Control.Monad.State.Class | ||||||
| import           Control.Monad.State | import           Control.Monad.State | ||||||
| import           Control.Monad.Random.Class | import           Control.Monad.Random.Class | ||||||
| import           Brick (EventM, Widget) | import           Brick (EventM, Widget, raw, str) | ||||||
| import           Data.Aeson (ToJSON(..), FromJSON(..), Value(Null)) | import           Data.Aeson (ToJSON(..), FromJSON(..), Value(Null)) | ||||||
| import qualified Data.Aeson as JSON | import qualified Data.Aeson as JSON | ||||||
| import           Data.Aeson.Generic.DerivingVia | 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 | ||||||
|  | import           Xanthous.Data.EntityMap (EntityMap, EntityID) | ||||||
|  | import           Xanthous.Data.EntityChar | ||||||
| import           Xanthous.Orphans () | import           Xanthous.Orphans () | ||||||
| import           Xanthous.Game.Prompt | import           Xanthous.Game.Prompt | ||||||
| import           Xanthous.Resource | import           Xanthous.Resource | ||||||
|  | @ -181,6 +194,73 @@ instance Draw a => Draw (Positioned a) where | ||||||
|   drawWithNeighbors ns (Positioned _ a) = drawWithNeighbors ns a |   drawWithNeighbors ns (Positioned _ a) = drawWithNeighbors ns a | ||||||
|   draw (Positioned _ a) = draw 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 | class Brain a where | ||||||
|  | @ -208,6 +288,7 @@ class ( Show a, Eq a, NFData a | ||||||
|       ) => Entity a where |       ) => Entity a where | ||||||
|   blocksVision :: a -> Bool |   blocksVision :: a -> Bool | ||||||
|   description :: a -> Text |   description :: a -> Text | ||||||
|  |   entityChar :: a -> EntityChar | ||||||
| 
 | 
 | ||||||
| data SomeEntity where | data SomeEntity where | ||||||
|   SomeEntity :: forall a. (Entity a, Typeable a) => a -> SomeEntity |   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           Brick.Widgets.Core (getName) | ||||||
| import           System.Random (StdGen) | import           System.Random (StdGen) | ||||||
| import           Test.QuickCheck | import           Test.QuickCheck | ||||||
| import           Test.QuickCheck.Arbitrary.Generic |  | ||||||
| import           Text.Megaparsec (errorBundlePretty) | import           Text.Megaparsec (errorBundlePretty) | ||||||
| import           Text.Megaparsec.Pos | import           Text.Megaparsec.Pos | ||||||
| import           Text.Mustache | import           Text.Mustache | ||||||
|  |  | ||||||
|  | @ -1,3 +1,4 @@ | ||||||
|  | -------------------------------------------------------------------------------- | ||||||
| module Xanthous.Prelude | module Xanthous.Prelude | ||||||
|   ( module ClassyPrelude |   ( module ClassyPrelude | ||||||
|   , Type |   , Type | ||||||
|  | @ -5,11 +6,14 @@ module Xanthous.Prelude | ||||||
|   , module GHC.TypeLits |   , module GHC.TypeLits | ||||||
|   , module Control.Lens |   , module Control.Lens | ||||||
|   , module Data.Void |   , module Data.Void | ||||||
|  |   , module Control.Comonad | ||||||
|   ) where |   ) where | ||||||
| 
 | -------------------------------------------------------------------------------- | ||||||
| import ClassyPrelude hiding | import ClassyPrelude hiding | ||||||
|   (return, (<|), unsnoc, uncons, cons, snoc, index, (<.>), Index, say) |   (return, (<|), unsnoc, uncons, cons, snoc, index, (<.>), Index, say) | ||||||
| import Data.Kind | import Data.Kind | ||||||
| import GHC.TypeLits hiding (Text) | import GHC.TypeLits hiding (Text) | ||||||
| import Control.Lens | import Control.Lens | ||||||
| import Data.Void | import Data.Void | ||||||
|  | import Control.Comonad | ||||||
|  | -------------------------------------------------------------------------------- | ||||||
|  |  | ||||||
|  | @ -12,7 +12,8 @@ save: | ||||||
| entities: | entities: | ||||||
|   description: You see here {{entityDescriptions}} |   description: You see here {{entityDescriptions}} | ||||||
| 
 | 
 | ||||||
| items: | pickUp: | ||||||
|  |   menu: What would you like to pick up? | ||||||
|   pickUp: You pick up the {{item.itemType.name}} |   pickUp: You pick up the {{item.itemType.name}} | ||||||
|   nothingToPickUp: "There's nothing here to pick up" |   nothingToPickUp: "There's nothing here to pick up" | ||||||
| 
 | 
 | ||||||
|  | @ -31,6 +32,7 @@ character: | ||||||
| 
 | 
 | ||||||
| combat: | combat: | ||||||
|   nothingToAttack: There's nothing to attack there. |   nothingToAttack: There's nothing to attack there. | ||||||
|  |   menu: Which creature would you like to attack? | ||||||
|   hit: |   hit: | ||||||
|     - You hit the {{creature.creatureType.name}}. |     - You hit the {{creature.creatureType.name}}. | ||||||
|     - You attack the {{creature.creatureType.name}}. |     - You attack the {{creature.creatureType.name}}. | ||||||
|  |  | ||||||
|  | @ -1,23 +1,23 @@ | ||||||
| import Test.Prelude | import Test.Prelude | ||||||
|  | import qualified Xanthous.Data.EntityCharSpec | ||||||
| import qualified Xanthous.Data.EntityMapSpec | import qualified Xanthous.Data.EntityMapSpec | ||||||
| import qualified Xanthous.DataSpec | import qualified Xanthous.DataSpec | ||||||
| import qualified Xanthous.EntitiesSpec |  | ||||||
| import qualified Xanthous.Entities.RawsSpec | import qualified Xanthous.Entities.RawsSpec | ||||||
| import qualified Xanthous.GameSpec | import qualified Xanthous.GameSpec | ||||||
| import qualified Xanthous.Generators.UtilSpec | import qualified Xanthous.Generators.UtilSpec | ||||||
| import qualified Xanthous.MessageSpec | import qualified Xanthous.MessageSpec | ||||||
| import qualified Xanthous.OrphansSpec | import qualified Xanthous.OrphansSpec | ||||||
| import qualified Xanthous.UtilSpec |  | ||||||
| import qualified Xanthous.Util.GraphicsSpec | import qualified Xanthous.Util.GraphicsSpec | ||||||
| import qualified Xanthous.Util.InflectionSpec | import qualified Xanthous.Util.InflectionSpec | ||||||
|  | import qualified Xanthous.UtilSpec | ||||||
| 
 | 
 | ||||||
| main :: IO () | main :: IO () | ||||||
| main = defaultMain test | main = defaultMain test | ||||||
| 
 | 
 | ||||||
| test :: TestTree | test :: TestTree | ||||||
| test = testGroup "Xanthous" | test = testGroup "Xanthous" | ||||||
|   [ Xanthous.Data.EntityMapSpec.test |   [ Xanthous.Data.EntityCharSpec.test | ||||||
|   , Xanthous.EntitiesSpec.test |   , Xanthous.Data.EntityMapSpec.test | ||||||
|   , Xanthous.Entities.RawsSpec.test |   , Xanthous.Entities.RawsSpec.test | ||||||
|   , Xanthous.GameSpec.test |   , Xanthous.GameSpec.test | ||||||
|   , Xanthous.Generators.UtilSpec.test |   , Xanthous.Generators.UtilSpec.test | ||||||
|  |  | ||||||
|  | @ -1,20 +1,18 @@ | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| module Xanthous.EntitiesSpec where | module Xanthous.Data.EntityCharSpec where | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| import           Test.Prelude | import           Test.Prelude | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| import qualified Data.Aeson as JSON | import qualified Data.Aeson as JSON | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| import           Xanthous.Entities | import           Xanthous.Data.EntityChar | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| 
 | 
 | ||||||
| main :: IO () | main :: IO () | ||||||
| main = defaultMain test | main = defaultMain test | ||||||
| 
 | 
 | ||||||
| test :: TestTree | test :: TestTree | ||||||
| test = testGroup "Xanthous.Entities" | test = testGroup "Xanthous.Data.EntityChar" | ||||||
|   [ testGroup "EntityChar" |  | ||||||
|   [ testProperty "JSON round-trip" $ \(ec :: EntityChar) -> |   [ testProperty "JSON round-trip" $ \(ec :: EntityChar) -> | ||||||
|       JSON.decode (JSON.encode ec) === Just ec |       JSON.decode (JSON.encode ec) === Just ec | ||||||
|   ] |   ] | ||||||
|   ] |  | ||||||
|  | @ -2,10 +2,10 @@ module Xanthous.GameSpec where | ||||||
| 
 | 
 | ||||||
| import Test.Prelude hiding (Down) | import Test.Prelude hiding (Down) | ||||||
| import Xanthous.Game | import Xanthous.Game | ||||||
|  | import Xanthous.Game.State | ||||||
| import Control.Lens.Properties | import Control.Lens.Properties | ||||||
| import Xanthous.Data (move, Direction(Down)) | import Xanthous.Data (move, Direction(Down)) | ||||||
| import Xanthous.Data.EntityMap (atPosition) | import Xanthous.Data.EntityMap (atPosition) | ||||||
| import Xanthous.Entities (SomeEntity(SomeEntity)) |  | ||||||
| 
 | 
 | ||||||
| main :: IO () | main :: IO () | ||||||
| main = defaultMain test | main = defaultMain test | ||||||
|  |  | ||||||
|  | @ -4,7 +4,7 @@ cabal-version: 1.12 | ||||||
| -- | -- | ||||||
| -- see: https://github.com/sol/hpack | -- see: https://github.com/sol/hpack | ||||||
| -- | -- | ||||||
| -- hash: 0ec32d45d89e30640d8d59137c5eaa80e5eed7eb31cb553d9b251db94ed1ba36 | -- hash: 2f93900ad18d56709eb363a7f8dd251a9474dd7092b1aef956389f32c036a121 | ||||||
| 
 | 
 | ||||||
| name:           xanthous | name:           xanthous | ||||||
| version:        0.1.0.0 | version:        0.1.0.0 | ||||||
|  | @ -34,9 +34,9 @@ library | ||||||
|       Xanthous.App |       Xanthous.App | ||||||
|       Xanthous.Command |       Xanthous.Command | ||||||
|       Xanthous.Data |       Xanthous.Data | ||||||
|  |       Xanthous.Data.EntityChar | ||||||
|       Xanthous.Data.EntityMap |       Xanthous.Data.EntityMap | ||||||
|       Xanthous.Data.EntityMap.Graphics |       Xanthous.Data.EntityMap.Graphics | ||||||
|       Xanthous.Entities |  | ||||||
|       Xanthous.Entities.Character |       Xanthous.Entities.Character | ||||||
|       Xanthous.Entities.Creature |       Xanthous.Entities.Creature | ||||||
|       Xanthous.Entities.Draw.Util |       Xanthous.Entities.Draw.Util | ||||||
|  | @ -81,6 +81,7 @@ library | ||||||
|     , brick |     , brick | ||||||
|     , checkers |     , checkers | ||||||
|     , classy-prelude |     , classy-prelude | ||||||
|  |     , comonad | ||||||
|     , constraints |     , constraints | ||||||
|     , containers |     , containers | ||||||
|     , data-default |     , data-default | ||||||
|  | @ -120,9 +121,9 @@ executable xanthous | ||||||
|       Xanthous.App |       Xanthous.App | ||||||
|       Xanthous.Command |       Xanthous.Command | ||||||
|       Xanthous.Data |       Xanthous.Data | ||||||
|  |       Xanthous.Data.EntityChar | ||||||
|       Xanthous.Data.EntityMap |       Xanthous.Data.EntityMap | ||||||
|       Xanthous.Data.EntityMap.Graphics |       Xanthous.Data.EntityMap.Graphics | ||||||
|       Xanthous.Entities |  | ||||||
|       Xanthous.Entities.Character |       Xanthous.Entities.Character | ||||||
|       Xanthous.Entities.Creature |       Xanthous.Entities.Creature | ||||||
|       Xanthous.Entities.Draw.Util |       Xanthous.Entities.Draw.Util | ||||||
|  | @ -166,6 +167,7 @@ executable xanthous | ||||||
|     , brick |     , brick | ||||||
|     , checkers |     , checkers | ||||||
|     , classy-prelude |     , classy-prelude | ||||||
|  |     , comonad | ||||||
|     , constraints |     , constraints | ||||||
|     , containers |     , containers | ||||||
|     , data-default |     , data-default | ||||||
|  | @ -203,10 +205,10 @@ test-suite test | ||||||
|   main-is: Spec.hs |   main-is: Spec.hs | ||||||
|   other-modules: |   other-modules: | ||||||
|       Test.Prelude |       Test.Prelude | ||||||
|  |       Xanthous.Data.EntityCharSpec | ||||||
|       Xanthous.Data.EntityMapSpec |       Xanthous.Data.EntityMapSpec | ||||||
|       Xanthous.DataSpec |       Xanthous.DataSpec | ||||||
|       Xanthous.Entities.RawsSpec |       Xanthous.Entities.RawsSpec | ||||||
|       Xanthous.EntitiesSpec |  | ||||||
|       Xanthous.GameSpec |       Xanthous.GameSpec | ||||||
|       Xanthous.Generators.UtilSpec |       Xanthous.Generators.UtilSpec | ||||||
|       Xanthous.MessageSpec |       Xanthous.MessageSpec | ||||||
|  | @ -228,6 +230,7 @@ test-suite test | ||||||
|     , brick |     , brick | ||||||
|     , checkers |     , checkers | ||||||
|     , classy-prelude |     , classy-prelude | ||||||
|  |     , comonad | ||||||
|     , constraints |     , constraints | ||||||
|     , containers |     , containers | ||||||
|     , data-default |     , data-default | ||||||
|  |  | ||||||
		Loading…
	
	Add table
		Add a link
		
	
		Reference in a new issue