From 61802fe1064f96b5d723650d06072a6347a0748e Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Sat, 30 Oct 2021 12:12:47 -0400 Subject: [PATCH] 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 Tested-by: BuildkiteCI --- users/grfn/xanthous/src/Xanthous/App.hs | 78 ++++++++--- .../grfn/xanthous/src/Xanthous/App/Prompt.hs | 86 +++++++++--- users/grfn/xanthous/src/Xanthous/Command.hs | 2 + users/grfn/xanthous/src/Xanthous/Data.hs | 126 ++++++++++++++++-- .../xanthous/src/Xanthous/Data/EntityMap.hs | 7 +- .../src/Xanthous/Data/EntityMap/Graphics.hs | 36 +++-- .../src/Xanthous/Entities/Raws/rock.yaml | 10 ++ users/grfn/xanthous/src/Xanthous/Game/Draw.hs | 8 +- .../grfn/xanthous/src/Xanthous/Game/Lenses.hs | 4 +- .../grfn/xanthous/src/Xanthous/Game/Prompt.hs | 79 ++++++++--- .../src/Xanthous/Generators/Level/Dungeon.hs | 2 +- users/grfn/xanthous/src/Xanthous/Physics.hs | 71 ++++++++++ .../xanthous/src/Xanthous/Util/Graphics.hs | 3 +- .../grfn/xanthous/src/Xanthous/messages.yaml | 22 +++ users/grfn/xanthous/xanthous.cabal | 3 +- 15 files changed, 450 insertions(+), 87 deletions(-) create mode 100644 users/grfn/xanthous/src/Xanthous/Entities/Raws/rock.yaml create mode 100644 users/grfn/xanthous/src/Xanthous/Physics.hs diff --git a/users/grfn/xanthous/src/Xanthous/App.hs b/users/grfn/xanthous/src/Xanthous/App.hs index 9558c17bc..689a6a35c 100644 --- a/users/grfn/xanthous/src/Xanthous/App.hs +++ b/users/grfn/xanthous/src/Xanthous/App.hs @@ -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 - msg <- uses character getAttackMessage - message msg msgParams - entities . ix creatureID . positioned .= SomeEntity creature' - + creature' <- damageCreature creature charDamage + msg <- uses character getAttackMessage + 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] diff --git a/users/grfn/xanthous/src/Xanthous/App/Prompt.hs b/users/grfn/xanthous/src/Xanthous/App/Prompt.hs index 9b5a3bf24..911f86961 100644 --- a/users/grfn/xanthous/src/Xanthous/App/Prompt.hs +++ b/users/grfn/xanthous/src/Xanthous/App/Prompt.hs @@ -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) diff --git a/users/grfn/xanthous/src/Xanthous/Command.hs b/users/grfn/xanthous/src/Xanthous/Command.hs index 30359c6c6..92bb0dca2 100644 --- a/users/grfn/xanthous/src/Xanthous/Command.hs +++ b/users/grfn/xanthous/src/Xanthous/Command.hs @@ -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 diff --git a/users/grfn/xanthous/src/Xanthous/Data.hs b/users/grfn/xanthous/src/Xanthous/Data.hs index 9b3c35c54..1b67e0f16 100644 --- a/users/grfn/xanthous/src/Xanthous/Data.hs +++ b/users/grfn/xanthous/src/Xanthous/Data.hs @@ -8,10 +8,9 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} -------------------------------------------------------------------------------- --- | 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 `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 +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 diff --git a/users/grfn/xanthous/src/Xanthous/Data/EntityMap.hs b/users/grfn/xanthous/src/Xanthous/Data/EntityMap.hs index d24defa84..1d9c4d46c 100644 --- a/users/grfn/xanthous/src/Xanthous/Data/EntityMap.hs +++ b/users/grfn/xanthous/src/Xanthous/Data/EntityMap.hs @@ -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 diff --git a/users/grfn/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs b/users/grfn/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs index 19e7b0cdf..1398c611c 100644 --- a/users/grfn/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs +++ b/users/grfn/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs @@ -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 diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws/rock.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/rock.yaml new file mode 100644 index 000000000..e7492bf5f --- /dev/null +++ b/users/grfn/xanthous/src/Xanthous/Entities/Raws/rock.yaml @@ -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 ] diff --git a/users/grfn/xanthous/src/Xanthous/Game/Draw.hs b/users/grfn/xanthous/src/Xanthous/Game/Draw.hs index 3f148e842..25b1b92e2 100644 --- a/users/grfn/xanthous/src/Xanthous/Game/Draw.hs +++ b/users/grfn/xanthous/src/Xanthous/Game/Draw.hs @@ -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) diff --git a/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs b/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs index f7b4d5fb9..fd60e3637 100644 --- a/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs +++ b/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE AllowAmbiguousTypes #-} -------------------------------------------------------------------------------- module Xanthous.Game.Lenses ( clearMemo diff --git a/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs b/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs index fa4c3903d..0674d853b 100644 --- a/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs +++ b/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GADTs #-} -------------------------------------------------------------------------------- module Xanthous.Game.Prompt ( PromptType(..) @@ -11,6 +10,7 @@ module Xanthous.Game.Prompt , PromptCancellable(..) , PromptResult(..) , PromptState(..) + , promptStatePosition , MenuOption(..) , mkMenuItems , PromptInput @@ -18,19 +18,19 @@ module Xanthous.Game.Prompt , mkPrompt , mkMenu , mkPointOnMapPrompt + , mkFirePrompt , isCancellable , submitPrompt ) where -------------------------------------------------------------------------------- -import Xanthous.Prelude +import Xanthous.Prelude -------------------------------------------------------------------------------- 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,14 +54,16 @@ instance Show PromptType where show DirectionPrompt = "DirectionPrompt" show PointOnMap = "PointOnMap" show Continue = "Continue" + show Fire = "Fire" data SPromptType :: PromptType -> Type where - SStringPrompt :: SPromptType 'StringPrompt - SConfirm :: SPromptType 'Confirm - SMenu :: SPromptType ('Menu a) - SDirectionPrompt :: SPromptType 'DirectionPrompt - SPointOnMap :: SPromptType 'PointOnMap - SContinue :: SPromptType 'Continue + SStringPrompt :: SPromptType 'StringPrompt + SConfirm :: SPromptType 'Confirm + SMenu :: SPromptType ('Menu a) + 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) @@ -184,8 +215,9 @@ instance Show (MenuOption a) where show (MenuOption m _) = show m type family PromptInput (pt :: PromptType) :: Type where - PromptInput ('Menu a) = Map Char (MenuOption a) + 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 diff --git a/users/grfn/xanthous/src/Xanthous/Generators/Level/Dungeon.hs b/users/grfn/xanthous/src/Xanthous/Generators/Level/Dungeon.hs index 4851b0226..0be7c0435 100644 --- a/users/grfn/xanthous/src/Xanthous/Generators/Level/Dungeon.hs +++ b/users/grfn/xanthous/src/Xanthous/Generators/Level/Dungeon.hs @@ -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) diff --git a/users/grfn/xanthous/src/Xanthous/Physics.hs b/users/grfn/xanthous/src/Xanthous/Physics.hs new file mode 100644 index 000000000..37530cbbc --- /dev/null +++ b/users/grfn/xanthous/src/Xanthous/Physics.hs @@ -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 diff --git a/users/grfn/xanthous/src/Xanthous/Util/Graphics.hs b/users/grfn/xanthous/src/Xanthous/Util/Graphics.hs index 6ba63a2d8..0cb009f45 100644 --- a/users/grfn/xanthous/src/Xanthous/Util/Graphics.hs +++ b/users/grfn/xanthous/src/Xanthous/Util/Graphics.hs @@ -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) diff --git a/users/grfn/xanthous/src/Xanthous/messages.yaml b/users/grfn/xanthous/src/Xanthous/messages.yaml index b26425743..a906650aa 100644 --- a/users/grfn/xanthous/src/Xanthous/messages.yaml +++ b/users/grfn/xanthous/src/Xanthous/messages.yaml @@ -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? diff --git a/users/grfn/xanthous/xanthous.cabal b/users/grfn/xanthous/xanthous.cabal index fc17ceaa2..5dc046dbe 100644 --- a/users/grfn/xanthous/xanthous.cabal +++ b/users/grfn/xanthous/xanthous.cabal @@ -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