about summary refs log tree commit diff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Xanthous/AI/Gormlak.hs4
-rw-r--r--src/Xanthous/AI/Gormlak.hs-boot2
-rw-r--r--src/Xanthous/App.hs47
-rw-r--r--src/Xanthous/Data/EntityChar.hs56
-rw-r--r--src/Xanthous/Data/EntityMap/Graphics.hs2
-rw-r--r--src/Xanthous/Entities.hs146
-rw-r--r--src/Xanthous/Entities/Character.hs3
-rw-r--r--src/Xanthous/Entities/Creature.hs2
-rw-r--r--src/Xanthous/Entities/Entities.hs2
-rw-r--r--src/Xanthous/Entities/Environment.hs12
-rw-r--r--src/Xanthous/Entities/Item.hs10
-rw-r--r--src/Xanthous/Entities/RawTypes.hs3
-rw-r--r--src/Xanthous/Entities/Raws.hs2
-rw-r--r--src/Xanthous/Game/Arbitrary.hs4
-rw-r--r--src/Xanthous/Game/Draw.hs2
-rw-r--r--src/Xanthous/Game/Lenses.hs8
-rw-r--r--src/Xanthous/Game/Prompt.hs9
-rw-r--r--src/Xanthous/Game/State.hs85
-rw-r--r--src/Xanthous/Orphans.hs1
-rw-r--r--src/Xanthous/Prelude.hs6
-rw-r--r--src/Xanthous/messages.yaml4
21 files changed, 214 insertions, 196 deletions
diff --git a/src/Xanthous/AI/Gormlak.hs b/src/Xanthous/AI/Gormlak.hs
index 268e33ad6caa..8b30bc2c9de0 100644
--- a/src/Xanthous/AI/Gormlak.hs
+++ b/src/Xanthous/AI/Gormlak.hs
@@ -24,8 +24,7 @@ import           Xanthous.Entities.Creature
 import           Xanthous.Entities.Character (Character)
 import qualified Xanthous.Entities.Character as Character
 import qualified Xanthous.Entities.RawTypes as Raw
-import           Xanthous.Entities (Entity(..), Brain(..), brainVia)
-import           Xanthous.Game.State (entities, GameState, entityIs)
+import           Xanthous.Game.State
 import           Xanthous.Game.Lenses
                  ( Collision(..), entityCollision, collisionAt
                  , character, characterPosition
@@ -99,3 +98,4 @@ instance Brain Creature where step = brainVia GormlakBrain
 instance Entity Creature where
   blocksVision _ = False
   description = view $ Creature.creatureType . Raw.description
+  entityChar = view $ Creature.creatureType . char
diff --git a/src/Xanthous/AI/Gormlak.hs-boot b/src/Xanthous/AI/Gormlak.hs-boot
index 391a8a807f8c..47e62f624905 100644
--- a/src/Xanthous/AI/Gormlak.hs-boot
+++ b/src/Xanthous/AI/Gormlak.hs-boot
@@ -1,7 +1,7 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Xanthous.AI.Gormlak where
 
-import Xanthous.Entities
+import Xanthous.Game.State
 import Xanthous.Entities.Creature
 
 instance Entity Creature
diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs
index 13c4af1246d5..76e03e860999 100644
--- a/src/Xanthous/App.hs
+++ b/src/Xanthous/App.hs
@@ -30,6 +30,7 @@ import           Xanthous.Data
 import           Xanthous.Data.EntityMap (EntityMap)
 import qualified Xanthous.Data.EntityMap as EntityMap
 import           Xanthous.Game
+import           Xanthous.Game.State
 import           Xanthous.Game.Draw (drawGame)
 import           Xanthous.Game.Prompt
 import           Xanthous.Monad
@@ -38,8 +39,7 @@ import qualified Xanthous.Messages as Messages
 import           Xanthous.Util.Inflection (toSentence)
 --------------------------------------------------------------------------------
 import qualified Xanthous.Entities.Character as Character
-import           Xanthous.Entities.Character
-import           Xanthous.Entities
+import           Xanthous.Entities.Character hiding (pickUpItem)
 import           Xanthous.Entities.Item (Item)
 import qualified Xanthous.Entities.Item as Item
 import           Xanthous.Entities.Creature (Creature)
@@ -138,16 +138,19 @@ handleCommand (Move dir) = do
 
 handleCommand PickUp = do
   pos <- use characterPosition
-  items <- uses entities $ entitiesAtPositionWithType @Item pos
-  case items of
-    [] -> say_ ["items", "nothingToPickUp"]
-    [(itemID, item)] -> do
+  uses entities (entitiesAtPositionWithType @Item pos) >>= \case
+    [] -> say_ ["pickUp", "nothingToPickUp"]
+    [item] -> pickUpItem item
+    items ->
+      menu_ ["pickUp", "menu"] Cancellable (entityMenu_ items)
+      $ \(MenuResult item) -> pickUpItem item
+  continue
+  where
+    pickUpItem (itemID, item) = do
       character %= Character.pickUpItem item
       entities . at itemID .= Nothing
-      say ["items", "pickUp"] $ object [ "item" A..= item ]
+      say ["pickUp", "pickUp"] $ object [ "item" A..= item ]
       stepGameBy 100 -- TODO
-    _ -> undefined
-  continue
 
 handleCommand PreviousMessage = do
   messageHistory %= previousMessage
@@ -188,6 +191,7 @@ handleCommand Eat = do
         let foodMenuItem idx (item, edibleItem)
               = ( item ^. Item.itemType . char . char
                 , MenuOption (description item) (idx, item, edibleItem))
+                -- TODO refactor to use entityMenu_
             menuItems = mkMenuItems $ imap foodMenuItem food
         in menu_ ["eat", "menuPrompt"] Cancellable menuItems
           $ \(MenuResult (idx, item, edibleItem)) -> do
@@ -265,6 +269,8 @@ handlePromptEvent
        >> continue
 handlePromptEvent _ (Prompt _ SPointOnMap _ _ _) _ = continue
 
+handlePromptEvent _ _ _ = continue
+
 clearPrompt :: AppM (Next GameState)
 clearPrompt = promptState .= NoPrompt >> continue
 
@@ -330,7 +336,6 @@ menu_ :: forall (a :: Type).
       -> AppM ()
 menu_ msgPath = menu msgPath $ object []
 
-
 --------------------------------------------------------------------------------
 
 entitiesAtPositionWithType
@@ -374,7 +379,9 @@ attackAt pos =
   uses entities (entitiesAtPositionWithType @Creature pos) >>= \case
     Empty               -> say_ ["combat", "nothingToAttack"]
     (creature :< Empty) -> attackCreature creature
-    creatures           -> undefined
+    creatures ->
+      menu_ ["combat", "menu"] Cancellable (entityMenu_ creatures)
+      $ \(MenuResult creature) -> attackCreature creature
  where
   attackCreature (creatureID, creature) = do
     charDamage <- use $ character . characterDamage
@@ -388,3 +395,21 @@ attackAt pos =
         say ["combat", "hit"] msgParams
         entities . ix creatureID . positioned .= SomeEntity creature'
     stepGame -- TODO
+
+entityMenu_
+  :: (Comonad w, Entity entity)
+  => [w entity]
+  -> Map Char (MenuOption (w entity))
+entityMenu_ = mkMenuItems @[_] . map entityMenuItem
+  where
+    entityMenuItem wentity
+      = let entity = extract wentity
+      in (entityMenuChar entity, MenuOption (description entity) wentity)
+    entityMenuChar entity
+      = let ec = entityChar entity ^. char
+        in if ec `elem` (['a'..'z'] ++ ['A'..'Z'])
+           then ec
+           else 'a'
+
+entityMenu :: Entity entity => [entity] -> Map Char (MenuOption entity)
+entityMenu = map (map runIdentity) . entityMenu_ . fmap Identity
diff --git a/src/Xanthous/Data/EntityChar.hs b/src/Xanthous/Data/EntityChar.hs
new file mode 100644
index 000000000000..7aeb5fdf86a0
--- /dev/null
+++ b/src/Xanthous/Data/EntityChar.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE RoleAnnotations      #-}
+{-# LANGUAGE RecordWildCards      #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE GADTs                #-}
+{-# LANGUAGE AllowAmbiguousTypes  #-}
+{-# LANGUAGE TemplateHaskell      #-}
+--------------------------------------------------------------------------------
+module Xanthous.Data.EntityChar
+  ( EntityChar(..)
+  , HasChar(..)
+  , HasStyle(..)
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding ((.=))
+--------------------------------------------------------------------------------
+import qualified Graphics.Vty.Attributes as Vty
+import           Test.QuickCheck
+import           Data.Aeson
+--------------------------------------------------------------------------------
+import           Xanthous.Orphans ()
+import           Xanthous.Util.QuickCheck (GenericArbitrary(..))
+--------------------------------------------------------------------------------
+
+
+class HasChar s a | s -> a where
+  char :: Lens' s a
+  {-# MINIMAL char #-}
+
+data EntityChar = EntityChar
+  { _char :: Char
+  , _style :: Vty.Attr
+  }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary EntityChar
+makeFieldsNoPrefix ''EntityChar
+
+instance FromJSON EntityChar where
+  parseJSON (String (chr :< Empty)) = pure $ EntityChar chr Vty.defAttr
+  parseJSON (Object o) = do
+    (EntityChar _char _) <- o .: "char"
+    _style <- o .:? "style" .!= Vty.defAttr
+    pure EntityChar {..}
+  parseJSON _ = fail "Invalid type, expected string or object"
+
+instance ToJSON EntityChar where
+  toJSON (EntityChar chr styl)
+    | styl == Vty.defAttr = String $ chr <| Empty
+    | otherwise = object
+      [ "char" .= chr
+      , "style" .= styl
+      ]
+
+instance IsString EntityChar where
+  fromString [ch] = EntityChar ch Vty.defAttr
+  fromString _ = error "Entity char must only be a single character"
diff --git a/src/Xanthous/Data/EntityMap/Graphics.hs b/src/Xanthous/Data/EntityMap/Graphics.hs
index ace5ae49e804..30c6d096737e 100644
--- a/src/Xanthous/Data/EntityMap/Graphics.hs
+++ b/src/Xanthous/Data/EntityMap/Graphics.hs
@@ -12,7 +12,7 @@ import Xanthous.Prelude hiding (lines)
 import Xanthous.Util (takeWhileInclusive)
 import Xanthous.Data
 import Xanthous.Data.EntityMap
-import Xanthous.Entities
+import Xanthous.Game.State
 import Xanthous.Util.Graphics (circle, line)
 --------------------------------------------------------------------------------
 
diff --git a/src/Xanthous/Entities.hs b/src/Xanthous/Entities.hs
deleted file mode 100644
index 7f4efb71d17e..000000000000
--- a/src/Xanthous/Entities.hs
+++ /dev/null
@@ -1,146 +0,0 @@
-{-# LANGUAGE RoleAnnotations      #-}
-{-# LANGUAGE RecordWildCards      #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE GADTs                #-}
-{-# LANGUAGE AllowAmbiguousTypes  #-}
-{-# LANGUAGE TemplateHaskell      #-}
---------------------------------------------------------------------------------
-module Xanthous.Entities
-  ( Draw(..)
-  , DrawCharacter(..)
-  , DrawStyledCharacter(..)
-  , DrawRawChar(..)
-  , DrawRawCharPriority(..)
-  , Entity(..)
-  , SomeEntity(..)
-  , downcastEntity
-  , entityIs
-  , _SomeEntity
-
-  , Color(..)
-  , KnownColor(..)
-
-  , EntityChar(..)
-  , HasChar(..)
-  , HasStyle(..)
-
-  , Brain(..)
-  , Brainless(..)
-  , brainVia
-  ) where
---------------------------------------------------------------------------------
-import           Xanthous.Prelude hiding ((.=))
---------------------------------------------------------------------------------
-import           Brick
-import qualified Graphics.Vty.Attributes as Vty
-import qualified Graphics.Vty.Image as Vty
-import           Data.Aeson
-import           Data.Typeable (Proxy(..))
-import           Data.Generics.Product.Fields
-import           Test.QuickCheck
-import           Test.QuickCheck.Arbitrary.Generic
---------------------------------------------------------------------------------
-import           Xanthous.Orphans ()
-import           Xanthous.Game.State
---------------------------------------------------------------------------------
-
-newtype DrawCharacter (char :: Symbol) (a :: Type) where
-  DrawCharacter :: a -> DrawCharacter char a
-
-instance KnownSymbol char => Draw (DrawCharacter char a) where
-  draw _ = str $ symbolVal @char Proxy
-
---------------------------------------------------------------------------------
-
-data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White
-
-class KnownColor (color :: Color) where
-  colorVal :: forall proxy. proxy color -> Vty.Color
-
-instance KnownColor 'Black where colorVal _ = Vty.black
-instance KnownColor 'Red where colorVal _ = Vty.red
-instance KnownColor 'Green where colorVal _ = Vty.green
-instance KnownColor 'Yellow where colorVal _ = Vty.yellow
-instance KnownColor 'Blue where colorVal _ = Vty.blue
-instance KnownColor 'Magenta where colorVal _ = Vty.magenta
-instance KnownColor 'Cyan where colorVal _ = Vty.cyan
-instance KnownColor 'White where colorVal _ = Vty.white
-
-newtype DrawStyledCharacter (fg :: Color) (bg :: Color) (char :: Symbol) (a :: Type) where
-  DrawStyledCharacter :: a -> DrawStyledCharacter fg bg char a
-
-instance
-  ( KnownColor fg
-  , KnownColor bg
-  , KnownSymbol char
-  )
-  => Draw (DrawStyledCharacter fg bg char a) where
-  draw _ = raw $ Vty.string attr $ symbolVal @char Proxy
-    where attr = Vty.Attr
-            { Vty.attrStyle = Vty.Default
-            , Vty.attrForeColor = Vty.SetTo $ colorVal @fg Proxy
-            , Vty.attrBackColor = Vty.SetTo $ colorVal @bg Proxy
-            , Vty.attrURL = Vty.Default
-            }
-
---------------------------------------------------------------------------------
-
-class HasChar s a | s -> a where
-  char :: Lens' s a
-  {-# MINIMAL char #-}
-
-newtype DrawRawChar (rawField :: Symbol) (a :: Type) = DrawRawChar a
-
-instance
-  forall rawField a raw.
-  ( HasField rawField a a raw raw
-  , HasChar raw EntityChar
-  ) => Draw (DrawRawChar rawField a) where
-  draw (DrawRawChar e) = draw $ e ^. field @rawField . char
-
-newtype DrawRawCharPriority
-  (rawField :: Symbol)
-  (priority :: Nat)
-  (a :: Type)
-  = DrawRawCharPriority a
-
-instance
-  forall rawField priority a raw.
-  ( HasField rawField a a raw raw
-  , KnownNat priority
-  , HasChar raw EntityChar
-  ) => Draw (DrawRawCharPriority rawField priority a) where
-  draw (DrawRawCharPriority e) = draw $ e ^. field @rawField . char
-  drawPriority = const . fromIntegral $ natVal @priority Proxy
-
---------------------------------------------------------------------------------
-
-data EntityChar = EntityChar
-  { _char :: Char
-  , _style :: Vty.Attr
-  }
-  deriving stock (Show, Eq, Generic)
-  deriving anyclass (NFData, CoArbitrary, Function)
-makeFieldsNoPrefix ''EntityChar
-
-instance Arbitrary EntityChar where
-  arbitrary = genericArbitrary
-
-instance FromJSON EntityChar where
-  parseJSON (String (chr :< Empty)) = pure $ EntityChar chr Vty.defAttr
-  parseJSON (Object o) = do
-    (EntityChar _char _) <- o .: "char"
-    _style <- o .:? "style" .!= Vty.defAttr
-    pure EntityChar {..}
-  parseJSON _ = fail "Invalid type, expected string or object"
-
-instance ToJSON EntityChar where
-  toJSON (EntityChar chr styl)
-    | styl == Vty.defAttr = String $ chr <| Empty
-    | otherwise = object
-      [ "char" .= chr
-      , "style" .= styl
-      ]
-
-instance Draw EntityChar where
-  draw EntityChar{..} = raw $ Vty.string _style [_char]
diff --git a/src/Xanthous/Entities/Character.hs b/src/Xanthous/Entities/Character.hs
index cc04340f6e24..22589252acce 100644
--- a/src/Xanthous/Entities/Character.hs
+++ b/src/Xanthous/Entities/Character.hs
@@ -27,7 +27,7 @@ import Data.Aeson.Generic.DerivingVia
 import Data.Aeson (ToJSON, FromJSON)
 import Data.Coerce (coerce)
 --------------------------------------------------------------------------------
-import Xanthous.Entities
+import Xanthous.Game.State
 import Xanthous.Entities.Item
 import Xanthous.Data (TicksPerTile, Hitpoints, Per, Ticks, (|*|), positioned)
 --------------------------------------------------------------------------------
@@ -68,6 +68,7 @@ instance Brain Character where
 instance Entity Character where
   blocksVision _ = False
   description _ = "yourself"
+  entityChar _ = "@"
 
 instance Arbitrary Character where
   arbitrary = genericArbitrary
diff --git a/src/Xanthous/Entities/Creature.hs b/src/Xanthous/Entities/Creature.hs
index 11cad1ce6b8b..de9122746bcf 100644
--- a/src/Xanthous/Entities/Creature.hs
+++ b/src/Xanthous/Entities/Creature.hs
@@ -35,7 +35,7 @@ import           Data.Aeson.Generic.DerivingVia
 import           Data.Aeson (ToJSON, FromJSON)
 --------------------------------------------------------------------------------
 import           Xanthous.Entities.RawTypes hiding (Creature, description)
-import           Xanthous.Entities (Draw(..), DrawRawCharPriority(..))
+import           Xanthous.Game.State
 import           Xanthous.Data
 --------------------------------------------------------------------------------
 
diff --git a/src/Xanthous/Entities/Entities.hs b/src/Xanthous/Entities/Entities.hs
index 410a6514ae4f..7e41fc8b7b3a 100644
--- a/src/Xanthous/Entities/Entities.hs
+++ b/src/Xanthous/Entities/Entities.hs
@@ -9,7 +9,6 @@ import           Test.QuickCheck
 import qualified Test.QuickCheck.Gen as Gen
 import           Data.Aeson
 --------------------------------------------------------------------------------
-import           Xanthous.Entities (Entity(..), SomeEntity(..))
 import           Xanthous.Entities.Character
 import           Xanthous.Entities.Item
 import           Xanthous.Entities.Creature
@@ -46,6 +45,7 @@ deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameState
 instance Entity SomeEntity where
   blocksVision (SomeEntity ent) = blocksVision ent
   description (SomeEntity ent) = description ent
+  entityChar (SomeEntity ent) = entityChar ent
 
 instance Function SomeEntity where
   function = functionJSON
diff --git a/src/Xanthous/Entities/Environment.hs b/src/Xanthous/Entities/Environment.hs
index 811919963122..8baa07650f7c 100644
--- a/src/Xanthous/Entities/Environment.hs
+++ b/src/Xanthous/Entities/Environment.hs
@@ -14,17 +14,9 @@ import Brick.Widgets.Border.Style (unicode)
 import Brick.Types (Edges(..))
 import Data.Aeson
 --------------------------------------------------------------------------------
-import Xanthous.Entities
-       ( Draw(..)
-       , entityIs
-       , Entity(..)
-       , SomeEntity
-       , Brain(..)
-       , Brainless(..)
-       , brainVia
-       )
 import Xanthous.Entities.Draw.Util
 import Xanthous.Data
+import Xanthous.Game.State
 --------------------------------------------------------------------------------
 
 data Wall = Wall
@@ -45,6 +37,7 @@ instance Brain Wall where step = brainVia Brainless
 instance Entity Wall where
   blocksVision _ = True
   description _ = "a wall"
+  entityChar _ = "┼"
 
 instance Arbitrary Wall where
   arbitrary = pure Wall
@@ -90,3 +83,4 @@ instance Brain Door where step = brainVia Brainless
 instance Entity Door where
   blocksVision = not . view open
   description _ = "a door"
+  entityChar _ = "d"
diff --git a/src/Xanthous/Entities/Item.hs b/src/Xanthous/Entities/Item.hs
index ddd387af8c78..465110069c1d 100644
--- a/src/Xanthous/Entities/Item.hs
+++ b/src/Xanthous/Entities/Item.hs
@@ -15,14 +15,7 @@ import           Data.Aeson.Generic.DerivingVia
 --------------------------------------------------------------------------------
 import           Xanthous.Entities.RawTypes hiding (Item, description, isEdible)
 import qualified Xanthous.Entities.RawTypes as Raw
-import           Xanthous.Entities
-                 ( Draw(..)
-                 , Entity(..)
-                 , DrawRawChar(..)
-                 , Brain(..)
-                 , Brainless(..)
-                 , brainVia
-                 )
+import           Xanthous.Game.State
 --------------------------------------------------------------------------------
 
 data Item = Item
@@ -47,6 +40,7 @@ instance Arbitrary Item where
 instance Entity Item where
   blocksVision _ = False
   description = view $ itemType . Raw.description
+  entityChar = view $ itemType . Raw.char
 
 newWithType :: ItemType -> Item
 newWithType = Item
diff --git a/src/Xanthous/Entities/RawTypes.hs b/src/Xanthous/Entities/RawTypes.hs
index 09b250fb310d..f715f8743ab1 100644
--- a/src/Xanthous/Entities/RawTypes.hs
+++ b/src/Xanthous/Entities/RawTypes.hs
@@ -10,6 +10,7 @@ module Xanthous.Entities.RawTypes
 
   , _Creature
     -- * Lens classes
+  , HasChar(..)
   , HasName(..)
   , HasDescription(..)
   , HasLongDescription(..)
@@ -27,9 +28,9 @@ import Test.QuickCheck.Arbitrary.Generic
 import Data.Aeson.Generic.DerivingVia
 import Data.Aeson (ToJSON, FromJSON)
 --------------------------------------------------------------------------------
-import Xanthous.Entities (EntityChar, HasChar(..))
 import Xanthous.Messages (Message(..))
 import Xanthous.Data (TicksPerTile, Hitpoints)
+import Xanthous.Data.EntityChar
 --------------------------------------------------------------------------------
 data CreatureType = CreatureType
   { _name         :: !Text
diff --git a/src/Xanthous/Entities/Raws.hs b/src/Xanthous/Entities/Raws.hs
index 9b7d63c6c4c5..d4cae7ccc299 100644
--- a/src/Xanthous/Entities/Raws.hs
+++ b/src/Xanthous/Entities/Raws.hs
@@ -14,7 +14,7 @@ import           Xanthous.Prelude
 import           System.FilePath.Posix
 --------------------------------------------------------------------------------
 import           Xanthous.Entities.RawTypes
-import           Xanthous.Entities
+import           Xanthous.Game.State
 import qualified Xanthous.Entities.Creature as Creature
 import qualified Xanthous.Entities.Item as Item
 import           Xanthous.AI.Gormlak ()
diff --git a/src/Xanthous/Game/Arbitrary.hs b/src/Xanthous/Game/Arbitrary.hs
index e8f9ae22c461..090eba634d4b 100644
--- a/src/Xanthous/Game/Arbitrary.hs
+++ b/src/Xanthous/Game/Arbitrary.hs
@@ -18,11 +18,11 @@ import qualified Xanthous.Data.EntityMap as EntityMap
 
 instance Arbitrary GameState where
   arbitrary = do
-    char <- arbitrary @Character
+    chr <- arbitrary @Character
     charPos <- arbitrary
     _messageHistory <- arbitrary
     (_characterEntityID, _entities) <- arbitrary <&>
-      EntityMap.insertAtReturningID charPos (SomeEntity char)
+      EntityMap.insertAtReturningID charPos (SomeEntity chr)
     _revealedPositions <- fmap setFromList . sublistOf $ EntityMap.positions _entities
     _randomGen <- mkStdGen <$> arbitrary
     let _promptState = NoPrompt -- TODO
diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs
index 2f7ccf29f795..ab0e31f8a04a 100644
--- a/src/Xanthous/Game/Draw.hs
+++ b/src/Xanthous/Game/Draw.hs
@@ -12,7 +12,7 @@ import           Brick.Widgets.Edit
 import           Xanthous.Data
 import           Xanthous.Data.EntityMap (EntityMap, atPosition)
 import qualified Xanthous.Data.EntityMap as EntityMap
-import           Xanthous.Entities
+import           Xanthous.Game.State
 import           Xanthous.Entities.Character
 import           Xanthous.Game
                  ( GameState(..)
diff --git a/src/Xanthous/Game/Lenses.hs b/src/Xanthous/Game/Lenses.hs
index cd7148442ace..7dbd60290144 100644
--- a/src/Xanthous/Game/Lenses.hs
+++ b/src/Xanthous/Game/Lenses.hs
@@ -37,11 +37,11 @@ getInitialState = initialStateFromSeed <$> getRandom
 initialStateFromSeed :: Int -> GameState
 initialStateFromSeed seed =
   let _randomGen = mkStdGen seed
-      char = mkCharacter
+      chr = mkCharacter
       (_characterEntityID, _entities)
         = EntityMap.insertAtReturningID
           (Position 0 0)
-          (SomeEntity char)
+          (SomeEntity chr)
           mempty
       _messageHistory = mempty
       _revealedPositions = mempty
@@ -56,10 +56,10 @@ positionedCharacter :: Lens' GameState (Positioned Character)
 positionedCharacter = lens getPositionedCharacter setPositionedCharacter
   where
     setPositionedCharacter :: GameState -> Positioned Character -> GameState
-    setPositionedCharacter game char
+    setPositionedCharacter game chr
       = game
       &  entities . at (game ^. characterEntityID)
-      ?~ fmap SomeEntity char
+      ?~ fmap SomeEntity chr
 
     getPositionedCharacter :: GameState -> Positioned Character
     getPositionedCharacter game
diff --git a/src/Xanthous/Game/Prompt.hs b/src/Xanthous/Game/Prompt.hs
index 6c3629f31055..8e9ec04ccb33 100644
--- a/src/Xanthous/Game/Prompt.hs
+++ b/src/Xanthous/Game/Prompt.hs
@@ -1,6 +1,8 @@
+{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE DeriveFunctor #-}
 --------------------------------------------------------------------------------
 module Xanthous.Game.Prompt
   ( PromptType(..)
@@ -25,6 +27,7 @@ import Xanthous.Prelude
 import           Brick.Widgets.Edit (Editor, editorText, getEditContents)
 import           Test.QuickCheck
 import           Test.QuickCheck.Arbitrary.Generic
+import           Control.Comonad
 --------------------------------------------------------------------------------
 import           Xanthous.Util (smallestNotIn)
 import           Xanthous.Data (Direction, Position)
@@ -159,9 +162,13 @@ instance CoArbitrary (PromptState ('Menu a)) where
 deriving stock instance Show (PromptState pt)
 
 data MenuOption a = MenuOption Text a
-  deriving stock (Eq, Generic)
+  deriving stock (Eq, Generic, Functor)
   deriving anyclass (NFData, CoArbitrary, Function)
 
+instance Comonad MenuOption where
+  extract (MenuOption _ x) = x
+  extend cok mo@(MenuOption text _) = MenuOption text (cok mo)
+
 mkMenuItems :: (MonoFoldable f, Element f ~ (Char, MenuOption a))
             => f
             -> Map Char (MenuOption a)
diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs
index 92c68a3f65c0..16d93c61bae6 100644
--- a/src/Xanthous/Game/State.hs
+++ b/src/Xanthous/Game/State.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE TemplateHaskell     #-}
 {-# LANGUAGE GADTs               #-}
@@ -36,6 +37,13 @@ module Xanthous.Game.State
   , downcastEntity
   , _SomeEntity
   , entityIs
+  , DrawRawChar(..)
+  , DrawRawCharPriority(..)
+  , DrawCharacter(..)
+  , DrawStyledCharacter(..)
+    -- ** Field classes
+  , HasChar(..)
+  , HasStyle(..)
 
     -- * Debug State
   , DebugState(..)
@@ -55,13 +63,18 @@ import           Test.QuickCheck.Arbitrary.Generic
 import           Control.Monad.State.Class
 import           Control.Monad.State
 import           Control.Monad.Random.Class
-import           Brick (EventM, Widget)
+import           Brick (EventM, Widget, raw, str)
 import           Data.Aeson (ToJSON(..), FromJSON(..), Value(Null))
 import qualified Data.Aeson as JSON
 import           Data.Aeson.Generic.DerivingVia
+import           Data.Generics.Product.Fields
+import qualified Graphics.Vty.Attributes as Vty
+import qualified Graphics.Vty.Image as Vty
+import           Control.Comonad
 --------------------------------------------------------------------------------
-import           Xanthous.Data.EntityMap (EntityMap, EntityID)
 import           Xanthous.Data
+import           Xanthous.Data.EntityMap (EntityMap, EntityID)
+import           Xanthous.Data.EntityChar
 import           Xanthous.Orphans ()
 import           Xanthous.Game.Prompt
 import           Xanthous.Resource
@@ -181,6 +194,73 @@ instance Draw a => Draw (Positioned a) where
   drawWithNeighbors ns (Positioned _ a) = drawWithNeighbors ns a
   draw (Positioned _ a) = draw a
 
+newtype DrawCharacter (char :: Symbol) (a :: Type) where
+  DrawCharacter :: a -> DrawCharacter char a
+
+instance KnownSymbol char => Draw (DrawCharacter char a) where
+  draw _ = str $ symbolVal @char Proxy
+
+data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White
+
+class KnownColor (color :: Color) where
+  colorVal :: forall proxy. proxy color -> Vty.Color
+
+instance KnownColor 'Black where colorVal _ = Vty.black
+instance KnownColor 'Red where colorVal _ = Vty.red
+instance KnownColor 'Green where colorVal _ = Vty.green
+instance KnownColor 'Yellow where colorVal _ = Vty.yellow
+instance KnownColor 'Blue where colorVal _ = Vty.blue
+instance KnownColor 'Magenta where colorVal _ = Vty.magenta
+instance KnownColor 'Cyan where colorVal _ = Vty.cyan
+instance KnownColor 'White where colorVal _ = Vty.white
+
+newtype DrawStyledCharacter (fg :: Color) (bg :: Color) (char :: Symbol) (a :: Type) where
+  DrawStyledCharacter :: a -> DrawStyledCharacter fg bg char a
+
+instance
+  ( KnownColor fg
+  , KnownColor bg
+  , KnownSymbol char
+  )
+  => Draw (DrawStyledCharacter fg bg char a) where
+  draw _ = raw $ Vty.string attr $ symbolVal @char Proxy
+    where attr = Vty.Attr
+            { Vty.attrStyle = Vty.Default
+            , Vty.attrForeColor = Vty.SetTo $ colorVal @fg Proxy
+            , Vty.attrBackColor = Vty.SetTo $ colorVal @bg Proxy
+            , Vty.attrURL = Vty.Default
+            }
+
+instance Draw EntityChar where
+  draw EntityChar{..} = raw $ Vty.string _style [_char]
+
+--------------------------------------------------------------------------------
+
+newtype DrawRawChar (rawField :: Symbol) (a :: Type) = DrawRawChar a
+
+instance
+  forall rawField a raw.
+  ( HasField rawField a a raw raw
+  , HasChar raw EntityChar
+  ) => Draw (DrawRawChar rawField a) where
+  draw (DrawRawChar e) = draw $ e ^. field @rawField . char
+
+newtype DrawRawCharPriority
+  (rawField :: Symbol)
+  (priority :: Nat)
+  (a :: Type)
+  = DrawRawCharPriority a
+
+instance
+  forall rawField priority a raw.
+  ( HasField rawField a a raw raw
+  , KnownNat priority
+  , HasChar raw EntityChar
+  ) => Draw (DrawRawCharPriority rawField priority a) where
+  draw (DrawRawCharPriority e) = draw $ e ^. field @rawField . char
+  drawPriority = const . fromIntegral $ natVal @priority Proxy
+
+
 --------------------------------------------------------------------------------
 
 class Brain a where
@@ -208,6 +288,7 @@ class ( Show a, Eq a, NFData a
       ) => Entity a where
   blocksVision :: a -> Bool
   description :: a -> Text
+  entityChar :: a -> EntityChar
 
 data SomeEntity where
   SomeEntity :: forall a. (Entity a, Typeable a) => a -> SomeEntity
diff --git a/src/Xanthous/Orphans.hs b/src/Xanthous/Orphans.hs
index 6714a3bc5610..bb6b0d024e32 100644
--- a/src/Xanthous/Orphans.hs
+++ b/src/Xanthous/Orphans.hs
@@ -21,7 +21,6 @@ import           Data.Text.Zipper.Generic (GenericTextZipper)
 import           Brick.Widgets.Core (getName)
 import           System.Random (StdGen)
 import           Test.QuickCheck
-import           Test.QuickCheck.Arbitrary.Generic
 import           Text.Megaparsec (errorBundlePretty)
 import           Text.Megaparsec.Pos
 import           Text.Mustache
diff --git a/src/Xanthous/Prelude.hs b/src/Xanthous/Prelude.hs
index 756642440b7e..b17fd2897bb1 100644
--- a/src/Xanthous/Prelude.hs
+++ b/src/Xanthous/Prelude.hs
@@ -1,3 +1,4 @@
+--------------------------------------------------------------------------------
 module Xanthous.Prelude
   ( module ClassyPrelude
   , Type
@@ -5,11 +6,14 @@ module Xanthous.Prelude
   , module GHC.TypeLits
   , module Control.Lens
   , module Data.Void
+  , module Control.Comonad
   ) where
-
+--------------------------------------------------------------------------------
 import ClassyPrelude hiding
   (return, (<|), unsnoc, uncons, cons, snoc, index, (<.>), Index, say)
 import Data.Kind
 import GHC.TypeLits hiding (Text)
 import Control.Lens
 import Data.Void
+import Control.Comonad
+--------------------------------------------------------------------------------
diff --git a/src/Xanthous/messages.yaml b/src/Xanthous/messages.yaml
index 71f08f263185..ae9ca060bfef 100644
--- a/src/Xanthous/messages.yaml
+++ b/src/Xanthous/messages.yaml
@@ -12,7 +12,8 @@ save:
 entities:
   description: You see here {{entityDescriptions}}
 
-items:
+pickUp:
+  menu: What would you like to pick up?
   pickUp: You pick up the {{item.itemType.name}}
   nothingToPickUp: "There's nothing here to pick up"
 
@@ -31,6 +32,7 @@ character:
 
 combat:
   nothingToAttack: There's nothing to attack there.
+  menu: Which creature would you like to attack?
   hit:
     - You hit the {{creature.creatureType.name}}.
     - You attack the {{creature.creatureType.name}}.
generated by cgit-pink 1.4.1 (git 2.44.2) at 2024-11-14T18·27+0000