diff options
Diffstat (limited to 'users/grfn/xanthous/src/Xanthous')
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/App.hs | 78 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/App/Prompt.hs | 86 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Command.hs | 2 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Data.hs | 126 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Data/EntityMap.hs | 7 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs | 36 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Entities/Raws/rock.yaml | 10 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Game/Draw.hs | 8 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Game/Lenses.hs | 4 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Game/Prompt.hs | 79 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Generators/Level/Dungeon.hs | 2 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Physics.hs | 71 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Util/Graphics.hs | 3 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/messages.yaml | 22 |
14 files changed, 448 insertions, 86 deletions
diff --git a/users/grfn/xanthous/src/Xanthous/App.hs b/users/grfn/xanthous/src/Xanthous/App.hs index 9558c17bcd6c..689a6a35ca30 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 9b5a3bf24fa7..911f8696123a 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 @@ -77,6 +82,17 @@ handlePromptEvent 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 _ _ _ _) (VtyEvent (EvKey (KChar 'q') [])) @@ -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 30359c6c6407..92bb0dca2941 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 9b3c35c5457c..1b67e0f160db 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 <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 diff --git a/users/grfn/xanthous/src/Xanthous/Data/EntityMap.hs b/users/grfn/xanthous/src/Xanthous/Data/EntityMap.hs index d24defa841ab..1d9c4d46cdc9 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 19e7b0cdf086..1398c611cf20 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 000000000000..e7492bf5fb6f --- /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 3f148e8428e8..25b1b92e215c 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 f7b4d5fb9fd2..fd60e3637cc9 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 fa4c3903deb1..0674d853beb7 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 4851b02269c8..0be7c0435c5a 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 000000000000..37530cbbc21b --- /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 6ba63a2d8a3f..0cb009f45ad0 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 b26425743319..a906650aa7f8 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? |