Use menus for combat and picking up items

Refactor a bunch of stuff around to allow for polymorphically surfacing
an EntityChar for all entities, and use this to write a generic
`entityMenu` function, which generates a menu from the chars of a list
of entities - and use that to fully implement (removing `undefined`)
menus for both attacking and picking things up when there are multiple
entities on the relevant tile.

package.yaml

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

src/Xanthous/AI/Gormlak.hs

@@ -24,8 +24,7 @@ import           Xanthous.Entities.Creature
 import           Xanthous.Entities.Character (Character)
 import qualified Xanthous.Entities.Character as Character
 import qualified Xanthous.Entities.RawTypes as Raw
-import           Xanthous.Entities (Entity(..), Brain(..), brainVia)
+import           Xanthous.Game.State
-import           Xanthous.Game.State (entities, GameState, entityIs)
 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

src/Xanthous/AI/Gormlak.hs-boot

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

src/Xanthous/App.hs

@@ -30,6 +30,7 @@ import           Xanthous.Data
 import           Xanthous.Data.EntityMap (EntityMap)
 import qualified Xanthous.Data.EntityMap as EntityMap
 import           Xanthous.Game
+import           Xanthous.Game.State
 import           Xanthous.Game.Draw (drawGame)
 import           Xanthous.Game.Prompt
 import           Xanthous.Monad
@@ -38,8 +39,7 @@ import qualified Xanthous.Messages as Messages
 import           Xanthous.Util.Inflection (toSentence)
 --------------------------------------------------------------------------------
 import qualified Xanthous.Entities.Character as Character
-import           Xanthous.Entities.Character
+import           Xanthous.Entities.Character hiding (pickUpItem)
-import           Xanthous.Entities
 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
+  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
       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

src/Xanthous/Data/EntityChar.hs

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

src/Xanthous/Data/EntityMap/Graphics.hs

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

src/Xanthous/Entities.hs

@@ -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]

src/Xanthous/Entities/Character.hs

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

src/Xanthous/Entities/Creature.hs

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

src/Xanthous/Entities/Entities.hs

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

src/Xanthous/Entities/Environment.hs

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

src/Xanthous/Entities/Item.hs

@@ -15,14 +15,7 @@ import           Data.Aeson.Generic.DerivingVia
 --------------------------------------------------------------------------------
 import           Xanthous.Entities.RawTypes hiding (Item, description, isEdible)
 import qualified Xanthous.Entities.RawTypes as Raw
-import           Xanthous.Entities
+import           Xanthous.Game.State
-                 ( Draw(..)
-                 , Entity(..)
-                 , DrawRawChar(..)
-                 , Brain(..)
-                 , Brainless(..)
-                 , brainVia
-                 )
 --------------------------------------------------------------------------------
 
 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

src/Xanthous/Entities/RawTypes.hs

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

src/Xanthous/Entities/Raws.hs

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

src/Xanthous/Game/Arbitrary.hs

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

src/Xanthous/Game/Draw.hs

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

src/Xanthous/Game/Lenses.hs

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

src/Xanthous/Game/Prompt.hs

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

src/Xanthous/Game/State.hs

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

src/Xanthous/Orphans.hs

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

src/Xanthous/Prelude.hs

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

src/Xanthous/messages.yaml

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

test/Spec.hs

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

test/Xanthous/Data/EntityCharSpec.hs

@@ -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"
+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
-    ]
   ]

test/Xanthous/GameSpec.hs

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

xanthous.cabal

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