about summary refs log tree commit diff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Xanthous/App.hs87
-rw-r--r--src/Xanthous/Data/EntityMap.hs27
-rw-r--r--src/Xanthous/Entities/Character.hs9
-rw-r--r--src/Xanthous/Game.hs44
-rw-r--r--src/Xanthous/Game/Draw.hs68
-rw-r--r--src/Xanthous/Game/Prompt.hs117
-rw-r--r--src/Xanthous/Monad.hs39
-rw-r--r--src/Xanthous/Resource.hs1
-rw-r--r--src/Xanthous/messages.yaml4
-rw-r--r--test/Xanthous/Data/EntityMapSpec.hs5
-rw-r--r--test/Xanthous/GameSpec.hs3
-rw-r--r--xanthous.cabal4
12 files changed, 312 insertions, 96 deletions
diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs
index 0f49b4d800..0c7b85541a 100644
--- a/src/Xanthous/App.hs
+++ b/src/Xanthous/App.hs
@@ -4,11 +4,13 @@ module Xanthous.App (makeApp) where
 import           Xanthous.Prelude
 import           Brick hiding (App, halt, continue, raw)
 import qualified Brick
+import           Brick.Widgets.Edit (handleEditorEvent)
 import           Graphics.Vty.Attributes (defAttr)
-import           Graphics.Vty.Input.Events (Event(EvKey))
-import           Control.Monad.State (get)
+import           Graphics.Vty.Input.Events (Event(EvKey), Key(..))
+import           Control.Monad.State (get, state, StateT(..))
+import           Data.Coerce
 import           Control.Monad.State.Class (modify)
-import           Data.Aeson (object)
+import           Data.Aeson (object, ToJSON)
 import qualified Data.Aeson as A
 --------------------------------------------------------------------------------
 import           Xanthous.Command
@@ -20,14 +22,13 @@ import           Xanthous.Data
 import qualified Xanthous.Data.EntityMap as EntityMap
 import           Xanthous.Game
 import           Xanthous.Game.Draw (drawGame)
+import           Xanthous.Game.Prompt
 import           Xanthous.Monad
 import           Xanthous.Resource (Name)
+import           Xanthous.Messages (message)
 --------------------------------------------------------------------------------
-import           Xanthous.Entities.Creature (Creature)
-import qualified Xanthous.Entities.Creature as Creature
 import qualified Xanthous.Entities.Character as Character
-import           Xanthous.Entities.RawTypes (EntityRaw(..))
-import           Xanthous.Entities.Raws (raw)
+import           Xanthous.Entities.Character (characterName)
 import           Xanthous.Entities
 import           Xanthous.Entities.Item (Item)
 import           Xanthous.Generators
@@ -41,7 +42,7 @@ makeApp :: IO App
 makeApp = pure $ Brick.App
   { appDraw = drawGame
   , appChooseCursor = const headMay
-  , appHandleEvent = \state event -> runAppM (handleEvent event) state
+  , appHandleEvent = \game event -> runAppM (handleEvent event) game
   , appStartEvent = runAppM $ startEvent >> get
   , appAttrMap = const $ attrMap defAttr []
   }
@@ -49,14 +50,13 @@ makeApp = pure $ Brick.App
 runAppM :: AppM a -> GameState -> EventM Name a
 runAppM appm = fmap fst . runAppT appm
 
-testGormlak :: Creature
-testGormlak =
-  let Just (Creature gormlak) = raw "gormlak"
-  in Creature.newWithType gormlak
+-- testGormlak :: Creature
+-- testGormlak =
+--   let Just (Creature gormlak) = raw "gormlak"
+--   in Creature.newWithType gormlak
 
 startEvent :: AppM ()
 startEvent = do
-  say_ ["welcome"]
   level <-
     generateLevel SCaveAutomata CaveAutomata.defaultParams
     $ Dimensions 80 80
@@ -64,15 +64,23 @@ startEvent = do
   entities <>= (SomeEntity <$> level ^. levelItems)
   characterPosition .= level ^. levelCharacterPosition
   modify updateCharacterVision
-  -- entities %= EntityMap.insertAt (Position 10 10) (SomeEntity testGormlak)
-
+  prompt_ @'StringPrompt ["character", "namePrompt"] Uncancellable
+    $ \(StringResult s) -> do
+      character . characterName ?= s
+      say ["welcome"] =<< use character
 
 handleEvent :: BrickEvent Name () -> AppM (Next GameState)
-handleEvent (VtyEvent (EvKey k mods))
+handleEvent ev = use promptState >>= \case
+  NoPrompt -> handleNoPromptEvent ev
+  WaitingPrompt msg pr -> handlePromptEvent msg pr ev
+
+
+handleNoPromptEvent :: BrickEvent Name () -> AppM (Next GameState)
+handleNoPromptEvent (VtyEvent (EvKey k mods))
   | Just command <- commandFromKey k mods
   = do messageHistory %= hideMessage
        handleCommand command
-handleEvent _ = continue
+handleNoPromptEvent _ = continue
 
 handleCommand :: Command -> AppM (Next GameState)
 handleCommand Quit = halt
@@ -106,3 +114,48 @@ handleCommand PreviousMessage = do
   messageHistory %= popMessage
   continue
 
+handlePromptEvent
+  :: Text -- ^ Prompt message
+  -> Prompt (AppT Identity)
+  -> BrickEvent Name ()
+  -> AppM (Next GameState)
+handlePromptEvent _ (Prompt Cancellable _ _ _) (VtyEvent (EvKey KEsc [])) = do
+  promptState .= NoPrompt
+  continue
+handlePromptEvent _ pr (VtyEvent (EvKey KEnter [])) = do
+  () <- state . coerce $ submitPrompt pr
+  promptState .= NoPrompt
+  continue
+handlePromptEvent
+  msg
+  (Prompt c SStringPrompt (StringPromptState edit) cb)
+  (VtyEvent ev)
+  = do
+    edit' <- lift $ handleEditorEvent ev edit
+    let prompt' = Prompt c SStringPrompt (StringPromptState edit') cb
+    promptState .= WaitingPrompt msg prompt'
+    continue
+handlePromptEvent _ _ _ = undefined
+
+prompt
+  :: forall (pt :: PromptType) (params :: Type).
+    (ToJSON params, SingPromptType pt)
+  => [Text]                     -- ^ Message key
+  -> params                     -- ^ Message params
+  -> PromptCancellable
+  -> (PromptResult pt -> AppT Identity ()) -- ^ Prompt promise handler
+  -> AppM ()
+prompt msgPath params cancellable cb = do
+  let pt = singPromptType @pt
+  msg <- message msgPath params
+  let p = mkPrompt cancellable pt cb
+  promptState .= WaitingPrompt msg p
+
+prompt_
+  :: forall (pt :: PromptType) .
+    (SingPromptType pt)
+  => [Text] -- ^ Message key
+  -> PromptCancellable
+  -> (PromptResult pt -> AppT Identity ()) -- ^ Prompt promise handler
+  -> AppM ()
+prompt_ msg = prompt msg $ object []
diff --git a/src/Xanthous/Data/EntityMap.hs b/src/Xanthous/Data/EntityMap.hs
index 926a02a48c..7885839d51 100644
--- a/src/Xanthous/Data/EntityMap.hs
+++ b/src/Xanthous/Data/EntityMap.hs
@@ -23,7 +23,10 @@ module Xanthous.Data.EntityMap
   , neighbors
   , Deduplicate(..)
 
-    -- * Querying an entityMap
+  -- * debug
+  , byID
+  , byPosition
+
   ) where
 --------------------------------------------------------------------------------
 import Xanthous.Prelude hiding (lookup)
@@ -31,7 +34,6 @@ import Xanthous.Data
   ( Position
   , Positioned(..)
   , positioned
-  , position
   , Neighbors(..)
   , neighborPositions
   )
@@ -81,15 +83,15 @@ instance At (EntityMap a) where
         pure $ m
           & removeEIDAtPos pos
           & byID . at eid .~ Nothing
-      setter m (Just (Positioned pos e)) =
-        case lookupWithPosition eid m of
-          Nothing -> insertAt pos e m
-          Just (Positioned origPos _) -> m
-            & removeEIDAtPos origPos
-            & byID . ix eid . position .~ pos
-            & byPosition . at pos %~ \case
-              Nothing -> Just $ ncons eid mempty
-              Just es -> Just $ eid <| es
+      setter m (Just pe@(Positioned pos _)) = m
+        & (case lookupWithPosition eid m of
+             Nothing -> id
+             Just (Positioned origPos _) -> removeEIDAtPos origPos
+          )
+        & byID . at eid ?~ pe
+        & byPosition . at pos %~ \case
+            Nothing -> Just $ ncons eid mempty
+            Just es -> Just $ eid <| es
       removeEIDAtPos pos =
         byPosition . at pos %~ (>>= fromNullable . nfilter (/= eid))
 
@@ -117,9 +119,6 @@ instance Semigroup (Deduplicate a) where
         _lastID = fromMaybe 1 $ maximumOf (ifolded . asIndex) _byID
     in Deduplicate EntityMap{..}
 
-instance Monoid (Deduplicate a) where
-  mempty = Deduplicate emptyEntityMap
-
 
 --------------------------------------------------------------------------------
 
diff --git a/src/Xanthous/Entities/Character.hs b/src/Xanthous/Entities/Character.hs
index 3b2b320004..695d7bb0d0 100644
--- a/src/Xanthous/Entities/Character.hs
+++ b/src/Xanthous/Entities/Character.hs
@@ -1,6 +1,8 @@
 {-# LANGUAGE TemplateHaskell #-}
 module Xanthous.Entities.Character
   ( Character(..)
+  , characterName
+  , inventory
   , mkCharacter
   , pickUpItem
   ) where
@@ -10,6 +12,8 @@ import Test.QuickCheck
 import Test.QuickCheck.Instances.Vector ()
 import Test.QuickCheck.Arbitrary.Generic
 import Brick
+import Data.Aeson.Generic.DerivingVia
+import Data.Aeson (ToJSON, FromJSON)
 --------------------------------------------------------------------------------
 import Xanthous.Entities
 import Xanthous.Entities.Item
@@ -17,9 +21,13 @@ import Xanthous.Entities.Item
 
 data Character = Character
   { _inventory :: !(Vector Item)
+  , _characterName :: !(Maybe Text)
   }
   deriving stock (Show, Eq, Generic)
   deriving anyclass (CoArbitrary, Function)
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           Character
 makeLenses ''Character
 
 scrollOffset :: Int
@@ -40,6 +48,7 @@ instance Arbitrary Character where
 mkCharacter :: Character
 mkCharacter = Character
   { _inventory = mempty
+  , _characterName = Nothing
   }
 
 pickUpItem :: Item -> Character -> Character
diff --git a/src/Xanthous/Game.hs b/src/Xanthous/Game.hs
index 777e05ee41..59e436edc9 100644
--- a/src/Xanthous/Game.hs
+++ b/src/Xanthous/Game.hs
@@ -8,6 +8,8 @@ module Xanthous.Game
   , revealedPositions
   , messageHistory
   , randomGen
+  , promptState
+  , GamePromptState(..)
 
   , getInitialState
 
@@ -24,6 +26,9 @@ module Xanthous.Game
     -- * collisions
   , Collision(..)
   , collisionAt
+
+    -- * App monad
+  , AppT(..)
   ) where
 --------------------------------------------------------------------------------
 import           Xanthous.Prelude
@@ -34,6 +39,8 @@ import           System.Random
 import           Test.QuickCheck
 import           Test.QuickCheck.Arbitrary.Generic
 import           Control.Monad.State.Class
+import           Control.Monad.State
+import           Control.Monad.Random.Class
 --------------------------------------------------------------------------------
 import           Xanthous.Data.EntityMap (EntityMap, EntityID)
 import qualified Xanthous.Data.EntityMap as EntityMap
@@ -45,6 +52,7 @@ import           Xanthous.Entities.Creature
 import           Xanthous.Entities.Item
 import           Xanthous.Entities.Arbitrary ()
 import           Xanthous.Orphans ()
+import           Xanthous.Game.Prompt
 --------------------------------------------------------------------------------
 
 data MessageHistory
@@ -70,12 +78,33 @@ hideMessage :: MessageHistory -> MessageHistory
 hideMessage NoMessageHistory = NoMessageHistory
 hideMessage (MessageHistory msgs _) = MessageHistory msgs False
 
+--------------------------------------------------------------------------------
+
+data GamePromptState m where
+  NoPrompt :: GamePromptState m
+  WaitingPrompt :: Text -> Prompt m -> GamePromptState m
+  deriving stock (Show)
+
+--------------------------------------------------------------------------------
+
+newtype AppT m a
+  = AppT { unAppT :: StateT GameState m a }
+  deriving ( Functor
+           , Applicative
+           , Monad
+           , MonadState GameState
+           )
+       via (StateT GameState m)
+
+--------------------------------------------------------------------------------
+
 data GameState = GameState
   { _entities          :: !(EntityMap SomeEntity)
   , _revealedPositions :: !(Set Position)
   , _characterEntityID :: !EntityID
   , _messageHistory    :: !MessageHistory
   , _randomGen         :: !StdGen
+  , _promptState       :: !(GamePromptState (AppT Identity))
   }
   deriving stock (Show)
 makeLenses ''GameState
@@ -88,6 +117,7 @@ instance Eq GameState where
     , gs ^. messageHistory
     )
 
+
 instance Arbitrary GameState where
   arbitrary = do
     char <- arbitrary @Character
@@ -97,8 +127,10 @@ instance Arbitrary GameState where
       EntityMap.insertAtReturningID charPos (SomeEntity char)
     _revealedPositions <- fmap setFromList . sublistOf $ EntityMap.positions _entities
     _randomGen <- mkStdGen <$> arbitrary
+    let _promptState = NoPrompt -- TODO
     pure $ GameState {..}
 
+
 getInitialState :: IO GameState
 getInitialState = do
   _randomGen <- getStdGen
@@ -110,6 +142,7 @@ getInitialState = do
           mempty
       _messageHistory = NoMessageHistory
       _revealedPositions = mempty
+      _promptState = NoPrompt
   pure GameState {..}
 
 positionedCharacter :: Lens' GameState (Positioned Character)
@@ -166,3 +199,14 @@ collisionAt pos = do
        | any (entityIs @Creature) ents -> pure Combat
        | all (entityIs @Item) ents -> Nothing
        | otherwise -> pure Stop
+
+--------------------------------------------------------------------------------
+
+instance MonadTrans AppT where
+  lift = AppT . lift
+
+instance (Monad m) => MonadRandom (AppT m) where
+  getRandomR rng = randomGen %%= randomR rng
+  getRandom = randomGen %%= random
+  getRandomRs rng = uses randomGen $ randomRs rng
+  getRandoms = uses randomGen randoms
diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs
index 8deb20ff84..60ae7110a6 100644
--- a/src/Xanthous/Game/Draw.hs
+++ b/src/Xanthous/Game/Draw.hs
@@ -1,40 +1,47 @@
-{-# LANGUAGE ViewPatterns #-}
-
+--------------------------------------------------------------------------------
 module Xanthous.Game.Draw
   ( drawGame
   ) where
-
-import Xanthous.Prelude
-import Brick hiding (loc)
-import Brick.Widgets.Border
-import Brick.Widgets.Border.Style
-import Data.List.NonEmpty(NonEmpty((:|)))
-
-import Xanthous.Data (Position(Position), x, y, loc)
-import Xanthous.Data.EntityMap (EntityMap, atPosition)
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+import           Brick hiding (loc)
+import           Brick.Widgets.Border
+import           Brick.Widgets.Border.Style
+import           Brick.Widgets.Edit
+import           Data.List.NonEmpty(NonEmpty((:|)))
+--------------------------------------------------------------------------------
+import           Xanthous.Data (Position(Position), x, y, loc)
+import           Xanthous.Data.EntityMap (EntityMap, atPosition)
 import qualified Xanthous.Data.EntityMap as EntityMap
-import Xanthous.Entities
-import Xanthous.Game
-  ( GameState(..)
-  , entities
-  , revealedPositions
-  , characterPosition
-  , MessageHistory(..)
-  , messageHistory
-  )
-import Xanthous.Resource (Name(..))
-import Xanthous.Orphans ()
+import           Xanthous.Entities
+import           Xanthous.Game
+                 ( GameState(..)
+                 , entities
+                 , revealedPositions
+                 , characterPosition
+                 , MessageHistory(..)
+                 , messageHistory
+                 , GamePromptState(..)
+                 , promptState
+                 )
+import           Xanthous.Game.Prompt
+import           Xanthous.Resource (Name)
+import qualified Xanthous.Resource as Resource
+import           Xanthous.Orphans ()
+--------------------------------------------------------------------------------
 
 drawMessages :: MessageHistory -> Widget Name
 drawMessages NoMessageHistory = emptyWidget
-drawMessages (MessageHistory _ False) = emptyWidget
+drawMessages (MessageHistory _ False) = str " "
 drawMessages (MessageHistory (lastMessage :| _) True) = txt lastMessage
 
--- an attempt to still take up a row even when no messages
--- drawMessages msgs = vLimit 1 . Widget Greedy Fixed . render $ case msgs of
---   NoMessageHistory -> padTop (Pad 2) $ str " "
---   (MessageHistory _ False) -> padTop (Pad 2) $ str " "
---   (MessageHistory (lastMessage :| _) True) -> txt lastMessage
+drawPromptState :: GamePromptState m -> Widget Name
+drawPromptState NoPrompt = emptyWidget
+drawPromptState (WaitingPrompt msg (Prompt _ pt ps _)) =
+  case (pt, ps) of
+    (SStringPrompt, StringPromptState edit) ->
+      txt msg <+> renderEditor (txt . fold) True edit
+    _ -> undefined
 
 drawEntities
   :: Set Position
@@ -61,8 +68,8 @@ drawEntities visiblePositions allEnts
 
 drawMap :: GameState -> Widget Name
 drawMap game
-  = viewport MapViewport Both
-  . showCursor Character (game ^. characterPosition . loc)
+  = viewport Resource.MapViewport Both
+  . showCursor Resource.Character (game ^. characterPosition . loc)
   $ drawEntities
     (game ^. revealedPositions)
     (game ^. entities)
@@ -72,4 +79,5 @@ drawGame game
   = pure
   . withBorderStyle unicode
   $   drawMessages (game ^. messageHistory)
+  <=> drawPromptState (game ^. promptState)
   <=> border (drawMap game)
diff --git a/src/Xanthous/Game/Prompt.hs b/src/Xanthous/Game/Prompt.hs
new file mode 100644
index 0000000000..928340f064
--- /dev/null
+++ b/src/Xanthous/Game/Prompt.hs
@@ -0,0 +1,117 @@
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE GADTs #-}
+--------------------------------------------------------------------------------
+module Xanthous.Game.Prompt
+  ( PromptType(..)
+  , SPromptType(..)
+  , SingPromptType(..)
+  , PromptCancellable(..)
+  , PromptResult(..)
+  , PromptState(..)
+  , Prompt(..)
+  , mkPrompt
+  , isCancellable
+  , submitPrompt
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Brick.Widgets.Edit (Editor, editorText, getEditContents)
+import Test.QuickCheck
+import Test.QuickCheck.Arbitrary.Generic
+--------------------------------------------------------------------------------
+import Xanthous.Data (Direction, Position)
+import Xanthous.Resource (Name)
+import qualified Xanthous.Resource as Resource
+--------------------------------------------------------------------------------
+
+data PromptType where
+  StringPrompt    :: PromptType
+  Confirm         :: PromptType
+  Menu            :: Type -> PromptType
+  DirectionPrompt :: PromptType
+  PointOnMap      :: PromptType
+  deriving stock (Generic)
+
+instance Show PromptType where
+  show StringPrompt = "StringPrompt"
+  show Confirm = "Confirm"
+  show (Menu _) = "Menu"
+  show DirectionPrompt = "DirectionPrompt"
+  show PointOnMap = "PointOnMap"
+
+data SPromptType :: PromptType -> Type where
+  SStringPrompt    ::      SPromptType 'StringPrompt
+  SConfirm         ::      SPromptType 'Confirm
+  SMenu            :: forall a. SPromptType ('Menu a)
+  SDirectionPrompt ::      SPromptType 'DirectionPrompt
+  SPointOnMap      ::      SPromptType 'PointOnMap
+
+class SingPromptType pt where singPromptType :: SPromptType pt
+instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt
+
+instance Show (SPromptType pt) where
+  show SStringPrompt    = "SStringPrompt"
+  show SConfirm         = "SConfirm"
+  show SMenu            = "SMenu"
+  show SDirectionPrompt = "SDirectionPrompt"
+  show SPointOnMap      = "SPointOnMap"
+
+data PromptCancellable
+  = Cancellable
+  | Uncancellable
+  deriving stock (Show, Eq, Ord, Enum, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+
+instance Arbitrary PromptCancellable where
+  arbitrary = genericArbitrary
+
+data PromptResult (pt :: PromptType) where
+  StringResult     :: Text      -> PromptResult 'StringPrompt
+  ConfirmResult    :: Bool      -> PromptResult 'Confirm
+  MenuResult       :: forall a. a    -> PromptResult ('Menu a)
+  DirectionResult  :: Direction -> PromptResult 'DirectionPrompt
+  PointOnMapResult :: Position  -> PromptResult 'PointOnMap
+
+data PromptState pt where
+  StringPromptState :: Editor Text Name -> PromptState 'StringPrompt
+
+deriving stock instance Show (PromptState pt)
+
+data Prompt (m :: Type -> Type) where
+  Prompt
+    :: forall (pt :: PromptType)
+        (m :: Type -> Type).
+      PromptCancellable
+    -> SPromptType pt
+    -> PromptState pt
+    -> (PromptResult pt -> m ())
+    -> Prompt m
+
+instance Show (Prompt m) where
+  show (Prompt c pt ps _)
+    = "(Prompt "
+    <> show c <> " "
+    <> show pt <> " "
+    <> show ps
+    <> " <function> )"
+
+mkPrompt :: PromptCancellable -> SPromptType pt -> (PromptResult pt -> m ()) -> Prompt m
+mkPrompt c pt@SStringPrompt cb =
+  let ps = StringPromptState $ editorText Resource.Prompt (Just 1) ""
+  in Prompt c pt ps cb
+mkPrompt _ _ _ = undefined
+
+isCancellable :: Prompt m -> Bool
+isCancellable (Prompt Cancellable _ _ _)   = True
+isCancellable (Prompt Uncancellable _ _ _) = False
+
+submitPrompt :: Prompt m -> m ()
+submitPrompt (Prompt _ pt ps cb) =
+  case (pt, ps) of
+    (SStringPrompt, StringPromptState edit) ->
+      cb . StringResult . mconcat . getEditContents $ edit
+    _ -> undefined
+
+-- data PromptInput :: PromptType -> Type where
+--   StringInput :: PromptInput 'StringPrompt
diff --git a/src/Xanthous/Monad.hs b/src/Xanthous/Monad.hs
index acf7775ede..4e3e58607c 100644
--- a/src/Xanthous/Monad.hs
+++ b/src/Xanthous/Monad.hs
@@ -17,24 +17,6 @@ import Data.Aeson
 import Xanthous.Game
 import Xanthous.Messages (message)
 
-newtype AppT m a
-  = AppT { unAppT :: StateT GameState m a }
-  deriving ( Functor
-           , Applicative
-           , Monad
-           , MonadState GameState
-           )
-       via (StateT GameState m)
-
-instance MonadTrans AppT where
-  lift = AppT . lift
-
-instance (Monad m) => MonadRandom (AppT m) where
-  getRandomR rng = randomGen %%= randomR rng
-  getRandom = randomGen %%= random
-  getRandomRs rng = uses randomGen $ randomRs rng
-  getRandoms = uses randomGen randoms
-
 runAppT :: Monad m => AppT m a -> GameState -> m (a, GameState)
 runAppT appt initialState = flip runStateT initialState . unAppT $ appt
 
@@ -44,19 +26,12 @@ halt = lift . Brick.halt =<< get
 continue :: AppT (EventM n) (Next GameState)
 continue = lift . Brick.continue =<< get
 
--- say :: [Text] -> AppT m ()
--- say :: [Text] -> params -> AppT m ()
-
-class SayR a where
-  say :: [Text] -> a
-
-instance Monad m => SayR (AppT m ()) where
-  say msgPath = say msgPath $ object []
 
-instance (Monad m, ToJSON params) => SayR (params -> AppT m ()) where
-  say msgPath params = do
-    msg <- message msgPath params
-    messageHistory %= pushMessage msg
+say :: (MonadRandom m, ToJSON params, MonadState GameState m)
+    => [Text] -> params -> m ()
+say msgPath params = do
+  msg <- message msgPath params
+  messageHistory %= pushMessage msg
 
-say_ :: Monad m => [Text] -> AppT m ()
-say_ = say
+say_ :: (MonadRandom m, MonadState GameState m) => [Text] -> m ()
+say_ msgPath = say msgPath $ object []
diff --git a/src/Xanthous/Resource.hs b/src/Xanthous/Resource.hs
index aa9020903c..782fd5040d 100644
--- a/src/Xanthous/Resource.hs
+++ b/src/Xanthous/Resource.hs
@@ -10,4 +10,5 @@ data Name = MapViewport
             -- ^ The character
           | MessageBox
             -- ^ The box where we display messages to the user
+          | Prompt
   deriving stock (Show, Eq, Ord)
diff --git a/src/Xanthous/messages.yaml b/src/Xanthous/messages.yaml
index 5bb11ab059..0f0a0149f6 100644
--- a/src/Xanthous/messages.yaml
+++ b/src/Xanthous/messages.yaml
@@ -1,4 +1,6 @@
-welcome: Welcome to Xanthous! It's dangerous out there, why not stay inside?
+welcome: Welcome to Xanthous, {{characterName}}! It's dangerous out there, why not stay inside?
 items:
   pickUp: You pick up the {{item.itemType.name}}
   nothingToPickUp: There's nothing here to pick up
+character:
+  namePrompt: "What's your name? "
diff --git a/test/Xanthous/Data/EntityMapSpec.hs b/test/Xanthous/Data/EntityMapSpec.hs
index 00bf150046..2e9714a44e 100644
--- a/test/Xanthous/Data/EntityMapSpec.hs
+++ b/test/Xanthous/Data/EntityMapSpec.hs
@@ -15,7 +15,10 @@ test = localOption (QuickCheckTests 20)
   $ testGroup "Xanthous.Data.EntityMap"
   [ testBatch $ monoid @(EntityMap Int) mempty
   , testGroup "Deduplicate"
-    [ testBatch $ monoid @(Deduplicate Int) mempty
+    [ testGroup "Semigroup laws"
+      [ testProperty "associative" $ \(a :: Deduplicate (EntityMap Int)) b c ->
+          a <> (b <> c) === (a <> b) <> c
+      ]
     ]
   , testGroup "Eq laws"
     [ testProperty "reflexivity" $ \(em :: EntityMap Int) ->
diff --git a/test/Xanthous/GameSpec.hs b/test/Xanthous/GameSpec.hs
index dbd1677f7e..32faae03d7 100644
--- a/test/Xanthous/GameSpec.hs
+++ b/test/Xanthous/GameSpec.hs
@@ -27,4 +27,7 @@ test = testGroup "Xanthous.Game"
   , testGroup "characterPosition"
     [ testProperty "lens laws" $ isLens characterPosition
     ]
+  , testGroup "character"
+    [ testProperty "lens laws" $ isLens character
+    ]
   ]
diff --git a/xanthous.cabal b/xanthous.cabal
index ef3498af06..cb89323b2b 100644
--- a/xanthous.cabal
+++ b/xanthous.cabal
@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 78a45f3d5eb8c2993c219fd4214f61e9842177fa4d97667aeaedbfe3d0842165
+-- hash: 40187d0301465905043b8caafec5465e644f711620c9fc1cfc57af4105ebe08c
 
 name:           xanthous
 version:        0.1.0.0
@@ -46,6 +46,7 @@ library
       Xanthous.Entities.RawTypes
       Xanthous.Game
       Xanthous.Game.Draw
+      Xanthous.Game.Prompt
       Xanthous.Generators
       Xanthous.Generators.CaveAutomata
       Xanthous.Generators.LevelContents
@@ -118,6 +119,7 @@ executable xanthous
       Xanthous.Entities.RawTypes
       Xanthous.Game
       Xanthous.Game.Draw
+      Xanthous.Game.Prompt
       Xanthous.Generators
       Xanthous.Generators.CaveAutomata
       Xanthous.Generators.LevelContents
generated by cgit-pink 1.4.1 (git 2.44.2) at 2024-07-06T17ยท52+0000