feat(gs/xanthous): Allow throwing rocks

Implement a first pass at a "fire" command, which allows throwing rocks,
the max distance and the damage of which is based on the weight of the
item and the strength of the player.

Currently the actual numbers here likely need some tweaking, as the
rocks are easily throwable at good distances but don't really deal any
damage.

Change-Id: Ic6ad0599444af44d8438b834237a1997b67f220f
Reviewed-on: https://cl.tvl.fyi/c/depot/+/3764
Reviewed-by: grfn <grfn@gws.fyi>
Tested-by: BuildkiteCI
This commit is contained in:
Griffin Smith 2021-10-30 12:12:47 -04:00 committed by grfn
parent 352c75630d
commit 61802fe106
15 changed files with 450 additions and 87 deletions

View file

@ -34,7 +34,7 @@ import Xanthous.Data
, position
, Position
, (|*|)
, Tiles(..)
, Tiles(..), Hitpoints, fromScalar
)
import Xanthous.Data.App (ResourceName, Panel(..), AppEvent(..))
import qualified Xanthous.Data.EntityMap as EntityMap
@ -45,15 +45,18 @@ import Xanthous.Game
import Xanthous.Game.State
import Xanthous.Game.Env
import Xanthous.Game.Draw (drawGame)
import Xanthous.Game.Prompt
import Xanthous.Game.Prompt hiding (Fire)
import qualified Xanthous.Messages as Messages
import Xanthous.Random
import Xanthous.Util (removeVectorIndex)
import Xanthous.Util.Inflection (toSentence)
import Xanthous.Physics (throwDistance, bluntThrowDamage)
import Xanthous.Data.EntityMap.Graphics (lineOfSight)
import Xanthous.Data.EntityMap (EntityID)
--------------------------------------------------------------------------------
import qualified Xanthous.Entities.Character as Character
import Xanthous.Entities.Character hiding (pickUpItem)
import Xanthous.Entities.Item (Item)
import Xanthous.Entities.Item (Item, weight)
import qualified Xanthous.Entities.Item as Item
import Xanthous.Entities.Creature (Creature)
import qualified Xanthous.Entities.Creature as Creature
@ -292,6 +295,43 @@ handleCommand Wield = do
say ["wield", "wielded"] item
continue
handleCommand Fire = do
selectItemFromInventory_ ["fire", "menu"] Cancellable id
(say_ ["fire", "nothing"])
$ \(MenuResult (invPos, item)) ->
let wt = weight item
dist = throwDistance wt
dam = bluntThrowDamage wt
in if dist < fromScalar 1
then say_ ["fire", "zeroRange"]
else firePrompt_ ["fire", "target"] Cancellable dist $
\(FireResult targetPos) -> do
charPos <- use characterPosition
mTarget <- uses entities $ firstEnemy . lineOfSight charPos targetPos
case mTarget of
Just target -> do
creature' <- damageCreature target dam
unless (Creature.isDead creature') $
let msgPath = ["fire", "fired"] <> [if dam == 0
then "noDamage"
else "someDamage"]
in say msgPath $ object [ "item" A..= item
, "creature" A..= creature'
]
Nothing ->
say ["fire", "fired", "noTarget"] $ object [ "item" A..= item ]
character . inventory %= removeItemFromPosition invPos item
entities . EntityMap.atPosition targetPos %= (SomeEntity item <|)
stepGame -- TODO(grfn): should this be based on distance?
continue
where
firstEnemy
:: [(Position, Vector (EntityID, SomeEntity))]
-> Maybe (EntityID, Creature)
firstEnemy los =
let enemies = los >>= \(_, es) -> toList $ headMay es
in enemies ^? folded . below _SomeEntity
handleCommand Save = do
-- TODO default save locations / config file?
prompt_ @'StringPrompt ["save", "location"] Cancellable
@ -364,22 +404,14 @@ attackAt pos =
menu_ ["combat", "menu"] Cancellable (entityMenu_ creatures)
$ \(MenuResult creature) -> attackCreature creature
where
attackCreature (creatureID, creature) = do
attackCreature creature = do
charDamage <- uses character characterDamage
let creature' = Creature.damage charDamage creature
msgParams = object ["creature" A..= creature']
if Creature.isDead creature'
then do
say ["combat", "killed"] msgParams
entities . at creatureID .= Nothing
else do
creature' <- damageCreature creature charDamage
msg <- uses character getAttackMessage
message msg msgParams
entities . ix creatureID . positioned .= SomeEntity creature'
unless (Creature.isDead creature')
. message msg $ object ["creature" A..= creature']
whenM (uses character $ isNothing . weapon) handleFists
stepGame -- TODO
stepGame
weapon chr = chr ^? inventory . wielded . wieldedItems . wieldableItem
getAttackMessage chr =
case weapon chr of
@ -399,6 +431,18 @@ attackAt pos =
character %= Character.damage damageAmount
character . body . knuckles %= damageKnuckles
damageCreature :: (EntityID, Creature) -> Hitpoints -> AppM Creature
damageCreature (creatureID, creature) dam = do
let creature' = Creature.damage dam creature
msgParams = object ["creature" A..= creature']
if Creature.isDead creature'
then do
say ["combat", "killed"] msgParams
entities . at creatureID .= Nothing
else entities . ix creatureID . positioned .= SomeEntity creature'
pure creature'
entityMenu_
:: (Comonad w, Entity entity)
=> [w entity]

View file

@ -9,6 +9,7 @@ module Xanthous.App.Prompt
, confirm
, menu
, menu_
, firePrompt_
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
@ -17,15 +18,19 @@ import Brick (BrickEvent(..), Next)
import Brick.Widgets.Edit (handleEditorEvent)
import Data.Aeson (ToJSON, object)
import Graphics.Vty.Input.Events (Event(EvKey), Key(..))
import GHC.TypeLits (ErrorMessage(..))
--------------------------------------------------------------------------------
import Xanthous.App.Common
import Xanthous.Data (move)
import Xanthous.Data (move, Tiles, Position, positioned, _Position)
import qualified Xanthous.Data as Data
import Xanthous.Command (directionFromChar)
import Xanthous.Data.App (ResourceName, AppEvent)
import Xanthous.Game.Prompt
import Xanthous.Game.State
import qualified Xanthous.Messages as Messages
import qualified Xanthous.Data.EntityMap as EntityMap
import Xanthous.Entities.Creature (creatureType)
import Xanthous.Entities.RawTypes (hostile)
import qualified Linear.Metric as Metric
--------------------------------------------------------------------------------
handlePromptEvent
@ -76,6 +81,17 @@ handlePromptEvent
>> continue
handlePromptEvent _ (Prompt _ SPointOnMap _ _ _) _ = continue
handlePromptEvent
msg
(Prompt c SFire (FirePromptState pos) pri@(origin, range) cb)
(VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) []))
= do
let pos' = move dir pos
prompt' = Prompt c SFire (FirePromptState pos') pri cb
when (Data.distance origin pos' <= range) $
promptState .= WaitingPrompt msg prompt'
continue
handlePromptEvent
_
(Prompt Cancellable _ _ _ _)
@ -86,19 +102,15 @@ handlePromptEvent _ _ _ = continue
clearPrompt :: AppM ()
clearPrompt = promptState .= NoPrompt
class NotMenu (pt :: PromptType)
instance NotMenu 'StringPrompt
instance NotMenu 'Confirm
instance NotMenu 'DirectionPrompt
instance NotMenu 'PointOnMap
instance NotMenu 'Continue
instance TypeError ('Text "Cannot use `prompt` or `prompt_` for menu prompts"
':$$: 'Text "Use `menu` or `menu_` instead")
=> NotMenu ('Menu a)
type PromptParams :: PromptType -> Type
type family PromptParams pt where
PromptParams ('Menu a) = Map Char (MenuOption a) -- Menu items
PromptParams 'Fire = Tiles -- Range
PromptParams _ = ()
prompt
:: forall (pt :: PromptType) (params :: Type).
(ToJSON params, SingPromptType pt, NotMenu pt)
(ToJSON params, SingPromptType pt, PromptParams pt ~ ())
=> [Text] -- ^ Message key
-> params -- ^ Message params
-> PromptCancellable
@ -107,20 +119,19 @@ prompt
prompt msgPath params cancellable cb = do
let pt = singPromptType @pt
msg <- Messages.message msgPath params
p <- case pt of
mp :: Maybe (Prompt AppM) <- case pt of
SPointOnMap -> do
charPos <- use characterPosition
pure $ mkPointOnMapPrompt cancellable charPos cb
SStringPrompt -> pure $ mkPrompt cancellable pt cb
SConfirm -> pure $ mkPrompt cancellable pt cb
SDirectionPrompt -> pure $ mkPrompt cancellable pt cb
SContinue -> pure $ mkPrompt cancellable pt cb
SMenu -> error "unreachable"
promptState .= WaitingPrompt msg p
pure . Just $ mkPointOnMapPrompt cancellable charPos cb
SStringPrompt -> pure . Just $ mkPrompt cancellable pt cb
SConfirm -> pure . Just $ mkPrompt cancellable pt cb
SDirectionPrompt -> pure . Just $ mkPrompt cancellable pt cb
SContinue -> pure . Just $ mkPrompt cancellable pt cb
for_ mp $ \p -> promptState .= WaitingPrompt msg p
prompt_
:: forall (pt :: PromptType).
(SingPromptType pt, NotMenu pt)
(SingPromptType pt, PromptParams pt ~ ())
=> [Text] -- ^ Message key
-> PromptCancellable
-> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler
@ -159,3 +170,36 @@ menu_ :: forall (a :: Type).
-> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler
-> AppM ()
menu_ msgPath = menu msgPath $ object []
firePrompt_
:: [Text] -- ^ Message key
-> PromptCancellable
-> Tiles -- ^ Range
-> (PromptResult 'Fire -> AppM ()) -- ^ Promise handler
-> AppM ()
firePrompt_ msgPath cancellable range cb = do
msg <- Messages.message msgPath $ object []
initialPos <- maybe (use characterPosition) pure =<< nearestEnemyPosition
let p = mkFirePrompt cancellable initialPos range cb
promptState .= WaitingPrompt msg p
-- | Returns the position of the nearest visible hostile creature, if any
nearestEnemyPosition :: AppM (Maybe Position)
nearestEnemyPosition = do
charPos <- use characterPosition
em <- use entities
ps <- characterVisiblePositions
let candidates = toList ps >>= \p ->
let ents = EntityMap.atPositionWithIDs p em
in ents
^.. folded
. _2
. positioned
. _SomeEntity
. creatureType
. filtered (view hostile)
. to (const (distance charPos p, p))
pure . headMay . fmap snd $ sortOn fst candidates
where
distance :: Position -> Position -> Double
distance = Metric.distance `on` (fmap fromIntegral . view _Position)

View file

@ -26,6 +26,7 @@ data Command
| ShowInventory
| DescribeInventory
| Wield
| Fire
| GoUp
| GoDown
| Rest
@ -53,6 +54,7 @@ commandFromKey (KChar 'r') [] = Just Read
commandFromKey (KChar 'i') [] = Just ShowInventory
commandFromKey (KChar 'I') [] = Just DescribeInventory
commandFromKey (KChar 'w') [] = Just Wield
commandFromKey (KChar 'f') [] = Just Fire
commandFromKey (KChar '<') [] = Just GoUp
commandFromKey (KChar '>') [] = Just GoDown
commandFromKey (KChar 'R') [] = Just Rest

View file

@ -8,10 +8,9 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE UndecidableInstances #-}
--------------------------------------------------------------------------------
-- | Common data types for Xanthous
--------------------------------------------------------------------------------
{-# LANGUAGE AllowAmbiguousTypes #-}
--------------------------------------------------------------------------------
-- | Common data types for Xanthous ------------------------------------------------------------------------------
module Xanthous.Data
( Opposite(..)
@ -34,6 +33,7 @@ module Xanthous.Data
, diffPositions
, stepTowards
, isUnit
, distance
-- * Boxes
, Box(..)
@ -47,20 +47,29 @@ module Xanthous.Data
, boxEdge
, module Linear.V2
-- *
-- * Unit math
, Scalar(..)
, Per(..)
, invertRate
, invertedRate
, (|+|)
, (|*|)
, (|/|)
, (:+:)
, (:*:)
, (:/:)
, (:**:)(..)
, Ticks(..)
, Tiles(..)
, TicksPerTile
, TilesPerTick
, timesTiles
, Square(..)
, squared
, Cubic(..)
, Grams
, Meters
, Uno(..)
, Unit(..)
, UnitSymbol(..)
@ -125,6 +134,7 @@ import Xanthous.Util (EqEqProp(..), EqProp, between)
import Xanthous.Util.QuickCheck (GenericArbitrary(..))
import Xanthous.Orphans ()
import Xanthous.Util.Graphics
import qualified Linear.Metric as Metric
--------------------------------------------------------------------------------
-- | opposite ∘ opposite ≡ id
@ -246,7 +256,7 @@ loc = iso hither yon
_Position :: Iso' (Position' a) (V2 a)
_Position = iso hither yon
where
hither (Position px py) = (V2 px py)
hither (Position px py) = V2 px py
yon (V2 lx ly) = Position lx ly
positionFromPair :: (Num a, Integral i, Integral j) => (i, j) -> Position' a
@ -531,11 +541,28 @@ invertRate (Rate p) = Rate $ 1 / p
invertedRate :: Iso (a `Per` b) (b' `Per` a') (b `Per` a) (a' `Per` b')
invertedRate = iso invertRate invertRate
type (:+:) :: Type -> Type -> Type
type family (:+:) a b where
a :+: a = a
a :+: (Uno b) = a
infixl 6 |+|
class AddUnit a b where
(|+|) :: a -> b -> a :+: b
instance Scalar a => AddUnit a a where
x' |+| y' = fromScalar $ scalar x' + scalar y'
instance (Scalar a, Scalar b) => AddUnit a (Uno b) where
x' |+| y' = fromScalar $ scalar x' + scalar y'
type (:*:) :: Type -> Type -> Type
type family (:*:) a b where
(a `Per` b) :*: b = a
(Square a) :*: a = Cubic a
a :*: a = Square a
a :*: Uno b = a
a :*: b = a :**: b
infixl 7 |*|
class MulUnit a b where
@ -550,6 +577,58 @@ instance forall a. (Scalar a, a :*: a ~ Square a) => MulUnit a a where
instance forall a. (Scalar a) => MulUnit (Square a) a where
x' |*| y' = Cubic @a . fromScalar $ scalar x' * scalar y'
instance {-# INCOHERENT #-} forall a b.
(Scalar a, Scalar b, Scalar (a :*: Uno b))
=> MulUnit a (Uno b) where
x' |*| y' = fromScalar $ scalar x' * scalar y'
type (:/:) :: Type -> Type -> Type
type family (:/:) a b where
(Square a) :/: a = a
(Cubic a) :/: a = Square a
(Cubic a) :/: (Square a) = a
(a :**: b) :/: b = a
(a :**: b) :/: a = b
a :/: Uno b = a
a :/: b = a `Per` b
infixl 7 |/|
class DivUnit a b where
(|/|) :: a -> b -> a :/: b
instance Scalar a => DivUnit (Square a) a where
(Square a) |/| b = fromScalar $ scalar a / scalar b
instance Scalar a => DivUnit (Cubic a) a where
(Cubic a) |/| b = fromScalar $ scalar a / scalar b
instance (Scalar a, Cubic a :/: Square a ~ a)
=> DivUnit (Cubic a) (Square a) where
(Cubic a) |/| (Square b) = fromScalar $ scalar a / scalar b
instance (Scalar a, Scalar b) => DivUnit (a :**: b) b where
(Times a) |/| b = fromScalar $ scalar a / scalar b
instance (Scalar a, Scalar b) => DivUnit (a :**: b) a where
(Times a) |/| b = fromScalar $ scalar a / scalar b
instance {-# INCOHERENT #-} forall a b.
(Scalar a, Scalar b, Scalar (a :/: Uno b))
=> DivUnit a (Uno b) where
x' |/| y' = fromScalar $ scalar x' / scalar y'
-- | Dimensionless quantitites (mass per unit mass, radians, etc)
--
-- see <https://en.wikipedia.org/wiki/Parts-per_notation#Uno>
newtype Uno a = Uno a
deriving stock (Eq, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving ( Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON
, Scalar, Show
)
via a
deriving Unit via UnitSymbol "" (Uno a)
newtype Square a = Square a
deriving stock (Eq, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
@ -569,6 +648,9 @@ instance Unit a => Unit (Square a) where
instance Show a => Show (Square a) where
show (Square n) = show n <> "²"
squared :: (Scalar a, a :*: a ~ Square a) => a -> Square a
squared v = v |*| v
newtype Cubic a = Cubic a
deriving stock (Eq, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
@ -588,6 +670,21 @@ instance Unit a => Unit (Cubic a) where
instance Show a => Show (Cubic a) where
show (Cubic n) = show n <> "³"
newtype (:**:) a b = Times Double
deriving stock (Eq, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving (Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON)
via Double
deriving (Semigroup, Monoid) via Sum Double
deriving Show via ShowUnitSuffix (a :**: b) Double
deriving via Double
instance ( Distribution d Double
, forall xx yy. Coercible xx yy => Coercible (d xx) (d yy)
)
=> Distribution d (a :**: b)
instance (Unit a, Unit b) => Unit (a :**: b) where
unitSuffix = unitSuffix @a <> " " <> unitSuffix @b
--------------------------------------------------------------------------------
@ -626,12 +723,23 @@ type TilesPerTick = Tiles `Per` Ticks
timesTiles :: TicksPerTile -> Tiles -> Ticks
timesTiles = (|*|)
-- | Calculate the (cartesian) distance between two 'Position's, floored and
-- represented as a number of 'Tile's
--
-- Note that this is imprecise, and may be different than the length of a
-- bresenham's line between the points
distance :: Position -> Position -> Tiles
distance
= (fromScalar .) . (Metric.distance `on` (fmap fromIntegral . view _Position))
--------------------------------------------------------------------------------
newtype Hitpoints = Hitpoints Word
deriving stock (Eq, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving (Arbitrary, Num, Ord, Bounded, Enum, Integral, Real, ToJSON, FromJSON)
deriving ( Arbitrary, Num, Ord, Bounded, Enum, Integral, Real, Scalar
, ToJSON, FromJSON
)
via Word
deriving (Semigroup, Monoid) via Sum Word
deriving Unit via UnitSymbol "hp" Hitpoints

View file

@ -20,6 +20,7 @@ module Xanthous.Data.EntityMap
, positions
, lookup
, lookupWithPosition
, positionOf
-- , positionedEntities
, neighbors
, Deduplicate(..)
@ -37,7 +38,7 @@ import Xanthous.Data
, Positioned(..)
, positioned
, Neighbors(..)
, neighborPositions
, neighborPositions, position
)
import Xanthous.Data.VectorBag
import Xanthous.Orphans ()
@ -268,5 +269,9 @@ lookup eid = fmap (view positioned) . lookupWithPosition eid
neighbors :: (Ord a, Show a) => Position -> EntityMap a -> Neighbors (VectorBag a)
neighbors pos em = (\p -> view (atPosition p) em) <$> neighborPositions pos
-- | Traversal to the position of the entity with the given ID
positionOf :: EntityID -> Traversal' (EntityMap a) Position
positionOf eid = ix eid . position
--------------------------------------------------------------------------------
makeWrapped ''Deduplicate

View file

@ -2,6 +2,7 @@
module Xanthous.Data.EntityMap.Graphics
( visiblePositions
, visibleEntities
, lineOfSight
, linesOfSight
, canSee
) where
@ -27,27 +28,34 @@ visiblePositions
visiblePositions pos radius
= setFromList . positions . visibleEntities pos radius
-- | Returns a list of entities on the *line of sight* from the first position
-- to the second position
lineOfSight
:: forall e. Entity e
=> Position -- ^ Origin
-> Position -- ^ Destination
-> EntityMap e
-> [(Position, Vector (EntityID, e))]
lineOfSight (view _Position -> origin) (view _Position -> destination) em =
takeWhileInclusive (none (view blocksVision . entityAttributes . snd) . snd)
$ getPositionedAt <$> line origin destination
where
getPositionedAt :: V2 Int -> (Position, Vector (EntityID, e))
getPositionedAt (review _Position -> p) =
(p, over _2 (view positioned) <$> atPositionWithIDs p em)
-- | Returns a list of individual lines of sight, each of which is a list of
-- entities at positions on that line of sight
linesOfSight
:: forall e. Entity e
=> Position
-> Word
=> Position -- ^ Centerpoint
-> Word -- ^ Radius
-> EntityMap e
-> [[(Position, Vector (EntityID, e))]]
linesOfSight (view _Position -> pos) visionRadius em
= entitiesOnLines
<&> takeWhileInclusive
(none (view blocksVision . entityAttributes . snd) . snd)
linesOfSight pos visionRadius em =
radius <&> \edge -> lineOfSight pos (_Position # edge) em
where
radius = circle pos $ fromIntegral visionRadius
lines = line pos <$> radius
entitiesOnLines :: [[(Position, Vector (EntityID, e))]]
entitiesOnLines = lines <&> map getPositionedAt
getPositionedAt :: V2 Int -> (Position, Vector (EntityID, e))
getPositionedAt p =
let ppos = _Position # p
in (ppos, over _2 (view positioned) <$> atPositionWithIDs ppos em)
radius = circle (pos ^. _Position) $ fromIntegral visionRadius
-- | Given a point and a radius of vision, returns a list of all entities that
-- are *visible* (eg, not blocked by an entity that obscures vision) from that

View file

@ -0,0 +1,10 @@
Item:
name: rock
description: a rock
longDescription: a medium-sized rock made out of some unknown stone
char: .
wieldable:
damage: 1
attackMessage: you hit the {{creature.creatureType.name}} in the head with your rock.
density: [ 1500000, 2500000 ]
volume: [ 0.000125, 0.001 ]

View file

@ -4,10 +4,13 @@ module Xanthous.Game.Draw
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
--------------------------------------------------------------------------------
import Brick hiding (loc, on)
import Brick.Widgets.Border
import Brick.Widgets.Border.Style
import Brick.Widgets.Edit
import Control.Monad.State.Lazy (evalState)
import Control.Monad.State.Class ( get, MonadState, gets )
--------------------------------------------------------------------------------
import Xanthous.Data
import Xanthous.Data.App (ResourceName, Panel(..))
@ -23,13 +26,11 @@ import Xanthous.Game
)
import Xanthous.Game.Prompt
import Xanthous.Orphans ()
import Control.Monad.State.Lazy (evalState)
import Control.Monad.State.Class ( get, MonadState, gets )
--------------------------------------------------------------------------------
cursorPosition :: GameState -> Widget ResourceName -> Widget ResourceName
cursorPosition game
| WaitingPrompt _ (Prompt _ SPointOnMap (PointOnMapPromptState pos) _ _)
| WaitingPrompt _ (Prompt _ _ (preview promptStatePosition -> Just pos) _ _)
<- game ^. promptState
= showCursor Resource.Prompt (pos ^. loc)
| otherwise
@ -45,7 +46,6 @@ drawPromptState (WaitingPrompt msg (Prompt _ pt ps pri _)) =
(SStringPrompt, StringPromptState edit, _) ->
txtWrap msg <+> txt " " <+> renderEditor (txt . fold) True edit
(SDirectionPrompt, DirectionPromptState, _) -> txtWrap msg
(SContinue, _, _) -> txtWrap msg
(SMenu, _, menuItems) ->
txtWrap msg
<=> foldl' (<=>) emptyWidget (map drawMenuItem $ itoList menuItems)

View file

@ -2,7 +2,6 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DeriveFunctor #-}
--------------------------------------------------------------------------------
module Xanthous.Game.Prompt
( PromptType(..)
@ -11,6 +10,7 @@ module Xanthous.Game.Prompt
, PromptCancellable(..)
, PromptResult(..)
, PromptState(..)
, promptStatePosition
, MenuOption(..)
, mkMenuItems
, PromptInput
@ -18,6 +18,7 @@ module Xanthous.Game.Prompt
, mkPrompt
, mkMenu
, mkPointOnMapPrompt
, mkFirePrompt
, isCancellable
, submitPrompt
) where
@ -28,9 +29,8 @@ import Brick.Widgets.Edit (Editor, editorText, getEditContents)
import Test.QuickCheck
import Test.QuickCheck.Arbitrary.Generic
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
import Xanthous.Util (smallestNotIn, AlphaChar (..))
import Xanthous.Data (Direction, Position)
import Xanthous.Data (Direction, Position, Tiles)
import Xanthous.Data.App (ResourceName)
import qualified Xanthous.Data.App as Resource
--------------------------------------------------------------------------------
@ -41,6 +41,9 @@ data PromptType where
Menu :: Type -> PromptType
DirectionPrompt :: PromptType
PointOnMap :: PromptType
-- | Throw an item or fire a projectile weapon. Prompt is to select the
-- direction
Fire :: PromptType
Continue :: PromptType
deriving stock (Generic)
@ -51,6 +54,7 @@ instance Show PromptType where
show DirectionPrompt = "DirectionPrompt"
show PointOnMap = "PointOnMap"
show Continue = "Continue"
show Fire = "Fire"
data SPromptType :: PromptType -> Type where
SStringPrompt :: SPromptType 'StringPrompt
@ -59,6 +63,7 @@ data SPromptType :: PromptType -> Type where
SDirectionPrompt :: SPromptType 'DirectionPrompt
SPointOnMap :: SPromptType 'PointOnMap
SContinue :: SPromptType 'Continue
SFire :: SPromptType 'Fire
instance NFData (SPromptType pt) where
rnf SStringPrompt = ()
@ -67,6 +72,7 @@ instance NFData (SPromptType pt) where
rnf SDirectionPrompt = ()
rnf SPointOnMap = ()
rnf SContinue = ()
rnf SFire = ()
class SingPromptType pt where singPromptType :: SPromptType pt
instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt
@ -74,6 +80,7 @@ instance SingPromptType 'Confirm where singPromptType = SConfirm
instance SingPromptType 'DirectionPrompt where singPromptType = SDirectionPrompt
instance SingPromptType 'PointOnMap where singPromptType = SPointOnMap
instance SingPromptType 'Continue where singPromptType = SContinue
instance SingPromptType 'Fire where singPromptType = SFire
instance Show (SPromptType pt) where
show SStringPrompt = "SStringPrompt"
@ -82,6 +89,7 @@ instance Show (SPromptType pt) where
show SDirectionPrompt = "SDirectionPrompt"
show SPointOnMap = "SPointOnMap"
show SContinue = "SContinue"
show SFire = "SFire"
data PromptCancellable
= Cancellable
@ -98,6 +106,7 @@ data PromptResult (pt :: PromptType) where
MenuResult :: forall a. a -> PromptResult ('Menu a)
DirectionResult :: Direction -> PromptResult 'DirectionPrompt
PointOnMapResult :: Position -> PromptResult 'PointOnMap
FireResult :: Position -> PromptResult 'Fire
ContinueResult :: PromptResult 'Continue
instance Arbitrary (PromptResult 'StringPrompt) where
@ -118,6 +127,9 @@ instance Arbitrary (PromptResult 'PointOnMap) where
instance Arbitrary (PromptResult 'Continue) where
arbitrary = pure ContinueResult
instance Arbitrary (PromptResult 'Fire) where
arbitrary = FireResult <$> arbitrary
--------------------------------------------------------------------------------
data PromptState pt where
@ -128,6 +140,7 @@ data PromptState pt where
ConfirmPromptState :: PromptState 'Confirm
MenuPromptState :: forall a. PromptState ('Menu a)
PointOnMapPromptState :: Position -> PromptState 'PointOnMap
FirePromptState :: Position -> PromptState 'Fire
instance NFData (PromptState pt) where
rnf sps@(StringPromptState ed) = sps `deepseq` ed `deepseq` ()
@ -136,6 +149,7 @@ instance NFData (PromptState pt) where
rnf ConfirmPromptState = ()
rnf MenuPromptState = ()
rnf pomps@(PointOnMapPromptState pos) = pomps `deepseq` pos `deepseq` ()
rnf fps@(FirePromptState pos) = fps `deepseq` pos `deepseq` ()
instance Arbitrary (PromptState 'StringPrompt) where
arbitrary = StringPromptState <$> arbitrary
@ -149,6 +163,9 @@ instance Arbitrary (PromptState 'Continue) where
instance Arbitrary (PromptState ('Menu a)) where
arbitrary = pure MenuPromptState
instance Arbitrary (PromptState 'Fire) where
arbitrary = FirePromptState <$> arbitrary
instance CoArbitrary (PromptState 'StringPrompt) where
coarbitrary (StringPromptState ed) = coarbitrary ed
@ -161,8 +178,22 @@ instance CoArbitrary (PromptState 'Continue) where
instance CoArbitrary (PromptState ('Menu a)) where
coarbitrary MenuPromptState = coarbitrary ()
instance CoArbitrary (PromptState 'Fire) where
coarbitrary (FirePromptState pos) = coarbitrary pos
deriving stock instance Show (PromptState pt)
-- | Traversal over the position for the prompt types with positions in their
-- prompt state (currently 'Fire' and 'PointOnMap')
promptStatePosition :: forall pt. Traversal' (PromptState pt) Position
promptStatePosition _ ps@(StringPromptState _) = pure ps
promptStatePosition _ DirectionPromptState = pure DirectionPromptState
promptStatePosition _ ContinuePromptState = pure ContinuePromptState
promptStatePosition _ ConfirmPromptState = pure ConfirmPromptState
promptStatePosition _ MenuPromptState = pure MenuPromptState
promptStatePosition f (PointOnMapPromptState p) = PointOnMapPromptState <$> f p
promptStatePosition f (FirePromptState p) = FirePromptState <$> f p
data MenuOption a = MenuOption Text a
deriving stock (Eq, Generic, Functor)
deriving anyclass (NFData, CoArbitrary, Function)
@ -186,6 +217,7 @@ instance Show (MenuOption a) where
type family PromptInput (pt :: PromptType) :: Type where
PromptInput ('Menu a) = Map Char (MenuOption a)
PromptInput 'PointOnMap = Position -- Character pos
PromptInput 'Fire = (Position, Tiles) -- Nearest enemy, range
PromptInput _ = ()
data Prompt (m :: Type -> Type) where
@ -239,6 +271,8 @@ instance CoArbitrary (m ()) => CoArbitrary (Prompt m) where
variant @Int 5 . coarbitrary (c, pri, cb)
coarbitrary (Prompt c SContinue ps pri cb) =
variant @Int 6 . coarbitrary (c, ps, pri, cb)
coarbitrary (Prompt c SFire ps pri cb) =
variant @Int 7 . coarbitrary (c, ps, pri, cb)
-- instance Function (Prompt m) where
-- function = functionMap toTuple _fromTuple
@ -246,7 +280,12 @@ instance CoArbitrary (m ()) => CoArbitrary (Prompt m) where
-- toTuple (Prompt c pt ps pri cb) = (c, pt, ps, pri, cb)
mkPrompt :: (PromptInput pt ~ ()) => PromptCancellable -> SPromptType pt -> (PromptResult pt -> m ()) -> Prompt m
mkPrompt
:: (PromptInput pt ~ ())
=> PromptCancellable -- ^ Is the prompt cancellable or not?
-> SPromptType pt -- ^ The type of the prompt
-> (PromptResult pt -> m ()) -- ^ Function to call when the prompt is complete
-> Prompt m
mkPrompt c pt@SStringPrompt cb =
let ps = StringPromptState $ editorText Resource.Prompt (Just 1) ""
in Prompt c pt ps () cb
@ -269,6 +308,14 @@ mkPointOnMapPrompt
-> Prompt m
mkPointOnMapPrompt c pos = Prompt c SPointOnMap (PointOnMapPromptState pos) pos
mkFirePrompt
:: PromptCancellable
-> Position -- ^ Initial position
-> Tiles -- ^ Range
-> (PromptResult 'Fire -> m ())
-> Prompt m
mkFirePrompt c pos range = Prompt c SFire (FirePromptState pos) (pos, range)
isCancellable :: Prompt m -> Bool
isCancellable (Prompt Cancellable _ _ _ _) = True
isCancellable (Prompt Uncancellable _ _ _ _) = False
@ -288,3 +335,5 @@ submitPrompt (Prompt _ pt ps _ cb) =
cb $ PointOnMapResult pos
(SConfirm, ConfirmPromptState) ->
cb $ ConfirmResult True
(SFire, FirePromptState pos) ->
cb $ FireResult pos

View file

@ -23,7 +23,7 @@ import Linear.Metric
import qualified Options.Applicative as Opt
--------------------------------------------------------------------------------
import Xanthous.Random
import Xanthous.Data hiding (x, y, _x, _y, edges)
import Xanthous.Data hiding (x, y, _x, _y, edges, distance)
import Xanthous.Generators.Level.Util
import Xanthous.Util.Graphics (delaunay, straightLine)
import Xanthous.Util.Graph (mstSubGraph)

View file

@ -0,0 +1,71 @@
--------------------------------------------------------------------------------
module Xanthous.Physics
( throwDistance
, bluntThrowDamage
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
import Xanthous.Data
( Meters
, (:**:)(..)
, Square
, Grams
, (|*|)
, (|/|)
, Hitpoints
, Per (..)
, squared
, Uno(..), (|+|)
)
--------------------------------------------------------------------------------
-- university shotputter can put a 16 lb shot about 14 meters
-- ≈ 7.25 kg 14 meters
-- 14m = x / (7.25kg × y + z)²
-- 14m = x / (7250g × y + z)²
--
-- we don't want to scale down too much:
--
-- 10 kg 10 meters
-- = 10000 g 10 meters
--
-- 15 kg w meters
-- = 15000 g w meters
--
-- 14m = x / (7250g × y + z)²
-- 10m = x / (10000g × y + z)²
-- wm = x / (15000g × y + z)²
--
-- w≈0.527301 ∧ y≈0.000212178 sqrt(x) ∧ z≈1.80555 sqrt(x) ∧ 22824.1 sqrt(x)!=0
--
-- x = 101500
-- y = 0.0675979
-- z = 575.231
--
-- TODO make this dynamic
strength :: Meters :**: Square Grams
strength = Times 10150000
yCoeff :: Uno Double
yCoeff = Uno 0.0675979
zCoeff :: Uno Double
zCoeff = Uno 575.231
-- | Calculate the maximum distance an object with the given weight can be
-- thrown
throwDistance
:: Grams -- ^ Weight of the object
-> Meters -- ^ Max distance thrown
throwDistance weight = strength |/| squared (weight |*| yCoeff |+| zCoeff)
-- | Returns the damage dealt by a blunt object with the given weight when
-- thrown
bluntThrowDamage
:: Grams
-> Hitpoints
bluntThrowDamage weight = throwDamageRatio |*| weight
where
throwDamageRatio :: Hitpoints `Per` Grams
throwDamageRatio = Rate $ 1 / 5000

View file

@ -126,7 +126,7 @@ line pa@(V2 xa ya) pb@(V2 xb yb)
ystep = if y < y then 1 else -1
go (xTemp, yTemp, err)
| xTemp > x = Nothing
| otherwise = Just ((V2 xTemp yTemp), (xTemp + 1, newY, newError))
| otherwise = Just (V2 xTemp yTemp, (xTemp + 1, newY, newError))
where
tempError = err + δy
(newY, newError) = if (2 * tempError) >= δx
@ -139,7 +139,6 @@ straightLine :: (Num i, Ord i) => V2 i -> V2 i -> [V2 i]
straightLine pa@(V2 xa _) pb@(V2 _ yb) = line pa midpoint ++ line midpoint pb
where midpoint = V2 xa yb
delaunay
:: (Ord n, Fractional n)
=> NonEmpty (V2 n, p)

View file

@ -115,6 +115,28 @@ wield:
# TODO: use actual hands
wielded : You wield the {{wieldedItem.itemType.name}} in your right hand.
fire:
nothing:
- You don't currently have anything you can throw
- You don't have anything to throw
zeroRange:
- That item is too heavy to throw!
- That's too heavy to throw
- You're not strong enough to throw that any meaningful distance
menu: What would you like to throw?
target: Choose a target
atRange:
- It's too heavy for you to throw any further than this
fired:
noTarget:
- You throw the {{item.itemType.name}} at the ground
noDamage:
- You throw the {{item.itemType.name}} at the {{creature.creatureType.name}}. It doesn't seem to care.
- You throw the {{item.itemType.name}} at the {{creature.creatureType.name}}. It doesn't seem to do anything.
- You throw the {{item.itemType.name}} at the {{creature.creatureType.name}}. It doesn't seem to hurt it.
someDamage:
- You throw the {{item.itemType.name}} at the {{creature.creatureType.name}}. It hits it on the head!.
drop:
nothing: You aren't carrying anything
menu: What would you like to drop?

View file

@ -4,7 +4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
-- hash: c12ae4038a2e1f287de557b72b8493da05ccbf428e7ac7862349c46d241f342f
-- hash: 2db6cb1320baa23f71c24dff106bf682fb21e38c602d57e7e99297ae6abdc772
name: xanthous
version: 0.1.0.0
@ -75,6 +75,7 @@ library
Xanthous.Messages.Template
Xanthous.Monad
Xanthous.Orphans
Xanthous.Physics
Xanthous.Prelude
Xanthous.Random
Xanthous.Util