4 files changed, 0 insertions, 413 deletions
diff --git a/users/grfn/xanthous/src/Xanthous/App/Autocommands.hs b/users/grfn/xanthous/src/Xanthous/App/Autocommands.hs
deleted file mode 100644
index 5d4db1a47465..000000000000
--- a/users/grfn/xanthous/src/Xanthous/App/Autocommands.hs
+++ /dev/null
@@ -1,76 +0,0 @@
---------------------------------------------------------------------------------
-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/grfn/xanthous/src/Xanthous/App/Common.hs b/users/grfn/xanthous/src/Xanthous/App/Common.hs
deleted file mode 100644
index 69ba6f0e0596..000000000000
--- a/users/grfn/xanthous/src/Xanthous/App/Common.hs
+++ /dev/null
@@ -1,67 +0,0 @@
---------------------------------------------------------------------------------
-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/grfn/xanthous/src/Xanthous/App/Prompt.hs b/users/grfn/xanthous/src/Xanthous/App/Prompt.hs
deleted file mode 100644
index 799281a1c2fd..000000000000
--- a/users/grfn/xanthous/src/Xanthous/App/Prompt.hs
+++ /dev/null
@@ -1,228 +0,0 @@
-{-# 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/grfn/xanthous/src/Xanthous/App/Time.hs b/users/grfn/xanthous/src/Xanthous/App/Time.hs
deleted file mode 100644
index cca352858d9c..000000000000
--- a/users/grfn/xanthous/src/Xanthous/App/Time.hs
+++ /dev/null
@@ -1,42 +0,0 @@
---------------------------------------------------------------------------------
-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