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>

7 files changed, 0 insertions, 1475 deletions

diff --git a/users/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs b/users/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs
deleted file mode 100644
index 679bfe54597f..000000000000
--- a/users/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs
+++ /dev/null
@@ -1,53 +0,0 @@
-{-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE RecordWildCards #-}
---------------------------------------------------------------------------------
-module Xanthous.Game.Arbitrary where
---------------------------------------------------------------------------------
-import           Xanthous.Prelude hiding (foldMap)
---------------------------------------------------------------------------------
-import           Test.QuickCheck
-import           System.Random
-import           Data.Foldable (foldMap)
---------------------------------------------------------------------------------
-import           Xanthous.Data.Levels
-import qualified Xanthous.Data.EntityMap as EntityMap
-import           Xanthous.Entities.Entities ()
-import           Xanthous.Entities.Character
-import           Xanthous.Game.State
-import           Xanthous.Orphans ()
-import           Xanthous.Util.QuickCheck (GenericArbitrary(..))
---------------------------------------------------------------------------------
-
-deriving via GenericArbitrary GameLevel instance Arbitrary GameLevel
-
-instance Arbitrary GameState where
-  arbitrary = do
-    chr <- arbitrary @Character
-    _upStaircasePosition <- arbitrary
-    _messageHistory <- arbitrary
-    levs <- arbitrary @(Levels GameLevel)
-    _levelRevealedPositions <-
-      fmap setFromList
-      . sublistOf
-      . foldMap (EntityMap.positions . _levelEntities)
-      $ levs
-    let (_characterEntityID, _levelEntities) =
-          EntityMap.insertAtReturningID _upStaircasePosition (SomeEntity chr)
-          $ levs ^. current . levelEntities
-        _levels = levs & current .~ GameLevel {..}
-    _randomGen <- mkStdGen <$> arbitrary
-    let _promptState = NoPrompt -- TODO
-    _activePanel <- arbitrary
-    _debugState <- arbitrary
-    let _autocommand = NoAutocommand
-    _memo <- arbitrary
-    _savefile <- arbitrary
-    pure $ GameState {..}
-
-
-instance CoArbitrary GameLevel
-instance Function GameLevel
-instance CoArbitrary GameState
-instance Function GameState
diff --git a/users/grfn/xanthous/src/Xanthous/Game/Draw.hs b/users/grfn/xanthous/src/Xanthous/Game/Draw.hs
deleted file mode 100644
index 291dfd8b5e46..000000000000
--- a/users/grfn/xanthous/src/Xanthous/Game/Draw.hs
+++ /dev/null
@@ -1,224 +0,0 @@
---------------------------------------------------------------------------------
-module Xanthous.Game.Draw
-  ( drawGame
-  ) 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(..))
-import qualified Xanthous.Data.App as Resource
-import qualified Xanthous.Data.EntityMap as EntityMap
-import           Xanthous.Game.State
-import           Xanthous.Entities.Common (Wielded(..), wielded, backpack)
-import           Xanthous.Entities.Character
-import           Xanthous.Entities.Item (Item)
-import           Xanthous.Game
-                 ( characterPosition
-                 , character
-                 , revealedEntitiesAtPosition
-                 )
-import           Xanthous.Game.Prompt
-import           Xanthous.Orphans ()
-import Brick.Widgets.Center (hCenter)
-import Xanthous.Command (Keybinding (..), keybindings, Command, commandIsHidden)
-import Graphics.Vty.Input.Events (Modifier(..))
-import Graphics.Vty.Input (Key(..))
-import Brick.Widgets.Table
---------------------------------------------------------------------------------
-
-cursorPosition :: GameState -> Widget ResourceName -> Widget ResourceName
-cursorPosition game
-  | WaitingPrompt _ (Prompt _ _ (preview promptStatePosition -> Just pos) _ _)
-    <- game ^. promptState
-  = showCursor Resource.Prompt (pos ^. loc)
-  | otherwise
-  = showCursor Resource.Character (game ^. characterPosition . loc)
-
-drawMessages :: MessageHistory -> Widget ResourceName
-drawMessages = txtWrap . (<> " ") . unwords . reverse . oextract
-
-drawPromptState :: GamePromptState m -> Widget ResourceName
-drawPromptState NoPrompt = emptyWidget
-drawPromptState (WaitingPrompt msg (Prompt _ pt ps pri _)) =
-  case (pt, ps, pri) of
-    (SStringPrompt, StringPromptState edit, mDef) ->
-      txt msg
-      <+> txt (maybe "" (\def -> "(default: " <> def <> ") ") mDef)
-      <+> renderEditor (txt . fold) True edit
-    (SDirectionPrompt, DirectionPromptState, _) -> txtWrap msg
-    (SMenu, _, menuItems) ->
-      txtWrap msg
-      <=> foldl' (<=>) emptyWidget (map drawMenuItem $ itoList menuItems)
-    _ -> txtWrap msg
-  where
-    drawMenuItem (chr, MenuOption m _) =
-      str ("[" <> pure chr <> "] ") <+> txtWrap m
-
-drawEntities
-  :: forall m. MonadState GameState m
-  => m (Widget ResourceName)
-drawEntities = do
-  allEnts <- use entities
-  let entityPositions = EntityMap.positions allEnts
-      maxY = fromMaybe 0 $ maximumOf (folded . y) entityPositions
-      maxX = fromMaybe 0 $ maximumOf (folded . x) entityPositions
-      rows = traverse mkRow [0..maxY]
-      mkRow rowY = hBox <$> traverse (renderEntityAt . flip Position rowY) [0..maxX]
-      renderEntityAt pos
-        = renderTopEntity pos <$> revealedEntitiesAtPosition pos
-      renderTopEntity pos ents
-        = let neighbors = EntityMap.neighbors pos allEnts
-          in maybe (str " ") (drawWithNeighbors neighbors)
-             $ maximumBy (compare `on` drawPriority)
-             <$> fromNullable ents
-  vBox <$> rows
-
-drawMap :: MonadState GameState m => m (Widget ResourceName)
-drawMap = do
-  cursorPos <- gets cursorPosition
-  viewport Resource.MapViewport Both . cursorPos <$> drawEntities
-
-bullet :: Char
-bullet = '•'
-
-drawInventoryPanel :: GameState -> Widget ResourceName
-drawInventoryPanel game
-  =   drawWielded  (game ^. character . inventory . wielded)
-  <=> drawBackpack (game ^. character . inventory . backpack)
-  where
-    drawWielded (Hands Nothing Nothing) = emptyWidget
-    drawWielded (DoubleHanded i) =
-      txtWrap $ "You are holding " <> description i <> " in both hands"
-    drawWielded (Hands l r) = drawHand "left" l <=> drawHand "right" r
-    drawHand side = maybe emptyWidget $ \i ->
-      txtWrap ( "You are holding "
-              <> description i
-              <> " in your " <> side <> " hand"
-              )
-      <=> txt " "
-
-    drawBackpack :: Vector Item -> Widget ResourceName
-    drawBackpack Empty = txtWrap "Your backpack is empty right now."
-    drawBackpack backpackItems
-      = txtWrap ( "You are currently carrying the following items in your "
-                <> "backpack:")
-        <=> txt " "
-        <=> foldl' (<=>) emptyWidget
-            (map
-              (txtWrap . ((bullet <| " ") <>) . description)
-              backpackItems)
-
-drawHelpPanel :: Widget ResourceName
-drawHelpPanel
-  = txtWrap "To move in a direction or attack, use vi keys (hjklyubn):"
-  <=> txt " "
-  <=> hCenter keyStar
-  <=> txt " "
-  <=> cmds
-  where
-    keyStar
-      =   txt "y k u"
-      <=> txt " \\|/"
-      <=> txt "h-.-l"
-      <=> txt " /|\\"
-      <=> txt "b j n"
-
-    cmds
-      = renderTable
-      . alignRight 0
-      . setDefaultRowAlignment AlignTop
-      . surroundingBorder False
-      . rowBorders False
-      . columnBorders False
-      . table $ help <&> \(key, cmd) -> [ txt $ key <> " : "
-                                       , hLimitPercent 100 $ txtWrap cmd]
-
-    help =
-      extraHelp <>
-      keybindings
-        ^.. ifolded
-          . filtered (not . commandIsHidden)
-          . withIndex
-          . to (bimap displayKeybinding displayCommand)
-    extraHelp
-      = [("Shift-Dir", "Auto-move")]
-
-    displayCommand = tshow @Command
-    displayKeybinding (Keybinding k mods) = foldMap showMod mods <> showKey k
-
-    showMod MCtrl  = "Ctrl-"
-    showMod MShift = "Shift-"
-    showMod MAlt   = "Alt-"
-    showMod MMeta  = "Meta-"
-
-    showKey (KChar c) = pack [c]
-    showKey KEsc = "<Esc>"
-    showKey KBS = "<Backspace>"
-    showKey KEnter = "<Enter>"
-    showKey KLeft = "<Left>"
-    showKey KRight = "<Right>"
-    showKey KUp = "<Up>"
-    showKey KDown = "<Down>"
-    showKey KUpLeft = "<UpLeft>"
-    showKey KUpRight = "<UpRight>"
-    showKey KDownLeft = "<DownLeft>"
-    showKey KDownRight = "<DownRight>"
-    showKey KCenter = "<Center>"
-    showKey (KFun n) = "<F" <> tshow n <> ">"
-    showKey KBackTab = "<BackTab>"
-    showKey KPrtScr = "<PrtScr>"
-    showKey KPause = "<Pause>"
-    showKey KIns = "<Ins>"
-    showKey KHome = "<Home>"
-    showKey KPageUp = "<PageUp>"
-    showKey KDel = "<Del>"
-    showKey KEnd = "<End>"
-    showKey KPageDown = "<PageDown>"
-    showKey KBegin = "<Begin>"
-    showKey KMenu = "<Menu>"
-
-drawPanel :: GameState -> Panel -> Widget ResourceName
-drawPanel game panel
-  = border
-  . hLimit 35
-  . viewport (Resource.Panel panel) Vertical
-  $ case panel of
-      HelpPanel -> drawHelpPanel
-      InventoryPanel -> drawInventoryPanel game
-      ItemDescriptionPanel desc -> txtWrap desc
-
-drawCharacterInfo :: Character -> Widget ResourceName
-drawCharacterInfo ch = txt " " <+> charName <+> charHitpoints
-  where
-    charName | Just n <- ch ^. characterName
-             = txt $ n <> " "
-             | otherwise
-             = emptyWidget
-    charHitpoints
-        = txt "Hitpoints: "
-      <+> txt (tshow $ let Hitpoints hp = characterHitpoints ch in hp)
-
-drawGame :: GameState -> [Widget ResourceName]
-drawGame = evalState $ do
-  game <- get
-  drawnMap <- drawMap
-  pure
-    . pure
-    . withBorderStyle unicode
-    $ case game ^. promptState of
-        NoPrompt -> drawMessages (game ^. messageHistory)
-        _ -> emptyWidget
-    <=> drawPromptState (game ^. promptState)
-    <=>
-    (maybe emptyWidget (drawPanel game) (game ^. activePanel)
-    <+> border drawnMap
-    )
-    <=> drawCharacterInfo (game ^. character)
diff --git a/users/grfn/xanthous/src/Xanthous/Game/Env.hs b/users/grfn/xanthous/src/Xanthous/Game/Env.hs
deleted file mode 100644
index 5d7b275c8a0b..000000000000
--- a/users/grfn/xanthous/src/Xanthous/Game/Env.hs
+++ /dev/null
@@ -1,37 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
---------------------------------------------------------------------------------
-module Xanthous.Game.Env
-  ( Config(..)
-  , defaultConfig
-  , disableSaving
-  , GameEnv(..)
-  , eventChan
-  , config
-  ) where
---------------------------------------------------------------------------------
-import Xanthous.Prelude
---------------------------------------------------------------------------------
-import Brick.BChan (BChan)
-import Xanthous.Data.App (AppEvent)
---------------------------------------------------------------------------------
-
-data Config = Config
-  { _disableSaving :: Bool
-  }
-  deriving stock (Generic, Show, Eq)
-makeLenses ''Config
-{-# ANN Config ("HLint: ignore Use newtype instead of data" :: String) #-}
-
-defaultConfig :: Config
-defaultConfig = Config
-  { _disableSaving = False
-  }
-
---------------------------------------------------------------------------------
-
-data GameEnv = GameEnv
-  { _eventChan :: BChan AppEvent
-  , _config :: Config
-  }
-  deriving stock (Generic)
-makeLenses ''GameEnv
diff --git a/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs b/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs
deleted file mode 100644
index c692a3b47944..000000000000
--- a/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs
+++ /dev/null
@@ -1,178 +0,0 @@
-{-# LANGUAGE RecordWildCards       #-}
-{-# LANGUAGE QuantifiedConstraints #-}
-{-# LANGUAGE AllowAmbiguousTypes   #-}
---------------------------------------------------------------------------------
-module Xanthous.Game.Lenses
-  ( clearMemo
-  , positionedCharacter
-  , character
-  , characterPosition
-  , updateCharacterVision
-  , characterVisiblePositions
-  , characterVisibleEntities
-  , positionIsCharacterVisible
-  , getInitialState
-  , initialStateFromSeed
-  , entitiesAtCharacter
-  , revealedEntitiesAtPosition
-  , hearingRadius
-
-    -- * Collisions
-  , Collision(..)
-  , entitiesCollision
-  , collisionAt
-  ) where
---------------------------------------------------------------------------------
-import           Xanthous.Prelude
---------------------------------------------------------------------------------
-import           System.Random
-import           Control.Monad.State
-import           Control.Monad.Random (getRandom)
---------------------------------------------------------------------------------
-import           Xanthous.Game.State
-import qualified Xanthous.Game.Memo as Memo
-import           Xanthous.Data
-import           Xanthous.Data.Levels
-import qualified Xanthous.Data.EntityMap as EntityMap
-import           Xanthous.Data.EntityMap.Graphics
-                 (visiblePositions, visibleEntities)
-import           Xanthous.Data.VectorBag
-import           Xanthous.Entities.Character (Character, mkCharacter)
-import           {-# SOURCE #-} Xanthous.Entities.Entities ()
-import           Xanthous.Game.Memo (emptyMemoState, MemoState)
-import           Xanthous.Data.Memo (fillWithM, Memoized)
---------------------------------------------------------------------------------
-
-getInitialState :: IO GameState
-getInitialState = initialStateFromSeed <$> getRandom
-
-initialStateFromSeed :: Int -> GameState
-initialStateFromSeed seed =
-  let _randomGen = mkStdGen seed
-      chr = mkCharacter
-      _upStaircasePosition = Position 0 0
-      (_characterEntityID, _levelEntities)
-        = EntityMap.insertAtReturningID
-          _upStaircasePosition
-          (SomeEntity chr)
-          mempty
-      _levelRevealedPositions = mempty
-      level = GameLevel {..}
-      _levels = oneLevel level
-      _messageHistory = mempty
-      _promptState = NoPrompt
-      _activePanel = Nothing
-      _debugState = DebugState
-        { _allRevealed = False
-        }
-      _savefile = Nothing
-      _autocommand = NoAutocommand
-      _memo = emptyMemoState
-  in GameState {..}
-
-clearMemo :: MonadState GameState m => Lens' MemoState (Memoized k v) -> m ()
-clearMemo l = memo %= Memo.clear l
-
-positionedCharacter :: Lens' GameState (Positioned Character)
-positionedCharacter = lens getPositionedCharacter setPositionedCharacter
-  where
-    setPositionedCharacter :: GameState -> Positioned Character -> GameState
-    setPositionedCharacter game chr
-      = game
-      &  entities . at (game ^. characterEntityID)
-      ?~ fmap SomeEntity chr
-
-    getPositionedCharacter :: GameState -> Positioned Character
-    getPositionedCharacter game
-      = over positioned
-        ( fromMaybe (error "Invariant error: Character was not a character!")
-        . downcastEntity
-        )
-      . fromMaybe (error "Invariant error: Character not found!")
-      $ EntityMap.lookupWithPosition
-        (game ^. characterEntityID)
-        (game ^. entities)
-
-
-character :: Lens' GameState Character
-character = positionedCharacter . positioned
-
-characterPosition :: Lens' GameState Position
-characterPosition = positionedCharacter . position
-
--- TODO make this dynamic
-visionRadius :: Word
-visionRadius = 12
-
--- TODO make this dynamic
-hearingRadius :: Word
-hearingRadius = 12
-
--- | Update the revealed entities at the character's position based on their
--- vision
-updateCharacterVision :: GameState -> GameState
-updateCharacterVision = execState $ do
-  positions <- characterVisiblePositions
-  revealedPositions <>= positions
-
-characterVisiblePositions :: MonadState GameState m => m (Set Position)
-characterVisiblePositions = do
-  charPos <- use characterPosition
-  fillWithM
-    (memo . Memo.characterVisiblePositions)
-    charPos
-    (uses entities $ visiblePositions charPos visionRadius)
-
-characterVisibleEntities :: GameState -> EntityMap.EntityMap SomeEntity
-characterVisibleEntities game =
-  let charPos = game ^. characterPosition
-  in visibleEntities charPos visionRadius $ game ^. entities
-
-positionIsCharacterVisible :: MonadState GameState m => Position -> m Bool
-positionIsCharacterVisible p = (p `elem`) <$> characterVisiblePositions
--- ^ TODO optimize
-
-entitiesCollision
-  :: ( Functor f
-    , forall xx. MonoFoldable (f xx)
-    , Element (f SomeEntity) ~ SomeEntity
-    , Element (f (Maybe Collision)) ~ Maybe Collision
-    , Show (f (Maybe Collision))
-    , Show (f SomeEntity)
-    )
-  => f SomeEntity
-  -> Maybe Collision
-entitiesCollision = join . maximumMay . fmap entityCollision
-
-collisionAt :: MonadState GameState m => Position -> m (Maybe Collision)
-collisionAt p = uses (entities . EntityMap.atPosition p) entitiesCollision
-
-entitiesAtCharacter :: Lens' GameState (VectorBag SomeEntity)
-entitiesAtCharacter = lens getter setter
-  where
-    getter gs = gs ^. entities . EntityMap.atPosition (gs ^. characterPosition)
-    setter gs ents = gs
-      & entities . EntityMap.atPosition (gs ^. characterPosition) .~ ents
-
--- | Returns all entities at the given position that are revealed to the
--- character.
---
--- Concretely, this is either entities that are *currently* visible to the
--- character, or entities, that are immobile and that the character has seen
--- before
-revealedEntitiesAtPosition
-  :: MonadState GameState m
-  => Position
-  -> m (VectorBag SomeEntity)
-revealedEntitiesAtPosition p = do
-  allRev <- use $ debugState . allRevealed
-  cvps <- characterVisiblePositions
-  entitiesAtPosition <- use $ entities . EntityMap.atPosition p
-  revealed <- use revealedPositions
-  let immobileEntitiesAtPosition = filter (not . entityCanMove) entitiesAtPosition
-  pure $ if | allRev || p `member` cvps
-              -> entitiesAtPosition
-            | p `member` revealed
-              -> immobileEntitiesAtPosition
-            | otherwise
-              -> mempty
diff --git a/users/grfn/xanthous/src/Xanthous/Game/Memo.hs b/users/grfn/xanthous/src/Xanthous/Game/Memo.hs
deleted file mode 100644
index 154063b5dde2..000000000000
--- a/users/grfn/xanthous/src/Xanthous/Game/Memo.hs
+++ /dev/null
@@ -1,52 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
---------------------------------------------------------------------------------
--- | Memoized versions of calculations
---------------------------------------------------------------------------------
-module Xanthous.Game.Memo
-  ( MemoState
-  , emptyMemoState
-  , clear
-    -- ** Memo lenses
-  , characterVisiblePositions
-
-    -- * Memoized values
-  , Memoized(UnMemoized)
-  , memoizeWith
-  , getMemoized
-  , runMemoized
-  ) where
---------------------------------------------------------------------------------
-import Xanthous.Prelude
---------------------------------------------------------------------------------
-import Data.Aeson (ToJSON, FromJSON)
-import Data.Aeson.Generic.DerivingVia
-import Test.QuickCheck (CoArbitrary, Function, Arbitrary)
---------------------------------------------------------------------------------
-import Xanthous.Data (Position)
-import Xanthous.Data.Memo
-import Xanthous.Util.QuickCheck (GenericArbitrary(GenericArbitrary))
---------------------------------------------------------------------------------
-
--- | Memoized calculations on the game state
-data MemoState = MemoState
-  { -- | Memoized version of 'Xanthous.Game.Lenses.characterVisiblePositions',
-    -- memoized with the position of the character
-    _characterVisiblePositions :: Memoized Position (Set Position)
-  }
-  deriving stock (Show, Eq, Generic)
-  deriving anyclass (NFData, CoArbitrary, Function)
-  deriving Arbitrary via GenericArbitrary MemoState
-  deriving (ToJSON, FromJSON)
-       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
-           MemoState
-makeLenses ''MemoState
-
-emptyMemoState :: MemoState
-emptyMemoState = MemoState { _characterVisiblePositions = UnMemoized }
-{-# INLINE emptyMemoState #-}
-
-clear :: ASetter' MemoState (Memoized key val) -> MemoState -> MemoState
-clear = flip set UnMemoized
-{-# INLINE clear #-}
-
-{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-}
diff --git a/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs b/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs
deleted file mode 100644
index 2d6c0a280f41..000000000000
--- a/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs
+++ /dev/null
@@ -1,359 +0,0 @@
-{-# LANGUAGE DeriveFunctor        #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE StandaloneDeriving   #-}
-{-# LANGUAGE GADTs                #-}
---------------------------------------------------------------------------------
-module Xanthous.Game.Prompt
-  ( PromptType(..)
-  , SPromptType(..)
-  , SingPromptType(..)
-  , PromptCancellable(..)
-  , PromptResult(..)
-  , PromptState(..)
-  , promptStatePosition
-  , MenuOption(..)
-  , mkMenuItems
-  , PromptInput
-  , Prompt(..)
-  , mkPrompt
-  , mkStringPrompt
-  , mkStringPromptWithDefault
-  , mkMenu
-  , mkPointOnMapPrompt
-  , mkFirePrompt
-  , isCancellable
-  , submitPrompt
-  ) where
---------------------------------------------------------------------------------
-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, Tiles)
-import           Xanthous.Data.App (ResourceName)
-import qualified Xanthous.Data.App as Resource
---------------------------------------------------------------------------------
-
-data PromptType where
-  StringPrompt    :: PromptType
-  Confirm         :: PromptType
-  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)
-
-instance Show PromptType where
-  show StringPrompt = "StringPrompt"
-  show Confirm = "Confirm"
-  show (Menu _) = "Menu"
-  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
-  SFire            :: SPromptType 'Fire
-
-instance NFData (SPromptType pt) where
-  rnf SStringPrompt = ()
-  rnf SConfirm = ()
-  rnf SMenu = ()
-  rnf SDirectionPrompt = ()
-  rnf SPointOnMap = ()
-  rnf SContinue = ()
-  rnf SFire = ()
-
-class SingPromptType pt where singPromptType :: SPromptType pt
-instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt
-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"
-  show SConfirm         = "SConfirm"
-  show SMenu            = "SMenu"
-  show SDirectionPrompt = "SDirectionPrompt"
-  show SPointOnMap      = "SPointOnMap"
-  show SContinue        = "SContinue"
-  show SFire            = "SFire"
-
-data PromptCancellable
-  = Cancellable
-  | Uncancellable
-  deriving stock (Show, Eq, Ord, Enum, Generic)
-  deriving anyclass (NFData, CoArbitrary, Function)
-
-instance Arbitrary PromptCancellable where
-  arbitrary = genericArbitrary
-
-data PromptResult (pt :: PromptType) where
-  StringResult     :: Text      -> PromptResult 'StringPrompt
-  ConfirmResult    :: Bool      -> PromptResult 'Confirm
-  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
-  arbitrary = StringResult <$> arbitrary
-
-instance Arbitrary (PromptResult 'Confirm) where
-  arbitrary = ConfirmResult <$> arbitrary
-
-instance Arbitrary a => Arbitrary (PromptResult ('Menu a)) where
-  arbitrary = MenuResult <$> arbitrary
-
-instance Arbitrary (PromptResult 'DirectionPrompt) where
-  arbitrary = DirectionResult <$> arbitrary
-
-instance Arbitrary (PromptResult 'PointOnMap) where
-  arbitrary = PointOnMapResult <$> arbitrary
-
-instance Arbitrary (PromptResult 'Continue) where
-  arbitrary = pure ContinueResult
-
-instance Arbitrary (PromptResult 'Fire) where
-  arbitrary = FireResult <$> arbitrary
-
---------------------------------------------------------------------------------
-
-data PromptState pt where
-  StringPromptState
-    :: Editor Text ResourceName     -> PromptState 'StringPrompt
-  DirectionPromptState  ::            PromptState 'DirectionPrompt
-  ContinuePromptState   ::            PromptState 'Continue
-  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` ()
-  rnf DirectionPromptState = ()
-  rnf ContinuePromptState = ()
-  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
-
-instance Arbitrary (PromptState 'DirectionPrompt) where
-  arbitrary = pure DirectionPromptState
-
-instance Arbitrary (PromptState 'Continue) where
-  arbitrary = pure ContinuePromptState
-
-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
-
-instance CoArbitrary (PromptState 'DirectionPrompt) where
-  coarbitrary DirectionPromptState = coarbitrary ()
-
-instance CoArbitrary (PromptState 'Continue) where
-  coarbitrary ContinuePromptState = coarbitrary ()
-
-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)
-
-instance Comonad MenuOption where
-  extract (MenuOption _ x) = x
-  extend cok mo@(MenuOption text _) = MenuOption text (cok mo)
-
-mkMenuItems :: (MonoFoldable f, Element f ~ (Char, MenuOption a))
-            => f
-            -> Map Char (MenuOption a)
-mkMenuItems = flip foldl' mempty $ \items (chr, option) ->
-  let chr' = if has (ix chr) items
-             then getAlphaChar . smallestNotIn . map AlphaChar $ keys items
-             else chr
-  in items & at chr' ?~ option
-
-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 'PointOnMap   = Position -- Character pos
-  PromptInput 'Fire         = (Position, Tiles) -- Nearest enemy, range
-  PromptInput 'StringPrompt = Maybe Text -- Default value
-  PromptInput _ = ()
-
-data Prompt (m :: Type -> Type) where
-  Prompt
-    :: forall (pt :: PromptType)
-        (m :: Type -> Type).
-      PromptCancellable
-    -> SPromptType pt
-    -> PromptState pt
-    -> PromptInput pt
-    -> (PromptResult pt -> m ())
-    -> Prompt m
-
-instance Show (Prompt m) where
-  show (Prompt c pt ps pri _)
-    = "(Prompt "
-    <> show c <> " "
-    <> show pt <> " "
-    <> show ps <> " "
-    <> showPri
-    <> " <function>)"
-    where showPri = case pt of
-            SMenu -> show pri
-            _ -> "()"
-
-instance NFData (Prompt m) where
-  rnf (Prompt c SMenu ps pri cb)
-            = c
-    `deepseq` ps
-    `deepseq` pri
-    `seq` cb
-    `seq` ()
-  rnf (Prompt c spt ps pri cb)
-            = c
-    `deepseq` spt
-    `deepseq` ps
-    `deepseq` pri
-    `seq` cb
-    `seq` ()
-
-instance CoArbitrary (m ()) => CoArbitrary (Prompt m) where
-  coarbitrary (Prompt c SStringPrompt ps pri cb) =
-    variant @Int 1 . coarbitrary (c, ps, pri, cb)
-  coarbitrary (Prompt c SConfirm _ pri cb) = -- TODO fill in prompt state
-    variant @Int 2 . coarbitrary (c, pri, cb)
-  coarbitrary (Prompt c SMenu _ps _pri _cb) =
-    variant @Int 3 . coarbitrary c {-, ps, pri, cb -}
-  coarbitrary (Prompt c SDirectionPrompt ps pri cb) =
-    variant @Int 4 . coarbitrary (c, ps, pri, cb)
-  coarbitrary (Prompt c SPointOnMap _ pri cb) = -- TODO fill in prompt state
-    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
---     where
---       toTuple (Prompt c pt ps pri cb) = (c, pt, ps, pri, cb)
-
-
-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@SDirectionPrompt cb = Prompt c pt DirectionPromptState () cb
-mkPrompt c pt@SContinue cb = Prompt c pt ContinuePromptState () cb
-mkPrompt c pt@SConfirm cb = Prompt c pt ConfirmPromptState () cb
-
-mkStringPrompt
-  :: PromptCancellable                  -- ^ Is the prompt cancellable or not?
-  -> (PromptResult 'StringPrompt -> m ()) -- ^ Function to call when the prompt is complete
-  -> Prompt m
-mkStringPrompt c =
-  let ps = StringPromptState $ editorText Resource.Prompt (Just 1) ""
-  in Prompt c SStringPrompt ps Nothing
-
-mkStringPromptWithDefault
-  :: PromptCancellable                  -- ^ Is the prompt cancellable or not?
-  -> Text                               -- ^ Default value for the prompt
-  -> (PromptResult 'StringPrompt -> m ()) -- ^ Function to call when the prompt is complete
-  -> Prompt m
-mkStringPromptWithDefault c def =
-  let ps = StringPromptState $ editorText Resource.Prompt (Just 1) ""
-  in Prompt c SStringPrompt ps (Just def)
-
-mkMenu
-  :: forall a m.
-    PromptCancellable
-  -> Map Char (MenuOption a) -- ^ Menu items
-  -> (PromptResult ('Menu a) -> m ())
-  -> Prompt m
-mkMenu c = Prompt c SMenu MenuPromptState
-
-mkPointOnMapPrompt
-  :: PromptCancellable
-  -> Position
-  -> (PromptResult 'PointOnMap -> m ())
-  -> 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
-
-submitPrompt :: Applicative m => Prompt m -> m ()
-submitPrompt (Prompt _ pt ps pri cb) =
-  case (pt, ps, pri) of
-    (SStringPrompt, StringPromptState edit, mDef) ->
-      let inputVal = mconcat . getEditContents $ edit
-          val | null inputVal, Just def <- mDef = def
-              | otherwise = inputVal
-      in cb $ StringResult val
-    (SDirectionPrompt, DirectionPromptState, _) ->
-      pure () -- Don't use submit with a direction prompt
-    (SContinue, ContinuePromptState, _) ->
-      cb ContinueResult
-    (SMenu, MenuPromptState, _) ->
-      pure () -- Don't use submit with a menu prompt
-    (SPointOnMap, PointOnMapPromptState pos, _) ->
-      cb $ PointOnMapResult pos
-    (SConfirm, ConfirmPromptState, _) ->
-      cb $ ConfirmResult True
-    (SFire, FirePromptState pos, _) ->
-      cb $ FireResult pos
diff --git a/users/grfn/xanthous/src/Xanthous/Game/State.hs b/users/grfn/xanthous/src/Xanthous/Game/State.hs
deleted file mode 100644
index 13b1ba158818..000000000000
--- a/users/grfn/xanthous/src/Xanthous/Game/State.hs
+++ /dev/null
@@ -1,572 +0,0 @@
-{-# LANGUAGE StandaloneDeriving   #-}
-{-# LANGUAGE RecordWildCards      #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE TemplateHaskell      #-}
-{-# LANGUAGE GADTs                #-}
-{-# LANGUAGE AllowAmbiguousTypes  #-}
---------------------------------------------------------------------------------
-module Xanthous.Game.State
-  ( GameState(..)
-  , entities
-  , levels
-  , revealedPositions
-  , messageHistory
-  , randomGen
-  , activePanel
-  , promptState
-  , characterEntityID
-  , autocommand
-  , savefile
-  , memo
-  , GamePromptState(..)
-
-    -- * Game Level
-  , GameLevel(..)
-  , levelEntities
-  , upStaircasePosition
-  , levelRevealedPositions
-
-    -- * Messages
-  , MessageHistory(..)
-  , HasMessages(..)
-  , HasTurn(..)
-  , HasDisplayedTurn(..)
-  , pushMessage
-  , previousMessage
-  , nextTurn
-
-    -- * Autocommands
-  , Autocommand(..)
-  , AutocommandState(..)
-  , _NoAutocommand
-  , _ActiveAutocommand
-
-    -- * App monad
-  , AppT(..)
-  , AppM
-  , runAppT
-
-    -- * Entities
-  , Draw(..)
-  , Brain(..)
-  , Brainless(..)
-  , brainVia
-  , Collision(..)
-  , Entity(..)
-  , SomeEntity(..)
-  , downcastEntity
-  , _SomeEntity
-  , entityIs
-  , entityTypeName
-
-    -- ** Vias
-  , Color(..)
-  , DrawNothing(..)
-  , DrawRawChar(..)
-  , DrawRawCharPriority(..)
-  , DrawCharacter(..)
-  , DrawStyledCharacter(..)
-  , DeriveEntity(..)
-    -- ** Field classes
-  , HasChar(..)
-  , HasStyle(..)
-
-    -- * Debug State
-  , DebugState(..)
-  , debugState
-  , allRevealed
-  ) where
---------------------------------------------------------------------------------
-import           Xanthous.Prelude
---------------------------------------------------------------------------------
-import           Data.List.NonEmpty ( NonEmpty((:|)))
-import qualified Data.List.NonEmpty as NonEmpty
-import           Data.Typeable
-import           Data.Coerce
-import           System.Random
-import           Test.QuickCheck
-import           Test.QuickCheck.Arbitrary.Generic
-import           Control.Monad.Random.Class
-import           Control.Monad.State
-import           Control.Monad.Trans.Control (MonadTransControl(..))
-import           Control.Monad.Trans.Compose
-import           Control.Monad.Morph (MFunctor(..))
-import           Brick (EventM, Widget, raw, str, emptyWidget)
-import           Data.Aeson (ToJSON(..), FromJSON(..), Value(Null))
-import qualified Data.Aeson as JSON
-import           Data.Aeson.Generic.DerivingVia
-import           Data.Generics.Product.Fields
-import qualified Graphics.Vty.Attributes as Vty
-import qualified Graphics.Vty.Image as Vty
---------------------------------------------------------------------------------
-import           Xanthous.Util (KnownBool(..))
-import           Xanthous.Data
-import           Xanthous.Data.App
-import           Xanthous.Data.Levels
-import           Xanthous.Data.EntityMap (EntityMap, EntityID)
-import           Xanthous.Data.EntityChar
-import           Xanthous.Data.VectorBag
-import           Xanthous.Data.Entities
-import           Xanthous.Orphans ()
-import           Xanthous.Game.Prompt
-import           Xanthous.Game.Env
-import           Xanthous.Game.Memo (MemoState)
---------------------------------------------------------------------------------
-
-data MessageHistory
-  = MessageHistory
-  { _messages      :: Map Word (NonEmpty Text)
-  , _turn          :: Word
-  , _displayedTurn :: Maybe Word
-  }
-  deriving stock (Show, Eq, Generic)
-  deriving anyclass (NFData, CoArbitrary, Function)
-  deriving Arbitrary via GenericArbitrary MessageHistory
-  deriving (ToJSON, FromJSON)
-       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
-           MessageHistory
-makeFieldsNoPrefix ''MessageHistory
-
-instance Semigroup MessageHistory where
-  (MessageHistory msgs₁ turn₁ dt₁) <> (MessageHistory msgs₂ turn₂ dt₂) =
-    MessageHistory (msgs₁ <> msgs₂) (max turn₁ turn₂) $ case (dt₁, dt₂) of
-      (_, Nothing)      -> Nothing
-      (Just t, _)       -> Just t
-      (Nothing, Just t) -> Just t
-
-instance Monoid MessageHistory where
-  mempty = MessageHistory mempty 0 Nothing
-
-type instance Element MessageHistory = [Text]
-instance MonoFunctor MessageHistory where
-  omap f mh@(MessageHistory _ t _) =
-    mh & messages . at t %~ (NonEmpty.nonEmpty . f . toList =<<)
-
-instance MonoComonad MessageHistory where
-  oextract (MessageHistory ms t dt) = maybe [] toList $ ms ^. at (fromMaybe t dt)
-  oextend cok mh@(MessageHistory _ t dt) =
-    mh & messages . at (fromMaybe t dt) .~ NonEmpty.nonEmpty (cok mh)
-
-pushMessage :: Text -> MessageHistory -> MessageHistory
-pushMessage msg mh@(MessageHistory _ turn' _) =
-  mh
-  & messages . at turn' %~ \case
-    Nothing -> Just $ msg :| mempty
-    Just msgs -> Just $ msg <| msgs
-  & displayedTurn .~ Nothing
-
-nextTurn :: MessageHistory -> MessageHistory
-nextTurn = (turn +~ 1) . (displayedTurn .~ Nothing)
-
-previousMessage :: MessageHistory -> MessageHistory
-previousMessage mh = mh & displayedTurn .~ maximumOf
-  (messages . ifolded . asIndex . filtered (< mh ^. turn))
-  mh
-
-
---------------------------------------------------------------------------------
-
-data GamePromptState m where
-  NoPrompt :: GamePromptState m
-  WaitingPrompt :: Text -> Prompt m -> GamePromptState m
-  deriving stock (Show, Generic)
-  deriving anyclass (NFData)
-
--- | Non-injective! We never try to serialize waiting prompts, since:
---
---  * they contain callback functions
---  * we can't save the game when in a prompt anyway
-instance ToJSON (GamePromptState m) where
-  toJSON _ = Null
-
--- | Always expects Null
-instance FromJSON (GamePromptState m) where
-  parseJSON Null = pure NoPrompt
-  parseJSON _ = fail "Invalid GamePromptState; expected null"
-
-instance CoArbitrary (GamePromptState m) where
-  coarbitrary NoPrompt = variant @Int 1
-  coarbitrary (WaitingPrompt txt _) = variant @Int 2 . coarbitrary txt
-
-instance Function (GamePromptState m) where
-  function = functionMap onlyNoPrompt (const NoPrompt)
-    where
-      onlyNoPrompt NoPrompt = ()
-      onlyNoPrompt (WaitingPrompt _ _) =
-        error "Can't handle prompts in Function!"
-
---------------------------------------------------------------------------------
-
-newtype AppT m a
-  = AppT { unAppT :: ReaderT GameEnv (StateT GameState m) a }
-  deriving ( Functor
-           , Applicative
-           , Monad
-           , MonadState GameState
-           , MonadReader GameEnv
-           , MonadIO
-           )
-       via (ReaderT GameEnv (StateT GameState m))
-  deriving ( MonadTrans
-           , MFunctor
-           )
-       via (ReaderT GameEnv `ComposeT` StateT GameState)
-
-type AppM = AppT (EventM ResourceName)
-
---------------------------------------------------------------------------------
-
-class Draw a where
-  drawWithNeighbors :: Neighbors (VectorBag SomeEntity) -> a -> Widget n
-  drawWithNeighbors = const draw
-
-  draw :: a -> Widget n
-  draw = drawWithNeighbors $ pure mempty
-
-  -- | higher priority gets drawn on top
-  drawPriority :: a -> Word
-  drawPriority = const minBound
-
-instance Draw a => Draw (Positioned a) where
-  drawWithNeighbors ns (Positioned _ a) = drawWithNeighbors ns a
-  draw (Positioned _ a) = draw a
-
-newtype DrawCharacter (char :: Symbol) (a :: Type) where
-  DrawCharacter :: a -> DrawCharacter char a
-
-instance KnownSymbol char => Draw (DrawCharacter char a) where
-  draw _ = str $ symbolVal @char Proxy
-
-data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White
-
-class KnownColor (color :: Color) where
-  colorVal :: forall proxy. proxy color -> Vty.Color
-
-instance KnownColor 'Black where colorVal _ = Vty.black
-instance KnownColor 'Red where colorVal _ = Vty.red
-instance KnownColor 'Green where colorVal _ = Vty.green
-instance KnownColor 'Yellow where colorVal _ = Vty.yellow
-instance KnownColor 'Blue where colorVal _ = Vty.blue
-instance KnownColor 'Magenta where colorVal _ = Vty.magenta
-instance KnownColor 'Cyan where colorVal _ = Vty.cyan
-instance KnownColor 'White where colorVal _ = Vty.white
-
-class KnownMaybeColor (maybeColor :: Maybe Color) where
-  maybeColorVal :: forall proxy. proxy maybeColor -> Maybe Vty.Color
-
-instance KnownMaybeColor 'Nothing where maybeColorVal _ = Nothing
-instance KnownColor color => KnownMaybeColor ('Just color) where
-  maybeColorVal _ = Just $ colorVal @color Proxy
-
-newtype DrawStyledCharacter (fg :: Maybe Color) (bg :: Maybe Color) (char :: Symbol) (a :: Type) where
-  DrawStyledCharacter :: a -> DrawStyledCharacter fg bg char a
-
-instance
-  ( KnownMaybeColor fg
-  , KnownMaybeColor bg
-  , KnownSymbol char
-  )
-  => Draw (DrawStyledCharacter fg bg char a) where
-  draw _ = raw $ Vty.string attr $ symbolVal @char Proxy
-    where attr = Vty.Attr
-            { Vty.attrStyle = Vty.Default
-            , Vty.attrForeColor = maybe Vty.Default Vty.SetTo
-                                  $ maybeColorVal @fg Proxy
-            , Vty.attrBackColor = maybe Vty.Default Vty.SetTo
-                                  $ maybeColorVal @bg Proxy
-            , Vty.attrURL = Vty.Default
-            }
-
-instance Draw EntityChar where
-  draw EntityChar{..} = raw $ Vty.string _style [_char]
-
---------------------------------------------------------------------------------
-
-newtype DrawNothing (a :: Type) = DrawNothing a
-
-instance Draw (DrawNothing a) where
-  draw = const emptyWidget
-  drawPriority = const 0
-
-newtype DrawRawChar (rawField :: Symbol) (a :: Type) = DrawRawChar a
-
-instance
-  forall rawField a raw.
-  ( HasField rawField a a raw raw
-  , HasChar raw EntityChar
-  ) => Draw (DrawRawChar rawField a) where
-  draw (DrawRawChar e) = draw $ e ^. field @rawField . char
-
-newtype DrawRawCharPriority
-  (rawField :: Symbol)
-  (priority :: Nat)
-  (a :: Type)
-  = DrawRawCharPriority a
-
-instance
-  forall rawField priority a raw.
-  ( HasField rawField a a raw raw
-  , KnownNat priority
-  , HasChar raw EntityChar
-  ) => Draw (DrawRawCharPriority rawField priority a) where
-  draw (DrawRawCharPriority e) = draw $ e ^. field @rawField . char
-  drawPriority = const . fromIntegral $ natVal @priority Proxy
-
-
---------------------------------------------------------------------------------
-
-class Brain a where
-  step :: Ticks -> Positioned a -> AppM (Positioned a)
-  -- | Does this entity ever move on its own?
-  entityCanMove :: a -> Bool
-  entityCanMove = const False
-
-newtype Brainless a = Brainless a
-
-instance Brain (Brainless a) where
-  step = const pure
-
--- | Workaround for the inability to use DerivingVia on Brain due to the lack of
--- higher-order roles (specifically AppT not having its last type argument have
--- role representational bc of StateT)
-brainVia
-  :: forall brain entity. (Coercible entity brain, Brain brain)
-  => (entity -> brain) -- ^ constructor, ignored
-  -> (Ticks -> Positioned entity -> AppM (Positioned entity))
-brainVia _ ticks = fmap coerce . step ticks . coerce @_ @(Positioned brain)
-
---------------------------------------------------------------------------------
-
-class ( Show a, Eq a, Ord a, NFData a
-      , ToJSON a, FromJSON a
-      , Draw a, Brain a
-      ) => Entity a where
-  entityAttributes :: a -> EntityAttributes
-  entityAttributes = const defaultEntityAttributes
-  description :: a -> Text
-  entityChar :: a -> EntityChar
-  entityCollision :: a -> Maybe Collision
-  entityCollision = const $ Just Stop
-
-data SomeEntity where
-  SomeEntity :: forall a. (Entity a, Typeable a) => a -> SomeEntity
-
-instance Show SomeEntity where
-  show (SomeEntity e) = "SomeEntity (" <> show e <> ")"
-
-instance Eq SomeEntity where
-  (SomeEntity (a :: ea)) == (SomeEntity (b :: eb)) = case eqT @ea @eb of
-    Just Refl -> a == b
-    _ -> False
-
-instance Ord SomeEntity where
-  compare (SomeEntity (a :: ea)) (SomeEntity (b :: eb)) = case eqT @ea @eb of
-    Just Refl -> compare a b
-    _ -> compare (typeRep $ Proxy @ea) (typeRep $ Proxy @eb)
-
-
-instance NFData SomeEntity where
-  rnf (SomeEntity ent) = ent `deepseq` ()
-
-instance ToJSON SomeEntity where
-  toJSON (SomeEntity ent) = entityToJSON ent
-    where
-      entityToJSON :: forall entity. (Entity entity, Typeable entity)
-                   => entity -> JSON.Value
-      entityToJSON entity = JSON.object
-        [ "type" JSON..= tshow (typeRep @_ @entity Proxy)
-        , "data" JSON..= toJSON entity
-        ]
-
-instance Draw SomeEntity where
-  drawWithNeighbors ns (SomeEntity ent) = drawWithNeighbors ns ent
-  drawPriority (SomeEntity ent) = drawPriority ent
-
-instance Brain SomeEntity where
-  step ticks (Positioned p (SomeEntity ent)) =
-    fmap SomeEntity <$> step ticks (Positioned p ent)
-  entityCanMove (SomeEntity ent) = entityCanMove ent
-
-downcastEntity :: forall (a :: Type). (Typeable a) => SomeEntity -> Maybe a
-downcastEntity (SomeEntity e) = cast e
-
-entityIs :: forall (a :: Type). (Typeable a) => SomeEntity -> Bool
-entityIs = isJust . downcastEntity @a
-
-_SomeEntity :: forall a. (Entity a, Typeable a) => Prism' SomeEntity a
-_SomeEntity = prism' SomeEntity downcastEntity
-
--- | Get the name of the type of 'SomeEntity' as a string
-entityTypeName :: SomeEntity -> Text
-entityTypeName (SomeEntity e) = pack . tyConName . typeRepTyCon $ typeOf e
-
-newtype DeriveEntity
-  (blocksVision :: Bool)
-  (description :: Symbol)
-  (entityChar :: Symbol)
-  (entity :: Type)
-  = DeriveEntity entity
-  deriving newtype (Show, Eq, Ord, NFData, ToJSON, FromJSON, Draw)
-
-instance Brain entity => Brain (DeriveEntity b d c entity) where
-  step = brainVia $ \(DeriveEntity e) -> e
-
-instance
-  ( KnownBool blocksVision
-  , KnownSymbol description
-  , KnownSymbol entityChar
-  , Show entity, Eq entity, Ord entity, NFData entity
-  , ToJSON entity, FromJSON entity
-  , Draw entity, Brain entity
-  )
-  => Entity (DeriveEntity blocksVision description entityChar entity) where
-  entityAttributes _ = defaultEntityAttributes
-    & blocksVision .~ boolVal @blocksVision
-  description _ = pack . symbolVal $ Proxy @description
-  entityChar _ = fromString . symbolVal $ Proxy @entityChar
-
---------------------------------------------------------------------------------
-
-data GameLevel = GameLevel
-  { _levelEntities :: !(EntityMap SomeEntity)
-  , _upStaircasePosition :: !Position
-  , _levelRevealedPositions :: !(Set Position)
-  }
-  deriving stock (Show, Eq, Generic)
-  deriving anyclass (NFData)
-  deriving (ToJSON)
-       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
-           GameLevel
-
---------------------------------------------------------------------------------
-
-data Autocommand
-  = AutoMove Direction
-  | AutoRest
-  deriving stock (Show, Eq, Ord, Generic)
-  deriving anyclass (NFData, Hashable, ToJSON, FromJSON, CoArbitrary, Function)
-  deriving Arbitrary via GenericArbitrary Autocommand
-{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
-
-data AutocommandState
-  = NoAutocommand
-  | ActiveAutocommand Autocommand (Async ())
-  deriving stock (Eq, Ord, Generic)
-  deriving anyclass (Hashable)
-
-instance Show AutocommandState where
-  show NoAutocommand = "NoAutocommand"
-  show (ActiveAutocommand ac _) =
-    "(ActiveAutocommand " <> show ac <> " <Async>)"
-
-instance ToJSON AutocommandState where
-  toJSON = const Null
-
-instance FromJSON AutocommandState where
-  parseJSON Null = pure NoAutocommand
-  parseJSON _ = fail "Invalid AutocommandState; expected null"
-
-instance NFData AutocommandState where
-  rnf NoAutocommand = ()
-  rnf (ActiveAutocommand ac t) = ac `deepseq` t `seq` ()
-
-instance CoArbitrary AutocommandState where
-  coarbitrary NoAutocommand = variant @Int 1
-  coarbitrary (ActiveAutocommand ac t)
-    = variant @Int 2
-    . coarbitrary ac
-    . coarbitrary (hash t)
-
-instance Function AutocommandState where
-  function = functionMap onlyNoAC (const NoAutocommand)
-    where
-      onlyNoAC NoAutocommand = ()
-      onlyNoAC _ = error "Can't handle autocommands in Function"
-
---------------------------------------------------------------------------------
-
-
-data DebugState = DebugState
-  { _allRevealed :: !Bool
-  }
-  deriving stock (Show, Eq, Generic)
-  deriving anyclass (NFData, CoArbitrary, Function)
-  deriving (ToJSON, FromJSON)
-       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
-           DebugState
-{-# ANN DebugState ("HLint: ignore Use newtype instead of data" :: String) #-}
-
-instance Arbitrary DebugState where
-  arbitrary = genericArbitrary
-
-data GameState = GameState
-  { _levels            :: !(Levels GameLevel)
-  , _characterEntityID :: !EntityID
-  , _messageHistory    :: !MessageHistory
-  , _randomGen         :: !StdGen
-
-    -- | The active panel displayed in the UI, if any
-  , _activePanel       :: !(Maybe Panel)
-
-  , _promptState       :: !(GamePromptState AppM)
-  , _debugState        :: !DebugState
-  , _autocommand       :: !AutocommandState
-
-  -- | The path to the savefile that was loaded for this game, if any
-  , _savefile          :: !(Maybe FilePath)
-
-  , _memo              :: MemoState
-  }
-  deriving stock (Show, Generic)
-  deriving anyclass (NFData)
-  deriving (ToJSON)
-       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
-           GameState
-
-makeLenses ''GameLevel
-makeLenses ''GameState
-
-entities :: Lens' GameState (EntityMap SomeEntity)
-entities = levels . current . levelEntities
-
-revealedPositions :: Lens' GameState (Set Position)
-revealedPositions = levels . current . levelRevealedPositions
-
-instance Eq GameState where
-  (==) = (==) `on` \gs ->
-    ( gs ^. entities
-    , gs ^. revealedPositions
-    , gs ^. characterEntityID
-    , gs ^. messageHistory
-    , gs ^. activePanel
-    , gs ^. debugState
-    )
-
---------------------------------------------------------------------------------
-
-runAppT :: Monad m => AppT m a -> GameEnv -> GameState -> m (a, GameState)
-runAppT appt env initialState
-  = flip runStateT initialState
-  . flip runReaderT env
-  . unAppT
-  $ appt
-
-instance (Monad m) => MonadRandom (AppT m) where
-  getRandomR rng = randomGen %%= randomR rng
-  getRandom = randomGen %%= random
-  getRandomRs rng = uses randomGen $ randomRs rng
-  getRandoms = uses randomGen randoms
-
-instance MonadTransControl AppT where
-  type StT AppT a = (a, GameState)
-  liftWith f
-    = AppT
-    . ReaderT $ \e
-    -> StateT $ \s
-    -> (,s) <$> f (\action -> runAppT action e s)
-  restoreT = AppT . ReaderT . const . StateT . const
-
---------------------------------------------------------------------------------
-
-makeLenses ''DebugState
-makePrisms ''AutocommandState