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
This commit is contained in:
		
							parent
							
								
									abea2dcfac
								
							
						
					
					
						commit
						ec39dc0a5b
					
				
					 8 changed files with 115 additions and 36 deletions
				
			
		|  | @ -41,6 +41,9 @@ dependencies: | |||
| - mtl | ||||
| - optparse-applicative | ||||
| - random | ||||
| - random-fu | ||||
| - random-extras | ||||
| - random-source | ||||
| - raw-strings-qq | ||||
| - reflection | ||||
| - stache | ||||
|  |  | |||
|  | @ -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 | ||||
| 
 | ||||
|  |  | |||
|  | @ -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 | ||||
|  |  | |||
|  | @ -52,4 +52,4 @@ isDead :: Creature -> Bool | |||
| isDead = views hitpoints (== 0) | ||||
| 
 | ||||
| visionRadius :: Creature -> Word | ||||
| visionRadius = const 12 -- TODO | ||||
| visionRadius = const 50 -- TODO | ||||
|  |  | |||
|  | @ -19,6 +19,10 @@ module Xanthous.Game | |||
|   , popMessage | ||||
|   , hideMessage | ||||
| 
 | ||||
|     -- * Collisions | ||||
|   , Collision(..) | ||||
|   , collisionAt | ||||
| 
 | ||||
|     -- * App monad | ||||
|   , AppT(..) | ||||
| 
 | ||||
|  |  | |||
|  | @ -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 | ||||
|  |  | |||
|  | @ -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) | ||||
|  |  | |||
|  | @ -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 | ||||
|  |  | |||
		Loading…
	
	Add table
		Add a link
		
	
		Reference in a new issue