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

3 files changed, 70 insertions, 21 deletions

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