chore(users): grfn -> aspen r/7511

Change-Id: I6c6847fac56f0a9a1a2209792e00a3aec5e672b9
Reviewed-on: https://cl.tvl.fyi/c/depot/+/10809
Autosubmit: aspen <root@gws.fyi>
Reviewed-by: sterni <sternenseemann@systemli.org>
Tested-by: BuildkiteCI
Reviewed-by: lukegb <lukegb@tvl.fyi>

4 files changed, 413 insertions, 0 deletions

diff --git a/users/aspen/xanthous/src/Xanthous/App/Autocommands.hs b/users/aspen/xanthous/src/Xanthous/App/Autocommands.hs
new file mode 100644
index 000000000000..5d4db1a47465
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/App/Autocommands.hs
@@ -0,0 +1,76 @@
+--------------------------------------------------------------------------------
+module Xanthous.App.Autocommands
+  ( runAutocommand
+  , autoStep
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Control.Concurrent (threadDelay)
+import qualified Data.Aeson as A
+import           Data.Aeson (object)
+import           Data.List.NonEmpty (nonEmpty)
+import qualified Data.List.NonEmpty as NE
+import           Control.Monad.State (gets)
+--------------------------------------------------------------------------------
+import           Xanthous.App.Common
+import           Xanthous.App.Time
+import           Xanthous.Data
+import           Xanthous.Data.App
+import           Xanthous.Entities.Character (speed, isFullyHealed)
+import           Xanthous.Entities.Creature (Creature, creatureType)
+import           Xanthous.Entities.RawTypes (hostile)
+import           Xanthous.Game.State
+--------------------------------------------------------------------------------
+
+-- | Step the given autocommand forward once
+autoStep :: Autocommand -> AppM ()
+autoStep (AutoMove dir) = do
+  newPos <- uses characterPosition $ move dir
+  collisionAt newPos >>= \case
+    Nothing -> do
+      characterPosition .= newPos
+      stepGameBy =<< uses (character . speed) (|*| (1 :: Tiles))
+      describeEntitiesAt newPos
+      cancelIfDanger
+    Just _ -> cancelAutocommand
+
+autoStep AutoRest = do
+  done <- uses character isFullyHealed
+  if done
+    then say_ ["autocommands", "doneResting"] >> cancelAutocommand
+    else stepGame >> cancelIfDanger
+
+-- | Cancel the autocommand if the character is in danger
+cancelIfDanger :: AppM ()
+cancelIfDanger = do
+  maybeVisibleEnemies <- nonEmpty <$> enemiesInSight
+  for_ maybeVisibleEnemies $ \visibleEnemies -> do
+    say ["autocommands", "enemyInSight"]
+      $ object [ "firstEntity" A..= NE.head visibleEnemies ]
+    cancelAutocommand
+  where
+    enemiesInSight :: AppM [Creature]
+    enemiesInSight = do
+      ents <- gets characterVisibleEntities
+      pure $ ents
+          ^.. folded
+            . _SomeEntity @Creature
+            . filtered (view $ creatureType . hostile)
+
+--------------------------------------------------------------------------------
+
+autocommandIntervalμs :: Int
+autocommandIntervalμs = 1000 * 50 -- 50 ms
+
+runAutocommand :: Autocommand -> AppM ()
+runAutocommand ac = do
+  env <- ask
+  tid <- liftIO . async $ runReaderT go env
+  autocommand .= ActiveAutocommand ac tid
+  where
+    go = everyμs autocommandIntervalμs $ sendEvent AutoContinue
+
+-- | Perform 'act' every μs microseconds forever
+everyμs :: MonadIO m => Int -> m () -> m ()
+everyμs μs act = act >> liftIO (threadDelay μs) >> everyμs μs act
diff --git a/users/aspen/xanthous/src/Xanthous/App/Common.hs b/users/aspen/xanthous/src/Xanthous/App/Common.hs
new file mode 100644
index 000000000000..69ba6f0e0596
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/App/Common.hs
@@ -0,0 +1,67 @@
+--------------------------------------------------------------------------------
+module Xanthous.App.Common
+  ( describeEntities
+  , describeEntitiesAt
+  , entitiesAtPositionWithType
+
+    -- * Re-exports
+  , MonadState
+  , MonadRandom
+  , EntityMap
+  , module Xanthous.Game.Lenses
+  , module Xanthous.Monad
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Data.Aeson (object)
+import qualified Data.Aeson as A
+import           Control.Monad.State (MonadState)
+import           Control.Monad.Random (MonadRandom)
+--------------------------------------------------------------------------------
+import           Xanthous.Data (Position, positioned)
+import           Xanthous.Data.EntityMap (EntityMap)
+import qualified Xanthous.Data.EntityMap as EntityMap
+import           Xanthous.Game
+import           Xanthous.Game.Lenses
+import           Xanthous.Game.State
+import           Xanthous.Monad
+import           Xanthous.Entities.Character (Character)
+import           Xanthous.Util.Inflection (toSentence)
+--------------------------------------------------------------------------------
+
+entitiesAtPositionWithType
+  :: forall a. (Entity a, Typeable a)
+  => Position
+  -> EntityMap SomeEntity
+  -> [(EntityMap.EntityID, a)]
+entitiesAtPositionWithType pos em =
+  let someEnts = EntityMap.atPositionWithIDs pos em
+  in flip foldMap someEnts $ \(eid, view positioned -> se) ->
+    case downcastEntity @a se of
+      Just e  -> [(eid, e)]
+      Nothing -> []
+
+describeEntitiesAt :: (MonadState GameState m, MonadRandom m) => Position -> m ()
+describeEntitiesAt pos =
+  use ( entities
+      . EntityMap.atPosition pos
+      . to (filter (not . entityIs @Character))
+      ) >>= \case
+        Empty -> pure ()
+        ents  -> describeEntities ents
+
+describeEntities
+  :: ( Entity entity
+    , MonadRandom m
+    , MonadState GameState m
+    , MonoFoldable (f Text)
+    , Functor f
+    , Element (f Text) ~ Text
+    )
+  => f entity
+  -> m ()
+describeEntities ents =
+  let descriptions = description <$> ents
+  in say ["entities", "description"]
+     $ object ["entityDescriptions" A..= toSentence descriptions]
diff --git a/users/aspen/xanthous/src/Xanthous/App/Prompt.hs b/users/aspen/xanthous/src/Xanthous/App/Prompt.hs
new file mode 100644
index 000000000000..799281a1c2fd
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/App/Prompt.hs
@@ -0,0 +1,228 @@
+{-# LANGUAGE UndecidableInstances #-}
+--------------------------------------------------------------------------------
+module Xanthous.App.Prompt
+  ( handlePromptEvent
+  , clearPrompt
+  , prompt
+  , prompt_
+  , stringPromptWithDefault
+  , stringPromptWithDefault_
+  , confirm_
+  , confirm
+  , menu
+  , menu_
+  , firePrompt_
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Brick (BrickEvent(..), Next)
+import           Brick.Widgets.Edit (handleEditorEvent)
+import           Data.Aeson (ToJSON, object)
+import           Graphics.Vty.Input.Events (Event(EvKey), Key(..))
+--------------------------------------------------------------------------------
+import           Xanthous.App.Common
+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, Creature)
+import           Xanthous.Entities.RawTypes (hostile)
+import qualified Linear.Metric as Metric
+--------------------------------------------------------------------------------
+
+handlePromptEvent
+  :: Text -- ^ Prompt message
+  -> Prompt AppM
+  -> BrickEvent ResourceName AppEvent
+  -> AppM (Next GameState)
+
+handlePromptEvent _ (Prompt Cancellable _ _ _ _) (VtyEvent (EvKey KEsc []))
+  = clearPrompt >> continue
+handlePromptEvent _ pr (VtyEvent (EvKey KEnter []))
+  = clearPrompt >> submitPrompt pr >> continue
+
+handlePromptEvent _ pr@(Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'y') []))
+  = clearPrompt >> submitPrompt pr >> continue
+
+handlePromptEvent _ (Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'n') []))
+  = clearPrompt >> continue
+
+handlePromptEvent
+  msg
+  (Prompt c SStringPrompt (StringPromptState edit) pri cb)
+  (VtyEvent ev)
+  = do
+    edit' <- lift $ handleEditorEvent ev edit
+    let prompt' = Prompt c SStringPrompt (StringPromptState edit') pri cb
+    promptState .= WaitingPrompt msg prompt'
+    continue
+
+handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ cb)
+  (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) []))
+  = clearPrompt >> cb (DirectionResult dir) >> continue
+handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ _) _ = continue
+
+handlePromptEvent _ (Prompt _ SMenu _ items' cb) (VtyEvent (EvKey (KChar chr) []))
+  | Just (MenuOption _ res) <- items' ^. at chr
+  = clearPrompt >> cb (MenuResult res) >> continue
+  | otherwise
+  = continue
+
+handlePromptEvent
+  msg
+  (Prompt c SPointOnMap (PointOnMapPromptState pos) pri cb)
+  (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) []))
+  = let pos' = move dir pos
+        prompt' = Prompt c SPointOnMap (PointOnMapPromptState pos') pri cb
+    in promptState .= WaitingPrompt msg prompt'
+       >> 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 _ _ _ _)
+  (VtyEvent (EvKey (KChar 'q') []))
+  = clearPrompt >> continue
+handlePromptEvent _ _ _ = continue
+
+clearPrompt :: AppM ()
+clearPrompt = promptState .= NoPrompt
+
+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, PromptParams pt ~ ())
+  => [Text]                     -- ^ Message key
+  -> params                     -- ^ Message params
+  -> PromptCancellable
+  -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler
+  -> AppM ()
+prompt msgPath params cancellable cb = do
+  let pt = singPromptType @pt
+  msg <- Messages.message msgPath params
+  mp :: Maybe (Prompt AppM) <- case pt of
+    SPointOnMap -> do
+      charPos <- use characterPosition
+      pure . Just $ mkPointOnMapPrompt cancellable charPos cb
+    SStringPrompt -> pure . Just $ mkStringPrompt cancellable 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, PromptParams pt ~ ())
+  => [Text] -- ^ Message key
+  -> PromptCancellable
+  -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler
+  -> AppM ()
+prompt_ msg = prompt msg $ object []
+
+stringPromptWithDefault
+  :: forall (params :: Type). (ToJSON params)
+  => [Text]                                -- ^ Message key
+  -> params                                -- ^ Message params
+  -> PromptCancellable
+  -> Text                                  -- ^ Prompt default
+  -> (PromptResult 'StringPrompt -> AppM ()) -- ^ Prompt promise handler
+  -> AppM ()
+stringPromptWithDefault msgPath params cancellable def cb = do
+  msg <- Messages.message msgPath params
+  let p = mkStringPromptWithDefault cancellable def cb
+  promptState .= WaitingPrompt msg p
+
+stringPromptWithDefault_
+  :: [Text]                                -- ^ Message key
+  -> PromptCancellable
+  -> Text                                  -- ^ Prompt default
+  -> (PromptResult 'StringPrompt -> AppM ()) -- ^ Prompt promise handler
+  -> AppM ()
+stringPromptWithDefault_ msg = stringPromptWithDefault msg $ object []
+
+confirm
+  :: ToJSON params
+  => [Text] -- ^ Message key
+  -> params
+  -> AppM ()
+  -> AppM ()
+confirm msgPath params
+  = prompt @'Confirm msgPath params Cancellable . const
+
+confirm_ :: [Text] -> AppM () -> AppM ()
+confirm_ msgPath = confirm msgPath $ object []
+
+menu :: forall (a :: Type) (params :: Type).
+       (ToJSON params)
+     => [Text]                            -- ^ Message key
+     -> params                            -- ^ Message params
+     -> PromptCancellable
+     -> Map Char (MenuOption a)           -- ^ Menu items
+     -> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler
+     -> AppM ()
+menu msgPath params cancellable items' cb = do
+  msg <- Messages.message msgPath params
+  let p = mkMenu cancellable items' cb
+  promptState .= WaitingPrompt msg p
+
+menu_ :: forall (a :: Type).
+        [Text]                            -- ^ Message key
+      -> PromptCancellable
+      -> Map Char (MenuOption a)           -- ^ Menu items
+      -> (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 @Creature
+           . 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/aspen/xanthous/src/Xanthous/App/Time.hs b/users/aspen/xanthous/src/Xanthous/App/Time.hs
new file mode 100644
index 000000000000..cca352858d9c
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/App/Time.hs
@@ -0,0 +1,42 @@
+--------------------------------------------------------------------------------
+module Xanthous.App.Time
+  ( stepGame
+  , stepGameBy
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           System.Exit
+--------------------------------------------------------------------------------
+import           Xanthous.Data (Ticks)
+import           Xanthous.App.Prompt
+import qualified Xanthous.Data.EntityMap as EntityMap
+import           Xanthous.Entities.Character (isDead)
+import           Xanthous.Game.State
+import           Xanthous.Game.Prompt
+import           Xanthous.Game.Lenses
+import           Control.Monad.State (modify)
+import qualified Xanthous.Game.Memo as Memo
+--------------------------------------------------------------------------------
+
+
+stepGameBy :: Ticks -> AppM ()
+stepGameBy ticks = do
+  ents <- uses entities EntityMap.toEIDsAndPositioned
+  for_ ents $ \(eid, pEntity) -> do
+    pEntity' <- step ticks pEntity
+    entities . ix eid .= pEntity'
+
+  clearMemo Memo.characterVisiblePositions
+  modify updateCharacterVision
+
+  whenM (uses character isDead)
+    . prompt_ @'Continue ["dead"] Uncancellable
+    . const . lift . liftIO
+    $ exitSuccess
+
+ticksPerTurn :: Ticks
+ticksPerTurn = 100
+
+stepGame :: AppM ()
+stepGame = stepGameBy ticksPerTurn