From 1a0f618a829ec356e29176c77ea90a8a5a0157b4 Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Sat, 28 Sep 2019 13:20:57 -0400 Subject: Implement the start of creature AI Add a Brain class, which determines for an entity the set of moves it makes every step of the game, and begin to implement that for gormlaks. The idea here is that every step of the game, a gormlak will move towards the furthest-away wall it can see. --- src/Xanthous/AI/Gormlak.hs | 39 +++++++ src/Xanthous/App.hs | 50 ++++++-- src/Xanthous/Command.hs | 2 + src/Xanthous/Data.hs | 2 + src/Xanthous/Data/EntityMap.hs | 12 ++ src/Xanthous/Data/EntityMap/Graphics.hs | 44 ++++--- src/Xanthous/Entities.hs | 66 ++--------- src/Xanthous/Entities/Arbitrary.hs | 1 + src/Xanthous/Entities/Character.hs | 3 + src/Xanthous/Entities/Creature.hs | 11 +- src/Xanthous/Entities/Environment.hs | 16 ++- src/Xanthous/Entities/Item.hs | 13 ++- src/Xanthous/Entities/Raws.hs | 1 + src/Xanthous/Game.hs | 194 +------------------------------ src/Xanthous/Game/Arbitrary.hs | 27 +++++ src/Xanthous/Game/Lenses.hs | 72 ++++++++++++ src/Xanthous/Game/State.hs | 200 ++++++++++++++++++++++++++++++++ src/Xanthous/Monad.hs | 3 +- src/Xanthous/Util.hs | 1 + 19 files changed, 480 insertions(+), 277 deletions(-) create mode 100644 src/Xanthous/AI/Gormlak.hs create mode 100644 src/Xanthous/Game/Arbitrary.hs create mode 100644 src/Xanthous/Game/Lenses.hs create mode 100644 src/Xanthous/Game/State.hs (limited to 'src') diff --git a/src/Xanthous/AI/Gormlak.hs b/src/Xanthous/AI/Gormlak.hs new file mode 100644 index 0000000000..1cdb977619 --- /dev/null +++ b/src/Xanthous/AI/Gormlak.hs @@ -0,0 +1,39 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +-------------------------------------------------------------------------------- +module Xanthous.AI.Gormlak () where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (lines) +-------------------------------------------------------------------------------- +import Data.Coerce +import Control.Monad.State +-------------------------------------------------------------------------------- +import Xanthous.Data (Positioned(..)) +import qualified Xanthous.Entities.Creature as Creature +import Xanthous.Entities.Creature (Creature) +import qualified Xanthous.Entities.RawTypes as Raw +import Xanthous.Entities (Entity(..), Brain(..), brainVia) +import Xanthous.Game.State (entities, GameState) +import Xanthous.Data.EntityMap.Graphics (linesOfSight) +-------------------------------------------------------------------------------- + +stepGormlak :: MonadState GameState m => Positioned Creature -> m (Positioned Creature) +stepGormlak (Positioned pos creature) = do + lines <- uses entities $ linesOfSight pos (Creature.visionRadius creature) + let newPos = fromMaybe pos + $ fmap fst + . headMay <=< tailMay <=< headMay + . sortOn (Down . length) + $ lines + pure $ Positioned newPos creature + +newtype GormlakBrain = GormlakBrain Creature + +instance Brain GormlakBrain where + step = fmap coerce . stepGormlak . coerce +-------------------------------------------------------------------------------- + +instance Brain Creature where step = brainVia GormlakBrain + +instance Entity Creature where + blocksVision _ = False + description = view $ Creature.creatureType . Raw.description diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs index 8353df437b..8d9ea54f0f 100644 --- a/src/Xanthous/App.hs +++ b/src/Xanthous/App.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ViewPatterns #-} +-------------------------------------------------------------------------------- module Xanthous.App (makeApp) where -------------------------------------------------------------------------------- import Xanthous.Prelude @@ -8,9 +8,8 @@ import qualified Brick import Brick.Widgets.Edit (handleEditorEvent) import Graphics.Vty.Attributes (defAttr) import Graphics.Vty.Input.Events (Event(EvKey), Key(..)) -import Control.Monad.State (get, state, StateT(..), MonadState) +import Control.Monad.State (get, MonadState) import Control.Monad.Random (MonadRandom) -import Data.Coerce import Control.Monad.State.Class (modify) import Data.Aeson (object, ToJSON) import qualified Data.Aeson as A @@ -45,7 +44,6 @@ import qualified Xanthous.Generators.CaveAutomata as CaveAutomata -------------------------------------------------------------------------------- type App = Brick.App GameState () Name -type AppM a = AppT (EventM Name) a makeApp :: IO App makeApp = pure $ Brick.App @@ -85,6 +83,17 @@ initLevel = do characterPosition .= level ^. levelCharacterPosition +-------------------------------------------------------------------------------- + +stepGame :: AppM () +stepGame = do + ents <- uses entities EntityMap.toEIDsAndPositioned + for_ ents $ \(eid, pEntity) -> do + pEntity' <- step pEntity + entities . ix eid .= pEntity' + +-------------------------------------------------------------------------------- + handleEvent :: BrickEvent Name () -> AppM (Next GameState) handleEvent ev = use promptState >>= \case NoPrompt -> handleNoPromptEvent ev @@ -107,6 +116,7 @@ handleCommand (Move dir) = do characterPosition .= newPos describeEntitiesAt newPos modify updateCharacterVision + stepGame Just Combat -> attackAt newPos Just Stop -> pure () continue @@ -120,6 +130,7 @@ handleCommand PickUp = do character %= Character.pickUpItem item entities . at itemID .= Nothing say ["items", "pickUp"] $ object [ "item" A..= item ] + stepGame _ -> undefined continue @@ -139,11 +150,14 @@ handleCommand Open = do entities . ix eid . positioned . _SomeEntity . open .= True say_ ["open", "success"] pure () + stepGame continue +handleCommand Wait = stepGame >> continue + handlePromptEvent :: Text -- ^ Prompt message - -> Prompt (AppT Identity) + -> Prompt AppM -> BrickEvent Name () -> AppM (Next GameState) @@ -151,7 +165,7 @@ handlePromptEvent _ (Prompt Cancellable _ _ _) (VtyEvent (EvKey KEsc [])) = do promptState .= NoPrompt continue handlePromptEvent _ pr (VtyEvent (EvKey KEnter [])) = do - () <- state . coerce $ submitPrompt pr + submitPrompt pr promptState .= NoPrompt continue @@ -168,7 +182,7 @@ handlePromptEvent handlePromptEvent _ (Prompt _ SDirectionPrompt _ cb) (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) [])) = do - () <- state . coerce . cb $ DirectionResult dir + cb $ DirectionResult dir promptState .= NoPrompt continue handlePromptEvent _ (Prompt _ SDirectionPrompt _ _) _ = continue @@ -181,7 +195,7 @@ prompt => [Text] -- ^ Message key -> params -- ^ Message params -> PromptCancellable - -> (PromptResult pt -> AppT Identity ()) -- ^ Prompt promise handler + -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler -> AppM () prompt msgPath params cancellable cb = do let pt = singPromptType @pt @@ -194,7 +208,7 @@ prompt_ (SingPromptType pt) => [Text] -- ^ Message key -> PromptCancellable - -> (PromptResult pt -> AppT Identity ()) -- ^ Prompt promise handler + -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler -> AppM () prompt_ msg = prompt msg $ object [] @@ -242,3 +256,21 @@ attackAt pos = else do say ["combat", "hit"] msgParams entities . ix creatureID . positioned .= SomeEntity creature' + stepGame + +data Collision + = Stop + | Combat + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +collisionAt :: MonadState GameState m => Position -> m (Maybe Collision) +collisionAt pos = do + ents <- use $ entities . EntityMap.atPosition pos + pure $ + if | null ents -> Nothing + | any (entityIs @Creature) ents -> pure Combat + | all (entityIs @Item) ents -> Nothing + | doors@(_ : _) <- ents ^.. folded . _SomeEntity @Door + , all (view open) doors -> Nothing + | otherwise -> pure Stop diff --git a/src/Xanthous/Command.hs b/src/Xanthous/Command.hs index 19c5e17e0a..c2dbfe37ef 100644 --- a/src/Xanthous/Command.hs +++ b/src/Xanthous/Command.hs @@ -15,9 +15,11 @@ data Command | PreviousMessage | PickUp | Open + | Wait commandFromKey :: Key -> [Modifier] -> Maybe Command commandFromKey (KChar 'q') [] = Just Quit +commandFromKey (KChar '.') [] = Just Wait commandFromKey (KChar (directionFromChar -> Just dir)) [] = Just $ Move dir commandFromKey (KChar 'p') [MCtrl] = Just PreviousMessage commandFromKey (KChar ',') [] = Just PickUp diff --git a/src/Xanthous/Data.hs b/src/Xanthous/Data.hs index afba273005..ff9da6280b 100644 --- a/src/Xanthous/Data.hs +++ b/src/Xanthous/Data.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveFoldable #-} @@ -74,6 +75,7 @@ data Positioned a where Positioned :: Position -> a -> Positioned a deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) deriving anyclass (CoArbitrary, Function) +type role Positioned representational _Positioned :: Iso (Position, a) (Position, b) (Positioned a) (Positioned b) _Positioned = iso hither yon diff --git a/src/Xanthous/Data/EntityMap.hs b/src/Xanthous/Data/EntityMap.hs index 7885839d51..5b5e8a063f 100644 --- a/src/Xanthous/Data/EntityMap.hs +++ b/src/Xanthous/Data/EntityMap.hs @@ -14,6 +14,7 @@ module Xanthous.Data.EntityMap , insertAt , insertAtReturningID , fromEIDsAndPositioned + , toEIDsAndPositioned , atPosition , atPositionWithIDs , positions @@ -101,6 +102,14 @@ instance Semigroup (EntityMap a) where instance Monoid (EntityMap a) where mempty = emptyEntityMap +instance FunctorWithIndex EntityID EntityMap + +instance FoldableWithIndex EntityID EntityMap + +instance TraversableWithIndex EntityID EntityMap where + itraversed = byID . itraversed . rmap sequenceA . distrib + itraverse = itraverseOf itraversed + emptyEntityMap :: EntityMap a emptyEntityMap = EntityMap mempty mempty 0 @@ -183,6 +192,9 @@ fromEIDsAndPositioned eps = newLastID $ alaf Endo foldMap insert' eps mempty .~ fromMaybe 1 (maximumOf (ifolded . asIndex) (em ^. byID)) +toEIDsAndPositioned :: EntityMap a -> [(EntityID, Positioned a)] +toEIDsAndPositioned = itoListOf $ byID . ifolded + positions :: EntityMap a -> [Position] positions = toListOf $ byPosition . to keys . folded diff --git a/src/Xanthous/Data/EntityMap/Graphics.hs b/src/Xanthous/Data/EntityMap/Graphics.hs index 9dcc02b8e8..3124c6a334 100644 --- a/src/Xanthous/Data/EntityMap/Graphics.hs +++ b/src/Xanthous/Data/EntityMap/Graphics.hs @@ -3,9 +3,10 @@ module Xanthous.Data.EntityMap.Graphics ( visiblePositions , visibleEntities + , linesOfSight ) where -------------------------------------------------------------------------------- -import Xanthous.Prelude +import Xanthous.Prelude hiding (lines) -------------------------------------------------------------------------------- import Xanthous.Util (takeWhileInclusive) import Xanthous.Data @@ -14,22 +15,37 @@ import Xanthous.Entities import Xanthous.Util.Graphics (circle, line) -------------------------------------------------------------------------------- -visiblePositions :: Position -> Word -> EntityMap SomeEntity -> Set Position +visiblePositions :: Entity e => Position -> Word -> EntityMap e -> Set Position visiblePositions pos radius = setFromList . positions . visibleEntities pos radius - --- | Given a point and a radius of vision, returns a list of all entities that --- are *visible* (eg, not blocked by an entity that obscures vision) from that --- point -visibleEntities :: Position -> Word -> EntityMap SomeEntity -> EntityMap SomeEntity -visibleEntities (view _Position -> pos) visionRadius em - = fromEIDsAndPositioned . fold . fold $ sightAdjustedLines +-- | Returns a list of individual lines of sight, each of which is a list of +-- entities at positions on that line of sight +linesOfSight + :: forall e. Entity e + => Position + -> Word + -> EntityMap e + -> [[(Position, Vector (EntityID, e))]] +linesOfSight (view _Position -> pos) visionRadius em + = entitiesOnLines + <&> takeWhileInclusive (none (blocksVision . snd) . snd) where - -- I love laziness! radius = circle pos $ fromIntegral visionRadius - linesOfSight = radius <&> line pos - entitiesOnLines = linesOfSight <&> map getPositionedAt - sightAdjustedLines = entitiesOnLines <&> takeWhileInclusive (none $ blocksVision . snd) + lines = line pos <$> radius + entitiesOnLines :: [[(Position, Vector (EntityID, e))]] + entitiesOnLines = lines <&> map getPositionedAt + getPositionedAt :: (Int, Int) -> (Position, Vector (EntityID, e)) getPositionedAt p = let ppos = _Position # p - in atPositionWithIDs ppos em + in (ppos, over _2 (view positioned) <$> atPositionWithIDs ppos em) + +-- | Given a point and a radius of vision, returns a list of all entities that +-- are *visible* (eg, not blocked by an entity that obscures vision) from that +-- point +visibleEntities :: Entity e => Position -> Word -> EntityMap e -> EntityMap e +visibleEntities pos visionRadius + = fromEIDsAndPositioned + . fold + . map (\(p, es) -> over _2 (Positioned p) <$> es) + . fold + . linesOfSight pos visionRadius diff --git a/src/Xanthous/Entities.hs b/src/Xanthous/Entities.hs index 66a583f6b3..15080b3221 100644 --- a/src/Xanthous/Entities.hs +++ b/src/Xanthous/Entities.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE AllowAmbiguousTypes #-} -------------------------------------------------------------------------------- module Xanthous.Entities ( Draw(..) @@ -19,72 +20,27 @@ module Xanthous.Entities , EntityChar(..) , HasChar(..) + + , Brain(..) + , Brainless(..) + , brainVia ) where -------------------------------------------------------------------------------- import Xanthous.Prelude hiding ((.=)) -------------------------------------------------------------------------------- import Brick -import Data.Typeable 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.Data import Xanthous.Orphans () +import Xanthous.Game.State -------------------------------------------------------------------------------- -class (Show a, Eq a, Draw a) => Entity a where - blocksVision :: a -> Bool - description :: a -> Text - -instance Entity a => Entity (Positioned a) where - blocksVision (Positioned _ ent) = blocksVision ent - description (Positioned _ ent) = description ent - --------------------------------------------------------------------------------- -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 Entity SomeEntity where - blocksVision (SomeEntity ent) = blocksVision ent - description (SomeEntity ent) = description ent - -downcastEntity :: (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 - --------------------------------------------------------------------------------- - -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 - newtype DrawCharacter (char :: Symbol) (a :: Type) where DrawCharacter :: a -> DrawCharacter char a diff --git a/src/Xanthous/Entities/Arbitrary.hs b/src/Xanthous/Entities/Arbitrary.hs index 2d1890f787..8ba6447933 100644 --- a/src/Xanthous/Entities/Arbitrary.hs +++ b/src/Xanthous/Entities/Arbitrary.hs @@ -12,6 +12,7 @@ import Xanthous.Entities.Character import Xanthous.Entities.Item import Xanthous.Entities.Creature import Xanthous.Entities.Environment +import Xanthous.AI.Gormlak () -------------------------------------------------------------------------------- instance Arbitrary SomeEntity where diff --git a/src/Xanthous/Entities/Character.hs b/src/Xanthous/Entities/Character.hs index 9423f2dc96..1c7d1bbe82 100644 --- a/src/Xanthous/Entities/Character.hs +++ b/src/Xanthous/Entities/Character.hs @@ -41,6 +41,9 @@ instance Draw Character where rloc = Location (negate scrollOffset, negate scrollOffset) rreg = (2 * scrollOffset, 2 * scrollOffset) +-- the character does not (yet) have a mind of its own +instance Brain Character where step = brainVia Brainless + instance Entity Character where blocksVision _ = False description _ = "yourself" diff --git a/src/Xanthous/Entities/Creature.hs b/src/Xanthous/Entities/Creature.hs index 5151f78b30..accf0c42e2 100644 --- a/src/Xanthous/Entities/Creature.hs +++ b/src/Xanthous/Entities/Creature.hs @@ -8,6 +8,7 @@ module Xanthous.Entities.Creature , newWithType , damage , isDead + , visionRadius ) where -------------------------------------------------------------------------------- import Xanthous.Prelude @@ -17,8 +18,7 @@ import Data.Aeson.Generic.DerivingVia import Data.Aeson (ToJSON, FromJSON) -------------------------------------------------------------------------------- import Xanthous.Entities.RawTypes hiding (Creature, description) -import qualified Xanthous.Entities.RawTypes as Raw -import Xanthous.Entities (Draw(..), Entity(..), DrawRawChar(..)) +import Xanthous.Entities (Draw(..), DrawRawChar(..)) -------------------------------------------------------------------------------- data Creature = Creature @@ -35,9 +35,7 @@ makeLenses ''Creature instance Arbitrary Creature where arbitrary = genericArbitrary -instance Entity Creature where - blocksVision _ = False - description = view $ creatureType . Raw.description +-------------------------------------------------------------------------------- newWithType :: CreatureType -> Creature newWithType _creatureType = @@ -52,3 +50,6 @@ damage amount = hitpoints %~ \hp -> isDead :: Creature -> Bool isDead = views hitpoints (== 0) + +visionRadius :: Creature -> Word +visionRadius = const 12 -- TODO diff --git a/src/Xanthous/Entities/Environment.hs b/src/Xanthous/Entities/Environment.hs index 4ef67a577d..e8190cd42a 100644 --- a/src/Xanthous/Entities/Environment.hs +++ b/src/Xanthous/Entities/Environment.hs @@ -13,7 +13,15 @@ import Brick (str) import Brick.Widgets.Border.Style (unicode) import Brick.Types (Edges(..)) -------------------------------------------------------------------------------- -import Xanthous.Entities (Draw(..), entityIs, Entity(..), SomeEntity) +import Xanthous.Entities + ( Draw(..) + , entityIs + , Entity(..) + , SomeEntity + , Brain(..) + , Brainless(..) + , brainVia + ) import Xanthous.Entities.Draw.Util import Xanthous.Data -------------------------------------------------------------------------------- @@ -22,6 +30,9 @@ data Wall = Wall deriving stock (Show, Eq, Ord, Generic, Enum) deriving anyclass (CoArbitrary, Function) +-- deriving via Brainless Wall instance Brain Wall +instance Brain Wall where step = brainVia Brainless + instance Entity Wall where blocksVision _ = True description _ = "a wall" @@ -64,6 +75,9 @@ instance Draw Door where horizDoor = '␣' vertDoor = '[' +-- deriving via Brainless Door instance Brain Door +instance Brain Door where step = brainVia Brainless + instance Entity Door where blocksVision = not . view open description _ = "a door" diff --git a/src/Xanthous/Entities/Item.hs b/src/Xanthous/Entities/Item.hs index 6b50f50ad8..832f0d4d62 100644 --- a/src/Xanthous/Entities/Item.hs +++ b/src/Xanthous/Entities/Item.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StandaloneDeriving #-} -------------------------------------------------------------------------------- module Xanthous.Entities.Item ( Item(..) @@ -13,7 +14,14 @@ import Data.Aeson.Generic.DerivingVia -------------------------------------------------------------------------------- import Xanthous.Entities.RawTypes hiding (Item, description) import qualified Xanthous.Entities.RawTypes as Raw -import Xanthous.Entities (Draw(..), Entity(..), DrawRawChar(..)) +import Xanthous.Entities + ( Draw(..) + , Entity(..) + , DrawRawChar(..) + , Brain(..) + , Brainless(..) + , brainVia + ) -------------------------------------------------------------------------------- data Item = Item @@ -27,6 +35,9 @@ data Item = Item Item makeLenses ''Item +-- deriving via (Brainless Item) instance Brain Item +instance Brain Item where step = brainVia Brainless + instance Arbitrary Item where arbitrary = Item <$> arbitrary diff --git a/src/Xanthous/Entities/Raws.hs b/src/Xanthous/Entities/Raws.hs index e1bb429a0f..9b7d63c6c4 100644 --- a/src/Xanthous/Entities/Raws.hs +++ b/src/Xanthous/Entities/Raws.hs @@ -17,6 +17,7 @@ import Xanthous.Entities.RawTypes import Xanthous.Entities import qualified Xanthous.Entities.Creature as Creature import qualified Xanthous.Entities.Item as Item +import Xanthous.AI.Gormlak () -------------------------------------------------------------------------------- rawRaws :: [(FilePath, ByteString)] rawRaws = $(embedDir "src/Xanthous/Entities/Raws") diff --git a/src/Xanthous/Game.hs b/src/Xanthous/Game.hs index 68bd9e0438..278e3d8ff4 100644 --- a/src/Xanthous/Game.hs +++ b/src/Xanthous/Game.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE RecordWildCards #-} --------------------------------------------------------------------------------- module Xanthous.Game ( GameState(..) , entities @@ -23,194 +19,10 @@ module Xanthous.Game , popMessage , hideMessage - -- * collisions - , Collision(..) - , collisionAt - -- * App monad , AppT(..) ) where -------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Data.List.NonEmpty ( NonEmpty((:|))) -import qualified Data.List.NonEmpty as NonEmpty -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 -import Xanthous.Data.EntityMap.Graphics -import Xanthous.Data (Positioned, Position(..), positioned, position) -import Xanthous.Entities - (SomeEntity(..), downcastEntity, entityIs, _SomeEntity) -import Xanthous.Entities.Character -import Xanthous.Entities.Creature -import Xanthous.Entities.Item -import Xanthous.Entities.Environment -import Xanthous.Entities.Arbitrary () -import Xanthous.Orphans () -import Xanthous.Game.Prompt --------------------------------------------------------------------------------- - -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) - --------------------------------------------------------------------------------- - -data GameState = GameState - { _entities :: !(EntityMap SomeEntity) - , _revealedPositions :: !(Set Position) - , _characterEntityID :: !EntityID - , _messageHistory :: !MessageHistory - , _randomGen :: !StdGen - , _promptState :: !(GamePromptState (AppT Identity)) - } - deriving stock (Show) -makeLenses ''GameState - -instance Eq GameState where - (==) = (==) `on` \gs -> - ( gs ^. entities - , gs ^. revealedPositions - , gs ^. characterEntityID - , gs ^. messageHistory - ) - - -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 {..} - - -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 - - --------------------------------------------------------------------------------- - -data Collision - = Stop - | Combat - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData) - -collisionAt :: MonadState GameState m => Position -> m (Maybe Collision) -collisionAt pos = do - ents <- use $ entities . EntityMap.atPosition pos - pure $ - if | null ents -> Nothing - | any (entityIs @Creature) ents -> pure Combat - | all (entityIs @Item) ents -> Nothing - | doors@(_ : _) <- ents ^.. folded . _SomeEntity @Door - , all (view open) doors -> 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 +import Xanthous.Game.State +import Xanthous.Game.Lenses +import Xanthous.Game.Arbitrary () diff --git a/src/Xanthous/Game/Arbitrary.hs b/src/Xanthous/Game/Arbitrary.hs new file mode 100644 index 0000000000..5ab2301e70 --- /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 0000000000..91ff5c137d --- /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 0000000000..9b81abe352 --- /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 diff --git a/src/Xanthous/Monad.hs b/src/Xanthous/Monad.hs index 4e3e58607c..3e567ee8fa 100644 --- a/src/Xanthous/Monad.hs +++ b/src/Xanthous/Monad.hs @@ -1,5 +1,6 @@ module Xanthous.Monad ( AppT(..) + , AppM , runAppT , continue , halt @@ -14,7 +15,7 @@ import qualified Brick import Brick (EventM, Next) import Data.Aeson -import Xanthous.Game +import Xanthous.Game.State import Xanthous.Messages (message) runAppT :: Monad m => AppT m a -> GameState -> m (a, GameState) diff --git a/src/Xanthous/Util.hs b/src/Xanthous/Util.hs index 439f9e8ffa..d90cf5b03d 100644 --- a/src/Xanthous/Util.hs +++ b/src/Xanthous/Util.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE QuantifiedConstraints #-} module Xanthous.Util ( EqEqProp(..) -- cgit 1.4.1