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

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
+    creature' <- damageCreature creature charDamage
-        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
+    unless (Creature.isDead creature')
-        entities . ix creatureID . positioned .= SomeEntity creature'
+      . message msg $ object ["creature" A..= creature']
-
     whenM (uses character $ isNothing . weapon) handleFists
-
+    stepGame
-    stepGame -- TODO
   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]

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)
+type PromptParams :: PromptType -> Type
-instance NotMenu 'StringPrompt
+type family PromptParams pt where
-instance NotMenu 'Confirm
+  PromptParams ('Menu a) = Map Char (MenuOption a) -- Menu items
-instance NotMenu 'DirectionPrompt
+  PromptParams 'Fire     = Tiles -- Range
-instance NotMenu 'PointOnMap
+  PromptParams _         = ()
-instance NotMenu 'Continue
-instance TypeError ('Text "Cannot use `prompt` or `prompt_` for menu prompts"
-                    ':$$: 'Text "Use `menu` or `menu_` instead")
-         => NotMenu ('Menu a)
 
 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
+      pure . Just $ mkPointOnMapPrompt cancellable charPos cb
-    SStringPrompt -> pure $ mkPrompt cancellable pt cb
+    SStringPrompt -> pure . Just $ mkPrompt cancellable pt cb
-    SConfirm -> pure $ mkPrompt cancellable pt cb
+    SConfirm -> pure . Just $ mkPrompt cancellable pt cb
-    SDirectionPrompt -> pure $ mkPrompt cancellable pt cb
+    SDirectionPrompt -> pure . Just $ mkPrompt cancellable pt cb
-    SContinue -> pure $ mkPrompt cancellable pt cb
+    SContinue -> pure . Just $ mkPrompt cancellable pt cb
-    SMenu -> error "unreachable"
+  for_ mp $ \p -> promptState .= WaitingPrompt msg 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)

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

users/grfn/xanthous/src/Xanthous/Data.hs

@@ -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

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

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
+  => Position    -- ^ Centerpoint
-  -> Word
+  -> Word        -- ^ Radius
   -> EntityMap e
   -> [[(Position, Vector (EntityID, e))]]
-linesOfSight (view _Position -> pos) visionRadius em
+linesOfSight pos visionRadius em =
-  = entitiesOnLines
+  radius <&> \edge -> lineOfSight pos (_Position # edge) em
-  <&> takeWhileInclusive
-      (none (view blocksVision . entityAttributes . snd) . snd)
   where
-    radius = circle pos $ fromIntegral visionRadius
+    radius = circle (pos ^. _Position) $ 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)
 
 -- | 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

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 ]

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)

users/grfn/xanthous/src/Xanthous/Game/Prompt.hs

@@ -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

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)

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

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)

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?

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