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
parent
8d36fb4af2
commit
8a4220df83
11 changed files with 277 additions and 84 deletions
|
|
@ -10,10 +10,17 @@ import Control.Monad.Random
|
|||
import Data.Aeson (object)
|
||||
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 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 qualified Xanthous.Entities.Character as Character
|
||||
import qualified Xanthous.Entities.RawTypes as Raw
|
||||
|
|
@ -28,30 +35,47 @@ import Xanthous.Monad (say)
|
|||
|
||||
stepGormlak
|
||||
:: (MonadState GameState m, MonadRandom m)
|
||||
=> Positioned Creature
|
||||
=> Ticks
|
||||
-> Positioned Creature
|
||||
-> m (Positioned Creature)
|
||||
stepGormlak pe@(Positioned pos creature) = do
|
||||
newPos <- 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
|
||||
stepGormlak ticks pe@(Positioned pos creature) = do
|
||||
dest <- maybe (selectDestination pos creature) pure
|
||||
$ creature ^. hippocampus . destination
|
||||
let progress' =
|
||||
dest ^. destinationProgress
|
||||
+ creature ^. creatureType . Raw.speed . invertedRate |*| ticks
|
||||
if progress' < 1
|
||||
then pure
|
||||
$ pe
|
||||
& positioned . hippocampus . destination
|
||||
?~ (dest & destinationProgress .~ progress')
|
||||
else do
|
||||
lines <- uses entities $ linesOfSight pos (Creature.visionRadius creature)
|
||||
line <- choose $ weightedBy length lines
|
||||
pure $ fromMaybe pos $ fmap fst . headMay =<< tailMay =<< line
|
||||
collisionAt newPos >>= \case
|
||||
Nothing -> pure $ Positioned newPos creature
|
||||
Just Stop -> pure pe
|
||||
Just Combat -> do
|
||||
ents <- use $ entities . atPosition newPos
|
||||
when (any (entityIs @Character) ents) attackCharacter
|
||||
pure pe
|
||||
|
||||
let newPos = dest ^. destinationPosition
|
||||
remainingSpeed = progress' - 1
|
||||
newDest <- selectDestination newPos creature
|
||||
<&> destinationProgress +~ remainingSpeed
|
||||
let pe' = pe & positioned . hippocampus . destination ?~ newDest
|
||||
collisionAt newPos >>= \case
|
||||
Nothing -> pure $ pe' & position .~ newPos
|
||||
Just Stop -> pure pe'
|
||||
Just Combat -> do
|
||||
ents <- use $ entities . atPosition newPos
|
||||
when (any (entityIs @Character) ents) attackCharacter
|
||||
pure pe'
|
||||
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
|
||||
attackCharacter = do
|
||||
say ["combat", "creatureAttack"] $ object [ "creature" A..= creature ]
|
||||
|
|
@ -60,7 +84,7 @@ stepGormlak pe@(Positioned pos creature) = do
|
|||
newtype GormlakBrain = GormlakBrain Creature
|
||||
|
||||
instance Brain GormlakBrain where
|
||||
step = fmap coerce . stepGormlak . coerce
|
||||
step ticks = fmap coerce . stepGormlak ticks . coerce
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -22,6 +22,9 @@ import Xanthous.Data
|
|||
, Dimensions'(Dimensions)
|
||||
, positioned
|
||||
, Position
|
||||
, Ticks
|
||||
, Position'(Position)
|
||||
, (|*|)
|
||||
)
|
||||
import Xanthous.Data.EntityMap (EntityMap)
|
||||
import qualified Xanthous.Data.EntityMap as EntityMap
|
||||
|
|
@ -85,11 +88,11 @@ initLevel = do
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
stepGame :: AppM ()
|
||||
stepGame = do
|
||||
stepGameBy :: Ticks -> AppM ()
|
||||
stepGameBy ticks = do
|
||||
ents <- uses entities EntityMap.toEIDsAndPositioned
|
||||
for_ ents $ \(eid, pEntity) -> do
|
||||
pEntity' <- step pEntity
|
||||
pEntity' <- step ticks pEntity
|
||||
entities . ix eid .= pEntity'
|
||||
|
||||
whenM (uses (character . characterHitpoints) (== 0))
|
||||
|
|
@ -97,6 +100,12 @@ stepGame = do
|
|||
. const . lift . liftIO
|
||||
$ exitSuccess
|
||||
|
||||
ticksPerTurn :: Ticks
|
||||
ticksPerTurn = 100
|
||||
|
||||
stepGame :: AppM ()
|
||||
stepGame = stepGameBy ticksPerTurn
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
handleEvent :: BrickEvent Name () -> AppM (Next GameState)
|
||||
|
|
@ -119,7 +128,7 @@ handleCommand (Move dir) = do
|
|||
collisionAt newPos >>= \case
|
||||
Nothing -> do
|
||||
characterPosition .= newPos
|
||||
stepGame
|
||||
stepGameBy =<< uses (character . speed) (|*| 1)
|
||||
describeEntitiesAt newPos
|
||||
modify updateCharacterVision
|
||||
Just Combat -> attackAt newPos
|
||||
|
|
@ -135,7 +144,7 @@ handleCommand PickUp = do
|
|||
character %= Character.pickUpItem item
|
||||
entities . at itemID .= Nothing
|
||||
say ["items", "pickUp"] $ object [ "item" A..= item ]
|
||||
stepGame
|
||||
stepGameBy 100 -- TODO
|
||||
_ -> undefined
|
||||
continue
|
||||
|
||||
|
|
@ -155,7 +164,7 @@ handleCommand Open = do
|
|||
entities . ix eid . positioned . _SomeEntity . open .= True
|
||||
say_ ["open", "success"]
|
||||
pure ()
|
||||
stepGame
|
||||
stepGame -- TODO
|
||||
continue
|
||||
|
||||
handleCommand Wait = stepGame >> continue
|
||||
|
|
@ -180,7 +189,7 @@ handleCommand Eat = do
|
|||
character . characterHitpoints +=
|
||||
edibleItem ^. hitpointsHealed . to fromIntegral
|
||||
message msg $ object ["item" A..= item]
|
||||
stepGame
|
||||
stepGame -- TODO
|
||||
continue
|
||||
|
||||
handleCommand ToggleRevealAll = do
|
||||
|
|
@ -318,4 +327,4 @@ attackAt pos =
|
|||
else do
|
||||
say ["combat", "hit"] msgParams
|
||||
entities . ix creatureID . positioned .= SomeEntity creature'
|
||||
stepGame
|
||||
stepGame -- TODO
|
||||
|
|
|
|||
|
|
@ -1,16 +1,20 @@
|
|||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE RoleAnnotations #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE RoleAnnotations #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE DeriveFoldable #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE DeriveFoldable #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE NoTypeSynonymInstances #-}
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Common data types for Xanthous
|
||||
--------------------------------------------------------------------------------
|
||||
module Xanthous.Data
|
||||
( -- *
|
||||
Position(..)
|
||||
Position'(..)
|
||||
, Position
|
||||
, x
|
||||
, y
|
||||
|
||||
|
|
@ -26,6 +30,17 @@ module Xanthous.Data
|
|||
, stepTowards
|
||||
, isUnit
|
||||
|
||||
-- *
|
||||
, Per(..)
|
||||
, invertRate
|
||||
, invertedRate
|
||||
, (|*|)
|
||||
, Ticks(..)
|
||||
, Tiles(..)
|
||||
, TicksPerTile
|
||||
, TilesPerTick
|
||||
, timesTiles
|
||||
|
||||
-- *
|
||||
, Dimensions'(..)
|
||||
, Dimensions
|
||||
|
|
@ -51,33 +66,67 @@ import Test.QuickCheck (Arbitrary, CoArbitrary, Function)
|
|||
import Test.QuickCheck.Arbitrary.Generic
|
||||
import Data.Group
|
||||
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.Orphans ()
|
||||
import Xanthous.Util.Graphics
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Position where
|
||||
Position :: { _x :: Int
|
||||
, _y :: Int
|
||||
} -> Position
|
||||
deriving stock (Show, Eq, Generic, Ord)
|
||||
deriving anyclass (Hashable, CoArbitrary, Function)
|
||||
deriving EqProp via EqEqProp Position
|
||||
makeLenses ''Position
|
||||
-- fromScalar ∘ scalar ≡ id
|
||||
class Scalar a where
|
||||
scalar :: a -> Double
|
||||
fromScalar :: Double -> a
|
||||
|
||||
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
|
||||
shrink = genericShrink
|
||||
|
||||
instance Semigroup Position where
|
||||
instance Num a => Semigroup (Position' a) where
|
||||
(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
|
||||
|
||||
instance Group Position where
|
||||
invert (Position px py) = Position (-px) (-py)
|
||||
instance Num a => Group (Position' a) where
|
||||
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
|
||||
Positioned :: Position -> a -> Positioned a
|
||||
|
|
@ -110,32 +159,32 @@ loc = iso hither yon
|
|||
hither (Position px py) = Location (px, py)
|
||||
yon (Location (lx, ly)) = Position lx ly
|
||||
|
||||
_Position :: Iso' Position (Int, Int)
|
||||
_Position :: Iso' (Position' a) (a, a)
|
||||
_Position = iso hither yon
|
||||
where
|
||||
hither (Position px py) = (px, py)
|
||||
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)
|
||||
|
||||
-- | Add two positions
|
||||
--
|
||||
-- Operation for the additive group on positions
|
||||
addPositions :: Position -> Position -> Position
|
||||
addPositions :: Num a => Position' a -> Position' a -> Position' a
|
||||
addPositions = (<>)
|
||||
|
||||
-- | Subtract two positions.
|
||||
--
|
||||
-- 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₂)
|
||||
|
||||
-- | Is this position a unit position? or: When taken as a difference, does this
|
||||
-- position represent a step of one tile?
|
||||
--
|
||||
-- ∀ dir :: Direction. isUnit ('asPosition' dir)
|
||||
isUnit :: Position -> Bool
|
||||
isUnit :: (Eq a, Num a) => Position' a -> Bool
|
||||
isUnit (Position px py) =
|
||||
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
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
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 = (|*|)
|
||||
|
|
|
|||
|
|
@ -5,6 +5,9 @@ module Xanthous.Entities.Character
|
|||
, inventory
|
||||
, characterDamage
|
||||
, characterHitpoints
|
||||
, speed
|
||||
|
||||
-- *
|
||||
, mkCharacter
|
||||
, pickUpItem
|
||||
, isDead
|
||||
|
|
@ -12,6 +15,7 @@ module Xanthous.Entities.Character
|
|||
) where
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Prelude
|
||||
--------------------------------------------------------------------------------
|
||||
import Test.QuickCheck
|
||||
import Test.QuickCheck.Instances.Vector ()
|
||||
import Test.QuickCheck.Arbitrary.Generic
|
||||
|
|
@ -21,6 +25,7 @@ import Data.Aeson (ToJSON, FromJSON)
|
|||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Entities
|
||||
import Xanthous.Entities.Item
|
||||
import Xanthous.Data (TicksPerTile)
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Character = Character
|
||||
|
|
@ -28,6 +33,7 @@ data Character = Character
|
|||
, _characterName :: !(Maybe Text)
|
||||
, _characterDamage :: !Word
|
||||
, _characterHitpoints :: !Word
|
||||
, _speed :: TicksPerTile
|
||||
}
|
||||
deriving stock (Show, Eq, Generic)
|
||||
deriving anyclass (CoArbitrary, Function)
|
||||
|
|
@ -58,12 +64,16 @@ instance Arbitrary Character where
|
|||
initialHitpoints :: Word
|
||||
initialHitpoints = 10
|
||||
|
||||
defaultSpeed :: TicksPerTile
|
||||
defaultSpeed = 100
|
||||
|
||||
mkCharacter :: Character
|
||||
mkCharacter = Character
|
||||
{ _inventory = mempty
|
||||
, _characterName = Nothing
|
||||
, _characterDamage = 1
|
||||
, _characterHitpoints = initialHitpoints
|
||||
, _speed = defaultSpeed
|
||||
}
|
||||
|
||||
isDead :: Character -> Bool
|
||||
|
|
|
|||
|
|
@ -2,44 +2,101 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
--------------------------------------------------------------------------------
|
||||
module Xanthous.Entities.Creature
|
||||
( Creature(..)
|
||||
( -- * Creature
|
||||
Creature(..)
|
||||
-- ** Lenses
|
||||
, creatureType
|
||||
, hitpoints
|
||||
, hippocampus
|
||||
|
||||
-- ** Creature functions
|
||||
, newWithType
|
||||
, damage
|
||||
, isDead
|
||||
, visionRadius
|
||||
|
||||
-- * Hippocampus
|
||||
, Hippocampus(..)
|
||||
-- ** Lenses
|
||||
, destination
|
||||
-- ** Destination
|
||||
, Destination(..)
|
||||
, destinationFromPos
|
||||
-- *** Lenses
|
||||
, destinationPosition
|
||||
, destinationProgress
|
||||
) where
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Prelude
|
||||
--------------------------------------------------------------------------------
|
||||
import Test.QuickCheck
|
||||
import Test.QuickCheck.Arbitrary.Generic
|
||||
import Data.Aeson.Generic.DerivingVia
|
||||
import Data.Aeson (ToJSON, FromJSON)
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Entities.RawTypes hiding (Creature, description)
|
||||
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
|
||||
{ _creatureType :: CreatureType
|
||||
, _hitpoints :: Word
|
||||
{ _creatureType :: !CreatureType
|
||||
, _hitpoints :: !Word
|
||||
, _hippocampus :: !Hippocampus
|
||||
}
|
||||
deriving stock (Eq, Show, Generic)
|
||||
deriving anyclass (NFData, CoArbitrary, Function)
|
||||
deriving Draw via DrawRawChar "_creatureType" Creature
|
||||
deriving (ToJSON, FromJSON)
|
||||
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
|
||||
Creature
|
||||
instance Arbitrary Creature where arbitrary = genericArbitrary
|
||||
makeLenses ''Creature
|
||||
|
||||
instance Arbitrary Creature where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
newWithType :: CreatureType -> Creature
|
||||
newWithType _creatureType =
|
||||
let _hitpoints = _creatureType ^. maxHitpoints
|
||||
_hippocampus = initialHippocampus
|
||||
in Creature {..}
|
||||
|
||||
damage :: Word -> Creature -> Creature
|
||||
|
|
@ -53,3 +110,5 @@ isDead = views hitpoints (== 0)
|
|||
|
||||
visionRadius :: Creature -> Word
|
||||
visionRadius = const 50 -- TODO
|
||||
|
||||
{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-}
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
--------------------------------------------------------------------------------
|
||||
module Xanthous.Entities.RawTypes
|
||||
|
|
@ -8,6 +8,7 @@ module Xanthous.Entities.RawTypes
|
|||
, isEdible
|
||||
, EntityRaw(..)
|
||||
|
||||
, _Creature
|
||||
-- * Lens classes
|
||||
, HasName(..)
|
||||
, HasDescription(..)
|
||||
|
|
@ -17,7 +18,7 @@ module Xanthous.Entities.RawTypes
|
|||
, HasEatMessage(..)
|
||||
, HasHitpointsHealed(..)
|
||||
, HasEdible(..)
|
||||
, _Creature
|
||||
, HasSpeed(..)
|
||||
) where
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Prelude
|
||||
|
|
@ -28,16 +29,18 @@ import Data.Aeson (ToJSON, FromJSON)
|
|||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Entities (EntityChar, HasChar(..))
|
||||
import Xanthous.Messages (Message(..))
|
||||
import Xanthous.Data (TicksPerTile)
|
||||
--------------------------------------------------------------------------------
|
||||
data CreatureType = CreatureType
|
||||
{ _name :: Text
|
||||
, _description :: Text
|
||||
, _char :: EntityChar
|
||||
, _maxHitpoints :: Word
|
||||
, _friendly :: Bool
|
||||
{ _name :: !Text
|
||||
, _description :: !Text
|
||||
, _char :: !EntityChar
|
||||
, _maxHitpoints :: !Word
|
||||
, _friendly :: !Bool
|
||||
, _speed :: !TicksPerTile
|
||||
}
|
||||
deriving stock (Show, Eq, Generic)
|
||||
deriving anyclass (NFData)
|
||||
deriving anyclass (NFData, CoArbitrary, Function)
|
||||
deriving (ToJSON, FromJSON)
|
||||
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
|
||||
CreatureType
|
||||
|
|
|
|||
|
|
@ -8,5 +8,5 @@ Creature:
|
|||
style:
|
||||
foreground: red
|
||||
maxHitpoints: 5
|
||||
speed: 120
|
||||
speed: 125
|
||||
friendly: false
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ import Brick.Widgets.Border
|
|||
import Brick.Widgets.Border.Style
|
||||
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 qualified Xanthous.Data.EntityMap as EntityMap
|
||||
import Xanthous.Entities
|
||||
|
|
|
|||
|
|
@ -57,7 +57,8 @@ import Control.Monad.Random.Class
|
|||
import Brick (EventM, Widget)
|
||||
--------------------------------------------------------------------------------
|
||||
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.Game.Prompt
|
||||
import Xanthous.Resource
|
||||
|
|
@ -149,12 +150,12 @@ instance Draw a => Draw (Positioned a) where
|
|||
--------------------------------------------------------------------------------
|
||||
|
||||
class Brain a where
|
||||
step :: Positioned a -> AppM (Positioned a)
|
||||
step :: Ticks -> Positioned a -> AppM (Positioned a)
|
||||
|
||||
newtype Brainless a = Brainless a
|
||||
|
||||
instance Brain (Brainless a) where
|
||||
step = pure
|
||||
step = const 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
|
||||
|
|
@ -162,8 +163,8 @@ instance Brain (Brainless a) where
|
|||
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)
|
||||
-> (Ticks -> Positioned entity -> AppM (Positioned entity))
|
||||
brainVia _ ticks = fmap coerce . step ticks . coerce @_ @(Positioned brain)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -186,8 +187,8 @@ 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)
|
||||
step ticks (Positioned pos (SomeEntity ent)) =
|
||||
fmap SomeEntity <$> step ticks (Positioned pos ent)
|
||||
|
||||
instance Entity SomeEntity where
|
||||
blocksVision (SomeEntity ent) = blocksVision ent
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ import Control.Monad.Random
|
|||
import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
|
||||
import Xanthous.Generators.Util
|
||||
import Xanthous.Generators.LevelContents
|
||||
import Xanthous.Data (Dimensions, Position(Position))
|
||||
import Xanthous.Data (Dimensions, Position'(Position), Position)
|
||||
import Xanthous.Data.EntityMap (EntityMap)
|
||||
import qualified Xanthous.Data.EntityMap as EntityMap
|
||||
import Xanthous.Entities.Environment
|
||||
|
|
|
|||
|
|
@ -24,15 +24,15 @@ test = testGroup "Xanthous.Data"
|
|||
]
|
||||
, testProperty "directionOf laws" $ \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₂)
|
||||
, testGroup "isUnit"
|
||||
[ testProperty "double direction is never unit" $ \dir ->
|
||||
not . isUnit $ move dir (asPosition dir)
|
||||
, testCase "examples" $ do
|
||||
isUnit (Position 1 1) @? "not . isUnit $ Position 1 1"
|
||||
isUnit (Position 0 (-1)) @? "not . isUnit $ Position 0 (-1)"
|
||||
(not . isUnit) (Position 1 13) @? "isUnit $ Position 1 13"
|
||||
isUnit (Position @Int 1 1) @? "not . isUnit $ Position 1 1"
|
||||
isUnit (Position @Int 0 (-1)) @? "not . isUnit $ Position 0 (-1)"
|
||||
(not . isUnit) (Position @Int 1 13) @? "isUnit $ Position 1 13"
|
||||
]
|
||||
]
|
||||
, testGroup "Direction"
|
||||
|
|
|
|||
Loading…
Reference in a new issue