about summary refs log tree commit diff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Xanthous/App.hs4
-rw-r--r--src/Xanthous/Game.hs8
-rw-r--r--src/Xanthous/Game/Draw.hs5
-rw-r--r--src/Xanthous/Game/Lenses.hs2
-rw-r--r--src/Xanthous/Game/State.hs60
-rw-r--r--src/Xanthous/Orphans.hs21
-rw-r--r--test/Xanthous/GameSpec.hs12
7 files changed, 84 insertions, 28 deletions
diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs
index 02f6f0987d..72c9a3f553 100644
--- a/src/Xanthous/App.hs
+++ b/src/Xanthous/App.hs
@@ -103,7 +103,7 @@ handleEvent ev = use promptState >>= \case
 handleNoPromptEvent :: BrickEvent Name () -> AppM (Next GameState)
 handleNoPromptEvent (VtyEvent (EvKey k mods))
   | Just command <- commandFromKey k mods
-  = do messageHistory %= hideMessage
+  = do messageHistory %= nextTurn
        handleCommand command
 handleNoPromptEvent _ = continue
 
@@ -135,7 +135,7 @@ handleCommand PickUp = do
   continue
 
 handleCommand PreviousMessage = do
-  messageHistory %= popMessage
+  messageHistory %= previousMessage
   continue
 
 handleCommand Open = do
diff --git a/src/Xanthous/Game.hs b/src/Xanthous/Game.hs
index 2b346ace56..0ab5425a04 100644
--- a/src/Xanthous/Game.hs
+++ b/src/Xanthous/Game.hs
@@ -14,10 +14,14 @@ module Xanthous.Game
   , characterPosition
   , updateCharacterVision
 
+    -- * Messages
   , MessageHistory(..)
+  , HasMessages(..)
+  , HasTurn(..)
+  , HasDisplayedTurn(..)
   , pushMessage
-  , popMessage
-  , hideMessage
+  , previousMessage
+  , nextTurn
 
     -- * Collisions
   , Collision(..)
diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs
index e1242f2b7a..addeaa14cd 100644
--- a/src/Xanthous/Game/Draw.hs
+++ b/src/Xanthous/Game/Draw.hs
@@ -8,7 +8,6 @@ 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)
@@ -34,9 +33,7 @@ import           Xanthous.Orphans ()
 --------------------------------------------------------------------------------
 
 drawMessages :: MessageHistory -> Widget Name
-drawMessages NoMessageHistory = emptyWidget
-drawMessages (MessageHistory _ False) = str " "
-drawMessages (MessageHistory (lastMessage :| _) True) = txt lastMessage
+drawMessages = txt . (<> " ") . unwords . oextract
 
 drawPromptState :: GamePromptState m -> Widget Name
 drawPromptState NoPrompt = emptyWidget
diff --git a/src/Xanthous/Game/Lenses.hs b/src/Xanthous/Game/Lenses.hs
index e077e339cd..101de3021c 100644
--- a/src/Xanthous/Game/Lenses.hs
+++ b/src/Xanthous/Game/Lenses.hs
@@ -36,7 +36,7 @@ getInitialState = do
           (Position 0 0)
           (SomeEntity char)
           mempty
-      _messageHistory = NoMessageHistory
+      _messageHistory = mempty
       _revealedPositions = mempty
       _promptState = NoPrompt
       _debugState = DebugState
diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs
index 00785bf124..302d20e1ef 100644
--- a/src/Xanthous/Game/State.hs
+++ b/src/Xanthous/Game/State.hs
@@ -14,9 +14,12 @@ module Xanthous.Game.State
 
     -- * Messages
   , MessageHistory(..)
+  , HasMessages(..)
+  , HasTurn(..)
+  , HasDisplayedTurn(..)
   , pushMessage
-  , popMessage
-  , hideMessage
+  , previousMessage
+  , nextTurn
 
     -- * App monad
   , AppT(..)
@@ -61,27 +64,54 @@ import           Xanthous.Resource
 --------------------------------------------------------------------------------
 
 data MessageHistory
-  = NoMessageHistory
-  | MessageHistory (NonEmpty Text) Bool
+  = MessageHistory
+  { _messages      :: Map Word (NonEmpty Text)
+  , _turn          :: Word
+  , _displayedTurn :: Maybe Word
+  }
   deriving stock (Show, Eq, Generic)
   deriving anyclass (NFData, CoArbitrary, Function)
+makeFieldsNoPrefix ''MessageHistory
+
+instance Semigroup MessageHistory where
+  (MessageHistory msgs₁ turn₁ dt₁) <> (MessageHistory msgs₂ turn₂ dt₂) =
+    MessageHistory (msgs₁ <> msgs₂) (max turn₁ turn₂) $ case (dt₁, dt₂) of
+      (_, Nothing)      -> Nothing
+      (Just t, _)       -> Just t
+      (Nothing, Just t) -> Just t
+
+instance Monoid MessageHistory where
+  mempty = MessageHistory mempty 0 Nothing
 
 instance Arbitrary MessageHistory where
   arbitrary = genericArbitrary
 
+type instance Element MessageHistory = [Text]
+instance MonoFunctor MessageHistory where
+  omap f mh@(MessageHistory _ t _) =
+    mh & messages . at t %~ (NonEmpty.nonEmpty . f . toList =<<)
+
+instance MonoComonad MessageHistory where
+  oextract (MessageHistory ms t dt) = maybe [] toList $ ms ^. at (fromMaybe t dt)
+  oextend cok mh@(MessageHistory _ t dt) =
+    mh & messages . at (fromMaybe t dt) .~ NonEmpty.nonEmpty (cok mh)
+
 pushMessage :: Text -> MessageHistory -> MessageHistory
-pushMessage msg NoMessageHistory = MessageHistory (msg :| []) True
-pushMessage msg (MessageHistory msgs _) = MessageHistory (NonEmpty.cons msg msgs) True
+pushMessage msg mh@(MessageHistory _ turn' _) =
+  mh
+  & messages . at turn' %~ \case
+    Nothing -> Just $ msg :| mempty
+    Just msgs -> Just $ msg <| msgs
+  & displayedTurn .~ Nothing
+
+nextTurn :: MessageHistory -> MessageHistory
+nextTurn = (turn +~ 1) . (displayedTurn .~ Nothing)
 
-popMessage :: MessageHistory -> MessageHistory
-popMessage NoMessageHistory = NoMessageHistory
-popMessage (MessageHistory msgs False) = MessageHistory msgs True
-popMessage (MessageHistory msgs@(_ :| []) _) = MessageHistory msgs True
-popMessage (MessageHistory (_ :| (msg : msgs)) True) = MessageHistory (msg :| msgs) True
+previousMessage :: MessageHistory -> MessageHistory
+previousMessage mh = mh & displayedTurn .~ maximumOf
+  (messages . ifolded . asIndex . filtered (< mh ^. turn))
+  mh
 
-hideMessage :: MessageHistory -> MessageHistory
-hideMessage NoMessageHistory = NoMessageHistory
-hideMessage (MessageHistory msgs _) = MessageHistory msgs False
 
 --------------------------------------------------------------------------------
 
@@ -152,7 +182,7 @@ instance Eq SomeEntity where
     Just Refl -> a == b
     _ -> False
 
-instance Draw (SomeEntity) where
+instance Draw SomeEntity where
   drawWithNeighbors ns (SomeEntity ent) = drawWithNeighbors ns ent
 
 instance Brain SomeEntity where
diff --git a/src/Xanthous/Orphans.hs b/src/Xanthous/Orphans.hs
index 22325f6366..610067a375 100644
--- a/src/Xanthous/Orphans.hs
+++ b/src/Xanthous/Orphans.hs
@@ -25,7 +25,8 @@ import           Text.Mustache.Type ( showKey )
 
 instance forall s a.
   ( Cons s s a a
-  , MonoFoldable s
+  , IsSequence s
+  , Element s ~ a
   ) => Cons (NonNull s) (NonNull s) a a where
   _Cons = prism hither yon
     where
@@ -35,9 +36,21 @@ instance forall s a.
         in impureNonNull $ a <| s
 
       yon :: NonNull s -> Either (NonNull s) (a, NonNull s)
-      yon ns = case ns ^? _Cons of
-        Nothing -> Left ns
-        Just (a, ns') -> Right (a, ns')
+      yon ns = case nuncons ns of
+        (_, Nothing) -> Left ns
+        (x, Just xs) -> Right (x, xs)
+
+instance forall a. Cons (NonEmpty a) (NonEmpty a) a a where
+  _Cons = prism hither yon
+    where
+      hither :: (a, NonEmpty a) -> NonEmpty a
+      hither (a, x :| xs) = a :| (x : xs)
+
+      yon :: NonEmpty a -> Either (NonEmpty a) (a, NonEmpty a)
+      yon ns@(x :| xs) = case xs of
+        (y : ys) -> Right (x, y :| ys)
+        [] -> Left ns
+
 
 instance Arbitrary PName where
   arbitrary = PName . pack <$> listOf1 (elements ['a'..'z'])
diff --git a/test/Xanthous/GameSpec.hs b/test/Xanthous/GameSpec.hs
index 32faae03d7..af98c7f6cc 100644
--- a/test/Xanthous/GameSpec.hs
+++ b/test/Xanthous/GameSpec.hs
@@ -30,4 +30,16 @@ test = testGroup "Xanthous.Game"
   , testGroup "character"
     [ testProperty "lens laws" $ isLens character
     ]
+  , localOption (QuickCheckTests 10)
+  $ testGroup "MessageHistory"
+    [ testGroup "MonoComonad laws"
+      [ testProperty "oextend oextract ≡ id"
+        $ \(mh :: MessageHistory) -> oextend oextract mh === mh
+      , testProperty "oextract ∘ oextend f ≡ f"
+        $ \(mh :: MessageHistory) f -> (oextract . oextend f) mh === f mh
+      , testProperty "oextend f ∘ oextend g ≡ oextend (f . oextend g)"
+        $ \(mh :: MessageHistory) f g ->
+          (oextend f . oextend g) mh === oextend (f . oextend g) mh
+      ]
+    ]
   ]
generated by cgit-pink 1.4.1 (git 2.44.0) at 2024-05-28T10·35+0000