Implement speed and ticks

Gormlaks now move 1/8th the speed of the character, which means we can
run away from them - yay!

Unfortunately this also introduces a bug where they'll eventually get
stuck and not do anything, so I'll be tackling that next.
This commit is contained in:
Griffin Smith 2019-10-13 12:37:08 -04:00
parent 8d36fb4af2
commit 8a4220df83
11 changed files with 277 additions and 84 deletions

View file

@ -10,10 +10,17 @@ import Control.Monad.Random
import Data.Aeson (object) import Data.Aeson (object)
import qualified Data.Aeson as A import qualified Data.Aeson as A
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Data (Positioned(..), diffPositions, stepTowards, isUnit) import Xanthous.Data
( Positioned(..), positioned, position
, diffPositions, stepTowards, isUnit
, Ticks, (|*|), invertedRate
)
import Xanthous.Data.EntityMap import Xanthous.Data.EntityMap
import qualified Xanthous.Entities.Creature as Creature import qualified Xanthous.Entities.Creature as Creature
import Xanthous.Entities.Creature (Creature) import Xanthous.Entities.Creature
( Creature, hippocampus, creatureType
, destination, destinationProgress, destinationPosition
)
import Xanthous.Entities.Character (Character) import Xanthous.Entities.Character (Character)
import qualified Xanthous.Entities.Character as Character import qualified Xanthous.Entities.Character as Character
import qualified Xanthous.Entities.RawTypes as Raw import qualified Xanthous.Entities.RawTypes as Raw
@ -28,30 +35,47 @@ import Xanthous.Monad (say)
stepGormlak stepGormlak
:: (MonadState GameState m, MonadRandom m) :: (MonadState GameState m, MonadRandom m)
=> Positioned Creature => Ticks
-> Positioned Creature
-> m (Positioned Creature) -> m (Positioned Creature)
stepGormlak pe@(Positioned pos creature) = do stepGormlak ticks pe@(Positioned pos creature) = do
newPos <- do dest <- maybe (selectDestination pos creature) pure
canSeeCharacter <- uses entities $ canSee (entityIs @Character) pos vision $ creature ^. hippocampus . destination
if canSeeCharacter let progress' =
then do dest ^. destinationProgress
charPos <- use characterPosition + creature ^. creatureType . Raw.speed . invertedRate |*| ticks
if isUnit (pos `diffPositions` charPos) if progress' < 1
then attackCharacter $> pos then pure
else pure $ pos `stepTowards` charPos $ pe
& positioned . hippocampus . destination
?~ (dest & destinationProgress .~ progress')
else do else do
lines <- uses entities $ linesOfSight pos (Creature.visionRadius creature) let newPos = dest ^. destinationPosition
line <- choose $ weightedBy length lines remainingSpeed = progress' - 1
pure $ fromMaybe pos $ fmap fst . headMay =<< tailMay =<< line newDest <- selectDestination newPos creature
collisionAt newPos >>= \case <&> destinationProgress +~ remainingSpeed
Nothing -> pure $ Positioned newPos creature let pe' = pe & positioned . hippocampus . destination ?~ newDest
Just Stop -> pure pe collisionAt newPos >>= \case
Just Combat -> do Nothing -> pure $ pe' & position .~ newPos
ents <- use $ entities . atPosition newPos Just Stop -> pure pe'
when (any (entityIs @Character) ents) attackCharacter Just Combat -> do
pure pe ents <- use $ entities . atPosition newPos
when (any (entityIs @Character) ents) attackCharacter
pure pe'
where where
selectDestination pos' creature' = Creature.destinationFromPos <$> do
canSeeCharacter <- uses entities $ canSee (entityIs @Character) pos' vision
if canSeeCharacter
then do
charPos <- use characterPosition
if isUnit (pos' `diffPositions` charPos)
then attackCharacter $> pos'
else pure $ pos' `stepTowards` charPos
else do
lines <- uses entities $ linesOfSight pos' (Creature.visionRadius creature')
line <- choose $ weightedBy length lines
pure $ fromMaybe pos' $ fmap fst . headMay =<< tailMay =<< line
vision = Creature.visionRadius creature vision = Creature.visionRadius creature
attackCharacter = do attackCharacter = do
say ["combat", "creatureAttack"] $ object [ "creature" A..= creature ] say ["combat", "creatureAttack"] $ object [ "creature" A..= creature ]
@ -60,7 +84,7 @@ stepGormlak pe@(Positioned pos creature) = do
newtype GormlakBrain = GormlakBrain Creature newtype GormlakBrain = GormlakBrain Creature
instance Brain GormlakBrain where instance Brain GormlakBrain where
step = fmap coerce . stepGormlak . coerce step ticks = fmap coerce . stepGormlak ticks . coerce
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

View file

@ -22,6 +22,9 @@ import Xanthous.Data
, Dimensions'(Dimensions) , Dimensions'(Dimensions)
, positioned , positioned
, Position , Position
, Ticks
, Position'(Position)
, (|*|)
) )
import Xanthous.Data.EntityMap (EntityMap) import Xanthous.Data.EntityMap (EntityMap)
import qualified Xanthous.Data.EntityMap as EntityMap import qualified Xanthous.Data.EntityMap as EntityMap
@ -85,11 +88,11 @@ initLevel = do
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
stepGame :: AppM () stepGameBy :: Ticks -> AppM ()
stepGame = do stepGameBy ticks = do
ents <- uses entities EntityMap.toEIDsAndPositioned ents <- uses entities EntityMap.toEIDsAndPositioned
for_ ents $ \(eid, pEntity) -> do for_ ents $ \(eid, pEntity) -> do
pEntity' <- step pEntity pEntity' <- step ticks pEntity
entities . ix eid .= pEntity' entities . ix eid .= pEntity'
whenM (uses (character . characterHitpoints) (== 0)) whenM (uses (character . characterHitpoints) (== 0))
@ -97,6 +100,12 @@ stepGame = do
. const . lift . liftIO . const . lift . liftIO
$ exitSuccess $ exitSuccess
ticksPerTurn :: Ticks
ticksPerTurn = 100
stepGame :: AppM ()
stepGame = stepGameBy ticksPerTurn
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
handleEvent :: BrickEvent Name () -> AppM (Next GameState) handleEvent :: BrickEvent Name () -> AppM (Next GameState)
@ -119,7 +128,7 @@ handleCommand (Move dir) = do
collisionAt newPos >>= \case collisionAt newPos >>= \case
Nothing -> do Nothing -> do
characterPosition .= newPos characterPosition .= newPos
stepGame stepGameBy =<< uses (character . speed) (|*| 1)
describeEntitiesAt newPos describeEntitiesAt newPos
modify updateCharacterVision modify updateCharacterVision
Just Combat -> attackAt newPos Just Combat -> attackAt newPos
@ -135,7 +144,7 @@ handleCommand PickUp = do
character %= Character.pickUpItem item character %= Character.pickUpItem item
entities . at itemID .= Nothing entities . at itemID .= Nothing
say ["items", "pickUp"] $ object [ "item" A..= item ] say ["items", "pickUp"] $ object [ "item" A..= item ]
stepGame stepGameBy 100 -- TODO
_ -> undefined _ -> undefined
continue continue
@ -155,7 +164,7 @@ handleCommand Open = do
entities . ix eid . positioned . _SomeEntity . open .= True entities . ix eid . positioned . _SomeEntity . open .= True
say_ ["open", "success"] say_ ["open", "success"]
pure () pure ()
stepGame stepGame -- TODO
continue continue
handleCommand Wait = stepGame >> continue handleCommand Wait = stepGame >> continue
@ -180,7 +189,7 @@ handleCommand Eat = do
character . characterHitpoints += character . characterHitpoints +=
edibleItem ^. hitpointsHealed . to fromIntegral edibleItem ^. hitpointsHealed . to fromIntegral
message msg $ object ["item" A..= item] message msg $ object ["item" A..= item]
stepGame stepGame -- TODO
continue continue
handleCommand ToggleRevealAll = do handleCommand ToggleRevealAll = do
@ -318,4 +327,4 @@ attackAt pos =
else do else do
say ["combat", "hit"] msgParams say ["combat", "hit"] msgParams
entities . ix creatureID . positioned .= SomeEntity creature' entities . ix creatureID . positioned .= SomeEntity creature'
stepGame stepGame -- TODO

View file

@ -1,16 +1,20 @@
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoTypeSynonymInstances #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Common data types for Xanthous -- | Common data types for Xanthous
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
module Xanthous.Data module Xanthous.Data
( -- * ( -- *
Position(..) Position'(..)
, Position
, x , x
, y , y
@ -26,6 +30,17 @@ module Xanthous.Data
, stepTowards , stepTowards
, isUnit , isUnit
-- *
, Per(..)
, invertRate
, invertedRate
, (|*|)
, Ticks(..)
, Tiles(..)
, TicksPerTile
, TilesPerTick
, timesTiles
-- * -- *
, Dimensions'(..) , Dimensions'(..)
, Dimensions , Dimensions
@ -51,33 +66,67 @@ import Test.QuickCheck (Arbitrary, CoArbitrary, Function)
import Test.QuickCheck.Arbitrary.Generic import Test.QuickCheck.Arbitrary.Generic
import Data.Group import Data.Group
import Brick (Location(Location), Edges(..)) import Brick (Location(Location), Edges(..))
import Data.Monoid (Product(..), Sum(..))
import Data.Aeson.Generic.DerivingVia
import Data.Aeson (ToJSON, FromJSON)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Util (EqEqProp(..), EqProp) import Xanthous.Util (EqEqProp(..), EqProp)
import Xanthous.Orphans () import Xanthous.Orphans ()
import Xanthous.Util.Graphics import Xanthous.Util.Graphics
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
data Position where -- fromScalar ∘ scalar ≡ id
Position :: { _x :: Int class Scalar a where
, _y :: Int scalar :: a -> Double
} -> Position fromScalar :: Double -> a
deriving stock (Show, Eq, Generic, Ord)
deriving anyclass (Hashable, CoArbitrary, Function)
deriving EqProp via EqEqProp Position
makeLenses ''Position
instance Arbitrary Position where instance Scalar Double where
scalar = id
fromScalar = id
newtype ScalarIntegral a = ScalarIntegral a
deriving newtype (Eq, Ord, Num, Enum, Real, Integral)
instance Integral a => Scalar (ScalarIntegral a) where
scalar = fromIntegral
fromScalar = floor
deriving via (ScalarIntegral Integer) instance Scalar Integer
deriving via (ScalarIntegral Word) instance Scalar Word
--------------------------------------------------------------------------------
data Position' a where
Position :: { _x :: a
, _y :: a
} -> (Position' a)
deriving stock (Show, Eq, Generic, Ord, Functor, Foldable, Traversable)
deriving anyclass (NFData, Hashable, CoArbitrary, Function)
deriving EqProp via EqEqProp (Position' a)
deriving (ToJSON, FromJSON)
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
(Position' a)
makeLenses ''Position'
type Position = Position' Int
instance Arbitrary a => Arbitrary (Position' a) where
arbitrary = genericArbitrary arbitrary = genericArbitrary
shrink = genericShrink shrink = genericShrink
instance Semigroup Position where instance Num a => Semigroup (Position' a) where
(Position x y) <> (Position x y) = Position (x + x) (y + y) (Position x y) <> (Position x y) = Position (x + x) (y + y)
instance Monoid Position where instance Num a => Monoid (Position' a) where
mempty = Position 0 0 mempty = Position 0 0
instance Group Position where instance Num a => Group (Position' a) where
invert (Position px py) = Position (-px) (-py) invert (Position px py) = Position (negate px) (negate py)
-- | Positions convert to scalars by discarding their orientation and just
-- measuring the length from the origin
instance (Ord a, Num a, Scalar a) => Scalar (Position' a) where
scalar = fromIntegral . length . line (0, 0) . view _Position
fromScalar n = Position (fromScalar n) (fromScalar n)
data Positioned a where data Positioned a where
Positioned :: Position -> a -> Positioned a Positioned :: Position -> a -> Positioned a
@ -110,32 +159,32 @@ loc = iso hither yon
hither (Position px py) = Location (px, py) hither (Position px py) = Location (px, py)
yon (Location (lx, ly)) = Position lx ly yon (Location (lx, ly)) = Position lx ly
_Position :: Iso' Position (Int, Int) _Position :: Iso' (Position' a) (a, a)
_Position = iso hither yon _Position = iso hither yon
where where
hither (Position px py) = (px, py) hither (Position px py) = (px, py)
yon (lx, ly) = Position lx ly yon (lx, ly) = Position lx ly
positionFromPair :: (Integral i, Integral j) => (i, j) -> Position positionFromPair :: (Num a, Integral i, Integral j) => (i, j) -> Position' a
positionFromPair (i, j) = Position (fromIntegral i) (fromIntegral j) positionFromPair (i, j) = Position (fromIntegral i) (fromIntegral j)
-- | Add two positions -- | Add two positions
-- --
-- Operation for the additive group on positions -- Operation for the additive group on positions
addPositions :: Position -> Position -> Position addPositions :: Num a => Position' a -> Position' a -> Position' a
addPositions = (<>) addPositions = (<>)
-- | Subtract two positions. -- | Subtract two positions.
-- --
-- diffPositions pos₁ pos₂ = pos₁ `addPositions` (invert pos₂) -- diffPositions pos₁ pos₂ = pos₁ `addPositions` (invert pos₂)
diffPositions :: Position -> Position -> Position diffPositions :: Num a => Position' a -> Position' a -> Position' a
diffPositions (Position x y) (Position x y) = Position (x - x) (y - y) diffPositions (Position x y) (Position x y) = Position (x - x) (y - y)
-- | Is this position a unit position? or: When taken as a difference, does this -- | Is this position a unit position? or: When taken as a difference, does this
-- position represent a step of one tile? -- position represent a step of one tile?
-- --
-- ∀ dir :: Direction. isUnit ('asPosition' dir) -- ∀ dir :: Direction. isUnit ('asPosition' dir)
isUnit :: Position -> Bool isUnit :: (Eq a, Num a) => Position' a -> Bool
isUnit (Position px py) = isUnit (Position px py) =
abs px `elem` [0,1] && abs py `elem` [0, 1] && (px, py) /= (0, 0) abs px `elem` [0,1] && abs py `elem` [0, 1] && (px, py) /= (0, 0)
@ -291,3 +340,41 @@ neighborPositions :: Position -> Neighbors Position
neighborPositions pos = (`move` pos) <$> neighborDirections neighborPositions pos = (`move` pos) <$> neighborDirections
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
newtype Per a b = Rate Double
deriving stock (Show, Eq, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving (Num, Ord, Enum, Real, ToJSON, FromJSON) via Double
deriving (Semigroup, Monoid) via Product Double
instance Arbitrary (Per a b) where arbitrary = genericArbitrary
invertRate :: a `Per` b -> b `Per` a
invertRate (Rate p) = Rate $ 1 / p
invertedRate :: Iso (a `Per` b) (b' `Per` a') (b `Per` a) (a' `Per` b')
invertedRate = iso invertRate invertRate
infixl 7 |*|
(|*|) :: (Scalar a, Scalar b) => a `Per` b -> b -> a
(|*|) (Rate rate) b = fromScalar $ rate * scalar b
newtype Ticks = Ticks Word
deriving stock (Show, Eq, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving (Num, Ord, Bounded, Enum, Integral, Real, ToJSON, FromJSON) via Word
deriving (Semigroup, Monoid) via (Sum Word)
deriving Scalar via ScalarIntegral Ticks
instance Arbitrary Ticks where arbitrary = genericArbitrary
newtype Tiles = Tiles Double
deriving stock (Show, Eq, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving (Num, Ord, Enum, Real, ToJSON, FromJSON, Scalar) via Double
deriving (Semigroup, Monoid) via (Sum Double)
instance Arbitrary Tiles where arbitrary = genericArbitrary
type TicksPerTile = Ticks `Per` Tiles
type TilesPerTick = Tiles `Per` Ticks
timesTiles :: TicksPerTile -> Tiles -> Ticks
timesTiles = (|*|)

View file

@ -5,6 +5,9 @@ module Xanthous.Entities.Character
, inventory , inventory
, characterDamage , characterDamage
, characterHitpoints , characterHitpoints
, speed
-- *
, mkCharacter , mkCharacter
, pickUpItem , pickUpItem
, isDead , isDead
@ -12,6 +15,7 @@ module Xanthous.Entities.Character
) where ) where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Prelude import Xanthous.Prelude
--------------------------------------------------------------------------------
import Test.QuickCheck import Test.QuickCheck
import Test.QuickCheck.Instances.Vector () import Test.QuickCheck.Instances.Vector ()
import Test.QuickCheck.Arbitrary.Generic import Test.QuickCheck.Arbitrary.Generic
@ -21,6 +25,7 @@ import Data.Aeson (ToJSON, FromJSON)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Entities import Xanthous.Entities
import Xanthous.Entities.Item import Xanthous.Entities.Item
import Xanthous.Data (TicksPerTile)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
data Character = Character data Character = Character
@ -28,6 +33,7 @@ data Character = Character
, _characterName :: !(Maybe Text) , _characterName :: !(Maybe Text)
, _characterDamage :: !Word , _characterDamage :: !Word
, _characterHitpoints :: !Word , _characterHitpoints :: !Word
, _speed :: TicksPerTile
} }
deriving stock (Show, Eq, Generic) deriving stock (Show, Eq, Generic)
deriving anyclass (CoArbitrary, Function) deriving anyclass (CoArbitrary, Function)
@ -58,12 +64,16 @@ instance Arbitrary Character where
initialHitpoints :: Word initialHitpoints :: Word
initialHitpoints = 10 initialHitpoints = 10
defaultSpeed :: TicksPerTile
defaultSpeed = 100
mkCharacter :: Character mkCharacter :: Character
mkCharacter = Character mkCharacter = Character
{ _inventory = mempty { _inventory = mempty
, _characterName = Nothing , _characterName = Nothing
, _characterDamage = 1 , _characterDamage = 1
, _characterHitpoints = initialHitpoints , _characterHitpoints = initialHitpoints
, _speed = defaultSpeed
} }
isDead :: Character -> Bool isDead :: Character -> Bool

View file

@ -2,44 +2,101 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
module Xanthous.Entities.Creature module Xanthous.Entities.Creature
( Creature(..) ( -- * Creature
Creature(..)
-- ** Lenses
, creatureType , creatureType
, hitpoints , hitpoints
, hippocampus
-- ** Creature functions
, newWithType , newWithType
, damage , damage
, isDead , isDead
, visionRadius , visionRadius
-- * Hippocampus
, Hippocampus(..)
-- ** Lenses
, destination
-- ** Destination
, Destination(..)
, destinationFromPos
-- *** Lenses
, destinationPosition
, destinationProgress
) where ) where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Prelude import Xanthous.Prelude
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Test.QuickCheck
import Test.QuickCheck.Arbitrary.Generic import Test.QuickCheck.Arbitrary.Generic
import Data.Aeson.Generic.DerivingVia import Data.Aeson.Generic.DerivingVia
import Data.Aeson (ToJSON, FromJSON) import Data.Aeson (ToJSON, FromJSON)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Entities.RawTypes hiding (Creature, description) import Xanthous.Entities.RawTypes hiding (Creature, description)
import Xanthous.Entities (Draw(..), DrawRawChar(..)) import Xanthous.Entities (Draw(..), DrawRawChar(..))
import Xanthous.Data
--------------------------------------------------------------------------------
data Destination = Destination
{ _destinationPosition :: !Position
-- | The progress towards the destination, tracked as an offset from the
-- creature's original position.
--
-- When this value reaches >= 1, the creature has reached their destination
, _destinationProgress :: !Tiles
}
deriving stock (Eq, Show, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving (ToJSON, FromJSON)
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
Destination
instance Arbitrary Destination where arbitrary = genericArbitrary
makeLenses ''Destination
destinationFromPos :: Position -> Destination
destinationFromPos _destinationPosition =
let _destinationProgress = 0
in Destination{..}
data Hippocampus = Hippocampus
{ _destination :: !(Maybe Destination)
}
deriving stock (Eq, Show, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving (ToJSON, FromJSON)
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
Hippocampus
instance Arbitrary Hippocampus where arbitrary = genericArbitrary
makeLenses ''Hippocampus
initialHippocampus :: Hippocampus
initialHippocampus = Hippocampus Nothing
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
data Creature = Creature data Creature = Creature
{ _creatureType :: CreatureType { _creatureType :: !CreatureType
, _hitpoints :: Word , _hitpoints :: !Word
, _hippocampus :: !Hippocampus
} }
deriving stock (Eq, Show, Generic) deriving stock (Eq, Show, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving Draw via DrawRawChar "_creatureType" Creature deriving Draw via DrawRawChar "_creatureType" Creature
deriving (ToJSON, FromJSON) deriving (ToJSON, FromJSON)
via WithOptions '[ FieldLabelModifier '[Drop 1] ] via WithOptions '[ FieldLabelModifier '[Drop 1] ]
Creature Creature
instance Arbitrary Creature where arbitrary = genericArbitrary
makeLenses ''Creature makeLenses ''Creature
instance Arbitrary Creature where
arbitrary = genericArbitrary
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
newWithType :: CreatureType -> Creature newWithType :: CreatureType -> Creature
newWithType _creatureType = newWithType _creatureType =
let _hitpoints = _creatureType ^. maxHitpoints let _hitpoints = _creatureType ^. maxHitpoints
_hippocampus = initialHippocampus
in Creature {..} in Creature {..}
damage :: Word -> Creature -> Creature damage :: Word -> Creature -> Creature
@ -53,3 +110,5 @@ isDead = views hitpoints (== 0)
visionRadius :: Creature -> Word visionRadius :: Creature -> Word
visionRadius = const 50 -- TODO visionRadius = const 50 -- TODO
{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-}

View file

@ -1,4 +1,4 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
module Xanthous.Entities.RawTypes module Xanthous.Entities.RawTypes
@ -8,6 +8,7 @@ module Xanthous.Entities.RawTypes
, isEdible , isEdible
, EntityRaw(..) , EntityRaw(..)
, _Creature
-- * Lens classes -- * Lens classes
, HasName(..) , HasName(..)
, HasDescription(..) , HasDescription(..)
@ -17,7 +18,7 @@ module Xanthous.Entities.RawTypes
, HasEatMessage(..) , HasEatMessage(..)
, HasHitpointsHealed(..) , HasHitpointsHealed(..)
, HasEdible(..) , HasEdible(..)
, _Creature , HasSpeed(..)
) where ) where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Prelude import Xanthous.Prelude
@ -28,16 +29,18 @@ import Data.Aeson (ToJSON, FromJSON)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Entities (EntityChar, HasChar(..)) import Xanthous.Entities (EntityChar, HasChar(..))
import Xanthous.Messages (Message(..)) import Xanthous.Messages (Message(..))
import Xanthous.Data (TicksPerTile)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
data CreatureType = CreatureType data CreatureType = CreatureType
{ _name :: Text { _name :: !Text
, _description :: Text , _description :: !Text
, _char :: EntityChar , _char :: !EntityChar
, _maxHitpoints :: Word , _maxHitpoints :: !Word
, _friendly :: Bool , _friendly :: !Bool
, _speed :: !TicksPerTile
} }
deriving stock (Show, Eq, Generic) deriving stock (Show, Eq, Generic)
deriving anyclass (NFData) deriving anyclass (NFData, CoArbitrary, Function)
deriving (ToJSON, FromJSON) deriving (ToJSON, FromJSON)
via WithOptions '[ FieldLabelModifier '[Drop 1] ] via WithOptions '[ FieldLabelModifier '[Drop 1] ]
CreatureType CreatureType

View file

@ -8,5 +8,5 @@ Creature:
style: style:
foreground: red foreground: red
maxHitpoints: 5 maxHitpoints: 5
speed: 120 speed: 125
friendly: false friendly: false

View file

@ -9,7 +9,7 @@ import Brick.Widgets.Border
import Brick.Widgets.Border.Style import Brick.Widgets.Border.Style
import Brick.Widgets.Edit import Brick.Widgets.Edit
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Data (Position(Position), x, y, loc) import Xanthous.Data (Position'(..), type Position, x, y, loc)
import Xanthous.Data.EntityMap (EntityMap, atPosition) import Xanthous.Data.EntityMap (EntityMap, atPosition)
import qualified Xanthous.Data.EntityMap as EntityMap import qualified Xanthous.Data.EntityMap as EntityMap
import Xanthous.Entities import Xanthous.Entities

View file

@ -57,7 +57,8 @@ import Control.Monad.Random.Class
import Brick (EventM, Widget) import Brick (EventM, Widget)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Data.EntityMap (EntityMap, EntityID) import Xanthous.Data.EntityMap (EntityMap, EntityID)
import Xanthous.Data (Positioned(..), Position(..), Neighbors) import Xanthous.Data
(Positioned(..), type Position, Neighbors, Ticks(..))
import Xanthous.Orphans () import Xanthous.Orphans ()
import Xanthous.Game.Prompt import Xanthous.Game.Prompt
import Xanthous.Resource import Xanthous.Resource
@ -149,12 +150,12 @@ instance Draw a => Draw (Positioned a) where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
class Brain a where class Brain a where
step :: Positioned a -> AppM (Positioned a) step :: Ticks -> Positioned a -> AppM (Positioned a)
newtype Brainless a = Brainless a newtype Brainless a = Brainless a
instance Brain (Brainless a) where instance Brain (Brainless a) where
step = pure step = const pure
-- | Workaround for the inability to use DerivingVia on Brain due to the lack of -- | 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 -- higher-order roles (specifically AppT not having its last type argument have
@ -162,8 +163,8 @@ instance Brain (Brainless a) where
brainVia brainVia
:: forall brain entity. (Coercible entity brain, Brain brain) :: forall brain entity. (Coercible entity brain, Brain brain)
=> (entity -> brain) -- ^ constructor, ignored => (entity -> brain) -- ^ constructor, ignored
-> (Positioned entity -> AppM (Positioned entity)) -> (Ticks -> Positioned entity -> AppM (Positioned entity))
brainVia _ = fmap coerce . step . coerce @_ @(Positioned brain) brainVia _ ticks = fmap coerce . step ticks . coerce @_ @(Positioned brain)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -186,8 +187,8 @@ instance Draw SomeEntity where
drawWithNeighbors ns (SomeEntity ent) = drawWithNeighbors ns ent drawWithNeighbors ns (SomeEntity ent) = drawWithNeighbors ns ent
instance Brain SomeEntity where instance Brain SomeEntity where
step (Positioned pos (SomeEntity ent)) = step ticks (Positioned pos (SomeEntity ent)) =
fmap SomeEntity <$> step (Positioned pos ent) fmap SomeEntity <$> step ticks (Positioned pos ent)
instance Entity SomeEntity where instance Entity SomeEntity where
blocksVision (SomeEntity ent) = blocksVision ent blocksVision (SomeEntity ent) = blocksVision ent

View file

@ -26,7 +26,7 @@ import Control.Monad.Random
import qualified Xanthous.Generators.CaveAutomata as CaveAutomata import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
import Xanthous.Generators.Util import Xanthous.Generators.Util
import Xanthous.Generators.LevelContents import Xanthous.Generators.LevelContents
import Xanthous.Data (Dimensions, Position(Position)) import Xanthous.Data (Dimensions, Position'(Position), Position)
import Xanthous.Data.EntityMap (EntityMap) import Xanthous.Data.EntityMap (EntityMap)
import qualified Xanthous.Data.EntityMap as EntityMap import qualified Xanthous.Data.EntityMap as EntityMap
import Xanthous.Entities.Environment import Xanthous.Entities.Environment

View file

@ -24,15 +24,15 @@ test = testGroup "Xanthous.Data"
] ]
, testProperty "directionOf laws" $ \pos dir -> , testProperty "directionOf laws" $ \pos dir ->
directionOf pos (move dir pos) == dir directionOf pos (move dir pos) == dir
, testProperty "diffPositions is add inverse" $ \pos pos -> , testProperty "diffPositions is add inverse" $ \(pos :: Position) pos ->
diffPositions pos pos == addPositions pos (invert pos) diffPositions pos pos == addPositions pos (invert pos)
, testGroup "isUnit" , testGroup "isUnit"
[ testProperty "double direction is never unit" $ \dir -> [ testProperty "double direction is never unit" $ \dir ->
not . isUnit $ move dir (asPosition dir) not . isUnit $ move dir (asPosition dir)
, testCase "examples" $ do , testCase "examples" $ do
isUnit (Position 1 1) @? "not . isUnit $ Position 1 1" isUnit (Position @Int 1 1) @? "not . isUnit $ Position 1 1"
isUnit (Position 0 (-1)) @? "not . isUnit $ Position 0 (-1)" isUnit (Position @Int 0 (-1)) @? "not . isUnit $ Position 0 (-1)"
(not . isUnit) (Position 1 13) @? "isUnit $ Position 1 13" (not . isUnit) (Position @Int 1 13) @? "isUnit $ Position 1 13"
] ]
] ]
, testGroup "Direction" , testGroup "Direction"