From ec39dc0a5bed58e0b0b48eeac98e0fd0ceaa65db Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Sat, 28 Sep 2019 15:02:30 -0400 Subject: Tweak gormlak movement slightly - Don't let gormlaks run into things like walls or each other - Add a small element of randomness to gormlaks' motion - Increase gormlaks' vision by a large amount --- package.yaml | 3 +++ src/Xanthous/AI/Gormlak.hs | 34 +++++++++++++++++++++------- src/Xanthous/App.hs | 22 ------------------ src/Xanthous/Entities/Creature.hs | 2 +- src/Xanthous/Game.hs | 4 ++++ src/Xanthous/Game/Lenses.hs | 28 +++++++++++++++++++++++ src/Xanthous/Random.hs | 47 +++++++++++++++++++++++++++++++++++---- xanthous.cabal | 11 ++++++++- 8 files changed, 115 insertions(+), 36 deletions(-) diff --git a/package.yaml b/package.yaml index fe4dde46c816..aa1b52ed032e 100644 --- a/package.yaml +++ b/package.yaml @@ -41,6 +41,9 @@ dependencies: - mtl - optparse-applicative - random +- random-fu +- random-extras +- random-source - raw-strings-qq - reflection - stache diff --git a/src/Xanthous/AI/Gormlak.hs b/src/Xanthous/AI/Gormlak.hs index 1cdb977619f3..6ea9254ba200 100644 --- a/src/Xanthous/AI/Gormlak.hs +++ b/src/Xanthous/AI/Gormlak.hs @@ -6,25 +6,43 @@ import Xanthous.Prelude hiding (lines) -------------------------------------------------------------------------------- import Data.Coerce import Control.Monad.State +import Control.Monad.Random -------------------------------------------------------------------------------- -import Xanthous.Data (Positioned(..)) +import Xanthous.Data (Positioned(..), positioned) +import Xanthous.Data.EntityMap import qualified Xanthous.Entities.Creature as Creature import Xanthous.Entities.Creature (Creature) +import Xanthous.Entities.Character (Character) import qualified Xanthous.Entities.RawTypes as Raw import Xanthous.Entities (Entity(..), Brain(..), brainVia) -import Xanthous.Game.State (entities, GameState) +import Xanthous.Game.State (entities, GameState, entityIs) +import Xanthous.Game.Lenses (Collision(..), collisionAt) import Xanthous.Data.EntityMap.Graphics (linesOfSight) +import Xanthous.Random -------------------------------------------------------------------------------- -stepGormlak :: MonadState GameState m => Positioned Creature -> m (Positioned Creature) -stepGormlak (Positioned pos creature) = do +stepGormlak + :: (MonadState GameState m, MonadRandom m) + => Positioned Creature + -> m (Positioned Creature) +stepGormlak pe@(Positioned pos creature) = do lines <- uses entities $ linesOfSight pos (Creature.visionRadius creature) + line <- choose $ weightedBy length lines + -- traceShowM ("current position", pos) + -- traceShowM ("lines", (headMay <=< tailMay) <$> lines) let newPos = fromMaybe pos $ fmap fst - . headMay <=< tailMay <=< headMay - . sortOn (Down . length) - $ lines - pure $ Positioned newPos creature + . headMay + =<< tailMay + =<< line + collisionAt newPos >>= \case + Nothing -> pure $ Positioned newPos creature + Just Stop -> pure pe + Just Combat -> do + ents <- use $ entities . atPosition newPos + if | any (entityIs @Creature) ents -> pure pe + | any (entityIs @Character) ents -> undefined + | otherwise -> pure pe newtype GormlakBrain = GormlakBrain Creature diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs index cff4a4d611e3..1632c39e586d 100644 --- a/src/Xanthous/App.hs +++ b/src/Xanthous/App.hs @@ -57,11 +57,6 @@ 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 - startEvent :: AppM () startEvent = do initLevel @@ -264,20 +259,3 @@ attackAt pos = 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/Entities/Creature.hs b/src/Xanthous/Entities/Creature.hs index accf0c42e2ad..f2c789d6a6a8 100644 --- a/src/Xanthous/Entities/Creature.hs +++ b/src/Xanthous/Entities/Creature.hs @@ -52,4 +52,4 @@ isDead :: Creature -> Bool isDead = views hitpoints (== 0) visionRadius :: Creature -> Word -visionRadius = const 12 -- TODO +visionRadius = const 50 -- TODO diff --git a/src/Xanthous/Game.hs b/src/Xanthous/Game.hs index ffbeddb29d1a..2b346ace5631 100644 --- a/src/Xanthous/Game.hs +++ b/src/Xanthous/Game.hs @@ -19,6 +19,10 @@ module Xanthous.Game , popMessage , hideMessage + -- * Collisions + , Collision(..) + , collisionAt + -- * App monad , AppT(..) diff --git a/src/Xanthous/Game/Lenses.hs b/src/Xanthous/Game/Lenses.hs index 91ff5c137d1a..e077e339cd87 100644 --- a/src/Xanthous/Game/Lenses.hs +++ b/src/Xanthous/Game/Lenses.hs @@ -6,17 +6,25 @@ module Xanthous.Game.Lenses , characterPosition , updateCharacterVision , getInitialState + + -- * Collisions + , Collision(..) + , collisionAt ) where -------------------------------------------------------------------------------- import Xanthous.Prelude -------------------------------------------------------------------------------- import System.Random +import Control.Monad.State -------------------------------------------------------------------------------- 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) +import Xanthous.Entities.Environment (Door, open) +import Xanthous.Entities.Item (Item) +import Xanthous.Entities.Creature (Creature) -------------------------------------------------------------------------------- getInitialState :: IO GameState @@ -31,6 +39,9 @@ getInitialState = do _messageHistory = NoMessageHistory _revealedPositions = mempty _promptState = NoPrompt + _debugState = DebugState + { _allRevealed = False + } pure GameState {..} @@ -70,3 +81,20 @@ 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 diff --git a/src/Xanthous/Random.hs b/src/Xanthous/Random.hs index 33ada54cf105..bbf176f71d6e 100644 --- a/src/Xanthous/Random.hs +++ b/src/Xanthous/Random.hs @@ -1,14 +1,34 @@ -{-# LANGUAGE TupleSections #-} +-------------------------------------------------------------------------------- {-# LANGUAGE UndecidableInstances #-} - +{-# OPTIONS_GHC -fno-warn-orphans #-} +-------------------------------------------------------------------------------- module Xanthous.Random ( Choose(..) , ChooseElement(..) + , Weighted(..) + , evenlyWeighted + , weightedBy ) where - +-------------------------------------------------------------------------------- import Xanthous.Prelude +-------------------------------------------------------------------------------- import Data.List.NonEmpty (NonEmpty) -import Control.Monad.Random.Class (MonadRandom(getRandomR)) +import Control.Monad.Random.Class (MonadRandom(getRandomR, getRandom)) +import Data.Random.Shuffle.Weighted +import Data.Random.Distribution +import Data.Random.Distribution.Uniform +import Data.Random.Distribution.Uniform.Exclusive +import Data.Random.Sample +import qualified Data.Random.Source as DRS +-------------------------------------------------------------------------------- + +instance {-# INCOHERENT #-} (Monad m, MonadRandom m) => DRS.MonadRandom m where + getRandomWord8 = getRandom + getRandomWord16 = getRandom + getRandomWord32 = getRandom + getRandomWord64 = getRandom + getRandomDouble = getRandom + getRandomNByteInteger n = getRandomR (0, 256 ^ n) class Choose a where type RandomResult a @@ -37,3 +57,22 @@ instance MonoFoldable a => Choose (NonNull a) where instance Choose (NonEmpty a) where type RandomResult (NonEmpty a) = a choose = choose . fromNonEmpty @[_] + +newtype Weighted w t a = Weighted (t (w, a)) + +evenlyWeighted :: [a] -> Weighted Int [] a +evenlyWeighted = Weighted . itoList + +weightedBy :: Functor t => (a -> w) -> t a -> Weighted w t a +weightedBy weighting xs = Weighted $ (weighting &&& id) <$> xs + +instance (Num w, Ord w, Distribution Uniform w, Excludable w) => Choose (Weighted w [] a) where + type RandomResult (Weighted w [] a) = Maybe a + choose (Weighted ws) = sample $ headMay <$> weightedSample 1 ws + +instance (Num w, Ord w, Distribution Uniform w, Excludable w) => Choose (Weighted w NonEmpty a) where + type RandomResult (Weighted w NonEmpty a) = a + choose (Weighted ws) = + sample + $ fromMaybe (error "unreachable") . headMay + <$> weightedSample 1 (toList ws) diff --git a/xanthous.cabal b/xanthous.cabal index e0a2571677b5..022b6442094e 100644 --- a/xanthous.cabal +++ b/xanthous.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 121c6fd553f5e73ac5ff4c89f17eacc3a85997255aba87390943a418b439896c +-- hash: ad4acf50f6be0dc7ae6c68d9920b61c2d32b5d759aae7311a124d159b4a9bc7f name: xanthous version: 0.1.0.0 @@ -96,6 +96,9 @@ library , quickcheck-instances , quickcheck-text , random + , random-extras + , random-fu + , random-source , raw-strings-qq , reflection , stache @@ -173,6 +176,9 @@ executable xanthous , quickcheck-instances , quickcheck-text , random + , random-extras + , random-fu + , random-source , raw-strings-qq , reflection , stache @@ -228,6 +234,9 @@ test-suite test , quickcheck-instances , quickcheck-text , random + , random-extras + , random-fu + , random-source , raw-strings-qq , reflection , stache -- cgit 1.4.1