Add 'users/glittershark/xanthous/' from commit '53b56744f4335c038724a1bcffc27a7eb8cf6a6d' r/978

git-subtree-dir: users/glittershark/xanthous
git-subtree-mainline: 91f53f02d8479303910abfd3f3690d3ef27e6c4b
git-subtree-split: 53b56744f4335c038724a1bcffc27a7eb8cf6a6d

56 files changed, 7267 insertions, 0 deletions

diff --git a/users/glittershark/xanthous/src/Xanthous/AI/Gormlak.hs b/users/glittershark/xanthous/src/Xanthous/AI/Gormlak.hs
new file mode 100644
index 000000000000..8040fea35b8d
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/AI/Gormlak.hs
@@ -0,0 +1,124 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE UndecidableInstances #-}
+--------------------------------------------------------------------------------
+module Xanthous.AI.Gormlak
+  ( HasVisionRadius(..)
+  , GormlakBrain(..)
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding (lines)
+--------------------------------------------------------------------------------
+import           Control.Monad.State
+import           Control.Monad.Random
+import           Data.Aeson (object)
+import qualified Data.Aeson as A
+import           Data.Generics.Product.Fields
+--------------------------------------------------------------------------------
+import           Xanthous.Data
+                 ( Positioned(..), positioned, position
+                 , diffPositions, stepTowards, isUnit
+                 , Ticks, (|*|), invertedRate
+                 )
+import           Xanthous.Data.EntityMap
+import           Xanthous.Entities.Creature.Hippocampus
+import           Xanthous.Entities.Character (Character)
+import qualified Xanthous.Entities.Character as Character
+import qualified Xanthous.Entities.RawTypes as Raw
+import           Xanthous.Entities.RawTypes (CreatureType)
+import           Xanthous.Game.State
+import           Xanthous.Game.Lenses
+                 ( Collision(..), entitiesCollision, collisionAt
+                 , character, characterPosition
+                 )
+import           Xanthous.Data.EntityMap.Graphics (linesOfSight, canSee)
+import           Xanthous.Random
+import           Xanthous.Monad (say)
+--------------------------------------------------------------------------------
+
+--  TODO move the following two classes to a more central location
+
+class HasVisionRadius a where visionRadius :: a -> Word
+
+type IsCreature entity =
+  ( HasVisionRadius entity
+  , HasField "_hippocampus" entity entity Hippocampus Hippocampus
+  , HasField "_creatureType" entity entity CreatureType CreatureType
+  , A.ToJSON entity
+  )
+
+--------------------------------------------------------------------------------
+
+stepGormlak
+  :: forall entity m.
+    ( MonadState GameState m, MonadRandom m
+    , IsCreature entity
+    )
+  => Ticks
+  -> Positioned entity
+  -> m (Positioned entity)
+stepGormlak ticks pe@(Positioned pos creature) = do
+  dest <- maybe (selectDestination pos creature) pure
+         $ creature ^. field @"_hippocampus" . destination
+  let progress' =
+        dest ^. destinationProgress
+        + creature ^. field @"_creatureType" . Raw.speed . invertedRate |*| ticks
+  if progress' < 1
+    then pure
+         $ pe
+         & positioned . field @"_hippocampus" . destination
+         ?~ (dest & destinationProgress .~ progress')
+    else do
+      let newPos = dest ^. destinationPosition
+          remainingSpeed = progress' - 1
+      newDest <- selectDestination newPos creature
+                <&> destinationProgress +~ remainingSpeed
+      let pe' = pe & positioned . field @"_hippocampus" . destination ?~ newDest
+      collisionAt newPos >>= \case
+        Nothing -> pure $ pe' & position .~ newPos
+        Just Stop -> pure pe'
+        Just Combat -> do
+          ents <- use $ entities . atPosition newPos
+          when (any (entityIs @Character) ents) attackCharacter
+          pure pe'
+  where
+    selectDestination pos' creature' = destinationFromPos <$> do
+      canSeeCharacter <- uses entities $ canSee (entityIs @Character) pos' vision
+      if canSeeCharacter
+        then do
+          charPos <- use characterPosition
+          if isUnit (pos' `diffPositions` charPos)
+            then attackCharacter $> pos'
+            else pure $ pos' `stepTowards` charPos
+      else do
+        lines <- map (takeWhile (isNothing . entitiesCollision . map snd . snd)
+                    -- the first item on these lines is always the creature itself
+                    . fromMaybe mempty . tailMay)
+                . linesOfSight pos' (visionRadius creature')
+                <$> use entities
+        line <- choose $ weightedBy length lines
+        pure $ fromMaybe pos' $ fmap fst . headMay =<< line
+
+    vision = visionRadius creature
+    attackCharacter = do
+      say ["combat", "creatureAttack"] $ object [ "creature" A..= creature ]
+      character %= Character.damage 1
+
+newtype GormlakBrain entity = GormlakBrain { _unGormlakBrain :: entity }
+
+instance (IsCreature entity) => Brain (GormlakBrain entity) where
+  step ticks
+    = fmap (fmap GormlakBrain)
+    . stepGormlak ticks
+    . fmap _unGormlakBrain
+  entityCanMove = const True
+
+--------------------------------------------------------------------------------
+
+-- instance Brain Creature where
+--   step = brainVia GormlakBrain
+--   entityCanMove = const True
+
+-- instance Entity Creature where
+--   blocksVision _ = False
+--   description = view $ Creature.creatureType . Raw.description
+--   entityChar = view $ Creature.creatureType . char
diff --git a/users/glittershark/xanthous/src/Xanthous/App.hs b/users/glittershark/xanthous/src/Xanthous/App.hs
new file mode 100644
index 000000000000..672aa93f6b32
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/App.hs
@@ -0,0 +1,468 @@
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE RecordWildCards      #-}
+--------------------------------------------------------------------------------
+module Xanthous.App
+  ( makeApp
+  , RunType(..)
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+import           Brick hiding (App, halt, continue, raw)
+import qualified Brick
+import           Graphics.Vty.Attributes (defAttr)
+import           Graphics.Vty.Input.Events (Event(EvKey))
+import           Control.Monad.State (get, gets)
+import           Control.Monad.State.Class (modify)
+import           Data.Aeson (object, ToJSON)
+import qualified Data.Aeson as A
+import           Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.Vector as V
+import           System.Exit
+import           System.Directory (doesFileExist)
+--------------------------------------------------------------------------------
+import           Xanthous.App.Common
+import           Xanthous.App.Time
+import           Xanthous.App.Prompt
+import           Xanthous.App.Autocommands
+import           Xanthous.Command
+import           Xanthous.Data
+                 ( move
+                 , Dimensions'(Dimensions)
+                 , positioned
+                 , position
+                 , Position
+                 , (|*|)
+                 )
+import           Xanthous.Data.App (ResourceName, Panel(..), AppEvent(..))
+import qualified Xanthous.Data.EntityMap as EntityMap
+import           Xanthous.Data.Levels (prevLevel, nextLevel)
+import qualified Xanthous.Data.Levels as Levels
+import           Xanthous.Data.Entities (blocksObject)
+import           Xanthous.Game
+import           Xanthous.Game.State
+import           Xanthous.Game.Env
+import           Xanthous.Game.Draw (drawGame)
+import           Xanthous.Game.Prompt
+import qualified Xanthous.Messages as Messages
+import           Xanthous.Random
+import           Xanthous.Util (removeVectorIndex)
+import           Xanthous.Util.Inflection (toSentence)
+--------------------------------------------------------------------------------
+import qualified Xanthous.Entities.Character as Character
+import           Xanthous.Entities.Character hiding (pickUpItem)
+import           Xanthous.Entities.Item (Item)
+import qualified Xanthous.Entities.Item as Item
+import           Xanthous.Entities.Creature (Creature)
+import qualified Xanthous.Entities.Creature as Creature
+import           Xanthous.Entities.Environment
+                 (Door, open, closed, locked, GroundMessage(..), Staircase(..))
+import           Xanthous.Entities.RawTypes
+                 ( edible, eatMessage, hitpointsHealed
+                 , attackMessage
+                 )
+import           Xanthous.Generators
+import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
+import qualified Xanthous.Generators.Dungeon as Dungeon
+--------------------------------------------------------------------------------
+
+type App = Brick.App GameState AppEvent ResourceName
+
+data RunType = NewGame | LoadGame
+  deriving stock (Eq)
+
+makeApp :: GameEnv -> RunType -> IO App
+makeApp env rt = pure $ Brick.App
+  { appDraw = drawGame
+  , appChooseCursor = const headMay
+  , appHandleEvent = \game event -> runAppM (handleEvent event) env game
+  , appStartEvent = case rt of
+      NewGame -> runAppM (startEvent >> get) env
+      LoadGame -> pure
+  , appAttrMap = const $ attrMap defAttr []
+  }
+
+runAppM :: AppM a -> GameEnv -> GameState -> EventM ResourceName a
+runAppM appm ge = fmap fst . runAppT appm ge
+
+startEvent :: AppM ()
+startEvent = do
+  initLevel
+  modify updateCharacterVision
+  use (character . characterName) >>= \case
+    Nothing -> prompt_ @'StringPrompt ["character", "namePrompt"] Uncancellable
+      $ \(StringResult s) -> do
+        character . characterName ?= s
+        say ["welcome"] =<< use character
+    Just n -> say ["welcome"] $ object [ "characterName" A..= n ]
+
+initLevel :: AppM ()
+initLevel = do
+  level <- genLevel 0
+  entities <>= levelToEntityMap level
+  characterPosition .= level ^. levelCharacterPosition
+
+--------------------------------------------------------------------------------
+
+handleEvent :: BrickEvent ResourceName AppEvent -> AppM (Next GameState)
+handleEvent ev = use promptState >>= \case
+  NoPrompt -> handleNoPromptEvent ev
+  WaitingPrompt msg pr -> handlePromptEvent msg pr ev
+
+
+handleNoPromptEvent :: BrickEvent ResourceName AppEvent -> AppM (Next GameState)
+handleNoPromptEvent (VtyEvent (EvKey k mods))
+  | Just command <- commandFromKey k mods
+  = do messageHistory %= nextTurn
+       handleCommand command
+handleNoPromptEvent (AppEvent AutoContinue) = do
+  preuse (autocommand . _ActiveAutocommand . _1) >>= traverse_ autoStep
+  continue
+handleNoPromptEvent _ = continue
+
+handleCommand :: Command -> AppM (Next GameState)
+handleCommand Quit = confirm_ ["quit", "confirm"] (liftIO exitSuccess) >> continue
+handleCommand (Move dir) = do
+  newPos <- uses characterPosition $ move dir
+  collisionAt newPos >>= \case
+    Nothing -> do
+      characterPosition .= newPos
+      stepGameBy =<< uses (character . speed) (|*| 1)
+      describeEntitiesAt newPos
+    Just Combat -> attackAt newPos
+    Just Stop -> pure ()
+  continue
+
+handleCommand PickUp = do
+  pos <- use characterPosition
+  uses entities (entitiesAtPositionWithType @Item pos) >>= \case
+    [] -> say_ ["pickUp", "nothingToPickUp"]
+    [item] -> pickUpItem item
+    items' ->
+      menu_ ["pickUp", "menu"] Cancellable (entityMenu_ items')
+      $ \(MenuResult item) -> pickUpItem item
+  continue
+  where
+    pickUpItem (itemID, item) = do
+      character %= Character.pickUpItem item
+      entities . at itemID .= Nothing
+      say ["pickUp", "pickUp"] $ object [ "item" A..= item ]
+      stepGameBy 100 -- TODO
+
+handleCommand Drop = do
+  selectItemFromInventory_ ["drop", "menu"] Cancellable id
+    (say_ ["drop", "nothing"])
+    $ \(MenuResult item) -> do
+      entitiesAtCharacter %= (SomeEntity item <|)
+      say ["drop", "dropped"] $ object [ "item" A..= item ]
+  continue
+
+handleCommand PreviousMessage = do
+  messageHistory %= previousMessage
+  continue
+
+handleCommand Open = do
+  prompt_ @'DirectionPrompt ["open", "prompt"] Cancellable
+    $ \(DirectionResult dir) -> do
+      pos <- move dir <$> use characterPosition
+      doors <- uses entities $ entitiesAtPositionWithType @Door pos
+      if | null doors -> say_ ["open", "nothingToOpen"]
+         | any (view $ _2 . locked) doors -> say_ ["open", "locked"]
+         | all (view $ _2 . open) doors   -> say_ ["open", "alreadyOpen"]
+         | otherwise -> do
+             for_ doors $ \(eid, _) ->
+               entities . ix eid . positioned . _SomeEntity . open .= True
+             say_ ["open", "success"]
+      pure ()
+  stepGame -- TODO
+  continue
+
+handleCommand Close = do
+  prompt_ @'DirectionPrompt ["close", "prompt"] Cancellable
+    $ \(DirectionResult dir) -> do
+      pos <- move dir <$> use characterPosition
+      (nonDoors, doors) <- uses entities
+        $ partitionEithers
+        . toList
+        . map ( (matching . aside $ _SomeEntity @Door)
+              . over _2 (view positioned)
+              )
+        . EntityMap.atPositionWithIDs pos
+      if | null doors -> say_ ["close", "nothingToClose"]
+         | all (view $ _2 . closed) doors -> say_ ["close", "alreadyClosed"]
+         | any (view blocksObject . entityAttributes . snd) nonDoors ->
+           say ["close", "blocked"]
+           $ object [ "entityDescriptions"
+                      A..= ( toSentence
+                           . map description
+                           . filter (view blocksObject . entityAttributes)
+                           . map snd
+                           ) nonDoors
+                    , "blockOrBlocks"
+                      A..= ( if length nonDoors == 1
+                             then "blocks"
+                             else "block"
+                           :: Text)
+                    ]
+         | otherwise -> do
+             for_ doors $ \(eid, _) ->
+               entities . ix eid . positioned . _SomeEntity . closed .= True
+             for_ nonDoors $ \(eid, _) ->
+               entities . ix eid . position %= move dir
+             say_ ["close", "success"]
+      pure ()
+  stepGame -- TODO
+  continue
+
+handleCommand Look = do
+  prompt_ @'PointOnMap ["look", "prompt"] Cancellable
+    $ \(PointOnMapResult pos) ->
+      use (entities . EntityMap.atPosition pos)
+      >>= \case
+        Empty -> say_ ["look", "nothing"]
+        ents -> describeEntities ents
+  continue
+
+handleCommand Wait = stepGame >> continue
+
+handleCommand Eat = do
+  uses (character . inventory . backpack)
+       (V.mapMaybe (\item -> (item,) <$> item ^. Item.itemType . edible))
+    >>= \case
+      Empty -> say_ ["eat", "noFood"]
+      food ->
+        let foodMenuItem idx (item, edibleItem)
+              = ( item ^. Item.itemType . char . char
+                , MenuOption (description item) (idx, item, edibleItem))
+                -- TODO refactor to use entityMenu_
+            menuItems = mkMenuItems $ imap foodMenuItem food
+        in menu_ ["eat", "menuPrompt"] Cancellable menuItems
+          $ \(MenuResult (idx, item, edibleItem)) -> do
+            character . inventory . backpack %= removeVectorIndex idx
+            let msg = fromMaybe (Messages.lookup ["eat", "eat"])
+                      $ edibleItem ^. eatMessage
+            character . characterHitpoints' +=
+              edibleItem ^. hitpointsHealed . to fromIntegral
+            message msg $ object ["item" A..= item]
+            stepGame -- TODO
+  continue
+
+handleCommand Read = do
+  -- TODO allow reading things in the inventory (combo direction+menu prompt?)
+  prompt_ @'DirectionPrompt ["read", "prompt"] Cancellable
+    $ \(DirectionResult dir) -> do
+      pos <- uses characterPosition $ move dir
+      uses entities
+        (fmap snd . entitiesAtPositionWithType @GroundMessage pos) >>= \case
+          Empty -> say_ ["read", "nothing"]
+          GroundMessage msg :< Empty ->
+            say ["read", "result"] $ object ["message" A..= msg]
+          msgs ->
+            let readAndContinue Empty = pure ()
+                readAndContinue (msg :< msgs') =
+                  prompt @'Continue
+                    ["read", "result"]
+                    (object ["message" A..= msg])
+                    Cancellable
+                  . const
+                  $ readAndContinue msgs'
+                readAndContinue _ = error "this is total"
+            in readAndContinue msgs
+  continue
+
+handleCommand ShowInventory = showPanel InventoryPanel >> continue
+
+handleCommand Wield = do
+  selectItemFromInventory_ ["wield", "menu"] Cancellable asWieldedItem
+    (say_ ["wield", "nothing"])
+    $ \(MenuResult item) -> do
+      prevItems <- character . inventory . wielded <<.= inRightHand item
+      character . inventory . backpack
+        <>= fromList (prevItems ^.. wieldedItems . wieldedItem)
+      say ["wield", "wielded"] item
+  continue
+
+handleCommand Save = do
+  -- TODO default save locations / config file?
+  prompt_ @'StringPrompt ["save", "location"] Cancellable
+    $ \(StringResult filename) -> do
+       exists <- liftIO . doesFileExist $ unpack filename
+       if exists
+       then confirm ["save", "overwrite"] (object ["filename" A..= filename])
+            $ doSave filename
+       else doSave filename
+  continue
+  where
+    doSave filename = do
+      src <- gets saveGame
+      lift . liftIO $ do
+        writeFile (unpack filename) $ toStrict src
+        exitSuccess
+
+handleCommand GoUp = do
+  hasStairs <- uses entitiesAtCharacter $ elem (SomeEntity UpStaircase)
+  if hasStairs
+  then uses levels prevLevel >>= \case
+    Just levs' -> levels .= levs'
+    Nothing ->
+      -- TODO in nethack, this leaves the game. Maybe something similar here?
+      say_ ["cant", "goUp"]
+  else say_ ["cant", "goUp"]
+
+  continue
+
+handleCommand GoDown = do
+  hasStairs <- uses entitiesAtCharacter $ elem (SomeEntity DownStaircase)
+
+  if hasStairs
+  then do
+    levs <- use levels
+    let newLevelNum = Levels.pos levs + 1
+    levs' <- nextLevel (levelToGameLevel <$> genLevel newLevelNum) levs
+    cEID <- use characterEntityID
+    pCharacter <- entities . at cEID <<.= Nothing
+    levels .= levs'
+    entities . at cEID .= pCharacter
+    characterPosition .= extract levs' ^. upStaircasePosition
+  else say_ ["cant", "goDown"]
+
+  continue
+
+handleCommand (StartAutoMove dir) = do
+  runAutocommand $ AutoMove dir
+  continue
+
+--
+
+handleCommand ToggleRevealAll = do
+  val <- debugState . allRevealed <%= not
+  say ["debug", "toggleRevealAll"] $ object [ "revealAll" A..= val ]
+  continue
+
+--------------------------------------------------------------------------------
+attackAt :: Position -> AppM ()
+attackAt pos =
+  uses entities (entitiesAtPositionWithType @Creature pos) >>= \case
+    Empty               -> say_ ["combat", "nothingToAttack"]
+    (creature :< Empty) -> attackCreature creature
+    creatures ->
+      menu_ ["combat", "menu"] Cancellable (entityMenu_ creatures)
+      $ \(MenuResult creature) -> attackCreature creature
+ where
+  attackCreature (creatureID, creature) = do
+    charDamage <- uses character characterDamage
+    let creature' = Creature.damage charDamage creature
+        msgParams = object ["creature" A..= creature']
+    if Creature.isDead creature'
+      then do
+        say ["combat", "killed"] msgParams
+        entities . at creatureID .= Nothing
+      else do
+        msg <- uses character getAttackMessage
+        message msg msgParams
+        entities . ix creatureID . positioned .= SomeEntity creature'
+
+    whenM (uses character $ isNothing . weapon)
+      $ whenM (chance (0.08 :: Float)) $ do
+        say_ ["combat", "fistSelfDamage"]
+        character %= Character.damage 1
+
+    stepGame -- TODO
+  weapon chr = chr ^? inventory . wielded . wieldedItems . wieldableItem
+  getAttackMessage chr =
+    case weapon chr of
+      Just wi ->
+        fromMaybe (Messages.lookup ["combat", "hit", "generic"])
+        $ wi ^. attackMessage
+      Nothing ->
+        Messages.lookup ["combat", "hit", "fists"]
+
+entityMenu_
+  :: (Comonad w, Entity entity)
+  => [w entity]
+  -> Map Char (MenuOption (w entity))
+entityMenu_ = mkMenuItems @[_] . map entityMenuItem
+  where
+    entityMenuItem wentity
+      = let entity = extract wentity
+      in (entityMenuChar entity, MenuOption (description entity) wentity)
+
+
+entityMenuChar :: Entity a => a -> Char
+entityMenuChar entity
+  = let ec = entityChar entity ^. char
+    in if ec `elem` (['a'..'z'] ++ ['A'..'Z'])
+        then ec
+        else 'a'
+
+-- | Prompt with an item to select out of the inventory, remove it from the
+-- inventory, and call callback with it
+selectItemFromInventory
+  :: forall item params.
+    (ToJSON params)
+  => [Text]            -- ^ Menu message
+  -> params            -- ^ Menu message params
+  -> PromptCancellable -- ^ Is the menu cancellable?
+  -> Prism' Item item  -- ^ Attach some extra information to the item, in a
+                      --   recoverable fashion. Prism vs iso so we can discard
+                      --   items.
+  -> AppM ()            -- ^ Action to take if there are no items matching
+  -> (PromptResult ('Menu item) -> AppM ())
+  -> AppM ()
+selectItemFromInventory msgPath msgParams cancellable extraInfo onEmpty cb =
+  uses (character . inventory . backpack)
+       (V.mapMaybe $ preview extraInfo)
+    >>= \case
+      Empty -> onEmpty
+      items' ->
+        menu msgPath msgParams cancellable (itemMenu items')
+        $ \(MenuResult (idx, item)) -> do
+          character . inventory . backpack %= removeVectorIndex idx
+          cb $ MenuResult item
+  where
+    itemMenu = mkMenuItems . imap itemMenuItem
+    itemMenuItem idx extraInfoItem =
+      let item = extraInfo # extraInfoItem
+      in ( entityMenuChar item
+         , MenuOption (description item) (idx, extraInfoItem))
+
+selectItemFromInventory_
+  :: forall item.
+    [Text]            -- ^ Menu message
+  -> PromptCancellable -- ^ Is the menu cancellable?
+  -> Prism' Item item  -- ^ Attach some extra information to the item, in a
+                      --   recoverable fashion. Prism vs iso so we can discard
+                      --   items.
+  -> AppM ()            -- ^ Action to take if there are no items matching
+  -> (PromptResult ('Menu item) -> AppM ())
+  -> AppM ()
+selectItemFromInventory_ msgPath = selectItemFromInventory msgPath ()
+
+-- entityMenu :: Entity entity => [entity] -> Map Char (MenuOption entity)
+-- entityMenu = map (map runIdentity) . entityMenu_ . fmap Identity
+
+showPanel :: Panel -> AppM ()
+showPanel panel = do
+  activePanel ?= panel
+  prompt_ @'Continue ["generic", "continue"] Uncancellable
+    . const
+    $ activePanel .= Nothing
+
+--------------------------------------------------------------------------------
+
+genLevel
+  :: Int -- ^ level number
+  -> AppM Level
+genLevel _num = do
+  let dims = Dimensions 80 80
+  generator <- choose $ CaveAutomata :| [Dungeon]
+  level <- case generator of
+    CaveAutomata -> generateLevel SCaveAutomata CaveAutomata.defaultParams dims
+    Dungeon -> generateLevel SDungeon Dungeon.defaultParams dims
+  pure $!! level
+
+levelToGameLevel :: Level -> GameLevel
+levelToGameLevel level =
+  let _levelEntities = levelToEntityMap level
+      _upStaircasePosition = level ^. levelCharacterPosition
+      _levelRevealedPositions = mempty
+  in GameLevel {..}
diff --git a/users/glittershark/xanthous/src/Xanthous/App/Autocommands.hs b/users/glittershark/xanthous/src/Xanthous/App/Autocommands.hs
new file mode 100644
index 000000000000..35b92bba7289
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/App/Autocommands.hs
@@ -0,0 +1,65 @@
+--------------------------------------------------------------------------------
+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)
+import           Xanthous.Entities.Creature (Creature, creatureType)
+import           Xanthous.Entities.RawTypes (hostile)
+import           Xanthous.Game.State
+import           Xanthous.Game.Lenses (characterVisibleEntities)
+--------------------------------------------------------------------------------
+
+autoStep :: Autocommand -> AppM ()
+autoStep (AutoMove dir) = do
+  newPos <- uses characterPosition $ move dir
+  collisionAt newPos >>= \case
+    Nothing -> do
+      characterPosition .= newPos
+      stepGameBy =<< uses (character . speed) (|*| 1)
+      describeEntitiesAt newPos
+      maybeVisibleEnemies <- nonEmpty <$> enemiesInSight
+      for_ maybeVisibleEnemies $ \visibleEnemies -> do
+        say ["autoMove", "enemyInSight"]
+          $ object [ "firstEntity" A..= NE.head visibleEnemies ]
+        cancelAutocommand
+    Just _ -> 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/glittershark/xanthous/src/Xanthous/App/Common.hs b/users/glittershark/xanthous/src/Xanthous/App/Common.hs
new file mode 100644
index 000000000000..69ba6f0e0596
--- /dev/null
+++ b/users/glittershark/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/glittershark/xanthous/src/Xanthous/App/Prompt.hs b/users/glittershark/xanthous/src/Xanthous/App/Prompt.hs
new file mode 100644
index 000000000000..6704a601da90
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/App/Prompt.hs
@@ -0,0 +1,161 @@
+{-# LANGUAGE UndecidableInstances #-}
+--------------------------------------------------------------------------------
+module Xanthous.App.Prompt
+  ( handlePromptEvent
+  , clearPrompt
+  , prompt
+  , prompt_
+  , confirm_
+  , confirm
+  , menu
+  , menu_
+  ) 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           GHC.TypeLits (TypeError, ErrorMessage(..))
+--------------------------------------------------------------------------------
+import           Xanthous.App.Common
+import           Xanthous.Data (move)
+import           Xanthous.Command (directionFromChar)
+import           Xanthous.Data.App (ResourceName, AppEvent)
+import           Xanthous.Game.Prompt
+import           Xanthous.Game.State
+import qualified Xanthous.Messages as Messages
+--------------------------------------------------------------------------------
+
+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
+  _
+  (Prompt Cancellable _ _ _ _)
+  (VtyEvent (EvKey (KChar 'q') []))
+  = clearPrompt >> continue
+handlePromptEvent _ _ _ = continue
+
+clearPrompt :: AppM ()
+clearPrompt = promptState .= NoPrompt
+
+class NotMenu (pt :: PromptType)
+instance NotMenu 'StringPrompt
+instance NotMenu 'Confirm
+instance NotMenu 'DirectionPrompt
+instance NotMenu 'PointOnMap
+instance NotMenu 'Continue
+instance TypeError ('Text "Cannot use `prompt` or `prompt_` for menu prompts"
+                    ':$$: 'Text "Use `menu` or `menu_` instead")
+         => NotMenu ('Menu a)
+
+prompt
+  :: forall (pt :: PromptType) (params :: Type).
+    (ToJSON params, SingPromptType pt, NotMenu 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
+  p <- case pt of
+    SPointOnMap -> do
+      charPos <- use characterPosition
+      pure $ mkPointOnMapPrompt cancellable charPos cb
+    SStringPrompt -> pure $ mkPrompt cancellable pt cb
+    SConfirm -> pure $ mkPrompt cancellable pt cb
+    SDirectionPrompt -> pure $ mkPrompt cancellable pt cb
+    SContinue -> pure $ mkPrompt cancellable pt cb
+    SMenu -> error "unreachable"
+  promptState .= WaitingPrompt msg p
+
+prompt_
+  :: forall (pt :: PromptType).
+    (SingPromptType pt, NotMenu pt)
+  => [Text] -- ^ Message key
+  -> PromptCancellable
+  -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler
+  -> AppM ()
+prompt_ msg = prompt 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 []
diff --git a/users/glittershark/xanthous/src/Xanthous/App/Time.hs b/users/glittershark/xanthous/src/Xanthous/App/Time.hs
new file mode 100644
index 000000000000..b17348f3853e
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/App/Time.hs
@@ -0,0 +1,40 @@
+--------------------------------------------------------------------------------
+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)
+--------------------------------------------------------------------------------
+
+
+stepGameBy :: Ticks -> AppM ()
+stepGameBy ticks = do
+  ents <- uses entities EntityMap.toEIDsAndPositioned
+  for_ ents $ \(eid, pEntity) -> do
+    pEntity' <- step ticks pEntity
+    entities . ix eid .= pEntity'
+
+  modify updateCharacterVision
+
+  whenM (uses character isDead)
+    . prompt_ @'Continue ["dead"] Uncancellable
+    . const . lift . liftIO
+    $ exitSuccess
+
+ticksPerTurn :: Ticks
+ticksPerTurn = 100
+
+stepGame :: AppM ()
+stepGame = stepGameBy ticksPerTurn
diff --git a/users/glittershark/xanthous/src/Xanthous/Command.hs b/users/glittershark/xanthous/src/Xanthous/Command.hs
new file mode 100644
index 000000000000..37025dd37ad2
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Command.hs
@@ -0,0 +1,73 @@
+--------------------------------------------------------------------------------
+module Xanthous.Command where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude hiding (Left, Right, Down)
+--------------------------------------------------------------------------------
+import Graphics.Vty.Input (Key(..), Modifier(..))
+import qualified Data.Char as Char
+--------------------------------------------------------------------------------
+import Xanthous.Data (Direction(..))
+--------------------------------------------------------------------------------
+
+data Command
+  = Quit
+  | Move Direction
+  | StartAutoMove Direction
+  | PreviousMessage
+  | PickUp
+  | Drop
+  | Open
+  | Close
+  | Wait
+  | Eat
+  | Look
+  | Save
+  | Read
+  | ShowInventory
+  | Wield
+  | GoUp
+  | GoDown
+
+    -- | TODO replace with `:` commands
+  | ToggleRevealAll
+
+commandFromKey :: Key -> [Modifier] -> Maybe Command
+commandFromKey (KChar 'q') [] = Just Quit
+commandFromKey (KChar '.') [] = Just Wait
+commandFromKey (KChar (directionFromChar -> Just dir)) [] = Just $ Move dir
+commandFromKey (KChar c) []
+  | Char.isUpper c
+  , Just dir <- directionFromChar $ Char.toLower c
+  = Just $ StartAutoMove dir
+commandFromKey (KChar 'p') [MCtrl] = Just PreviousMessage
+commandFromKey (KChar ',') [] = Just PickUp
+commandFromKey (KChar 'd') [] = Just Drop
+commandFromKey (KChar 'o') [] = Just Open
+commandFromKey (KChar 'c') [] = Just Close
+commandFromKey (KChar ';') [] = Just Look
+commandFromKey (KChar 'e') [] = Just Eat
+commandFromKey (KChar 'S') [] = Just Save
+commandFromKey (KChar 'r') [] = Just Read
+commandFromKey (KChar 'i') [] = Just ShowInventory
+commandFromKey (KChar 'w') [] = Just Wield
+commandFromKey (KChar '<') [] = Just GoUp
+commandFromKey (KChar '>') [] = Just GoDown
+
+-- DEBUG COMMANDS --
+commandFromKey (KChar 'r') [MMeta] = Just ToggleRevealAll
+
+commandFromKey _ _ = Nothing
+
+--------------------------------------------------------------------------------
+
+directionFromChar :: Char -> Maybe Direction
+directionFromChar 'h' = Just Left
+directionFromChar 'j' = Just Down
+directionFromChar 'k' = Just Up
+directionFromChar 'l' = Just Right
+directionFromChar 'y' = Just UpLeft
+directionFromChar 'u' = Just UpRight
+directionFromChar 'b' = Just DownLeft
+directionFromChar 'n' = Just DownRight
+directionFromChar '.' = Just Here
+directionFromChar _   = Nothing
diff --git a/users/glittershark/xanthous/src/Xanthous/Data.hs b/users/glittershark/xanthous/src/Xanthous/Data.hs
new file mode 100644
index 000000000000..3cb74bdca9fd
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Data.hs
@@ -0,0 +1,571 @@
+{-# LANGUAGE PartialTypeSignatures  #-}
+{-# LANGUAGE StandaloneDeriving     #-}
+{-# LANGUAGE RoleAnnotations        #-}
+{-# LANGUAGE RecordWildCards        #-}
+{-# LANGUAGE DeriveTraversable      #-}
+{-# LANGUAGE DeriveFoldable         #-}
+{-# LANGUAGE DeriveFunctor          #-}
+{-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE NoTypeSynonymInstances #-}
+{-# LANGUAGE DuplicateRecordFields  #-}
+--------------------------------------------------------------------------------
+-- | Common data types for Xanthous
+--------------------------------------------------------------------------------
+module Xanthous.Data
+  ( Opposite(..)
+
+    -- *
+  , Position'(..)
+  , Position
+  , x
+  , y
+
+    -- **
+  , Positioned(..)
+  , _Positioned
+  , position
+  , positioned
+  , loc
+  , _Position
+  , positionFromPair
+  , addPositions
+  , diffPositions
+  , stepTowards
+  , isUnit
+
+    -- * Boxes
+  , Box(..)
+  , topLeftCorner
+  , bottomRightCorner
+  , setBottomRightCorner
+  , dimensions
+  , inBox
+  , boxIntersects
+  , boxCenter
+  , boxEdge
+  , module Linear.V2
+
+    -- *
+  , Per(..)
+  , invertRate
+  , invertedRate
+  , (|*|)
+  , Ticks(..)
+  , Tiles(..)
+  , TicksPerTile
+  , TilesPerTick
+  , timesTiles
+
+    -- *
+  , Dimensions'(..)
+  , Dimensions
+  , HasWidth(..)
+  , HasHeight(..)
+
+    -- *
+  , Direction(..)
+  , move
+  , asPosition
+  , directionOf
+  , Cardinal(..)
+
+    -- *
+  , Corner(..)
+  , Edge(..)
+  , cornerEdges
+
+    -- *
+  , Neighbors(..)
+  , edges
+  , neighborDirections
+  , neighborPositions
+  , arrayNeighbors
+  , rotations
+
+    -- *
+  , Hitpoints(..)
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding (Left, Down, Right, (.=), elements)
+--------------------------------------------------------------------------------
+import           Linear.V2 hiding (_x, _y)
+import qualified Linear.V2 as L
+import           Linear.V4 hiding (_x, _y)
+import           Test.QuickCheck (Arbitrary, CoArbitrary, Function, elements)
+import           Test.QuickCheck.Arbitrary.Generic
+import           Data.Group
+import           Brick (Location(Location), Edges(..))
+import           Data.Monoid (Product(..), Sum(..))
+import           Data.Array.IArray
+import           Data.Aeson.Generic.DerivingVia
+import           Data.Aeson
+                 ( ToJSON(..), FromJSON(..), object, (.=), (.:), withObject)
+--------------------------------------------------------------------------------
+import           Xanthous.Util (EqEqProp(..), EqProp, between)
+import           Xanthous.Util.QuickCheck (GenericArbitrary(..))
+import           Xanthous.Orphans ()
+import           Xanthous.Util.Graphics
+--------------------------------------------------------------------------------
+
+-- | opposite ∘ opposite ≡ id
+class Opposite x where
+  opposite :: x -> x
+
+--------------------------------------------------------------------------------
+
+-- fromScalar ∘ scalar ≡ id
+class Scalar a where
+  scalar :: a -> Double
+  fromScalar :: Double -> a
+
+instance Scalar Double where
+  scalar = id
+  fromScalar = id
+
+newtype ScalarIntegral a = ScalarIntegral a
+  deriving newtype (Eq, Ord, Num, Enum, Real, Integral)
+instance Integral a => Scalar (ScalarIntegral a) where
+  scalar = fromIntegral
+  fromScalar = floor
+
+deriving via (ScalarIntegral Integer) instance Scalar Integer
+deriving via (ScalarIntegral Word) instance Scalar Word
+
+--------------------------------------------------------------------------------
+
+data Position' a where
+  Position :: { _x :: a
+             , _y :: a
+             } -> (Position' a)
+  deriving stock (Show, Eq, Generic, Ord, Functor, Foldable, Traversable)
+  deriving anyclass (NFData, Hashable, CoArbitrary, Function)
+  deriving EqProp via EqEqProp (Position' a)
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       (Position' a)
+
+x, y :: Lens' (Position' a) a
+x = lens (\(Position xx _) -> xx) (\(Position _ yy) xx -> Position xx yy)
+y = lens (\(Position _ yy) -> yy) (\(Position xx _) yy -> Position xx yy)
+
+type Position = Position' Int
+
+instance Arbitrary a => Arbitrary (Position' a) where
+  arbitrary = genericArbitrary
+  shrink (Position px py) = Position <$> shrink px <*> shrink py
+
+
+instance Num a => Semigroup (Position' a) where
+  (Position x₁ y₁) <> (Position x₂ y₂) = Position (x₁ + x₂) (y₁ + y₂)
+
+instance Num a => Monoid (Position' a) where
+  mempty = Position 0 0
+
+instance Num a => Group (Position' a) where
+  invert (Position px py) = Position (negate px) (negate py)
+
+-- | Positions convert to scalars by discarding their orientation and just
+-- measuring the length from the origin
+instance (Ord a, Num a, Scalar a) => Scalar (Position' a) where
+  scalar = fromIntegral . length . line (0, 0) . view _Position
+  fromScalar n = Position (fromScalar n) (fromScalar n)
+
+data Positioned a where
+  Positioned :: Position -> a -> Positioned a
+  deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+type role Positioned representational
+
+_Positioned :: Iso (Position, a) (Position, b) (Positioned a) (Positioned b)
+_Positioned = iso hither yon
+  where
+    hither (pos, a) = Positioned pos a
+    yon (Positioned pos b) = (pos, b)
+
+instance Arbitrary a => Arbitrary (Positioned a) where
+  arbitrary = Positioned <$> arbitrary <*> arbitrary
+
+instance ToJSON a => ToJSON (Positioned a) where
+  toJSON (Positioned pos val) = object
+    [ "position" .= pos
+    , "data" .= val
+    ]
+
+instance FromJSON a => FromJSON (Positioned a) where
+  parseJSON = withObject "Positioned" $ \obj ->
+    Positioned <$> obj .: "position" <*> obj .: "data"
+
+position :: Lens' (Positioned a) Position
+position = lens
+  (\(Positioned pos _) -> pos)
+  (\(Positioned _ a) pos -> Positioned pos a)
+
+positioned :: Lens (Positioned a) (Positioned b) a b
+positioned = lens
+  (\(Positioned _ x') -> x')
+  (\(Positioned pos _) x' -> Positioned pos x')
+
+loc :: Iso' Position Location
+loc = iso hither yon
+  where
+    hither (Position px py) = Location (px, py)
+    yon (Location (lx, ly)) = Position lx ly
+
+_Position :: Iso' (Position' a) (a, a)
+_Position = iso hither yon
+  where
+    hither (Position px py) = (px, py)
+    yon (lx, ly) = Position lx ly
+
+positionFromPair :: (Num a, Integral i, Integral j) => (i, j) -> Position' a
+positionFromPair (i, j) = Position (fromIntegral i) (fromIntegral j)
+
+-- | Add two positions
+--
+-- Operation for the additive group on positions
+addPositions :: Num a => Position' a -> Position' a -> Position' a
+addPositions = (<>)
+
+-- | Subtract two positions.
+--
+-- diffPositions pos₁ pos₂ = pos₁ `addPositions` (invert pos₂)
+diffPositions :: Num a => Position' a -> Position' a -> Position' a
+diffPositions (Position x₁ y₁) (Position x₂ y₂) = Position (x₁ - x₂) (y₁ - y₂)
+
+-- | Is this position a unit position? or: When taken as a difference, does this
+-- position represent a step of one tile?
+--
+-- ∀ dir :: Direction. isUnit ('asPosition' dir)
+isUnit :: (Eq a, Num a) => Position' a -> Bool
+isUnit (Position px py) =
+  abs px `elem` [0,1] && abs py `elem` [0, 1] && (px, py) /= (0, 0)
+
+--------------------------------------------------------------------------------
+
+data Dimensions' a = Dimensions
+  { _width :: a
+  , _height :: a
+  }
+  deriving stock (Show, Eq, Functor, Generic)
+  deriving anyclass (CoArbitrary, Function)
+makeFieldsNoPrefix ''Dimensions'
+
+instance Arbitrary a => Arbitrary (Dimensions' a) where
+  arbitrary = Dimensions <$> arbitrary <*> arbitrary
+
+type Dimensions = Dimensions' Word
+
+--------------------------------------------------------------------------------
+
+data Direction where
+  Up        :: Direction
+  Down      :: Direction
+  Left      :: Direction
+  Right     :: Direction
+  UpLeft    :: Direction
+  UpRight   :: Direction
+  DownLeft  :: Direction
+  DownRight :: Direction
+  Here      :: Direction
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (CoArbitrary, Function, NFData, ToJSON, FromJSON, Hashable)
+  deriving Arbitrary via GenericArbitrary Direction
+
+instance Opposite Direction where
+  opposite Up        = Down
+  opposite Down      = Up
+  opposite Left      = Right
+  opposite Right     = Left
+  opposite UpLeft    = DownRight
+  opposite UpRight   = DownLeft
+  opposite DownLeft  = UpRight
+  opposite DownRight = UpLeft
+  opposite Here      = Here
+
+move :: Num a => Direction -> Position' a -> Position' a
+move Up        = y -~ 1
+move Down      = y +~ 1
+move Left      = x -~ 1
+move Right     = x +~ 1
+move UpLeft    = move Up . move Left
+move UpRight   = move Up . move Right
+move DownLeft  = move Down . move Left
+move DownRight = move Down . move Right
+move Here      = id
+
+asPosition :: Direction -> Position
+asPosition dir = move dir mempty
+
+-- | Returns the direction that a given position is from a given source position
+directionOf
+  :: Position -- ^ Source
+  -> Position -- ^ Target
+  -> Direction
+directionOf (Position x₁ y₁) (Position x₂ y₂) =
+  case (x₁ `compare` x₂, y₁ `compare` y₂) of
+    (EQ, EQ) -> Here
+    (EQ, LT) -> Down
+    (EQ, GT) -> Up
+    (LT, EQ) -> Right
+    (GT, EQ) -> Left
+
+    (LT, LT) -> DownRight
+    (GT, LT) -> DownLeft
+
+    (LT, GT) -> UpRight
+    (GT, GT) -> UpLeft
+
+-- | Take one (potentially diagonal) step towards the given position
+--
+-- ∀ src tgt. isUnit (src `diffPositions` (src `stepTowards tgt`))
+stepTowards
+  :: Position -- ^ Source
+  -> Position -- ^ Target
+  -> Position
+stepTowards (view _Position -> p₁) (view _Position -> p₂)
+  | p₁ == p₂ = _Position # p₁
+  | otherwise =
+    let (_:p:_) = line p₁ p₂
+    in _Position # p
+
+-- | Newtype controlling arbitrary generation to only include cardinal
+-- directions ('Up', 'Down', 'Left', 'Right')
+newtype Cardinal = Cardinal { getCardinal :: Direction }
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, Function, CoArbitrary)
+  deriving newtype (Opposite)
+
+instance Arbitrary Cardinal where
+  arbitrary = Cardinal <$> elements [Up, Down, Left, Right]
+
+--------------------------------------------------------------------------------
+
+data Corner
+  = TopLeft
+  | TopRight
+  | BottomLeft
+  | BottomRight
+  deriving stock (Show, Eq, Ord, Enum, Bounded, Generic)
+  deriving Arbitrary via GenericArbitrary Corner
+
+instance Opposite Corner where
+  opposite TopLeft = BottomRight
+  opposite TopRight = BottomLeft
+  opposite BottomLeft = TopRight
+  opposite BottomRight = TopLeft
+
+data Edge
+  = TopEdge
+  | LeftEdge
+  | RightEdge
+  | BottomEdge
+  deriving stock (Show, Eq, Ord, Enum, Bounded, Generic)
+  deriving Arbitrary via GenericArbitrary Edge
+
+instance Opposite Edge where
+  opposite TopEdge = BottomEdge
+  opposite BottomEdge = TopEdge
+  opposite LeftEdge = RightEdge
+  opposite RightEdge = LeftEdge
+
+cornerEdges :: Corner -> (Edge, Edge)
+cornerEdges TopLeft = (TopEdge, LeftEdge)
+cornerEdges TopRight = (TopEdge, RightEdge)
+cornerEdges BottomLeft = (BottomEdge, LeftEdge)
+cornerEdges BottomRight = (BottomEdge, RightEdge)
+
+--------------------------------------------------------------------------------
+
+data Neighbors a = Neighbors
+  { _topLeft
+  , _top
+  , _topRight
+  , _left
+  , _right
+  , _bottomLeft
+  , _bottom
+  , _bottomRight :: a
+  }
+  deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary (Neighbors a)
+makeFieldsNoPrefix ''Neighbors
+
+instance Applicative Neighbors where
+  pure α = Neighbors
+    { _topLeft     = α
+    , _top         = α
+    , _topRight    = α
+    , _left        = α
+    , _right       = α
+    , _bottomLeft  = α
+    , _bottom      = α
+    , _bottomRight = α
+    }
+  nf <*> nx = Neighbors
+    { _topLeft     = nf ^. topLeft     $ nx ^. topLeft
+    , _top         = nf ^. top         $ nx ^. top
+    , _topRight    = nf ^. topRight    $ nx ^. topRight
+    , _left        = nf ^. left        $ nx ^. left
+    , _right       = nf ^. right       $ nx ^. right
+    , _bottomLeft  = nf ^. bottomLeft  $ nx ^. bottomLeft
+    , _bottom      = nf ^. bottom      $ nx ^. bottom
+    , _bottomRight = nf ^. bottomRight $ nx ^. bottomRight
+    }
+
+edges :: Neighbors a -> Edges a
+edges neighs = Edges
+  { eTop = neighs ^. top
+  , eBottom = neighs ^. bottom
+  , eLeft = neighs ^. left
+  , eRight = neighs ^. right
+  }
+
+neighborDirections :: Neighbors Direction
+neighborDirections = Neighbors
+  { _topLeft     = UpLeft
+  , _top         = Up
+  , _topRight    = UpRight
+  , _left        = Left
+  , _right       = Right
+  , _bottomLeft  = DownLeft
+  , _bottom      = Down
+  , _bottomRight = DownRight
+  }
+
+neighborPositions :: Num a => Position' a -> Neighbors (Position' a)
+neighborPositions pos = (`move` pos) <$> neighborDirections
+
+arrayNeighbors
+  :: (IArray a e, Ix i, Num i)
+  => a (i, i) e
+  -> (i, i)
+  -> Neighbors (Maybe e)
+arrayNeighbors arr center = arrLookup <$> neighborPositions (_Position # center)
+  where
+    arrLookup (view _Position -> pos)
+      | inRange (bounds arr) pos = Just $ arr ! pos
+      | otherwise                = Nothing
+
+-- | Returns a list of all 4 90-degree rotations of the given neighbors
+rotations :: Neighbors a -> V4 (Neighbors a)
+rotations orig@(Neighbors tl t tr l r bl b br) = V4
+   orig                            -- tl t  tr
+                                   -- l     r
+                                   -- bl b  br
+
+   (Neighbors bl l tl b t br r tr) -- bl l tl
+                                   -- b    t
+                                   -- br r tr
+
+   (Neighbors br b bl r l tr t tl) -- br b bl
+                                   -- r    l
+                                   -- tr t tl
+
+   (Neighbors tr r br t b tl l bl) -- tr r br
+                                   -- t    b
+                                   -- tl l bl
+
+--------------------------------------------------------------------------------
+
+newtype Per a b = Rate Double
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON) via Double
+  deriving (Semigroup, Monoid) via Product Double
+instance Arbitrary (Per a b) where arbitrary = genericArbitrary
+
+invertRate :: a `Per` b -> b `Per` a
+invertRate (Rate p) = Rate $ 1 / p
+
+invertedRate :: Iso (a `Per` b) (b' `Per` a') (b `Per` a) (a' `Per` b')
+invertedRate = iso invertRate invertRate
+
+infixl 7 |*|
+(|*|) :: (Scalar a, Scalar b) => a `Per` b -> b -> a
+(|*|) (Rate rate) b = fromScalar $ rate * scalar b
+
+newtype Ticks = Ticks Word
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (Num, Ord, Bounded, Enum, Integral, Real, ToJSON, FromJSON) via Word
+  deriving (Semigroup, Monoid) via (Sum Word)
+  deriving Scalar via ScalarIntegral Ticks
+instance Arbitrary Ticks where arbitrary = genericArbitrary
+
+newtype Tiles = Tiles Double
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (Num, Ord, Enum, Real, ToJSON, FromJSON, Scalar) via Double
+  deriving (Semigroup, Monoid) via (Sum Double)
+instance Arbitrary Tiles where arbitrary = genericArbitrary
+
+type TicksPerTile = Ticks `Per` Tiles
+type TilesPerTick = Tiles `Per` Ticks
+
+timesTiles :: TicksPerTile -> Tiles -> Ticks
+timesTiles = (|*|)
+
+--------------------------------------------------------------------------------
+
+newtype Hitpoints = Hitpoints Word
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (Arbitrary, Num, Ord, Bounded, Enum, Integral, Real, ToJSON, FromJSON)
+       via Word
+  deriving (Semigroup, Monoid) via Sum Word
+
+--------------------------------------------------------------------------------
+
+data Box a = Box
+  { _topLeftCorner :: V2 a
+  , _dimensions    :: V2 a
+  }
+  deriving stock (Show, Eq, Ord, Functor, Generic)
+  deriving Arbitrary via GenericArbitrary (Box a)
+makeFieldsNoPrefix ''Box
+
+bottomRightCorner :: Num a => Box a -> V2 a
+bottomRightCorner box =
+  V2 (box ^. topLeftCorner . L._x + box ^. dimensions . L._x)
+     (box ^. topLeftCorner . L._y + box ^. dimensions . L._y)
+
+setBottomRightCorner :: (Num a, Ord a) => Box a -> V2 a -> Box a
+setBottomRightCorner box br@(V2 brx bry)
+  | brx < box ^. topLeftCorner . L._x || bry < box ^. topLeftCorner . L._y
+  = box & topLeftCorner .~ br
+        & dimensions . L._x .~ ((box ^. topLeftCorner . L._x) - brx)
+        & dimensions . L._y .~ ((box ^. topLeftCorner . L._y) - bry)
+  | otherwise
+  = box & dimensions . L._x .~ (brx - (box ^. topLeftCorner . L._x))
+        & dimensions . L._y .~ (bry - (box ^. topLeftCorner . L._y))
+
+inBox :: (Ord a, Num a) => Box a -> V2 a -> Bool
+inBox box pt = flip all [L._x, L._y] $ \component ->
+  between (box ^. topLeftCorner . component)
+          (box ^. to bottomRightCorner . component)
+          (pt ^. component)
+
+boxIntersects :: (Ord a, Num a) => Box a -> Box a -> Bool
+boxIntersects box₁ box₂
+  = any (inBox box₁) [box₂ ^. topLeftCorner, bottomRightCorner box₂]
+
+boxCenter :: (Fractional a) => Box a -> V2 a
+boxCenter box = V2 cx cy
+ where
+   cx = box ^. topLeftCorner . L._x + (box ^. dimensions . L._x / 2)
+   cy = box ^. topLeftCorner . L._y + (box ^. dimensions . L._y / 2)
+
+boxEdge :: (Enum a, Num a) => Box a -> Edge -> [V2 a]
+boxEdge box LeftEdge =
+  V2 (box ^. topLeftCorner . L._x)
+  <$> [box ^. topLeftCorner . L._y .. box ^. to bottomRightCorner . L._y]
+boxEdge box RightEdge =
+  V2 (box ^. to bottomRightCorner . L._x)
+  <$> [box ^. to bottomRightCorner . L._y .. box ^. to bottomRightCorner . L._y]
+boxEdge box TopEdge =
+  flip V2 (box ^. topLeftCorner . L._y)
+  <$> [box ^. topLeftCorner . L._x .. box ^. to bottomRightCorner . L._x]
+boxEdge box BottomEdge =
+  flip V2 (box ^. to bottomRightCorner . L._y)
+  <$> [box ^. topLeftCorner . L._x .. box ^. to bottomRightCorner . L._x]
diff --git a/users/glittershark/xanthous/src/Xanthous/Data/App.hs b/users/glittershark/xanthous/src/Xanthous/Data/App.hs
new file mode 100644
index 000000000000..0361d2a59ed5
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Data/App.hs
@@ -0,0 +1,39 @@
+--------------------------------------------------------------------------------
+module Xanthous.Data.App
+  ( Panel(..)
+  , ResourceName(..)
+  , AppEvent(..)
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Test.QuickCheck
+import Data.Aeson (ToJSON, FromJSON)
+--------------------------------------------------------------------------------
+import Xanthous.Util.QuickCheck
+--------------------------------------------------------------------------------
+
+-- | Enum for "panels" displayed in the game's UI.
+data Panel
+  = InventoryPanel -- ^ A panel displaying the character's inventory
+  deriving stock (Show, Eq, Ord, Generic, Enum, Bounded)
+  deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON)
+  deriving Arbitrary via GenericArbitrary Panel
+
+
+data ResourceName
+  = MapViewport -- ^ The main viewport where we display the game content
+  | Character   -- ^ The character
+  | MessageBox  -- ^ The box where we display messages to the user
+  | Prompt      -- ^ The game's prompt
+  | Panel Panel -- ^ A panel in the game
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON)
+  deriving Arbitrary via GenericArbitrary ResourceName
+
+data AppEvent
+  = AutoContinue -- ^ Continue whatever autocommand has been requested by the
+                 --   user
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON)
+  deriving Arbitrary via GenericArbitrary AppEvent
diff --git a/users/glittershark/xanthous/src/Xanthous/Data/Entities.hs b/users/glittershark/xanthous/src/Xanthous/Data/Entities.hs
new file mode 100644
index 000000000000..39953410f2f3
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Data/Entities.hs
@@ -0,0 +1,68 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE RecordWildCards #-}
+--------------------------------------------------------------------------------
+module Xanthous.Data.Entities
+  ( -- * Collisions
+    Collision(..)
+  , _Stop
+  , _Combat
+    -- * Entity Attributes
+  , EntityAttributes(..)
+  , blocksVision
+  , blocksObject
+  , collision
+  , defaultEntityAttributes
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Data.Aeson (ToJSON(..), FromJSON(..), (.:?), (.!=), withObject)
+import           Data.Aeson.Generic.DerivingVia
+import           Xanthous.Util.QuickCheck (GenericArbitrary(..))
+import           Test.QuickCheck
+--------------------------------------------------------------------------------
+
+data Collision
+  = Stop   -- ^ Can't move through this
+  | Combat -- ^ Moving into this equates to hitting it with a stick
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary Collision
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ AllNullaryToStringTag 'True ]
+           Collision
+makePrisms ''Collision
+
+-- | Attributes of an entity
+data EntityAttributes = EntityAttributes
+  { _blocksVision :: Bool
+    -- | Does this entity block a large object from being put in the same tile as
+    -- it - eg a a door being closed on it
+  , _blocksObject :: Bool
+    -- | What type of collision happens when moving into this entity?
+  , _collision :: Collision
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary EntityAttributes
+  deriving (ToJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           EntityAttributes
+makeLenses ''EntityAttributes
+
+instance FromJSON EntityAttributes where
+  parseJSON = withObject "EntityAttributes" $ \o -> do
+    _blocksVision <- o .:? "blocksVision"
+                      .!= _blocksVision defaultEntityAttributes
+    _blocksObject <- o .:? "blocksObject"
+                      .!= _blocksObject defaultEntityAttributes
+    _collision    <- o .:? "collision"
+                      .!= _collision defaultEntityAttributes
+    pure EntityAttributes {..}
+
+defaultEntityAttributes :: EntityAttributes
+defaultEntityAttributes = EntityAttributes
+  { _blocksVision = False
+  , _blocksObject = False
+  , _collision    = Stop
+  }
diff --git a/users/glittershark/xanthous/src/Xanthous/Data/EntityChar.hs b/users/glittershark/xanthous/src/Xanthous/Data/EntityChar.hs
new file mode 100644
index 000000000000..855a3462daee
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Data/EntityChar.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE RoleAnnotations      #-}
+{-# LANGUAGE RecordWildCards      #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE GADTs                #-}
+{-# LANGUAGE AllowAmbiguousTypes  #-}
+{-# LANGUAGE TemplateHaskell      #-}
+--------------------------------------------------------------------------------
+module Xanthous.Data.EntityChar
+  ( EntityChar(..)
+  , HasChar(..)
+  , HasStyle(..)
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding ((.=))
+--------------------------------------------------------------------------------
+import qualified Graphics.Vty.Attributes as Vty
+import           Test.QuickCheck
+import           Data.Aeson
+--------------------------------------------------------------------------------
+import           Xanthous.Orphans ()
+import           Xanthous.Util.QuickCheck (GenericArbitrary(..))
+--------------------------------------------------------------------------------
+
+
+class HasChar s a | s -> a where
+  char :: Lens' s a
+  {-# MINIMAL char #-}
+
+data EntityChar = EntityChar
+  { _char :: Char
+  , _style :: Vty.Attr
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary EntityChar
+makeFieldsNoPrefix ''EntityChar
+
+instance FromJSON EntityChar where
+  parseJSON (String (chr :< Empty)) = pure $ EntityChar chr Vty.defAttr
+  parseJSON (Object o) = do
+    (EntityChar _char _) <- o .: "char"
+    _style <- o .:? "style" .!= Vty.defAttr
+    pure EntityChar {..}
+  parseJSON _ = fail "Invalid type, expected string or object"
+
+instance ToJSON EntityChar where
+  toJSON (EntityChar chr styl)
+    | styl == Vty.defAttr = String $ chr <| Empty
+    | otherwise = object
+      [ "char" .= chr
+      , "style" .= styl
+      ]
+
+instance IsString EntityChar where
+  fromString [ch] = EntityChar ch Vty.defAttr
+  fromString _ = error "Entity char must only be a single character"
diff --git a/users/glittershark/xanthous/src/Xanthous/Data/EntityMap.hs b/users/glittershark/xanthous/src/Xanthous/Data/EntityMap.hs
new file mode 100644
index 000000000000..d24defa841ab
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Data/EntityMap.hs
@@ -0,0 +1,272 @@
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE DeriveTraversable  #-}
+{-# LANGUAGE TupleSections      #-}
+{-# LANGUAGE TemplateHaskell    #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveFunctor      #-}
+--------------------------------------------------------------------------------
+module Xanthous.Data.EntityMap
+  ( EntityMap
+  , _EntityMap
+  , EntityID
+  , emptyEntityMap
+  , insertAt
+  , insertAtReturningID
+  , fromEIDsAndPositioned
+  , toEIDsAndPositioned
+  , atPosition
+  , atPositionWithIDs
+  , positions
+  , lookup
+  , lookupWithPosition
+  -- , positionedEntities
+  , neighbors
+  , Deduplicate(..)
+
+  -- * debug
+  , byID
+  , byPosition
+  , lastID
+
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude hiding (lookup)
+import Xanthous.Data
+  ( Position
+  , Positioned(..)
+  , positioned
+  , Neighbors(..)
+  , neighborPositions
+  )
+import Xanthous.Data.VectorBag
+import Xanthous.Orphans ()
+import Xanthous.Util (EqEqProp(..))
+--------------------------------------------------------------------------------
+import Data.Monoid (Endo(..))
+import Test.QuickCheck (Arbitrary(..), CoArbitrary, Function)
+import Test.QuickCheck.Checkers (EqProp)
+import Test.QuickCheck.Instances.UnorderedContainers ()
+import Test.QuickCheck.Instances.Vector ()
+import Text.Show (showString, showParen)
+import Data.Aeson
+--------------------------------------------------------------------------------
+
+type EntityID = Word32
+type NonNullSet a = NonNull (Set a)
+
+data EntityMap a where
+  EntityMap ::
+    { _byPosition :: Map Position (NonNullSet EntityID)
+    , _byID       :: HashMap EntityID (Positioned a)
+    , _lastID     :: EntityID
+    } -> EntityMap a
+  deriving stock (Functor, Foldable, Traversable, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+deriving via (EqEqProp (EntityMap a)) instance (Eq a, Ord a) => EqProp (EntityMap a)
+makeLenses ''EntityMap
+
+instance ToJSON a => ToJSON (EntityMap a) where
+  toJSON = toJSON . toEIDsAndPositioned
+
+
+instance FromJSON a => FromJSON (EntityMap a) where
+  parseJSON = fmap (fromEIDsAndPositioned @[_]) . parseJSON
+
+byIDInvariantError :: forall a. a
+byIDInvariantError = error $ "Invariant violation: All EntityIDs in byPosition "
+  <> "must point to entityIDs in byID"
+
+instance (Ord a, Eq a) => Eq (EntityMap a) where
+  -- em₁ == em₂ = em₁ ^. _EntityMap == em₂ ^. _EntityMap
+  (==) = (==) `on` view (_EntityMap . to sort)
+
+deriving stock instance (Ord a) => Ord (EntityMap a)
+
+instance Show a => Show (EntityMap a) where
+  showsPrec pr em
+    = showParen (pr > 10)
+    $ showString
+    . ("fromEIDsAndPositioned " <>)
+    . show
+    . toEIDsAndPositioned
+    $ em
+
+instance Arbitrary a => Arbitrary (EntityMap a) where
+  arbitrary = review _EntityMap <$> arbitrary
+  shrink em = review _EntityMap <$> shrink (em ^. _EntityMap)
+
+type instance Index (EntityMap a) = EntityID
+type instance IxValue (EntityMap a) = (Positioned a)
+instance Ixed (EntityMap a) where ix eid = at eid . traverse
+
+instance At (EntityMap a) where
+  at eid = lens (view $ byID . at eid) setter
+    where
+      setter :: EntityMap a -> Maybe (Positioned a) -> EntityMap a
+      setter m Nothing = fromMaybe m $ do
+        Positioned pos _ <- m ^. byID . at eid
+        pure $ m
+          & removeEIDAtPos pos
+          & byID . at eid .~ Nothing
+      setter m (Just pe@(Positioned pos _)) = m
+        & (case lookupWithPosition eid m of
+             Nothing -> id
+             Just (Positioned origPos _) -> removeEIDAtPos origPos
+          )
+        & byID . at eid ?~ pe
+        & byPosition . at pos %~ \case
+            Nothing -> Just $ opoint eid
+            Just es -> Just $ ninsertSet eid es
+      removeEIDAtPos pos =
+        byPosition . at pos %~ (>>= fromNullable . ndeleteSet eid)
+
+instance Semigroup (EntityMap a) where
+  em₁ <> em₂ = alaf Endo foldMap (uncurry insertAt) (em₂ ^. _EntityMap) em₁
+
+instance Monoid (EntityMap a) where
+  mempty = emptyEntityMap
+
+instance FunctorWithIndex EntityID EntityMap
+
+instance FoldableWithIndex EntityID EntityMap
+
+instance TraversableWithIndex EntityID EntityMap where
+  itraversed = byID . itraversed . rmap sequenceA . distrib
+  itraverse = itraverseOf itraversed
+
+type instance Element (EntityMap a) = a
+instance MonoFoldable (EntityMap a)
+
+emptyEntityMap :: EntityMap a
+emptyEntityMap = EntityMap mempty mempty 0
+
+newtype Deduplicate a = Deduplicate (EntityMap a)
+  deriving stock (Show, Traversable, Generic)
+  deriving newtype (Eq, Functor, Foldable, EqProp, Arbitrary)
+
+instance Semigroup (Deduplicate a) where
+  (Deduplicate em₁) <> (Deduplicate em₂) =
+    let _byID = em₁ ^. byID <> em₂ ^. byID
+        _byPosition = mempty &~ do
+          ifor_ _byID $ \eid (Positioned pos _) ->
+            at pos %= \case
+              Just eids -> Just $ ninsertSet eid eids
+              Nothing -> Just $ opoint eid
+        _lastID = fromMaybe 1 $ maximumOf (ifolded . asIndex) _byID
+    in Deduplicate EntityMap{..}
+
+
+--------------------------------------------------------------------------------
+
+_EntityMap :: Iso' (EntityMap a) [(Position, a)]
+_EntityMap = iso hither yon
+  where
+    hither :: EntityMap a -> [(Position, a)]
+    hither em = do
+       (pos, eids) <- em ^. byPosition . _Wrapped
+       eid <- toList eids
+       ent <- em ^.. byID . at eid . folded . positioned
+       pure (pos, ent)
+    yon :: [(Position, a)] -> EntityMap a
+    yon poses = alaf Endo foldMap (uncurry insertAt) poses emptyEntityMap
+
+
+insertAtReturningID :: forall a. Position -> a -> EntityMap a -> (EntityID, EntityMap a)
+insertAtReturningID pos e em =
+  let (eid, em') = em & lastID <+~ 1
+  in em'
+     & byID . at eid ?~ Positioned pos e
+     & byPosition . at pos %~ \case
+       Nothing -> Just $ opoint eid
+       Just es -> Just $ ninsertSet eid es
+     & (eid, )
+
+insertAt :: forall a. Position -> a -> EntityMap a -> EntityMap a
+insertAt pos e = snd . insertAtReturningID pos e
+
+atPosition :: forall a. (Ord a, Show a) => Position -> Lens' (EntityMap a) (VectorBag a)
+atPosition pos = lens getter setter
+  where
+    getter em =
+      let eids :: VectorBag EntityID
+          eids = maybe mempty (VectorBag . toVector . toNullable)
+                 $ em ^. byPosition . at pos
+      in getEIDAssume em <$> eids
+    setter em Empty = em & byPosition . at pos .~ Nothing
+    setter em (sort -> entities) =
+      let origEIDs = maybe Empty toNullable $ em ^. byPosition . at pos
+          origEntitiesWithIDs =
+            sortOn snd $ toList origEIDs <&> \eid -> (eid, getEIDAssume em eid)
+          go alles₁@((eid, e₁) :< es₁) -- orig
+             (e₂ :< es₂)               -- new
+            | e₁ == e₂
+              -- same, do nothing
+            = let (eids, lastEID, byID') = go es₁ es₂
+              in (insertSet eid eids, lastEID, byID')
+            | otherwise
+              -- e₂ is new, generate a new ID for it
+            = let (eids, lastEID, byID') = go alles₁ es₂
+                  eid' = succ lastEID
+              in (insertSet eid' eids, eid', byID' & at eid' ?~ Positioned pos e₂)
+          go Empty Empty = (mempty, em ^. lastID, em ^. byID)
+          go orig Empty =
+            let byID' = foldr deleteMap (em ^. byID) $ map fst orig
+            in (mempty, em ^. lastID, byID')
+          go Empty (new :< news) =
+            let (eids, lastEID, byID') = go Empty news
+                eid' = succ lastEID
+            in (insertSet eid' eids, eid', byID' & at eid' ?~ Positioned pos new)
+          go _ _ = error "unreachable"
+          (eidsAtPosition, newLastID, newByID) = go origEntitiesWithIDs entities
+      in em & byPosition . at pos .~ fromNullable eidsAtPosition
+            & byID .~ newByID
+            & lastID .~ newLastID
+
+getEIDAssume :: EntityMap a -> EntityID -> a
+getEIDAssume em eid = fromMaybe byIDInvariantError
+  $ em ^? byID . ix eid . positioned
+
+atPositionWithIDs :: Position -> EntityMap a -> Vector (EntityID, Positioned a)
+atPositionWithIDs pos em =
+  let eids = maybe mempty (toVector . toNullable)
+             $ em ^. byPosition . at pos
+  in (id &&& Positioned pos . getEIDAssume em) <$> eids
+
+fromEIDsAndPositioned
+  :: forall mono a. (MonoFoldable mono, Element mono ~ (EntityID, Positioned a))
+  => mono
+  -> EntityMap a
+fromEIDsAndPositioned eps = newLastID $ alaf Endo foldMap insert' eps mempty
+  where
+    insert' (eid, pe@(Positioned pos _))
+      = (byID . at eid ?~ pe)
+      . (byPosition . at pos %~ \case
+            Just eids -> Just $ ninsertSet eid eids
+            Nothing   -> Just $ opoint eid
+        )
+    newLastID em = em & lastID
+      .~ fromMaybe 1
+         (maximumOf (ifolded . asIndex) (em ^. byID))
+
+toEIDsAndPositioned :: EntityMap a -> [(EntityID, Positioned a)]
+toEIDsAndPositioned = itoListOf $ byID . ifolded
+
+positions :: EntityMap a -> [Position]
+positions = toListOf $ byPosition . to keys . folded
+
+lookupWithPosition :: EntityID -> EntityMap a -> Maybe (Positioned a)
+lookupWithPosition eid = view $ byID . at eid
+
+lookup :: EntityID -> EntityMap a -> Maybe a
+lookup eid = fmap (view positioned) . lookupWithPosition eid
+
+-- unlawful :(
+-- positionedEntities :: IndexedTraversal EntityID (EntityMap a) (EntityMap b) (Positioned a) (Positioned b)
+-- positionedEntities = byID . itraversed
+
+neighbors :: (Ord a, Show a) => Position -> EntityMap a -> Neighbors (VectorBag a)
+neighbors pos em = (\p -> view (atPosition p) em) <$> neighborPositions pos
+
+--------------------------------------------------------------------------------
+makeWrapped ''Deduplicate
diff --git a/users/glittershark/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs b/users/glittershark/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs
new file mode 100644
index 000000000000..5a73bd393848
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs
@@ -0,0 +1,64 @@
+--------------------------------------------------------------------------------
+module Xanthous.Data.EntityMap.Graphics
+  ( visiblePositions
+  , visibleEntities
+  , linesOfSight
+  , canSee
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude hiding (lines)
+--------------------------------------------------------------------------------
+import Xanthous.Util (takeWhileInclusive)
+import Xanthous.Data
+import Xanthous.Data.Entities
+import Xanthous.Data.EntityMap
+import Xanthous.Game.State
+import Xanthous.Util.Graphics (circle, line)
+--------------------------------------------------------------------------------
+
+-- | Returns a set of positions that are visible, when taking into account
+-- 'blocksVision', from the given position, within the given radius.
+visiblePositions
+  :: Entity e
+  => Position
+  -> Word -- ^ Vision radius
+  -> EntityMap e
+  -> Set Position
+visiblePositions pos radius
+  = setFromList . positions . visibleEntities pos radius
+
+-- | Returns a list of individual lines of sight, each of which is a list of
+-- entities at positions on that line of sight
+linesOfSight
+  :: forall e. Entity e
+  => Position
+  -> Word
+  -> EntityMap e
+  -> [[(Position, Vector (EntityID, e))]]
+linesOfSight (view _Position -> pos) visionRadius em
+  = entitiesOnLines
+  <&> takeWhileInclusive
+      (none (view blocksVision . entityAttributes . snd) . snd)
+  where
+    radius = circle pos $ fromIntegral visionRadius
+    lines = line pos <$> radius
+    entitiesOnLines :: [[(Position, Vector (EntityID, e))]]
+    entitiesOnLines = lines <&> map getPositionedAt
+    getPositionedAt :: (Int, Int) -> (Position, Vector (EntityID, e))
+    getPositionedAt p =
+      let ppos = _Position # p
+      in (ppos, over _2 (view positioned) <$> atPositionWithIDs ppos em)
+
+-- | Given a point and a radius of vision, returns a list of all entities that
+-- are *visible* (eg, not blocked by an entity that obscures vision) from that
+-- point
+visibleEntities :: Entity e => Position -> Word -> EntityMap e -> EntityMap e
+visibleEntities pos visionRadius
+  = fromEIDsAndPositioned
+  . foldMap (\(p, es) -> over _2 (Positioned p) <$> es)
+  . fold
+  . linesOfSight pos visionRadius
+
+canSee :: Entity e => (e -> Bool) -> Position -> Word -> EntityMap e -> Bool
+canSee match pos radius = any match . visibleEntities pos radius
+-- ^ this might be optimizable
diff --git a/users/glittershark/xanthous/src/Xanthous/Data/Levels.hs b/users/glittershark/xanthous/src/Xanthous/Data/Levels.hs
new file mode 100644
index 000000000000..efc0f53acecf
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Data/Levels.hs
@@ -0,0 +1,170 @@
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Data.Levels
+  ( Levels
+  , allLevels
+  , nextLevel
+  , prevLevel
+  , mkLevels1
+  , mkLevels
+  , oneLevel
+  , current
+  , ComonadStore(..)
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding ((<.>), Empty, foldMap)
+import           Xanthous.Util (between, EqProp, EqEqProp(..))
+import           Xanthous.Util.Comonad (current)
+import           Xanthous.Orphans ()
+--------------------------------------------------------------------------------
+import           Control.Comonad.Store
+import           Control.Comonad.Store.Zipper
+import           Data.Aeson (ToJSON(..), FromJSON(..))
+import           Data.Aeson.Generic.DerivingVia
+import           Data.Functor.Apply
+import           Data.Foldable (foldMap)
+import           Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as NE
+import           Data.Maybe (fromJust)
+import           Data.Sequence (Seq((:<|), Empty))
+import           Data.Semigroup.Foldable.Class
+import           Data.Text (replace)
+import           Test.QuickCheck
+--------------------------------------------------------------------------------
+
+-- | Collection of levels plus a pointer to the current level
+--
+-- Navigation is via the 'Comonad' instance. We can get the current level with
+-- 'extract':
+--
+--     extract @Levels :: Levels level -> level
+--
+-- For access to and modification of the level, use
+-- 'Xanthous.Util.Comonad.current'
+newtype Levels a = Levels { levelZipper :: Zipper Seq a }
+    deriving stock (Generic)
+    deriving (Functor, Comonad, Foldable) via (Zipper Seq)
+    deriving (ComonadStore Int) via (Zipper Seq)
+
+type instance Element (Levels a) = a
+instance MonoFoldable (Levels a)
+instance MonoFunctor (Levels a)
+instance MonoTraversable (Levels a)
+
+instance Traversable Levels where
+  traverse f (Levels z) = Levels <$> traverse f z
+
+instance Foldable1 Levels
+
+instance Traversable1 Levels where
+  traverse1 f (Levels z) = seek (pos z) . partialMkLevels <$> go (unzipper z)
+    where
+      go Empty = error "empty seq, unreachable"
+      go (x :<| xs) = (<|) <$> f x <.> go xs
+
+-- | Always takes the position of the latter element
+instance Semigroup (Levels a) where
+  levs₁ <> levs₂
+    = seek (pos levs₂)
+    . partialMkLevels
+    $ allLevels levs₁ <> allLevels levs₂
+
+-- | Make Levels from a Seq. Throws an error if the seq is not empty
+partialMkLevels :: Seq a -> Levels a
+partialMkLevels = Levels . fromJust . zipper
+
+-- | Make Levels from a possibly-empty structure
+mkLevels :: Foldable1 f => f level -> Maybe (Levels level)
+mkLevels = fmap Levels . zipper . foldMap pure
+
+-- | Make Levels from a non-empty structure
+mkLevels1 :: Foldable1 f => f level -> Levels level
+mkLevels1 = fromJust . mkLevels
+
+oneLevel :: a -> Levels a
+oneLevel = mkLevels1 . Identity
+
+-- | Get a sequence of all the levels
+allLevels :: Levels a -> Seq a
+allLevels = unzipper . levelZipper
+
+-- | Step to the next level, generating a new level if necessary using the given
+-- applicative action
+nextLevel
+  :: Applicative m
+  => m level -- ^ Generate a new level, if necessary
+  -> Levels level
+  -> m (Levels level)
+nextLevel genLevel levs
+  | pos levs + 1 < size (levelZipper levs)
+  = pure $ seeks succ levs
+  | otherwise
+  = genLevel <&> \level ->
+      seek (pos levs + 1) . partialMkLevels $ allLevels levs |> level
+
+-- | Go to the previous level. Returns Nothing if 'pos' is 0
+prevLevel :: Levels level -> Maybe (Levels level)
+prevLevel levs | pos levs == 0 = Nothing
+               | otherwise = Just $ seeks pred levs
+
+--------------------------------------------------------------------------------
+
+-- | alternate, slower representation of Levels we can Iso into to perform
+-- various operations
+data AltLevels a = AltLevels
+  { _levels :: NonEmpty a
+  , _currentLevel :: Int -- ^ invariant: is within the bounds of _levels
+  }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           (AltLevels a)
+makeLenses ''AltLevels
+
+alt :: Iso (Levels a) (Levels b) (AltLevels a) (AltLevels b)
+alt = iso hither yon
+  where
+    hither levs = AltLevels (NE.fromList . toList $ allLevels levs) (pos levs)
+    yon (AltLevels levs curr) = seek curr $ mkLevels1 levs
+
+instance Eq a => Eq (Levels a) where
+  (==) = (==) `on` view alt
+
+deriving via EqEqProp (Levels a) instance Eq a => EqProp (Levels a)
+
+instance Show a => Show (Levels a) where
+  show = unpack . replace "AltLevels" "Levels" . pack . show . view alt
+
+instance NFData a => NFData (Levels a) where
+  rnf = rnf . view alt
+
+instance ToJSON a => ToJSON (Levels a) where
+  toJSON = toJSON . view alt
+
+instance FromJSON a => FromJSON (Levels a) where
+  parseJSON = fmap (review alt) . parseJSON
+
+instance Arbitrary a => Arbitrary (AltLevels a) where
+  arbitrary = do
+    _levels <- arbitrary
+    _currentLevel <- choose (0, length _levels - 1)
+    pure AltLevels {..}
+  shrink als = do
+    _levels <- shrink $ als ^. levels
+    _currentLevel <- filter (between 0 $ length _levels - 1)
+                    $ shrink $ als ^. currentLevel
+    pure AltLevels {..}
+
+
+instance Arbitrary a => Arbitrary (Levels a) where
+  arbitrary = review alt <$> arbitrary
+  shrink = fmap (review alt) . shrink . view alt
+
+instance CoArbitrary a => CoArbitrary (Levels a) where
+  coarbitrary = coarbitrary . view alt
+
+instance Function a => Function (Levels a) where
+  function = functionMap (view alt) (review alt)
diff --git a/users/glittershark/xanthous/src/Xanthous/Data/NestedMap.hs b/users/glittershark/xanthous/src/Xanthous/Data/NestedMap.hs
new file mode 100644
index 000000000000..1b875d448302
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Data/NestedMap.hs
@@ -0,0 +1,227 @@
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE UndecidableInstances  #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE StandaloneDeriving    #-}
+{-# LANGUAGE PolyKinds             #-}
+--------------------------------------------------------------------------------
+module Xanthous.Data.NestedMap
+  ( NestedMapVal(..)
+  , NestedMap(..)
+  , lookup
+  , lookupVal
+  , insert
+
+    -- *
+  , (:->)
+  , BifunctorFunctor'(..)
+  , BifunctorMonad'(..)
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding (lookup, foldMap)
+import qualified Xanthous.Prelude as P
+--------------------------------------------------------------------------------
+import           Test.QuickCheck
+import           Data.Aeson
+import           Data.Function (fix)
+import           Data.Foldable (Foldable(..))
+import           Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NE
+--------------------------------------------------------------------------------
+
+-- | Natural transformations on bifunctors
+type (:->) p q = forall a b. p a b -> q a b
+infixr 0 :->
+
+class (forall b. Bifunctor b => Bifunctor (t b)) => BifunctorFunctor' t where
+  bifmap' :: (Bifunctor p, Bifunctor q) => (p :-> q) -> t p :-> t q
+
+class BifunctorFunctor' t => BifunctorMonad' t where
+  bireturn' :: (Bifunctor p) => p :-> t p
+
+  bibind' :: (Bifunctor p, Bifunctor q) => (p :-> t q) -> t p :-> t q
+  bibind' f = bijoin' . bifmap' f
+
+  bijoin' :: (Bifunctor p) => t (t p) :-> t p
+  bijoin' = bibind' id
+
+  {-# MINIMAL bireturn', (bibind' | bijoin') #-}
+
+--------------------------------------------------------------------------------
+
+data NestedMapVal m k v = Val v | Nested (NestedMap m k v)
+
+deriving stock instance
+  ( forall k' v'. (Show k', Show v') => Show (m k' v')
+  , Show k
+  , Show v
+  ) => Show (NestedMapVal m k v)
+
+deriving stock instance
+  ( forall k' v'. (Eq k', Eq v') => Eq (m k' v')
+  , Eq k
+  , Eq v
+  ) => Eq (NestedMapVal m k v)
+
+instance
+  forall m k v.
+  ( Arbitrary (m k v)
+  , Arbitrary (m k (NestedMapVal m k v))
+  , Arbitrary k
+  , Arbitrary v
+  , IsMap (m k (NestedMapVal m k v))
+  , MapValue (m k (NestedMapVal m k v)) ~ (NestedMapVal m k v)
+  , ContainerKey (m k (NestedMapVal m k v)) ~ k
+  ) => Arbitrary (NestedMapVal m k v) where
+  arbitrary = sized . fix $ \gen n ->
+    let nst = fmap (NestedMap . mapFromList)
+            . listOf
+            $ (,) <$> arbitrary @k <*> gen (n `div` 2)
+    in if n == 0
+       then Val <$> arbitrary
+       else oneof [ Val <$> arbitrary
+                  , Nested <$> nst]
+  shrink (Val v) = Val <$> shrink v
+  shrink (Nested mkv) = Nested <$> shrink mkv
+
+instance Functor (m k) => Functor (NestedMapVal m k) where
+  fmap f (Val v) = Val $ f v
+  fmap f (Nested m) = Nested $ fmap f m
+
+instance Bifunctor m => Bifunctor (NestedMapVal m) where
+  bimap _ g (Val v) = Val $ g v
+  bimap f g (Nested m) = Nested $ bimap f g m
+
+instance BifunctorFunctor' NestedMapVal where
+  bifmap' _ (Val v) = Val v
+  bifmap' f (Nested m) = Nested $ bifmap' f m
+
+instance (ToJSONKey k, ToJSON v, ToJSON (m k (NestedMapVal m k v)))
+       => ToJSON (NestedMapVal m k v) where
+  toJSON (Val v) = toJSON v
+  toJSON (Nested m) = toJSON m
+
+instance Foldable (m k) => Foldable (NestedMapVal m k) where
+  foldMap f (Val v) = f v
+  foldMap f (Nested m) = foldMap f m
+
+-- _NestedMapVal
+--   :: forall m k v m' k' v'.
+--     ( IsMap (m k v), IsMap (m' k' v')
+--     , IsMap (m [k] v), IsMap (m' [k'] v')
+--     , ContainerKey (m k v) ~ k, ContainerKey (m' k' v') ~ k'
+--     , ContainerKey (m [k] v) ~ [k], ContainerKey (m' [k'] v') ~ [k']
+--     , MapValue (m k v) ~ v, MapValue (m' k' v') ~ v'
+--     , MapValue (m [k] v) ~ v, MapValue (m' [k'] v') ~ v'
+--     )
+--   => Iso (NestedMapVal m k v)
+--         (NestedMapVal m' k' v')
+--         (m [k] v)
+--         (m' [k'] v')
+-- _NestedMapVal = iso hither yon
+--   where
+--     hither :: NestedMapVal m k v -> m [k] v
+--     hither (Val v) = singletonMap [] v
+--     hither (Nested m) = bimap _ _ $ m ^. _NestedMap
+--     yon = _
+
+--------------------------------------------------------------------------------
+
+newtype NestedMap m k v = NestedMap (m k (NestedMapVal m k v))
+
+deriving stock instance
+  ( forall k' v'. (Eq k', Eq v') => Eq (m k' v')
+  , Eq k
+  , Eq v
+  ) => Eq (NestedMap m k v)
+
+deriving stock instance
+  ( forall k' v'. (Show k', Show v') => Show (m k' v')
+  , Show k
+  , Show v
+  ) => Show (NestedMap m k v)
+
+instance Arbitrary (m k (NestedMapVal m k v))
+       => Arbitrary (NestedMap m k v) where
+  arbitrary = NestedMap <$> arbitrary
+  shrink (NestedMap m) = NestedMap <$> shrink m
+
+instance Functor (m k) => Functor (NestedMap m k) where
+  fmap f (NestedMap m) = NestedMap $ fmap (fmap f) m
+
+instance Bifunctor m => Bifunctor (NestedMap m) where
+  bimap f g (NestedMap m) = NestedMap $ bimap f (bimap f g) m
+
+instance BifunctorFunctor' NestedMap where
+  bifmap' f (NestedMap m) = NestedMap . f $ bimap id (bifmap' f) m
+
+instance (ToJSONKey k, ToJSON v, ToJSON (m k (NestedMapVal m k v)))
+       => ToJSON (NestedMap m k v) where
+  toJSON (NestedMap m) = toJSON m
+
+instance Foldable (m k) => Foldable (NestedMap m k) where
+  foldMap f (NestedMap m) = foldMap (foldMap f) m
+
+--------------------------------------------------------------------------------
+
+lookup
+  :: ( IsMap (m k (NestedMapVal m k v))
+    , MapValue (m k (NestedMapVal m k v)) ~ (NestedMapVal m k v)
+    , ContainerKey (m k (NestedMapVal m k v)) ~ k
+    )
+  => NonEmpty k
+  -> NestedMap m k v
+  -> Maybe (NestedMapVal m k v)
+lookup (p :| []) (NestedMap vs) = P.lookup p vs
+lookup (p :| (p₁ : ps)) (NestedMap vs) = P.lookup p vs >>= \case
+  (Val _) -> Nothing
+  (Nested vs') -> lookup (p₁ :| ps) vs'
+
+lookupVal
+  :: ( IsMap (m k (NestedMapVal m k v))
+    , MapValue (m k (NestedMapVal m k v)) ~ (NestedMapVal m k v)
+    , ContainerKey (m k (NestedMapVal m k v)) ~ k
+    )
+  => NonEmpty k
+  -> NestedMap m k v
+  -> Maybe v
+lookupVal ks m
+  | Just (Val v) <- lookup ks m = Just v
+  | otherwise                  = Nothing
+
+insert
+  :: ( IsMap (m k (NestedMapVal m k v))
+    , MapValue (m k (NestedMapVal m k v)) ~ (NestedMapVal m k v)
+    , ContainerKey (m k (NestedMapVal m k v)) ~ k
+    )
+  => NonEmpty k
+  -> v
+  -> NestedMap m k v
+  -> NestedMap m k v
+insert (k :| []) v (NestedMap m) = NestedMap $ P.insertMap k (Val v) m
+insert (k₁ :| (k₂ : ks)) v (NestedMap m) = NestedMap $ alterMap upd k₁ m
+  where
+    upd (Just (Nested nm)) = Just . Nested $ insert (k₂ :| ks) v nm
+    upd _ = Just $
+      let (kΩ :| ks') = NE.reverse (k₂ :| ks)
+      in P.foldl'
+         (\m' k -> Nested . NestedMap . singletonMap k $ m')
+         (Nested . NestedMap . singletonMap kΩ $ Val v)
+         ks'
+
+-- _NestedMap
+--   :: ( IsMap (m k v), IsMap (m' k' v')
+--     , IsMap (m (NonEmpty k) v), IsMap (m' (NonEmpty k') v')
+--     , ContainerKey (m k v) ~ k, ContainerKey (m' k' v') ~ k'
+--     , ContainerKey (m (NonEmpty k) v) ~ (NonEmpty k)
+--     , ContainerKey (m' (NonEmpty k') v') ~ (NonEmpty k')
+--     , MapValue (m k v) ~ v, MapValue (m' k' v') ~ v'
+--     , MapValue (m (NonEmpty k) v) ~ v, MapValue (m' (NonEmpty k') v') ~ v'
+--     )
+--   => Iso (NestedMap m k v)
+--         (NestedMap m' k' v')
+--         (m (NonEmpty k) v)
+--         (m' (NonEmpty k') v')
+-- _NestedMap = iso undefined yon
+--   where
+--     hither (NestedMap m) = undefined . mapToList $ m
+--     yon mkv = undefined
diff --git a/users/glittershark/xanthous/src/Xanthous/Data/VectorBag.hs b/users/glittershark/xanthous/src/Xanthous/Data/VectorBag.hs
new file mode 100644
index 000000000000..bd9af369e01c
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Data/VectorBag.hs
@@ -0,0 +1,94 @@
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Data.VectorBag
+  (VectorBag(..)
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+import           Data.Aeson
+import qualified Data.Vector as V
+import           Test.QuickCheck
+import           Test.QuickCheck.Instances.Vector ()
+--------------------------------------------------------------------------------
+
+-- | Acts exactly like a Vector, except ignores order when testing for equality
+newtype VectorBag a = VectorBag (Vector a)
+  deriving stock
+    ( Traversable
+    , Generic
+    )
+  deriving newtype
+    ( Show
+    , Read
+    , Foldable
+    , FromJSON
+    , FromJSON1
+    , ToJSON
+    , Reversing
+    , Applicative
+    , Functor
+    , Monad
+    , Monoid
+    , Semigroup
+    , Arbitrary
+    , CoArbitrary
+    )
+makeWrapped ''VectorBag
+
+instance Function a => Function (VectorBag a) where
+  function = functionMap (\(VectorBag v) -> v) VectorBag
+
+type instance Element (VectorBag a) = a
+deriving via (Vector a) instance MonoFoldable (VectorBag a)
+deriving via (Vector a) instance GrowingAppend (VectorBag a)
+deriving via (Vector a) instance SemiSequence (VectorBag a)
+deriving via (Vector a) instance MonoPointed (VectorBag a)
+deriving via (Vector a) instance MonoFunctor (VectorBag a)
+
+instance Cons (VectorBag a) (VectorBag b) a b where
+  _Cons = prism (\(x, VectorBag xs) -> VectorBag $ x <| xs) $ \(VectorBag v) ->
+    if V.null v
+    then Left (VectorBag mempty)
+    else Right (V.unsafeHead v, VectorBag $ V.unsafeTail v)
+
+instance AsEmpty (VectorBag a) where
+  _Empty = prism' (const $ VectorBag Empty) $ \case
+    (VectorBag Empty) -> Just ()
+    _ -> Nothing
+
+{-
+    TODO:
+    , Ixed
+    , FoldableWithIndex
+    , FunctorWithIndex
+    , TraversableWithIndex
+    , Snoc
+    , Each
+-}
+
+instance Ord a => Eq (VectorBag a) where
+  (==) = (==) `on` (view _Wrapped . sort)
+
+instance Ord a => Ord (VectorBag a) where
+  compare = compare  `on` (view _Wrapped . sort)
+
+instance MonoTraversable (VectorBag a) where
+  otraverse f (VectorBag v) = VectorBag <$> otraverse f v
+
+instance IsSequence (VectorBag a) where
+  fromList = VectorBag . fromList
+  break prd (VectorBag v) = bimap VectorBag VectorBag $ break prd v
+  span prd (VectorBag v) = bimap VectorBag VectorBag $ span prd v
+  dropWhile prd (VectorBag v) = VectorBag $ dropWhile prd v
+  takeWhile prd (VectorBag v) = VectorBag $ takeWhile prd v
+  splitAt idx (VectorBag v) = bimap VectorBag VectorBag $ splitAt idx v
+  unsafeSplitAt idx (VectorBag v) =
+    bimap VectorBag VectorBag $ unsafeSplitAt idx v
+  take n (VectorBag v) = VectorBag $ take n v
+  unsafeTake n (VectorBag v) = VectorBag $ unsafeTake n v
+  drop n (VectorBag v) = VectorBag $ drop n v
+  unsafeDrop n (VectorBag v) = VectorBag $ unsafeDrop n v
+  partition p (VectorBag v) = bimap VectorBag VectorBag $ partition p v
diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Character.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Character.hs
new file mode 100644
index 000000000000..c18d726a4bfd
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Entities/Character.hs
@@ -0,0 +1,276 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Xanthous.Entities.Character
+  ( Character(..)
+  , characterName
+  , inventory
+  , characterDamage
+  , characterHitpoints'
+  , characterHitpoints
+  , hitpointRecoveryRate
+  , speed
+
+    -- * Inventory
+  , Inventory(..)
+  , backpack
+  , wielded
+  , items
+    -- ** Wielded items
+  , Wielded(..)
+  , hands
+  , leftHand
+  , rightHand
+  , inLeftHand
+  , inRightHand
+  , doubleHanded
+  , wieldedItems
+  , WieldedItem(..)
+  , wieldedItem
+  , wieldableItem
+  , asWieldedItem
+
+    -- *
+  , mkCharacter
+  , pickUpItem
+  , isDead
+  , damage
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Brick
+import           Data.Aeson.Generic.DerivingVia
+import           Data.Aeson (ToJSON, FromJSON)
+import           Data.Coerce (coerce)
+import           Test.QuickCheck
+import           Test.QuickCheck.Instances.Vector ()
+import           Test.QuickCheck.Arbitrary.Generic
+--------------------------------------------------------------------------------
+import           Xanthous.Util.QuickCheck
+import           Xanthous.Game.State
+import           Xanthous.Entities.Item
+import           Xanthous.Data
+                 ( TicksPerTile, Hitpoints, Per, Ticks, (|*|), positioned
+                 , Positioned(..)
+                 )
+import           Xanthous.Entities.RawTypes (WieldableItem, wieldable)
+import qualified Xanthous.Entities.RawTypes as Raw
+--------------------------------------------------------------------------------
+
+data WieldedItem = WieldedItem
+  { _wieldedItem :: Item
+  , _wieldableItem :: WieldableItem
+    -- ^ Invariant: item ^. itemType . wieldable ≡ Just wieldableItem
+  }
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           WieldedItem
+makeFieldsNoPrefix ''WieldedItem
+
+asWieldedItem :: Prism' Item WieldedItem
+asWieldedItem = prism' hither yon
+ where
+   yon item = WieldedItem item <$> item ^. itemType . wieldable
+   hither (WieldedItem item _) = item
+
+instance Brain WieldedItem where
+  step ticks (Positioned p wi) =
+    over positioned (\i -> WieldedItem i $ wi ^. wieldableItem)
+    <$> step ticks (Positioned p $ wi ^. wieldedItem)
+
+instance Draw WieldedItem where
+  draw = draw . view wieldedItem
+
+instance Entity WieldedItem where
+  entityAttributes = entityAttributes . view wieldedItem
+  description = description . view wieldedItem
+  entityChar = entityChar . view wieldedItem
+
+instance Arbitrary WieldedItem where
+  arbitrary = genericArbitrary <&> \wi ->
+    wi & wieldedItem . itemType . wieldable ?~ wi ^. wieldableItem
+
+data Wielded
+  = DoubleHanded WieldedItem
+  | Hands { _leftHand :: !(Maybe WieldedItem)
+          , _rightHand :: !(Maybe WieldedItem)
+          }
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary Wielded
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ 'SumEnc 'ObjWithSingleField ]
+           Wielded
+
+hands :: Prism' Wielded (Maybe WieldedItem, Maybe WieldedItem)
+hands = prism' (uncurry Hands) $ \case
+  Hands l r -> Just (l, r)
+  _ -> Nothing
+
+leftHand :: Traversal' Wielded WieldedItem
+leftHand = hands . _1 . _Just
+
+inLeftHand :: WieldedItem -> Wielded
+inLeftHand wi = Hands (Just wi) Nothing
+
+rightHand :: Traversal' Wielded WieldedItem
+rightHand = hands . _2 . _Just
+
+inRightHand :: WieldedItem -> Wielded
+inRightHand wi = Hands Nothing (Just wi)
+
+doubleHanded :: Prism' Wielded WieldedItem
+doubleHanded = prism' DoubleHanded $ \case
+  DoubleHanded i -> Just i
+  _ -> Nothing
+
+wieldedItems :: Traversal' Wielded WieldedItem
+wieldedItems k (DoubleHanded wielded) = DoubleHanded <$> k wielded
+wieldedItems k (Hands l r) = Hands <$> _Just k l <*> _Just k r
+
+data Inventory = Inventory
+  { _backpack :: Vector Item
+  , _wielded :: Wielded
+  }
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary Inventory
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           Inventory
+makeFieldsNoPrefix ''Inventory
+
+items :: Traversal' Inventory Item
+items k (Inventory bp w) = Inventory
+  <$> traversed k bp
+  <*> (wieldedItems . wieldedItem) k w
+
+type instance Element Inventory = Item
+
+instance MonoFunctor Inventory where
+  omap = over items
+
+instance MonoFoldable Inventory where
+  ofoldMap = foldMapOf items
+  ofoldr = foldrOf items
+  ofoldl' = foldlOf' items
+  otoList = toListOf items
+  oall = allOf items
+  oany = anyOf items
+  onull = nullOf items
+  ofoldr1Ex = foldr1Of items
+  ofoldl1Ex' = foldl1Of' items
+  headEx = headEx . toListOf items
+  lastEx = lastEx . toListOf items
+
+instance MonoTraversable Inventory where
+  otraverse = traverseOf items
+
+instance Semigroup Inventory where
+  inv₁ <> inv₂ =
+    let backpack' = inv₁ ^. backpack <> inv₂ ^. backpack
+        (wielded', backpack'') = case (inv₁ ^. wielded, inv₂ ^. wielded) of
+          (wielded₁, wielded₂@(DoubleHanded _)) ->
+            (wielded₂, backpack' <> fromList (wielded₁ ^.. wieldedItems . wieldedItem))
+          (wielded₁, wielded₂@(Hands (Just _) (Just _))) ->
+            (wielded₂, backpack' <> fromList (wielded₁ ^.. wieldedItems . wieldedItem))
+          (wielded₁, Hands Nothing Nothing) -> (wielded₁, backpack')
+          (Hands Nothing Nothing, wielded₂) -> (wielded₂, backpack')
+          (Hands (Just l₁) Nothing, Hands Nothing (Just r₂)) ->
+            (Hands (Just l₁) (Just r₂), backpack')
+          (wielded₁@(DoubleHanded _), wielded₂) ->
+            (wielded₁, backpack' <> fromList (wielded₂ ^.. wieldedItems . wieldedItem))
+          (Hands Nothing (Just r₁), Hands Nothing (Just r₂)) ->
+            (Hands Nothing (Just r₂), r₁ ^. wieldedItem <| backpack')
+          (Hands Nothing r₁, Hands (Just l₂) Nothing) ->
+            (Hands (Just l₂) r₁, backpack')
+          (Hands (Just l₁) Nothing, Hands (Just l₂) Nothing) ->
+            (Hands (Just l₂) Nothing, l₁ ^. wieldedItem <| backpack')
+          (Hands (Just l₁) (Just r₁), Hands Nothing (Just r₂)) ->
+            (Hands (Just l₁) (Just r₂), r₁ ^. wieldedItem <| backpack')
+          (Hands (Just l₁) (Just r₁), Hands (Just l₂) Nothing) ->
+            (Hands (Just l₂) (Just r₁), l₁ ^. wieldedItem <| backpack')
+    in Inventory backpack'' wielded'
+
+instance Monoid Inventory where
+  mempty = Inventory mempty $ Hands Nothing Nothing
+
+--------------------------------------------------------------------------------
+
+data Character = Character
+  { _inventory :: !Inventory
+  , _characterName :: !(Maybe Text)
+  , _characterHitpoints' :: !Double
+  , _speed :: TicksPerTile
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           Character
+makeLenses ''Character
+
+characterHitpoints :: Character -> Hitpoints
+characterHitpoints = views characterHitpoints' floor
+
+scrollOffset :: Int
+scrollOffset = 5
+
+instance Draw Character where
+  draw _ = visibleRegion rloc rreg $ str "@"
+    where
+      rloc = Location (negate scrollOffset, negate scrollOffset)
+      rreg = (2 * scrollOffset, 2 * scrollOffset)
+  drawPriority = const maxBound -- Character should always be on top, for now
+
+instance Brain Character where
+  step ticks = (pure .) $ positioned . characterHitpoints' %~ \hp ->
+    if hp > fromIntegral initialHitpoints
+    then hp
+    else hp + hitpointRecoveryRate |*| ticks
+
+instance Entity Character where
+  description _ = "yourself"
+  entityChar _ = "@"
+
+instance Arbitrary Character where
+  arbitrary = genericArbitrary
+
+initialHitpoints :: Hitpoints
+initialHitpoints = 10
+
+hitpointRecoveryRate :: Double `Per` Ticks
+hitpointRecoveryRate = 1.0 / (15 * coerce defaultSpeed)
+
+defaultSpeed :: TicksPerTile
+defaultSpeed = 100
+
+mkCharacter :: Character
+mkCharacter = Character
+  { _inventory = mempty
+  , _characterName = Nothing
+  , _characterHitpoints' = fromIntegral initialHitpoints
+  , _speed = defaultSpeed
+  }
+
+defaultCharacterDamage :: Hitpoints
+defaultCharacterDamage = 1
+
+-- | Returns the damage that the character currently does with an attack
+-- TODO use double-handed/left-hand/right-hand here
+characterDamage :: Character -> Hitpoints
+characterDamage
+  = fromMaybe defaultCharacterDamage
+  . preview (inventory . wielded . wieldedItems . wieldableItem . Raw.damage)
+
+isDead :: Character -> Bool
+isDead = (== 0) . characterHitpoints
+
+pickUpItem :: Item -> Character -> Character
+pickUpItem it = inventory . backpack %~ (it <|)
+
+damage :: Hitpoints -> Character -> Character
+damage (fromIntegral -> amount) = characterHitpoints' %~ \case
+  n | n <= amount -> 0
+    | otherwise  -> n - amount
diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Creature.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Creature.hs
new file mode 100644
index 000000000000..e95e9f0b985b
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Entities/Creature.hs
@@ -0,0 +1,92 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Creature
+  ( -- * Creature
+    Creature(..)
+    -- ** Lenses
+  , creatureType
+  , hitpoints
+  , hippocampus
+
+    -- ** Creature functions
+  , newWithType
+  , damage
+  , isDead
+  , visionRadius
+
+    -- * Hippocampus
+  , Hippocampus(..)
+    -- ** Lenses
+  , destination
+    -- ** Destination
+  , Destination(..)
+  , destinationFromPos
+    -- *** Lenses
+  , destinationPosition
+  , destinationProgress
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Test.QuickCheck
+import           Test.QuickCheck.Arbitrary.Generic
+import           Data.Aeson.Generic.DerivingVia
+import           Data.Aeson (ToJSON, FromJSON)
+--------------------------------------------------------------------------------
+import           Xanthous.AI.Gormlak
+import           Xanthous.Entities.RawTypes hiding
+                 (Creature, description, damage)
+import qualified Xanthous.Entities.RawTypes as Raw
+import           Xanthous.Game.State
+import           Xanthous.Data
+import           Xanthous.Data.Entities
+import           Xanthous.Entities.Creature.Hippocampus
+--------------------------------------------------------------------------------
+
+data Creature = Creature
+  { _creatureType :: !CreatureType
+  , _hitpoints    :: !Hitpoints
+  , _hippocampus  :: !Hippocampus
+  }
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Draw via DrawRawCharPriority "_creatureType" 1000 Creature
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       Creature
+instance Arbitrary Creature where arbitrary = genericArbitrary
+makeLenses ''Creature
+
+instance HasVisionRadius Creature where
+  visionRadius = const 50 -- TODO
+
+instance Brain Creature where
+  step = brainVia GormlakBrain
+  entityCanMove = const True
+
+instance Entity Creature where
+  entityAttributes _ = defaultEntityAttributes
+    & blocksObject .~ True
+  description = view $ creatureType . Raw.description
+  entityChar = view $ creatureType . char
+  entityCollision = const $ Just Combat
+
+--------------------------------------------------------------------------------
+
+newWithType :: CreatureType -> Creature
+newWithType _creatureType =
+  let _hitpoints = _creatureType ^. maxHitpoints
+      _hippocampus = initialHippocampus
+  in Creature {..}
+
+damage :: Hitpoints -> Creature -> Creature
+damage amount = hitpoints %~ \hp ->
+  if hp <= amount
+  then 0
+  else hp - amount
+
+isDead :: Creature -> Bool
+isDead = views hitpoints (== 0)
+
+{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-}
diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs
new file mode 100644
index 000000000000..501a5b597221
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Creature.Hippocampus
+  (-- * Hippocampus
+    Hippocampus(..)
+  , initialHippocampus
+    -- ** Lenses
+  , destination
+    -- ** Destination
+  , Destination(..)
+  , destinationFromPos
+    -- *** Lenses
+  , destinationPosition
+  , destinationProgress
+  )
+where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Data.Aeson.Generic.DerivingVia
+import           Data.Aeson (ToJSON, FromJSON)
+import           Test.QuickCheck
+import           Test.QuickCheck.Arbitrary.Generic
+--------------------------------------------------------------------------------
+import           Xanthous.Data
+import           Xanthous.Util.QuickCheck
+--------------------------------------------------------------------------------
+
+
+data Destination = Destination
+  { _destinationPosition :: !Position
+    -- | The progress towards the destination, tracked as an offset from the
+    -- creature's original position.
+    --
+    -- When this value reaches >= 1, the creature has reached their destination
+  , _destinationProgress :: !Tiles
+  }
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       Destination
+instance Arbitrary Destination where arbitrary = genericArbitrary
+makeLenses ''Destination
+
+destinationFromPos :: Position -> Destination
+destinationFromPos _destinationPosition =
+  let _destinationProgress = 0
+  in Destination{..}
+
+data Hippocampus = Hippocampus
+  { _destination :: !(Maybe Destination)
+  }
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary Hippocampus
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       Hippocampus
+makeLenses ''Hippocampus
+
+initialHippocampus :: Hippocampus
+initialHippocampus = Hippocampus Nothing
diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Draw/Util.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Draw/Util.hs
new file mode 100644
index 000000000000..aa6c5fa4fc47
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Entities/Draw/Util.hs
@@ -0,0 +1,31 @@
+module Xanthous.Entities.Draw.Util where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Brick.Widgets.Border.Style
+import Brick.Types (Edges(..))
+--------------------------------------------------------------------------------
+
+borderFromEdges :: BorderStyle -> Edges Bool -> Char
+borderFromEdges bstyle edges = ($ bstyle) $ case edges of
+  Edges False False  False False -> const '☐'
+
+  Edges True  False  False False -> bsVertical
+  Edges False True   False False -> bsVertical
+  Edges False False  True  False -> bsHorizontal
+  Edges False False  False True  -> bsHorizontal
+
+  Edges True  True   False False -> bsVertical
+  Edges True  False  True  False -> bsCornerBR
+  Edges True  False  False True  -> bsCornerBL
+
+  Edges False True   True  False -> bsCornerTR
+  Edges False True   False True  -> bsCornerTL
+  Edges False False  True  True  -> bsHorizontal
+
+  Edges False True   True  True  -> bsIntersectT
+  Edges True  False  True  True  -> bsIntersectB
+  Edges True  True   False True  -> bsIntersectL
+  Edges True  True   True  False -> bsIntersectR
+
+  Edges True  True   True  True  -> bsIntersectFull
diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs
new file mode 100644
index 000000000000..62e6e15c9853
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs
@@ -0,0 +1,60 @@
+{-# LANGUAGE StandaloneDeriving #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Entities () where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Test.QuickCheck
+import qualified Test.QuickCheck.Gen as Gen
+import           Data.Aeson
+--------------------------------------------------------------------------------
+import           Xanthous.Entities.Character
+import           Xanthous.Entities.Item
+import           Xanthous.Entities.Creature
+import           Xanthous.Entities.Environment
+import           Xanthous.Game.State
+import           Xanthous.Util.QuickCheck
+import           Data.Aeson.Generic.DerivingVia
+--------------------------------------------------------------------------------
+
+instance Arbitrary SomeEntity where
+  arbitrary = Gen.oneof
+    [ SomeEntity <$> arbitrary @Character
+    , SomeEntity <$> arbitrary @Item
+    , SomeEntity <$> arbitrary @Creature
+    , SomeEntity <$> arbitrary @Wall
+    , SomeEntity <$> arbitrary @Door
+    , SomeEntity <$> arbitrary @GroundMessage
+    , SomeEntity <$> arbitrary @Staircase
+    ]
+
+instance FromJSON SomeEntity where
+  parseJSON = withObject "Entity" $ \obj -> do
+    (entityType :: Text) <- obj .: "type"
+    case entityType of
+      "Character" -> SomeEntity @Character <$> obj .: "data"
+      "Item" -> SomeEntity @Item <$> obj .: "data"
+      "Creature" -> SomeEntity @Creature <$> obj .: "data"
+      "Wall" -> SomeEntity @Wall <$> obj .: "data"
+      "Door" -> SomeEntity @Door <$> obj .: "data"
+      "GroundMessage" -> SomeEntity @GroundMessage <$> obj .: "data"
+      "Staircase" -> SomeEntity @Staircase <$> obj .: "data"
+      _ -> fail . unpack $ "Invalid entity type \"" <> entityType <> "\""
+
+deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameLevel
+  instance FromJSON GameLevel
+deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameState
+  instance FromJSON GameState
+
+instance Entity SomeEntity where
+  entityAttributes (SomeEntity ent) = entityAttributes ent
+  description (SomeEntity ent) = description ent
+  entityChar (SomeEntity ent) = entityChar ent
+  entityCollision (SomeEntity ent) = entityCollision ent
+
+instance Function SomeEntity where
+  function = functionJSON
+
+instance CoArbitrary SomeEntity where
+  coarbitrary = coarbitrary . encode
diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs-boot b/users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs-boot
new file mode 100644
index 000000000000..519a862c6a5a
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs-boot
@@ -0,0 +1,14 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Xanthous.Entities.Entities where
+
+import Test.QuickCheck
+import Data.Aeson
+import Xanthous.Game.State (SomeEntity, GameState, Entity)
+
+instance Arbitrary SomeEntity
+instance Function SomeEntity
+instance CoArbitrary SomeEntity
+instance FromJSON SomeEntity
+instance Entity SomeEntity
+
+instance FromJSON GameState
diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Environment.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Environment.hs
new file mode 100644
index 000000000000..b45a91eabed2
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Entities/Environment.hs
@@ -0,0 +1,160 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Xanthous.Entities.Environment
+  (
+    -- * Walls
+    Wall(..)
+
+    -- * Doors
+  , Door(..)
+  , open
+  , closed
+  , locked
+  , unlockedDoor
+
+    -- * Messages
+  , GroundMessage(..)
+
+    -- * Stairs
+  , Staircase(..)
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Test.QuickCheck
+import Brick (str)
+import Brick.Widgets.Border.Style (unicode)
+import Brick.Types (Edges(..))
+import Data.Aeson
+import Data.Aeson.Generic.DerivingVia
+--------------------------------------------------------------------------------
+import Xanthous.Entities.Draw.Util
+import Xanthous.Data
+import Xanthous.Data.Entities
+import Xanthous.Game.State
+import Xanthous.Util.QuickCheck
+--------------------------------------------------------------------------------
+
+data Wall = Wall
+  deriving stock (Show, Eq, Ord, Generic, Enum)
+  deriving anyclass (NFData, CoArbitrary, Function)
+
+instance ToJSON Wall where
+  toJSON = const $ String "Wall"
+
+instance FromJSON Wall where
+  parseJSON = withText "Wall" $ \case
+    "Wall" -> pure Wall
+    _      -> fail "Invalid Wall: expected Wall"
+
+instance Brain Wall where step = brainVia Brainless
+
+instance Entity Wall where
+  entityAttributes _ = defaultEntityAttributes
+    & blocksVision .~ True
+    & blocksObject .~ True
+  description _ = "a wall"
+  entityChar _ = "┼"
+
+instance Arbitrary Wall where
+  arbitrary = pure Wall
+
+wallEdges :: (MonoFoldable mono, Element mono ~ SomeEntity)
+          => Neighbors mono -> Edges Bool
+wallEdges neighs = any (entityIs @Wall) <$> edges neighs
+
+instance Draw Wall where
+  drawWithNeighbors neighs _wall =
+    str . pure . borderFromEdges unicode $ wallEdges neighs
+
+data Door = Door
+  { _open   :: Bool
+  , _locked :: Bool
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON)
+  deriving Arbitrary via GenericArbitrary Door
+makeLenses ''Door
+
+instance Draw Door where
+  drawWithNeighbors neighs door
+    = str . pure . ($ door ^. open) $ case wallEdges neighs of
+        Edges True  False  False False -> vertDoor
+        Edges False True   False False -> vertDoor
+        Edges True  True   False False -> vertDoor
+        Edges False False  True  False -> horizDoor
+        Edges False False  False True  -> horizDoor
+        Edges False False  True  True  -> horizDoor
+        _                              -> allsidesDoor
+    where
+      horizDoor True = '␣'
+      horizDoor False = 'ᚔ'
+      vertDoor True = '['
+      vertDoor False = 'ǂ'
+      allsidesDoor True = '+'
+      allsidesDoor False = '▥'
+
+instance Brain Door where step = brainVia Brainless
+
+instance Entity Door where
+  entityAttributes door = defaultEntityAttributes
+    & blocksVision .~ not (door ^. open)
+  description door | door ^. open = "an open door"
+                   | otherwise    = "a closed door"
+  entityChar _ = "d"
+  entityCollision door | door ^. open = Nothing
+                       | otherwise = Just Stop
+
+closed :: Lens' Door Bool
+closed = open . involuted not
+
+-- | A closed, unlocked door
+unlockedDoor :: Door
+unlockedDoor = Door
+  { _open = False
+  , _locked = False
+  }
+
+--------------------------------------------------------------------------------
+
+newtype GroundMessage = GroundMessage Text
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary GroundMessage
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ 'TagSingleConstructors 'True
+                        , 'SumEnc 'ObjWithSingleField
+                        ]
+           GroundMessage
+  deriving Draw
+       via DrawStyledCharacter ('Just 'Yellow) 'Nothing "≈"
+           GroundMessage
+instance Brain GroundMessage where step = brainVia Brainless
+
+instance Entity GroundMessage where
+  description = const "a message on the ground. Press r. to read it."
+  entityChar = const "≈"
+  entityCollision = const Nothing
+
+--------------------------------------------------------------------------------
+
+data Staircase = UpStaircase | DownStaircase
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary Staircase
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ 'TagSingleConstructors 'True
+                        , 'SumEnc 'ObjWithSingleField
+                        ]
+           Staircase
+instance Brain Staircase where step = brainVia Brainless
+
+instance Draw Staircase where
+  draw UpStaircase = str "<"
+  draw DownStaircase = str ">"
+
+instance Entity Staircase where
+  description UpStaircase = "a staircase leading upwards"
+  description DownStaircase = "a staircase leading downwards"
+  entityChar UpStaircase = "<"
+  entityChar DownStaircase = ">"
+  entityCollision = const Nothing
diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Item.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Item.hs
new file mode 100644
index 000000000000..b50a5eab809d
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Entities/Item.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StandaloneDeriving #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Item
+  ( Item(..)
+  , itemType
+  , newWithType
+  , isEdible
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+import           Test.QuickCheck
+import           Data.Aeson (ToJSON, FromJSON)
+import           Data.Aeson.Generic.DerivingVia
+--------------------------------------------------------------------------------
+import           Xanthous.Entities.RawTypes hiding (Item, description, isEdible)
+import qualified Xanthous.Entities.RawTypes as Raw
+import           Xanthous.Game.State
+--------------------------------------------------------------------------------
+
+data Item = Item
+  { _itemType :: ItemType
+  }
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Draw via DrawRawChar "_itemType" Item
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       Item
+makeLenses ''Item
+
+{-# ANN Item ("HLint: ignore Use newtype instead of data" :: String )#-}
+
+-- deriving via (Brainless Item) instance Brain Item
+instance Brain Item where step = brainVia Brainless
+
+instance Arbitrary Item where
+  arbitrary = Item <$> arbitrary
+
+instance Entity Item where
+  description = view $ itemType . Raw.description
+  entityChar = view $ itemType . Raw.char
+  entityCollision = const Nothing
+
+newWithType :: ItemType -> Item
+newWithType = Item
+
+isEdible :: Item -> Bool
+isEdible = Raw.isEdible . view itemType
diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/RawTypes.hs b/users/glittershark/xanthous/src/Xanthous/Entities/RawTypes.hs
new file mode 100644
index 000000000000..30039662f071
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Entities/RawTypes.hs
@@ -0,0 +1,133 @@
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.RawTypes
+  (
+    EntityRaw(..)
+  , _Creature
+  , _Item
+
+    -- * Creatures
+  , CreatureType(..)
+  , hostile
+
+    -- * Items
+  , ItemType(..)
+    -- ** Item sub-types
+    -- *** Edible
+  , EdibleItem(..)
+  , isEdible
+    -- *** Wieldable
+  , WieldableItem(..)
+  , isWieldable
+
+    -- * Lens classes
+  , HasAttackMessage(..)
+  , HasChar(..)
+  , HasDamage(..)
+  , HasDescription(..)
+  , HasEatMessage(..)
+  , HasEdible(..)
+  , HasFriendly(..)
+  , HasHitpointsHealed(..)
+  , HasLongDescription(..)
+  , HasMaxHitpoints(..)
+  , HasName(..)
+  , HasSpeed(..)
+  , HasWieldable(..)
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+import Test.QuickCheck
+import Data.Aeson.Generic.DerivingVia
+import Data.Aeson (ToJSON, FromJSON)
+--------------------------------------------------------------------------------
+import Xanthous.Messages (Message(..))
+import Xanthous.Data (TicksPerTile, Hitpoints)
+import Xanthous.Data.EntityChar
+import Xanthous.Util.QuickCheck
+--------------------------------------------------------------------------------
+
+data CreatureType = CreatureType
+  { _name         :: !Text
+  , _description  :: !Text
+  , _char         :: !EntityChar
+  , _maxHitpoints :: !Hitpoints
+  , _friendly     :: !Bool
+  , _speed        :: !TicksPerTile
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary CreatureType
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       CreatureType
+makeFieldsNoPrefix ''CreatureType
+
+hostile :: Lens' CreatureType Bool
+hostile = friendly . involuted not
+
+--------------------------------------------------------------------------------
+
+data EdibleItem = EdibleItem
+  { _hitpointsHealed :: Int
+  , _eatMessage :: Maybe Message
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary EdibleItem
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       EdibleItem
+makeFieldsNoPrefix ''EdibleItem
+
+data WieldableItem = WieldableItem
+  { _damage :: !Hitpoints
+  , _attackMessage :: !(Maybe Message)
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary WieldableItem
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       WieldableItem
+makeFieldsNoPrefix ''WieldableItem
+
+--------------------------------------------------------------------------------
+
+data ItemType = ItemType
+  { _name            :: Text
+  , _description     :: Text
+  , _longDescription :: Text
+  , _char            :: EntityChar
+  , _edible          :: Maybe EdibleItem
+  , _wieldable       :: Maybe WieldableItem
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary ItemType
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       ItemType
+makeFieldsNoPrefix ''ItemType
+
+-- | Can this item be eaten?
+isEdible :: ItemType -> Bool
+isEdible = has $ edible . _Just
+
+-- | Can this item be used as a weapon?
+isWieldable :: ItemType -> Bool
+isWieldable = has $ wieldable . _Just
+
+--------------------------------------------------------------------------------
+
+data EntityRaw
+  = Creature CreatureType
+  | Item ItemType
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData)
+  deriving Arbitrary via GenericArbitrary EntityRaw
+  deriving (FromJSON)
+       via WithOptions '[ SumEnc ObjWithSingleField ]
+                       EntityRaw
+makePrisms ''EntityRaw
diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Raws.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Raws.hs
new file mode 100644
index 000000000000..d4cae7ccc299
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Entities/Raws.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Raws
+  ( raws
+  , raw
+  , RawType(..)
+  , rawsWithType
+  , entityFromRaw
+  ) where
+--------------------------------------------------------------------------------
+import           Data.FileEmbed
+import qualified Data.Yaml as Yaml
+import           Xanthous.Prelude
+import           System.FilePath.Posix
+--------------------------------------------------------------------------------
+import           Xanthous.Entities.RawTypes
+import           Xanthous.Game.State
+import qualified Xanthous.Entities.Creature as Creature
+import qualified Xanthous.Entities.Item as Item
+import           Xanthous.AI.Gormlak ()
+--------------------------------------------------------------------------------
+rawRaws :: [(FilePath, ByteString)]
+rawRaws = $(embedDir "src/Xanthous/Entities/Raws")
+
+raws :: HashMap Text EntityRaw
+raws
+  = mapFromList
+  . map (bimap
+         (pack . takeBaseName)
+         (either (error . Yaml.prettyPrintParseException) id
+          . Yaml.decodeEither'))
+  $ rawRaws
+
+raw :: Text -> Maybe EntityRaw
+raw n = raws ^. at n
+
+class RawType (a :: Type) where
+  _RawType :: Prism' EntityRaw a
+
+instance RawType CreatureType where
+  _RawType = prism' Creature $ \case
+    Creature c -> Just c
+    _ -> Nothing
+
+instance RawType ItemType where
+  _RawType = prism' Item $ \case
+    Item i -> Just i
+    _ -> Nothing
+
+rawsWithType :: forall a. RawType a => HashMap Text a
+rawsWithType = mapFromList . itoListOf (ifolded . _RawType) $ raws
+
+--------------------------------------------------------------------------------
+
+entityFromRaw :: EntityRaw -> SomeEntity
+entityFromRaw (Creature creatureType)
+  = SomeEntity $ Creature.newWithType creatureType
+entityFromRaw (Item itemType)
+  = SomeEntity $ Item.newWithType itemType
diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml b/users/glittershark/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml
new file mode 100644
index 000000000000..2eac895190b3
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml
@@ -0,0 +1,13 @@
+Creature:
+  name: gormlak
+  description: a gormlak
+  longDescription: |
+    A chittering imp-like creature with bright yellow horns. It adores shiny objects
+    and gathers in swarms.
+  char:
+    char: g
+    style:
+      foreground: red
+  maxHitpoints: 5
+  speed: 125
+  friendly: false
diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Raws/noodles.yaml b/users/glittershark/xanthous/src/Xanthous/Entities/Raws/noodles.yaml
new file mode 100644
index 000000000000..c3f19dce91d1
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Entities/Raws/noodles.yaml
@@ -0,0 +1,12 @@
+Item:
+  name: noodles
+  description: "a big bowl o' noodles"
+  longDescription: You know exactly what kind of noodles
+  char:
+    char: 'n'
+    style:
+      foreground: yellow
+  edible:
+    hitpointsHealed: 2
+    eatMessage:
+      - You slurp up the noodles. Yumm!
diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Raws/stick.yaml b/users/glittershark/xanthous/src/Xanthous/Entities/Raws/stick.yaml
new file mode 100644
index 000000000000..bc7fde4d8b02
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Entities/Raws/stick.yaml
@@ -0,0 +1,14 @@
+Item:
+  name: stick
+  description: a wooden stick
+  longDescription: A sturdy branch broken off from some sort of tree
+  char:
+    char: ∤
+    style:
+      foreground: yellow
+  wieldable:
+    damage: 2
+    attackMessage:
+      - You bonk the {{creature.creatureType.name}} over the head with your stick.
+      - You bash the {{creature.creatureType.name}} on the noggin with your stick.
+      - You whack the {{creature.creatureType.name}} with your stick.
diff --git a/users/glittershark/xanthous/src/Xanthous/Game.hs b/users/glittershark/xanthous/src/Xanthous/Game.hs
new file mode 100644
index 000000000000..4ca668891971
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Game.hs
@@ -0,0 +1,72 @@
+module Xanthous.Game
+  ( GameState(..)
+  , levels
+  , entities
+  , revealedPositions
+  , messageHistory
+  , randomGen
+  , promptState
+  , GamePromptState(..)
+
+  , getInitialState
+  , initialStateFromSeed
+
+  , positionedCharacter
+  , character
+  , characterPosition
+  , updateCharacterVision
+  , characterVisiblePositions
+  , entitiesAtCharacter
+
+    -- * Messages
+  , MessageHistory(..)
+  , HasMessages(..)
+  , HasTurn(..)
+  , HasDisplayedTurn(..)
+  , pushMessage
+  , previousMessage
+  , nextTurn
+
+    -- * Collisions
+  , Collision(..)
+  , collisionAt
+
+    -- * App monad
+  , AppT(..)
+
+    -- * Saving the game
+  , saveGame
+  , loadGame
+  , saved
+
+    -- * Debug State
+  , DebugState(..)
+  , debugState
+  , allRevealed
+  ) where
+--------------------------------------------------------------------------------
+import qualified Codec.Compression.Zlib as Zlib
+import           Codec.Compression.Zlib.Internal (DecompressError)
+import qualified Data.Aeson as JSON
+import           System.IO.Unsafe
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+import           Xanthous.Game.State
+import           Xanthous.Game.Lenses
+import           Xanthous.Game.Arbitrary ()
+import           Xanthous.Entities.Entities ()
+--------------------------------------------------------------------------------
+
+saveGame :: GameState -> LByteString
+saveGame = Zlib.compress . JSON.encode
+
+loadGame :: LByteString -> Maybe GameState
+loadGame = JSON.decode <=< decompressZlibMay
+  where
+    decompressZlibMay bs
+      = unsafeDupablePerformIO
+      $ (let r = Zlib.decompress bs in r `seq` pure (Just r))
+      `catch` \(_ :: DecompressError) -> pure Nothing
+
+saved :: Prism' LByteString GameState
+saved = prism' saveGame loadGame
diff --git a/users/glittershark/xanthous/src/Xanthous/Game/Arbitrary.hs b/users/glittershark/xanthous/src/Xanthous/Game/Arbitrary.hs
new file mode 100644
index 000000000000..a1eb789a33c9
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Game/Arbitrary.hs
@@ -0,0 +1,50 @@
+{-# 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.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
+    pure $ GameState {..}
+
+
+instance CoArbitrary GameLevel
+instance Function GameLevel
+instance CoArbitrary GameState
+instance Function GameState
diff --git a/users/glittershark/xanthous/src/Xanthous/Game/Draw.hs b/users/glittershark/xanthous/src/Xanthous/Game/Draw.hs
new file mode 100644
index 000000000000..b9bd8fdc039e
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Game/Draw.hs
@@ -0,0 +1,166 @@
+--------------------------------------------------------------------------------
+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           Xanthous.Data
+import           Xanthous.Data.App (ResourceName, Panel(..))
+import qualified Xanthous.Data.App as Resource
+import           Xanthous.Data.EntityMap (EntityMap, atPosition)
+import qualified Xanthous.Data.EntityMap as EntityMap
+import           Xanthous.Game.State
+import           Xanthous.Entities.Character
+import           Xanthous.Entities.Item (Item)
+import           Xanthous.Game
+                 ( GameState(..)
+                 , entities
+                 , revealedPositions
+                 , characterPosition
+                 , characterVisiblePositions
+                 , character
+                 , MessageHistory(..)
+                 , messageHistory
+                 , GamePromptState(..)
+                 , promptState
+                 , debugState, allRevealed
+                 )
+import           Xanthous.Game.Prompt
+import           Xanthous.Orphans ()
+--------------------------------------------------------------------------------
+
+cursorPosition :: GameState -> Widget ResourceName -> Widget ResourceName
+cursorPosition game
+  | WaitingPrompt _ (Prompt _ SPointOnMap (PointOnMapPromptState 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, _) ->
+      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)
+    _ -> txtWrap msg
+  where
+    drawMenuItem (chr, MenuOption m _) =
+      str ("[" <> pure chr <> "] ") <+> txtWrap m
+
+drawEntities
+  :: (Position -> Bool)
+    -- ^ Is a given position directly visible to the character?
+  -> (Position -> Bool)
+    -- ^ Has a given position *ever* been seen by the character?
+  -> EntityMap SomeEntity -- ^ all entities
+  -> Widget ResourceName
+drawEntities isVisible isRevealed allEnts
+  = vBox rows
+  where
+    entityPositions = EntityMap.positions allEnts
+    maxY = fromMaybe 0 $ maximumOf (folded . y) entityPositions
+    maxX = fromMaybe 0 $ maximumOf (folded . x) entityPositions
+    rows = mkRow <$> [0..maxY]
+    mkRow rowY = hBox $ renderEntityAt . flip Position rowY <$> [0..maxX]
+    renderEntityAt pos
+      = let entitiesAtPosition = allEnts ^. atPosition pos
+            immobileEntitiesAtPosition =
+              filter (not . entityCanMove) entitiesAtPosition
+        in renderTopEntity pos
+           $ if | isVisible  pos -> entitiesAtPosition
+                | isRevealed pos -> immobileEntitiesAtPosition
+                | otherwise      -> mempty
+    renderTopEntity pos ents
+      = let neighbors = EntityMap.neighbors pos allEnts
+        in maybe (str " ") (drawWithNeighbors neighbors)
+           $ maximumBy (compare `on` drawPriority)
+           <$> fromNullable ents
+
+drawMap :: GameState -> Widget ResourceName
+drawMap game
+  = viewport Resource.MapViewport Both
+  . cursorPosition game
+  $ drawEntities
+    (`member` characterVisiblePositions game)
+    (\pos -> (game ^. debugState . allRevealed)
+            || (pos `member` (game ^. revealedPositions)))
+    (game ^. entities)
+
+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)
+
+
+drawPanel :: GameState -> Panel -> Widget ResourceName
+drawPanel game panel
+  = border
+  . hLimit 35
+  . viewport (Resource.Panel panel) Vertical
+  . case panel of
+      InventoryPanel -> drawInventoryPanel
+  $ game
+
+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 game
+  = pure
+  . withBorderStyle unicode
+  $ case game ^. promptState of
+       NoPrompt -> drawMessages (game ^. messageHistory)
+       _ -> emptyWidget
+  <=> drawPromptState (game ^. promptState)
+  <=>
+  (maybe emptyWidget (drawPanel game) (game ^. activePanel)
+  <+> border (drawMap game)
+  )
+  <=> drawCharacterInfo (game ^. character)
diff --git a/users/glittershark/xanthous/src/Xanthous/Game/Env.hs b/users/glittershark/xanthous/src/Xanthous/Game/Env.hs
new file mode 100644
index 000000000000..6e10d0f73581
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Game/Env.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Game.Env
+  ( GameEnv(..)
+  , eventChan
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Brick.BChan (BChan)
+import Xanthous.Data.App (AppEvent)
+--------------------------------------------------------------------------------
+
+data GameEnv = GameEnv
+  { _eventChan :: BChan AppEvent
+  }
+  deriving stock (Generic)
+makeLenses ''GameEnv
+{-# ANN GameEnv ("HLint: ignore Use newtype instead of data" :: String) #-}
diff --git a/users/glittershark/xanthous/src/Xanthous/Game/Lenses.hs b/users/glittershark/xanthous/src/Xanthous/Game/Lenses.hs
new file mode 100644
index 000000000000..5d5e673c5b88
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Game/Lenses.hs
@@ -0,0 +1,131 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+--------------------------------------------------------------------------------
+module Xanthous.Game.Lenses
+  ( positionedCharacter
+  , character
+  , characterPosition
+  , updateCharacterVision
+  , characterVisiblePositions
+  , characterVisibleEntities
+  , getInitialState
+  , initialStateFromSeed
+  , entitiesAtCharacter
+
+    -- * 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           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 ()
+--------------------------------------------------------------------------------
+
+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
+        }
+      _autocommand = NoAutocommand
+  in GameState {..}
+
+
+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
+
+visionRadius :: Word
+visionRadius = 12 -- TODO make this dynamic
+
+-- | Update the revealed entities at the character's position based on their
+-- vision
+updateCharacterVision :: GameState -> GameState
+updateCharacterVision game
+  = game & revealedPositions <>~ characterVisiblePositions game
+
+characterVisiblePositions :: GameState -> Set Position
+characterVisiblePositions game =
+  let charPos = game ^. characterPosition
+  in visiblePositions charPos visionRadius $ game ^. entities
+
+characterVisibleEntities :: GameState -> EntityMap.EntityMap SomeEntity
+characterVisibleEntities game =
+  let charPos = game ^. characterPosition
+  in visibleEntities charPos visionRadius $ game ^. entities
+
+entitiesCollision
+  :: ( Functor f
+    , forall xx. MonoFoldable (f xx)
+    , forall xx. Element (f xx) ~ xx
+    , 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
diff --git a/users/glittershark/xanthous/src/Xanthous/Game/Prompt.hs b/users/glittershark/xanthous/src/Xanthous/Game/Prompt.hs
new file mode 100644
index 000000000000..30b5fe7545e0
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Game/Prompt.hs
@@ -0,0 +1,289 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DeriveFunctor #-}
+--------------------------------------------------------------------------------
+module Xanthous.Game.Prompt
+  ( PromptType(..)
+  , SPromptType(..)
+  , SingPromptType(..)
+  , PromptCancellable(..)
+  , PromptResult(..)
+  , PromptState(..)
+  , MenuOption(..)
+  , mkMenuItems
+  , PromptInput
+  , Prompt(..)
+  , mkPrompt
+  , mkMenu
+  , mkPointOnMapPrompt
+  , 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)
+import           Xanthous.Data (Direction, Position)
+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
+  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"
+
+data SPromptType :: PromptType -> Type where
+  SStringPrompt    ::      SPromptType 'StringPrompt
+  SConfirm         ::      SPromptType 'Confirm
+  SMenu            ::      SPromptType ('Menu a)
+  SDirectionPrompt ::      SPromptType 'DirectionPrompt
+  SPointOnMap      ::      SPromptType 'PointOnMap
+  SContinue        ::      SPromptType 'Continue
+
+instance NFData (SPromptType pt) where
+  rnf SStringPrompt = ()
+  rnf SConfirm = ()
+  rnf SMenu = ()
+  rnf SDirectionPrompt = ()
+  rnf SPointOnMap = ()
+  rnf SContinue = ()
+
+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 Show (SPromptType pt) where
+  show SStringPrompt    = "SStringPrompt"
+  show SConfirm         = "SConfirm"
+  show SMenu            = "SMenu"
+  show SDirectionPrompt = "SDirectionPrompt"
+  show SPointOnMap      = "SPointOnMap"
+  show SContinue        = "SContinue"
+
+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
+  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
+
+--------------------------------------------------------------------------------
+
+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
+
+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` ()
+
+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 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 ()
+
+deriving stock instance Show (PromptState pt)
+
+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 smallestNotIn $ 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 _ = ()
+
+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)
+
+-- 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 -> SPromptType pt -> (PromptResult pt -> m ()) -> Prompt m
+mkPrompt c pt@SStringPrompt cb =
+  let ps = StringPromptState $ editorText Resource.Prompt (Just 1) ""
+  in Prompt c pt ps () cb
+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
+
+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
+
+isCancellable :: Prompt m -> Bool
+isCancellable (Prompt Cancellable _ _ _ _)   = True
+isCancellable (Prompt Uncancellable _ _ _ _) = False
+
+submitPrompt :: Applicative m => Prompt m -> m ()
+submitPrompt (Prompt _ pt ps _ cb) =
+  case (pt, ps) of
+    (SStringPrompt, StringPromptState edit) ->
+      cb . StringResult . mconcat . getEditContents $ edit
+    (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
diff --git a/users/glittershark/xanthous/src/Xanthous/Game/State.hs b/users/glittershark/xanthous/src/Xanthous/Game/State.hs
new file mode 100644
index 000000000000..f614cad47339
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Game/State.hs
@@ -0,0 +1,558 @@
+{-# 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
+  , 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
+    -- ** 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.Util.QuickCheck (GenericArbitrary(..))
+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
+--------------------------------------------------------------------------------
+
+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
+
+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
+  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
+  }
+  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
diff --git a/users/glittershark/xanthous/src/Xanthous/Generators.hs b/users/glittershark/xanthous/src/Xanthous/Generators.hs
new file mode 100644
index 000000000000..9b2b90e300c7
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Generators.hs
@@ -0,0 +1,154 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE GADTs           #-}
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Generators
+  ( generate
+  , Generator(..)
+  , SGenerator(..)
+  , GeneratorInput
+  , generateFromInput
+  , parseGeneratorInput
+  , showCells
+  , Level(..)
+  , levelWalls
+  , levelItems
+  , levelCreatures
+  , levelDoors
+  , levelCharacterPosition
+  , levelTutorialMessage
+  , generateLevel
+  , levelToEntityMap
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+import           Data.Array.Unboxed
+import           System.Random (RandomGen)
+import qualified Options.Applicative as Opt
+import           Control.Monad.Random
+--------------------------------------------------------------------------------
+import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
+import qualified Xanthous.Generators.Dungeon as Dungeon
+import           Xanthous.Generators.Util
+import           Xanthous.Generators.LevelContents
+import           Xanthous.Data (Dimensions, Position'(Position), Position)
+import           Xanthous.Data.EntityMap (EntityMap, _EntityMap)
+import qualified Xanthous.Data.EntityMap as EntityMap
+import           Xanthous.Entities.Environment
+import           Xanthous.Entities.Item (Item)
+import           Xanthous.Entities.Creature (Creature)
+import           Xanthous.Game.State (SomeEntity(..))
+--------------------------------------------------------------------------------
+
+data Generator
+  = CaveAutomata
+  | Dungeon
+  deriving stock (Show, Eq)
+
+data SGenerator (gen :: Generator) where
+  SCaveAutomata :: SGenerator 'CaveAutomata
+  SDungeon :: SGenerator 'Dungeon
+
+type family Params (gen :: Generator) :: Type where
+  Params 'CaveAutomata = CaveAutomata.Params
+  Params 'Dungeon = Dungeon.Params
+
+generate
+  :: RandomGen g
+  => SGenerator gen
+  -> Params gen
+  -> Dimensions
+  -> g
+  -> Cells
+generate SCaveAutomata = CaveAutomata.generate
+generate SDungeon = Dungeon.generate
+
+data GeneratorInput where
+  GeneratorInput :: forall gen. SGenerator gen -> Params gen -> GeneratorInput
+
+generateFromInput :: RandomGen g => GeneratorInput -> Dimensions -> g -> Cells
+generateFromInput (GeneratorInput sg ps) = generate sg ps
+
+parseGeneratorInput :: Opt.Parser GeneratorInput
+parseGeneratorInput = Opt.subparser
+  $ generatorCommand SCaveAutomata
+      "cave"
+      "Cellular-automata based cave generator"
+      CaveAutomata.parseParams
+  <> generatorCommand SDungeon
+      "dungeon"
+      "Classic dungeon map generator"
+      Dungeon.parseParams
+  where
+    generatorCommand sgen name desc parseParams =
+      Opt.command name
+        (Opt.info
+          (GeneratorInput <$> pure sgen <*> parseParams)
+          (Opt.progDesc desc)
+        )
+
+
+showCells :: Cells -> Text
+showCells arr =
+  let ((minX, minY), (maxX, maxY)) = bounds arr
+      showCellVal True = "x"
+      showCellVal False = " "
+      showCell = showCellVal . (arr !)
+      row r = foldMap (showCell . (, r)) [minX..maxX]
+      rows = row <$> [minY..maxY]
+  in intercalate "\n" rows
+
+cellsToWalls :: Cells -> EntityMap Wall
+cellsToWalls cells = foldl' maybeInsertWall mempty . assocs $ cells
+  where
+    maybeInsertWall em (pos@(x, y), True)
+      | not (surroundedOnAllSides pos) =
+        let x' = fromIntegral x
+            y' = fromIntegral y
+        in EntityMap.insertAt (Position x' y') Wall em
+    maybeInsertWall em _ = em
+    surroundedOnAllSides pos = numAliveNeighbors cells pos == 8
+
+--------------------------------------------------------------------------------
+
+data Level = Level
+  { _levelWalls             :: !(EntityMap Wall)
+  , _levelDoors             :: !(EntityMap Door)
+  , _levelItems             :: !(EntityMap Item)
+  , _levelCreatures         :: !(EntityMap Creature)
+  , _levelTutorialMessage   :: !(EntityMap GroundMessage)
+  , _levelStaircases        :: !(EntityMap Staircase)
+  , _levelCharacterPosition :: !Position
+  }
+  deriving stock (Generic)
+  deriving anyclass (NFData)
+makeLenses ''Level
+
+generateLevel
+  :: MonadRandom m
+  => SGenerator gen
+  -> Params gen
+  -> Dimensions
+  -> m Level
+generateLevel gen ps dims = do
+  rand <- mkStdGen <$> getRandom
+  let cells = generate gen ps dims rand
+      _levelWalls = cellsToWalls cells
+  _levelItems <- randomItems cells
+  _levelCreatures <- randomCreatures cells
+  _levelDoors <- randomDoors cells
+  _levelCharacterPosition <- chooseCharacterPosition cells
+  let upStaircase = _EntityMap # [(_levelCharacterPosition, UpStaircase)]
+  downStaircase <- placeDownStaircase cells
+  let _levelStaircases = upStaircase <> downStaircase
+  _levelTutorialMessage <- tutorialMessage cells _levelCharacterPosition
+  pure Level {..}
+
+levelToEntityMap :: Level -> EntityMap SomeEntity
+levelToEntityMap level
+  = (SomeEntity <$> level ^. levelWalls)
+  <> (SomeEntity <$> level ^. levelDoors)
+  <> (SomeEntity <$> level ^. levelItems)
+  <> (SomeEntity <$> level ^. levelCreatures)
+  <> (SomeEntity <$> level ^. levelTutorialMessage)
+  <> (SomeEntity <$> level ^. levelStaircases)
diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs b/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs
new file mode 100644
index 000000000000..83740fe4b73d
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs
@@ -0,0 +1,110 @@
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Generators.CaveAutomata
+  ( Params(..)
+  , defaultParams
+  , parseParams
+  , generate
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+import           Control.Monad.Random (RandomGen, runRandT)
+import           Data.Array.ST
+import           Data.Array.Unboxed
+import qualified Options.Applicative as Opt
+--------------------------------------------------------------------------------
+import           Xanthous.Util (between)
+import           Xanthous.Util.Optparse
+import           Xanthous.Data (Dimensions, width, height)
+import           Xanthous.Generators.Util
+--------------------------------------------------------------------------------
+
+data Params = Params
+  { _aliveStartChance :: Double
+  , _birthLimit :: Word
+  , _deathLimit :: Word
+  , _steps :: Word
+  }
+  deriving stock (Show, Eq, Generic)
+makeLenses ''Params
+
+defaultParams :: Params
+defaultParams = Params
+  { _aliveStartChance = 0.6
+  , _birthLimit = 3
+  , _deathLimit = 4
+  , _steps = 4
+  }
+
+parseParams :: Opt.Parser Params
+parseParams = Params
+  <$> Opt.option parseChance
+      ( Opt.long "alive-start-chance"
+      <> Opt.value (defaultParams ^. aliveStartChance)
+      <> Opt.showDefault
+      <> Opt.help ( "Chance for each cell to start alive at the beginning of "
+                 <> "the cellular automata"
+                 )
+      <> Opt.metavar "CHANCE"
+      )
+  <*> Opt.option parseNeighbors
+      ( Opt.long "birth-limit"
+      <> Opt.value (defaultParams ^. birthLimit)
+      <> Opt.showDefault
+      <> Opt.help "Minimum neighbor count required for birth of a cell"
+      <> Opt.metavar "NEIGHBORS"
+      )
+  <*> Opt.option parseNeighbors
+      ( Opt.long "death-limit"
+      <> Opt.value (defaultParams ^. deathLimit)
+      <> Opt.showDefault
+      <> Opt.help "Maximum neighbor count required for death of a cell"
+      <> Opt.metavar "NEIGHBORS"
+      )
+  <*> Opt.option Opt.auto
+      ( Opt.long "steps"
+      <> Opt.value (defaultParams ^. steps)
+      <> Opt.showDefault
+      <> Opt.help "Number of generations to run the automata for"
+      <> Opt.metavar "STEPS"
+      )
+  where
+    parseChance = readWithGuard
+      (between 0 1)
+      $ \res -> "Chance must be in the range [0,1], got: " <> show res
+
+    parseNeighbors = readWithGuard
+      (between 0 8)
+      $ \res -> "Neighbors must be in the range [0,8], got: " <> show res
+
+generate :: RandomGen g => Params -> Dimensions -> g -> Cells
+generate params dims gen
+  = runSTUArray
+  $ fmap fst
+  $ flip runRandT gen
+  $ generate' params dims
+
+generate' :: RandomGen g => Params -> Dimensions -> CellM g s (MCells s)
+generate' params dims = do
+  cells <- randInitialize dims $ params ^. aliveStartChance
+  let steps' = params ^. steps
+  when (steps' > 0)
+   $ for_ [0 .. pred steps'] . const $ stepAutomata cells dims params
+  -- Remove all but the largest contiguous region of unfilled space
+  (_: smallerRegions) <- lift $ regions @UArray . amap not <$> freeze cells
+  lift $ fillAllM (fold smallerRegions) cells
+  lift $ fillOuterEdgesM cells
+  pure cells
+
+stepAutomata :: forall s g. MCells s -> Dimensions -> Params -> CellM g s ()
+stepAutomata cells dims params = do
+  origCells <- lift $ cloneMArray @_ @(STUArray s) cells
+  for_ (range ((0, 0), (dims ^. width, dims ^. height))) $ \pos -> do
+    neighs <- lift $ numAliveNeighborsM origCells pos
+    origValue <- lift $ readArray origCells pos
+    lift . writeArray cells pos
+      $ if origValue
+        then neighs >= params ^. deathLimit
+        else neighs > params ^. birthLimit
diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/Dungeon.hs b/users/glittershark/xanthous/src/Xanthous/Generators/Dungeon.hs
new file mode 100644
index 000000000000..7fde0075e64f
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Generators/Dungeon.hs
@@ -0,0 +1,191 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Generators.Dungeon
+  ( Params(..)
+  , defaultParams
+  , parseParams
+  , generate
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding ((:>))
+--------------------------------------------------------------------------------
+import           Control.Monad.Random
+import           Data.Array.ST
+import           Data.Array.IArray (amap)
+import           Data.Stream.Infinite (Stream(..))
+import qualified Data.Stream.Infinite as Stream
+import qualified Data.Graph.Inductive.Graph as Graph
+import           Data.Graph.Inductive.PatriciaTree
+import qualified Data.List.NonEmpty as NE
+import           Data.Maybe (fromJust)
+import           Linear.V2
+import           Linear.Metric
+import qualified Options.Applicative as Opt
+--------------------------------------------------------------------------------
+import           Xanthous.Random
+import           Xanthous.Data hiding (x, y, _x, _y, edges)
+import           Xanthous.Generators.Util
+import           Xanthous.Util.Graphics (delaunay, straightLine)
+import           Xanthous.Util.Graph (mstSubGraph)
+--------------------------------------------------------------------------------
+
+data Params = Params
+  { _numRoomsRange :: (Word, Word)
+  , _roomDimensionRange :: (Word, Word)
+  , _connectednessRatioRange :: (Double, Double)
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+makeLenses ''Params
+
+defaultParams :: Params
+defaultParams = Params
+  { _numRoomsRange = (6, 8)
+  , _roomDimensionRange = (3, 12)
+  , _connectednessRatioRange = (0.1, 0.15)
+  }
+
+parseParams :: Opt.Parser Params
+parseParams = Params
+  <$> parseRange
+        "num-rooms"
+        "number of rooms to generate in the dungeon"
+        "ROOMS"
+        (defaultParams ^. numRoomsRange)
+  <*> parseRange
+        "room-size"
+        "size in tiles of one of the sides of a room"
+        "TILES"
+        (defaultParams ^. roomDimensionRange)
+  <*> parseRange
+        "connectedness-ratio"
+        ( "ratio of edges from the delaunay triangulation to re-add to the "
+        <> "minimum-spanning-tree")
+        "RATIO"
+        (defaultParams ^. connectednessRatioRange)
+  <**> Opt.helper
+  where
+    parseRange name desc metavar (defMin, defMax) =
+      (,)
+      <$> Opt.option Opt.auto
+          ( Opt.long ("min-" <> name)
+          <> Opt.value defMin
+          <> Opt.showDefault
+          <> Opt.help ("Minimum " <> desc)
+          <> Opt.metavar metavar
+          )
+      <*> Opt.option Opt.auto
+          ( Opt.long ("max-" <> name)
+          <> Opt.value defMax
+          <> Opt.showDefault
+          <> Opt.help ("Maximum " <> desc)
+          <> Opt.metavar metavar
+          )
+
+generate :: RandomGen g => Params -> Dimensions -> g -> Cells
+generate params dims gen
+  = amap not
+  $ runSTUArray
+  $ fmap fst
+  $ flip runRandT gen
+  $ generate' params dims
+
+--------------------------------------------------------------------------------
+
+generate' :: RandomGen g => Params -> Dimensions -> CellM g s (MCells s)
+generate' params dims = do
+  cells <- initializeEmpty dims
+  rooms <- genRooms params dims
+  for_ rooms $ fillRoom cells
+
+  let fullRoomGraph = delaunayRoomGraph rooms
+      mst = mstSubGraph fullRoomGraph
+      mstEdges = Graph.edges mst
+      nonMSTEdges = filter (\(n₁, n₂, _) -> (n₁, n₂) `notElem` mstEdges)
+                    $ Graph.labEdges fullRoomGraph
+
+  reintroEdgeCount <- floor . (* fromIntegral (length nonMSTEdges))
+                     <$> getRandomR (params ^. connectednessRatioRange)
+  let reintroEdges = take reintroEdgeCount nonMSTEdges
+      corridorGraph = Graph.insEdges reintroEdges mst
+
+  corridors <- traverse
+              ( uncurry corridorBetween
+              . over both (fromJust . Graph.lab corridorGraph)
+              ) $ Graph.edges corridorGraph
+
+  for_ (join corridors) $ \pt -> lift $ writeArray cells pt True
+
+  pure cells
+
+type Room = Box Word
+
+genRooms :: MonadRandom m => Params -> Dimensions -> m [Room]
+genRooms params dims = do
+  numRooms <- fromIntegral <$> getRandomR (params ^. numRoomsRange)
+  subRand . fmap (Stream.take numRooms . removeIntersecting []) . infinitely $ do
+    roomWidth <- getRandomR $ params ^. roomDimensionRange
+    roomHeight <- getRandomR $ params ^. roomDimensionRange
+    xPos <- getRandomR (0, dims ^. width - roomWidth)
+    yPos <- getRandomR (0, dims ^. height - roomHeight)
+    pure Box
+      { _topLeftCorner = V2 xPos yPos
+      , _dimensions = V2 roomWidth roomHeight
+      }
+  where
+    removeIntersecting seen (room :> rooms)
+      | any (boxIntersects room) seen
+      = removeIntersecting seen rooms
+      | otherwise
+      = room :> removeIntersecting (room : seen) rooms
+    streamRepeat x = x :> streamRepeat x
+    infinitely = sequence . streamRepeat
+
+delaunayRoomGraph :: [Room] -> Gr Room Double
+delaunayRoomGraph rooms =
+  Graph.insEdges edges . Graph.insNodes nodes $ Graph.empty
+  where
+    edges = map (\((n₁, room₁), (n₂, room₂)) -> (n₁, n₂, roomDist room₁ room₂))
+          . over (mapped . both) snd
+          . delaunay @Double
+          . NE.fromList
+          . map (\p@(_, room) -> (boxCenter $ fromIntegral <$> room, p))
+          $ nodes
+    nodes = zip [0..] rooms
+    roomDist = distance `on` (boxCenter . fmap fromIntegral)
+
+fillRoom :: MCells s -> Room -> CellM g s ()
+fillRoom cells room =
+  let V2 posx posy = room ^. topLeftCorner
+      V2 dimx dimy = room ^. dimensions
+  in for_ [posx .. posx + dimx] $ \x ->
+       for_ [posy .. posy + dimy] $ \y ->
+         lift $ writeArray cells (x, y) True
+
+corridorBetween :: MonadRandom m => Room -> Room -> m [(Word, Word)]
+corridorBetween originRoom destinationRoom
+  = straightLine <$> origin <*> destination
+  where
+    origin = choose . NE.fromList . map toTuple =<< originEdge
+    destination = choose . NE.fromList . map toTuple =<< destinationEdge
+    originEdge = pickEdge originRoom originCorner
+    destinationEdge = pickEdge destinationRoom destinationCorner
+    pickEdge room corner = choose . over both (boxEdge room) $ cornerEdges corner
+    originCorner =
+      case ( compare (originRoom ^. topLeftCorner . _x)
+                     (destinationRoom ^. topLeftCorner . _x)
+           , compare (originRoom ^. topLeftCorner . _y)
+                     (destinationRoom ^. topLeftCorner . _y)
+           ) of
+        (LT, LT) -> BottomRight
+        (LT, GT) -> TopRight
+        (GT, LT) -> BottomLeft
+        (GT, GT) -> TopLeft
+
+        (EQ, LT) -> BottomLeft
+        (EQ, GT) -> TopRight
+        (GT, EQ) -> TopLeft
+        (LT, EQ) -> BottomRight
+        (EQ, EQ) -> TopLeft -- should never happen
+
+    destinationCorner = opposite originCorner
+    toTuple (V2 x y) = (x, y)
diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/LevelContents.hs b/users/glittershark/xanthous/src/Xanthous/Generators/LevelContents.hs
new file mode 100644
index 000000000000..ed4cc87e79d7
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Generators/LevelContents.hs
@@ -0,0 +1,130 @@
+--------------------------------------------------------------------------------
+module Xanthous.Generators.LevelContents
+  ( chooseCharacterPosition
+  , randomItems
+  , randomCreatures
+  , randomDoors
+  , placeDownStaircase
+  , tutorialMessage
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding (any, toList)
+--------------------------------------------------------------------------------
+import           Control.Monad.Random
+import           Data.Array.IArray (amap, bounds, rangeSize, (!))
+import qualified Data.Array.IArray as Arr
+import           Data.Foldable (any, toList)
+--------------------------------------------------------------------------------
+import           Xanthous.Generators.Util
+import           Xanthous.Random
+import           Xanthous.Data ( Position, _Position, positionFromPair
+                               , rotations, arrayNeighbors, Neighbors(..)
+                               , neighborPositions
+                               )
+import           Xanthous.Data.EntityMap (EntityMap, _EntityMap)
+import           Xanthous.Entities.Raws (rawsWithType, RawType)
+import qualified Xanthous.Entities.Item as Item
+import           Xanthous.Entities.Item (Item)
+import qualified Xanthous.Entities.Creature as Creature
+import           Xanthous.Entities.Creature (Creature)
+import           Xanthous.Entities.Environment
+                 (GroundMessage(..), Door(..), unlockedDoor, Staircase(..))
+import           Xanthous.Messages (message_)
+import           Xanthous.Util.Graphics (circle)
+--------------------------------------------------------------------------------
+
+chooseCharacterPosition :: MonadRandom m => Cells -> m Position
+chooseCharacterPosition = randomPosition
+
+randomItems :: MonadRandom m => Cells -> m (EntityMap Item)
+randomItems = randomEntities Item.newWithType (0.0004, 0.001)
+
+placeDownStaircase :: MonadRandom m => Cells -> m (EntityMap Staircase)
+placeDownStaircase cells = do
+  pos <- randomPosition cells
+  pure $ _EntityMap # [(pos, DownStaircase)]
+
+randomDoors :: MonadRandom m => Cells -> m (EntityMap Door)
+randomDoors cells = do
+  doorRatio <- getRandomR subsetRange
+  let numDoors = floor $ doorRatio * fromIntegral (length candidateCells)
+      doorPositions =
+        removeAdjacent . fmap positionFromPair . take numDoors $ candidateCells
+      doors = zip doorPositions $ repeat unlockedDoor
+  pure $ _EntityMap # doors
+  where
+    removeAdjacent =
+      foldr (\pos acc ->
+               if pos `elem` (acc >>= toList . neighborPositions)
+               then acc
+               else pos : acc
+            ) []
+    candidateCells = filter doorable $ Arr.indices cells
+    subsetRange = (0.8 :: Double, 1.0)
+    doorable pos =
+      not (fromMaybe True $ cells ^? ix pos)
+      && any (teeish . fmap (fromMaybe True))
+        (rotations $ arrayNeighbors cells pos)
+    -- only generate doors at the *ends* of hallways, eg (where O is walkable,
+    -- X is a wall, and D is a door):
+    --
+    -- O O O
+    -- X D X
+    --   O
+    teeish (fmap not -> (Neighbors tl t tr l r _ b _ )) =
+      and [tl, t, tr, b] && (and . fmap not) [l, r]
+
+randomCreatures :: MonadRandom m => Cells -> m (EntityMap Creature)
+randomCreatures = randomEntities Creature.newWithType (0.0007, 0.002)
+
+tutorialMessage :: MonadRandom m
+  => Cells
+  -> Position -- ^ CharacterPosition
+  -> m (EntityMap GroundMessage)
+tutorialMessage cells characterPosition = do
+  let distance = 2
+  pos <- fmap (fromMaybe (error "No valid positions for tutorial message?"))
+        . choose . ChooseElement
+        $ accessiblePositionsWithin distance cells characterPosition
+  msg <- message_ ["tutorial", "message1"]
+  pure $ _EntityMap # [(pos, GroundMessage msg)]
+  where
+    accessiblePositionsWithin :: Int -> Cells -> Position -> [Position]
+    accessiblePositionsWithin dist valid pos =
+      review _Position
+      <$> filter (\(px, py) -> not $ valid ! (fromIntegral px, fromIntegral py))
+          (circle (pos ^. _Position) dist)
+
+randomEntities
+  :: forall entity raw m. (MonadRandom m, RawType raw)
+  => (raw -> entity)
+  -> (Float, Float)
+  -> Cells
+  -> m (EntityMap entity)
+randomEntities newWithType sizeRange cells =
+  case fromNullable $ rawsWithType @raw of
+    Nothing -> pure mempty
+    Just raws -> do
+      let len = rangeSize $ bounds cells
+      (numEntities :: Int) <-
+        floor . (* fromIntegral len) <$> getRandomR sizeRange
+      entities <- for [0..numEntities] $ const $ do
+        pos <- randomPosition cells
+        raw <- choose raws
+        let entity = newWithType raw
+        pure (pos, entity)
+      pure $ _EntityMap # entities
+
+randomPosition :: MonadRandom m => Cells -> m Position
+randomPosition = fmap positionFromPair . choose . impureNonNull . cellCandidates
+
+-- cellCandidates :: Cells -> Cells
+cellCandidates :: Cells -> Set (Word, Word)
+cellCandidates
+  -- find the largest contiguous region of cells in the cave.
+  = maximumBy (compare `on` length)
+  . fromMaybe (error "No regions generated! this should never happen.")
+  . fromNullable
+  . regions
+  -- cells ends up with true = wall, we want true = can put an item here
+  . amap not
diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs b/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs
new file mode 100644
index 000000000000..cdac568e40a0
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs
@@ -0,0 +1,221 @@
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+--------------------------------------------------------------------------------
+module Xanthous.Generators.Util
+  ( MCells
+  , Cells
+  , CellM
+  , randInitialize
+  , initializeEmpty
+  , numAliveNeighborsM
+  , numAliveNeighbors
+  , fillOuterEdgesM
+  , cloneMArray
+  , floodFill
+  , regions
+  , fillAll
+  , fillAllM
+  , fromPoints
+  , fromPointsM
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding (Foldable, toList, for_)
+import           Data.Array.ST
+import           Data.Array.Unboxed
+import           Control.Monad.ST
+import           Control.Monad.Random
+import           Data.Monoid
+import           Data.Foldable (Foldable, toList, for_)
+import qualified Data.Set as Set
+import           Data.Semigroup.Foldable
+--------------------------------------------------------------------------------
+import           Xanthous.Util (foldlMapM', maximum1, minimum1)
+import           Xanthous.Data (Dimensions, width, height)
+--------------------------------------------------------------------------------
+
+type MCells s = STUArray s (Word, Word) Bool
+type Cells = UArray (Word, Word) Bool
+type CellM g s a = RandT g (ST s) a
+
+randInitialize :: RandomGen g => Dimensions -> Double -> CellM g s (MCells s)
+randInitialize dims aliveChance = do
+  res <- initializeEmpty dims
+  for_ [0..dims ^. width] $ \i ->
+    for_ [0..dims ^. height] $ \j -> do
+      val <- (>= aliveChance) <$> getRandomR (0, 1)
+      lift $ writeArray res (i, j) val
+  pure res
+
+initializeEmpty :: RandomGen g => Dimensions -> CellM g s (MCells s)
+initializeEmpty dims =
+  lift $ newArray ((0, 0), (dims ^. width, dims ^. height)) False
+
+numAliveNeighborsM
+  :: forall a i j m
+  . (MArray a Bool m, Ix (i, j), Integral i, Integral j)
+  => a (i, j) Bool
+  -> (i, j)
+  -> m Word
+numAliveNeighborsM cells (x, y) = do
+  cellBounds <- getBounds cells
+  getSum <$> foldlMapM'
+    (fmap (Sum . fromIntegral . fromEnum) . boundedGet cellBounds)
+    neighborPositions
+
+  where
+    boundedGet :: ((i, j), (i, j)) -> (Int, Int) -> m Bool
+    boundedGet ((minX, minY), (maxX, maxY)) (i, j)
+      | x <= minX
+        || y <= minY
+        || x >= maxX
+        || y >= maxY
+      = pure True
+      | otherwise =
+        let nx = fromIntegral $ fromIntegral x + i
+            ny = fromIntegral $ fromIntegral y + j
+        in readArray cells (nx, ny)
+
+    neighborPositions :: [(Int, Int)]
+    neighborPositions = [(i, j) | i <- [-1..1], j <- [-1..1], (i, j) /= (0, 0)]
+
+numAliveNeighbors
+  :: forall a i j
+  . (IArray a Bool, Ix (i, j), Integral i, Integral j)
+  => a (i, j) Bool
+  -> (i, j)
+  -> Word
+numAliveNeighbors cells (x, y) =
+  let cellBounds = bounds cells
+  in getSum $ foldMap
+      (Sum . fromIntegral . fromEnum . boundedGet cellBounds)
+      neighborPositions
+
+  where
+    boundedGet :: ((i, j), (i, j)) -> (Int, Int) -> Bool
+    boundedGet ((minX, minY), (maxX, maxY)) (i, j)
+      | x <= minX
+        || y <= minY
+        || x >= maxX
+        || y >= maxY
+      = True
+      | otherwise =
+        let nx = fromIntegral $ fromIntegral x + i
+            ny = fromIntegral $ fromIntegral y + j
+        in cells ! (nx, ny)
+
+    neighborPositions :: [(Int, Int)]
+    neighborPositions = [(i, j) | i <- [-1..1], j <- [-1..1], (i, j) /= (0, 0)]
+
+fillOuterEdgesM :: (MArray a Bool m, Ix i, Ix j) => a (i, j) Bool -> m ()
+fillOuterEdgesM arr = do
+  ((minX, minY), (maxX, maxY)) <- getBounds arr
+  for_ (range (minX, maxX)) $ \x -> do
+    writeArray arr (x, minY) True
+    writeArray arr (x, maxY) True
+  for_ (range (minY, maxY)) $ \y -> do
+    writeArray arr (minX, y) True
+    writeArray arr (maxX, y) True
+
+cloneMArray
+  :: forall a a' i e m.
+  ( Ix i
+  , MArray a e m
+  , MArray a' e m
+  , IArray UArray e
+  )
+  => a i e
+  -> m (a' i e)
+cloneMArray = thaw @_ @UArray <=< freeze
+
+--------------------------------------------------------------------------------
+
+-- | Flood fill a cell array starting at a point, returning a list of all the
+-- (true) cell locations reachable from that point
+floodFill :: forall a i j.
+            ( IArray a Bool
+            , Ix (i, j)
+            , Enum i , Enum j
+            , Bounded i , Bounded j
+            , Eq i , Eq j
+            , Show i, Show j
+            )
+          => a (i, j) Bool -- ^ array
+          -> (i, j)        -- ^ position
+          -> Set (i, j)
+floodFill = go mempty
+  where
+    go :: Set (i, j) -> a (i, j) Bool -> (i, j) -> Set (i, j)
+    -- TODO pass result in rather than passing seen in, return result
+    go res arr@(bounds -> arrBounds) idx@(x, y)
+      | not (inRange arrBounds idx) =  res
+      | not (arr ! idx) =  res
+      | otherwise =
+        let neighbors
+              = filter (inRange arrBounds)
+              . filter (/= idx)
+              . filter (`notMember` res)
+              $ (,)
+              <$> [(if x == minBound then x else pred x)
+                   ..
+                   (if x == maxBound then x else succ x)]
+              <*> [(if y == minBound then y else pred y)
+                   ..
+                   (if y == maxBound then y else succ y)]
+        in foldl' (\r idx' ->
+                     if arr ! idx'
+                     then r <> go (r & contains idx' .~ True) arr idx'
+                     else r)
+           (res & contains idx .~ True) neighbors
+
+-- | Gives a list of all the disconnected regions in a cell array, represented
+-- each as lists of points
+regions :: forall a i j.
+          ( IArray a Bool
+          , Ix (i, j)
+          , Enum i , Enum j
+          , Bounded i , Bounded j
+          , Eq i , Eq j
+          , Show i, Show j
+          )
+        => a (i, j) Bool
+        -> [Set (i, j)]
+regions arr
+  | Just firstPoint <- findFirstPoint arr =
+      let region = floodFill arr firstPoint
+          arr' = fillAll region arr
+      in region : regions arr'
+  | otherwise = []
+  where
+    findFirstPoint :: a (i, j) Bool -> Maybe (i, j)
+    findFirstPoint = fmap fst . headMay . filter snd . assocs
+
+fillAll :: (IArray a Bool, Ix i, Foldable f) => f i -> a i Bool -> a i Bool
+fillAll ixes a = accum (const fst) a $ (, (False, ())) <$> toList ixes
+
+fillAllM :: (MArray a Bool m, Ix i, Foldable f) => f i -> a i Bool -> m ()
+fillAllM ixes a = for_ ixes $ \i -> writeArray a i False
+
+fromPoints
+  :: forall a f i.
+    ( IArray a Bool
+    , Ix i
+    , Functor f
+    , Foldable1 f
+    )
+  => f (i, i)
+  -> a (i, i) Bool
+fromPoints points =
+  let pts = Set.fromList $ toList points
+      dims = ( (minimum1 $ fst <$> points, minimum1 $ snd <$> points)
+             , (maximum1 $ fst <$> points, maximum1 $ snd <$> points)
+             )
+  in array dims $ range dims <&> \i -> (i, i `member` pts)
+
+fromPointsM
+  :: (MArray a Bool m, Ix i, Element f ~ i, MonoFoldable f)
+  => NonNull f
+  -> m (a i Bool)
+fromPointsM points = do
+  arr <- newArray (minimum points, maximum points) False
+  fillAllM (otoList points) arr
+  pure arr
diff --git a/users/glittershark/xanthous/src/Xanthous/Messages.hs b/users/glittershark/xanthous/src/Xanthous/Messages.hs
new file mode 100644
index 000000000000..2b1b3da1e8c1
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Messages.hs
@@ -0,0 +1,107 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Messages
+  ( Message(..)
+  , resolve
+  , MessageMap(..)
+  , lookupMessage
+
+    -- * Game messages
+  , messages
+  , render
+  , lookup
+  , message
+  , message_
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude hiding (lookup)
+--------------------------------------------------------------------------------
+import           Control.Monad.Random.Class (MonadRandom)
+import           Data.Aeson (FromJSON, ToJSON, toJSON)
+import qualified Data.Aeson as JSON
+import           Data.Aeson.Generic.DerivingVia
+import           Data.FileEmbed
+import           Data.List.NonEmpty
+import           Test.QuickCheck hiding (choose)
+import           Test.QuickCheck.Arbitrary.Generic
+import           Test.QuickCheck.Instances.UnorderedContainers ()
+import           Text.Mustache
+import qualified Data.Yaml as Yaml
+--------------------------------------------------------------------------------
+import           Xanthous.Random
+import           Xanthous.Orphans ()
+--------------------------------------------------------------------------------
+
+data Message = Single Template | Choice (NonEmpty Template)
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (CoArbitrary, Function, NFData)
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ SumEnc UntaggedVal ]
+           Message
+
+instance Arbitrary Message where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
+resolve :: MonadRandom m => Message -> m Template
+resolve (Single t) = pure t
+resolve (Choice ts) = choose ts
+
+data MessageMap = Direct Message | Nested (HashMap Text MessageMap)
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (CoArbitrary, Function, NFData)
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ SumEnc UntaggedVal ]
+           MessageMap
+
+instance Arbitrary MessageMap where
+  arbitrary = frequency [ (10, Direct <$> arbitrary)
+                        , (1, Nested <$> arbitrary)
+                        ]
+
+lookupMessage :: [Text] -> MessageMap -> Maybe Message
+lookupMessage [] (Direct msg) = Just msg
+lookupMessage (k:ks) (Nested m) = lookupMessage ks =<< m ^. at k
+lookupMessage _ _ = Nothing
+
+type instance Index MessageMap = [Text]
+type instance IxValue MessageMap = Message
+instance Ixed MessageMap where
+  ix [] f (Direct msg) = Direct <$> f msg
+  ix (k:ks) f (Nested m) = case m ^. at k of
+    Just m' -> ix ks f m' <&> \m'' ->
+      Nested $ m & at k ?~ m''
+    Nothing -> pure $ Nested m
+  ix _ _ m = pure m
+
+--------------------------------------------------------------------------------
+
+rawMessages :: ByteString
+rawMessages = $(embedFile "src/Xanthous/messages.yaml")
+
+messages :: MessageMap
+messages
+  = either (error . Yaml.prettyPrintParseException) id
+  $ Yaml.decodeEither' rawMessages
+
+render :: (MonadRandom m, ToJSON params) => Message -> params -> m Text
+render msg params = do
+  tpl <- resolve msg
+  pure . toStrict . renderMustache tpl $ toJSON params
+
+lookup :: [Text] -> Message
+lookup path = fromMaybe notFound $ messages ^? ix path
+  where notFound
+          = Single
+          $ compileMustacheText "template" "Message not found"
+          ^?! _Right
+
+message :: (MonadRandom m, ToJSON params) => [Text] -> params -> m Text
+message path params = maybe notFound (`render` params) $ messages ^? ix path
+  where
+    notFound = pure "Message not found"
+
+message_ :: (MonadRandom m) => [Text] -> m Text
+message_ path = maybe notFound (`render` JSON.object []) $ messages ^? ix path
+  where
+    notFound = pure "Message not found"
diff --git a/users/glittershark/xanthous/src/Xanthous/Messages/Template.hs b/users/glittershark/xanthous/src/Xanthous/Messages/Template.hs
new file mode 100644
index 000000000000..0f47729d6871
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Messages/Template.hs
@@ -0,0 +1,275 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+--------------------------------------------------------------------------------
+module Xanthous.Messages.Template
+  ( -- * Template AST
+    Template(..)
+  , Substitution(..)
+  , Filter(..)
+
+    -- ** Template AST transformations
+  , reduceTemplate
+
+    -- * Template parser
+  , template
+  , runParser
+  , errorBundlePretty
+
+    -- * Template pretty-printer
+  , ppTemplate
+
+    -- * Rendering templates
+  , TemplateVar(..)
+  , nested
+  , TemplateVars(..)
+  , vars
+  , RenderError
+  , render
+  )
+where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding
+                 (many, concat, try, elements, some, parts)
+--------------------------------------------------------------------------------
+import           Test.QuickCheck hiding (label)
+import           Test.QuickCheck.Instances.Text ()
+import           Test.QuickCheck.Instances.Semigroup ()
+import           Test.QuickCheck.Checkers (EqProp)
+import           Control.Monad.Combinators.NonEmpty
+import           Data.List.NonEmpty (NonEmpty(..))
+import           Data.Data
+import           Text.Megaparsec hiding (sepBy1, some)
+import           Text.Megaparsec.Char
+import qualified Text.Megaparsec.Char.Lexer as L
+import           Data.Function (fix)
+--------------------------------------------------------------------------------
+import Xanthous.Util (EqEqProp(..))
+--------------------------------------------------------------------------------
+
+genIdentifier :: Gen Text
+genIdentifier = pack <$> listOf1 (elements identifierChars)
+
+identifierChars :: String
+identifierChars = ['a'..'z'] <> ['A'..'Z'] <> ['-', '_']
+
+newtype Filter = FilterName Text
+  deriving stock (Show, Eq, Ord, Generic, Data)
+  deriving anyclass (NFData)
+  deriving (IsString) via Text
+
+instance Arbitrary Filter where
+  arbitrary = FilterName <$> genIdentifier
+  shrink (FilterName fn) = fmap FilterName . filter (not . null) $ shrink fn
+
+data Substitution
+  = SubstPath (NonEmpty Text)
+  | SubstFilter Substitution Filter
+  deriving stock (Show, Eq, Ord, Generic, Data)
+  deriving anyclass (NFData)
+
+instance Arbitrary Substitution where
+  arbitrary = sized . fix $ \gen n ->
+    let leaves =
+          [ SubstPath <$> ((:|) <$> genIdentifier <*> listOf genIdentifier)]
+        subtree = gen $ n `div` 2
+    in if n == 0
+       then oneof leaves
+       else oneof $ leaves <> [ SubstFilter <$> subtree <*> arbitrary ]
+  shrink (SubstPath pth) =
+    fmap SubstPath
+    . filter (not . any ((||) <$> null <*> any (`notElem` identifierChars)))
+    $ shrink pth
+  shrink (SubstFilter s f)
+    = shrink s
+    <> (uncurry SubstFilter <$> shrink (s, f))
+
+data Template
+  = Literal Text
+  | Subst Substitution
+  | Concat Template Template
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
+  deriving EqProp via EqEqProp Template
+
+instance Plated Template where
+  plate _ tpl@(Literal _) = pure tpl
+  plate _ tpl@(Subst _) = pure tpl
+  plate f (Concat tpl₁ tpl₂) = Concat <$> f tpl₁ <*> f tpl₂
+
+reduceTemplate :: Template -> Template
+reduceTemplate = transform $ \case
+  (Concat (Literal t₁) (Literal t₂)) -> Literal (t₁ <> t₂)
+  (Concat (Literal "") t) -> t
+  (Concat t (Literal "")) -> t
+  (Concat t₁ (Concat t₂ t₃)) -> Concat (Concat t₁ t₂) t₃
+  (Concat (Concat t₁ (Literal t₂)) (Literal t₃)) -> (Concat t₁ (Literal $ t₂ <> t₃))
+  t -> t
+
+instance Eq Template where
+  tpl₁ == tpl₂ = case (reduceTemplate tpl₁, reduceTemplate tpl₂) of
+    (Literal t₁, Literal t₂) -> t₁ == t₂
+    (Subst s₁, Subst s₂) -> s₁ == s₂
+    (Concat ta₁ ta₂, Concat tb₁ tb₂) -> ta₁ == tb₁ && ta₂ == tb₂
+    _ -> False
+
+instance Arbitrary Template where
+  arbitrary = sized . fix $ \gen n ->
+    let leaves = [ Literal . filter (`notElem` ['\\', '{']) <$> arbitrary
+                 , Subst <$> arbitrary
+                 ]
+        subtree = gen $ n `div` 2
+        genConcat = Concat <$> subtree <*> subtree
+    in if n == 0
+       then oneof leaves
+       else oneof $ genConcat : leaves
+  shrink (Literal t) = Literal <$> shrink t
+  shrink (Subst s) = Subst <$> shrink s
+  shrink (Concat t₁ t₂)
+    = shrink t₁
+    <> shrink t₂
+    <> (Concat <$> shrink t₁ <*> shrink t₂)
+
+instance Semigroup Template where
+  (<>) = Concat
+
+instance Monoid Template where
+  mempty = Literal ""
+
+--------------------------------------------------------------------------------
+
+type Parser = Parsec Void Text
+
+sc :: Parser ()
+sc = L.space space1 empty empty
+
+lexeme :: Parser a -> Parser a
+lexeme = L.lexeme sc
+
+symbol :: Text -> Parser Text
+symbol = L.symbol sc
+
+identifier :: Parser Text
+identifier = lexeme . label "identifier" $ do
+  firstChar <- letterChar <|> oneOf ['-', '_']
+  restChars <- many $ alphaNumChar <|> oneOf ['-', '_']
+  pure $ firstChar <| pack restChars
+
+filterName :: Parser Filter
+filterName = FilterName <$> identifier
+
+substitutionPath :: Parser Substitution
+substitutionPath = SubstPath <$> sepBy1 identifier (char '.')
+
+substitutionFilter :: Parser Substitution
+substitutionFilter = do
+  path <- substitutionPath
+  fs <- some $ symbol "|" *> filterName
+  pure $ foldl' SubstFilter path fs
+  -- pure $ SubstFilter path f
+
+substitutionContents :: Parser Substitution
+substitutionContents
+  =   try substitutionFilter
+  <|> substitutionPath
+
+substitution :: Parser Substitution
+substitution = between (string "{{") (string "}}") substitutionContents
+
+literal :: Parser Template
+literal = Literal <$>
+  (   (string "\\{" $> "{")
+  <|> takeWhile1P Nothing (`notElem` ['\\', '{'])
+  )
+
+subst :: Parser Template
+subst = Subst <$> substitution
+
+template' :: Parser Template
+template' = do
+  parts <- many $ literal <|> subst
+  pure $ foldr Concat (Literal "") parts
+
+
+template :: Parser Template
+template = reduceTemplate <$> template' <* eof
+
+--------------------------------------------------------------------------------
+
+ppSubstitution :: Substitution -> Text
+ppSubstitution (SubstPath substParts) = intercalate "." substParts
+ppSubstitution (SubstFilter s (FilterName f)) = ppSubstitution s <> " | " <> f
+
+ppTemplate :: Template -> Text
+ppTemplate (Literal txt) = txt
+ppTemplate (Subst s) = "{{" <> ppSubstitution s <> "}}"
+ppTemplate (Concat tpl₁ tpl₂) = ppTemplate tpl₁ <> ppTemplate tpl₂
+
+--------------------------------------------------------------------------------
+
+data TemplateVar
+  = Val Text
+  | Nested (Map Text TemplateVar)
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData)
+
+nested :: [(Text, TemplateVar)] -> TemplateVar
+nested = Nested . mapFromList
+
+instance Arbitrary TemplateVar where
+  arbitrary = sized . fix $ \gen n ->
+    let nst = fmap mapFromList . listOf $ (,) <$> arbitrary <*> gen (n `div` 2)
+    in if n == 0
+       then Val <$> arbitrary
+       else oneof [ Val <$> arbitrary
+                  , Nested <$> nst]
+
+newtype TemplateVars = Vars { getTemplateVars :: Map Text TemplateVar }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData)
+  deriving (Arbitrary) via (Map Text TemplateVar)
+
+type instance Index TemplateVars = Text
+type instance IxValue TemplateVars = TemplateVar
+instance Ixed TemplateVars where
+  ix k f (Vars vs) = Vars <$> ix k f vs
+instance At TemplateVars where
+  at k f (Vars vs) = Vars <$> at k f vs
+
+vars :: [(Text, TemplateVar)] -> TemplateVars
+vars = Vars . mapFromList
+
+lookupVar :: TemplateVars -> NonEmpty Text -> Maybe TemplateVar
+lookupVar vs (p :| []) = vs ^. at p
+lookupVar vs (p :| (p₁ : ps)) = vs ^. at p >>= \case
+  (Val _) -> Nothing
+  (Nested vs') -> lookupVar (Vars vs') $ p₁ :| ps
+
+data RenderError
+  = NoSuchVariable (NonEmpty Text)
+  | NestedFurther (NonEmpty Text)
+  | NoSuchFilter Filter
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData)
+
+renderSubst
+  :: Map Filter (Text -> Text) -- ^ Filters
+  -> TemplateVars
+  -> Substitution
+  -> Either RenderError Text
+renderSubst _ vs (SubstPath pth) =
+  case lookupVar vs pth of
+    Just (Val v) -> Right v
+    Just (Nested _) -> Left $ NestedFurther pth
+    Nothing -> Left $ NoSuchVariable pth
+renderSubst fs vs (SubstFilter s fn) =
+  case fs ^. at fn of
+    Just filterFn -> filterFn <$> renderSubst fs vs s
+    Nothing -> Left $ NoSuchFilter fn
+
+render
+  :: Map Filter (Text -> Text) -- ^ Filters
+  -> TemplateVars             -- ^ Template variables
+  -> Template                 -- ^ Template
+  -> Either RenderError Text
+render _ _ (Literal s) = pure s
+render fs vs (Concat t₁ t₂) = (<>) <$> render fs vs t₁ <*> render fs vs t₂
+render fs vs (Subst s) = renderSubst fs vs s
diff --git a/users/glittershark/xanthous/src/Xanthous/Monad.hs b/users/glittershark/xanthous/src/Xanthous/Monad.hs
new file mode 100644
index 000000000000..db602de56f3a
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Monad.hs
@@ -0,0 +1,76 @@
+--------------------------------------------------------------------------------
+module Xanthous.Monad
+  ( AppT(..)
+  , AppM
+  , runAppT
+  , continue
+  , halt
+
+    -- * Messages
+  , say
+  , say_
+  , message
+  , message_
+  , writeMessage
+
+    -- * Autocommands
+  , cancelAutocommand
+
+    -- * Events
+  , sendEvent
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+import           Control.Monad.Random
+import           Control.Monad.State
+import qualified Brick
+import           Brick (EventM, Next)
+import           Brick.BChan (writeBChan)
+import           Data.Aeson (ToJSON, object)
+--------------------------------------------------------------------------------
+import           Xanthous.Data.App (AppEvent)
+import           Xanthous.Game.State
+import           Xanthous.Game.Env
+import           Xanthous.Messages (Message)
+import qualified Xanthous.Messages as Messages
+--------------------------------------------------------------------------------
+
+halt :: AppT (EventM n) (Next GameState)
+halt = lift . Brick.halt =<< get
+
+continue :: AppT (EventM n) (Next GameState)
+continue = lift . Brick.continue =<< get
+
+--------------------------------------------------------------------------------
+
+say :: (MonadRandom m, ToJSON params, MonadState GameState m)
+    => [Text] -> params -> m ()
+say msgPath = writeMessage <=< Messages.message msgPath
+
+say_ :: (MonadRandom m, MonadState GameState m) => [Text] -> m ()
+say_ msgPath = say msgPath $ object []
+
+message :: (MonadRandom m, ToJSON params, MonadState GameState m)
+        => Message -> params -> m ()
+message msg = writeMessage <=< Messages.render msg
+
+message_ :: (MonadRandom m, MonadState GameState m)
+         => Message ->  m ()
+message_ msg = message msg $ object []
+
+writeMessage :: MonadState GameState m => Text -> m ()
+writeMessage m = messageHistory %= pushMessage m
+
+-- | Cancel the currently active autocommand, if any
+cancelAutocommand :: (MonadState GameState m, MonadIO m) => m ()
+cancelAutocommand = do
+  traverse_ (liftIO . cancel . snd) =<< preuse (autocommand . _ActiveAutocommand)
+  autocommand .= NoAutocommand
+
+--------------------------------------------------------------------------------
+
+-- | Send an event to the app in an environment where the game env is available
+sendEvent :: (MonadReader GameEnv m, MonadIO m) => AppEvent -> m ()
+sendEvent evt = do
+  ec <- view eventChan
+  liftIO $ writeBChan ec evt
diff --git a/users/glittershark/xanthous/src/Xanthous/Orphans.hs b/users/glittershark/xanthous/src/Xanthous/Orphans.hs
new file mode 100644
index 000000000000..8e82c372b21c
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Orphans.hs
@@ -0,0 +1,345 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE PackageImports #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+--------------------------------------------------------------------------------
+module Xanthous.Orphans
+  ( ppTemplate
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding (elements, (.=))
+--------------------------------------------------------------------------------
+import           Data.Aeson
+import           Data.Aeson.Types (typeMismatch)
+import           Data.List.NonEmpty (NonEmpty(..))
+import           Graphics.Vty.Attributes
+import           Brick.Widgets.Edit
+import           Data.Text.Zipper.Generic (GenericTextZipper)
+import           Brick.Widgets.Core (getName)
+import           System.Random (StdGen)
+import           Test.QuickCheck
+import           "quickcheck-instances" Test.QuickCheck.Instances ()
+import           Text.Megaparsec (errorBundlePretty)
+import           Text.Megaparsec.Pos
+import           Text.Mustache
+import           Text.Mustache.Type ( showKey )
+import           Control.Monad.State
+import           Linear
+--------------------------------------------------------------------------------
+import           Xanthous.Util.JSON
+import           Xanthous.Util.QuickCheck
+--------------------------------------------------------------------------------
+
+instance forall s a.
+  ( Cons s s a a
+  , IsSequence s
+  , Element s ~ a
+  ) => Cons (NonNull s) (NonNull s) a a where
+  _Cons = prism hither yon
+    where
+      hither :: (a, NonNull s) -> NonNull s
+      hither (a, ns) =
+        let s = toNullable ns
+        in impureNonNull $ a <| s
+
+      yon :: NonNull s -> Either (NonNull s) (a, NonNull s)
+      yon ns = case nuncons ns of
+        (_, Nothing) -> Left ns
+        (x, Just xs) -> Right (x, xs)
+
+instance forall a. Cons (NonEmpty a) (NonEmpty a) a a where
+  _Cons = prism hither yon
+    where
+      hither :: (a, NonEmpty a) -> NonEmpty a
+      hither (a, x :| xs) = a :| (x : xs)
+
+      yon :: NonEmpty a -> Either (NonEmpty a) (a, NonEmpty a)
+      yon ns@(x :| xs) = case xs of
+        (y : ys) -> Right (x, y :| ys)
+        [] -> Left ns
+
+
+instance Arbitrary PName where
+  arbitrary = PName . pack <$> listOf1 (elements ['a'..'z'])
+
+instance Arbitrary Key where
+  arbitrary = Key <$> listOf1 arbSafeText
+    where arbSafeText = pack <$> listOf1 (elements ['a'..'z'])
+  shrink (Key []) = error "unreachable"
+  shrink k@(Key [_]) = pure k
+  shrink (Key (p:ps)) = Key . (p :) <$> shrink ps
+
+instance Arbitrary Pos where
+  arbitrary = mkPos . succ . abs <$> arbitrary
+  shrink (unPos -> 1) = []
+  shrink (unPos -> x) = mkPos <$> [x..1]
+
+instance Arbitrary Node where
+  arbitrary = sized node
+    where
+      node n | n > 0 = oneof $ leaves ++ branches (n `div` 2)
+      node _ = oneof leaves
+      branches n =
+        [ Section <$> arbitrary <*> subnodes n
+        , InvertedSection <$> arbitrary <*> subnodes n
+        ]
+      subnodes = fmap concatTextBlocks . listOf . node
+      leaves =
+        [ TextBlock . pack <$> listOf1 (elements ['a'..'z'])
+        , EscapedVar <$> arbitrary
+        , UnescapedVar <$> arbitrary
+        -- TODO fix pretty-printing of mustache partials
+        -- , Partial <$> arbitrary <*> arbitrary
+        ]
+  shrink = genericShrink
+
+concatTextBlocks :: [Node] -> [Node]
+concatTextBlocks [] = []
+concatTextBlocks [x] = [x]
+concatTextBlocks (TextBlock txt₁ : TextBlock txt₂ : xs)
+  = concatTextBlocks $ TextBlock (txt₁ <> txt₂) : concatTextBlocks xs
+concatTextBlocks (x : xs) = x : concatTextBlocks xs
+
+instance Arbitrary Template where
+  arbitrary = do
+    template <- concatTextBlocks <$> arbitrary
+    -- templateName <- arbitrary
+    -- rest <- arbitrary
+    let templateName = "template"
+        rest = mempty
+    pure $ Template
+      { templateActual = templateName
+      , templateCache = rest & at templateName ?~ template
+      }
+  shrink (Template actual cache) =
+    let Just tpl = cache ^. at actual
+    in do
+      cache' <- shrink cache
+      tpl' <- shrink tpl
+      actual' <- shrink actual
+      pure $ Template
+        { templateActual = actual'
+        , templateCache = cache' & at actual' ?~ tpl'
+        }
+
+instance CoArbitrary Template where
+  coarbitrary = coarbitrary . ppTemplate
+
+instance Function Template where
+  function = functionMap ppTemplate parseTemplatePartial
+    where
+      parseTemplatePartial txt
+        = compileMustacheText "template" txt ^?! _Right
+
+ppNode :: Map PName [Node] -> Node -> Text
+ppNode _ (TextBlock txt) = txt
+ppNode _ (EscapedVar k) = "{{" <> showKey k <> "}}"
+ppNode ctx (Section k body) =
+  let sk = showKey k
+  in "{{#" <> sk <> "}}" <> foldMap (ppNode ctx) body <> "{{/" <> sk <> "}}"
+ppNode _ (UnescapedVar k) = "{{{" <> showKey k <> "}}}"
+ppNode ctx (InvertedSection k body) =
+  let sk = showKey k
+  in "{{^" <> sk <> "}}" <> foldMap (ppNode ctx) body <> "{{/" <> sk <> "}}"
+ppNode _ (Partial n _) = "{{> " <> unPName n <> "}}"
+
+ppTemplate :: Template -> Text
+ppTemplate (Template actual cache) =
+  case cache ^. at actual of
+    Nothing -> error "Template not found?"
+    Just nodes -> foldMap (ppNode cache) nodes
+
+instance ToJSON Template where
+  toJSON = String . ppTemplate
+
+instance FromJSON Template where
+  parseJSON
+    = withText "Template"
+    $ either (fail . errorBundlePretty) pure
+    . compileMustacheText "template"
+
+deriving anyclass instance NFData Node
+deriving anyclass instance NFData Template
+
+instance FromJSON Color where
+  parseJSON (String "black")         = pure black
+  parseJSON (String "red")           = pure red
+  parseJSON (String "green")         = pure green
+  parseJSON (String "yellow")        = pure yellow
+  parseJSON (String "blue")          = pure blue
+  parseJSON (String "magenta")       = pure magenta
+  parseJSON (String "cyan")          = pure cyan
+  parseJSON (String "white")         = pure white
+  parseJSON (String "brightBlack")   = pure brightBlack
+  parseJSON (String "brightRed")     = pure brightRed
+  parseJSON (String "brightGreen")   = pure brightGreen
+  parseJSON (String "brightYellow")  = pure brightYellow
+  parseJSON (String "brightBlue")    = pure brightBlue
+  parseJSON (String "brightMagenta") = pure brightMagenta
+  parseJSON (String "brightCyan")    = pure brightCyan
+  parseJSON (String "brightWhite")   = pure brightWhite
+  parseJSON n@(Number _)             = Color240 <$> parseJSON n
+  parseJSON x                        = typeMismatch "Color" x
+
+instance ToJSON Color where
+  toJSON color
+    | color == black         = "black"
+    | color == red           = "red"
+    | color == green         = "green"
+    | color == yellow        = "yellow"
+    | color == blue          = "blue"
+    | color == magenta       = "magenta"
+    | color == cyan          = "cyan"
+    | color == white         = "white"
+    | color == brightBlack   = "brightBlack"
+    | color == brightRed     = "brightRed"
+    | color == brightGreen   = "brightGreen"
+    | color == brightYellow  = "brightYellow"
+    | color == brightBlue    = "brightBlue"
+    | color == brightMagenta = "brightMagenta"
+    | color == brightCyan    = "brightCyan"
+    | color == brightWhite   = "brightWhite"
+    | Color240 num <- color  = toJSON num
+    | otherwise             = error $ "unimplemented: " <> show color
+
+instance (Eq a, Show a, Read a, FromJSON a) => FromJSON (MaybeDefault a) where
+  parseJSON Null                   = pure Default
+  parseJSON (String "keepCurrent") = pure KeepCurrent
+  parseJSON x                      = SetTo <$> parseJSON x
+
+instance ToJSON a => ToJSON (MaybeDefault a) where
+  toJSON Default     = Null
+  toJSON KeepCurrent = String "keepCurrent"
+  toJSON (SetTo x)   = toJSON x
+
+--------------------------------------------------------------------------------
+
+instance Arbitrary Color where
+  arbitrary = oneof [ Color240 <$> choose (0, 239)
+                    , ISOColor <$> choose (0, 15)
+                    ]
+
+deriving anyclass instance CoArbitrary Color
+deriving anyclass instance Function Color
+
+instance (Eq a, Show a, Read a, Arbitrary a) => Arbitrary (MaybeDefault a) where
+  arbitrary = oneof [ pure Default
+                    , pure KeepCurrent
+                    , SetTo <$> arbitrary
+                    ]
+
+instance CoArbitrary a => CoArbitrary (MaybeDefault a) where
+  coarbitrary Default = variant @Int 1
+  coarbitrary KeepCurrent = variant @Int 2
+  coarbitrary (SetTo x) = variant @Int 3 . coarbitrary x
+
+instance (Eq a, Show a, Read a, Function a) => Function (MaybeDefault a) where
+  function = functionShow
+
+instance Arbitrary Attr where
+  arbitrary = do
+    attrStyle <- arbitrary
+    attrForeColor <- arbitrary
+    attrBackColor <- arbitrary
+    attrURL <- arbitrary
+    pure Attr {..}
+
+deriving anyclass instance CoArbitrary Attr
+deriving anyclass instance Function Attr
+
+instance ToJSON Attr where
+  toJSON Attr{..} = object
+    [ "style" .= maybeDefaultToJSONWith styleToJSON attrStyle
+    , "foreground" .= attrForeColor
+    , "background" .= attrBackColor
+    , "url" .= attrURL
+    ]
+    where
+      maybeDefaultToJSONWith _ Default = Null
+      maybeDefaultToJSONWith _ KeepCurrent = String "keepCurrent"
+      maybeDefaultToJSONWith tj (SetTo x) = tj x
+      styleToJSON style
+        | style == standout     = "standout"
+        | style == underline    = "underline"
+        | style == reverseVideo = "reverseVideo"
+        | style == blink        = "blink"
+        | style == dim          = "dim"
+        | style == bold         = "bold"
+        | style == italic       = "italic"
+        | otherwise            = toJSON style
+
+instance FromJSON Attr where
+  parseJSON = withObject "Attr" $ \obj -> do
+    attrStyle <- parseStyle =<< obj .:? "style" .!= Default
+    attrForeColor <- obj .:? "foreground" .!= Default
+    attrBackColor <- obj .:? "background" .!= Default
+    attrURL <- obj .:? "url" .!= Default
+    pure Attr{..}
+
+    where
+      parseStyle (SetTo (String "standout"))     = pure (SetTo standout)
+      parseStyle (SetTo (String "underline"))    = pure (SetTo underline)
+      parseStyle (SetTo (String "reverseVideo")) = pure (SetTo reverseVideo)
+      parseStyle (SetTo (String "blink"))        = pure (SetTo blink)
+      parseStyle (SetTo (String "dim"))          = pure (SetTo dim)
+      parseStyle (SetTo (String "bold"))         = pure (SetTo bold)
+      parseStyle (SetTo (String "italic"))       = pure (SetTo italic)
+      parseStyle (SetTo n@(Number _))            = SetTo <$> parseJSON n
+      parseStyle (SetTo v)                       = typeMismatch "Style" v
+      parseStyle Default                         = pure Default
+      parseStyle KeepCurrent                     = pure KeepCurrent
+
+deriving stock instance Ord Color
+deriving stock instance Ord a => Ord (MaybeDefault a)
+deriving stock instance Ord Attr
+
+--------------------------------------------------------------------------------
+
+instance NFData a => NFData (NonNull a) where
+  rnf xs = xs `seq` toNullable xs `deepseq` ()
+
+instance forall t name. (NFData t, Monoid t, NFData name)
+                 => NFData (Editor t name) where
+  rnf ed = getName @_ @name ed `deepseq` getEditContents ed `deepseq` ()
+
+instance NFData StdGen where
+  -- StdGen's fields are bang-patterned so this is actually correct!
+  rnf sg = sg `seq` ()
+
+deriving via (ReadShowJSON StdGen) instance ToJSON StdGen
+deriving via (ReadShowJSON StdGen) instance FromJSON StdGen
+
+instance Function StdGen where
+  function = functionShow
+
+--------------------------------------------------------------------------------
+
+instance CoArbitrary a => CoArbitrary (NonNull a) where
+  coarbitrary = coarbitrary . toNullable
+
+instance (MonoFoldable a, Function a) => Function (NonNull a) where
+  function = functionMap toNullable $ fromMaybe (error "null") . fromNullable
+
+instance (Arbitrary t, Arbitrary n, GenericTextZipper t)
+       => Arbitrary (Editor t n) where
+  arbitrary = editor <$> arbitrary <*> arbitrary <*> arbitrary
+
+instance forall t n. (CoArbitrary t, CoArbitrary n, Monoid t)
+              => CoArbitrary (Editor t n) where
+  coarbitrary ed = coarbitrary (getName @_ @n ed, getEditContents ed)
+
+instance CoArbitrary StdGen where
+  coarbitrary = coarbitrary . show
+
+--------------------------------------------------------------------------------
+
+deriving newtype instance (Arbitrary s, CoArbitrary (m (a, s)))
+            => CoArbitrary (StateT s m a)
+
+--------------------------------------------------------------------------------
+
+deriving via (GenericArbitrary (V2 a)) instance Arbitrary a => Arbitrary (V2 a)
+instance CoArbitrary a => CoArbitrary (V2 a)
+instance Function a => Function (V2 a)
diff --git a/users/glittershark/xanthous/src/Xanthous/Prelude.hs b/users/glittershark/xanthous/src/Xanthous/Prelude.hs
new file mode 100644
index 000000000000..9a4ca0149f1a
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Prelude.hs
@@ -0,0 +1,36 @@
+--------------------------------------------------------------------------------
+module Xanthous.Prelude
+  ( module ClassyPrelude
+  , Type
+  , Constraint
+  , module GHC.TypeLits
+  , module Control.Lens
+  , module Data.Void
+  , module Control.Comonad
+
+
+    -- * Classy-Prelude addons
+  , ninsertSet
+  , ndeleteSet
+  , toVector
+  ) where
+--------------------------------------------------------------------------------
+import ClassyPrelude hiding
+  (return, (<|), unsnoc, uncons, cons, snoc, index, (<.>), Index, say)
+import Data.Kind
+import GHC.TypeLits hiding (Text)
+import Control.Lens hiding (levels, Level)
+import Data.Void
+import Control.Comonad
+--------------------------------------------------------------------------------
+
+ninsertSet
+  :: (IsSet set, MonoPointed set)
+  => Element set -> NonNull set -> NonNull set
+ninsertSet x xs = impureNonNull $ opoint x `union` toNullable xs
+
+ndeleteSet :: IsSet b => Element b -> NonNull b -> b
+ndeleteSet x = deleteSet x . toNullable
+
+toVector :: (MonoFoldable (f a), Element (f a) ~ a) => f a -> Vector a
+toVector = fromList . toList
diff --git a/users/glittershark/xanthous/src/Xanthous/Random.hs b/users/glittershark/xanthous/src/Xanthous/Random.hs
new file mode 100644
index 000000000000..41c80ab73c4c
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Random.hs
@@ -0,0 +1,102 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+--------------------------------------------------------------------------------
+module Xanthous.Random
+  ( Choose(..)
+  , ChooseElement(..)
+  , Weighted(..)
+  , evenlyWeighted
+  , weightedBy
+  , subRand
+  , chance
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Data.List.NonEmpty (NonEmpty(..))
+import           Control.Monad.Random.Class (MonadRandom(getRandomR, getRandom))
+import           Control.Monad.Random (Rand, evalRand, mkStdGen, StdGen)
+import           Data.Random.Shuffle.Weighted
+import           Data.Random.Distribution
+import           Data.Random.Distribution.Uniform
+import           Data.Random.Distribution.Uniform.Exclusive
+import           Data.Random.Sample
+import qualified Data.Random.Source as DRS
+--------------------------------------------------------------------------------
+
+instance {-# INCOHERENT #-} (Monad m, MonadRandom m) => DRS.MonadRandom m where
+  getRandomWord8 = getRandom
+  getRandomWord16 = getRandom
+  getRandomWord32 = getRandom
+  getRandomWord64 = getRandom
+  getRandomDouble = getRandom
+  getRandomNByteInteger n = getRandomR (0, 256 ^ n)
+
+class Choose a where
+  type RandomResult a
+  choose :: MonadRandom m => a -> m (RandomResult a)
+
+newtype ChooseElement a = ChooseElement a
+
+instance MonoFoldable a => Choose (ChooseElement a) where
+  type RandomResult (ChooseElement a) = Maybe (Element a)
+  choose (ChooseElement xs) = do
+    chosenIdx <- getRandomR (0, olength xs - 1)
+    let pick _ (Just x) = Just x
+        pick (x, i) Nothing
+          | i == chosenIdx = Just x
+          | otherwise = Nothing
+    pure $ ofoldr pick Nothing $ zip (toList xs) [0..]
+
+instance MonoFoldable a => Choose (NonNull a) where
+  type RandomResult (NonNull a) = Element a
+  choose
+    = fmap (fromMaybe (error "unreachable")) -- why not lol
+    . choose
+    . ChooseElement
+    . toNullable
+
+instance Choose (NonEmpty a) where
+  type RandomResult (NonEmpty a) = a
+  choose = choose . fromNonEmpty @[_]
+
+instance Choose (a, a) where
+  type RandomResult (a, a) = a
+  choose (x, y) = choose (x :| [y])
+
+newtype Weighted w t a = Weighted (t (w, a))
+
+evenlyWeighted :: [a] -> Weighted Int [] a
+evenlyWeighted = Weighted . itoList
+
+weightedBy :: Functor t => (a -> w) -> t a -> Weighted w t a
+weightedBy weighting xs = Weighted $ (weighting &&& id) <$> xs
+
+instance (Num w, Ord w, Distribution Uniform w, Excludable w) => Choose (Weighted w [] a) where
+  type RandomResult (Weighted w [] a) = Maybe a
+  choose (Weighted ws) = sample $ headMay <$> weightedSample 1 ws
+
+instance (Num w, Ord w, Distribution Uniform w, Excludable w) => Choose (Weighted w NonEmpty a) where
+  type RandomResult (Weighted w NonEmpty a) = a
+  choose (Weighted ws) =
+    sample
+    $ fromMaybe (error "unreachable") . headMay
+    <$> weightedSample 1 (toList ws)
+
+subRand :: MonadRandom m => Rand StdGen a -> m a
+subRand sub = evalRand sub . mkStdGen <$> getRandom
+
+-- | Has a @n@ chance of returning 'True'
+--
+-- eg, chance 0.5 will return 'True' half the time
+chance
+  :: (Num w, Ord w, Distribution Uniform w, Excludable w, MonadRandom m)
+  => w
+  -> m Bool
+chance n = choose $ weightedBy (bool 1 (n * 2)) bools
+
+--------------------------------------------------------------------------------
+
+bools :: NonEmpty Bool
+bools = True :| [False]
diff --git a/users/glittershark/xanthous/src/Xanthous/Util.hs b/users/glittershark/xanthous/src/Xanthous/Util.hs
new file mode 100644
index 000000000000..524ad4819dac
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Util.hs
@@ -0,0 +1,252 @@
+{-# LANGUAGE BangPatterns          #-}
+{-# LANGUAGE AllowAmbiguousTypes   #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+--------------------------------------------------------------------------------
+module Xanthous.Util
+  ( EqEqProp(..)
+  , EqProp(..)
+  , foldlMapM
+  , foldlMapM'
+  , between
+
+  , appendVia
+
+    -- * Foldable
+    -- ** Uniqueness
+    -- *** Predicates on uniqueness
+  , isUniqueOf
+  , isUnique
+    -- *** Removing all duplicate elements in n * log n time
+  , uniqueOf
+  , unique
+    -- *** Removing sequentially duplicate elements in linear time
+  , uniqOf
+  , uniq
+    -- ** Bag sequence algorithms
+  , takeWhileInclusive
+  , smallestNotIn
+  , removeVectorIndex
+  , maximum1
+  , minimum1
+
+    -- * Combinators
+  , times, times_
+
+    -- * Type-level programming utils
+  , KnownBool(..)
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding (foldr)
+--------------------------------------------------------------------------------
+import           Test.QuickCheck.Checkers
+import           Data.Foldable (foldr)
+import           Data.Monoid
+import           Data.Proxy
+import qualified Data.Vector as V
+import           Data.Semigroup (Max(..), Min(..))
+import           Data.Semigroup.Foldable
+--------------------------------------------------------------------------------
+
+newtype EqEqProp a = EqEqProp a
+  deriving newtype Eq
+
+instance Eq a => EqProp (EqEqProp a) where
+  (=-=) = eq
+
+foldlMapM :: forall g b a m. (Foldable g, Monoid b, Applicative m) => (a -> m b) -> g a -> m b
+foldlMapM f = foldr f' (pure mempty)
+  where
+    f' :: a -> m b -> m b
+    f' x = liftA2 mappend (f x)
+
+-- Strict in the monoidal accumulator. For monads strict
+-- in the left argument of bind, this will run in constant
+-- space.
+foldlMapM' :: forall g b a m. (Foldable g, Monoid b, Monad m) => (a -> m b) -> g a -> m b
+foldlMapM' f xs = foldr f' pure xs mempty
+  where
+  f' :: a -> (b -> m b) -> b -> m b
+  f' x k bl = do
+    br <- f x
+    let !b = mappend bl br
+    k b
+
+between
+  :: Ord a
+  => a -- ^ lower bound
+  -> a -- ^ upper bound
+  -> a -- ^ scrutinee
+  -> Bool
+between lower upper x = x >= lower && x <= upper
+
+-- |
+-- >>> appendVia Sum 1 2
+-- 3
+appendVia :: (Rewrapping s t, Semigroup s) => (Unwrapped s -> s) -> Unwrapped s -> Unwrapped s -> Unwrapped s
+appendVia wrap x y = op wrap $ wrap x <> wrap y
+
+--------------------------------------------------------------------------------
+
+-- | Returns True if the targets of the given 'Fold' are unique per the 'Ord' instance for @a@
+--
+-- >>> isUniqueOf (folded . _1) ([(1, 2), (2, 2), (3, 2)] :: [(Int, Int)])
+-- True
+--
+-- >>> isUniqueOf (folded . _2) ([(1, 2), (2, 2), (3, 2)] :: [(Int, Int)])
+-- False
+--
+-- @
+-- 'isUniqueOf' :: Ord a => 'Getter' s a     -> s -> 'Bool'
+-- 'isUniqueOf' :: Ord a => 'Fold' s a       -> s -> 'Bool'
+-- 'isUniqueOf' :: Ord a => 'Lens'' s a      -> s -> 'Bool'
+-- 'isUniqueOf' :: Ord a => 'Iso'' s a       -> s -> 'Bool'
+-- 'isUniqueOf' :: Ord a => 'Traversal'' s a -> s -> 'Bool'
+-- 'isUniqueOf' :: Ord a => 'Prism'' s a     -> s -> 'Bool'
+-- @
+isUniqueOf :: Ord a => Getting (Endo (Set a, Bool)) s a -> s -> Bool
+isUniqueOf aFold = orOf _2 . foldrOf aFold rejectUnique (mempty, True)
+ where
+  rejectUnique x (seen, acc)
+    | seen ^. contains x = (seen, False)
+    | otherwise          = (seen & contains x .~ True, acc)
+
+-- | Returns true if the given 'Foldable' container contains only unique
+-- elements, as determined by the 'Ord' instance for @a@
+--
+-- >>> isUnique ([3, 1, 2] :: [Int])
+-- True
+--
+-- >>> isUnique ([1, 1, 2, 2, 3, 1] :: [Int])
+-- False
+isUnique :: (Foldable f, Ord a) => f a -> Bool
+isUnique = isUniqueOf folded
+
+
+-- | O(n * log n). Returns a monoidal, 'Cons'able container (a list, a Set,
+-- etc.) consisting of the unique (per the 'Ord' instance for @a@) targets of
+-- the given 'Fold'
+--
+-- >>> uniqueOf (folded . _2) ([(1, 2), (2, 2), (3, 2), (4, 3)] :: [(Int, Int)]) :: [Int]
+-- [2,3]
+--
+-- @
+-- 'uniqueOf' :: Ord a => 'Getter' s a     -> s -> [a]
+-- 'uniqueOf' :: Ord a => 'Fold' s a       -> s -> [a]
+-- 'uniqueOf' :: Ord a => 'Lens'' s a      -> s -> [a]
+-- 'uniqueOf' :: Ord a => 'Iso'' s a       -> s -> [a]
+-- 'uniqueOf' :: Ord a => 'Traversal'' s a -> s -> [a]
+-- 'uniqueOf' :: Ord a => 'Prism'' s a     -> s -> [a]
+-- @
+uniqueOf
+  :: (Monoid c, Ord w, Cons c c w w) => Getting (Endo (Set w, c)) a w -> a -> c
+uniqueOf aFold = snd . foldrOf aFold rejectUnique (mempty, mempty)
+ where
+  rejectUnique x (seen, acc)
+    | seen ^. contains x = (seen, acc)
+    | otherwise          = (seen & contains x .~ True, cons x acc)
+
+-- | Returns a monoidal, 'Cons'able container (a list, a Set, etc.) consisting
+-- of the unique (per the 'Ord' instance for @a@) contents of the given
+-- 'Foldable' container
+--
+-- >>> unique [1, 1, 2, 2, 3, 1] :: [Int]
+-- [2,3,1]
+
+-- >>> unique [1, 1, 2, 2, 3, 1] :: Set Int
+-- fromList [3,2,1]
+unique :: (Foldable f, Cons c c a a, Ord a, Monoid c) => f a -> c
+unique = uniqueOf folded
+
+--------------------------------------------------------------------------------
+
+-- | O(n). Returns a monoidal, 'Cons'able container (a list, a Vector, etc.)
+-- consisting of the targets of the given 'Fold' with sequential duplicate
+-- elements removed
+--
+-- This function (sorry for the confusing name) differs from 'uniqueOf' in that
+-- it only compares /sequentially/ duplicate elements (and thus operates in
+-- linear time).
+-- cf 'Data.Vector.uniq' and POSIX @uniq@ for the name
+--
+-- >>> uniqOf (folded . _2) ([(1, 2), (2, 2), (3, 1), (4, 2)] :: [(Int, Int)]) :: [Int]
+-- [2,1,2]
+--
+-- @
+-- 'uniqOf' :: Eq a => 'Getter' s a     -> s -> [a]
+-- 'uniqOf' :: Eq a => 'Fold' s a       -> s -> [a]
+-- 'uniqOf' :: Eq a => 'Lens'' s a      -> s -> [a]
+-- 'uniqOf' :: Eq a => 'Iso'' s a       -> s -> [a]
+-- 'uniqOf' :: Eq a => 'Traversal'' s a -> s -> [a]
+-- 'uniqOf' :: Eq a => 'Prism'' s a     -> s -> [a]
+-- @
+uniqOf :: (Monoid c, Cons c c w w, Eq w) => Getting (Endo (Maybe w, c)) a w -> a -> c
+uniqOf aFold = snd . foldrOf aFold rejectSeen (Nothing, mempty)
+  where
+    rejectSeen x (Nothing, acc) = (Just x, x <| acc)
+    rejectSeen x tup@(Just a, acc)
+      | x == a     = tup
+      | otherwise = (Just x, x <| acc)
+
+-- | O(n). Returns a monoidal, 'Cons'able container (a list, a Vector, etc.)
+-- consisting of the targets of the given 'Foldable' container with sequential
+-- duplicate elements removed
+--
+-- This function (sorry for the confusing name) differs from 'unique' in that
+-- it only compares /sequentially/ unique elements (and thus operates in linear
+-- time).
+-- cf 'Data.Vector.uniq' and POSIX @uniq@ for the name
+--
+-- >>> uniq [1, 1, 1, 2, 2, 2, 3, 3, 1] :: [Int]
+-- [1,2,3,1]
+--
+-- >>> uniq [1, 1, 1, 2, 2, 2, 3, 3, 1] :: Vector Int
+-- [1,2,3,1]
+--
+uniq :: (Foldable f, Eq a, Cons c c a a, Monoid c) => f a -> c
+uniq = uniqOf folded
+
+-- | Like 'takeWhile', but inclusive
+takeWhileInclusive :: (a -> Bool) -> [a] -> [a]
+takeWhileInclusive _ [] = []
+takeWhileInclusive p (x:xs) = x : if p x then takeWhileInclusive p xs else []
+
+-- | Returns the smallest value not in a list
+smallestNotIn :: (Ord a, Bounded a, Enum a) => [a] -> a
+smallestNotIn xs = case uniq $ sort xs of
+  [] -> minBound
+  xs'@(x : _)
+    | x > minBound -> minBound
+    | otherwise
+    -> snd . headEx . filter (uncurry (/=)) $ zip (xs' ++ [minBound]) [minBound..]
+
+-- | Remove the element at the given index, if any, from the given vector
+removeVectorIndex :: Int -> Vector a -> Vector a
+removeVectorIndex idx vect =
+  let (before, after) = V.splitAt idx vect
+  in before <> fromMaybe Empty (tailMay after)
+
+maximum1 :: (Ord a, Foldable1 f) => f a -> a
+maximum1 = getMax . foldMap1 Max
+
+minimum1 :: (Ord a, Foldable1 f) => f a -> a
+minimum1 = getMin . foldMap1 Min
+
+times :: (Applicative f, Num n, Enum n) => n -> (n -> f b) -> f [b]
+times n f = traverse f [1..n]
+
+times_ :: (Applicative f, Num n, Enum n) => n -> f a -> f [a]
+times_ n fa = times n (const fa)
+
+--------------------------------------------------------------------------------
+
+-- | This class gives a boolean associated with a type-level bool, a'la
+-- 'KnownSymbol', 'KnownNat' etc.
+class KnownBool (bool :: Bool) where
+  boolVal' :: forall proxy. proxy bool -> Bool
+  boolVal' _ = boolVal @bool
+
+  boolVal :: Bool
+  boolVal = boolVal' $ Proxy @bool
+
+instance KnownBool 'True where boolVal = True
+instance KnownBool 'False where boolVal = False
diff --git a/users/glittershark/xanthous/src/Xanthous/Util/Comonad.hs b/users/glittershark/xanthous/src/Xanthous/Util/Comonad.hs
new file mode 100644
index 000000000000..9e158cc8e2d4
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Util/Comonad.hs
@@ -0,0 +1,24 @@
+--------------------------------------------------------------------------------
+module Xanthous.Util.Comonad
+  ( -- * Store comonad utils
+    replace
+  , current
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Control.Comonad.Store.Class
+--------------------------------------------------------------------------------
+
+-- | Replace the current position of a store comonad with a new value by
+-- comparing positions
+replace :: (Eq i, ComonadStore i w) => w a -> a -> w a
+replace w x = w =>> \w' -> if pos w' == pos w then x else extract w'
+{-# INLINE replace #-}
+
+-- | Lens into the current position of a store comonad.
+--
+--     current = lens extract replace
+current :: (Eq i, ComonadStore i w) => Lens' (w a) a
+current = lens extract replace
+{-# INLINE current #-}
diff --git a/users/glittershark/xanthous/src/Xanthous/Util/Graph.hs b/users/glittershark/xanthous/src/Xanthous/Util/Graph.hs
new file mode 100644
index 000000000000..8e5c04f4bfa9
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Util/Graph.hs
@@ -0,0 +1,33 @@
+--------------------------------------------------------------------------------
+module Xanthous.Util.Graph where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Data.Graph.Inductive.Query.MST (msTree)
+import qualified Data.Graph.Inductive.Graph as Graph
+import           Data.Graph.Inductive.Graph
+import           Data.Graph.Inductive.Basic (undir)
+import           Data.Set (isSubsetOf)
+--------------------------------------------------------------------------------
+
+mstSubGraph
+  :: forall gr node edge. (DynGraph gr, Real edge, Show edge)
+  => gr node edge -> gr node edge
+mstSubGraph graph = insEdges mstEdges . insNodes (labNodes graph) $ Graph.empty
+  where
+    mstEdges = ordNub $ do
+      LP path <- msTree $ undir graph
+      case path of
+        [] -> []
+        [_] -> []
+        ((n₂, edgeWeight) : (n₁, _) : _) ->
+          pure (n₁, n₂, edgeWeight)
+
+isSubGraphOf
+  :: (Graph gr1, Graph gr2, Ord node, Ord edge)
+  => gr1 node edge
+  -> gr2 node edge
+  -> Bool
+isSubGraphOf graph₁ graph₂
+  = setFromList (labNodes graph₁) `isSubsetOf` setFromList (labNodes graph₂)
+  && setFromList (labEdges graph₁) `isSubsetOf` setFromList (labEdges graph₂)
diff --git a/users/glittershark/xanthous/src/Xanthous/Util/Graphics.hs b/users/glittershark/xanthous/src/Xanthous/Util/Graphics.hs
new file mode 100644
index 000000000000..5f7432f4c7e2
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Util/Graphics.hs
@@ -0,0 +1,174 @@
+{-# LANGUAGE TemplateHaskell #-}
+-- | Graphics algorithms and utils for rendering things in 2D space
+--------------------------------------------------------------------------------
+module Xanthous.Util.Graphics
+  ( circle
+  , filledCircle
+  , line
+  , straightLine
+  , delaunay
+
+    -- * Debugging and testing tools
+  , renderBooleanGraphics
+  , showBooleanGraphics
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+-- https://github.com/noinia/hgeometry/issues/28
+-- import qualified Algorithms.Geometry.DelaunayTriangulation.DivideAndConquer
+--               as Geometry
+import qualified Algorithms.Geometry.DelaunayTriangulation.Naive
+              as Geometry
+import qualified Algorithms.Geometry.DelaunayTriangulation.Types as Geometry
+import           Control.Monad.State (execState, State)
+import qualified Data.Geometry.Point as Geometry
+import           Data.Ext ((:+)(..))
+import           Data.List (unfoldr)
+import           Data.List.NonEmpty (NonEmpty((:|)))
+import qualified Data.List.NonEmpty as NE
+import           Data.Ix (Ix)
+import           Linear.V2
+--------------------------------------------------------------------------------
+
+
+-- | Generate a circle centered at the given point and with the given radius
+-- using the <midpoint circle algorithm
+-- https://en.wikipedia.org/wiki/Midpoint_circle_algorithm>.
+--
+-- Code taken from <https://rosettacode.org/wiki/Bitmap/Midpoint_circle_algorithm#Haskell>
+circle :: (Num i, Ord i)
+       => (i, i) -- ^ center
+       -> i      -- ^ radius
+       -> [(i, i)]
+circle (x₀, y₀) radius
+  -- Four initial points, plus the generated points
+  = (x₀, y₀ + radius) : (x₀, y₀ - radius) : (x₀ + radius, y₀) : (x₀ - radius, y₀) : points
+    where
+      -- Creates the (x, y) octet offsets, then maps them to absolute points in all octets.
+      points = concatMap generatePoints $ unfoldr step initialValues
+
+      generatePoints (x, y)
+        = [ (x₀ `xop` x', y₀ `yop` y')
+          | (x', y') <- [(x, y), (y, x)]
+          , xop <- [(+), (-)]
+          , yop <- [(+), (-)]
+          ]
+
+      initialValues = (1 - radius, 1, (-2) * radius, 0, radius)
+
+      step (f, ddf_x, ddf_y, x, y)
+        | x >= y = Nothing
+        | otherwise = Just ((x', y'), (f', ddf_x', ddf_y', x', y'))
+        where
+          (f', ddf_y', y') | f >= 0 = (f + ddf_y' + ddf_x', ddf_y + 2, y - 1)
+                           | otherwise = (f + ddf_x, ddf_y, y)
+          ddf_x' = ddf_x + 2
+          x' = x + 1
+
+
+data FillState i
+  = FillState
+  { _inCircle :: Bool
+  , _result :: NonEmpty (i, i)
+  }
+makeLenses ''FillState
+
+runFillState :: NonEmpty (i, i) -> State (FillState i) a -> [(i, i)]
+runFillState circumference s
+  = toList
+  . view result
+  . execState s
+  $ FillState False circumference
+
+-- | Generate a *filled* circle centered at the given point and with the given
+-- radius by filling a circle generated with 'circle'
+filledCircle :: (Num i, Integral i, Ix i)
+             => (i, i) -- ^ center
+             -> i      -- ^ radius
+             -> [(i, i)]
+filledCircle origin radius =
+  case NE.nonEmpty (circle origin radius) of
+    Nothing -> []
+    Just circumference -> runFillState circumference $
+      -- the first and last lines of all circles are solid, so the whole "in the
+      -- circle, out of the circle" thing doesn't work... but that's fine since
+      -- we don't need to fill them. So just skip them
+      for_ [succ minX..pred maxX] $ \x ->
+        for_ [minY..maxY] $ \y -> do
+          let pt = (x, y)
+              next = (x, succ y)
+          whenM (use inCircle) $ result %= NE.cons pt
+
+          when (pt `elem` circumference && next `notElem` circumference)
+            $ inCircle %= not
+
+      where
+        ((minX, minY), (maxX, maxY)) = minmaxes circumference
+
+-- | Draw a line between two points using Bresenham's line drawing algorithm
+--
+-- Code taken from <https://wiki.haskell.org/Bresenham%27s_line_drawing_algorithm>
+line :: (Num i, Ord i) => (i, i) -> (i, i) -> [(i, i)]
+line pa@(xa, ya) pb@(xb, yb)
+  = (if maySwitch pa < maySwitch pb then id else reverse) points
+  where
+    points               = map maySwitch . unfoldr go $ (x₁, y₁, 0)
+    steep                = abs (yb - ya) > abs (xb - xa)
+    maySwitch            = if steep then swap else id
+    [(x₁, y₁), (x₂, y₂)] = sort [maySwitch pa, maySwitch pb]
+    δx                   = x₂ - x₁
+    δy                   = abs (y₂ - y₁)
+    ystep                = if y₁ < y₂ then 1 else -1
+    go (xTemp, yTemp, err)
+      | xTemp > x₂ = Nothing
+      | otherwise  = Just ((xTemp, yTemp), (xTemp + 1, newY, newError))
+      where
+        tempError        = err + δy
+        (newY, newError) = if (2 * tempError) >= δx
+                           then (yTemp + ystep, tempError - δx)
+                           else (yTemp, tempError)
+
+straightLine :: (Num i, Ord i) => (i, i) -> (i, i) -> [(i, i)]
+straightLine pa@(xa, _) pb@(_, yb) = line pa midpoint ++ line midpoint pb
+  where midpoint = (xa, yb)
+
+
+delaunay
+  :: (Ord n, Fractional n)
+  => NonEmpty (V2 n, p)
+  -> [((V2 n, p), (V2 n, p))]
+delaunay
+  = map (over both fromPoint)
+  . Geometry.triangulationEdges
+  . Geometry.delaunayTriangulation
+  . map toPoint
+  where
+    toPoint (V2 px py, pid) = Geometry.Point2 px py :+ pid
+    fromPoint (Geometry.Point2 px py :+ pid) = (V2 px py, pid)
+
+--------------------------------------------------------------------------------
+
+renderBooleanGraphics :: forall i. (Num i, Ord i, Enum i) => [(i, i)] -> String
+renderBooleanGraphics [] = ""
+renderBooleanGraphics (pt : pts') = intercalate "\n" rows
+  where
+    rows = row <$> [minX..maxX]
+    row x = [minY..maxY] <&> \y -> if (x, y) `member` ptSet then 'X' else ' '
+    ((minX, minY), (maxX, maxY)) = minmaxes pts
+    pts = pt :| pts'
+    ptSet :: Set (i, i)
+    ptSet = setFromList $ toList pts
+
+showBooleanGraphics :: forall i. (Num i, Ord i, Enum i) => [(i, i)] -> IO ()
+showBooleanGraphics = putStrLn . pack . renderBooleanGraphics
+
+minmaxes :: forall i. (Ord i) => NonEmpty (i, i) -> ((i, i), (i, i))
+minmaxes xs =
+    ( ( minimum1Of (traverse1 . _1) xs
+      , minimum1Of (traverse1 . _2) xs
+      )
+    , ( maximum1Of (traverse1 . _1) xs
+      , maximum1Of (traverse1 . _2) xs
+      )
+    )
diff --git a/users/glittershark/xanthous/src/Xanthous/Util/Inflection.hs b/users/glittershark/xanthous/src/Xanthous/Util/Inflection.hs
new file mode 100644
index 000000000000..724f2339dd21
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Util/Inflection.hs
@@ -0,0 +1,14 @@
+
+module Xanthous.Util.Inflection
+  ( toSentence
+  ) where
+
+import Xanthous.Prelude
+
+toSentence :: (MonoFoldable mono, Element mono ~ Text) => mono -> Text
+toSentence xs = case reverse . toList $ xs of
+  [] -> ""
+  [x] -> x
+  [b, a] -> a <> " and " <> b
+  (final : butlast) ->
+    intercalate ", " (reverse butlast) <> ", and " <> final
diff --git a/users/glittershark/xanthous/src/Xanthous/Util/JSON.hs b/users/glittershark/xanthous/src/Xanthous/Util/JSON.hs
new file mode 100644
index 000000000000..91d1328e4a10
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Util/JSON.hs
@@ -0,0 +1,19 @@
+--------------------------------------------------------------------------------
+module Xanthous.Util.JSON
+  ( ReadShowJSON(..)
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Data.Aeson
+--------------------------------------------------------------------------------
+
+newtype ReadShowJSON a = ReadShowJSON a
+  deriving newtype (Read, Show)
+
+instance Show a => ToJSON (ReadShowJSON a) where
+  toJSON = toJSON . show
+
+instance Read a => FromJSON (ReadShowJSON a) where
+  parseJSON = withText "readable"
+    $ maybe (fail "Could not read") pure . readMay
diff --git a/users/glittershark/xanthous/src/Xanthous/Util/Optparse.hs b/users/glittershark/xanthous/src/Xanthous/Util/Optparse.hs
new file mode 100644
index 000000000000..dfa65372351d
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Util/Optparse.hs
@@ -0,0 +1,21 @@
+--------------------------------------------------------------------------------
+module Xanthous.Util.Optparse
+  ( readWithGuard
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import qualified Options.Applicative as Opt
+--------------------------------------------------------------------------------
+
+readWithGuard
+  :: Read b
+  => (b -> Bool)
+  -> (b -> String)
+  -> Opt.ReadM b
+readWithGuard predicate errmsg = do
+  res <- Opt.auto
+  unless (predicate res)
+    $ Opt.readerError
+    $ errmsg res
+  pure res
diff --git a/users/glittershark/xanthous/src/Xanthous/Util/QuickCheck.hs b/users/glittershark/xanthous/src/Xanthous/Util/QuickCheck.hs
new file mode 100644
index 000000000000..be12bc294513
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Util/QuickCheck.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE UndecidableInstances #-}
+module Xanthous.Util.QuickCheck
+  ( functionShow
+  , FunctionShow(..)
+  , functionJSON
+  , FunctionJSON(..)
+  , genericArbitrary
+  , GenericArbitrary(..)
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+import Test.QuickCheck
+import Test.QuickCheck.Function
+import Test.QuickCheck.Instances.ByteString ()
+import Test.QuickCheck.Arbitrary.Generic
+import Data.Aeson
+import GHC.Generics (Rep)
+--------------------------------------------------------------------------------
+
+newtype FunctionShow a = FunctionShow a
+  deriving newtype (Show, Read)
+
+instance (Show a, Read a) => Function (FunctionShow a) where
+  function = functionShow
+
+functionJSON :: (ToJSON a, FromJSON a) => (a -> c) -> a :-> c
+functionJSON = functionMap encode (headEx . decode)
+
+newtype FunctionJSON a = FunctionJSON a
+  deriving newtype (ToJSON, FromJSON)
+
+instance (ToJSON a, FromJSON a) => Function (FunctionJSON a) where
+  function = functionJSON
+
+--------------------------------------------------------------------------------
+
+newtype GenericArbitrary a = GenericArbitrary a
+  deriving newtype Generic
+
+instance (Generic a, GArbitrary rep, Rep a ~ rep)
+  => Arbitrary (GenericArbitrary a) where
+  arbitrary = genericArbitrary
diff --git a/users/glittershark/xanthous/src/Xanthous/messages.yaml b/users/glittershark/xanthous/src/Xanthous/messages.yaml
new file mode 100644
index 000000000000..c1835ef2327b
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/messages.yaml
@@ -0,0 +1,120 @@
+welcome: Welcome to Xanthous, {{characterName}}! It's dangerous out there, why not stay inside? Use hjklybnu to move.
+dead:
+  - You have died...
+  - You die...
+  - You perish...
+  - You have perished...
+
+generic:
+  continue: Press enter to continue...
+
+save:
+  location: "Enter filename to save to: "
+  overwrite: "A file named {{filename}} already exists. Would you like to overwrite it? "
+
+quit:
+  confirm: Really quit without saving?
+
+entities:
+  description: You see here {{entityDescriptions}}
+
+pickUp:
+  menu: What would you like to pick up?
+  pickUp: You pick up the {{item.itemType.name}}
+  nothingToPickUp: "There's nothing here to pick up"
+
+cant:
+  goUp:
+    - You can't go up here
+    - There's nothing here that would let you go up
+  goDown:
+    - You can't go down here
+    - There's nothing here that would let you go down
+
+open:
+  prompt: Direction to open (hjklybnu.)?
+  success: "You open the door."
+  locked: "That door is locked"
+  nothingToOpen: "There's nothing to open there."
+  alreadyOpen: "That door is already open."
+
+close:
+  prompt: Direction to close (hjklybnu.)?
+  success:
+    - You close the door.
+    - You shut the door.
+  nothingToClose: "There's nothing to close there."
+  alreadyClosed: "That door is already closed."
+  blocked: "The {{entityDescriptions}} {{blockOrBlocks}} the door!"
+
+look:
+  prompt: Select a position on the map to describe (use Enter to confirm)
+  nothing: There's nothing there
+
+character:
+  namePrompt: "What's your name? "
+
+combat:
+  nothingToAttack: There's nothing to attack there.
+  menu: Which creature would you like to attack?
+  fistSelfDamage:
+    - You hit so hard with your fists you hurt yourself!
+    - The punch leaves your knuckles bloody!
+  hit:
+    fists:
+      - You punch the {{creature.creatureType.name}} with your bare fists! It hurts. A lot.
+      - You strike the {{creature.creatureType.name}} with your bare fists! It leaves a bit of a bruise on your knuckles.
+    generic:
+      - You hit the {{creature.creatureType.name}}.
+      - You attack the {{creature.creatureType.name}}.
+  creatureAttack:
+    - The {{creature.creatureType.name}} hits you!
+    - The {{creature.creatureType.name}} attacks you!
+  killed:
+    - You kill the {{creature.creatureType.name}}!
+    - You've killed the {{creature.creatureType.name}}!
+
+debug:
+  toggleRevealAll: revealAll now set to {{revealAll}}
+
+eat:
+  noFood:
+    - You have nothing edible.
+    - You don't have any food.
+    - You don't have anything to eat.
+    - You search your pockets for something edible, and come up short.
+  menuPrompt: What would you like to eat?
+  eat: You eat the {{item.itemType.name}}.
+
+read:
+  prompt: Direction to read (hjklybnu.)?
+  nothing: "There's nothing there to read"
+  result: "\"{{message}}\""
+
+wield:
+  nothing:
+    - You aren't carrying anything you can wield
+    - You can't wield anything in your backpack
+    - You can't wield anything currently in your backpack
+  menu: What would you like to wield?
+  # TODO: use actual hands
+  wielded : You wield the {{wieldedItem.itemType.name}} in your right hand.
+
+drop:
+  nothing: You aren't carrying anything
+  menu: What would you like to drop?
+  # TODO: use actual hands
+  dropped:
+    - You drop the {{item.itemType.name}}.
+    - You drop the {{item.itemType.name}} on the ground.
+    - You put the {{item.itemType.name}} on the ground.
+    - You take the {{item.itemType.name}} out of your backpack and put it on the ground.
+    - You take the {{item.itemType.name}} out of your backpack and drop it on the ground.
+
+autoMove:
+  enemyInSight:
+    - There's a {{firstEntity.creatureType.name}} nearby!
+###
+
+tutorial:
+  message1: The caves are dark and full of nightmarish creatures - and you are likely to perish without food. Seek out sustenance! You can pick items up with ,.