about summary refs log tree commit diff
path: root/src/Xanthous/Game
diff options
context:
space:
mode:
Diffstat (limited to 'src/Xanthous/Game')
-rw-r--r--src/Xanthous/Game/Arbitrary.hs27
-rw-r--r--src/Xanthous/Game/Lenses.hs72
-rw-r--r--src/Xanthous/Game/State.hs200
3 files changed, 299 insertions, 0 deletions
diff --git a/src/Xanthous/Game/Arbitrary.hs b/src/Xanthous/Game/Arbitrary.hs
new file mode 100644
index 000000000000..5ab2301e7083
--- /dev/null
+++ b/src/Xanthous/Game/Arbitrary.hs
@@ -0,0 +1,27 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE RecordWildCards #-}
+--------------------------------------------------------------------------------
+module Xanthous.Game.Arbitrary where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Test.QuickCheck
+import           System.Random
+--------------------------------------------------------------------------------
+import           Xanthous.Game.State
+import           Xanthous.Entities.Arbitrary ()
+import           Xanthous.Entities.Character
+import qualified Xanthous.Data.EntityMap as EntityMap
+--------------------------------------------------------------------------------
+
+instance Arbitrary GameState where
+  arbitrary = do
+    char <- arbitrary @Character
+    charPos <- arbitrary
+    _messageHistory <- arbitrary
+    (_characterEntityID, _entities) <- arbitrary <&>
+      EntityMap.insertAtReturningID charPos (SomeEntity char)
+    _revealedPositions <- fmap setFromList . sublistOf $ EntityMap.positions _entities
+    _randomGen <- mkStdGen <$> arbitrary
+    let _promptState = NoPrompt -- TODO
+    pure $ GameState {..}
diff --git a/src/Xanthous/Game/Lenses.hs b/src/Xanthous/Game/Lenses.hs
new file mode 100644
index 000000000000..91ff5c137d1a
--- /dev/null
+++ b/src/Xanthous/Game/Lenses.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE RecordWildCards #-}
+--------------------------------------------------------------------------------
+module Xanthous.Game.Lenses
+  ( positionedCharacter
+  , character
+  , characterPosition
+  , updateCharacterVision
+  , getInitialState
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           System.Random
+--------------------------------------------------------------------------------
+import           Xanthous.Game.State
+import           Xanthous.Data
+import qualified Xanthous.Data.EntityMap as EntityMap
+import           Xanthous.Data.EntityMap.Graphics (visiblePositions)
+import           Xanthous.Entities.Character (Character, mkCharacter)
+--------------------------------------------------------------------------------
+
+getInitialState :: IO GameState
+getInitialState = do
+  _randomGen <- getStdGen
+  let char = mkCharacter
+      (_characterEntityID, _entities)
+        = EntityMap.insertAtReturningID
+          (Position 0 0)
+          (SomeEntity char)
+          mempty
+      _messageHistory = NoMessageHistory
+      _revealedPositions = mempty
+      _promptState = NoPrompt
+  pure GameState {..}
+
+
+positionedCharacter :: Lens' GameState (Positioned Character)
+positionedCharacter = lens getPositionedCharacter setPositionedCharacter
+  where
+    setPositionedCharacter :: GameState -> Positioned Character -> GameState
+    setPositionedCharacter game char
+      = game
+      &  entities . at (game ^. characterEntityID)
+      ?~ fmap SomeEntity char
+
+    getPositionedCharacter :: GameState -> Positioned Character
+    getPositionedCharacter game
+      = over positioned
+        ( fromMaybe (error "Invariant error: Character was not a character!")
+        . downcastEntity
+        )
+      . fromMaybe (error "Invariant error: Character not found!")
+      $ EntityMap.lookupWithPosition
+        (game ^. characterEntityID)
+        (game ^. entities)
+
+
+character :: Lens' GameState Character
+character = positionedCharacter . positioned
+
+characterPosition :: Lens' GameState Position
+characterPosition = positionedCharacter . position
+
+visionRadius :: Word
+visionRadius = 12 -- TODO make this dynamic
+
+-- | Update the revealed entities at the character's position based on their vision
+updateCharacterVision :: GameState -> GameState
+updateCharacterVision game =
+  let charPos = game ^. characterPosition
+      visible = visiblePositions charPos visionRadius $ game ^. entities
+  in game & revealedPositions <>~ visible
diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs
new file mode 100644
index 000000000000..9b81abe35247
--- /dev/null
+++ b/src/Xanthous/Game/State.hs
@@ -0,0 +1,200 @@
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE GADTs               #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+--------------------------------------------------------------------------------
+module Xanthous.Game.State
+  ( GameState(..)
+  , entities
+  , revealedPositions
+  , messageHistory
+  , randomGen
+  , promptState
+  , characterEntityID
+  , GamePromptState(..)
+
+    -- * Messages
+  , MessageHistory(..)
+  , pushMessage
+  , popMessage
+  , hideMessage
+
+    -- * App monad
+  , AppT(..)
+  , AppM
+
+    -- * Entities
+  , Draw(..)
+  , Brain(..)
+  , Brainless(..)
+  , brainVia
+  , Entity(..)
+  , SomeEntity(..)
+  , downcastEntity
+  , _SomeEntity
+  , entityIs
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Data.List.NonEmpty ( NonEmpty((:|)))
+import qualified Data.List.NonEmpty as NonEmpty
+import           Data.Typeable
+import           Data.Coerce
+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           Brick (EventM, Widget)
+--------------------------------------------------------------------------------
+import           Xanthous.Data.EntityMap (EntityMap, EntityID)
+import           Xanthous.Data (Positioned(..), Position(..), Neighbors)
+import           Xanthous.Orphans ()
+import           Xanthous.Game.Prompt
+import           Xanthous.Resource
+--------------------------------------------------------------------------------
+
+data MessageHistory
+  = NoMessageHistory
+  | MessageHistory (NonEmpty Text) Bool
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+
+instance Arbitrary MessageHistory where
+  arbitrary = genericArbitrary
+
+pushMessage :: Text -> MessageHistory -> MessageHistory
+pushMessage msg NoMessageHistory = MessageHistory (msg :| []) True
+pushMessage msg (MessageHistory msgs _) = MessageHistory (NonEmpty.cons msg msgs) True
+
+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
+
+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)
+
+type AppM = AppT (EventM Name)
+
+--------------------------------------------------------------------------------
+
+class Draw a where
+  drawWithNeighbors :: Neighbors (Vector SomeEntity) -> a -> Widget n
+  drawWithNeighbors = const draw
+
+  draw :: a -> Widget n
+  draw = drawWithNeighbors $ pure mempty
+
+instance Draw a => Draw (Positioned a) where
+  drawWithNeighbors ns (Positioned _ a) = drawWithNeighbors ns a
+  draw (Positioned _ a) = draw a
+
+--------------------------------------------------------------------------------
+
+class Brain a where
+  step :: Positioned a -> AppM (Positioned a)
+
+newtype Brainless a = Brainless a
+
+instance Brain (Brainless a) where
+  step = pure
+
+-- | Workaround for the inability to use DerivingVia on Brain due to the lack of
+-- higher-order roles (specifically AppT not having its last type argument have
+-- role representational bc of StateT)
+brainVia
+  :: forall brain entity. (Coercible entity brain, Brain brain)
+  => (entity -> brain) -- ^ constructor, ignored
+  -> (Positioned entity -> AppM (Positioned entity))
+brainVia _ = fmap coerce . step . coerce @_ @(Positioned brain)
+
+--------------------------------------------------------------------------------
+
+class (Show a, Eq a, Draw a, Brain a) => Entity a where
+  blocksVision :: a -> Bool
+  description :: a -> Text
+
+data SomeEntity where
+  SomeEntity :: forall a. (Entity a, Typeable a) => a -> SomeEntity
+
+instance Show SomeEntity where
+  show (SomeEntity e) = "SomeEntity (" <> show e <> ")"
+
+instance Eq SomeEntity where
+  (SomeEntity (a :: ea)) == (SomeEntity (b :: eb)) = case eqT @ea @eb of
+    Just Refl -> a == b
+    _ -> False
+
+instance Draw (SomeEntity) where
+  drawWithNeighbors ns (SomeEntity ent) = drawWithNeighbors ns ent
+
+instance Brain SomeEntity where
+  step (Positioned pos (SomeEntity ent)) =
+    fmap SomeEntity <$> step (Positioned pos ent)
+
+instance Entity SomeEntity where
+  blocksVision (SomeEntity ent) = blocksVision ent
+  description (SomeEntity ent) = description ent
+
+downcastEntity :: forall a. (Entity a, Typeable a) => SomeEntity -> Maybe a
+downcastEntity (SomeEntity e) = cast e
+
+entityIs :: forall a. (Entity a, Typeable a) => SomeEntity -> Bool
+entityIs = isJust . downcastEntity @a
+
+_SomeEntity :: forall a. (Entity a, Typeable a) => Prism' SomeEntity a
+_SomeEntity = prism' SomeEntity downcastEntity
+
+--------------------------------------------------------------------------------
+
+data GameState = GameState
+  { _entities          :: !(EntityMap SomeEntity)
+  , _revealedPositions :: !(Set Position)
+  , _characterEntityID :: !EntityID
+  , _messageHistory    :: !MessageHistory
+  , _randomGen         :: !StdGen
+  , _promptState       :: !(GamePromptState AppM)
+  }
+  deriving stock (Show)
+makeLenses ''GameState
+
+instance Eq GameState where
+  (==) = (==) `on` \gs ->
+    ( gs ^. entities
+    , gs ^. revealedPositions
+    , gs ^. characterEntityID
+    , gs ^. messageHistory
+    )
+
+--------------------------------------------------------------------------------
+
+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
generated by cgit-pink 1.4.1 (git 2.44.2) at 2024-10-22T06ยท21+0000