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:
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 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
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 = (|*|)
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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) #-}
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -8,5 +8,5 @@ Creature:
|
||||||
style:
|
style:
|
||||||
foreground: red
|
foreground: red
|
||||||
maxHitpoints: 5
|
maxHitpoints: 5
|
||||||
speed: 120
|
speed: 125
|
||||||
friendly: false
|
friendly: false
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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"
|
||||||
|
|
Loading…
Reference in a new issue