feat(gs/xanthous): Allow throwing rocks r/2994

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

1 files changed, 65 insertions, 21 deletions

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)