Gormlaks attack back
When gormlaks see the character, they step towards them and attack dealing 1 damage when adjacent. Characters have hitpoints now, displayed at the bottom of the game screen, and when the game is over they die.
This commit is contained in:
parent
ec39dc0a5b
commit
05da490185
11 changed files with 163 additions and 22 deletions
|
@ -7,18 +7,22 @@ import Xanthous.Prelude hiding (lines)
|
||||||
import Data.Coerce
|
import Data.Coerce
|
||||||
import Control.Monad.State
|
import Control.Monad.State
|
||||||
import Control.Monad.Random
|
import Control.Monad.Random
|
||||||
|
import Data.Aeson (object)
|
||||||
|
import qualified Data.Aeson as A
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Xanthous.Data (Positioned(..), positioned)
|
import Xanthous.Data (Positioned(..), diffPositions, stepTowards, isUnit)
|
||||||
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)
|
||||||
import Xanthous.Entities.Character (Character)
|
import Xanthous.Entities.Character (Character, characterHitpoints)
|
||||||
import qualified Xanthous.Entities.RawTypes as Raw
|
import qualified Xanthous.Entities.RawTypes as Raw
|
||||||
import Xanthous.Entities (Entity(..), Brain(..), brainVia)
|
import Xanthous.Entities (Entity(..), Brain(..), brainVia)
|
||||||
import Xanthous.Game.State (entities, GameState, entityIs)
|
import Xanthous.Game.State (entities, GameState, entityIs)
|
||||||
import Xanthous.Game.Lenses (Collision(..), collisionAt)
|
import Xanthous.Game.Lenses
|
||||||
import Xanthous.Data.EntityMap.Graphics (linesOfSight)
|
( Collision(..), collisionAt, character, characterPosition )
|
||||||
|
import Xanthous.Data.EntityMap.Graphics (linesOfSight, canSee)
|
||||||
import Xanthous.Random
|
import Xanthous.Random
|
||||||
|
import Xanthous.Monad (say)
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
stepGormlak
|
stepGormlak
|
||||||
|
@ -26,28 +30,37 @@ stepGormlak
|
||||||
=> Positioned Creature
|
=> Positioned Creature
|
||||||
-> m (Positioned Creature)
|
-> m (Positioned Creature)
|
||||||
stepGormlak pe@(Positioned pos creature) = do
|
stepGormlak pe@(Positioned pos creature) = do
|
||||||
lines <- uses entities $ linesOfSight pos (Creature.visionRadius creature)
|
newPos <- do
|
||||||
line <- choose $ weightedBy length lines
|
canSeeCharacter <- uses entities $ canSee (entityIs @Character) pos vision
|
||||||
-- traceShowM ("current position", pos)
|
if canSeeCharacter
|
||||||
-- traceShowM ("lines", (headMay <=< tailMay) <$> lines)
|
then do
|
||||||
let newPos = fromMaybe pos
|
charPos <- use characterPosition
|
||||||
$ fmap fst
|
if isUnit (pos `diffPositions` charPos)
|
||||||
. headMay
|
then attackCharacter $> charPos
|
||||||
=<< tailMay
|
else pure $ pos `stepTowards` charPos
|
||||||
=<< line
|
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
|
collisionAt newPos >>= \case
|
||||||
Nothing -> pure $ Positioned newPos creature
|
Nothing -> pure $ Positioned newPos creature
|
||||||
Just Stop -> pure pe
|
Just Stop -> pure pe
|
||||||
Just Combat -> do
|
Just Combat -> do
|
||||||
ents <- use $ entities . atPosition newPos
|
ents <- use $ entities . atPosition newPos
|
||||||
if | any (entityIs @Creature) ents -> pure pe
|
when (any (entityIs @Character) ents) attackCharacter
|
||||||
| any (entityIs @Character) ents -> undefined
|
pure pe
|
||||||
| otherwise -> pure pe
|
|
||||||
|
where
|
||||||
|
vision = Creature.visionRadius creature
|
||||||
|
attackCharacter = do
|
||||||
|
say ["combat", "creatureAttack"] $ object [ "creature" A..= creature ]
|
||||||
|
character . characterHitpoints -= 1
|
||||||
|
|
||||||
newtype GormlakBrain = GormlakBrain Creature
|
newtype GormlakBrain = GormlakBrain Creature
|
||||||
|
|
||||||
instance Brain GormlakBrain where
|
instance Brain GormlakBrain where
|
||||||
step = fmap coerce . stepGormlak . coerce
|
step = fmap coerce . stepGormlak . coerce
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
instance Brain Creature where step = brainVia GormlakBrain
|
instance Brain Creature where step = brainVia GormlakBrain
|
||||||
|
|
|
@ -13,6 +13,7 @@ import Control.Monad.Random (MonadRandom)
|
||||||
import Control.Monad.State.Class (modify)
|
import Control.Monad.State.Class (modify)
|
||||||
import Data.Aeson (object, ToJSON)
|
import Data.Aeson (object, ToJSON)
|
||||||
import qualified Data.Aeson as A
|
import qualified Data.Aeson as A
|
||||||
|
import System.Exit
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Xanthous.Command
|
import Xanthous.Command
|
||||||
import Xanthous.Data
|
import Xanthous.Data
|
||||||
|
@ -32,13 +33,12 @@ import Xanthous.Messages (message)
|
||||||
import Xanthous.Util.Inflection (toSentence)
|
import Xanthous.Util.Inflection (toSentence)
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import qualified Xanthous.Entities.Character as Character
|
import qualified Xanthous.Entities.Character as Character
|
||||||
import Xanthous.Entities.Character (characterName)
|
import Xanthous.Entities.Character
|
||||||
import Xanthous.Entities
|
import Xanthous.Entities
|
||||||
import Xanthous.Entities.Item (Item)
|
import Xanthous.Entities.Item (Item)
|
||||||
import Xanthous.Entities.Creature (Creature)
|
import Xanthous.Entities.Creature (Creature)
|
||||||
import qualified Xanthous.Entities.Creature as Creature
|
import qualified Xanthous.Entities.Creature as Creature
|
||||||
import Xanthous.Entities.Environment (Door, open, locked)
|
import Xanthous.Entities.Environment (Door, open, locked)
|
||||||
import Xanthous.Entities.Character
|
|
||||||
import Xanthous.Generators
|
import Xanthous.Generators
|
||||||
import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
|
import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
@ -87,6 +87,11 @@ stepGame = do
|
||||||
pEntity' <- step pEntity
|
pEntity' <- step pEntity
|
||||||
entities . ix eid .= pEntity'
|
entities . ix eid .= pEntity'
|
||||||
|
|
||||||
|
whenM (uses (character . characterHitpoints) (== 0))
|
||||||
|
. prompt_ @'Continue ["dead"] Uncancellable
|
||||||
|
. const . lift . liftIO
|
||||||
|
$ exitSuccess
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
handleEvent :: BrickEvent Name () -> AppM (Next GameState)
|
handleEvent :: BrickEvent Name () -> AppM (Next GameState)
|
||||||
|
@ -189,6 +194,8 @@ handlePromptEvent _ (Prompt _ SDirectionPrompt _ cb)
|
||||||
continue
|
continue
|
||||||
handlePromptEvent _ (Prompt _ SDirectionPrompt _ _) _ = continue
|
handlePromptEvent _ (Prompt _ SDirectionPrompt _ _) _ = continue
|
||||||
|
|
||||||
|
handlePromptEvent _ (Prompt _ SContinue _ _) _ = continue
|
||||||
|
|
||||||
handlePromptEvent _ _ _ = undefined
|
handlePromptEvent _ _ _ = undefined
|
||||||
|
|
||||||
prompt
|
prompt
|
||||||
|
|
|
@ -1,3 +1,4 @@
|
||||||
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
{-# LANGUAGE RoleAnnotations #-}
|
{-# LANGUAGE RoleAnnotations #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE DeriveTraversable #-}
|
{-# LANGUAGE DeriveTraversable #-}
|
||||||
|
@ -8,7 +9,8 @@
|
||||||
-- | Common data types for Xanthous
|
-- | Common data types for Xanthous
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
module Xanthous.Data
|
module Xanthous.Data
|
||||||
( Position(..)
|
( -- *
|
||||||
|
Position(..)
|
||||||
, x
|
, x
|
||||||
, y
|
, y
|
||||||
|
|
||||||
|
@ -19,6 +21,10 @@ module Xanthous.Data
|
||||||
, loc
|
, loc
|
||||||
, _Position
|
, _Position
|
||||||
, positionFromPair
|
, positionFromPair
|
||||||
|
, addPositions
|
||||||
|
, diffPositions
|
||||||
|
, stepTowards
|
||||||
|
, isUnit
|
||||||
|
|
||||||
-- *
|
-- *
|
||||||
, Dimensions'(..)
|
, Dimensions'(..)
|
||||||
|
@ -31,6 +37,7 @@ module Xanthous.Data
|
||||||
, opposite
|
, opposite
|
||||||
, move
|
, move
|
||||||
, asPosition
|
, asPosition
|
||||||
|
, directionOf
|
||||||
|
|
||||||
-- *
|
-- *
|
||||||
, Neighbors(..)
|
, Neighbors(..)
|
||||||
|
@ -47,6 +54,7 @@ import Brick (Location(Location), Edges(..))
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Xanthous.Util (EqEqProp(..), EqProp)
|
import Xanthous.Util (EqEqProp(..), EqProp)
|
||||||
import Xanthous.Orphans ()
|
import Xanthous.Orphans ()
|
||||||
|
import Xanthous.Util.Graphics
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
data Position where
|
data Position where
|
||||||
|
@ -111,6 +119,25 @@ _Position = iso hither yon
|
||||||
positionFromPair :: (Integral i, Integral j) => (i, j) -> Position
|
positionFromPair :: (Integral i, Integral j) => (i, j) -> Position
|
||||||
positionFromPair (i, j) = Position (fromIntegral i) (fromIntegral j)
|
positionFromPair (i, j) = Position (fromIntegral i) (fromIntegral j)
|
||||||
|
|
||||||
|
-- | Add two positions
|
||||||
|
--
|
||||||
|
-- Operation for the additive group on positions
|
||||||
|
addPositions :: Position -> Position -> Position
|
||||||
|
addPositions = (<>)
|
||||||
|
|
||||||
|
-- | Subtract two positions.
|
||||||
|
--
|
||||||
|
-- diffPositions pos₁ pos₂ = pos₁ `addPositions` (invert pos₂)
|
||||||
|
diffPositions :: Position -> Position -> Position
|
||||||
|
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 (Position px py) = abs px == 1 || abs py == 1
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
data Dimensions' a = Dimensions
|
data Dimensions' a = Dimensions
|
||||||
|
@ -169,6 +196,38 @@ move Here = id
|
||||||
asPosition :: Direction -> Position
|
asPosition :: Direction -> Position
|
||||||
asPosition dir = move dir mempty
|
asPosition dir = move dir mempty
|
||||||
|
|
||||||
|
-- | Returns the direction that a given position is from a given source position
|
||||||
|
directionOf
|
||||||
|
:: Position -- ^ Source
|
||||||
|
-> Position -- ^ Target
|
||||||
|
-> Direction
|
||||||
|
directionOf (Position x₁ y₁) (Position x₂ y₂) =
|
||||||
|
case (x₁ `compare` x₂, y₁ `compare` y₂) of
|
||||||
|
(EQ, EQ) -> Here
|
||||||
|
(EQ, LT) -> Down
|
||||||
|
(EQ, GT) -> Up
|
||||||
|
(LT, EQ) -> Right
|
||||||
|
(GT, EQ) -> Left
|
||||||
|
|
||||||
|
(LT, LT) -> DownRight
|
||||||
|
(GT, LT) -> DownLeft
|
||||||
|
|
||||||
|
(LT, GT) -> UpRight
|
||||||
|
(GT, GT) -> UpLeft
|
||||||
|
|
||||||
|
-- | Take one (potentially diagonal) step towards the given position
|
||||||
|
--
|
||||||
|
-- ∀ src tgt. isUnit (src `diffPositions` (src `stepTowards tgt`))
|
||||||
|
stepTowards
|
||||||
|
:: Position -- ^ Source
|
||||||
|
-> Position -- ^ Target
|
||||||
|
-> Position
|
||||||
|
stepTowards (view _Position -> p₁) (view _Position -> p₂)
|
||||||
|
| p₁ == p₂ = _Position # p₁
|
||||||
|
| otherwise =
|
||||||
|
let (_:p:_) = line p₁ p₂
|
||||||
|
in _Position # p
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
data Neighbors a = Neighbors
|
data Neighbors a = Neighbors
|
||||||
|
@ -229,3 +288,5 @@ neighborDirections = Neighbors
|
||||||
|
|
||||||
neighborPositions :: Position -> Neighbors Position
|
neighborPositions :: Position -> Neighbors Position
|
||||||
neighborPositions pos = (`move` pos) <$> neighborDirections
|
neighborPositions pos = (`move` pos) <$> neighborDirections
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
|
@ -110,6 +110,9 @@ instance TraversableWithIndex EntityID EntityMap where
|
||||||
itraversed = byID . itraversed . rmap sequenceA . distrib
|
itraversed = byID . itraversed . rmap sequenceA . distrib
|
||||||
itraverse = itraverseOf itraversed
|
itraverse = itraverseOf itraversed
|
||||||
|
|
||||||
|
type instance Element (EntityMap a) = a
|
||||||
|
instance MonoFoldable (EntityMap a)
|
||||||
|
|
||||||
emptyEntityMap :: EntityMap a
|
emptyEntityMap :: EntityMap a
|
||||||
emptyEntityMap = EntityMap mempty mempty 0
|
emptyEntityMap = EntityMap mempty mempty 0
|
||||||
|
|
||||||
|
|
|
@ -4,6 +4,7 @@ module Xanthous.Data.EntityMap.Graphics
|
||||||
( visiblePositions
|
( visiblePositions
|
||||||
, visibleEntities
|
, visibleEntities
|
||||||
, linesOfSight
|
, linesOfSight
|
||||||
|
, canSee
|
||||||
) where
|
) where
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Xanthous.Prelude hiding (lines)
|
import Xanthous.Prelude hiding (lines)
|
||||||
|
@ -49,3 +50,7 @@ visibleEntities pos visionRadius
|
||||||
. map (\(p, es) -> over _2 (Positioned p) <$> es)
|
. map (\(p, es) -> over _2 (Positioned p) <$> es)
|
||||||
. fold
|
. fold
|
||||||
. linesOfSight pos visionRadius
|
. linesOfSight pos visionRadius
|
||||||
|
|
||||||
|
canSee :: Entity e => (e -> Bool) -> Position -> Word -> EntityMap e -> Bool
|
||||||
|
canSee match pos radius = any match . visibleEntities pos radius
|
||||||
|
-- ^ this might be optimizable
|
||||||
|
|
|
@ -4,8 +4,10 @@ module Xanthous.Entities.Character
|
||||||
, characterName
|
, characterName
|
||||||
, inventory
|
, inventory
|
||||||
, characterDamage
|
, characterDamage
|
||||||
|
, characterHitpoints
|
||||||
, mkCharacter
|
, mkCharacter
|
||||||
, pickUpItem
|
, pickUpItem
|
||||||
|
, isDead
|
||||||
) where
|
) where
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Xanthous.Prelude
|
import Xanthous.Prelude
|
||||||
|
@ -24,6 +26,7 @@ data Character = Character
|
||||||
{ _inventory :: !(Vector Item)
|
{ _inventory :: !(Vector Item)
|
||||||
, _characterName :: !(Maybe Text)
|
, _characterName :: !(Maybe Text)
|
||||||
, _characterDamage :: !Word
|
, _characterDamage :: !Word
|
||||||
|
, _characterHitpoints :: !Word
|
||||||
}
|
}
|
||||||
deriving stock (Show, Eq, Generic)
|
deriving stock (Show, Eq, Generic)
|
||||||
deriving anyclass (CoArbitrary, Function)
|
deriving anyclass (CoArbitrary, Function)
|
||||||
|
@ -51,13 +54,20 @@ instance Entity Character where
|
||||||
instance Arbitrary Character where
|
instance Arbitrary Character where
|
||||||
arbitrary = genericArbitrary
|
arbitrary = genericArbitrary
|
||||||
|
|
||||||
|
initialHitpoints :: Word
|
||||||
|
initialHitpoints = 10
|
||||||
|
|
||||||
mkCharacter :: Character
|
mkCharacter :: Character
|
||||||
mkCharacter = Character
|
mkCharacter = Character
|
||||||
{ _inventory = mempty
|
{ _inventory = mempty
|
||||||
, _characterName = Nothing
|
, _characterName = Nothing
|
||||||
, _characterDamage = 1
|
, _characterDamage = 1
|
||||||
|
, _characterHitpoints = initialHitpoints
|
||||||
}
|
}
|
||||||
|
|
||||||
|
isDead :: Character -> Bool
|
||||||
|
isDead = (== 0) . view characterHitpoints
|
||||||
|
|
||||||
pickUpItem :: Item -> Character -> Character
|
pickUpItem :: Item -> Character -> Character
|
||||||
pickUpItem item = inventory %~ (item <|)
|
pickUpItem item = inventory %~ (item <|)
|
||||||
|
|
||||||
|
|
|
@ -14,11 +14,13 @@ import Xanthous.Data (Position(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
|
||||||
|
import Xanthous.Entities.Character
|
||||||
import Xanthous.Game
|
import Xanthous.Game
|
||||||
( GameState(..)
|
( GameState(..)
|
||||||
, entities
|
, entities
|
||||||
, revealedPositions
|
, revealedPositions
|
||||||
, characterPosition
|
, characterPosition
|
||||||
|
, character
|
||||||
, MessageHistory(..)
|
, MessageHistory(..)
|
||||||
, messageHistory
|
, messageHistory
|
||||||
, GamePromptState(..)
|
, GamePromptState(..)
|
||||||
|
@ -42,8 +44,8 @@ drawPromptState (WaitingPrompt msg (Prompt _ pt ps _)) =
|
||||||
case (pt, ps) of
|
case (pt, ps) of
|
||||||
(SStringPrompt, StringPromptState edit) ->
|
(SStringPrompt, StringPromptState edit) ->
|
||||||
txt msg <+> renderEditor (txt . fold) True edit
|
txt msg <+> renderEditor (txt . fold) True edit
|
||||||
(SDirectionPrompt, DirectionPromptState) ->
|
(SDirectionPrompt, DirectionPromptState) -> txt msg
|
||||||
txt msg
|
(SContinue, _) -> txt msg
|
||||||
_ -> undefined
|
_ -> undefined
|
||||||
|
|
||||||
drawEntities
|
drawEntities
|
||||||
|
@ -79,6 +81,17 @@ drawMap game
|
||||||
-- character can't see them
|
-- character can't see them
|
||||||
(game ^. entities)
|
(game ^. entities)
|
||||||
|
|
||||||
|
drawCharacterInfo :: Character -> Widget Name
|
||||||
|
drawCharacterInfo ch = txt " " <+> charName <+> charHitpoints
|
||||||
|
where
|
||||||
|
charName | Just n <- ch ^. characterName
|
||||||
|
= txt n <+> txt " "
|
||||||
|
| otherwise
|
||||||
|
= emptyWidget
|
||||||
|
charHitpoints
|
||||||
|
= txt "Hitpoints: "
|
||||||
|
<+> txt (tshow $ ch ^. characterHitpoints)
|
||||||
|
|
||||||
drawGame :: GameState -> [Widget Name]
|
drawGame :: GameState -> [Widget Name]
|
||||||
drawGame game
|
drawGame game
|
||||||
= pure
|
= pure
|
||||||
|
@ -86,3 +99,4 @@ drawGame game
|
||||||
$ drawMessages (game ^. messageHistory)
|
$ drawMessages (game ^. messageHistory)
|
||||||
<=> drawPromptState (game ^. promptState)
|
<=> drawPromptState (game ^. promptState)
|
||||||
<=> border (drawMap game)
|
<=> border (drawMap game)
|
||||||
|
<=> drawCharacterInfo (game ^. character)
|
||||||
|
|
|
@ -31,6 +31,7 @@ data PromptType where
|
||||||
Menu :: Type -> PromptType
|
Menu :: Type -> PromptType
|
||||||
DirectionPrompt :: PromptType
|
DirectionPrompt :: PromptType
|
||||||
PointOnMap :: PromptType
|
PointOnMap :: PromptType
|
||||||
|
Continue :: PromptType
|
||||||
deriving stock (Generic)
|
deriving stock (Generic)
|
||||||
|
|
||||||
instance Show PromptType where
|
instance Show PromptType where
|
||||||
|
@ -39,6 +40,7 @@ instance Show PromptType where
|
||||||
show (Menu _) = "Menu"
|
show (Menu _) = "Menu"
|
||||||
show DirectionPrompt = "DirectionPrompt"
|
show DirectionPrompt = "DirectionPrompt"
|
||||||
show PointOnMap = "PointOnMap"
|
show PointOnMap = "PointOnMap"
|
||||||
|
show Continue = "Continue"
|
||||||
|
|
||||||
data SPromptType :: PromptType -> Type where
|
data SPromptType :: PromptType -> Type where
|
||||||
SStringPrompt :: SPromptType 'StringPrompt
|
SStringPrompt :: SPromptType 'StringPrompt
|
||||||
|
@ -46,10 +48,12 @@ data SPromptType :: PromptType -> Type where
|
||||||
SMenu :: forall a. SPromptType ('Menu a)
|
SMenu :: forall a. SPromptType ('Menu a)
|
||||||
SDirectionPrompt :: SPromptType 'DirectionPrompt
|
SDirectionPrompt :: SPromptType 'DirectionPrompt
|
||||||
SPointOnMap :: SPromptType 'PointOnMap
|
SPointOnMap :: SPromptType 'PointOnMap
|
||||||
|
SContinue :: SPromptType 'Continue
|
||||||
|
|
||||||
class SingPromptType pt where singPromptType :: SPromptType pt
|
class SingPromptType pt where singPromptType :: SPromptType pt
|
||||||
instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt
|
instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt
|
||||||
instance SingPromptType 'DirectionPrompt where singPromptType = SDirectionPrompt
|
instance SingPromptType 'DirectionPrompt where singPromptType = SDirectionPrompt
|
||||||
|
instance SingPromptType 'Continue where singPromptType = SContinue
|
||||||
|
|
||||||
instance Show (SPromptType pt) where
|
instance Show (SPromptType pt) where
|
||||||
show SStringPrompt = "SStringPrompt"
|
show SStringPrompt = "SStringPrompt"
|
||||||
|
@ -57,6 +61,7 @@ instance Show (SPromptType pt) where
|
||||||
show SMenu = "SMenu"
|
show SMenu = "SMenu"
|
||||||
show SDirectionPrompt = "SDirectionPrompt"
|
show SDirectionPrompt = "SDirectionPrompt"
|
||||||
show SPointOnMap = "SPointOnMap"
|
show SPointOnMap = "SPointOnMap"
|
||||||
|
show SContinue = "SContinue"
|
||||||
|
|
||||||
data PromptCancellable
|
data PromptCancellable
|
||||||
= Cancellable
|
= Cancellable
|
||||||
|
@ -73,10 +78,12 @@ data PromptResult (pt :: PromptType) where
|
||||||
MenuResult :: forall a. a -> PromptResult ('Menu a)
|
MenuResult :: forall a. a -> PromptResult ('Menu a)
|
||||||
DirectionResult :: Direction -> PromptResult 'DirectionPrompt
|
DirectionResult :: Direction -> PromptResult 'DirectionPrompt
|
||||||
PointOnMapResult :: Position -> PromptResult 'PointOnMap
|
PointOnMapResult :: Position -> PromptResult 'PointOnMap
|
||||||
|
ContinueResult :: PromptResult 'Continue
|
||||||
|
|
||||||
data PromptState pt where
|
data PromptState pt where
|
||||||
StringPromptState :: Editor Text Name -> PromptState 'StringPrompt
|
StringPromptState :: Editor Text Name -> PromptState 'StringPrompt
|
||||||
DirectionPromptState :: PromptState 'DirectionPrompt
|
DirectionPromptState :: PromptState 'DirectionPrompt
|
||||||
|
ContinuePromptState :: PromptState 'Continue
|
||||||
|
|
||||||
deriving stock instance Show (PromptState pt)
|
deriving stock instance Show (PromptState pt)
|
||||||
|
|
||||||
|
@ -103,6 +110,7 @@ mkPrompt c pt@SStringPrompt cb =
|
||||||
let ps = StringPromptState $ editorText Resource.Prompt (Just 1) ""
|
let ps = StringPromptState $ editorText Resource.Prompt (Just 1) ""
|
||||||
in Prompt c pt ps cb
|
in Prompt c pt ps cb
|
||||||
mkPrompt c pt@SDirectionPrompt cb = Prompt c pt DirectionPromptState cb
|
mkPrompt c pt@SDirectionPrompt cb = Prompt c pt DirectionPromptState cb
|
||||||
|
mkPrompt c pt@SContinue cb = Prompt c pt ContinuePromptState cb
|
||||||
mkPrompt _ _ _ = undefined
|
mkPrompt _ _ _ = undefined
|
||||||
|
|
||||||
isCancellable :: Prompt m -> Bool
|
isCancellable :: Prompt m -> Bool
|
||||||
|
@ -116,6 +124,8 @@ submitPrompt (Prompt _ pt ps cb) =
|
||||||
cb . StringResult . mconcat . getEditContents $ edit
|
cb . StringResult . mconcat . getEditContents $ edit
|
||||||
(SDirectionPrompt, DirectionPromptState) ->
|
(SDirectionPrompt, DirectionPromptState) ->
|
||||||
pure () -- Don't use submit with a direction prompt
|
pure () -- Don't use submit with a direction prompt
|
||||||
|
(SContinue, ContinuePromptState) ->
|
||||||
|
cb ContinueResult -- Don't use submit with a direction prompt
|
||||||
_ -> undefined
|
_ -> undefined
|
||||||
|
|
||||||
-- data PromptInput :: PromptType -> Type where
|
-- data PromptInput :: PromptType -> Type where
|
||||||
|
|
|
@ -3,7 +3,7 @@
|
||||||
module Xanthous.Util.Graphics where
|
module Xanthous.Util.Graphics where
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Xanthous.Prelude
|
import Xanthous.Prelude
|
||||||
import Data.List ( unfoldr )
|
import Data.List (unfoldr)
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
-- | Generate a circle centered at the given point and with the given radius
|
-- | Generate a circle centered at the given point and with the given radius
|
||||||
|
|
|
@ -1,4 +1,5 @@
|
||||||
welcome: Welcome to Xanthous, {{characterName}}! It's dangerous out there, why not stay inside?
|
welcome: Welcome to Xanthous, {{characterName}}! It's dangerous out there, why not stay inside?
|
||||||
|
dead: You have died... Press Enter to continue.
|
||||||
|
|
||||||
entities:
|
entities:
|
||||||
description: You see here {{entityDescriptions}}
|
description: You see here {{entityDescriptions}}
|
||||||
|
@ -21,6 +22,9 @@ combat:
|
||||||
hit:
|
hit:
|
||||||
- You hit the {{creature.creatureType.name}}
|
- You hit the {{creature.creatureType.name}}
|
||||||
- You attack the {{creature.creatureType.name}}
|
- You attack the {{creature.creatureType.name}}
|
||||||
|
creatureAttack:
|
||||||
|
- The {{creature.creatureType.name}} hits you!
|
||||||
|
- The {{creature.creatureType.name}} attacks you!
|
||||||
killed:
|
killed:
|
||||||
- You kill the {{creature.creatureType.name}}!
|
- You kill the {{creature.creatureType.name}}!
|
||||||
- You've killed the {{creature.creatureType.name}}!
|
- You've killed the {{creature.creatureType.name}}!
|
||||||
|
|
|
@ -15,12 +15,26 @@ test = testGroup "Xanthous.Data"
|
||||||
[ testBatch $ monoid @Position mempty
|
[ testBatch $ monoid @Position mempty
|
||||||
, testProperty "group laws" $ \(pos :: Position) ->
|
, testProperty "group laws" $ \(pos :: Position) ->
|
||||||
pos <> invert pos == mempty && invert pos <> pos == mempty
|
pos <> invert pos == mempty && invert pos <> pos == mempty
|
||||||
|
, testGroup "stepTowards laws"
|
||||||
|
[ testProperty "takes only one step" $ \src tgt ->
|
||||||
|
src /= tgt ==>
|
||||||
|
isUnit (src `diffPositions` (src `stepTowards` tgt))
|
||||||
|
-- , testProperty "moves in the right direction" $ \src tgt ->
|
||||||
|
-- stepTowards src tgt == move (directionOf src tgt) src
|
||||||
|
]
|
||||||
|
, testProperty "directionOf laws" $ \pos dir ->
|
||||||
|
directionOf pos (move dir pos) == dir
|
||||||
|
, testProperty "diffPositions is add inverse" $ \pos₁ pos₂ ->
|
||||||
|
diffPositions pos₁ pos₂ == addPositions pos₁ (invert pos₂)
|
||||||
|
|
||||||
]
|
]
|
||||||
, testGroup "Direction"
|
, testGroup "Direction"
|
||||||
[ testProperty "opposite is involutive" $ \(dir :: Direction) ->
|
[ testProperty "opposite is involutive" $ \(dir :: Direction) ->
|
||||||
opposite (opposite dir) == dir
|
opposite (opposite dir) == dir
|
||||||
, testProperty "opposite provides inverse" $ \dir ->
|
, testProperty "opposite provides inverse" $ \dir ->
|
||||||
invert (asPosition dir) == asPosition (opposite dir)
|
invert (asPosition dir) == asPosition (opposite dir)
|
||||||
|
, testProperty "asPosition isUnit" $ \dir ->
|
||||||
|
dir /= Here ==> isUnit (asPosition dir)
|
||||||
, testGroup "Move"
|
, testGroup "Move"
|
||||||
[ testCase "Up" $ move Up mempty @?= Position 0 (-1)
|
[ testCase "Up" $ move Up mempty @?= Position 0 (-1)
|
||||||
, testCase "Down" $ move Down mempty @?= Position 0 1
|
, testCase "Down" $ move Down mempty @?= Position 0 1
|
||||||
|
|
Loading…
Reference in a new issue