about summary refs log tree commit diff
path: root/users/grfn/xanthous/src
diff options
context:
space:
mode:
Diffstat (limited to 'users/grfn/xanthous/src')
-rw-r--r--users/grfn/xanthous/src/Xanthous/App.hs78
-rw-r--r--users/grfn/xanthous/src/Xanthous/App/Prompt.hs86
-rw-r--r--users/grfn/xanthous/src/Xanthous/Command.hs2
-rw-r--r--users/grfn/xanthous/src/Xanthous/Data.hs126
-rw-r--r--users/grfn/xanthous/src/Xanthous/Data/EntityMap.hs7
-rw-r--r--users/grfn/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs36
-rw-r--r--users/grfn/xanthous/src/Xanthous/Entities/Raws/rock.yaml10
-rw-r--r--users/grfn/xanthous/src/Xanthous/Game/Draw.hs8
-rw-r--r--users/grfn/xanthous/src/Xanthous/Game/Lenses.hs4
-rw-r--r--users/grfn/xanthous/src/Xanthous/Game/Prompt.hs79
-rw-r--r--users/grfn/xanthous/src/Xanthous/Generators/Level/Dungeon.hs2
-rw-r--r--users/grfn/xanthous/src/Xanthous/Physics.hs71
-rw-r--r--users/grfn/xanthous/src/Xanthous/Util/Graphics.hs3
-rw-r--r--users/grfn/xanthous/src/Xanthous/messages.yaml22
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 9558c17bcd..689a6a35ca 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 9b5a3bf24f..911f869612 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 30359c6c64..92bb0dca29 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 9b3c35c545..1b67e0f160 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 d24defa841..1d9c4d46cd 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 19e7b0cdf0..1398c611cf 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 0000000000..e7492bf5fb
--- /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 3f148e8428..25b1b92e21 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 f7b4d5fb9f..fd60e3637c 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 fa4c3903de..0674d853be 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 4851b02269..0be7c0435c 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 0000000000..37530cbbc2
--- /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 6ba63a2d8a..0cb009f45a 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 b264257433..a906650aa7 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?
generated by cgit-pink 1.4.1 (git 2.44.0) at 2024-06-02T18·14+0000