about summary refs log tree commit diff
path: root/users/aspen/xanthous
diff options
context:
space:
mode:
Diffstat (limited to 'users/aspen/xanthous')
-rw-r--r--users/aspen/xanthous/.envrc1
-rw-r--r--users/aspen/xanthous/.github/actions/nix-build/Dockerfile23
-rwxr-xr-xusers/aspen/xanthous/.github/actions/nix-build/entrypoint.sh24
-rw-r--r--users/aspen/xanthous/.github/workflows/haskell.yml15
-rw-r--r--users/aspen/xanthous/.gitignore37
-rw-r--r--users/aspen/xanthous/LICENSE674
-rw-r--r--users/aspen/xanthous/README.org36
-rw-r--r--users/aspen/xanthous/Setup.hs2
-rw-r--r--users/aspen/xanthous/app/Main.hs171
-rw-r--r--users/aspen/xanthous/bench/Bench.hs12
-rw-r--r--users/aspen/xanthous/bench/Bench/Prelude.hs9
-rw-r--r--users/aspen/xanthous/bench/Xanthous/Generators/UtilBench.hs37
-rw-r--r--users/aspen/xanthous/bench/Xanthous/RandomBench.hs32
-rw-r--r--users/aspen/xanthous/build/generic-arbitrary-export-garbitrary.patch12
-rw-r--r--users/aspen/xanthous/build/hgeometry-fix-haddock.patch13
-rw-r--r--users/aspen/xanthous/build/update-comonad-extras.patch92
-rw-r--r--users/aspen/xanthous/default.nix27
-rw-r--r--users/aspen/xanthous/docs/raw-types.org24
-rw-r--r--users/aspen/xanthous/hie.yaml10
-rw-r--r--users/aspen/xanthous/nixpkgs.nix3
-rw-r--r--users/aspen/xanthous/package.yaml157
-rw-r--r--users/aspen/xanthous/pkg.nix349
-rw-r--r--users/aspen/xanthous/server/.envrc1
-rw-r--r--users/aspen/xanthous/server/.gitignore1
-rw-r--r--users/aspen/xanthous/server/Cargo.lock1874
-rw-r--r--users/aspen/xanthous/server/Cargo.toml29
-rw-r--r--users/aspen/xanthous/server/default.nix24
-rw-r--r--users/aspen/xanthous/server/docker.nix21
-rw-r--r--users/aspen/xanthous/server/module.nix49
-rw-r--r--users/aspen/xanthous/server/shell.nix11
-rw-r--r--users/aspen/xanthous/server/src/main.rs385
-rw-r--r--users/aspen/xanthous/server/src/metrics.rs24
-rw-r--r--users/aspen/xanthous/server/src/pty.rs172
-rw-r--r--users/aspen/xanthous/shell.nix23
-rw-r--r--users/aspen/xanthous/src/Data/Aeson/Generic/DerivingVia.hs168
-rw-r--r--users/aspen/xanthous/src/Xanthous/AI/Gormlak.hs201
-rw-r--r--users/aspen/xanthous/src/Xanthous/App.hs647
-rw-r--r--users/aspen/xanthous/src/Xanthous/App/Autocommands.hs76
-rw-r--r--users/aspen/xanthous/src/Xanthous/App/Common.hs67
-rw-r--r--users/aspen/xanthous/src/Xanthous/App/Prompt.hs228
-rw-r--r--users/aspen/xanthous/src/Xanthous/App/Time.hs42
-rw-r--r--users/aspen/xanthous/src/Xanthous/Command.hs145
-rw-r--r--users/aspen/xanthous/src/Xanthous/Data.hs822
-rw-r--r--users/aspen/xanthous/src/Xanthous/Data/App.hs47
-rw-r--r--users/aspen/xanthous/src/Xanthous/Data/Entities.hs68
-rw-r--r--users/aspen/xanthous/src/Xanthous/Data/EntityChar.hs56
-rw-r--r--users/aspen/xanthous/src/Xanthous/Data/EntityMap.hs276
-rw-r--r--users/aspen/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs72
-rw-r--r--users/aspen/xanthous/src/Xanthous/Data/Levels.hs180
-rw-r--r--users/aspen/xanthous/src/Xanthous/Data/Memo.hs98
-rw-r--r--users/aspen/xanthous/src/Xanthous/Data/NestedMap.hs227
-rw-r--r--users/aspen/xanthous/src/Xanthous/Data/VectorBag.hs100
-rw-r--r--users/aspen/xanthous/src/Xanthous/Entities/Character.hs241
-rw-r--r--users/aspen/xanthous/src/Xanthous/Entities/Common.hs290
-rw-r--r--users/aspen/xanthous/src/Xanthous/Entities/Creature.hs88
-rw-r--r--users/aspen/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs71
-rw-r--r--users/aspen/xanthous/src/Xanthous/Entities/Draw/Util.hs31
-rw-r--r--users/aspen/xanthous/src/Xanthous/Entities/Entities.hs63
-rw-r--r--users/aspen/xanthous/src/Xanthous/Entities/Entities.hs-boot14
-rw-r--r--users/aspen/xanthous/src/Xanthous/Entities/Environment.hs160
-rw-r--r--users/aspen/xanthous/src/Xanthous/Entities/Item.hs76
-rw-r--r--users/aspen/xanthous/src/Xanthous/Entities/Marker.hs41
-rw-r--r--users/aspen/xanthous/src/Xanthous/Entities/RawTypes.hs286
-rw-r--r--users/aspen/xanthous/src/Xanthous/Entities/Raws.hs49
-rw-r--r--users/aspen/xanthous/src/Xanthous/Entities/Raws/broken-dagger.yaml24
-rw-r--r--users/aspen/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml20
-rw-r--r--users/aspen/xanthous/src/Xanthous/Entities/Raws/husk.yaml26
-rw-r--r--users/aspen/xanthous/src/Xanthous/Entities/Raws/noodles.yaml14
-rw-r--r--users/aspen/xanthous/src/Xanthous/Entities/Raws/ooze.yaml15
-rw-r--r--users/aspen/xanthous/src/Xanthous/Entities/Raws/rock.yaml10
-rw-r--r--users/aspen/xanthous/src/Xanthous/Entities/Raws/stick.yaml22
-rw-r--r--users/aspen/xanthous/src/Xanthous/Game.hs73
-rw-r--r--users/aspen/xanthous/src/Xanthous/Game/Arbitrary.hs53
-rw-r--r--users/aspen/xanthous/src/Xanthous/Game/Draw.hs224
-rw-r--r--users/aspen/xanthous/src/Xanthous/Game/Env.hs37
-rw-r--r--users/aspen/xanthous/src/Xanthous/Game/Lenses.hs178
-rw-r--r--users/aspen/xanthous/src/Xanthous/Game/Memo.hs52
-rw-r--r--users/aspen/xanthous/src/Xanthous/Game/Prompt.hs359
-rw-r--r--users/aspen/xanthous/src/Xanthous/Game/State.hs572
-rw-r--r--users/aspen/xanthous/src/Xanthous/Generators/Level.hs172
-rw-r--r--users/aspen/xanthous/src/Xanthous/Generators/Level/CaveAutomata.hs112
-rw-r--r--users/aspen/xanthous/src/Xanthous/Generators/Level/Dungeon.hs190
-rw-r--r--users/aspen/xanthous/src/Xanthous/Generators/Level/LevelContents.hs182
-rw-r--r--users/aspen/xanthous/src/Xanthous/Generators/Level/Util.hs236
-rw-r--r--users/aspen/xanthous/src/Xanthous/Generators/Level/Village.hs126
-rw-r--r--users/aspen/xanthous/src/Xanthous/Generators/Speech.hs181
-rw-r--r--users/aspen/xanthous/src/Xanthous/Messages.hs114
-rw-r--r--users/aspen/xanthous/src/Xanthous/Messages/Template.hs275
-rw-r--r--users/aspen/xanthous/src/Xanthous/Monad.hs76
-rw-r--r--users/aspen/xanthous/src/Xanthous/Orphans.hs495
-rw-r--r--users/aspen/xanthous/src/Xanthous/Physics.hs71
-rw-r--r--users/aspen/xanthous/src/Xanthous/Prelude.hs48
-rw-r--r--users/aspen/xanthous/src/Xanthous/Random.hs186
-rw-r--r--users/aspen/xanthous/src/Xanthous/Util.hs351
-rw-r--r--users/aspen/xanthous/src/Xanthous/Util/Comonad.hs24
-rw-r--r--users/aspen/xanthous/src/Xanthous/Util/Graph.hs33
-rw-r--r--users/aspen/xanthous/src/Xanthous/Util/Graphics.hs177
-rw-r--r--users/aspen/xanthous/src/Xanthous/Util/Inflection.hs14
-rw-r--r--users/aspen/xanthous/src/Xanthous/Util/JSON.hs19
-rw-r--r--users/aspen/xanthous/src/Xanthous/Util/Optparse.hs21
-rw-r--r--users/aspen/xanthous/src/Xanthous/Util/QuickCheck.hs32
-rw-r--r--users/aspen/xanthous/src/Xanthous/keybindings.yaml22
-rw-r--r--users/aspen/xanthous/src/Xanthous/messages.yaml161
-rw-r--r--users/aspen/xanthous/test/Spec.hs61
-rw-r--r--users/aspen/xanthous/test/Test/Prelude.hs34
-rw-r--r--users/aspen/xanthous/test/Xanthous/CommandSpec.hs40
-rw-r--r--users/aspen/xanthous/test/Xanthous/Data/EntitiesSpec.hs28
-rw-r--r--users/aspen/xanthous/test/Xanthous/Data/EntityCharSpec.hs18
-rw-r--r--users/aspen/xanthous/test/Xanthous/Data/EntityMap/GraphicsSpec.hs57
-rw-r--r--users/aspen/xanthous/test/Xanthous/Data/EntityMapSpec.hs69
-rw-r--r--users/aspen/xanthous/test/Xanthous/Data/LevelsSpec.hs66
-rw-r--r--users/aspen/xanthous/test/Xanthous/Data/MemoSpec.hs19
-rw-r--r--users/aspen/xanthous/test/Xanthous/Data/NestedMapSpec.hs20
-rw-r--r--users/aspen/xanthous/test/Xanthous/DataSpec.hs109
-rw-r--r--users/aspen/xanthous/test/Xanthous/Entities/CharacterSpec.hs24
-rw-r--r--users/aspen/xanthous/test/Xanthous/Entities/CommonSpec.hs65
-rw-r--r--users/aspen/xanthous/test/Xanthous/Entities/RawTypesSpec.hs45
-rw-r--r--users/aspen/xanthous/test/Xanthous/Entities/RawsSpec.hs30
-rw-r--r--users/aspen/xanthous/test/Xanthous/Game/PromptSpec.hs19
-rw-r--r--users/aspen/xanthous/test/Xanthous/Game/StateSpec.hs30
-rw-r--r--users/aspen/xanthous/test/Xanthous/GameSpec.hs55
-rw-r--r--users/aspen/xanthous/test/Xanthous/Generators/Level/UtilSpec.hs127
-rw-r--r--users/aspen/xanthous/test/Xanthous/MessageSpec.hs59
-rw-r--r--users/aspen/xanthous/test/Xanthous/Messages/TemplateSpec.hs80
-rw-r--r--users/aspen/xanthous/test/Xanthous/OrphansSpec.hs72
-rw-r--r--users/aspen/xanthous/test/Xanthous/RandomSpec.hs45
-rw-r--r--users/aspen/xanthous/test/Xanthous/Util/GraphSpec.hs39
-rw-r--r--users/aspen/xanthous/test/Xanthous/Util/GraphicsSpec.hs72
-rw-r--r--users/aspen/xanthous/test/Xanthous/Util/InflectionSpec.hs18
-rw-r--r--users/aspen/xanthous/test/Xanthous/UtilSpec.hs46
-rw-r--r--users/aspen/xanthous/xanthous.cabal529
131 files changed, 16177 insertions, 0 deletions
diff --git a/users/aspen/xanthous/.envrc b/users/aspen/xanthous/.envrc
new file mode 100644
index 000000000000..be81feddb1a5
--- /dev/null
+++ b/users/aspen/xanthous/.envrc
@@ -0,0 +1 @@
+eval "$(lorri direnv)"
\ No newline at end of file
diff --git a/users/aspen/xanthous/.github/actions/nix-build/Dockerfile b/users/aspen/xanthous/.github/actions/nix-build/Dockerfile
new file mode 100644
index 000000000000..cfe8e35df091
--- /dev/null
+++ b/users/aspen/xanthous/.github/actions/nix-build/Dockerfile
@@ -0,0 +1,23 @@
+FROM lnl7/nix:2.1.2
+
+LABEL name="Nix Build for GitHub Actions"
+LABEL version="1.0"
+LABEL repository="http://github.com/glittershark/xanthous"
+LABEL homepage="http://github.com/glittershark/xanthous"
+LABEL maintainer="Griffin Smith <root at gws dot fyi>"
+
+LABEL "com.github.actions.name"="Nix Build"
+LABEL "com.github.actions.description"="Runs 'nix-build'"
+LABEL "com.github.actions.icon"="cpu"
+LABEL "com.github.actions.color"="purple"
+
+RUN nix-env -iA \
+  nixpkgs.gnutar nixpkgs.gzip \
+  nixpkgs.gnugrep nixpkgs.git && \
+  mkdir -p /etc/nix && \
+  (echo "binary-caches = https://cache.nixos.org/" | tee -a /etc/nix/nix.conf) && \
+  (echo "trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=" | tee -a /etc/nix/nix.conf)
+
+COPY entrypoint.sh /entrypoint.sh
+ENTRYPOINT [ "/entrypoint.sh" ]
+CMD [ "--help" ]
diff --git a/users/aspen/xanthous/.github/actions/nix-build/entrypoint.sh b/users/aspen/xanthous/.github/actions/nix-build/entrypoint.sh
new file mode 100755
index 000000000000..cb7aca541a3f
--- /dev/null
+++ b/users/aspen/xanthous/.github/actions/nix-build/entrypoint.sh
@@ -0,0 +1,24 @@
+#!/usr/bin/env bash
+
+# Entrypoint that runs nix-build and, optionally, copies Docker image tarballs
+# to real files. The reason this is necessary is because once a Nix container
+# exits, you must copy out the artifacts to the working directory before exit.
+
+[ "$DEBUG" = "1" ] && set -x
+[ "$QUIET" = "1" ] && QUIET_ARG="-Q"
+
+set -e
+
+# file to build (e.g. release.nix)
+file="$1"
+
+[ "$file" = "" ] && echo "No .nix file to build specified!" && exit 1
+[ ! -e "$file" ] && echo "File $file not exist!" && exit 1
+
+echo "Building all attrs in $file..."
+nix-build --no-link ${QUIET_ARG} "$file" "${@:2}"
+
+echo "Copying build closure to $(pwd)/store..."
+mapfile -t storePaths < <(nix-build ${QUIET_ARG} --no-link "$file" | grep -v cache-deps)
+printf '%s\n' "${storePaths[@]}" > store.roots
+nix copy --to "file://$(pwd)/store" "${storePaths[@]}"
diff --git a/users/aspen/xanthous/.github/workflows/haskell.yml b/users/aspen/xanthous/.github/workflows/haskell.yml
new file mode 100644
index 000000000000..df82de3e8caf
--- /dev/null
+++ b/users/aspen/xanthous/.github/workflows/haskell.yml
@@ -0,0 +1,15 @@
+name: Haskell CI
+
+on: [push]
+
+jobs:
+  build:
+
+    runs-on: ubuntu-latest
+
+    steps:
+    - uses: actions/checkout@v1
+    - name: Nix Build
+      with:
+        args: default.nix --arg failOnWarnings true
+      uses: ./.github/actions/nix-build
diff --git a/users/aspen/xanthous/.gitignore b/users/aspen/xanthous/.gitignore
new file mode 100644
index 000000000000..2ad31c01d443
--- /dev/null
+++ b/users/aspen/xanthous/.gitignore
@@ -0,0 +1,37 @@
+dist
+dist-*
+cabal-dev
+*.o
+*.hi
+*.hie
+*.chi
+*.chs.h
+*.dyn_o
+*.dyn_hi
+.hpc
+.hsenv
+.cabal-sandbox/
+cabal.sandbox.config
+*.prof
+*.aux
+*.hp
+*.eventlog
+.stack-work/
+cabal.project.local
+cabal.project.local~
+cabal.project.local~*
+.HTF/
+.ghc.environment.*
+
+
+# from nix-build
+result
+
+# grr
+*_flymake.hs
+
+# app-specific
+debug.log
+data
+*.save
+.tasty-rerun-log
diff --git a/users/aspen/xanthous/LICENSE b/users/aspen/xanthous/LICENSE
new file mode 100644
index 000000000000..45644ff76449
--- /dev/null
+++ b/users/aspen/xanthous/LICENSE
@@ -0,0 +1,674 @@
+              GNU GENERAL PUBLIC LICENSE
+                Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+                     Preamble
+
+  The GNU General Public License is a free, copyleft license for
+software and other kinds of works.
+
+  The licenses for most software and other practical works are designed
+to take away your freedom to share and change the works.  By contrast,
+the GNU General Public License is intended to guarantee your freedom to
+share and change all versions of a program--to make sure it remains free
+software for all its users.  We, the Free Software Foundation, use the
+GNU General Public License for most of our software; it applies also to
+any other work released this way by its authors.  You can apply it to
+your programs, too.
+
+  When we speak of free software, we are referring to freedom, not
+price.  Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+them if you wish), that you receive source code or can get it if you
+want it, that you can change the software or use pieces of it in new
+free programs, and that you know you can do these things.
+
+  To protect your rights, we need to prevent others from denying you
+these rights or asking you to surrender the rights.  Therefore, you have
+certain responsibilities if you distribute copies of the software, or if
+you modify it: responsibilities to respect the freedom of others.
+
+  For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must pass on to the recipients the same
+freedoms that you received.  You must make sure that they, too, receive
+or can get the source code.  And you must show them these terms so they
+know their rights.
+
+  Developers that use the GNU GPL protect your rights with two steps:
+(1) assert copyright on the software, and (2) offer you this License
+giving you legal permission to copy, distribute and/or modify it.
+
+  For the developers' and authors' protection, the GPL clearly explains
+that there is no warranty for this free software.  For both users' and
+authors' sake, the GPL requires that modified versions be marked as
+changed, so that their problems will not be attributed erroneously to
+authors of previous versions.
+
+  Some devices are designed to deny users access to install or run
+modified versions of the software inside them, although the manufacturer
+can do so.  This is fundamentally incompatible with the aim of
+protecting users' freedom to change the software.  The systematic
+pattern of such abuse occurs in the area of products for individuals to
+use, which is precisely where it is most unacceptable.  Therefore, we
+have designed this version of the GPL to prohibit the practice for those
+products.  If such problems arise substantially in other domains, we
+stand ready to extend this provision to those domains in future versions
+of the GPL, as needed to protect the freedom of users.
+
+  Finally, every program is threatened constantly by software patents.
+States should not allow patents to restrict development and use of
+software on general-purpose computers, but in those that do, we wish to
+avoid the special danger that patents applied to a free program could
+make it effectively proprietary.  To prevent this, the GPL assures that
+patents cannot be used to render the program non-free.
+
+  The precise terms and conditions for copying, distribution and
+modification follow.
+
+                TERMS AND CONDITIONS
+
+  0. Definitions.
+
+  "This License" refers to version 3 of the GNU General Public License.
+
+  "Copyright" also means copyright-like laws that apply to other kinds of
+works, such as semiconductor masks.
+
+  "The Program" refers to any copyrightable work licensed under this
+License.  Each licensee is addressed as "you".  "Licensees" and
+"recipients" may be individuals or organizations.
+
+  To "modify" a work means to copy from or adapt all or part of the work
+in a fashion requiring copyright permission, other than the making of an
+exact copy.  The resulting work is called a "modified version" of the
+earlier work or a work "based on" the earlier work.
+
+  A "covered work" means either the unmodified Program or a work based
+on the Program.
+
+  To "propagate" a work means to do anything with it that, without
+permission, would make you directly or secondarily liable for
+infringement under applicable copyright law, except executing it on a
+computer or modifying a private copy.  Propagation includes copying,
+distribution (with or without modification), making available to the
+public, and in some countries other activities as well.
+
+  To "convey" a work means any kind of propagation that enables other
+parties to make or receive copies.  Mere interaction with a user through
+a computer network, with no transfer of a copy, is not conveying.
+
+  An interactive user interface displays "Appropriate Legal Notices"
+to the extent that it includes a convenient and prominently visible
+feature that (1) displays an appropriate copyright notice, and (2)
+tells the user that there is no warranty for the work (except to the
+extent that warranties are provided), that licensees may convey the
+work under this License, and how to view a copy of this License.  If
+the interface presents a list of user commands or options, such as a
+menu, a prominent item in the list meets this criterion.
+
+  1. Source Code.
+
+  The "source code" for a work means the preferred form of the work
+for making modifications to it.  "Object code" means any non-source
+form of a work.
+
+  A "Standard Interface" means an interface that either is an official
+standard defined by a recognized standards body, or, in the case of
+interfaces specified for a particular programming language, one that
+is widely used among developers working in that language.
+
+  The "System Libraries" of an executable work include anything, other
+than the work as a whole, that (a) is included in the normal form of
+packaging a Major Component, but which is not part of that Major
+Component, and (b) serves only to enable use of the work with that
+Major Component, or to implement a Standard Interface for which an
+implementation is available to the public in source code form.  A
+"Major Component", in this context, means a major essential component
+(kernel, window system, and so on) of the specific operating system
+(if any) on which the executable work runs, or a compiler used to
+produce the work, or an object code interpreter used to run it.
+
+  The "Corresponding Source" for a work in object code form means all
+the source code needed to generate, install, and (for an executable
+work) run the object code and to modify the work, including scripts to
+control those activities.  However, it does not include the work's
+System Libraries, or general-purpose tools or generally available free
+programs which are used unmodified in performing those activities but
+which are not part of the work.  For example, Corresponding Source
+includes interface definition files associated with source files for
+the work, and the source code for shared libraries and dynamically
+linked subprograms that the work is specifically designed to require,
+such as by intimate data communication or control flow between those
+subprograms and other parts of the work.
+
+  The Corresponding Source need not include anything that users
+can regenerate automatically from other parts of the Corresponding
+Source.
+
+  The Corresponding Source for a work in source code form is that
+same work.
+
+  2. Basic Permissions.
+
+  All rights granted under this License are granted for the term of
+copyright on the Program, and are irrevocable provided the stated
+conditions are met.  This License explicitly affirms your unlimited
+permission to run the unmodified Program.  The output from running a
+covered work is covered by this License only if the output, given its
+content, constitutes a covered work.  This License acknowledges your
+rights of fair use or other equivalent, as provided by copyright law.
+
+  You may make, run and propagate covered works that you do not
+convey, without conditions so long as your license otherwise remains
+in force.  You may convey covered works to others for the sole purpose
+of having them make modifications exclusively for you, or provide you
+with facilities for running those works, provided that you comply with
+the terms of this License in conveying all material for which you do
+not control copyright.  Those thus making or running the covered works
+for you must do so exclusively on your behalf, under your direction
+and control, on terms that prohibit them from making any copies of
+your copyrighted material outside their relationship with you.
+
+  Conveying under any other circumstances is permitted solely under
+the conditions stated below.  Sublicensing is not allowed; section 10
+makes it unnecessary.
+
+  3. Protecting Users' Legal Rights From Anti-Circumvention Law.
+
+  No covered work shall be deemed part of an effective technological
+measure under any applicable law fulfilling obligations under article
+11 of the WIPO copyright treaty adopted on 20 December 1996, or
+similar laws prohibiting or restricting circumvention of such
+measures.
+
+  When you convey a covered work, you waive any legal power to forbid
+circumvention of technological measures to the extent such circumvention
+is effected by exercising rights under this License with respect to
+the covered work, and you disclaim any intention to limit operation or
+modification of the work as a means of enforcing, against the work's
+users, your or third parties' legal rights to forbid circumvention of
+technological measures.
+
+  4. Conveying Verbatim Copies.
+
+  You may convey verbatim copies of the Program's source code as you
+receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice;
+keep intact all notices stating that this License and any
+non-permissive terms added in accord with section 7 apply to the code;
+keep intact all notices of the absence of any warranty; and give all
+recipients a copy of this License along with the Program.
+
+  You may charge any price or no price for each copy that you convey,
+and you may offer support or warranty protection for a fee.
+
+  5. Conveying Modified Source Versions.
+
+  You may convey a work based on the Program, or the modifications to
+produce it from the Program, in the form of source code under the
+terms of section 4, provided that you also meet all of these conditions:
+
+    a) The work must carry prominent notices stating that you modified
+    it, and giving a relevant date.
+
+    b) The work must carry prominent notices stating that it is
+    released under this License and any conditions added under section
+    7.  This requirement modifies the requirement in section 4 to
+    "keep intact all notices".
+
+    c) You must license the entire work, as a whole, under this
+    License to anyone who comes into possession of a copy.  This
+    License will therefore apply, along with any applicable section 7
+    additional terms, to the whole of the work, and all its parts,
+    regardless of how they are packaged.  This License gives no
+    permission to license the work in any other way, but it does not
+    invalidate such permission if you have separately received it.
+
+    d) If the work has interactive user interfaces, each must display
+    Appropriate Legal Notices; however, if the Program has interactive
+    interfaces that do not display Appropriate Legal Notices, your
+    work need not make them do so.
+
+  A compilation of a covered work with other separate and independent
+works, which are not by their nature extensions of the covered work,
+and which are not combined with it such as to form a larger program,
+in or on a volume of a storage or distribution medium, is called an
+"aggregate" if the compilation and its resulting copyright are not
+used to limit the access or legal rights of the compilation's users
+beyond what the individual works permit.  Inclusion of a covered work
+in an aggregate does not cause this License to apply to the other
+parts of the aggregate.
+
+  6. Conveying Non-Source Forms.
+
+  You may convey a covered work in object code form under the terms
+of sections 4 and 5, provided that you also convey the
+machine-readable Corresponding Source under the terms of this License,
+in one of these ways:
+
+    a) Convey the object code in, or embodied in, a physical product
+    (including a physical distribution medium), accompanied by the
+    Corresponding Source fixed on a durable physical medium
+    customarily used for software interchange.
+
+    b) Convey the object code in, or embodied in, a physical product
+    (including a physical distribution medium), accompanied by a
+    written offer, valid for at least three years and valid for as
+    long as you offer spare parts or customer support for that product
+    model, to give anyone who possesses the object code either (1) a
+    copy of the Corresponding Source for all the software in the
+    product that is covered by this License, on a durable physical
+    medium customarily used for software interchange, for a price no
+    more than your reasonable cost of physically performing this
+    conveying of source, or (2) access to copy the
+    Corresponding Source from a network server at no charge.
+
+    c) Convey individual copies of the object code with a copy of the
+    written offer to provide the Corresponding Source.  This
+    alternative is allowed only occasionally and noncommercially, and
+    only if you received the object code with such an offer, in accord
+    with subsection 6b.
+
+    d) Convey the object code by offering access from a designated
+    place (gratis or for a charge), and offer equivalent access to the
+    Corresponding Source in the same way through the same place at no
+    further charge.  You need not require recipients to copy the
+    Corresponding Source along with the object code.  If the place to
+    copy the object code is a network server, the Corresponding Source
+    may be on a different server (operated by you or a third party)
+    that supports equivalent copying facilities, provided you maintain
+    clear directions next to the object code saying where to find the
+    Corresponding Source.  Regardless of what server hosts the
+    Corresponding Source, you remain obligated to ensure that it is
+    available for as long as needed to satisfy these requirements.
+
+    e) Convey the object code using peer-to-peer transmission, provided
+    you inform other peers where the object code and Corresponding
+    Source of the work are being offered to the general public at no
+    charge under subsection 6d.
+
+  A separable portion of the object code, whose source code is excluded
+from the Corresponding Source as a System Library, need not be
+included in conveying the object code work.
+
+  A "User Product" is either (1) a "consumer product", which means any
+tangible personal property which is normally used for personal, family,
+or household purposes, or (2) anything designed or sold for incorporation
+into a dwelling.  In determining whether a product is a consumer product,
+doubtful cases shall be resolved in favor of coverage.  For a particular
+product received by a particular user, "normally used" refers to a
+typical or common use of that class of product, regardless of the status
+of the particular user or of the way in which the particular user
+actually uses, or expects or is expected to use, the product.  A product
+is a consumer product regardless of whether the product has substantial
+commercial, industrial or non-consumer uses, unless such uses represent
+the only significant mode of use of the product.
+
+  "Installation Information" for a User Product means any methods,
+procedures, authorization keys, or other information required to install
+and execute modified versions of a covered work in that User Product from
+a modified version of its Corresponding Source.  The information must
+suffice to ensure that the continued functioning of the modified object
+code is in no case prevented or interfered with solely because
+modification has been made.
+
+  If you convey an object code work under this section in, or with, or
+specifically for use in, a User Product, and the conveying occurs as
+part of a transaction in which the right of possession and use of the
+User Product is transferred to the recipient in perpetuity or for a
+fixed term (regardless of how the transaction is characterized), the
+Corresponding Source conveyed under this section must be accompanied
+by the Installation Information.  But this requirement does not apply
+if neither you nor any third party retains the ability to install
+modified object code on the User Product (for example, the work has
+been installed in ROM).
+
+  The requirement to provide Installation Information does not include a
+requirement to continue to provide support service, warranty, or updates
+for a work that has been modified or installed by the recipient, or for
+the User Product in which it has been modified or installed.  Access to a
+network may be denied when the modification itself materially and
+adversely affects the operation of the network or violates the rules and
+protocols for communication across the network.
+
+  Corresponding Source conveyed, and Installation Information provided,
+in accord with this section must be in a format that is publicly
+documented (and with an implementation available to the public in
+source code form), and must require no special password or key for
+unpacking, reading or copying.
+
+  7. Additional Terms.
+
+  "Additional permissions" are terms that supplement the terms of this
+License by making exceptions from one or more of its conditions.
+Additional permissions that are applicable to the entire Program shall
+be treated as though they were included in this License, to the extent
+that they are valid under applicable law.  If additional permissions
+apply only to part of the Program, that part may be used separately
+under those permissions, but the entire Program remains governed by
+this License without regard to the additional permissions.
+
+  When you convey a copy of a covered work, you may at your option
+remove any additional permissions from that copy, or from any part of
+it.  (Additional permissions may be written to require their own
+removal in certain cases when you modify the work.)  You may place
+additional permissions on material, added by you to a covered work,
+for which you have or can give appropriate copyright permission.
+
+  Notwithstanding any other provision of this License, for material you
+add to a covered work, you may (if authorized by the copyright holders of
+that material) supplement the terms of this License with terms:
+
+    a) Disclaiming warranty or limiting liability differently from the
+    terms of sections 15 and 16 of this License; or
+
+    b) Requiring preservation of specified reasonable legal notices or
+    author attributions in that material or in the Appropriate Legal
+    Notices displayed by works containing it; or
+
+    c) Prohibiting misrepresentation of the origin of that material, or
+    requiring that modified versions of such material be marked in
+    reasonable ways as different from the original version; or
+
+    d) Limiting the use for publicity purposes of names of licensors or
+    authors of the material; or
+
+    e) Declining to grant rights under trademark law for use of some
+    trade names, trademarks, or service marks; or
+
+    f) Requiring indemnification of licensors and authors of that
+    material by anyone who conveys the material (or modified versions of
+    it) with contractual assumptions of liability to the recipient, for
+    any liability that these contractual assumptions directly impose on
+    those licensors and authors.
+
+  All other non-permissive additional terms are considered "further
+restrictions" within the meaning of section 10.  If the Program as you
+received it, or any part of it, contains a notice stating that it is
+governed by this License along with a term that is a further
+restriction, you may remove that term.  If a license document contains
+a further restriction but permits relicensing or conveying under this
+License, you may add to a covered work material governed by the terms
+of that license document, provided that the further restriction does
+not survive such relicensing or conveying.
+
+  If you add terms to a covered work in accord with this section, you
+must place, in the relevant source files, a statement of the
+additional terms that apply to those files, or a notice indicating
+where to find the applicable terms.
+
+  Additional terms, permissive or non-permissive, may be stated in the
+form of a separately written license, or stated as exceptions;
+the above requirements apply either way.
+
+  8. Termination.
+
+  You may not propagate or modify a covered work except as expressly
+provided under this License.  Any attempt otherwise to propagate or
+modify it is void, and will automatically terminate your rights under
+this License (including any patent licenses granted under the third
+paragraph of section 11).
+
+  However, if you cease all violation of this License, then your
+license from a particular copyright holder is reinstated (a)
+provisionally, unless and until the copyright holder explicitly and
+finally terminates your license, and (b) permanently, if the copyright
+holder fails to notify you of the violation by some reasonable means
+prior to 60 days after the cessation.
+
+  Moreover, your license from a particular copyright holder is
+reinstated permanently if the copyright holder notifies you of the
+violation by some reasonable means, this is the first time you have
+received notice of violation of this License (for any work) from that
+copyright holder, and you cure the violation prior to 30 days after
+your receipt of the notice.
+
+  Termination of your rights under this section does not terminate the
+licenses of parties who have received copies or rights from you under
+this License.  If your rights have been terminated and not permanently
+reinstated, you do not qualify to receive new licenses for the same
+material under section 10.
+
+  9. Acceptance Not Required for Having Copies.
+
+  You are not required to accept this License in order to receive or
+run a copy of the Program.  Ancillary propagation of a covered work
+occurring solely as a consequence of using peer-to-peer transmission
+to receive a copy likewise does not require acceptance.  However,
+nothing other than this License grants you permission to propagate or
+modify any covered work.  These actions infringe copyright if you do
+not accept this License.  Therefore, by modifying or propagating a
+covered work, you indicate your acceptance of this License to do so.
+
+  10. Automatic Licensing of Downstream Recipients.
+
+  Each time you convey a covered work, the recipient automatically
+receives a license from the original licensors, to run, modify and
+propagate that work, subject to this License.  You are not responsible
+for enforcing compliance by third parties with this License.
+
+  An "entity transaction" is a transaction transferring control of an
+organization, or substantially all assets of one, or subdividing an
+organization, or merging organizations.  If propagation of a covered
+work results from an entity transaction, each party to that
+transaction who receives a copy of the work also receives whatever
+licenses to the work the party's predecessor in interest had or could
+give under the previous paragraph, plus a right to possession of the
+Corresponding Source of the work from the predecessor in interest, if
+the predecessor has it or can get it with reasonable efforts.
+
+  You may not impose any further restrictions on the exercise of the
+rights granted or affirmed under this License.  For example, you may
+not impose a license fee, royalty, or other charge for exercise of
+rights granted under this License, and you may not initiate litigation
+(including a cross-claim or counterclaim in a lawsuit) alleging that
+any patent claim is infringed by making, using, selling, offering for
+sale, or importing the Program or any portion of it.
+
+  11. Patents.
+
+  A "contributor" is a copyright holder who authorizes use under this
+License of the Program or a work on which the Program is based.  The
+work thus licensed is called the contributor's "contributor version".
+
+  A contributor's "essential patent claims" are all patent claims
+owned or controlled by the contributor, whether already acquired or
+hereafter acquired, that would be infringed by some manner, permitted
+by this License, of making, using, or selling its contributor version,
+but do not include claims that would be infringed only as a
+consequence of further modification of the contributor version.  For
+purposes of this definition, "control" includes the right to grant
+patent sublicenses in a manner consistent with the requirements of
+this License.
+
+  Each contributor grants you a non-exclusive, worldwide, royalty-free
+patent license under the contributor's essential patent claims, to
+make, use, sell, offer for sale, import and otherwise run, modify and
+propagate the contents of its contributor version.
+
+  In the following three paragraphs, a "patent license" is any express
+agreement or commitment, however denominated, not to enforce a patent
+(such as an express permission to practice a patent or covenant not to
+sue for patent infringement).  To "grant" such a patent license to a
+party means to make such an agreement or commitment not to enforce a
+patent against the party.
+
+  If you convey a covered work, knowingly relying on a patent license,
+and the Corresponding Source of the work is not available for anyone
+to copy, free of charge and under the terms of this License, through a
+publicly available network server or other readily accessible means,
+then you must either (1) cause the Corresponding Source to be so
+available, or (2) arrange to deprive yourself of the benefit of the
+patent license for this particular work, or (3) arrange, in a manner
+consistent with the requirements of this License, to extend the patent
+license to downstream recipients.  "Knowingly relying" means you have
+actual knowledge that, but for the patent license, your conveying the
+covered work in a country, or your recipient's use of the covered work
+in a country, would infringe one or more identifiable patents in that
+country that you have reason to believe are valid.
+
+  If, pursuant to or in connection with a single transaction or
+arrangement, you convey, or propagate by procuring conveyance of, a
+covered work, and grant a patent license to some of the parties
+receiving the covered work authorizing them to use, propagate, modify
+or convey a specific copy of the covered work, then the patent license
+you grant is automatically extended to all recipients of the covered
+work and works based on it.
+
+  A patent license is "discriminatory" if it does not include within
+the scope of its coverage, prohibits the exercise of, or is
+conditioned on the non-exercise of one or more of the rights that are
+specifically granted under this License.  You may not convey a covered
+work if you are a party to an arrangement with a third party that is
+in the business of distributing software, under which you make payment
+to the third party based on the extent of your activity of conveying
+the work, and under which the third party grants, to any of the
+parties who would receive the covered work from you, a discriminatory
+patent license (a) in connection with copies of the covered work
+conveyed by you (or copies made from those copies), or (b) primarily
+for and in connection with specific products or compilations that
+contain the covered work, unless you entered into that arrangement,
+or that patent license was granted, prior to 28 March 2007.
+
+  Nothing in this License shall be construed as excluding or limiting
+any implied license or other defenses to infringement that may
+otherwise be available to you under applicable patent law.
+
+  12. No Surrender of Others' Freedom.
+
+  If conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License.  If you cannot convey a
+covered work so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you may
+not convey it at all.  For example, if you agree to terms that obligate you
+to collect a royalty for further conveying from those to whom you convey
+the Program, the only way you could satisfy both those terms and this
+License would be to refrain entirely from conveying the Program.
+
+  13. Use with the GNU Affero General Public License.
+
+  Notwithstanding any other provision of this License, you have
+permission to link or combine any covered work with a work licensed
+under version 3 of the GNU Affero General Public License into a single
+combined work, and to convey the resulting work.  The terms of this
+License will continue to apply to the part which is the covered work,
+but the special requirements of the GNU Affero General Public License,
+section 13, concerning interaction through a network will apply to the
+combination as such.
+
+  14. Revised Versions of this License.
+
+  The Free Software Foundation may publish revised and/or new versions of
+the GNU General Public License from time to time.  Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+  Each version is given a distinguishing version number.  If the
+Program specifies that a certain numbered version of the GNU General
+Public License "or any later version" applies to it, you have the
+option of following the terms and conditions either of that numbered
+version or of any later version published by the Free Software
+Foundation.  If the Program does not specify a version number of the
+GNU General Public License, you may choose any version ever published
+by the Free Software Foundation.
+
+  If the Program specifies that a proxy can decide which future
+versions of the GNU General Public License can be used, that proxy's
+public statement of acceptance of a version permanently authorizes you
+to choose that version for the Program.
+
+  Later license versions may give you additional or different
+permissions.  However, no additional obligations are imposed on any
+author or copyright holder as a result of your choosing to follow a
+later version.
+
+  15. Disclaimer of Warranty.
+
+  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
+APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
+IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+  16. Limitation of Liability.
+
+  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.
+
+  17. Interpretation of Sections 15 and 16.
+
+  If the disclaimer of warranty and limitation of liability provided
+above cannot be given local legal effect according to their terms,
+reviewing courts shall apply local law that most closely approximates
+an absolute waiver of all civil liability in connection with the
+Program, unless a warranty or assumption of liability accompanies a
+copy of the Program in return for a fee.
+
+              END OF TERMS AND CONDITIONS
+
+     How to Apply These Terms to Your New Programs
+
+  If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+  To do so, attach the following notices to the program.  It is safest
+to attach them to the start of each source file to most effectively
+state the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+    <one line to give the program's name and a brief idea of what it does.>
+    Copyright (C) <year>  <name of author>
+
+    This program is free software: you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation, either version 3 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+Also add information on how to contact you by electronic and paper mail.
+
+  If the program does terminal interaction, make it output a short
+notice like this when it starts in an interactive mode:
+
+    <program>  Copyright (C) <year>  <name of author>
+    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+    This is free software, and you are welcome to redistribute it
+    under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License.  Of course, your program's commands
+might be different; for a GUI interface, you would use an "about box".
+
+  You should also get your employer (if you work as a programmer) or school,
+if any, to sign a "copyright disclaimer" for the program, if necessary.
+For more information on this, and how to apply and follow the GNU GPL, see
+<http://www.gnu.org/licenses/>.
+
+  The GNU General Public License does not permit incorporating your program
+into proprietary programs.  If your program is a subroutine library, you
+may consider it more useful to permit linking proprietary applications with
+the library.  If this is what you want to do, use the GNU Lesser General
+Public License instead of this License.  But first, please read
+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
diff --git a/users/aspen/xanthous/README.org b/users/aspen/xanthous/README.org
new file mode 100644
index 000000000000..7e1fedb069b1
--- /dev/null
+++ b/users/aspen/xanthous/README.org
@@ -0,0 +1,36 @@
+#+TITLE: Xanthous
+
+* Building
+
+#+BEGIN_SRC shell
+$ nix build
+#+END_SRC
+
+* Running
+
+#+BEGIN_SRC shell
+$ ./result/bin/xanthous [--help]
+#+END_SRC
+
+** Keyboard commands
+
+Keyboard commands are currently undocumented, but can be found in [[[https://github.com/glittershark/xanthous/blob/master/src/Xanthous/Command.hs#L26][this file]].
+Movement uses the nethack-esque hjklybnu.
+
+* Development
+
+Use [[https://github.com/target/lorri][lorri]], or run everything in a ~nix-shell~
+
+#+BEGIN_SRC shell
+# Build (for dev)
+$ cabal new-build
+
+# Run the game
+$ cabal new-run xanthous
+
+# Run tests
+$ cabal new-run test
+
+# Run a repl
+$ cabal new-repl
+#+END_SRC
diff --git a/users/aspen/xanthous/Setup.hs b/users/aspen/xanthous/Setup.hs
new file mode 100644
index 000000000000..9a994af677b0
--- /dev/null
+++ b/users/aspen/xanthous/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/users/aspen/xanthous/app/Main.hs b/users/aspen/xanthous/app/Main.hs
new file mode 100644
index 000000000000..c771a0d932cb
--- /dev/null
+++ b/users/aspen/xanthous/app/Main.hs
@@ -0,0 +1,171 @@
+{-# LANGUAGE RecordWildCards #-}
+--------------------------------------------------------------------------------
+module Main ( main ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding (finally)
+import           Brick
+import qualified Brick.BChan
+import qualified Graphics.Vty as Vty
+import qualified Options.Applicative as Opt
+import           System.Random
+import           Control.Monad.Random (getRandom)
+import           Control.Exception (finally)
+import           System.Exit (die)
+--------------------------------------------------------------------------------
+import qualified Xanthous.Game as Game
+import           Xanthous.Game.Env (GameEnv(..))
+import qualified Xanthous.Game.Env as Game
+import           Xanthous.App
+import           Xanthous.Generators.Level
+                 ( GeneratorInput
+                 , parseGeneratorInput
+                 , generateFromInput
+                 , showCells
+                 )
+import qualified Xanthous.Entities.Character as Character
+import           Xanthous.Generators.Level.Util (regions)
+import           Xanthous.Generators.Level.LevelContents
+import           Xanthous.Data (Dimensions, Dimensions'(Dimensions))
+import           Data.Array.IArray ( amap )
+--------------------------------------------------------------------------------
+
+parseGameConfig :: Opt.Parser Game.Config
+parseGameConfig = Game.Config
+  <$> Opt.switch
+      ( Opt.long "disable-saving"
+      <> Opt.help "Disallow saving games"
+      )
+
+data RunParams = RunParams
+  { seed :: Maybe Int
+  , characterName :: Maybe Text
+  , gameConfig :: Game.Config
+  }
+  deriving stock (Show, Eq)
+
+parseRunParams :: Opt.Parser RunParams
+parseRunParams = RunParams
+  <$> optional (Opt.option Opt.auto
+      ( Opt.long "seed"
+      <> Opt.help "Random seed for the game."
+      ))
+  <*> optional (Opt.strOption
+      ( Opt.short 'n'
+      <> Opt.long "name"
+      <> Opt.help
+        ( "Name for the character. If not set on the command line, "
+        <> "will be prompted for at runtime"
+        )
+      ))
+  <*> parseGameConfig
+
+data Command
+  = Run RunParams
+  | Load FilePath
+  | Generate GeneratorInput Dimensions (Maybe Int)
+
+parseDimensions :: Opt.Parser Dimensions
+parseDimensions = Dimensions
+  <$> Opt.option Opt.auto
+       ( Opt.short 'w'
+       <> Opt.long "width"
+       <> Opt.metavar "TILES"
+       )
+  <*> Opt.option Opt.auto
+       ( Opt.short 'h'
+       <> Opt.long "height"
+       <> Opt.metavar "TILES"
+       )
+
+
+parseCommand :: Opt.Parser Command
+parseCommand = (<|> Run <$> parseRunParams) $ Opt.subparser
+  $ Opt.command "run"
+      (Opt.info
+       (Run <$> parseRunParams)
+       (Opt.progDesc "Run the game"))
+  <> Opt.command "load"
+      (Opt.info
+       (Load <$> Opt.argument Opt.str (Opt.metavar "FILE"))
+       (Opt.progDesc "Load a saved game"))
+  <> Opt.command "generate"
+      (Opt.info
+       (Generate
+        <$> parseGeneratorInput
+        <*> parseDimensions
+        <*> optional
+            (Opt.option Opt.auto (Opt.long "seed"))
+        <**> Opt.helper
+       )
+       (Opt.progDesc "Generate a sample level"))
+
+optParser :: Opt.ParserInfo Command
+optParser = Opt.info
+  (parseCommand <**> Opt.helper)
+  (Opt.header "Xanthous: a WIP TUI RPG")
+
+thanks :: IO ()
+thanks = putStr "\n\n" >> putStrLn "Thanks for playing Xanthous!"
+
+newGame :: RunParams -> IO ()
+newGame rparams = do
+  gameSeed <- maybe getRandom pure $ seed rparams
+  when (isNothing $ seed rparams)
+    . putStrLn
+    $ "Seed: " <> tshow gameSeed
+  let initialState = Game.initialStateFromSeed gameSeed &~ do
+        for_ (characterName rparams) $ \cn ->
+          Game.character . Character.characterName ?= cn
+  runGame NewGame (gameConfig rparams) initialState `finally` do
+    thanks
+    when (isNothing $ seed rparams)
+      . putStrLn
+      $ "Seed: " <> tshow gameSeed
+    putStr "\n\n"
+
+loadGame :: FilePath -> IO ()
+loadGame saveFile = do
+  gameState <- maybe (die "Invalid save file!") pure . Game.loadGame  . fromStrict
+              =<< readFile @IO saveFile
+  gameState `deepseq` runGame (LoadGame saveFile) Game.defaultConfig gameState
+
+runGame :: RunType -> Game.Config -> Game.GameState -> IO ()
+runGame rt _config gameState = do
+  _eventChan <- Brick.BChan.newBChan 10
+  let gameEnv = GameEnv {..}
+  app <- makeApp gameEnv rt
+  let buildVty = Vty.mkVty Vty.defaultConfig
+  initialVty <- buildVty
+  _game' <- customMain
+    initialVty
+    buildVty
+    (Just _eventChan)
+    app
+    gameState
+  pure ()
+
+runGenerate :: GeneratorInput -> Dimensions -> Maybe Int -> IO ()
+runGenerate input dims mSeed = do
+  putStrLn "Generating..."
+  genSeed <- maybe getRandom pure mSeed
+  let randGen = mkStdGen genSeed
+      res = generateFromInput input dims randGen
+      rs = regions $ amap not res
+  when (isNothing mSeed)
+    . putStrLn
+    $ "Seed: " <> tshow genSeed
+  putStr "num regions: "
+  print $ length rs
+  putStr "region lengths: "
+  print $ length <$> rs
+  putStr "character position: "
+  print =<< chooseCharacterPosition res
+  putStrLn $ showCells res
+
+runCommand :: Command -> IO ()
+runCommand (Run runParams) = newGame runParams
+runCommand (Load saveFile) = loadGame saveFile
+runCommand (Generate input dims mSeed) = runGenerate input dims mSeed
+
+main :: IO ()
+main = runCommand =<< Opt.execParser optParser
diff --git a/users/aspen/xanthous/bench/Bench.hs b/users/aspen/xanthous/bench/Bench.hs
new file mode 100644
index 000000000000..5889618ee432
--- /dev/null
+++ b/users/aspen/xanthous/bench/Bench.hs
@@ -0,0 +1,12 @@
+--------------------------------------------------------------------------------
+module Main where
+--------------------------------------------------------------------------------
+import Bench.Prelude
+--------------------------------------------------------------------------------
+import qualified Xanthous.RandomBench
+import qualified Xanthous.Generators.UtilBench
+
+main :: IO ()
+main = defaultMain
+  [ Xanthous.Generators.UtilBench.benchmark
+  ]
diff --git a/users/aspen/xanthous/bench/Bench/Prelude.hs b/users/aspen/xanthous/bench/Bench/Prelude.hs
new file mode 100644
index 000000000000..c553abd6d5d0
--- /dev/null
+++ b/users/aspen/xanthous/bench/Bench/Prelude.hs
@@ -0,0 +1,9 @@
+--------------------------------------------------------------------------------
+module Bench.Prelude
+  ( module Xanthous.Prelude
+  , module Criterion.Main
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+import Criterion.Main
+--------------------------------------------------------------------------------
diff --git a/users/aspen/xanthous/bench/Xanthous/Generators/UtilBench.hs b/users/aspen/xanthous/bench/Xanthous/Generators/UtilBench.hs
new file mode 100644
index 000000000000..56310e691c33
--- /dev/null
+++ b/users/aspen/xanthous/bench/Xanthous/Generators/UtilBench.hs
@@ -0,0 +1,37 @@
+--------------------------------------------------------------------------------
+module Xanthous.Generators.UtilBench (benchmark, main) where
+--------------------------------------------------------------------------------
+import           Bench.Prelude
+--------------------------------------------------------------------------------
+import           Data.Array.IArray
+import           Data.Array.Unboxed
+import           System.Random (getStdGen)
+--------------------------------------------------------------------------------
+import           Xanthous.Generators.Util
+import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
+import           Xanthous.Data (Dimensions'(..))
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain [benchmark]
+
+--------------------------------------------------------------------------------
+
+benchmark :: Benchmark
+benchmark = bgroup "Generators.Util"
+  [ bgroup "floodFill"
+    [ env (NFWrapper <$> cells) $ \(NFWrapper ir) ->
+        bench "checkerboard" $ nf (floodFill ir) (1,0)
+    ]
+  ]
+  where
+    cells :: IO Cells
+    cells = CaveAutomata.generate
+      CaveAutomata.defaultParams
+      (Dimensions 50 50)
+      <$> getStdGen
+
+newtype NFWrapper a = NFWrapper a
+
+instance NFData (NFWrapper a) where
+  rnf (NFWrapper x) = x `seq` ()
diff --git a/users/aspen/xanthous/bench/Xanthous/RandomBench.hs b/users/aspen/xanthous/bench/Xanthous/RandomBench.hs
new file mode 100644
index 000000000000..fae4af92a7a5
--- /dev/null
+++ b/users/aspen/xanthous/bench/Xanthous/RandomBench.hs
@@ -0,0 +1,32 @@
+--------------------------------------------------------------------------------
+module Xanthous.RandomBench (benchmark, main) where
+--------------------------------------------------------------------------------
+import Bench.Prelude
+--------------------------------------------------------------------------------
+import Control.Parallel.Strategies
+import Control.Monad.Random
+--------------------------------------------------------------------------------
+import Xanthous.Random
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain [benchmark]
+
+--------------------------------------------------------------------------------
+
+benchmark :: Benchmark
+benchmark = bgroup "Random"
+  [ bgroup "chooseSubset"
+    [ bench "serially" $
+      nf (evalRand $ chooseSubset (0.5 :: Double) [1 :: Int ..1000000])
+         (mkStdGen 1234)
+    ]
+  , bgroup "choose weightedBy"
+    [ bench "serially" $
+      nf (evalRand
+          . choose
+          . weightedBy (\n -> product [n, pred n .. 1])
+          $ [1 :: Int ..1000000])
+         (mkStdGen 1234)
+    ]
+  ]
diff --git a/users/aspen/xanthous/build/generic-arbitrary-export-garbitrary.patch b/users/aspen/xanthous/build/generic-arbitrary-export-garbitrary.patch
new file mode 100644
index 000000000000..f0c936bfca18
--- /dev/null
+++ b/users/aspen/xanthous/build/generic-arbitrary-export-garbitrary.patch
@@ -0,0 +1,12 @@
+diff --git a/src/Test/QuickCheck/Arbitrary/Generic.hs b/src/Test/QuickCheck/Arbitrary/Generic.hs
+index fed6ab3..91f59f1 100644
+--- a/src/Test/QuickCheck/Arbitrary/Generic.hs
++++ b/src/Test/QuickCheck/Arbitrary/Generic.hs
+@@ -23,6 +23,7 @@ The generated 'arbitrary' method is equivalent to
+ 
+ module Test.QuickCheck.Arbitrary.Generic
+   ( Arbitrary(..)
++  , GArbitrary
+   , genericArbitrary
+   , genericShrink
+   ) where
diff --git a/users/aspen/xanthous/build/hgeometry-fix-haddock.patch b/users/aspen/xanthous/build/hgeometry-fix-haddock.patch
new file mode 100644
index 000000000000..748c65b3e0db
--- /dev/null
+++ b/users/aspen/xanthous/build/hgeometry-fix-haddock.patch
@@ -0,0 +1,13 @@
+diff --git a/src/Data/Geometry/PlanarSubdivision/Merge.hs b/src/Data/Geometry/PlanarSubdivision/Merge.hs
+index 1136114..3f4e7bb 100644
+--- a/src/Data/Geometry/PlanarSubdivision/Merge.hs
++++ b/src/Data/Geometry/PlanarSubdivision/Merge.hs
+@@ -153,7 +153,7 @@ mergeWith' mergeFaces p1 p2 = PlanarSubdivision cs vd rd rf
+         -- we have to shift the number of the *Arcs*. Since every dart
+         -- consists of two arcs, we have to shift by numDarts / 2
+         -- Furthermore, we take numFaces - 1 since we want the first
+-        -- *internal* face of p2 (the one with FaceId 1) to correspond with the first free
++        -- /internal/ face of p2 (the one with FaceId 1) to correspond with the first free
+         -- position (at index numFaces)
+
+     cs = p1^.components <> p2'^.components
diff --git a/users/aspen/xanthous/build/update-comonad-extras.patch b/users/aspen/xanthous/build/update-comonad-extras.patch
new file mode 100644
index 000000000000..cd1dbe24d361
--- /dev/null
+++ b/users/aspen/xanthous/build/update-comonad-extras.patch
@@ -0,0 +1,92 @@
+diff --git a/comonad-extras.cabal b/comonad-extras.cabal
+index fc3745a..77a2f0d 100644
+--- a/comonad-extras.cabal
++++ b/comonad-extras.cabal
+@@ -1,7 +1,7 @@
+ name:          comonad-extras
+ category:      Control, Comonads
+-version:       4.0
++version:       5.0
+ x-revision: 1
+ license:       BSD3
+ cabal-version: >= 1.6
+ license-file:  LICENSE
+@@ -34,8 +34,8 @@ library
+   build-depends:
+     array                >= 0.3   && < 0.6,
+-    base                 >= 4     && < 4.7,
+-    containers           >= 0.4   && < 0.6,
+-    comonad              >= 4     && < 5,
++    base                 >= 4     && < 5,
++    containers           >= 0.6   && < 0.7,
++    comonad              >= 5     && < 6,
+     distributive         >= 0.3.2 && < 1,
+-    semigroupoids        >= 4     && < 5,
+-    transformers         >= 0.2   && < 0.4
++    semigroupoids        >= 5     && < 6,
++    transformers         >= 0.5   && < 0.6
+
+   exposed-modules:
+     Control.Comonad.Store.Zipper
+diff --git a/src/Control/Comonad/Store/Pointer.hs b/src/Control/Comonad/Store/Pointer.hs
+index 5044a1e..8d4c62d 100644
+--- a/src/Control/Comonad/Store/Pointer.hs
++++ b/src/Control/Comonad/Store/Pointer.hs
+@@ -41,7 +41,6 @@ module Control.Comonad.Store.Pointer
+   , module Control.Comonad.Store.Class
+   ) where
+
+-import Control.Applicative
+ import Control.Comonad
+ import Control.Comonad.Hoist.Class
+ import Control.Comonad.Trans.Class
+@@ -51,27 +50,8 @@ import Control.Comonad.Env.Class
+ import Data.Functor.Identity
+ import Data.Functor.Extend
+ import Data.Array
+-
+ #ifdef __GLASGOW_HASKELL__
+ import Data.Typeable
+-instance (Typeable i, Typeable1 w) => Typeable1 (PointerT i w) where
+-  typeOf1 diwa = mkTyConApp storeTTyCon [typeOf (i diwa), typeOf1 (w diwa)]
+-    where
+-      i :: PointerT i w a -> i
+-      i = undefined
+-      w :: PointerT i w a -> w a
+-      w = undefined
+-
+-instance (Typeable i, Typeable1 w, Typeable a) => Typeable (PointerT i w a) where
+-  typeOf = typeOfDefault
+-
+-storeTTyCon :: TyCon
+-#if __GLASGOW_HASKELL__ < 704
+-storeTTyCon = mkTyCon "Control.Comonad.Trans.Store.Pointer.PointerT"
+-#else
+-storeTTyCon = mkTyCon3 "comonad-extras" "Control.Comonad.Trans.Store.Pointer" "PointerT"
+-#endif
+-{-# NOINLINE storeTTyCon #-}
+ #endif
+
+ type Pointer i = PointerT i Identity
+@@ -83,6 +63,9 @@ runPointer :: Pointer i a -> (Array i a, i)
+ runPointer (PointerT (Identity f) i) = (f, i)
+
+ data PointerT i w a = PointerT (w (Array i a)) i
++#ifdef __GLASGOW_HASKELL__
++  deriving Typeable
++#endif
+
+ runPointerT :: PointerT i w a -> (w (Array i a), i)
+ runPointerT (PointerT g i) = (g, i)
+diff --git a/src/Control/Comonad/Store/Zipper.hs b/src/Control/Comonad/Store/Zipper.hs
+index 3b70c86..decc378 100644
+--- a/src/Control/Comonad/Store/Zipper.hs
++++ b/src/Control/Comonad/Store/Zipper.hs
+@@ -15,7 +15,6 @@
+ module Control.Comonad.Store.Zipper
+   ( Zipper, zipper, zipper1, unzipper, size) where
+
+-import Control.Applicative
+ import Control.Comonad (Comonad(..))
+ import Data.Functor.Extend
+ import Data.Foldable
diff --git a/users/aspen/xanthous/default.nix b/users/aspen/xanthous/default.nix
new file mode 100644
index 000000000000..049c92fb4c9c
--- /dev/null
+++ b/users/aspen/xanthous/default.nix
@@ -0,0 +1,27 @@
+{ depot ? (import ../../../. { })
+, pkgs ? depot.third_party.nixpkgs
+, ...
+}:
+
+let
+  ignore = depot.third_party.gitignoreSource.gitignoreFilter ./.;
+  src = builtins.path {
+    name = "xanthous-source";
+    path = ./.;
+    filter = path: type:
+      !(type == "directory" && builtins.baseNameOf path == "server")
+      && !(type == "directory" && builtins.baseNameOf path == "docs")
+      && (ignore path type
+      || builtins.baseNameOf path == "package.yaml");
+  };
+  # generated by cabal2nix
+  basePkg = pkgs.haskell.packages.ghc8107.callPackage ./pkg.nix { };
+in
+
+pkgs.haskell.lib.overrideCabal basePkg (default: {
+  inherit src;
+  version = "canon";
+  configureFlags = [
+    "--ghc-option=-Wall --ghc-option=-Werror"
+  ] ++ (default.configureFlags or [ ]);
+})
diff --git a/users/aspen/xanthous/docs/raw-types.org b/users/aspen/xanthous/docs/raw-types.org
new file mode 100644
index 000000000000..e5bcda04268f
--- /dev/null
+++ b/users/aspen/xanthous/docs/raw-types.org
@@ -0,0 +1,24 @@
+#+TITLE: Raw Types (WIP)
+
+
+* Raw Types
+** Item
+*** Attributes
+| name            | type                      | commentary                                                       |
+|-----------------+---------------------------+------------------------------------------------------------------|
+| name            | string                    |                                                                  |
+| description     | string                    | Not capitalized, should usually start with an indefinite article |
+| longDescription | string                    | Capitalized, should usually start with an indefinite article     |
+| char            | [[*EntityChar][EntityChar]]                |                                                                  |
+| wieldable       | [[*EntityWieldable][EntityWieldable]]           |                                                                  |
+| density         | number , [number, number] | Density, or range for random density, in g/m³                    |
+| volume          | number , [number, number] | Volume, or range for random volume, in m³                        |
+* Data Types
+** EntityChar
+*** Attributes
+| name  | type | commentary                                            |
+|-------+------+-------------------------------------------------------|
+| char  | char | How the entity is displayed when dropped on the floor |
+| style | Attr |                                                       |
+** TODO EntityWieldable
+** TODO Attr
diff --git a/users/aspen/xanthous/hie.yaml b/users/aspen/xanthous/hie.yaml
new file mode 100644
index 000000000000..e7cf01d158e5
--- /dev/null
+++ b/users/aspen/xanthous/hie.yaml
@@ -0,0 +1,10 @@
+cradle:
+  cabal:
+    - path: './src'
+      component: 'lib:xanthous'
+    - path: './test'
+      component: 'test:test'
+    - path: './app'
+      component: 'exe:xanthous'
+    - path: './bench'
+      component: 'bench:benchmark'
diff --git a/users/aspen/xanthous/nixpkgs.nix b/users/aspen/xanthous/nixpkgs.nix
new file mode 100644
index 000000000000..7d7c16440545
--- /dev/null
+++ b/users/aspen/xanthous/nixpkgs.nix
@@ -0,0 +1,3 @@
+args:
+let pkgs = (import ../../../. args).third_party;
+in pkgs // { inherit pkgs; }
diff --git a/users/aspen/xanthous/package.yaml b/users/aspen/xanthous/package.yaml
new file mode 100644
index 000000000000..15a36fe964be
--- /dev/null
+++ b/users/aspen/xanthous/package.yaml
@@ -0,0 +1,157 @@
+name:                xanthous
+version:             0.1.0.0
+github:              "glittershark/xanthous"
+license:             GPL-3
+author:              "Griffin Smith"
+maintainer:          "root@gws.fyi"
+copyright:           "2019 Griffin Smith"
+
+extra-source-files:
+- README.org
+
+synopsis:            A WIP TUI RPG
+category:            Game
+
+description:         Please see the README on GitHub at <https://github.com/glittershark/xanthous>
+
+dependencies:
+- base
+
+- aeson
+- array
+- async
+- QuickCheck
+- quickcheck-text
+- quickcheck-instances
+- brick
+- bifunctors
+- checkers
+- classy-prelude
+- comonad
+- comonad-extras
+- constraints
+- containers
+- criterion
+- data-default
+- data-interval
+- deepseq
+- directory
+- fgl
+- fgl-arbitrary
+- file-embed
+- filepath
+- generic-arbitrary
+- generic-lens
+- groups
+- hgeometry
+- hgeometry-combinatorial
+- JuicyPixels
+- lens
+- lifted-async
+- linear
+- megaparsec
+- mmorph
+- monad-control
+- MonadRandom
+- mtl
+- optparse-applicative
+- parallel
+- parser-combinators
+- pointed
+- random
+- random-fu
+- random-extras
+- random-source
+- raw-strings-qq
+- reflection
+- Rasterific
+- splitmix
+- streams
+- stache
+- semigroups
+- semigroupoids
+- tomland
+- transformers
+- text
+- text-zipper
+- vector
+- vty
+- witherable
+- yaml
+- zlib
+
+default-extensions:
+- BlockArguments
+- ConstraintKinds
+- DataKinds
+- DeriveAnyClass
+- DeriveGeneric
+- DerivingStrategies
+- DerivingVia
+- FlexibleContexts
+- FlexibleInstances
+- FunctionalDependencies
+- GADTSyntax
+- GeneralizedNewtypeDeriving
+- KindSignatures
+- StandaloneKindSignatures
+- LambdaCase
+- MultiWayIf
+- NoImplicitPrelude
+- NoStarIsType
+- OverloadedStrings
+- PolyKinds
+- RankNTypes
+- ScopedTypeVariables
+- TupleSections
+- TypeApplications
+- TypeFamilies
+- TypeOperators
+- ViewPatterns
+
+ghc-options:
+- -Wall
+- -fconstraint-solver-iterations=6 # Xanthous.Data, Xanthous.Command
+
+library:
+  source-dirs: src
+
+executable:
+  source-dirs: app
+  main: Main.hs
+  dependencies:
+  - xanthous
+  ghc-options:
+  - -threaded
+  - -rtsopts
+  - -with-rtsopts=-N
+  - -O2
+
+tests:
+  test:
+    main:                Spec.hs
+    source-dirs:         test
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    - -O0
+    dependencies:
+    - xanthous
+    - tasty
+    - tasty-hunit
+    - tasty-quickcheck
+    - tasty-rerun
+    - lens-properties
+
+benchmarks:
+  benchmark:
+    main: Bench.hs
+    source-dirs: bench
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - xanthous
+    - criterion
diff --git a/users/aspen/xanthous/pkg.nix b/users/aspen/xanthous/pkg.nix
new file mode 100644
index 000000000000..f8364c467abe
--- /dev/null
+++ b/users/aspen/xanthous/pkg.nix
@@ -0,0 +1,349 @@
+{ mkDerivation
+, aeson
+, array
+, async
+, base
+, bifunctors
+, brick
+, checkers
+, classy-prelude
+, comonad
+, comonad-extras
+, constraints
+, containers
+, criterion
+, data-default
+, data-interval
+, deepseq
+, directory
+, fgl
+, fgl-arbitrary
+, file-embed
+, filepath
+, generic-arbitrary
+, generic-lens
+, groups
+, hgeometry
+, hgeometry-combinatorial
+, hpack
+, JuicyPixels
+, lens
+, lens-properties
+, lib
+, lifted-async
+, linear
+, megaparsec
+, mmorph
+, monad-control
+, MonadRandom
+, mtl
+, optparse-applicative
+, parallel
+, parser-combinators
+, pointed
+, QuickCheck
+, quickcheck-instances
+, quickcheck-text
+, random
+, random-extras
+, random-fu
+, random-source
+, Rasterific
+, raw-strings-qq
+, reflection
+, semigroupoids
+, semigroups
+, splitmix
+, stache
+, streams
+, tasty
+, tasty-hunit
+, tasty-quickcheck
+, tasty-rerun
+, text
+, text-zipper
+, tomland
+, transformers
+, vector
+, vty
+, witherable
+, yaml
+, zlib
+}:
+mkDerivation {
+  pname = "xanthous";
+  version = "0.1.0.0";
+  src = ./.;
+  isLibrary = true;
+  isExecutable = true;
+  libraryHaskellDepends = [
+    aeson
+    array
+    async
+    base
+    bifunctors
+    brick
+    checkers
+    classy-prelude
+    comonad
+    comonad-extras
+    constraints
+    containers
+    criterion
+    data-default
+    data-interval
+    deepseq
+    directory
+    fgl
+    fgl-arbitrary
+    file-embed
+    filepath
+    generic-arbitrary
+    generic-lens
+    groups
+    hgeometry
+    hgeometry-combinatorial
+    JuicyPixels
+    lens
+    lifted-async
+    linear
+    megaparsec
+    mmorph
+    monad-control
+    MonadRandom
+    mtl
+    optparse-applicative
+    parallel
+    parser-combinators
+    pointed
+    QuickCheck
+    quickcheck-instances
+    quickcheck-text
+    random
+    random-extras
+    random-fu
+    random-source
+    Rasterific
+    raw-strings-qq
+    reflection
+    semigroupoids
+    semigroups
+    splitmix
+    stache
+    streams
+    text
+    text-zipper
+    tomland
+    transformers
+    vector
+    vty
+    witherable
+    yaml
+    zlib
+  ];
+  libraryToolDepends = [ hpack ];
+  executableHaskellDepends = [
+    aeson
+    array
+    async
+    base
+    bifunctors
+    brick
+    checkers
+    classy-prelude
+    comonad
+    comonad-extras
+    constraints
+    containers
+    criterion
+    data-default
+    data-interval
+    deepseq
+    directory
+    fgl
+    fgl-arbitrary
+    file-embed
+    filepath
+    generic-arbitrary
+    generic-lens
+    groups
+    hgeometry
+    hgeometry-combinatorial
+    JuicyPixels
+    lens
+    lifted-async
+    linear
+    megaparsec
+    mmorph
+    monad-control
+    MonadRandom
+    mtl
+    optparse-applicative
+    parallel
+    parser-combinators
+    pointed
+    QuickCheck
+    quickcheck-instances
+    quickcheck-text
+    random
+    random-extras
+    random-fu
+    random-source
+    Rasterific
+    raw-strings-qq
+    reflection
+    semigroupoids
+    semigroups
+    splitmix
+    stache
+    streams
+    text
+    text-zipper
+    tomland
+    transformers
+    vector
+    vty
+    witherable
+    yaml
+    zlib
+  ];
+  testHaskellDepends = [
+    aeson
+    array
+    async
+    base
+    bifunctors
+    brick
+    checkers
+    classy-prelude
+    comonad
+    comonad-extras
+    constraints
+    containers
+    criterion
+    data-default
+    data-interval
+    deepseq
+    directory
+    fgl
+    fgl-arbitrary
+    file-embed
+    filepath
+    generic-arbitrary
+    generic-lens
+    groups
+    hgeometry
+    hgeometry-combinatorial
+    JuicyPixels
+    lens
+    lens-properties
+    lifted-async
+    linear
+    megaparsec
+    mmorph
+    monad-control
+    MonadRandom
+    mtl
+    optparse-applicative
+    parallel
+    parser-combinators
+    pointed
+    QuickCheck
+    quickcheck-instances
+    quickcheck-text
+    random
+    random-extras
+    random-fu
+    random-source
+    Rasterific
+    raw-strings-qq
+    reflection
+    semigroupoids
+    semigroups
+    splitmix
+    stache
+    streams
+    tasty
+    tasty-hunit
+    tasty-quickcheck
+    tasty-rerun
+    text
+    text-zipper
+    tomland
+    transformers
+    vector
+    vty
+    witherable
+    yaml
+    zlib
+  ];
+  benchmarkHaskellDepends = [
+    aeson
+    array
+    async
+    base
+    bifunctors
+    brick
+    checkers
+    classy-prelude
+    comonad
+    comonad-extras
+    constraints
+    containers
+    criterion
+    data-default
+    data-interval
+    deepseq
+    directory
+    fgl
+    fgl-arbitrary
+    file-embed
+    filepath
+    generic-arbitrary
+    generic-lens
+    groups
+    hgeometry
+    hgeometry-combinatorial
+    JuicyPixels
+    lens
+    lifted-async
+    linear
+    megaparsec
+    mmorph
+    monad-control
+    MonadRandom
+    mtl
+    optparse-applicative
+    parallel
+    parser-combinators
+    pointed
+    QuickCheck
+    quickcheck-instances
+    quickcheck-text
+    random
+    random-extras
+    random-fu
+    random-source
+    Rasterific
+    raw-strings-qq
+    reflection
+    semigroupoids
+    semigroups
+    splitmix
+    stache
+    streams
+    text
+    text-zipper
+    tomland
+    transformers
+    vector
+    vty
+    witherable
+    yaml
+    zlib
+  ];
+  prePatch = "hpack";
+  homepage = "https://github.com/glittershark/xanthous#readme";
+  description = "A WIP TUI RPG";
+  license = lib.licenses.gpl3Only;
+}
diff --git a/users/aspen/xanthous/server/.envrc b/users/aspen/xanthous/server/.envrc
new file mode 100644
index 000000000000..051d09d292a8
--- /dev/null
+++ b/users/aspen/xanthous/server/.envrc
@@ -0,0 +1 @@
+eval "$(lorri direnv)"
diff --git a/users/aspen/xanthous/server/.gitignore b/users/aspen/xanthous/server/.gitignore
new file mode 100644
index 000000000000..2f7896d1d136
--- /dev/null
+++ b/users/aspen/xanthous/server/.gitignore
@@ -0,0 +1 @@
+target/
diff --git a/users/aspen/xanthous/server/Cargo.lock b/users/aspen/xanthous/server/Cargo.lock
new file mode 100644
index 000000000000..173298b158c1
--- /dev/null
+++ b/users/aspen/xanthous/server/Cargo.lock
@@ -0,0 +1,1874 @@
+# This file is automatically @generated by Cargo.
+# It is not intended for manual editing.
+version = 3
+
+[[package]]
+name = "addr2line"
+version = "0.17.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "b9ecd88a8c8378ca913a680cd98f0f13ac67383d35993f86c90a70e3f137816b"
+dependencies = [
+ "gimli",
+]
+
+[[package]]
+name = "adler"
+version = "1.0.2"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "f26201604c87b1e01bd3d98f8d5d9a8fcbb815e8cedb41ffccbeb4bf593a35fe"
+
+[[package]]
+name = "aes"
+version = "0.7.5"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "9e8b47f52ea9bae42228d07ec09eb676433d7c4ed1ebdf0f1d1c29ed446f1ab8"
+dependencies = [
+ "cfg-if",
+ "cipher",
+ "cpufeatures",
+ "ctr",
+ "opaque-debug",
+]
+
+[[package]]
+name = "ahash"
+version = "0.7.6"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "fcb51a0695d8f838b1ee009b3fbf66bda078cd64590202a864a8f3e8c4315c47"
+dependencies = [
+ "getrandom",
+ "once_cell",
+ "version_check",
+]
+
+[[package]]
+name = "aho-corasick"
+version = "0.7.19"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "b4f55bd91a0978cbfd91c457a164bab8b4001c833b7f323132c0a4e1922dd44e"
+dependencies = [
+ "memchr",
+]
+
+[[package]]
+name = "android_system_properties"
+version = "0.1.5"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "819e7219dbd41043ac279b19830f2efc897156490d7fd6ea916720117ee66311"
+dependencies = [
+ "libc",
+]
+
+[[package]]
+name = "ansi_term"
+version = "0.12.1"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "d52a9bb7ec0cf484c551830a7ce27bd20d67eac647e1befb56b0be4ee39a55d2"
+dependencies = [
+ "winapi",
+]
+
+[[package]]
+name = "atomic-shim"
+version = "0.2.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "67cd4b51d303cf3501c301e8125df442128d3c6d7c69f71b27833d253de47e77"
+dependencies = [
+ "crossbeam-utils",
+]
+
+[[package]]
+name = "atty"
+version = "0.2.14"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "d9b39be18770d11421cdb1b9947a45dd3f37e93092cbf377614828a319d5fee8"
+dependencies = [
+ "hermit-abi",
+ "libc",
+ "winapi",
+]
+
+[[package]]
+name = "autocfg"
+version = "1.1.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "d468802bab17cbc0cc575e9b053f41e72aa36bfa6b7f55e3529ffa43161b97fa"
+
+[[package]]
+name = "backtrace"
+version = "0.3.66"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "cab84319d616cfb654d03394f38ab7e6f0919e181b1b57e1fd15e7fb4077d9a7"
+dependencies = [
+ "addr2line",
+ "cc",
+ "cfg-if",
+ "libc",
+ "miniz_oxide",
+ "object",
+ "rustc-demangle",
+]
+
+[[package]]
+name = "base64ct"
+version = "1.1.1"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "e6b4d9b1225d28d360ec6a231d65af1fd99a2a095154c8040689617290569c5c"
+
+[[package]]
+name = "bcrypt-pbkdf"
+version = "0.6.2"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "7c38c03b9506bd92bf1ef50665a81eda156f615438f7654bffba58907e6149d7"
+dependencies = [
+ "blowfish",
+ "crypto-mac",
+ "pbkdf2",
+ "sha2",
+ "zeroize",
+]
+
+[[package]]
+name = "bit-vec"
+version = "0.6.3"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "349f9b6a179ed607305526ca489b34ad0a41aed5f7980fa90eb03160b69598fb"
+
+[[package]]
+name = "bitflags"
+version = "1.3.2"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "bef38d45163c2f1dde094a7dfd33ccf595c92905c8f8f4fdc18d06fb1037718a"
+
+[[package]]
+name = "block-buffer"
+version = "0.9.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "4152116fd6e9dadb291ae18fc1ec3575ed6d84c29642d97890f4b4a3417297e4"
+dependencies = [
+ "generic-array",
+]
+
+[[package]]
+name = "block-modes"
+version = "0.8.1"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "2cb03d1bed155d89dce0f845b7899b18a9a163e148fd004e1c28421a783e2d8e"
+dependencies = [
+ "block-padding",
+ "cipher",
+]
+
+[[package]]
+name = "block-padding"
+version = "0.2.1"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "8d696c370c750c948ada61c69a0ee2cbbb9c50b1019ddb86d9317157a99c2cae"
+
+[[package]]
+name = "blowfish"
+version = "0.8.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "fe3ff3fc1de48c1ac2e3341c4df38b0d1bfb8fdf04632a187c8b75aaa319a7ab"
+dependencies = [
+ "byteorder",
+ "cipher",
+ "opaque-debug",
+]
+
+[[package]]
+name = "bumpalo"
+version = "3.11.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "c1ad822118d20d2c234f427000d5acc36eabe1e29a348c89b63dd60b13f28e5d"
+
+[[package]]
+name = "byteorder"
+version = "1.4.3"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "14c189c53d098945499cdfa7ecc63567cf3886b3332b312a5b4585d8d3a6a610"
+
+[[package]]
+name = "bytes"
+version = "1.2.1"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "ec8a7b6a70fde80372154c65702f00a0f56f3e1c36abbc6c440484be248856db"
+
+[[package]]
+name = "cc"
+version = "1.0.73"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "2fff2a6927b3bb87f9595d67196a70493f627687a71d87a0d692242c33f58c11"
+
+[[package]]
+name = "cfg-if"
+version = "1.0.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "baf1de4339761588bc0619e3cbc0120ee582ebb74b53b4efbf79117bd2da40fd"
+
+[[package]]
+name = "chrono"
+version = "0.4.22"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "bfd4d1b31faaa3a89d7934dbded3111da0d2ef28e3ebccdb4f0179f5929d1ef1"
+dependencies = [
+ "iana-time-zone",
+ "num-integer",
+ "num-traits",
+ "winapi",
+]
+
+[[package]]
+name = "cipher"
+version = "0.3.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "7ee52072ec15386f770805afd189a01c8841be8696bed250fa2f13c4c0d6dfb7"
+dependencies = [
+ "generic-array",
+]
+
+[[package]]
+name = "clap"
+version = "3.2.22"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "86447ad904c7fb335a790c9d7fe3d0d971dc523b8ccd1561a520de9a85302750"
+dependencies = [
+ "atty",
+ "bitflags",
+ "clap_derive",
+ "clap_lex",
+ "indexmap",
+ "once_cell",
+ "strsim",
+ "termcolor",
+ "textwrap",
+]
+
+[[package]]
+name = "clap_derive"
+version = "3.2.18"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "ea0c8bce528c4be4da13ea6fead8965e95b6073585a2f05204bd8f4119f82a65"
+dependencies = [
+ "heck",
+ "proc-macro-error",
+ "proc-macro2",
+ "quote",
+ "syn",
+]
+
+[[package]]
+name = "clap_lex"
+version = "0.2.4"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "2850f2f5a82cbf437dd5af4d49848fbdfc27c157c3d010345776f952765261c5"
+dependencies = [
+ "os_str_bytes",
+]
+
+[[package]]
+name = "color-eyre"
+version = "0.5.11"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "1f1885697ee8a177096d42f158922251a41973117f6d8a234cee94b9509157b7"
+dependencies = [
+ "backtrace",
+ "color-spantrace",
+ "eyre",
+ "indenter",
+ "once_cell",
+ "owo-colors",
+ "tracing-error",
+]
+
+[[package]]
+name = "color-spantrace"
+version = "0.1.6"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "b6eee477a4a8a72f4addd4de416eb56d54bc307b284d6601bafdee1f4ea462d1"
+dependencies = [
+ "once_cell",
+ "owo-colors",
+ "tracing-core",
+ "tracing-error",
+]
+
+[[package]]
+name = "core-foundation-sys"
+version = "0.8.3"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "5827cebf4670468b8772dd191856768aedcb1b0278a04f989f7766351917b9dc"
+
+[[package]]
+name = "cpufeatures"
+version = "0.2.5"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "28d997bd5e24a5928dd43e46dc529867e207907fe0b239c3477d924f7f2ca320"
+dependencies = [
+ "libc",
+]
+
+[[package]]
+name = "crc32fast"
+version = "1.3.2"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "b540bd8bc810d3885c6ea91e2018302f68baba2129ab3e88f32389ee9370880d"
+dependencies = [
+ "cfg-if",
+]
+
+[[package]]
+name = "crossbeam-epoch"
+version = "0.9.11"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "f916dfc5d356b0ed9dae65f1db9fc9770aa2851d2662b988ccf4fe3516e86348"
+dependencies = [
+ "autocfg",
+ "cfg-if",
+ "crossbeam-utils",
+ "memoffset",
+ "scopeguard",
+]
+
+[[package]]
+name = "crossbeam-utils"
+version = "0.8.12"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "edbafec5fa1f196ca66527c1b12c2ec4745ca14b50f1ad8f9f6f720b55d11fac"
+dependencies = [
+ "cfg-if",
+]
+
+[[package]]
+name = "crypto-mac"
+version = "0.11.1"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "b1d1a86f49236c215f271d40892d5fc950490551400b02ef360692c29815c714"
+dependencies = [
+ "generic-array",
+ "subtle",
+]
+
+[[package]]
+name = "cryptovec"
+version = "0.6.1"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "ccc7fa13a6bbb2322d325292c57f4c8e7291595506f8289968a0eb61c3130bdf"
+dependencies = [
+ "libc",
+ "winapi",
+]
+
+[[package]]
+name = "ctr"
+version = "0.8.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "049bb91fb4aaf0e3c7efa6cd5ef877dbbbd15b39dad06d9948de4ec8a75761ea"
+dependencies = [
+ "cipher",
+]
+
+[[package]]
+name = "dashmap"
+version = "4.0.2"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "e77a43b28d0668df09411cb0bc9a8c2adc40f9a048afe863e05fd43251e8e39c"
+dependencies = [
+ "cfg-if",
+ "num_cpus",
+]
+
+[[package]]
+name = "data-encoding"
+version = "2.3.2"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "3ee2393c4a91429dffb4bedf19f4d6abf27d8a732c8ce4980305d782e5426d57"
+
+[[package]]
+name = "digest"
+version = "0.9.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "d3dd60d1080a57a05ab032377049e0591415d2b31afd7028356dbf3cc6dcb066"
+dependencies = [
+ "generic-array",
+]
+
+[[package]]
+name = "dirs"
+version = "3.0.2"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "30baa043103c9d0c2a57cf537cc2f35623889dc0d405e6c3cccfadbc81c71309"
+dependencies = [
+ "dirs-sys",
+]
+
+[[package]]
+name = "dirs-sys"
+version = "0.3.7"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "1b1d1d91c932ef41c0f2663aa8b0ca0342d444d842c06914aa0a7e352d0bada6"
+dependencies = [
+ "libc",
+ "redox_users",
+ "winapi",
+]
+
+[[package]]
+name = "endian-type"
+version = "0.1.2"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "c34f04666d835ff5d62e058c3995147c06f42fe86ff053337632bca83e42702d"
+
+[[package]]
+name = "eyre"
+version = "0.6.8"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "4c2b6b5a29c02cdc822728b7d7b8ae1bab3e3b05d44522770ddd49722eeac7eb"
+dependencies = [
+ "indenter",
+ "once_cell",
+]
+
+[[package]]
+name = "fastrand"
+version = "1.8.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "a7a407cfaa3385c4ae6b23e84623d48c2798d06e3e6a1878f7f59f17b3f86499"
+dependencies = [
+ "instant",
+]
+
+[[package]]
+name = "flate2"
+version = "1.0.24"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "f82b0f4c27ad9f8bfd1f3208d882da2b09c301bc1c828fd3a00d0216d2fbbff6"
+dependencies = [
+ "crc32fast",
+ "miniz_oxide",
+]
+
+[[package]]
+name = "fnv"
+version = "1.0.7"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "3f9eec918d3f24069decb9af1554cad7c880e2da24a9afd88aca000531ab82c1"
+
+[[package]]
+name = "futures"
+version = "0.3.24"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "7f21eda599937fba36daeb58a22e8f5cee2d14c4a17b5b7739c7c8e5e3b8230c"
+dependencies = [
+ "futures-channel",
+ "futures-core",
+ "futures-executor",
+ "futures-io",
+ "futures-sink",
+ "futures-task",
+ "futures-util",
+]
+
+[[package]]
+name = "futures-channel"
+version = "0.3.24"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "30bdd20c28fadd505d0fd6712cdfcb0d4b5648baf45faef7f852afb2399bb050"
+dependencies = [
+ "futures-core",
+ "futures-sink",
+]
+
+[[package]]
+name = "futures-core"
+version = "0.3.24"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "4e5aa3de05362c3fb88de6531e6296e85cde7739cccad4b9dfeeb7f6ebce56bf"
+
+[[package]]
+name = "futures-executor"
+version = "0.3.24"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "9ff63c23854bee61b6e9cd331d523909f238fc7636290b96826e9cfa5faa00ab"
+dependencies = [
+ "futures-core",
+ "futures-task",
+ "futures-util",
+]
+
+[[package]]
+name = "futures-io"
+version = "0.3.24"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "bbf4d2a7a308fd4578637c0b17c7e1c7ba127b8f6ba00b29f717e9655d85eb68"
+
+[[package]]
+name = "futures-macro"
+version = "0.3.24"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "42cd15d1c7456c04dbdf7e88bcd69760d74f3a798d6444e16974b505b0e62f17"
+dependencies = [
+ "proc-macro2",
+ "quote",
+ "syn",
+]
+
+[[package]]
+name = "futures-sink"
+version = "0.3.24"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "21b20ba5a92e727ba30e72834706623d94ac93a725410b6a6b6fbc1b07f7ba56"
+
+[[package]]
+name = "futures-task"
+version = "0.3.24"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "a6508c467c73851293f390476d4491cf4d227dbabcd4170f3bb6044959b294f1"
+
+[[package]]
+name = "futures-util"
+version = "0.3.24"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "44fb6cb1be61cc1d2e43b262516aafcf63b241cffdb1d3fa115f91d9c7b09c90"
+dependencies = [
+ "futures-channel",
+ "futures-core",
+ "futures-io",
+ "futures-macro",
+ "futures-sink",
+ "futures-task",
+ "memchr",
+ "pin-project-lite",
+ "pin-utils",
+ "slab",
+]
+
+[[package]]
+name = "generic-array"
+version = "0.14.6"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "bff49e947297f3312447abdca79f45f4738097cc82b06e72054d2223f601f1b9"
+dependencies = [
+ "typenum",
+ "version_check",
+]
+
+[[package]]
+name = "getrandom"
+version = "0.2.7"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "4eb1a864a501629691edf6c15a593b7a51eebaa1e8468e9ddc623de7c9b58ec6"
+dependencies = [
+ "cfg-if",
+ "libc",
+ "wasi 0.11.0+wasi-snapshot-preview1",
+]
+
+[[package]]
+name = "gimli"
+version = "0.26.2"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "22030e2c5a68ec659fde1e949a745124b48e6fa8b045b7ed5bd1fe4ccc5c4e5d"
+
+[[package]]
+name = "hashbrown"
+version = "0.11.2"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "ab5ef0d4909ef3724cc8cce6ccc8572c5c817592e9285f5464f8e86f8bd3726e"
+dependencies = [
+ "ahash",
+]
+
+[[package]]
+name = "hashbrown"
+version = "0.12.3"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "8a9ee70c43aaf417c914396645a0fa852624801b24ebb7ae78fe8272889ac888"
+
+[[package]]
+name = "heck"
+version = "0.4.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "2540771e65fc8cb83cd6e8a237f70c319bd5c29f78ed1084ba5d50eeac86f7f9"
+
+[[package]]
+name = "hermit-abi"
+version = "0.1.19"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "62b467343b94ba476dcb2500d242dadbb39557df889310ac77c5d99100aaac33"
+dependencies = [
+ "libc",
+]
+
+[[package]]
+name = "hmac"
+version = "0.11.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "2a2a2320eb7ec0ebe8da8f744d7812d9fc4cb4d09344ac01898dbcb6a20ae69b"
+dependencies = [
+ "crypto-mac",
+ "digest",
+]
+
+[[package]]
+name = "http"
+version = "0.2.8"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "75f43d41e26995c17e71ee126451dd3941010b0514a81a9d11f3b341debc2399"
+dependencies = [
+ "bytes",
+ "fnv",
+ "itoa",
+]
+
+[[package]]
+name = "http-body"
+version = "0.4.5"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "d5f38f16d184e36f2408a55281cd658ecbd3ca05cce6d6510a176eca393e26d1"
+dependencies = [
+ "bytes",
+ "http",
+ "pin-project-lite",
+]
+
+[[package]]
+name = "httparse"
+version = "1.8.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "d897f394bad6a705d5f4104762e116a75639e470d80901eed05a860a95cb1904"
+
+[[package]]
+name = "httpdate"
+version = "1.0.2"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "c4a1e36c821dbe04574f602848a19f742f4fb3c98d40449f11bcad18d6b17421"
+
+[[package]]
+name = "hyper"
+version = "0.14.20"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "02c929dc5c39e335a03c405292728118860721b10190d98c2a0f0efd5baafbac"
+dependencies = [
+ "bytes",
+ "futures-channel",
+ "futures-core",
+ "futures-util",
+ "http",
+ "http-body",
+ "httparse",
+ "httpdate",
+ "itoa",
+ "pin-project-lite",
+ "socket2",
+ "tokio",
+ "tower-service",
+ "tracing",
+ "want",
+]
+
+[[package]]
+name = "iana-time-zone"
+version = "0.1.50"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "fd911b35d940d2bd0bea0f9100068e5b97b51a1cbe13d13382f132e0365257a0"
+dependencies = [
+ "android_system_properties",
+ "core-foundation-sys",
+ "js-sys",
+ "wasm-bindgen",
+ "winapi",
+]
+
+[[package]]
+name = "indenter"
+version = "0.3.3"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "ce23b50ad8242c51a442f3ff322d56b02f08852c77e4c0b4d3fd684abc89c683"
+
+[[package]]
+name = "indexmap"
+version = "1.9.1"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "10a35a97730320ffe8e2d410b5d3b69279b98d2c14bdb8b70ea89ecf7888d41e"
+dependencies = [
+ "autocfg",
+ "hashbrown 0.12.3",
+]
+
+[[package]]
+name = "instant"
+version = "0.1.12"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "7a5bbe824c507c5da5956355e86a746d82e0e1464f65d862cc5e71da70e94b2c"
+dependencies = [
+ "cfg-if",
+]
+
+[[package]]
+name = "ipnet"
+version = "2.5.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "879d54834c8c76457ef4293a689b2a8c59b076067ad77b15efafbb05f92a592b"
+
+[[package]]
+name = "itoa"
+version = "1.0.3"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "6c8af84674fe1f223a982c933a0ee1086ac4d4052aa0fb8060c12c6ad838e754"
+
+[[package]]
+name = "js-sys"
+version = "0.3.60"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "49409df3e3bf0856b916e2ceaca09ee28e6871cf7d9ce97a692cacfdb2a25a47"
+dependencies = [
+ "wasm-bindgen",
+]
+
+[[package]]
+name = "lazy_static"
+version = "1.4.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "e2abad23fbc42b3700f2f279844dc832adb2b2eb069b2df918f455c4e18cc646"
+
+[[package]]
+name = "libc"
+version = "0.2.134"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "329c933548736bc49fd575ee68c89e8be4d260064184389a5b77517cddd99ffb"
+
+[[package]]
+name = "libsodium-sys"
+version = "0.2.7"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "6b779387cd56adfbc02ea4a668e704f729be8d6a6abd2c27ca5ee537849a92fd"
+dependencies = [
+ "cc",
+ "libc",
+ "pkg-config",
+ "walkdir",
+]
+
+[[package]]
+name = "lock_api"
+version = "0.4.9"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "435011366fe56583b16cf956f9df0095b405b82d76425bc8981c0e22e60ec4df"
+dependencies = [
+ "autocfg",
+ "scopeguard",
+]
+
+[[package]]
+name = "log"
+version = "0.4.17"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "abb12e687cfb44aa40f41fc3978ef76448f9b6038cad6aef4259d3c095a2382e"
+dependencies = [
+ "cfg-if",
+]
+
+[[package]]
+name = "mach"
+version = "0.3.2"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "b823e83b2affd8f40a9ee8c29dbc56404c1e34cd2710921f2801e2cf29527afa"
+dependencies = [
+ "libc",
+]
+
+[[package]]
+name = "matchers"
+version = "0.0.1"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "f099785f7595cc4b4553a174ce30dd7589ef93391ff414dbb67f62392b9e0ce1"
+dependencies = [
+ "regex-automata",
+]
+
+[[package]]
+name = "md5"
+version = "0.7.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "490cc448043f947bae3cbee9c203358d62dbee0db12107a74be5c30ccfd09771"
+
+[[package]]
+name = "memchr"
+version = "2.5.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "2dffe52ecf27772e601905b7522cb4ef790d2cc203488bbd0e2fe85fcb74566d"
+
+[[package]]
+name = "memoffset"
+version = "0.6.5"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "5aa361d4faea93603064a027415f07bd8e1d5c88c9fbf68bf56a285428fd79ce"
+dependencies = [
+ "autocfg",
+]
+
+[[package]]
+name = "metrics"
+version = "0.17.1"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "55586aa936c35f34ba8aa5d97356d554311206e1ce1f9e68fe7b07288e5ad827"
+dependencies = [
+ "ahash",
+ "metrics-macros",
+]
+
+[[package]]
+name = "metrics-exporter-prometheus"
+version = "0.6.1"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "343a5ceb38235928e7a5687412590f07e6d281522dcd9ff51246f8856eef5fe5"
+dependencies = [
+ "hyper",
+ "ipnet",
+ "metrics",
+ "metrics-util",
+ "parking_lot",
+ "quanta",
+ "thiserror",
+ "tokio",
+]
+
+[[package]]
+name = "metrics-macros"
+version = "0.4.1"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "0daa0ab3a0ae956d0e2c1f42511422850e577d36a255357d1a7d08d45ee3a2f1"
+dependencies = [
+ "lazy_static",
+ "proc-macro2",
+ "quote",
+ "regex",
+ "syn",
+]
+
+[[package]]
+name = "metrics-util"
+version = "0.10.2"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "1174223789e331d9d47a4a953dac36e397db60fa8d2a111ac505388c6c7fe32e"
+dependencies = [
+ "ahash",
+ "aho-corasick",
+ "atomic-shim",
+ "crossbeam-epoch",
+ "crossbeam-utils",
+ "dashmap",
+ "hashbrown 0.11.2",
+ "indexmap",
+ "metrics",
+ "num_cpus",
+ "ordered-float",
+ "parking_lot",
+ "quanta",
+ "radix_trie",
+ "sketches-ddsketch",
+]
+
+[[package]]
+name = "miniz_oxide"
+version = "0.5.4"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "96590ba8f175222643a85693f33d26e9c8a015f599c216509b1a6894af675d34"
+dependencies = [
+ "adler",
+]
+
+[[package]]
+name = "mio"
+version = "0.8.4"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "57ee1c23c7c63b0c9250c339ffdc69255f110b298b901b9f6c82547b7b87caaf"
+dependencies = [
+ "libc",
+ "log",
+ "wasi 0.11.0+wasi-snapshot-preview1",
+ "windows-sys",
+]
+
+[[package]]
+name = "nibble_vec"
+version = "0.1.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "77a5d83df9f36fe23f0c3648c6bbb8b0298bb5f1939c8f2704431371f4b84d43"
+dependencies = [
+ "smallvec",
+]
+
+[[package]]
+name = "nix"
+version = "0.23.1"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "9f866317acbd3a240710c63f065ffb1e4fd466259045ccb504130b7f668f35c6"
+dependencies = [
+ "bitflags",
+ "cc",
+ "cfg-if",
+ "libc",
+ "memoffset",
+]
+
+[[package]]
+name = "num-bigint"
+version = "0.4.3"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "f93ab6289c7b344a8a9f60f88d80aa20032336fe78da341afc91c8a2341fc75f"
+dependencies = [
+ "autocfg",
+ "num-integer",
+ "num-traits",
+]
+
+[[package]]
+name = "num-integer"
+version = "0.1.45"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "225d3389fb3509a24c93f5c29eb6bde2586b98d9f016636dff58d7c6f7569cd9"
+dependencies = [
+ "autocfg",
+ "num-traits",
+]
+
+[[package]]
+name = "num-traits"
+version = "0.2.15"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "578ede34cf02f8924ab9447f50c28075b4d3e5b269972345e7e0372b38c6cdcd"
+dependencies = [
+ "autocfg",
+]
+
+[[package]]
+name = "num_cpus"
+version = "1.13.1"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "19e64526ebdee182341572e50e9ad03965aa510cd94427a4549448f285e957a1"
+dependencies = [
+ "hermit-abi",
+ "libc",
+]
+
+[[package]]
+name = "object"
+version = "0.29.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "21158b2c33aa6d4561f1c0a6ea283ca92bc54802a93b263e910746d679a7eb53"
+dependencies = [
+ "memchr",
+]
+
+[[package]]
+name = "once_cell"
+version = "1.15.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "e82dad04139b71a90c080c8463fe0dc7902db5192d939bd0950f074d014339e1"
+
+[[package]]
+name = "opaque-debug"
+version = "0.3.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "624a8340c38c1b80fd549087862da4ba43e08858af025b236e509b6649fc13d5"
+
+[[package]]
+name = "ordered-float"
+version = "2.10.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "7940cf2ca942593318d07fcf2596cdca60a85c9e7fab408a5e21a4f9dcd40d87"
+dependencies = [
+ "num-traits",
+]
+
+[[package]]
+name = "os_str_bytes"
+version = "6.3.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "9ff7415e9ae3fff1225851df9e0d9e4e5479f947619774677a63572e55e80eff"
+
+[[package]]
+name = "owo-colors"
+version = "1.3.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "2386b4ebe91c2f7f51082d4cefa145d030e33a1842a96b12e4885cc3c01f7a55"
+
+[[package]]
+name = "parking_lot"
+version = "0.11.2"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "7d17b78036a60663b797adeaee46f5c9dfebb86948d1255007a1d6be0271ff99"
+dependencies = [
+ "instant",
+ "lock_api",
+ "parking_lot_core",
+]
+
+[[package]]
+name = "parking_lot_core"
+version = "0.8.5"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "d76e8e1493bcac0d2766c42737f34458f1c8c50c0d23bcb24ea953affb273216"
+dependencies = [
+ "cfg-if",
+ "instant",
+ "libc",
+ "redox_syscall",
+ "smallvec",
+ "winapi",
+]
+
+[[package]]
+name = "password-hash"
+version = "0.2.3"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "77e0b28ace46c5a396546bcf443bf422b57049617433d8854227352a4a9b24e7"
+dependencies = [
+ "base64ct",
+ "rand_core",
+ "subtle",
+]
+
+[[package]]
+name = "pbkdf2"
+version = "0.8.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "d95f5254224e617595d2cc3cc73ff0a5eaf2637519e25f03388154e9378b6ffa"
+dependencies = [
+ "base64ct",
+ "crypto-mac",
+ "hmac",
+ "password-hash",
+ "sha2",
+]
+
+[[package]]
+name = "pin-project-lite"
+version = "0.2.9"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "e0a7ae3ac2f1173085d398531c705756c94a4c56843785df85a60c1a0afac116"
+
+[[package]]
+name = "pin-utils"
+version = "0.1.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "8b870d8c151b6f2fb93e84a13146138f05d02ed11c7e7c54f8826aaaf7c9f184"
+
+[[package]]
+name = "pkg-config"
+version = "0.3.25"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "1df8c4ec4b0627e53bdf214615ad287367e482558cf84b109250b37464dc03ae"
+
+[[package]]
+name = "ppv-lite86"
+version = "0.2.16"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "eb9f9e6e233e5c4a35559a617bf40a4ec447db2e84c20b55a6f83167b7e57872"
+
+[[package]]
+name = "proc-macro-error"
+version = "1.0.4"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "da25490ff9892aab3fcf7c36f08cfb902dd3e71ca0f9f9517bea02a73a5ce38c"
+dependencies = [
+ "proc-macro-error-attr",
+ "proc-macro2",
+ "quote",
+ "syn",
+ "version_check",
+]
+
+[[package]]
+name = "proc-macro-error-attr"
+version = "1.0.4"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "a1be40180e52ecc98ad80b184934baf3d0d29f979574e439af5a55274b35f869"
+dependencies = [
+ "proc-macro2",
+ "quote",
+ "version_check",
+]
+
+[[package]]
+name = "proc-macro2"
+version = "1.0.46"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "94e2ef8dbfc347b10c094890f778ee2e36ca9bb4262e86dc99cd217e35f3470b"
+dependencies = [
+ "unicode-ident",
+]
+
+[[package]]
+name = "quanta"
+version = "0.9.3"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "20afe714292d5e879d8b12740aa223c6a88f118af41870e8b6196e39a02238a8"
+dependencies = [
+ "crossbeam-utils",
+ "libc",
+ "mach",
+ "once_cell",
+ "raw-cpuid",
+ "wasi 0.10.2+wasi-snapshot-preview1",
+ "web-sys",
+ "winapi",
+]
+
+[[package]]
+name = "quote"
+version = "1.0.21"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "bbe448f377a7d6961e30f5955f9b8d106c3f5e449d493ee1b125c1d43c2b5179"
+dependencies = [
+ "proc-macro2",
+]
+
+[[package]]
+name = "radix_trie"
+version = "0.2.1"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "c069c179fcdc6a2fe24d8d18305cf085fdbd4f922c041943e203685d6a1c58fd"
+dependencies = [
+ "endian-type",
+ "nibble_vec",
+]
+
+[[package]]
+name = "rand"
+version = "0.8.5"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "34af8d1a0e25924bc5b7c43c079c942339d8f0a8b57c39049bef581b46327404"
+dependencies = [
+ "libc",
+ "rand_chacha",
+ "rand_core",
+]
+
+[[package]]
+name = "rand_chacha"
+version = "0.3.1"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "e6c10a63a0fa32252be49d21e7709d4d4baf8d231c2dbce1eaa8141b9b127d88"
+dependencies = [
+ "ppv-lite86",
+ "rand_core",
+]
+
+[[package]]
+name = "rand_core"
+version = "0.6.4"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "ec0be4795e2f6a28069bec0b5ff3e2ac9bafc99e6a9a7dc3547996c5c816922c"
+dependencies = [
+ "getrandom",
+]
+
+[[package]]
+name = "raw-cpuid"
+version = "10.6.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "a6823ea29436221176fe662da99998ad3b4db2c7f31e7b6f5fe43adccd6320bb"
+dependencies = [
+ "bitflags",
+]
+
+[[package]]
+name = "redox_syscall"
+version = "0.2.16"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "fb5a58c1855b4b6819d59012155603f0b22ad30cad752600aadfcb695265519a"
+dependencies = [
+ "bitflags",
+]
+
+[[package]]
+name = "redox_users"
+version = "0.4.3"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "b033d837a7cf162d7993aded9304e30a83213c648b6e389db233191f891e5c2b"
+dependencies = [
+ "getrandom",
+ "redox_syscall",
+ "thiserror",
+]
+
+[[package]]
+name = "regex"
+version = "1.6.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "4c4eb3267174b8c6c2f654116623910a0fef09c4753f8dd83db29c48a0df988b"
+dependencies = [
+ "aho-corasick",
+ "memchr",
+ "regex-syntax",
+]
+
+[[package]]
+name = "regex-automata"
+version = "0.1.10"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "6c230d73fb8d8c1b9c0b3135c5142a8acee3a0558fb8db5cf1cb65f8d7862132"
+dependencies = [
+ "regex-syntax",
+]
+
+[[package]]
+name = "regex-syntax"
+version = "0.6.27"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "a3f87b73ce11b1619a3c6332f45341e0047173771e8b8b73f87bfeefb7b56244"
+
+[[package]]
+name = "remove_dir_all"
+version = "0.5.3"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "3acd125665422973a33ac9d3dd2df85edad0f4ae9b00dafb1a05e43a9f5ef8e7"
+dependencies = [
+ "winapi",
+]
+
+[[package]]
+name = "rustc-demangle"
+version = "0.1.21"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "7ef03e0a2b150c7a90d01faf6254c9c48a41e95fb2a8c2ac1c6f0d2b9aefc342"
+
+[[package]]
+name = "ryu"
+version = "1.0.11"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "4501abdff3ae82a1c1b477a17252eb69cee9e66eb915c1abaa4f44d873df9f09"
+
+[[package]]
+name = "same-file"
+version = "1.0.6"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "93fc1dc3aaa9bfed95e02e6eadabb4baf7e3078b0bd1b4d7b6b0b68378900502"
+dependencies = [
+ "winapi-util",
+]
+
+[[package]]
+name = "scopeguard"
+version = "1.1.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "d29ab0c6d3fc0ee92fe66e2d99f700eab17a8d57d1c1d3b748380fb20baa78cd"
+
+[[package]]
+name = "serde"
+version = "1.0.145"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "728eb6351430bccb993660dfffc5a72f91ccc1295abaa8ce19b27ebe4f75568b"
+
+[[package]]
+name = "serde_derive"
+version = "1.0.145"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "81fa1584d3d1bcacd84c277a0dfe21f5b0f6accf4a23d04d4c6d61f1af522b4c"
+dependencies = [
+ "proc-macro2",
+ "quote",
+ "syn",
+]
+
+[[package]]
+name = "serde_json"
+version = "1.0.85"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "e55a28e3aaef9d5ce0506d0a14dbba8054ddc7e499ef522dd8b26859ec9d4a44"
+dependencies = [
+ "itoa",
+ "ryu",
+ "serde",
+]
+
+[[package]]
+name = "sha2"
+version = "0.9.9"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "4d58a1e1bf39749807d89cf2d98ac2dfa0ff1cb3faa38fbb64dd88ac8013d800"
+dependencies = [
+ "block-buffer",
+ "cfg-if",
+ "cpufeatures",
+ "digest",
+ "opaque-debug",
+]
+
+[[package]]
+name = "sharded-slab"
+version = "0.1.4"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "900fba806f70c630b0a382d0d825e17a0f19fcd059a2ade1ff237bcddf446b31"
+dependencies = [
+ "lazy_static",
+]
+
+[[package]]
+name = "signal-hook-registry"
+version = "1.4.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "e51e73328dc4ac0c7ccbda3a494dfa03df1de2f46018127f60c693f2648455b0"
+dependencies = [
+ "libc",
+]
+
+[[package]]
+name = "sketches-ddsketch"
+version = "0.1.3"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "04d2ecae5fcf33b122e2e6bd520a57ccf152d2dde3b38c71039df1a6867264ee"
+
+[[package]]
+name = "slab"
+version = "0.4.7"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "4614a76b2a8be0058caa9dbbaf66d988527d86d003c11a94fbd335d7661edcef"
+dependencies = [
+ "autocfg",
+]
+
+[[package]]
+name = "smallvec"
+version = "1.9.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "2fd0db749597d91ff862fd1d55ea87f7855a744a8425a64695b6fca237d1dad1"
+
+[[package]]
+name = "socket2"
+version = "0.4.7"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "02e2d2db9033d13a1567121ddd7a095ee144db4e1ca1b1bda3419bc0da294ebd"
+dependencies = [
+ "libc",
+ "winapi",
+]
+
+[[package]]
+name = "strsim"
+version = "0.10.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "73473c0e59e6d5812c5dfe2a064a6444949f089e20eec9a2e5506596494e4623"
+
+[[package]]
+name = "subtle"
+version = "2.4.1"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "6bdef32e8150c2a081110b42772ffe7d7c9032b606bc226c8260fd97e0976601"
+
+[[package]]
+name = "syn"
+version = "1.0.101"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "e90cde112c4b9690b8cbe810cba9ddd8bc1d7472e2cae317b69e9438c1cba7d2"
+dependencies = [
+ "proc-macro2",
+ "quote",
+ "unicode-ident",
+]
+
+[[package]]
+name = "tempfile"
+version = "3.3.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "5cdb1ef4eaeeaddc8fbd371e5017057064af0911902ef36b39801f67cc6d79e4"
+dependencies = [
+ "cfg-if",
+ "fastrand",
+ "libc",
+ "redox_syscall",
+ "remove_dir_all",
+ "winapi",
+]
+
+[[package]]
+name = "termcolor"
+version = "1.1.3"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "bab24d30b911b2376f3a13cc2cd443142f0c81dda04c118693e35b3835757755"
+dependencies = [
+ "winapi-util",
+]
+
+[[package]]
+name = "textwrap"
+version = "0.15.1"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "949517c0cf1bf4ee812e2e07e08ab448e3ae0d23472aee8a06c985f0c8815b16"
+
+[[package]]
+name = "thiserror"
+version = "1.0.37"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "10deb33631e3c9018b9baf9dcbbc4f737320d2b576bac10f6aefa048fa407e3e"
+dependencies = [
+ "thiserror-impl",
+]
+
+[[package]]
+name = "thiserror-impl"
+version = "1.0.37"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "982d17546b47146b28f7c22e3d08465f6b8903d0ea13c1660d9d84a6e7adcdbb"
+dependencies = [
+ "proc-macro2",
+ "quote",
+ "syn",
+]
+
+[[package]]
+name = "thread_local"
+version = "1.1.4"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "5516c27b78311c50bf42c071425c560ac799b11c30b31f87e3081965fe5e0180"
+dependencies = [
+ "once_cell",
+]
+
+[[package]]
+name = "thrussh"
+version = "0.33.5"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "8e6540238a9adf83df6e66541c182a52acf892ab335595ca965c229ade8536f8"
+dependencies = [
+ "bitflags",
+ "byteorder",
+ "cryptovec",
+ "digest",
+ "flate2",
+ "futures",
+ "generic-array",
+ "log",
+ "rand",
+ "sha2",
+ "thiserror",
+ "thrussh-keys",
+ "thrussh-libsodium",
+ "tokio",
+]
+
+[[package]]
+name = "thrussh-keys"
+version = "0.21.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "a72cc51a2932b18d92f7289332d8564cec4a5014063722a9d3fdca52c5d8f5ab"
+dependencies = [
+ "aes",
+ "bcrypt-pbkdf",
+ "bit-vec",
+ "block-modes",
+ "byteorder",
+ "cryptovec",
+ "data-encoding",
+ "dirs",
+ "futures",
+ "hmac",
+ "log",
+ "md5",
+ "num-bigint",
+ "num-integer",
+ "pbkdf2",
+ "rand",
+ "serde",
+ "serde_derive",
+ "sha2",
+ "thiserror",
+ "thrussh-libsodium",
+ "tokio",
+ "tokio-stream",
+ "yasna",
+]
+
+[[package]]
+name = "thrussh-libsodium"
+version = "0.2.1"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "cfe89c70d27b1cb92e13bc8af63493e890d0de46dae4df0e28233f62b4ed9500"
+dependencies = [
+ "lazy_static",
+ "libc",
+ "libsodium-sys",
+ "pkg-config",
+ "vcpkg",
+]
+
+[[package]]
+name = "tokio"
+version = "1.21.2"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "a9e03c497dc955702ba729190dc4aac6f2a0ce97f913e5b1b5912fc5039d9099"
+dependencies = [
+ "autocfg",
+ "bytes",
+ "libc",
+ "memchr",
+ "mio",
+ "num_cpus",
+ "pin-project-lite",
+ "signal-hook-registry",
+ "socket2",
+ "tokio-macros",
+ "winapi",
+]
+
+[[package]]
+name = "tokio-macros"
+version = "1.8.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "9724f9a975fb987ef7a3cd9be0350edcbe130698af5b8f7a631e23d42d052484"
+dependencies = [
+ "proc-macro2",
+ "quote",
+ "syn",
+]
+
+[[package]]
+name = "tokio-stream"
+version = "0.1.10"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "f6edf2d6bc038a43d31353570e27270603f4648d18f5ed10c0e179abe43255af"
+dependencies = [
+ "futures-core",
+ "pin-project-lite",
+ "tokio",
+]
+
+[[package]]
+name = "tower-service"
+version = "0.3.2"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "b6bc1c9ce2b5135ac7f93c72918fc37feb872bdc6a5533a8b85eb4b86bfdae52"
+
+[[package]]
+name = "tracing"
+version = "0.1.36"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "2fce9567bd60a67d08a16488756721ba392f24f29006402881e43b19aac64307"
+dependencies = [
+ "cfg-if",
+ "pin-project-lite",
+ "tracing-attributes",
+ "tracing-core",
+]
+
+[[package]]
+name = "tracing-attributes"
+version = "0.1.22"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "11c75893af559bc8e10716548bdef5cb2b983f8e637db9d0e15126b61b484ee2"
+dependencies = [
+ "proc-macro2",
+ "quote",
+ "syn",
+]
+
+[[package]]
+name = "tracing-core"
+version = "0.1.29"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "5aeea4303076558a00714b823f9ad67d58a3bbda1df83d8827d21193156e22f7"
+dependencies = [
+ "once_cell",
+ "valuable",
+]
+
+[[package]]
+name = "tracing-error"
+version = "0.1.2"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "b4d7c0b83d4a500748fa5879461652b361edf5c9d51ede2a2ac03875ca185e24"
+dependencies = [
+ "tracing",
+ "tracing-subscriber",
+]
+
+[[package]]
+name = "tracing-log"
+version = "0.1.3"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "78ddad33d2d10b1ed7eb9d1f518a5674713876e97e5bb9b7345a7984fbb4f922"
+dependencies = [
+ "lazy_static",
+ "log",
+ "tracing-core",
+]
+
+[[package]]
+name = "tracing-serde"
+version = "0.1.3"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "bc6b213177105856957181934e4920de57730fc69bf42c37ee5bb664d406d9e1"
+dependencies = [
+ "serde",
+ "tracing-core",
+]
+
+[[package]]
+name = "tracing-subscriber"
+version = "0.2.25"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "0e0d2eaa99c3c2e41547cfa109e910a68ea03823cccad4a0525dcbc9b01e8c71"
+dependencies = [
+ "ansi_term",
+ "chrono",
+ "lazy_static",
+ "matchers",
+ "regex",
+ "serde",
+ "serde_json",
+ "sharded-slab",
+ "smallvec",
+ "thread_local",
+ "tracing",
+ "tracing-core",
+ "tracing-log",
+ "tracing-serde",
+]
+
+[[package]]
+name = "try-lock"
+version = "0.2.3"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "59547bce71d9c38b83d9c0e92b6066c4253371f15005def0c30d9657f50c7642"
+
+[[package]]
+name = "typenum"
+version = "1.15.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "dcf81ac59edc17cc8697ff311e8f5ef2d99fcbd9817b34cec66f90b6c3dfd987"
+
+[[package]]
+name = "unicode-ident"
+version = "1.0.4"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "dcc811dc4066ac62f84f11307873c4850cb653bfa9b1719cee2bd2204a4bc5dd"
+
+[[package]]
+name = "valuable"
+version = "0.1.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "830b7e5d4d90034032940e4ace0d9a9a057e7a45cd94e6c007832e39edb82f6d"
+
+[[package]]
+name = "vcpkg"
+version = "0.2.15"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "accd4ea62f7bb7a82fe23066fb0957d48ef677f6eeb8215f372f52e48bb32426"
+
+[[package]]
+name = "version_check"
+version = "0.9.4"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "49874b5167b65d7193b8aba1567f5c7d93d001cafc34600cee003eda787e483f"
+
+[[package]]
+name = "walkdir"
+version = "2.3.2"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "808cf2735cd4b6866113f648b791c6adc5714537bc222d9347bb203386ffda56"
+dependencies = [
+ "same-file",
+ "winapi",
+ "winapi-util",
+]
+
+[[package]]
+name = "want"
+version = "0.3.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "1ce8a968cb1cd110d136ff8b819a556d6fb6d919363c61534f6860c7eb172ba0"
+dependencies = [
+ "log",
+ "try-lock",
+]
+
+[[package]]
+name = "wasi"
+version = "0.10.2+wasi-snapshot-preview1"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "fd6fbd9a79829dd1ad0cc20627bf1ed606756a7f77edff7b66b7064f9cb327c6"
+
+[[package]]
+name = "wasi"
+version = "0.11.0+wasi-snapshot-preview1"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "9c8d87e72b64a3b4db28d11ce29237c246188f4f51057d65a7eab63b7987e423"
+
+[[package]]
+name = "wasm-bindgen"
+version = "0.2.83"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "eaf9f5aceeec8be17c128b2e93e031fb8a4d469bb9c4ae2d7dc1888b26887268"
+dependencies = [
+ "cfg-if",
+ "wasm-bindgen-macro",
+]
+
+[[package]]
+name = "wasm-bindgen-backend"
+version = "0.2.83"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "4c8ffb332579b0557b52d268b91feab8df3615f265d5270fec2a8c95b17c1142"
+dependencies = [
+ "bumpalo",
+ "log",
+ "once_cell",
+ "proc-macro2",
+ "quote",
+ "syn",
+ "wasm-bindgen-shared",
+]
+
+[[package]]
+name = "wasm-bindgen-macro"
+version = "0.2.83"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "052be0f94026e6cbc75cdefc9bae13fd6052cdcaf532fa6c45e7ae33a1e6c810"
+dependencies = [
+ "quote",
+ "wasm-bindgen-macro-support",
+]
+
+[[package]]
+name = "wasm-bindgen-macro-support"
+version = "0.2.83"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "07bc0c051dc5f23e307b13285f9d75df86bfdf816c5721e573dec1f9b8aa193c"
+dependencies = [
+ "proc-macro2",
+ "quote",
+ "syn",
+ "wasm-bindgen-backend",
+ "wasm-bindgen-shared",
+]
+
+[[package]]
+name = "wasm-bindgen-shared"
+version = "0.2.83"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "1c38c045535d93ec4f0b4defec448e4291638ee608530863b1e2ba115d4fff7f"
+
+[[package]]
+name = "web-sys"
+version = "0.3.60"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "bcda906d8be16e728fd5adc5b729afad4e444e106ab28cd1c7256e54fa61510f"
+dependencies = [
+ "js-sys",
+ "wasm-bindgen",
+]
+
+[[package]]
+name = "winapi"
+version = "0.3.9"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "5c839a674fcd7a98952e593242ea400abe93992746761e38641405d28b00f419"
+dependencies = [
+ "winapi-i686-pc-windows-gnu",
+ "winapi-x86_64-pc-windows-gnu",
+]
+
+[[package]]
+name = "winapi-i686-pc-windows-gnu"
+version = "0.4.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "ac3b87c63620426dd9b991e5ce0329eff545bccbbb34f3be09ff6fb6ab51b7b6"
+
+[[package]]
+name = "winapi-util"
+version = "0.1.5"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "70ec6ce85bb158151cae5e5c87f95a8e97d2c0c4b001223f33a334e3ce5de178"
+dependencies = [
+ "winapi",
+]
+
+[[package]]
+name = "winapi-x86_64-pc-windows-gnu"
+version = "0.4.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "712e227841d057c1ee1cd2fb22fa7e5a5461ae8e48fa2ca79ec42cfc1931183f"
+
+[[package]]
+name = "windows-sys"
+version = "0.36.1"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "ea04155a16a59f9eab786fe12a4a450e75cdb175f9e0d80da1e17db09f55b8d2"
+dependencies = [
+ "windows_aarch64_msvc",
+ "windows_i686_gnu",
+ "windows_i686_msvc",
+ "windows_x86_64_gnu",
+ "windows_x86_64_msvc",
+]
+
+[[package]]
+name = "windows_aarch64_msvc"
+version = "0.36.1"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "9bb8c3fd39ade2d67e9874ac4f3db21f0d710bee00fe7cab16949ec184eeaa47"
+
+[[package]]
+name = "windows_i686_gnu"
+version = "0.36.1"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "180e6ccf01daf4c426b846dfc66db1fc518f074baa793aa7d9b9aaeffad6a3b6"
+
+[[package]]
+name = "windows_i686_msvc"
+version = "0.36.1"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "e2e7917148b2812d1eeafaeb22a97e4813dfa60a3f8f78ebe204bcc88f12f024"
+
+[[package]]
+name = "windows_x86_64_gnu"
+version = "0.36.1"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "4dcd171b8776c41b97521e5da127a2d86ad280114807d0b2ab1e462bc764d9e1"
+
+[[package]]
+name = "windows_x86_64_msvc"
+version = "0.36.1"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "c811ca4a8c853ef420abd8592ba53ddbbac90410fab6903b3e79972a631f7680"
+
+[[package]]
+name = "xanthous-server"
+version = "0.1.0"
+dependencies = [
+ "base64ct",
+ "clap",
+ "color-eyre",
+ "eyre",
+ "futures",
+ "libc",
+ "metrics",
+ "metrics-exporter-prometheus",
+ "nix",
+ "pbkdf2",
+ "tempfile",
+ "thrussh",
+ "thrussh-keys",
+ "tokio",
+ "tracing",
+ "tracing-subscriber",
+]
+
+[[package]]
+name = "yasna"
+version = "0.4.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "e262a29d0e61ccf2b6190d7050d4b237535fc76ce4c1210d9caa316f71dffa75"
+dependencies = [
+ "bit-vec",
+ "num-bigint",
+]
+
+[[package]]
+name = "zeroize"
+version = "1.3.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "4756f7db3f7b5574938c3eb1c117038b8e07f95ee6718c0efad4ac21508f1efd"
diff --git a/users/aspen/xanthous/server/Cargo.toml b/users/aspen/xanthous/server/Cargo.toml
new file mode 100644
index 000000000000..d4a064beb697
--- /dev/null
+++ b/users/aspen/xanthous/server/Cargo.toml
@@ -0,0 +1,29 @@
+[package]
+name = "xanthous-server"
+version = "0.1.0"
+edition = "2018"
+
+[dependencies]
+clap = { version = "3.0", features = [ "derive", "env" ] }
+color-eyre = "0.5.11"
+eyre = "0.6.5"
+thrussh = "0.33.5"
+thrussh-keys = "0.21.0"
+tracing = "0.1.29"
+tracing-subscriber = "0.2.25"
+metrics = "0.17.0"
+metrics-exporter-prometheus = "0.6.1"
+futures = "0.3.17"
+libc = "0.2.103"
+nix = "0.23.0"
+
+# Pins for rust 1.55 (2018 edition) until we have 1.56 in nixpkgs-unstable
+pbkdf2 = "<0.9"
+base64ct = "<1.2"
+
+[dependencies.tokio]
+version = "1.13"
+features = ["rt", "rt-multi-thread", "macros", "net", "process", "fs", "signal"]
+
+[dev-dependencies]
+tempfile = "3.2.0"
diff --git a/users/aspen/xanthous/server/default.nix b/users/aspen/xanthous/server/default.nix
new file mode 100644
index 000000000000..572230a56c5e
--- /dev/null
+++ b/users/aspen/xanthous/server/default.nix
@@ -0,0 +1,24 @@
+args@{ depot ? import ../../../.. { }
+, pkgs ? depot.third_party.nixpkgs
+, ...
+}:
+
+depot.third_party.naersk.buildPackage {
+  name = "xanthous-server";
+  version = "0.0.1";
+  src = depot.third_party.gitignoreSource ./.;
+
+  # Workaround for a potential Nix bug related to restricted eval.
+  # See https://github.com/nix-community/naersk/issues/169
+  root = depot.nix.sparseTree {
+    root = ./.;
+    paths = [
+      ./Cargo.toml
+      ./Cargo.lock
+    ];
+  };
+
+  passthru = {
+    docker = import ./docker.nix args;
+  };
+}
diff --git a/users/aspen/xanthous/server/docker.nix b/users/aspen/xanthous/server/docker.nix
new file mode 100644
index 000000000000..5eaef4553be6
--- /dev/null
+++ b/users/aspen/xanthous/server/docker.nix
@@ -0,0 +1,21 @@
+{ depot ? import ../../../.. { }
+, pkgs ? depot.third_party.nixpkgs
+, ...
+}:
+
+let
+  inherit (depot.users.aspen) xanthous;
+  xanthous-server = xanthous.server;
+in
+pkgs.dockerTools.buildLayeredImage {
+  name = "xanthous-server";
+  tag = "latest";
+  contents = [ xanthous xanthous-server ];
+  config = {
+    Cmd = [
+      "${xanthous-server}/bin/xanthous-server"
+      "--xanthous-binary-path"
+      "${xanthous}/bin/xanthous"
+    ];
+  };
+}
diff --git a/users/aspen/xanthous/server/module.nix b/users/aspen/xanthous/server/module.nix
new file mode 100644
index 000000000000..6d1bdc687341
--- /dev/null
+++ b/users/aspen/xanthous/server/module.nix
@@ -0,0 +1,49 @@
+{ config, lib, pkgs, depot, ... }:
+
+let
+  cfg = config.services.xanthous-server;
+in
+{
+  options = with lib; {
+    services.xanthous-server = {
+      enable = mkEnableOption "xanthous server";
+
+      port = mkOption {
+        type = types.int;
+        default = 2222;
+        description = "Port to listen to for SSH connections";
+      };
+
+      metricsPort = mkOption {
+        type = types.int;
+        default = 9000;
+        description = "Port to listen to for prometheus metrics";
+      };
+
+      image = mkOption {
+        type = types.package;
+        default = depot.users.aspen.xanthous.server.docker;
+        description = "OCI image file to run";
+      };
+
+      ed25519SecretKeyFile = mkOption {
+        type = with types; uniq string;
+        description = "Path to the ed25519 secret key for the server";
+      };
+    };
+  };
+
+  config = lib.mkIf cfg.enable {
+    virtualisation.oci-containers.containers."xanthous-server" = {
+      autoStart = true;
+      image = "${cfg.image.imageName}:${cfg.image.imageTag}";
+      imageFile = cfg.image;
+      ports = [
+        "${toString cfg.port}:22"
+        "${toString cfg.metricsPort}:9000"
+      ];
+      environment.SECRET_KEY_FILE = "/secret-key";
+      volumes = [ "/etc/secrets/xanthous-server-secret-key:/secret-key" ];
+    };
+  };
+}
diff --git a/users/aspen/xanthous/server/shell.nix b/users/aspen/xanthous/server/shell.nix
new file mode 100644
index 000000000000..e01c0316a6b2
--- /dev/null
+++ b/users/aspen/xanthous/server/shell.nix
@@ -0,0 +1,11 @@
+let
+  depot = import ../../../.. { };
+  pkgs = depot.third_party.nixpkgs;
+in
+
+pkgs.mkShell {
+  buildInputs = with pkgs; [
+    rustup
+    rust-analyzer
+  ];
+}
diff --git a/users/aspen/xanthous/server/src/main.rs b/users/aspen/xanthous/server/src/main.rs
new file mode 100644
index 000000000000..1b2c1c104b33
--- /dev/null
+++ b/users/aspen/xanthous/server/src/main.rs
@@ -0,0 +1,385 @@
+use std::net::SocketAddr;
+use std::path::PathBuf;
+use std::pin::Pin;
+use std::process::Command;
+use std::str;
+use std::sync::Arc;
+
+use clap::Parser;
+use color_eyre::eyre::Result;
+use eyre::{bail, Context};
+use futures::future::{ready, Ready};
+use futures::Future;
+use metrics_exporter_prometheus::PrometheusBuilder;
+use nix::pty::Winsize;
+use pty::ChildHandle;
+use thrussh::server::{self, Auth, Session};
+use thrussh::{ChannelId, CryptoVec};
+use thrussh_keys::decode_secret_key;
+use thrussh_keys::key::KeyPair;
+use tokio::fs::File;
+use tokio::io::{AsyncReadExt, AsyncWriteExt};
+use tokio::net::TcpListener;
+use tokio::select;
+use tokio::time::Instant;
+use tracing::{debug, error, info, info_span, trace, warn, Instrument};
+use tracing_subscriber::EnvFilter;
+
+use crate::pty::WaitPid;
+
+mod metrics;
+mod pty;
+
+use crate::metrics::reported::*;
+use crate::metrics::{decrement_gauge, histogram, increment_counter, increment_gauge};
+
+/// SSH-compatible server for playing Xanthous
+#[derive(Parser, Debug)]
+struct Opts {
+    /// Address to bind to
+    #[clap(long, short = 'a', default_value = "0.0.0.0:22")]
+    address: String,
+
+    /// Address to listen to for metrics
+    #[clap(long, default_value = "0.0.0.0:9000")]
+    metrics_address: SocketAddr,
+
+    /// Format to use when emitting log events
+    #[clap(
+        long,
+        env = "LOG_FORMAT",
+        default_value = "full",
+        possible_values = &["compact", "full", "pretty", "json"]
+    )]
+    log_format: String,
+
+    /// Full path to the xanthous binary
+    #[clap(long, env = "XANTHOUS_BINARY_PATH")]
+    xanthous_binary_path: String,
+
+    /// Path to a file containing the ed25519 secret key for the server
+    #[clap(long, env = "SECRET_KEY_FILE")]
+    secret_key_file: PathBuf,
+
+    /// Level to log at
+    #[clap(long, env = "LOG_LEVEL", default_value = "info")]
+    log_level: String,
+}
+
+impl Opts {
+    async fn read_secret_key(&self) -> Result<KeyPair> {
+        let mut file = File::open(&self.secret_key_file)
+            .await
+            .context("Reading secret key file")?;
+        let mut secret_key = Vec::with_capacity(464);
+        file.read_to_end(&mut secret_key).await?;
+        Ok(decode_secret_key(str::from_utf8(&secret_key)?, None)?)
+    }
+
+    async fn ssh_server_config(&self) -> Result<server::Config> {
+        let key_pair = self.read_secret_key().await?;
+
+        Ok(server::Config {
+            server_id: "SSH-2.0-xanthous".to_owned(),
+            keys: vec![key_pair],
+            ..Default::default()
+        })
+    }
+
+    fn init_logging(&self) -> Result<()> {
+        let filter = EnvFilter::try_new(&self.log_level)?;
+        let s = tracing_subscriber::fmt().with_env_filter(filter);
+
+        match self.log_format.as_str() {
+            "compact" => s.compact().init(),
+            "full" => s.init(),
+            "pretty" => s.pretty().init(),
+            "json" => s.json().with_current_span(true).init(),
+            f => bail!("Invalid log format `{}`", f),
+        }
+
+        Ok(())
+    }
+}
+
+struct Handler {
+    address: SocketAddr,
+    xanthous_binary_path: &'static str,
+    username: Option<String>,
+    child: Option<ChildHandle>,
+}
+
+async fn run_child(
+    mut child: pty::Child,
+    mut server_handle: server::Handle,
+    channel_id: ChannelId,
+) -> Result<()> {
+    let mut buf = [0; 2048];
+    loop {
+        select! {
+            r = child.tty.read(&mut buf)  => {
+                let read_bytes = r?;
+                if read_bytes == 0 {
+                    info!("EOF received from process");
+                    let _ = server_handle.close(channel_id).await;
+                    return Ok(())
+                } else {
+                    trace!(?read_bytes, "read bytes from child");
+                    let _ = server_handle.data(channel_id, CryptoVec::from_slice(&buf[..read_bytes])).await;
+                }
+            }
+            status = WaitPid::new(child.pid) => {
+                match status {
+                    Ok(_status) => info!("Child exited"),
+                    Err(error) => error!(%error, "Child failed"),
+                }
+                let _ = server_handle.close(channel_id).await;
+                return Ok(())
+            }
+        }
+    }
+}
+
+impl Handler {
+    async fn spawn_shell(
+        &mut self,
+        mut handle: server::Handle,
+        channel_id: ChannelId,
+        term: String,
+        winsize: Winsize,
+    ) -> Result<()> {
+        let mut cmd = Command::new(self.xanthous_binary_path);
+        cmd.env("TERM", term);
+        if let Some(username) = &self.username {
+            cmd.args(["--name", username]);
+        }
+        cmd.arg("--disable-saving");
+
+        let child = pty::spawn(cmd, Some(winsize), None).await?;
+        info!(pid = %child.pid, "Spawned child");
+        increment_gauge!(RUNNING_PROCESSES, 1.0);
+        self.child = Some(child.handle().await?);
+        tokio::spawn(
+            async move {
+                let span = info_span!("child", pid = %child.pid);
+                if let Err(error) = run_child(child, handle.clone(), channel_id)
+                    .instrument(span.clone())
+                    .await
+                {
+                    span.in_scope(|| error!(%error, "Error running child"));
+                    let _ = handle.close(channel_id).await;
+                }
+                decrement_gauge!(RUNNING_PROCESSES, 1.0);
+            }
+            .in_current_span(),
+        );
+        Ok(())
+    }
+}
+
+#[allow(clippy::type_complexity)]
+impl server::Handler for Handler {
+    type Error = eyre::Error;
+    type FutureAuth = Ready<Result<(Self, Auth)>>;
+    type FutureUnit = Pin<Box<dyn Future<Output = Result<(Self, Session)>> + Send + 'static>>;
+    type FutureBool = Ready<Result<(Self, Session, bool)>>;
+
+    fn finished_auth(self, auth: Auth) -> Self::FutureAuth {
+        ready(Ok((self, auth)))
+    }
+
+    fn finished_bool(self, b: bool, session: Session) -> Self::FutureBool {
+        ready(Ok((self, session, b)))
+    }
+
+    fn finished(self, session: Session) -> Self::FutureUnit {
+        Box::pin(ready(Ok((self, session))))
+    }
+
+    fn auth_none(mut self, username: &str) -> Self::FutureAuth {
+        info!(%username, "Accepted new connection");
+        self.username = Some(username.to_owned());
+        self.finished_auth(Auth::Accept)
+    }
+
+    fn auth_password(mut self, username: &str, _password: &str) -> Self::FutureAuth {
+        info!(%username, "Accepted new connection");
+        self.username = Some(username.to_owned());
+        self.finished_auth(Auth::Accept)
+    }
+
+    fn auth_publickey(
+        mut self,
+        username: &str,
+        _: &thrussh_keys::key::PublicKey,
+    ) -> Self::FutureAuth {
+        info!(%username, "Accepted new connection");
+        self.username = Some(username.to_owned());
+        self.finished_auth(Auth::Accept)
+    }
+
+    fn pty_request(
+        mut self,
+        channel: thrussh::ChannelId,
+        term: &str,
+        col_width: u32,
+        row_height: u32,
+        pix_width: u32,
+        pix_height: u32,
+        modes: &[(thrussh::Pty, u32)],
+        session: Session,
+    ) -> Self::FutureUnit {
+        let term = term.to_owned();
+        let modes = modes.to_vec();
+        Box::pin(async move {
+            debug!(
+                %term,
+                %col_width,
+                %row_height,
+                %pix_width,
+                %pix_height,
+                ?modes,
+                "PTY Requested"
+            );
+
+            self.spawn_shell(
+                session.handle(),
+                channel,
+                term,
+                Winsize {
+                    ws_row: row_height as _,
+                    ws_col: col_width as _,
+                    ws_xpixel: pix_width as _,
+                    ws_ypixel: pix_height as _,
+                },
+            )
+            .await?;
+
+            Ok((self, session))
+        })
+    }
+
+    fn window_change_request(
+        mut self,
+        _channel: ChannelId,
+        col_width: u32,
+        row_height: u32,
+        pix_width: u32,
+        pix_height: u32,
+        session: Session,
+    ) -> Self::FutureUnit {
+        Box::pin(async move {
+            if let Some(child) = self.child.as_mut() {
+                trace!(%row_height, %col_width, "Window resize request received");
+                child
+                    .resize_window(Winsize {
+                        ws_row: row_height as _,
+                        ws_col: col_width as _,
+                        ws_xpixel: pix_width as _,
+                        ws_ypixel: pix_height as _,
+                    })
+                    .await?;
+            } else {
+                warn!("Resize request received without child process; ignoring");
+            }
+
+            Ok((self, session))
+        })
+    }
+
+    fn data(
+        mut self,
+        _channel: thrussh::ChannelId,
+        data: &[u8],
+        session: Session,
+    ) -> Self::FutureUnit {
+        trace!(data = %String::from_utf8_lossy(data), raw_data = ?data);
+        let data = data.to_owned();
+        Box::pin(async move {
+            if let Some(child) = self.child.as_mut() {
+                child.write_all(&data).await?;
+            } else {
+                warn!("Data received without child process; ignoring");
+            }
+
+            Ok((self, session))
+        })
+    }
+}
+
+#[tokio::main]
+async fn main() -> Result<()> {
+    color_eyre::install()?;
+    let opts = Box::leak::<'static>(Box::new(Opts::parse()));
+    opts.init_logging()?;
+    PrometheusBuilder::new()
+        .listen_address(opts.metrics_address)
+        .install()?;
+    metrics::register();
+
+    let config = Arc::new(opts.ssh_server_config().await?);
+    info!(address = %opts.address, "Listening for new SSH connections");
+    let listener = TcpListener::bind(&opts.address).await?;
+
+    loop {
+        let (stream, address) = listener.accept().await?;
+        increment_counter!(CONNECTIONS_ACCEPTED);
+        increment_gauge!(ACTIVE_CONNECTIONS, 1.0);
+        let config = config.clone();
+        let handler = Handler {
+            xanthous_binary_path: &opts.xanthous_binary_path,
+            address,
+            username: None,
+            child: None,
+        };
+        tokio::spawn(async move {
+            let span = info_span!("client", address = %handler.address);
+            let start = Instant::now();
+            if let Err(error) = server::run_stream(config, stream, handler)
+                .instrument(span.clone())
+                .await
+            {
+                span.in_scope(|| error!(%error));
+            }
+            let duration = start.elapsed();
+            span.in_scope(|| info!(duration_ms = %duration.as_millis(), "Client disconnected"));
+            histogram!(CONNECTION_DURATION, duration);
+            decrement_gauge!(ACTIVE_CONNECTIONS, 1.0);
+        });
+    }
+}
+
+#[cfg(test)]
+mod tests {
+    use tempfile::NamedTempFile;
+
+    use super::*;
+
+    #[tokio::test]
+    async fn read_secret_key() {
+        use std::io::Write;
+
+        let mut file = NamedTempFile::new().unwrap();
+        file.write_all(
+            b"
+-----BEGIN OPENSSH PRIVATE KEY-----
+b3BlbnNzaC1rZXktdjEAAAAABG5vbmUAAAAEbm9uZQAAAAAAAAABAAAAMwAAAAtzc2gtZW
+QyNTUxOQAAACAYz80xcK7jYxZMAl6apIHKRtB0Z2U78gG39c1QaIhgMwAAAJB9vxK9fb8S
+vQAAAAtzc2gtZWQyNTUxOQAAACAYz80xcK7jYxZMAl6apIHKRtB0Z2U78gG39c1QaIhgMw
+AAAEDNZ0d3lLNBGU6Im4JOpr490TOjm+cB7kMVXjVg3iCowBjPzTFwruNjFkwCXpqkgcpG
+0HRnZTvyAbf1zVBoiGAzAAAACHRlc3Qta2V5AQIDBAU=
+-----END OPENSSH PRIVATE KEY-----
+",
+        )
+        .unwrap();
+
+        let opts: Opts = Opts::parse_from(&[
+            "xanthous-server".as_ref(),
+            "--xanthous-binary-path".as_ref(),
+            "/bin/xanthous".as_ref(),
+            "--secret-key-file".as_ref(),
+            file.path().as_os_str(),
+        ]);
+        opts.read_secret_key().await.unwrap();
+    }
+}
diff --git a/users/aspen/xanthous/server/src/metrics.rs b/users/aspen/xanthous/server/src/metrics.rs
new file mode 100644
index 000000000000..6912cdd9c9ee
--- /dev/null
+++ b/users/aspen/xanthous/server/src/metrics.rs
@@ -0,0 +1,24 @@
+pub use ::metrics::*;
+
+pub mod reported {
+    /// Counter: Connections accepted on the TCP listener
+    pub const CONNECTIONS_ACCEPTED: &str = "ssh.connections.accepted";
+
+    /// Histogram: Connection duration
+    pub const CONNECTION_DURATION: &str = "ssh.connections.duration";
+
+    /// Gauge: Currently active connections
+    pub const ACTIVE_CONNECTIONS: &str = "ssh.connections.active";
+
+    /// Gauge: Currently running xanthous processes
+    pub const RUNNING_PROCESSES: &str = "ssh.child.processes";
+}
+
+pub fn register() {
+    use reported::*;
+
+    register_counter!(CONNECTIONS_ACCEPTED);
+    register_histogram!(CONNECTION_DURATION);
+    register_gauge!(ACTIVE_CONNECTIONS);
+    register_gauge!(RUNNING_PROCESSES);
+}
diff --git a/users/aspen/xanthous/server/src/pty.rs b/users/aspen/xanthous/server/src/pty.rs
new file mode 100644
index 000000000000..234ecd8f2336
--- /dev/null
+++ b/users/aspen/xanthous/server/src/pty.rs
@@ -0,0 +1,172 @@
+use std::io::{self};
+use std::os::unix::prelude::{AsRawFd, CommandExt, FromRawFd};
+use std::pin::Pin;
+use std::process::{abort, Command};
+use std::task::{Context, Poll};
+
+use eyre::{bail, Result};
+use futures::Future;
+use nix::pty::{forkpty, Winsize};
+use nix::sys::termios::Termios;
+use nix::sys::wait::{waitpid, WaitPidFlag, WaitStatus};
+use nix::unistd::{ForkResult, Pid};
+use tokio::fs::File;
+use tokio::io::{AsyncRead, AsyncWrite};
+use tokio::signal::unix::{signal, Signal, SignalKind};
+use tokio::task::spawn_blocking;
+
+mod ioctl {
+    use super::Winsize;
+    use libc::TIOCSWINSZ;
+    use nix::ioctl_write_ptr_bad;
+
+    ioctl_write_ptr_bad!(tiocswinsz, TIOCSWINSZ, Winsize);
+}
+
+async fn asyncify<F, T>(f: F) -> Result<T>
+where
+    F: FnOnce() -> Result<T> + Send + 'static,
+    T: Send + 'static,
+{
+    match spawn_blocking(f).await {
+        Ok(res) => res,
+        Err(_) => bail!("background task failed",),
+    }
+}
+
+pub struct Child {
+    pub tty: File,
+    pub pid: Pid,
+}
+
+pub struct ChildHandle {
+    pub tty: File,
+}
+
+pub struct WaitPid {
+    pid: Pid,
+    signal: Signal,
+}
+
+impl WaitPid {
+    pub fn new(pid: Pid) -> Self {
+        Self {
+            pid,
+            signal: signal(SignalKind::child()).unwrap(),
+        }
+    }
+}
+
+impl Future for WaitPid {
+    type Output = nix::Result<WaitStatus>;
+
+    fn poll(mut self: Pin<&mut Self>, cx: &mut Context<'_>) -> Poll<Self::Output> {
+        let _ = self.signal.poll_recv(cx);
+        match waitpid(self.pid, Some(WaitPidFlag::WNOHANG)) {
+            Ok(WaitStatus::StillAlive) => Poll::Pending,
+            result => Poll::Ready(result),
+        }
+    }
+}
+
+impl Child {
+    pub async fn handle(&self) -> io::Result<ChildHandle> {
+        Ok(ChildHandle {
+            tty: self.tty.try_clone().await?,
+        })
+    }
+}
+
+impl ChildHandle {
+    pub async fn resize_window(&mut self, winsize: Winsize) -> Result<()> {
+        let fd = self.tty.as_raw_fd();
+        asyncify(move || unsafe {
+            ioctl::tiocswinsz(fd, &winsize as *const Winsize)?;
+            Ok(())
+        })
+        .await
+    }
+}
+
+pub async fn spawn(
+    mut cmd: Command,
+    winsize: Option<Winsize>,
+    termios: Option<Termios>,
+) -> Result<Child> {
+    asyncify(move || unsafe {
+        let res = forkpty(winsize.as_ref(), termios.as_ref())?;
+        match res.fork_result {
+            ForkResult::Parent { child } => Ok(Child {
+                pid: child,
+                tty: File::from_raw_fd(res.master),
+            }),
+            ForkResult::Child => {
+                cmd.exec();
+                abort();
+            }
+        }
+    })
+    .await
+}
+
+impl AsyncRead for Child {
+    fn poll_read(
+        mut self: Pin<&mut Self>,
+        cx: &mut Context<'_>,
+        buf: &mut tokio::io::ReadBuf<'_>,
+    ) -> Poll<io::Result<()>> {
+        Pin::new(&mut self.tty).poll_read(cx, buf)
+    }
+}
+
+impl AsyncWrite for Child {
+    fn poll_write(
+        mut self: Pin<&mut Self>,
+        cx: &mut Context<'_>,
+        buf: &[u8],
+    ) -> Poll<Result<usize, io::Error>> {
+        Pin::new(&mut self.tty).poll_write(cx, buf)
+    }
+
+    fn poll_flush(mut self: Pin<&mut Self>, cx: &mut Context<'_>) -> Poll<Result<(), io::Error>> {
+        Pin::new(&mut self.tty).poll_flush(cx)
+    }
+
+    fn poll_shutdown(
+        mut self: Pin<&mut Self>,
+        cx: &mut Context<'_>,
+    ) -> Poll<Result<(), io::Error>> {
+        Pin::new(&mut self.tty).poll_shutdown(cx)
+    }
+}
+
+impl AsyncRead for ChildHandle {
+    fn poll_read(
+        mut self: Pin<&mut Self>,
+        cx: &mut Context<'_>,
+        buf: &mut tokio::io::ReadBuf<'_>,
+    ) -> Poll<io::Result<()>> {
+        Pin::new(&mut self.tty).poll_read(cx, buf)
+    }
+}
+
+impl AsyncWrite for ChildHandle {
+    fn poll_write(
+        mut self: Pin<&mut Self>,
+        cx: &mut Context<'_>,
+        buf: &[u8],
+    ) -> Poll<Result<usize, io::Error>> {
+        Pin::new(&mut self.tty).poll_write(cx, buf)
+    }
+
+    fn poll_flush(mut self: Pin<&mut Self>, cx: &mut Context<'_>) -> Poll<Result<(), io::Error>> {
+        Pin::new(&mut self.tty).poll_flush(cx)
+    }
+
+    fn poll_shutdown(
+        mut self: Pin<&mut Self>,
+        cx: &mut Context<'_>,
+    ) -> Poll<Result<(), io::Error>> {
+        Pin::new(&mut self.tty).poll_shutdown(cx)
+    }
+}
diff --git a/users/aspen/xanthous/shell.nix b/users/aspen/xanthous/shell.nix
new file mode 100644
index 000000000000..2c41cb4aa864
--- /dev/null
+++ b/users/aspen/xanthous/shell.nix
@@ -0,0 +1,23 @@
+let
+  depot = import ../../../. { };
+  inherit (depot) third_party;
+  pkgs = third_party.nixpkgs;
+in
+
+(pkgs.haskell.packages.ghc8107.extend (pkgs.haskell.lib.packageSourceOverrides {
+  xanthous = third_party.gitignoreSource ./.;
+})).shellFor {
+  packages = p: [ p.xanthous ];
+  withHoogle = true;
+  doBenchmark = true;
+  buildInputs = (with pkgs.haskell.packages.ghc8107; [
+    cabal-install
+    ghc-prof-flamegraph
+    hp2pretty
+    hlint
+    haskell-language-server
+    cabal2nix
+  ]) ++ (with pkgs; [
+    qpdf
+  ]);
+}
diff --git a/users/aspen/xanthous/src/Data/Aeson/Generic/DerivingVia.hs b/users/aspen/xanthous/src/Data/Aeson/Generic/DerivingVia.hs
new file mode 100644
index 000000000000..e89fcd621157
--- /dev/null
+++ b/users/aspen/xanthous/src/Data/Aeson/Generic/DerivingVia.hs
@@ -0,0 +1,168 @@
+{-# LANGUAGE ConstraintKinds, DataKinds, DeriveGeneric, DerivingVia    #-}
+{-# LANGUAGE ExplicitNamespaces, FlexibleContexts, FlexibleInstances   #-}
+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, MultiParamTypeClasses  #-}
+{-# LANGUAGE PolyKinds, ScopedTypeVariables, StandaloneDeriving        #-}
+{-# LANGUAGE TypeApplications, TypeFamilies, TypeInType, TypeOperators #-}
+{-# LANGUAGE UndecidableInstances                                      #-}
+{-# OPTIONS_GHC -Wall #-}
+-- | https://gist.github.com/konn/27c00f784dd883ec2b90eab8bc84a81d
+module Data.Aeson.Generic.DerivingVia
+     ( StrFun(..), Setting(..), SumEncoding'(..), DefaultOptions, WithOptions(..)
+     , -- Utility type synonyms to save ticks (') before promoted data constructors
+       type Drop, type CamelTo2, type UserDefined
+     , type TaggedObj, type UntaggedVal, type ObjWithSingleField, type TwoElemArr
+     , type FieldLabelModifier
+     , type ConstructorTagModifier
+     , type AllNullaryToStringTag
+     , type OmitNothingFields
+     , type SumEnc
+     , type UnwrapUnaryRecords
+     , type TagSingleConstructors
+     )
+  where
+
+import           Prelude
+import           Data.Aeson      (FromJSON (..), GFromJSON, GToJSON,
+                                  ToJSON (..))
+import           Data.Aeson      (Options (..), Zero, camelTo2,
+                                  genericParseJSON)
+import           Data.Aeson      (defaultOptions, genericToJSON)
+import qualified Data.Aeson      as Aeson
+import           Data.Kind       (Constraint, Type)
+import           Data.Proxy      (Proxy (..))
+import           Data.Reflection (Reifies (..))
+import           GHC.Generics    (Generic, Rep)
+import           GHC.TypeLits    (KnownNat, KnownSymbol, natVal, symbolVal)
+import           GHC.TypeLits    (Nat, Symbol)
+
+newtype WithOptions options a = WithOptions { runWithOptions :: a }
+
+data StrFun = Drop     Nat
+            | CamelTo2 Symbol
+            | forall p. UserDefined p
+
+type Drop = 'Drop
+type CamelTo2 = 'CamelTo2
+type UserDefined = 'UserDefined
+
+type family Demoted a where
+  Demoted Symbol  = String
+  Demoted StrFun  = String -> String
+  Demoted [a]     = [Demoted a]
+  Demoted Setting = Options -> Options
+  Demoted SumEncoding' = Aeson.SumEncoding
+  Demoted a = a
+
+data SumEncoding' = TaggedObj {tagFieldName' :: Symbol, contentsFieldName :: Symbol }
+                  | UntaggedVal
+                  | ObjWithSingleField
+                  | TwoElemArr
+
+type TaggedObj          = 'TaggedObj
+type UntaggedVal        = 'UntaggedVal
+type ObjWithSingleField = 'ObjWithSingleField
+type TwoElemArr         = 'TwoElemArr
+
+data Setting = FieldLabelModifier     [StrFun]
+             | ConstructorTagModifier [StrFun]
+             | AllNullaryToStringTag  Bool
+             | OmitNothingFields      Bool
+             | SumEnc                 SumEncoding'
+             | UnwrapUnaryRecords     Bool
+             | TagSingleConstructors  Bool
+
+type FieldLabelModifier     = 'FieldLabelModifier
+type ConstructorTagModifier = 'ConstructorTagModifier
+-- | If 'True' the constructors of a datatype, with all nullary constructors,
+-- will be encoded to just a string with the constructor tag. If 'False' the
+-- encoding will always follow the 'SumEncoding'.
+type AllNullaryToStringTag  = 'AllNullaryToStringTag
+type OmitNothingFields      = 'OmitNothingFields
+type SumEnc                 = 'SumEnc
+-- | Hide the field name when a record constructor has only one field, like a
+-- newtype.
+type UnwrapUnaryRecords     = 'UnwrapUnaryRecords
+-- | Encode types with a single constructor as sums, so that
+-- 'AllNullaryToStringTag' and 'SumEncoding' apply.
+type TagSingleConstructors  = 'TagSingleConstructors
+
+class Demotable (a :: k) where
+  demote :: proxy a -> Demoted k
+
+type All :: (Type -> Constraint) -> [Type] -> Constraint
+type family All p xs where
+  All p '[] = ()
+  All p (x ': xs) = (p x, All p xs)
+
+instance Reifies f (String -> String) => Demotable ('UserDefined f) where
+  demote _ = reflect @f Proxy
+
+instance KnownSymbol sym => Demotable sym where
+  demote = symbolVal
+
+instance (KnownSymbol s, KnownSymbol t) => Demotable ('TaggedObj s t) where
+  demote _ = Aeson.TaggedObject (symbolVal @s Proxy) (symbolVal @t Proxy)
+
+instance Demotable 'UntaggedVal where
+  demote _ = Aeson.UntaggedValue
+
+instance Demotable 'ObjWithSingleField where
+  demote _ = Aeson.ObjectWithSingleField
+
+instance Demotable 'TwoElemArr where
+  demote _ = Aeson.TwoElemArray
+
+instance Demotable xs => Demotable ('FieldLabelModifier xs) where
+  demote _ o = o { fieldLabelModifier = foldr (.) id (demote (Proxy @xs)) }
+
+instance Demotable xs => Demotable ('ConstructorTagModifier xs) where
+  demote _ o = o { constructorTagModifier = foldr (.) id (demote (Proxy @xs)) }
+
+instance Demotable b => Demotable ('AllNullaryToStringTag b) where
+  demote _ o = o { allNullaryToStringTag = demote (Proxy @b) }
+
+instance Demotable b => Demotable ('OmitNothingFields b) where
+  demote _ o = o { omitNothingFields = demote (Proxy @b) }
+
+instance Demotable b => Demotable ('UnwrapUnaryRecords b) where
+  demote _ o = o { unwrapUnaryRecords = demote (Proxy @b) }
+
+instance Demotable b => Demotable ('TagSingleConstructors b) where
+  demote _ o = o { tagSingleConstructors = demote (Proxy @b) }
+
+instance Demotable b => Demotable ('SumEnc b) where
+  demote _ o = o { sumEncoding = demote (Proxy @b) }
+
+instance Demotable 'True where
+  demote _ = True
+
+instance Demotable 'False where
+  demote _ = False
+
+instance KnownNat n => Demotable ('Drop n) where
+  demote _ = drop (fromIntegral $ natVal (Proxy :: Proxy n))
+
+instance KnownSymbol sym => Demotable ('CamelTo2 sym) where
+  demote _ = camelTo2 $ head $ symbolVal @sym Proxy
+
+instance {-# OVERLAPPING #-} Demotable ('[] :: [k]) where
+  demote _ = []
+
+instance (Demotable (x :: k), Demotable (xs :: [k])) => Demotable (x ': xs) where
+  demote _ = demote (Proxy @x) : demote (Proxy @xs)
+
+type DefaultOptions = ('[] :: [Setting])
+
+reflectOptions :: forall xs proxy. Demotable (xs :: [Setting]) => proxy xs -> Options
+reflectOptions pxy = foldr (.) id (demote pxy) defaultOptions
+
+instance (Demotable (options :: [Setting])) => Reifies options Options where
+  reflect = reflectOptions
+
+instance (Generic a, GToJSON Zero (Rep a), Reifies (options :: k) Options)
+       => ToJSON (WithOptions options a) where
+  toJSON = genericToJSON (reflect (Proxy @options)) . runWithOptions
+
+instance (Generic a, GFromJSON Zero (Rep a), Reifies (options :: k) Options)
+       => FromJSON (WithOptions options a) where
+  parseJSON = fmap WithOptions . genericParseJSON (reflect (Proxy @options))
diff --git a/users/aspen/xanthous/src/Xanthous/AI/Gormlak.hs b/users/aspen/xanthous/src/Xanthous/AI/Gormlak.hs
new file mode 100644
index 000000000000..1f2b513ffe0e
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/AI/Gormlak.hs
@@ -0,0 +1,201 @@
+{-# 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, _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, HasLanguage(language), getLanguage
+                 , HasAttacks (attacks), creatureAttackMessage
+                 )
+import           Xanthous.Entities.Common
+                 ( wielded, Inventory, wieldedItems, WieldedItem (WieldedItem) )
+import           Xanthous.Game.State
+import           Xanthous.Game.Lenses
+                 ( entitiesCollision, collisionAt
+                 , character, characterPosition, positionIsCharacterVisible
+                 , hearingRadius
+                 )
+import           Xanthous.Data.EntityMap.Graphics (linesOfSight, canSee)
+import           Xanthous.Random
+import           Xanthous.Monad (say, message)
+import           Xanthous.Generators.Speech (word)
+import qualified Linear.Metric as Metric
+import qualified Xanthous.Messages as Messages
+--------------------------------------------------------------------------------
+
+--  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
+  , HasField "_inventory" entity entity Inventory Inventory
+  , 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
+  canSeeCharacter <- uses entities $ canSee (entityIs @Character) pos vision
+
+  let selectDestination pos' creature' = destinationFromPos <$> do
+        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
+
+  pe' <- if canSeeCharacter && not (creature ^. creatureGreeted)
+        then yellAtCharacter $> (pe & positioned . creatureGreeted .~ True)
+        else pure pe
+
+  dest <- maybe (selectDestination pos creature) pure
+         . mfilter (\(Destination p _) -> p /= pos)
+         $ creature ^. hippocampus . destination
+  let progress' =
+        dest ^. destinationProgress
+        + creature ^. creatureType . Raw.speed . invertedRate |*| ticks
+  if progress' < 1
+    then pure
+         $ pe'
+         & positioned . hippocampus . destination
+         ?~ (dest & destinationProgress .~ progress')
+    else do
+      let newPos = dest ^. destinationPosition
+          remainingSpeed = progress' - 1
+      newDest <- selectDestination newPos creature
+                <&> destinationProgress +~ remainingSpeed
+      let pe'' = pe' & positioned . 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
+    vision = visionRadius creature
+    attackCharacter = do
+      dmg <- case creature ^? inventory . wielded . wieldedItems of
+        Just (WieldedItem item wi) -> do
+          let msg = fromMaybe
+                    (Messages.lookup ["combat", "creatureAttack", "genericWeapon"])
+                    $ wi ^. creatureAttackMessage
+          message msg $ object [ "creature" A..= creature
+                               , "item" A..= item
+                               ]
+          pure $ wi ^. Raw.damage
+        Nothing -> do
+          attack <- choose $ creature ^. creatureType . attacks
+          attackDescription <- Messages.render (attack ^. Raw.description)
+                              $ object []
+          say ["combat", "creatureAttack", "natural"]
+              $ object [ "creature" A..= creature
+                       , "attackDescription" A..= attackDescription
+                       ]
+          pure $ attack ^. Raw.damage
+
+      character %= Character.damage dmg
+
+    yellAtCharacter = for_ (creature ^. creatureType . language)
+      $ \lang -> do
+          utterance <- fmap (<> "!") . word $ getLanguage lang
+          creatureSaysText pe utterance
+
+    creatureGreeted :: Lens' entity Bool
+    creatureGreeted = hippocampus . greetedCharacter
+
+
+-- | A creature sends some text
+--
+-- If that creature is visible to the character, its description will be
+-- included, otherwise if it's within earshot the character will just hear the
+-- sound
+creatureSaysText
+  :: (MonadState GameState m, MonadRandom m, IsCreature entity)
+  => Positioned entity
+  -> Text
+  -> m ()
+creatureSaysText ent txt = do
+  let entPos = ent ^. position . _Position . to (fmap fromIntegral)
+  charPos <- use $ characterPosition . _Position . to (fmap fromIntegral)
+  let dist :: Int
+      dist = round $ Metric.distance @_ @Double entPos charPos
+      audible = dist <= fromIntegral hearingRadius
+  when audible $ do
+    visible <- positionIsCharacterVisible $ ent ^. position
+    let path = ["entities", "say", "creature"]
+               <> [if visible then "visible" else "invisible"]
+        params = object [ "creature" A..= (ent ^. positioned)
+                        , "message" A..= txt
+                        ]
+    say path params
+
+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
+
+hippocampus :: HasField "_hippocampus" s t a b => Lens s t a b
+hippocampus = field @"_hippocampus"
+
+creatureType :: HasField "_creatureType" s t a b => Lens s t a b
+creatureType = field @"_creatureType"
+
+inventory :: HasField "_inventory" s t a b => Lens s t a b
+inventory = field @"_inventory"
+
+--------------------------------------------------------------------------------
+
+-- 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/aspen/xanthous/src/Xanthous/App.hs b/users/aspen/xanthous/src/Xanthous/App.hs
new file mode 100644
index 000000000000..426230cdc2fc
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/App.hs
@@ -0,0 +1,647 @@
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE RecordWildCards      #-}
+--------------------------------------------------------------------------------
+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
+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 qualified Data.Vector as V
+import           System.Exit
+import           System.Directory (doesFileExist)
+import           Data.List.NonEmpty (NonEmpty(..))
+import           Data.Vector.Lens (toVectorOf)
+--------------------------------------------------------------------------------
+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
+                 , (|*|)
+                 , Tiles(..), Hitpoints, fromScalar
+                 )
+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 hiding (Fire)
+import qualified Xanthous.Messages as Messages
+import           Xanthous.Random
+import           Xanthous.Util (removeVectorIndex, useListOf)
+import           Xanthous.Util.Inflection (toSentence)
+import           Xanthous.Physics (throwDistance, bluntThrowDamage)
+import           Xanthous.Data.EntityMap.Graphics (lineOfSight)
+import           Xanthous.Data.EntityMap (EntityID)
+--------------------------------------------------------------------------------
+import           Xanthous.Entities.Common
+                 ( InventoryPosition, describeInventoryPosition, backpack
+                 , wieldableItem, wieldedItems, wielded, itemsWithPosition
+                 , removeItemFromPosition, asWieldedItem
+                 , wieldedItem, items, Hand (..), describeHand, wieldInHand
+                 , WieldedItem, Wielded (..)
+                 )
+import qualified Xanthous.Entities.Character as Character
+import           Xanthous.Entities.Character hiding (pickUpItem)
+import           Xanthous.Entities.Item (Item, weight)
+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.Level
+import qualified Xanthous.Generators.Level.CaveAutomata as CaveAutomata
+import qualified Xanthous.Generators.Level.Dungeon as Dungeon
+--------------------------------------------------------------------------------
+
+type App = Brick.App GameState AppEvent ResourceName
+
+data RunType = NewGame | LoadGame FilePath
+  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 save -> pure . (savefile ?~ save)
+  , 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
+       cancelAutocommand
+       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 Help = showPanel HelpPanel >> continue
+
+handleCommand (Move dir) = do
+  newPos <- uses characterPosition $ move dir
+  collisionAt newPos >>= \case
+    Nothing -> do
+      characterPosition .= newPos
+      stepGameBy =<< uses (character . speed) (|*| Tiles 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
+  takeItemFromInventory_ ["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) -> revealedEntitiesAtPosition 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 DescribeInventory = do
+  selectItemFromInventory_ ["inventory", "describe", "select"] Cancellable id
+    (say_ ["inventory", "describe", "nothing"])
+    $ \(MenuResult (invPos, item)) -> showPanel . ItemDescriptionPanel
+        $ Item.fullDescription item
+        <> "\n\n" <> describeInventoryPosition invPos
+  continue
+
+
+handleCommand Wield = do
+  hs <- use $ character . inventory . wielded
+  selectItem $ \(MenuResult (invPos, (item :: WieldedItem))) -> do
+    selectHand hs $ \(MenuResult hand) -> do
+      character . inventory
+        %= removeItemFromPosition invPos (asWieldedItem # item)
+      prevItems <- character . inventory . wielded %%= wieldInHand hand item
+      character . inventory . backpack
+        <>= fromList (map (view wieldedItem) prevItems)
+      say ["wield", "wielded"] $ object [ "item" A..= item
+                                        , "hand" A..= describeHand hand
+                                        ]
+  continue
+  where
+    selectItem =
+      selectItemFromInventory_ ["wield", "menu"] Cancellable asWieldedItem
+        (say_ ["wield", "nothing"])
+    selectHand hs = menu_ ["wield", "hand"] Cancellable $ handsMenu hs
+    itemsInHand (Hands i _) LeftHand       = toList i
+    itemsInHand (DoubleHanded _) LeftHand  = []
+    itemsInHand (Hands _ i) RightHand      = toList i
+    itemsInHand (DoubleHanded _) RightHand = []
+    itemsInHand (Hands l r) BothHands      = toList l <> toList r
+    itemsInHand (DoubleHanded i) BothHands = [i]
+    describeItems [] = ""
+    describeItems is
+      = " (currently holding "
+      <> (intercalate " and" $ map (view $ wieldedItem . to description) is)
+      <> ")"
+    handsMenu hs = mapFromList
+      . map (second $ \hand ->
+                MenuOption
+                ( describeHand hand
+                <> describeItems (itemsInHand hs hand)
+                )
+                hand
+            )
+      $ [ ('l', LeftHand)
+        , ('r', RightHand)
+        , ('b', BothHands)
+        ]
+
+handleCommand Fire = do
+  selectItemFromInventory_ ["fire", "menu"] Cancellable id
+    (say_ ["fire", "nothing"])
+    $ \(MenuResult (invPos, item)) ->
+      let wt = weight item
+          dist = throwDistance wt
+          dam = bluntThrowDamage wt
+      in if dist < fromScalar 1
+         then say_ ["fire", "zeroRange"]
+         else firePrompt_ ["fire", "target"] Cancellable dist $
+          \(FireResult targetPos) -> do
+              charPos <- use characterPosition
+              mTarget <- uses entities $ firstEnemy . lineOfSight charPos targetPos
+              case mTarget of
+                Just target -> do
+                  creature' <- damageCreature target dam
+                  unless (Creature.isDead creature') $
+                    let msgPath = ["fire", "fired"] <> [if dam == 0
+                                                        then "noDamage"
+                                                        else "someDamage"]
+                    in say msgPath $ object [ "item" A..= item
+                                            , "creature" A..= creature'
+                                            ]
+                Nothing ->
+                  say ["fire", "fired", "noTarget"] $ object [ "item" A..= item ]
+              character . inventory %= removeItemFromPosition invPos item
+              entities . EntityMap.atPosition targetPos %= (SomeEntity item <|)
+              stepGame -- TODO(grfn): should this be based on distance?
+  continue
+  where
+    firstEnemy
+      :: [(Position, Vector (EntityID, SomeEntity))]
+      -> Maybe (EntityID, Creature)
+    firstEnemy los =
+      let enemies = los >>= \(_, es) -> toList $ headMay es
+      in enemies ^? folded . below _SomeEntity
+
+handleCommand Save =
+  view (config . disableSaving) >>= \case
+    True -> say_ ["save", "disabled"] >> continue
+    False -> do
+      -- TODO default save locations / config file?
+      use savefile >>= \case
+        Just filepath ->
+          stringPromptWithDefault_
+            ["save", "location"]
+            Cancellable
+            (pack filepath)
+            promptCallback
+        Nothing -> prompt_ @'StringPrompt ["save", "location"] Cancellable promptCallback
+      continue
+      where
+        promptCallback :: PromptResult 'StringPrompt -> AppM ()
+        promptCallback (StringResult filename) = do
+          sf <- use savefile
+          exists <- liftIO . doesFileExist $ unpack filename
+          if exists && sf /= Just (unpack filename)
+          then confirm ["save", "overwrite"] (object ["filename" A..= filename])
+              $ doSave filename
+          else doSave filename
+        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' -> do
+      cEID <- use characterEntityID
+      pCharacter <- entities . at cEID <<.= Nothing
+      levels .= levs'
+      charPos <- use characterPosition
+      entities . at cEID .= pCharacter
+      characterPosition .= charPos
+    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 Rest = do
+  say_ ["autocommands", "resting"]
+  runAutocommand AutoRest
+  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 creature = do
+    charDamage <- uses character characterDamage
+    creature' <- damageCreature creature charDamage
+    unless (Creature.isDead creature') $ writeAttackMessage creature'
+    whenM (uses character $ isNothing . weapon) handleFists
+    stepGame
+  weapon chr = chr ^? inventory . wielded . wieldedItems . wieldableItem
+  writeAttackMessage creature = do
+    let params = object ["creature" A..= creature]
+    attackMessages <- uses character getAttackMessages
+    msg <- intercalate " and " <$> for attackMessages (`Messages.render` params)
+    writeMessage $ "You " <> msg
+  getAttackMessages chr =
+    case chr ^.. inventory . wielded . wieldedItems . wieldableItem of
+      [] -> [Messages.lookup ["combat", "hit", "fists"]]
+      is ->
+        is
+        <&> \wi ->
+              fromMaybe (Messages.lookup ["combat", "hit", "generic"])
+              $ wi ^. attackMessage
+
+
+  handleFists = do
+    damageChance <- use $ character . body . knuckles . to fistDamageChance
+    whenM (chance damageChance) $ do
+      damageAmount <- use $ character . body . knuckles . to fistfightingDamage
+      say_ [ "combat" , if damageAmount > 1
+                        then "fistExtraSelfDamage"
+                        else "fistSelfDamage" ]
+      character %= Character.damage damageAmount
+      character . body . knuckles %= damageKnuckles
+
+damageCreature :: (EntityID, Creature) -> Hitpoints -> AppM Creature
+damageCreature (creatureID, creature) dam = do
+  let creature' = Creature.damage dam creature
+      msgParams = object ["creature" A..= creature']
+  if Creature.isDead creature'
+    then do
+      say ["combat", "killed"] msgParams
+      floorItems <- useListOf
+                   $ entities
+                   . ix creatureID
+                   . positioned
+                   . _SomeEntity @Creature
+                   . inventory
+                   . items
+      mCreaturePos <- preuse $ entities . ix creatureID . position
+      entities . at creatureID .= Nothing
+      for_ mCreaturePos $ \creaturePos ->
+        entities . EntityMap.atPosition creaturePos
+          %= (<> fromList (SomeEntity <$> floorItems))
+    else entities . ix creatureID . positioned .= SomeEntity creature'
+  pure creature'
+
+
+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 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 (InventoryPosition, item)) -> AppM ())
+  -> AppM ()
+selectItemFromInventory msgPath msgParams cancellable extraInfo onEmpty cb = do
+  uses (character . inventory)
+       (V.mapMaybe (_2 $ preview extraInfo) . toVectorOf itemsWithPosition)
+    >>= \case
+      Empty -> onEmpty
+      items' -> menu msgPath msgParams cancellable (itemMenu items') cb
+  where
+    itemMenu = mkMenuItems . map itemMenuItem
+    itemMenuItem (invPos, extraInfoItem) =
+      let item = extraInfo # extraInfoItem
+      in ( entityMenuChar item
+         , MenuOption
+           (description item <> " (" <> describeInventoryPosition invPos <> ")")
+           (invPos, extraInfoItem)
+         )
+
+-- | Prompt with an item to select out of the inventory and call callback with
+-- it
+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 (InventoryPosition, item)) -> AppM ())
+  -> AppM ()
+selectItemFromInventory_ msgPath = selectItemFromInventory msgPath ()
+
+-- | Prompt with an item to select out of the inventory, remove it from the
+-- inventory, and call callback with it
+takeItemFromInventory
+  :: 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 ()
+takeItemFromInventory msgPath msgParams cancellable extraInfo onEmpty cb =
+  selectItemFromInventory msgPath msgParams cancellable extraInfo onEmpty
+    $ \(MenuResult (invPos, item)) -> do
+      character . inventory
+        %= removeItemFromPosition invPos (item ^. re extraInfo)
+      cb $ MenuResult item
+
+takeItemFromInventory_
+  :: 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 ()
+takeItemFromInventory_ msgPath = takeItemFromInventory 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
+  :: Word -- ^ Level number, starting at 0
+  -> AppM Level
+genLevel num = do
+  let dims = Dimensions 80 80
+  generator <- choose $ CaveAutomata :| [Dungeon]
+  let
+    doGen = case generator of
+      CaveAutomata -> generateLevel SCaveAutomata CaveAutomata.defaultParams
+      Dungeon -> generateLevel SDungeon Dungeon.defaultParams
+  level <- doGen dims num
+  pure $!! level
+
+levelToGameLevel :: Level -> GameLevel
+levelToGameLevel level =
+  let _levelEntities = levelToEntityMap level
+      _upStaircasePosition = level ^. levelCharacterPosition
+      _levelRevealedPositions = mempty
+  in GameLevel {..}
diff --git a/users/aspen/xanthous/src/Xanthous/App/Autocommands.hs b/users/aspen/xanthous/src/Xanthous/App/Autocommands.hs
new file mode 100644
index 000000000000..5d4db1a47465
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/App/Autocommands.hs
@@ -0,0 +1,76 @@
+--------------------------------------------------------------------------------
+module Xanthous.App.Autocommands
+  ( runAutocommand
+  , autoStep
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Control.Concurrent (threadDelay)
+import qualified Data.Aeson as A
+import           Data.Aeson (object)
+import           Data.List.NonEmpty (nonEmpty)
+import qualified Data.List.NonEmpty as NE
+import           Control.Monad.State (gets)
+--------------------------------------------------------------------------------
+import           Xanthous.App.Common
+import           Xanthous.App.Time
+import           Xanthous.Data
+import           Xanthous.Data.App
+import           Xanthous.Entities.Character (speed, isFullyHealed)
+import           Xanthous.Entities.Creature (Creature, creatureType)
+import           Xanthous.Entities.RawTypes (hostile)
+import           Xanthous.Game.State
+--------------------------------------------------------------------------------
+
+-- | Step the given autocommand forward once
+autoStep :: Autocommand -> AppM ()
+autoStep (AutoMove dir) = do
+  newPos <- uses characterPosition $ move dir
+  collisionAt newPos >>= \case
+    Nothing -> do
+      characterPosition .= newPos
+      stepGameBy =<< uses (character . speed) (|*| (1 :: Tiles))
+      describeEntitiesAt newPos
+      cancelIfDanger
+    Just _ -> cancelAutocommand
+
+autoStep AutoRest = do
+  done <- uses character isFullyHealed
+  if done
+    then say_ ["autocommands", "doneResting"] >> cancelAutocommand
+    else stepGame >> cancelIfDanger
+
+-- | Cancel the autocommand if the character is in danger
+cancelIfDanger :: AppM ()
+cancelIfDanger = do
+  maybeVisibleEnemies <- nonEmpty <$> enemiesInSight
+  for_ maybeVisibleEnemies $ \visibleEnemies -> do
+    say ["autocommands", "enemyInSight"]
+      $ object [ "firstEntity" A..= NE.head visibleEnemies ]
+    cancelAutocommand
+  where
+    enemiesInSight :: AppM [Creature]
+    enemiesInSight = do
+      ents <- gets characterVisibleEntities
+      pure $ ents
+          ^.. folded
+            . _SomeEntity @Creature
+            . filtered (view $ creatureType . hostile)
+
+--------------------------------------------------------------------------------
+
+autocommandIntervalμs :: Int
+autocommandIntervalμs = 1000 * 50 -- 50 ms
+
+runAutocommand :: Autocommand -> AppM ()
+runAutocommand ac = do
+  env <- ask
+  tid <- liftIO . async $ runReaderT go env
+  autocommand .= ActiveAutocommand ac tid
+  where
+    go = everyμs autocommandIntervalμs $ sendEvent AutoContinue
+
+-- | Perform 'act' every μs microseconds forever
+everyμs :: MonadIO m => Int -> m () -> m ()
+everyμs μs act = act >> liftIO (threadDelay μs) >> everyμs μs act
diff --git a/users/aspen/xanthous/src/Xanthous/App/Common.hs b/users/aspen/xanthous/src/Xanthous/App/Common.hs
new file mode 100644
index 000000000000..69ba6f0e0596
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/App/Common.hs
@@ -0,0 +1,67 @@
+--------------------------------------------------------------------------------
+module Xanthous.App.Common
+  ( describeEntities
+  , describeEntitiesAt
+  , entitiesAtPositionWithType
+
+    -- * Re-exports
+  , MonadState
+  , MonadRandom
+  , EntityMap
+  , module Xanthous.Game.Lenses
+  , module Xanthous.Monad
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Data.Aeson (object)
+import qualified Data.Aeson as A
+import           Control.Monad.State (MonadState)
+import           Control.Monad.Random (MonadRandom)
+--------------------------------------------------------------------------------
+import           Xanthous.Data (Position, positioned)
+import           Xanthous.Data.EntityMap (EntityMap)
+import qualified Xanthous.Data.EntityMap as EntityMap
+import           Xanthous.Game
+import           Xanthous.Game.Lenses
+import           Xanthous.Game.State
+import           Xanthous.Monad
+import           Xanthous.Entities.Character (Character)
+import           Xanthous.Util.Inflection (toSentence)
+--------------------------------------------------------------------------------
+
+entitiesAtPositionWithType
+  :: forall a. (Entity a, Typeable a)
+  => Position
+  -> EntityMap SomeEntity
+  -> [(EntityMap.EntityID, a)]
+entitiesAtPositionWithType pos em =
+  let someEnts = EntityMap.atPositionWithIDs pos em
+  in flip foldMap someEnts $ \(eid, view positioned -> se) ->
+    case downcastEntity @a se of
+      Just e  -> [(eid, e)]
+      Nothing -> []
+
+describeEntitiesAt :: (MonadState GameState m, MonadRandom m) => Position -> m ()
+describeEntitiesAt pos =
+  use ( entities
+      . EntityMap.atPosition pos
+      . to (filter (not . entityIs @Character))
+      ) >>= \case
+        Empty -> pure ()
+        ents  -> describeEntities ents
+
+describeEntities
+  :: ( Entity entity
+    , MonadRandom m
+    , MonadState GameState m
+    , MonoFoldable (f Text)
+    , Functor f
+    , Element (f Text) ~ Text
+    )
+  => f entity
+  -> m ()
+describeEntities ents =
+  let descriptions = description <$> ents
+  in say ["entities", "description"]
+     $ object ["entityDescriptions" A..= toSentence descriptions]
diff --git a/users/aspen/xanthous/src/Xanthous/App/Prompt.hs b/users/aspen/xanthous/src/Xanthous/App/Prompt.hs
new file mode 100644
index 000000000000..799281a1c2fd
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/App/Prompt.hs
@@ -0,0 +1,228 @@
+{-# LANGUAGE UndecidableInstances #-}
+--------------------------------------------------------------------------------
+module Xanthous.App.Prompt
+  ( handlePromptEvent
+  , clearPrompt
+  , prompt
+  , prompt_
+  , stringPromptWithDefault
+  , stringPromptWithDefault_
+  , confirm_
+  , confirm
+  , menu
+  , menu_
+  , firePrompt_
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Brick (BrickEvent(..), Next)
+import           Brick.Widgets.Edit (handleEditorEvent)
+import           Data.Aeson (ToJSON, object)
+import           Graphics.Vty.Input.Events (Event(EvKey), Key(..))
+--------------------------------------------------------------------------------
+import           Xanthous.App.Common
+import           Xanthous.Data (move, Tiles, Position, positioned, _Position)
+import qualified Xanthous.Data as Data
+import           Xanthous.Command (directionFromChar)
+import           Xanthous.Data.App (ResourceName, AppEvent)
+import           Xanthous.Game.Prompt
+import           Xanthous.Game.State
+import qualified Xanthous.Messages as Messages
+import qualified Xanthous.Data.EntityMap as EntityMap
+import           Xanthous.Entities.Creature (creatureType, Creature)
+import           Xanthous.Entities.RawTypes (hostile)
+import qualified Linear.Metric as Metric
+--------------------------------------------------------------------------------
+
+handlePromptEvent
+  :: Text -- ^ Prompt message
+  -> Prompt AppM
+  -> BrickEvent ResourceName AppEvent
+  -> AppM (Next GameState)
+
+handlePromptEvent _ (Prompt Cancellable _ _ _ _) (VtyEvent (EvKey KEsc []))
+  = clearPrompt >> continue
+handlePromptEvent _ pr (VtyEvent (EvKey KEnter []))
+  = clearPrompt >> submitPrompt pr >> continue
+
+handlePromptEvent _ pr@(Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'y') []))
+  = clearPrompt >> submitPrompt pr >> continue
+
+handlePromptEvent _ (Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'n') []))
+  = clearPrompt >> continue
+
+handlePromptEvent
+  msg
+  (Prompt c SStringPrompt (StringPromptState edit) pri cb)
+  (VtyEvent ev)
+  = do
+    edit' <- lift $ handleEditorEvent ev edit
+    let prompt' = Prompt c SStringPrompt (StringPromptState edit') pri cb
+    promptState .= WaitingPrompt msg prompt'
+    continue
+
+handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ cb)
+  (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) []))
+  = clearPrompt >> cb (DirectionResult dir) >> continue
+handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ _) _ = continue
+
+handlePromptEvent _ (Prompt _ SMenu _ items' cb) (VtyEvent (EvKey (KChar chr) []))
+  | Just (MenuOption _ res) <- items' ^. at chr
+  = clearPrompt >> cb (MenuResult res) >> continue
+  | otherwise
+  = continue
+
+handlePromptEvent
+  msg
+  (Prompt c SPointOnMap (PointOnMapPromptState pos) pri cb)
+  (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) []))
+  = let pos' = move dir pos
+        prompt' = Prompt c SPointOnMap (PointOnMapPromptState pos') pri cb
+    in promptState .= WaitingPrompt msg prompt'
+       >> continue
+handlePromptEvent _ (Prompt _ SPointOnMap _ _ _) _ = continue
+
+handlePromptEvent
+  msg
+  (Prompt c SFire (FirePromptState pos) pri@(origin, range) cb)
+  (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) []))
+  = do
+  let pos' = move dir pos
+      prompt' = Prompt c SFire (FirePromptState pos') pri cb
+  when (Data.distance origin pos' <= range) $
+    promptState .= WaitingPrompt msg prompt'
+  continue
+
+handlePromptEvent
+  _
+  (Prompt Cancellable _ _ _ _)
+  (VtyEvent (EvKey (KChar 'q') []))
+  = clearPrompt >> continue
+handlePromptEvent _ _ _ = continue
+
+clearPrompt :: AppM ()
+clearPrompt = promptState .= NoPrompt
+
+type PromptParams :: PromptType -> Type
+type family PromptParams pt where
+  PromptParams ('Menu a) = Map Char (MenuOption a) -- Menu items
+  PromptParams 'Fire     = Tiles -- Range
+  PromptParams _         = ()
+
+prompt
+  :: forall (pt :: PromptType) (params :: Type).
+    (ToJSON params, SingPromptType pt, PromptParams pt ~ ())
+  => [Text]                     -- ^ Message key
+  -> params                     -- ^ Message params
+  -> PromptCancellable
+  -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler
+  -> AppM ()
+prompt msgPath params cancellable cb = do
+  let pt = singPromptType @pt
+  msg <- Messages.message msgPath params
+  mp :: Maybe (Prompt AppM) <- case pt of
+    SPointOnMap -> do
+      charPos <- use characterPosition
+      pure . Just $ mkPointOnMapPrompt cancellable charPos cb
+    SStringPrompt -> pure . Just $ mkStringPrompt cancellable cb
+    SConfirm -> pure . Just $ mkPrompt cancellable pt cb
+    SDirectionPrompt -> pure . Just $ mkPrompt cancellable pt cb
+    SContinue -> pure . Just $ mkPrompt cancellable pt cb
+  for_ mp $ \p -> promptState .= WaitingPrompt msg p
+
+prompt_
+  :: forall (pt :: PromptType).
+    (SingPromptType pt, PromptParams pt ~ ())
+  => [Text] -- ^ Message key
+  -> PromptCancellable
+  -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler
+  -> AppM ()
+prompt_ msg = prompt msg $ object []
+
+stringPromptWithDefault
+  :: forall (params :: Type). (ToJSON params)
+  => [Text]                                -- ^ Message key
+  -> params                                -- ^ Message params
+  -> PromptCancellable
+  -> Text                                  -- ^ Prompt default
+  -> (PromptResult 'StringPrompt -> AppM ()) -- ^ Prompt promise handler
+  -> AppM ()
+stringPromptWithDefault msgPath params cancellable def cb = do
+  msg <- Messages.message msgPath params
+  let p = mkStringPromptWithDefault cancellable def cb
+  promptState .= WaitingPrompt msg p
+
+stringPromptWithDefault_
+  :: [Text]                                -- ^ Message key
+  -> PromptCancellable
+  -> Text                                  -- ^ Prompt default
+  -> (PromptResult 'StringPrompt -> AppM ()) -- ^ Prompt promise handler
+  -> AppM ()
+stringPromptWithDefault_ msg = stringPromptWithDefault msg $ object []
+
+confirm
+  :: ToJSON params
+  => [Text] -- ^ Message key
+  -> params
+  -> AppM ()
+  -> AppM ()
+confirm msgPath params
+  = prompt @'Confirm msgPath params Cancellable . const
+
+confirm_ :: [Text] -> AppM () -> AppM ()
+confirm_ msgPath = confirm msgPath $ object []
+
+menu :: forall (a :: Type) (params :: Type).
+       (ToJSON params)
+     => [Text]                            -- ^ Message key
+     -> params                            -- ^ Message params
+     -> PromptCancellable
+     -> Map Char (MenuOption a)           -- ^ Menu items
+     -> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler
+     -> AppM ()
+menu msgPath params cancellable items' cb = do
+  msg <- Messages.message msgPath params
+  let p = mkMenu cancellable items' cb
+  promptState .= WaitingPrompt msg p
+
+menu_ :: forall (a :: Type).
+        [Text]                            -- ^ Message key
+      -> PromptCancellable
+      -> Map Char (MenuOption a)           -- ^ Menu items
+      -> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler
+      -> AppM ()
+menu_ msgPath = menu msgPath $ object []
+
+firePrompt_
+  :: [Text]                        -- ^ Message key
+  -> PromptCancellable
+  -> Tiles                         -- ^ Range
+  -> (PromptResult 'Fire -> AppM ()) -- ^ Promise handler
+  -> AppM ()
+firePrompt_ msgPath cancellable range cb = do
+  msg <- Messages.message msgPath $ object []
+  initialPos <- maybe (use characterPosition) pure =<< nearestEnemyPosition
+  let p = mkFirePrompt cancellable initialPos range cb
+  promptState .= WaitingPrompt msg p
+
+-- | Returns the position of the nearest visible hostile creature, if any
+nearestEnemyPosition :: AppM (Maybe Position)
+nearestEnemyPosition = do
+  charPos <- use characterPosition
+  em <- use entities
+  ps <- characterVisiblePositions
+  let candidates = toList ps >>= \p ->
+        let ents = EntityMap.atPositionWithIDs p em
+        in ents
+           ^.. folded
+           . _2
+           . positioned
+           . _SomeEntity @Creature
+           . creatureType
+           . filtered (view hostile)
+           . to (const (distance charPos p, p))
+  pure . headMay . fmap snd $ sortOn fst candidates
+  where
+    distance :: Position -> Position -> Double
+    distance = Metric.distance `on` (fmap fromIntegral . view _Position)
diff --git a/users/aspen/xanthous/src/Xanthous/App/Time.hs b/users/aspen/xanthous/src/Xanthous/App/Time.hs
new file mode 100644
index 000000000000..cca352858d9c
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/App/Time.hs
@@ -0,0 +1,42 @@
+--------------------------------------------------------------------------------
+module Xanthous.App.Time
+  ( stepGame
+  , stepGameBy
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           System.Exit
+--------------------------------------------------------------------------------
+import           Xanthous.Data (Ticks)
+import           Xanthous.App.Prompt
+import qualified Xanthous.Data.EntityMap as EntityMap
+import           Xanthous.Entities.Character (isDead)
+import           Xanthous.Game.State
+import           Xanthous.Game.Prompt
+import           Xanthous.Game.Lenses
+import           Control.Monad.State (modify)
+import qualified Xanthous.Game.Memo as Memo
+--------------------------------------------------------------------------------
+
+
+stepGameBy :: Ticks -> AppM ()
+stepGameBy ticks = do
+  ents <- uses entities EntityMap.toEIDsAndPositioned
+  for_ ents $ \(eid, pEntity) -> do
+    pEntity' <- step ticks pEntity
+    entities . ix eid .= pEntity'
+
+  clearMemo Memo.characterVisiblePositions
+  modify updateCharacterVision
+
+  whenM (uses character isDead)
+    . prompt_ @'Continue ["dead"] Uncancellable
+    . const . lift . liftIO
+    $ exitSuccess
+
+ticksPerTurn :: Ticks
+ticksPerTurn = 100
+
+stepGame :: AppM ()
+stepGame = stepGameBy ticksPerTurn
diff --git a/users/aspen/xanthous/src/Xanthous/Command.hs b/users/aspen/xanthous/src/Xanthous/Command.hs
new file mode 100644
index 000000000000..6e6274a02c6f
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Command.hs
@@ -0,0 +1,145 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Command
+  ( -- * Commands
+    Command(..)
+  , commandIsHidden
+    -- * Keybindings
+  , Keybinding(..)
+  , keybindings
+  , commands
+  , commandFromKey
+  , directionFromChar
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude hiding (Left, Right, Down, try)
+--------------------------------------------------------------------------------
+import           Graphics.Vty.Input (Key(..), Modifier(..))
+import qualified Data.Char as Char
+import           Data.Aeson (FromJSON (parseJSON), FromJSONKey, FromJSONKeyFunction (FromJSONKeyTextParser))
+import qualified Data.Aeson as A
+import           Data.Aeson.Generic.DerivingVia
+import           Text.Megaparsec (Parsec, errorBundlePretty, parse, eof, try)
+import           Text.Megaparsec.Char (string', char', printChar)
+import           Data.FileEmbed (embedFile)
+import qualified Data.Yaml as Yaml
+import           Test.QuickCheck.Arbitrary
+import           Data.Aeson.Types (Parser)
+--------------------------------------------------------------------------------
+import           Xanthous.Data (Direction(..))
+import           Xanthous.Util.QuickCheck (GenericArbitrary(..))
+--------------------------------------------------------------------------------
+
+data Command
+  = Quit
+  | Help
+  | Move !Direction
+  | StartAutoMove !Direction
+  | PreviousMessage
+  | PickUp
+  | Drop
+  | Open
+  | Close
+  | Wait
+  | Eat
+  | Look
+  | Save
+  | Read
+  | ShowInventory
+  | DescribeInventory
+  | Wield
+  | Fire
+  | GoUp
+  | GoDown
+  | Rest
+
+    -- | TODO replace with `:` commands
+  | ToggleRevealAll
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (Hashable, NFData)
+  deriving Arbitrary via GenericArbitrary Command
+  deriving (FromJSON)
+       via WithOptions '[ SumEnc UntaggedVal ]
+           Command
+
+-- | Should the command be hidden from the help menu?
+--
+-- Note that this is true for both debug commands and movement commands, as the
+-- latter is documented non-automatically
+commandIsHidden :: Command -> Bool
+commandIsHidden (Move _) = True
+commandIsHidden (StartAutoMove _) = True
+commandIsHidden ToggleRevealAll = True
+commandIsHidden _ = False
+
+--------------------------------------------------------------------------------
+
+data Keybinding = Keybinding !Key ![Modifier]
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (Hashable, NFData)
+
+parseKeybindingFromText :: Text -> Parser Keybinding
+parseKeybindingFromText
+  = either (fail . errorBundlePretty) pure
+  . parse keybinding "<JSON>"
+  where
+    key :: Parsec Void Text Key
+    key = KUp <$ string' "<up>"
+      <|> KDown <$ string' "<down>"
+      <|> KLeft <$ string' "<left>"
+      <|> KRight <$ string' "<right>"
+      <|> KChar <$> printChar
+
+    modifier :: Parsec Void Text Modifier
+    modifier = modf <* char' '-'
+      where
+        modf = MAlt <$ char' 'a'
+          <|> MMeta <$ char' 'm'
+          <|> MCtrl  <$ char' 'c'
+          <|> MShift  <$ char' 's'
+
+    keybinding :: Parsec Void Text Keybinding
+    keybinding = do
+      mods <- many (try modifier)
+      k <- key
+      eof
+      pure $ Keybinding k mods
+
+instance FromJSON Keybinding where
+  parseJSON = A.withText "Keybinding" parseKeybindingFromText
+
+instance FromJSONKey Keybinding where
+  fromJSONKey = FromJSONKeyTextParser parseKeybindingFromText
+
+rawKeybindings :: ByteString
+rawKeybindings = $(embedFile "src/Xanthous/keybindings.yaml")
+
+keybindings :: HashMap Keybinding Command
+keybindings = either (error . Yaml.prettyPrintParseException) id
+  $ Yaml.decodeEither' rawKeybindings
+
+commands :: HashMap Command Keybinding
+commands = mapFromList . map swap . itoList $ keybindings
+
+commandFromKey :: Key -> [Modifier] -> Maybe Command
+commandFromKey (KChar (directionFromChar -> Just dir)) [] = Just $ Move dir
+commandFromKey (KChar c) []
+  | Char.isUpper c
+  , Just dir <- directionFromChar $ Char.toLower c
+  = Just $ StartAutoMove dir
+commandFromKey k mods = keybindings ^. at keybinding
+  where keybinding = Keybinding k mods
+
+--------------------------------------------------------------------------------
+
+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/aspen/xanthous/src/Xanthous/Data.hs b/users/aspen/xanthous/src/Xanthous/Data.hs
new file mode 100644
index 000000000000..703955206a7e
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Data.hs
@@ -0,0 +1,822 @@
+{-# LANGUAGE PartialTypeSignatures  #-}
+{-# LANGUAGE StandaloneDeriving     #-}
+{-# LANGUAGE RoleAnnotations        #-}
+{-# LANGUAGE RecordWildCards        #-}
+{-# LANGUAGE DeriveTraversable      #-}
+{-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE NoTypeSynonymInstances #-}
+{-# LANGUAGE DuplicateRecordFields  #-}
+{-# LANGUAGE QuantifiedConstraints  #-}
+{-# LANGUAGE UndecidableInstances   #-}
+{-# LANGUAGE AllowAmbiguousTypes    #-}
+--------------------------------------------------------------------------------
+-- | Common data types for Xanthous ------------------------------------------------------------------------------
+module Xanthous.Data
+  ( Opposite(..)
+
+    -- *
+  , Position'(..)
+  , Position
+  , x
+  , y
+
+    -- **
+  , Positioned(..)
+  , _Positioned
+  , position
+  , positioned
+  , loc
+  , _Position
+  , positionFromPair
+  , positionFromV2
+  , addPositions
+  , diffPositions
+  , stepTowards
+  , isUnit
+  , distance
+
+    -- * Boxes
+  , Box(..)
+  , topLeftCorner
+  , bottomRightCorner
+  , setBottomRightCorner
+  , dimensions
+  , inBox
+  , boxIntersects
+  , boxCenter
+  , boxEdge
+  , module Linear.V2
+
+    -- * Unit math
+  , Scalar(..)
+  , Per(..)
+  , invertRate
+  , invertedRate
+  , (|+|)
+  , (|*|)
+  , (|/|)
+  , (:+:)
+  , (:*:)
+  , (:/:)
+  , (:**:)(..)
+  , Ticks(..)
+  , Tiles(..)
+  , TicksPerTile
+  , TilesPerTick
+  , timesTiles
+  , Square(..)
+  , squared
+  , Cubic(..)
+  , Grams
+  , Meters
+  , Uno(..)
+  , Unit(..)
+  , UnitSymbol(..)
+
+    -- *
+  , Dimensions'(..)
+  , Dimensions
+  , HasWidth(..)
+  , HasHeight(..)
+
+    -- *
+  , Direction(..)
+  , move
+  , asPosition
+  , directionOf
+  , Cardinal(..)
+
+    -- *
+  , Corner(..)
+  , Edge(..)
+  , cornerEdges
+
+    -- *
+  , Neighbors(..)
+  , edges
+  , neighborDirections
+  , neighborPositions
+  , neighborCells
+  , arrayNeighbors
+  , rotations
+  , HasTopLeft(..)
+  , HasTop(..)
+  , HasTopRight(..)
+  , HasLeft(..)
+  , HasRight(..)
+  , HasBottomLeft(..)
+  , HasBottom(..)
+  , HasBottomRight(..)
+
+    -- *
+  , 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 (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           Data.Random (Distribution)
+import           Data.Coerce
+import           Data.Proxy (Proxy(Proxy))
+--------------------------------------------------------------------------------
+import           Xanthous.Util (EqEqProp(..), EqProp, between)
+import           Xanthous.Orphans ()
+import           Xanthous.Util.Graphics
+import qualified Linear.Metric as Metric
+--------------------------------------------------------------------------------
+
+-- | 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
+
+-- | Units of measure
+class Unit a where
+  unitSuffix :: Text
+type UnitSymbol :: Symbol -> Type -> Type
+newtype UnitSymbol suffix a = UnitSymbol a
+instance KnownSymbol suffix => Unit (UnitSymbol suffix a) where
+  unitSuffix = pack $ symbolVal @suffix Proxy
+
+newtype ShowUnitSuffix a b = ShowUnitSuffix a
+instance (Show b, Unit a, Coercible a b) => Show (ShowUnitSuffix a b) where
+  show a = show (coerce @_ @b a) <> " " <> unpack (unitSuffix @a)
+
+--------------------------------------------------------------------------------
+
+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 . 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) (V2 a)
+_Position = iso hither yon
+  where
+    hither (Position px py) = V2 px py
+    yon (V2 lx ly) = Position lx ly
+
+positionFromPair :: (Num a, Integral i, Integral j) => (i, j) -> Position' a
+positionFromPair (i, j) = Position (fromIntegral i) (fromIntegral j)
+
+positionFromV2 :: (Num a, Integral i) => V2 i -> Position' a
+positionFromV2 (V2 xx yy) = Position (fromIntegral xx) (fromIntegral yy)
+
+-- | 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 via (GenericArbitrary Direction) instance Arbitrary 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, MonoFoldable)
+
+deriving via (GenericArbitrary (Neighbors a)) instance (Arbitrary a) => Arbitrary (Neighbors a)
+
+type instance Element (Neighbors a) = 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
+
+neighborCells :: Num a => V2 a -> Neighbors (V2 a)
+neighborCells = map (view _Position) . neighborPositions . review _Position
+
+arrayNeighbors
+  :: (IArray a e, Ix i, Num i)
+  => a (V2 i) e
+  -> V2 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 (Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON)
+       via Double
+  deriving (Semigroup, Monoid) via Product Double
+  deriving Show via ShowUnitSuffix (Per a b) Double
+deriving via Double
+  instance ( Distribution d Double
+           , forall xx yy. Coercible xx yy => Coercible (d xx) (d yy)
+           )
+  => Distribution d (Per a b)
+
+instance (Unit a, Unit b) => Unit (a `Per` b) where
+  unitSuffix = unitSuffix @a <> "/" <> unitSuffix @b
+
+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
+
+type (:+:) :: Type -> Type -> Type
+type family (:+:) a b where
+  a :+: a       = a
+  a :+: (Uno b) = a
+
+infixl 6 |+|
+class AddUnit a b where
+  (|+|) :: a -> b -> a :+: b
+
+instance Scalar a => AddUnit a a where
+  x' |+| y' = fromScalar $ scalar x' + scalar y'
+
+instance (Scalar a, Scalar b) => AddUnit a (Uno b) where
+  x' |+| y' = fromScalar $ scalar x' + scalar y'
+
+type (:*:) :: Type -> Type -> Type
+type family (:*:) a b where
+  (a `Per` b) :*: b     = a
+  (Square a)  :*: a     = Cubic a
+  a           :*: a     = Square a
+  a           :*: Uno b = a
+  a           :*: b     = a :**: b
+
+infixl 7 |*|
+class MulUnit a b where
+  (|*|) :: a -> b -> a :*: b
+
+instance (Scalar a, Scalar b) => MulUnit (a `Per` b) b where
+  (Rate rate) |*| b = fromScalar $ rate * scalar b
+
+instance forall a. (Scalar a, a :*: a ~ Square a) => MulUnit a a where
+  x' |*| y' = Square @a . fromScalar $ scalar x' * scalar y'
+
+instance forall a. (Scalar a) => MulUnit (Square a) a where
+  x' |*| y' = Cubic @a . fromScalar $ scalar x' * scalar y'
+
+instance {-# INCOHERENT #-} forall a b.
+  (Scalar a, Scalar b, Scalar (a :*: Uno b))
+    => MulUnit a (Uno b) where
+  x' |*| y' = fromScalar $ scalar x' * scalar y'
+
+type (:/:) :: Type -> Type -> Type
+type family (:/:) a b where
+  (Square a) :/: a          = a
+  (Cubic a)  :/: a          = Square a
+  (Cubic a)  :/: (Square a) = a
+  (a :**: b) :/: b          = a
+  (a :**: b) :/: a          = b
+  a          :/: Uno b      = a
+  a          :/: b          = a `Per` b
+
+infixl 7 |/|
+class DivUnit a b where
+  (|/|) :: a -> b -> a :/: b
+
+instance Scalar a => DivUnit (Square a) a where
+  (Square a) |/| b = fromScalar $ scalar a / scalar b
+
+instance Scalar a => DivUnit (Cubic a) a where
+  (Cubic a) |/| b = fromScalar $ scalar a / scalar b
+
+instance (Scalar a, Cubic a :/: Square a ~ a)
+       => DivUnit (Cubic a) (Square a) where
+  (Cubic a) |/| (Square b) = fromScalar $ scalar a / scalar b
+
+instance (Scalar a, Scalar b) => DivUnit (a :**: b) b where
+  (Times a) |/| b = fromScalar $ scalar a / scalar b
+
+instance (Scalar a, Scalar b) => DivUnit (a :**: b) a where
+  (Times a) |/| b = fromScalar $ scalar a / scalar b
+
+instance {-# INCOHERENT #-} forall a b.
+  (Scalar a, Scalar b, Scalar (a :/: Uno b))
+    => DivUnit a (Uno b) where
+  x' |/| y' = fromScalar $ scalar x' / scalar y'
+
+-- | Dimensionless quantitites (mass per unit mass, radians, etc)
+--
+-- see <https://en.wikipedia.org/wiki/Parts-per_notation#Uno>
+newtype Uno a = Uno a
+  deriving stock (Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving ( Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON
+           , Scalar, Show
+           )
+       via a
+  deriving Unit via UnitSymbol "" (Uno a)
+
+newtype Square a = Square a
+  deriving stock (Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving ( Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON
+           , Scalar
+           )
+       via a
+deriving via (a :: Type)
+  instance ( Distribution d a
+           , forall xx yy. Coercible xx yy => Coercible (d xx) (d yy)
+           )
+  => Distribution d (Square a)
+
+instance Unit a => Unit (Square a) where
+  unitSuffix = unitSuffix @a <> "²"
+
+instance Show a => Show (Square a) where
+  show (Square n) = show n <> "²"
+
+squared :: (Scalar a, a :*: a ~ Square a) => a -> Square a
+squared v = v |*| v
+
+newtype Cubic a = Cubic a
+  deriving stock (Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving ( Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON
+           , Scalar
+           )
+       via a
+deriving via (a :: Type)
+  instance ( Distribution d a
+           , forall xx yy. Coercible xx yy => Coercible (d xx) (d yy)
+           )
+  => Distribution d (Cubic a)
+
+instance Unit a => Unit (Cubic a) where
+  unitSuffix = unitSuffix @a <> "³"
+
+instance Show a => Show (Cubic a) where
+  show (Cubic n) = show n <> "³"
+
+newtype (:**:) a b = Times Double
+  deriving stock (Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON)
+       via Double
+  deriving (Semigroup, Monoid) via Sum Double
+  deriving Show via ShowUnitSuffix (a :**: b) Double
+deriving via Double
+  instance ( Distribution d Double
+           , forall xx yy. Coercible xx yy => Coercible (d xx) (d yy)
+           )
+  => Distribution d (a :**: b)
+
+instance (Unit a, Unit b) => Unit (a :**: b) where
+  unitSuffix = unitSuffix @a <> " " <> unitSuffix @b
+
+--------------------------------------------------------------------------------
+
+newtype Ticks = Ticks Word
+  deriving stock (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
+  deriving Arbitrary via GenericArbitrary Ticks
+  deriving Unit via UnitSymbol "ticks" Ticks
+  deriving Show via ShowUnitSuffix Ticks Word
+deriving via Word
+  instance ( Distribution d Word
+           , forall xx yy. Coercible xx yy => Coercible (d xx) (d yy)
+           )
+  => Distribution d Ticks
+
+newtype Tiles = Tiles Double
+  deriving stock (Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (Num, Ord, Enum, Real, ToJSON, FromJSON, Scalar) via Double
+  deriving (Semigroup, Monoid) via (Sum Double)
+  deriving Arbitrary via GenericArbitrary Tiles
+  deriving Unit via UnitSymbol "m" Tiles
+  deriving Show via ShowUnitSuffix Tiles Double
+deriving via Double
+  instance ( Distribution d Double
+           , forall xx yy. Coercible xx yy => Coercible (d xx) (d yy)
+           )
+  => Distribution d Tiles
+
+type TicksPerTile = Ticks `Per` Tiles
+type TilesPerTick = Tiles `Per` Ticks
+
+timesTiles :: TicksPerTile -> Tiles -> Ticks
+timesTiles = (|*|)
+
+-- | Calculate the (cartesian) distance between two 'Position's, floored and
+-- represented as a number of 'Tile's
+--
+-- Note that this is imprecise, and may be different than the length of a
+-- bresenham's line between the points
+distance :: Position -> Position -> Tiles
+distance
+  = (fromScalar .) . (Metric.distance `on` (fmap fromIntegral . view _Position))
+
+--------------------------------------------------------------------------------
+
+newtype Hitpoints = Hitpoints Word
+  deriving stock (Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving ( Arbitrary, Num, Ord, Bounded, Enum, Integral, Real, Scalar
+           , ToJSON, FromJSON
+           )
+       via Word
+  deriving (Semigroup, Monoid) via Sum Word
+  deriving Unit via UnitSymbol "hp" Hitpoints
+  deriving Show via ShowUnitSuffix Hitpoints Word
+
+--------------------------------------------------------------------------------
+
+-- | Grams, the fundamental measure of weight in Xanthous.
+newtype Grams = Grams Double
+  deriving stock (Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving ( Arbitrary, Num, Ord, Enum, Real, Floating, Fractional, RealFloat
+           , RealFrac, Scalar, ToJSON, FromJSON
+           )
+       via Double
+  deriving (Semigroup, Monoid) via Sum Double
+  deriving Unit via UnitSymbol "g" Grams
+  deriving Show via ShowUnitSuffix Grams Double
+
+-- | Every tile is 1 meter
+type Meters = Tiles
+
+--------------------------------------------------------------------------------
+
+data Box a = Box
+  { _topLeftCorner :: V2 a
+  , _dimensions    :: V2 a
+  }
+  deriving stock (Show, Eq, Ord, Functor, Generic)
+makeFieldsNoPrefix ''Box
+
+-- It seems to be necessary to have an `Arg (V2 a) a` constraint, as a is passed
+-- to V2 internally, in order to make GHC figure out this deriving via correctly.
+deriving via (GenericArbitrary (Box a)) instance (Arbitrary a) => Arbitrary (Box a)
+
+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/aspen/xanthous/src/Xanthous/Data/App.hs b/users/aspen/xanthous/src/Xanthous/Data/App.hs
new file mode 100644
index 000000000000..13c4b5d61068
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Data/App.hs
@@ -0,0 +1,47 @@
+--------------------------------------------------------------------------------
+module Xanthous.Data.App
+  ( Panel(..)
+  , ResourceName(..)
+  , AppEvent(..)
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Test.QuickCheck
+import Test.QuickCheck.Instances.Text ()
+import Data.Aeson (ToJSON, FromJSON)
+--------------------------------------------------------------------------------
+import Xanthous.Util.QuickCheck
+--------------------------------------------------------------------------------
+
+-- | Enum for "panels" displayed in the game's UI.
+data Panel
+  = -- | A panel providing help with the game's commands
+    HelpPanel
+  | -- | A panel displaying the character's inventory
+    InventoryPanel
+  | -- | A panel describing an item in the inventory in detail
+    --
+    -- The argument is the full description of the item
+    ItemDescriptionPanel Text
+  deriving stock (Show, Eq, Ord, Generic)
+  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/aspen/xanthous/src/Xanthous/Data/Entities.hs b/users/aspen/xanthous/src/Xanthous/Data/Entities.hs
new file mode 100644
index 000000000000..39953410f2f3
--- /dev/null
+++ b/users/aspen/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/aspen/xanthous/src/Xanthous/Data/EntityChar.hs b/users/aspen/xanthous/src/Xanthous/Data/EntityChar.hs
new file mode 100644
index 000000000000..855a3462daee
--- /dev/null
+++ b/users/aspen/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/aspen/xanthous/src/Xanthous/Data/EntityMap.hs b/users/aspen/xanthous/src/Xanthous/Data/EntityMap.hs
new file mode 100644
index 000000000000..33a98f1ae5a9
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Data/EntityMap.hs
@@ -0,0 +1,276 @@
+{-# 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
+  , positionOf
+  -- , positionedEntities
+  , neighbors
+  , Deduplicate(..)
+
+  -- * debug
+  , byID
+  , byPosition
+  , lastID
+
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude hiding (lookup)
+import Xanthous.Data
+  ( Position
+  , Positioned(..)
+  , positioned
+  , Neighbors(..)
+  , neighborPositions, position
+  )
+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
+  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
+
+-- | Traversal to the position of the entity with the given ID
+positionOf :: EntityID -> Traversal' (EntityMap a) Position
+positionOf eid = ix eid . position
+
+--------------------------------------------------------------------------------
+makeWrapped ''Deduplicate
diff --git a/users/aspen/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs b/users/aspen/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs
new file mode 100644
index 000000000000..1398c611cf20
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs
@@ -0,0 +1,72 @@
+--------------------------------------------------------------------------------
+module Xanthous.Data.EntityMap.Graphics
+  ( visiblePositions
+  , visibleEntities
+  , lineOfSight
+  , 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 entities on the *line of sight* from the first position
+-- to the second position
+lineOfSight
+  :: forall e. Entity e
+  => Position -- ^ Origin
+  -> Position -- ^ Destination
+  -> EntityMap e
+  -> [(Position, Vector (EntityID, e))]
+lineOfSight (view _Position -> origin) (view _Position -> destination) em =
+  takeWhileInclusive (none (view blocksVision . entityAttributes . snd) . snd)
+    $ getPositionedAt <$> line origin destination
+  where
+    getPositionedAt :: V2 Int -> (Position, Vector (EntityID, e))
+    getPositionedAt (review _Position -> p) =
+      (p, over _2 (view positioned) <$> atPositionWithIDs p em)
+
+-- | 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    -- ^ Centerpoint
+  -> Word        -- ^ Radius
+  -> EntityMap e
+  -> [[(Position, Vector (EntityID, e))]]
+linesOfSight pos visionRadius em =
+  radius <&> \edge -> lineOfSight pos (_Position # edge) em
+  where
+    radius = circle (pos ^. _Position) $ fromIntegral visionRadius
+
+-- | 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/aspen/xanthous/src/Xanthous/Data/Levels.hs b/users/aspen/xanthous/src/Xanthous/Data/Levels.hs
new file mode 100644
index 000000000000..13251d8afdf2
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Data/Levels.hs
@@ -0,0 +1,180 @@
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Data.Levels
+  ( Levels
+  , allLevels
+  , numLevels
+  , 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)
+
+type instance Element (Levels a) = a
+instance MonoFoldable (Levels a)
+instance MonoFunctor (Levels a)
+instance MonoTraversable (Levels a)
+
+instance ComonadStore Word Levels where
+  pos = toEnum . pos . levelZipper
+  peek i = peek (fromEnum i) . levelZipper
+
+instance Traversable Levels where
+  traverse f (Levels z) = Levels <$> traverse f z
+
+instance Foldable1 Levels
+
+instance Traversable1 Levels where
+  traverse1 f levs@(Levels z) = seek (pos levs) . 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₂
+
+-- | The number of levels stored in 'Levels'
+--
+-- Equivalent to 'Data.Foldable.length', but likely faster
+numLevels :: Levels a -> Word
+numLevels = toEnum . size . levelZipper
+
+-- | 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
+  | succ (pos levs) < numLevels 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 :: Word -- ^ 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, pred . toEnum . length $ _levels)
+    pure AltLevels {..}
+  shrink als = do
+    _levels <- shrink $ als ^. levels
+    _currentLevel <- filter (between 0 $ pred . toEnum . length $ _levels)
+                    $ 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/aspen/xanthous/src/Xanthous/Data/Memo.hs b/users/aspen/xanthous/src/Xanthous/Data/Memo.hs
new file mode 100644
index 000000000000..2b2ee0f96028
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Data/Memo.hs
@@ -0,0 +1,98 @@
+--------------------------------------------------------------------------------
+-- | Memoized values
+--------------------------------------------------------------------------------
+module Xanthous.Data.Memo
+  ( Memoized(UnMemoized)
+  , memoizeWith
+  , getMemoized
+  , runMemoized
+  , fillWith
+  , fillWithM
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+import Data.Aeson (FromJSON, ToJSON)
+import Test.QuickCheck (Arbitrary (arbitrary), oneof, CoArbitrary, Function)
+import Test.QuickCheck.Checkers (EqProp)
+import Xanthous.Util (EqEqProp(EqEqProp))
+import Control.Monad.State.Class (MonadState)
+--------------------------------------------------------------------------------
+
+-- | A memoized value, keyed by a key
+--
+-- If key is different than what is stored here, then val is invalid
+data Memoized key val = Memoized key val | UnMemoized
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (Hashable, FromJSON, ToJSON, NFData, CoArbitrary, Function)
+  deriving EqProp via EqEqProp (Memoized key val)
+
+instance (Arbitrary k, Arbitrary v) => Arbitrary (Memoized k v) where
+  arbitrary = oneof [ pure UnMemoized
+                    , Memoized <$> arbitrary <*> arbitrary
+                    ]
+
+-- | Construct a memoized value with the given key
+memoizeWith :: forall key val. key -> val -> Memoized key val
+memoizeWith = Memoized
+{-# INLINE memoizeWith #-}
+
+-- | Retrieve a memoized value providing the key. If the value is unmemoized or
+-- the keys do not match, returns Nothing.
+--
+-- >>> getMemoized 1 (memoizeWith @Int @Int 1 2)
+-- Just 2
+--
+-- >>> getMemoized 2 (memoizeWith @Int @Int 1 2)
+-- Nothing
+--
+-- >>> getMemoized 1 (UnMemoized :: Memoized Int Int)
+-- Nothing
+getMemoized :: Eq key => key -> Memoized key val -> Maybe val
+getMemoized key (Memoized key' v)
+  | key == key' = Just v
+  | otherwise = Nothing
+getMemoized _ UnMemoized = Nothing
+{-# INLINE getMemoized #-}
+
+-- | Get a memoized value using an applicative action to obtain the key
+runMemoized
+  :: (Eq key, Applicative m)
+  => Memoized key val
+  -> m key
+  -> m (Maybe val)
+runMemoized m mk = getMemoized <$> mk <*> pure m
+
+-- | In a monadic state containing a 'MemoState', look up the current memoized
+-- target of some lens keyed by k, filling it with v if not present and
+-- returning either the new or old value
+fillWith
+  :: forall m s k v.
+    (MonadState s m, Eq k)
+  => Lens' s (Memoized k v)
+  -> k
+  -> v
+  -> m v
+fillWith l k v' = do
+  uses l (getMemoized k) >>= \case
+    Just v -> pure v
+    Nothing -> do
+      l .= memoizeWith k v'
+      pure v'
+
+-- | In a monadic state, look up the current memoized target of some lens keyed
+-- by k, filling it with the result of some monadic action v if not present and
+-- returning either the new or old value
+fillWithM
+  :: forall m s k v.
+    (MonadState s m, Eq k)
+  => Lens' s (Memoized k v)
+  -> k
+  -> m v
+  -> m v
+fillWithM l k mv = do
+  uses l (getMemoized k) >>= \case
+    Just v -> pure v
+    Nothing -> do
+      v' <- mv
+      l .= memoizeWith k v'
+      pure v'
diff --git a/users/aspen/xanthous/src/Xanthous/Data/NestedMap.hs b/users/aspen/xanthous/src/Xanthous/Data/NestedMap.hs
new file mode 100644
index 000000000000..1b875d448302
--- /dev/null
+++ b/users/aspen/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/aspen/xanthous/src/Xanthous/Data/VectorBag.hs b/users/aspen/xanthous/src/Xanthous/Data/VectorBag.hs
new file mode 100644
index 000000000000..2e6d48062a45
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Data/VectorBag.hs
@@ -0,0 +1,100 @@
+{-# 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
+    , Filterable
+    )
+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
+
+instance Witherable VectorBag where
+  wither f (VectorBag v) = VectorBag <$> wither f v
+  witherM f (VectorBag v) = VectorBag <$> witherM f v
+  filterA p (VectorBag v) = VectorBag <$> filterA p v
+
+{-
+    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/aspen/xanthous/src/Xanthous/Entities/Character.hs b/users/aspen/xanthous/src/Xanthous/Entities/Character.hs
new file mode 100644
index 000000000000..c8153086f1ac
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Entities/Character.hs
@@ -0,0 +1,241 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE RecordWildCards #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Character
+
+  ( -- * Character datatype
+    Character(..)
+  , characterName
+  , HasInventory(..)
+  , characterDamage
+  , characterHitpoints'
+  , characterHitpoints
+  , hitpointRecoveryRate
+  , speed
+  , body
+
+    -- *** Body
+  , Body(..)
+  , initialBody
+  , knuckles
+  , Knuckles(..)
+  , fistDamageChance
+  , damageKnuckles
+  , fistfightingDamage
+
+    -- * Character functions
+  , mkCharacter
+  , pickUpItem
+  , isDead
+  , isFullyHealed
+  , 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           Test.QuickCheck.Gen (chooseUpTo)
+import           Test.QuickCheck.Checkers (EqProp)
+import           Control.Monad.State.Lazy (execState)
+import           Control.Monad.Trans.State.Lazy (execStateT)
+--------------------------------------------------------------------------------
+import           Xanthous.Game.State
+import           Xanthous.Entities.Item
+import           Xanthous.Entities.Common
+import           Xanthous.Data
+                 ( TicksPerTile, Hitpoints, Per, Ticks, (|*|), positioned )
+import qualified Xanthous.Entities.RawTypes as Raw
+import           Xanthous.Util (EqEqProp(EqEqProp), modifyKL)
+import           Xanthous.Monad (say_)
+--------------------------------------------------------------------------------
+
+-- | The status of the character's knuckles
+--
+-- This struct is used to track the damage and then eventual build-up of
+-- calluses when the character is fighting with their fists
+data Knuckles = Knuckles
+  { -- | How damaged are the knuckles currently, from 0 to 5?
+    --
+    -- At 0, no calluses will form
+    -- At 1 and up, the character will form calluses after a while
+    -- At 5, continuing to fistfight will deal the character even more damage
+    _knuckleDamage   :: !Word
+    -- | How built-up are the character's calluses, from 0 to 5?
+    --
+    -- Each level of calluses decreases the likelihood of being damaged when
+    -- fistfighting by 1%, up to 5 where the character will never be damaged
+    -- fistfighting
+  , _knuckleCalluses :: !Word
+
+    -- | Number of turns that have passed since the last time the knuckles were
+    -- damaged
+  , _ticksSinceDamaged :: Ticks
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving EqProp via EqEqProp Knuckles
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           Knuckles
+makeLenses ''Knuckles
+
+instance Semigroup Knuckles where
+  (Knuckles d₁ c₁ t₁) <> (Knuckles d₂ c₂ t₂) = Knuckles
+    (min (d₁ + d₂) 5)
+    (min (c₁ + c₂) 5)
+    (max t₁ t₂)
+
+instance Monoid Knuckles where
+  mempty = Knuckles 0 0 0
+
+instance Arbitrary Knuckles where
+  arbitrary = do
+    _knuckleDamage <- fromIntegral <$> chooseUpTo 5
+    _knuckleCalluses <- fromIntegral <$> chooseUpTo 5
+    _ticksSinceDamaged <- arbitrary
+    pure Knuckles{..}
+
+-- | Likelihood that the character fighting with their fists will damage
+-- themselves
+fistDamageChance :: Knuckles -> Float
+fistDamageChance knuckles
+  | calluses == 5 = 0
+  | otherwise = baseChance - (0.01 * fromIntegral calluses)
+  where
+    baseChance = 0.08
+    calluses = knuckles ^. knuckleCalluses
+
+-- | Damage the knuckles by a level (capping at the max knuckle damage)
+damageKnuckles :: Knuckles -> Knuckles
+damageKnuckles = execState $ do
+  knuckleDamage %= min 5 . succ
+  ticksSinceDamaged .= 0
+
+-- | Damage taken when fistfighting and 'fistDamageChance' has occurred
+fistfightingDamage :: Knuckles -> Hitpoints
+fistfightingDamage knuckles
+  | knuckles ^. knuckleDamage == 5 = 2
+  | otherwise = 1
+
+stepKnuckles :: Ticks -> Knuckles -> AppM Knuckles
+stepKnuckles ticks = execStateT . whenM (uses knuckleDamage (> 0)) $ do
+  ticksSinceDamaged += ticks
+  whenM (uses ticksSinceDamaged (>= 2000)) $ do
+    dam <- knuckleDamage <<.= 0
+    knuckleCalluses %= min 5 . (+ dam)
+    ticksSinceDamaged .= 0
+    lift $ say_ ["character", "body", "knuckles", "calluses"]
+
+
+-- | Status of the character's body
+data Body = Body
+  { _knuckles :: !Knuckles
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary Body
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           Body
+makeLenses ''Body
+
+initialBody :: Body
+initialBody = Body { _knuckles = mempty }
+
+--------------------------------------------------------------------------------
+
+data Character = Character
+  { _inventory           :: !Inventory
+  , _characterName       :: !(Maybe Text)
+  , _characterHitpoints' :: !Double
+  , _speed               :: !TicksPerTile
+  , _body                :: !Body
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           Character
+makeFieldsNoPrefix ''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 = execStateT $ do
+    positioned . characterHitpoints' %= \hp ->
+      if hp > fromIntegral initialHitpoints
+      then hp
+      else hp + hitpointRecoveryRate |*| ticks
+    modifyKL (positioned . body . knuckles) $ lift . stepKnuckles 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
+  , _body                = initialBody
+  }
+
+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
+  . filter (/= 0)
+  . Just
+  . sumOf (inventory . wielded . wieldedItems . wieldableItem . Raw.damage)
+
+-- | Is the character fully healed up to or past their initial hitpoints?
+isFullyHealed :: Character -> Bool
+isFullyHealed = (>= initialHitpoints) . characterHitpoints
+
+-- | Is the character dead?
+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
+
+{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-}
diff --git a/users/aspen/xanthous/src/Xanthous/Entities/Common.hs b/users/aspen/xanthous/src/Xanthous/Entities/Common.hs
new file mode 100644
index 000000000000..368b03f25bed
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Entities/Common.hs
@@ -0,0 +1,290 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      : Xanthous.Entities.Common
+-- Description : Common data type definitions and utilities for entities
+--
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Common
+  ( -- * Inventory
+    Inventory(..)
+  , HasInventory(..)
+  , backpack
+  , wielded
+  , items
+  , InventoryPosition(..)
+  , describeInventoryPosition
+  , inventoryPosition
+  , itemsWithPosition
+  , removeItemFromPosition
+
+    -- ** Wielded items
+  , Wielded(..)
+  , nothingWielded
+  , hands
+  , leftHand
+  , rightHand
+  , inLeftHand
+  , inRightHand
+  , doubleHanded
+  , Hand(..)
+  , itemsInHand
+  , inHand
+  , wieldInHand
+  , describeHand
+  , wieldedItems
+  , WieldedItem(..)
+  , wieldedItem
+  , wieldableItem
+  , asWieldedItem
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Data.Aeson (ToJSON, FromJSON)
+import           Data.Aeson.Generic.DerivingVia
+import           Test.QuickCheck
+import           Test.QuickCheck.Checkers (EqProp)
+--------------------------------------------------------------------------------
+import           Xanthous.Data (Positioned(..), positioned)
+import           Xanthous.Util.QuickCheck
+import           Xanthous.Game.State
+import           Xanthous.Entities.Item
+import           Xanthous.Entities.RawTypes (WieldableItem, wieldable)
+import           Xanthous.Util (removeFirst, EqEqProp(..))
+--------------------------------------------------------------------------------
+
+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
+
+
+nothingWielded :: Wielded
+nothingWielded = Hands Nothing Nothing
+
+hands :: Prism' Wielded (Maybe WieldedItem, Maybe WieldedItem)
+hands = prism' (uncurry Hands) $ \case
+  Hands l r -> Just (l, r)
+  _ -> Nothing
+
+leftHand :: Traversal' Wielded (Maybe WieldedItem)
+leftHand = hands . _1
+
+inLeftHand :: WieldedItem -> Wielded
+inLeftHand wi = Hands (Just wi) Nothing
+
+rightHand :: Traversal' Wielded (Maybe WieldedItem)
+rightHand = hands . _2
+
+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 Hand
+  = LeftHand
+  | RightHand
+  | BothHands
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary Hand
+
+itemsInHand :: Hand -> Wielded -> [WieldedItem]
+itemsInHand LeftHand (DoubleHanded wi) = [wi]
+itemsInHand LeftHand (Hands lh _) = toList lh
+itemsInHand RightHand (DoubleHanded wi) = [wi]
+itemsInHand RightHand (Hands _ rh) = toList rh
+itemsInHand BothHands (DoubleHanded wi) = [wi]
+itemsInHand BothHands (Hands lh rh) = toList lh <> toList rh
+
+inHand :: Hand -> WieldedItem -> Wielded
+inHand LeftHand = inLeftHand
+inHand RightHand = inRightHand
+inHand BothHands = review doubleHanded
+
+wieldInHand :: Hand -> WieldedItem -> Wielded -> ([WieldedItem], Wielded)
+wieldInHand hand item w = (itemsInHand hand w, doWield)
+  where
+    doWield = case (hand, w) of
+      (LeftHand, Hands _ r) -> Hands (Just item) r
+      (LeftHand, DoubleHanded _) -> inLeftHand item
+      (RightHand, Hands l _) -> Hands l (Just item)
+      (RightHand, DoubleHanded _) -> inRightHand item
+      (BothHands, _) -> DoubleHanded item
+
+describeHand :: Hand -> Text
+describeHand LeftHand = "your left hand"
+describeHand RightHand = "your right hand"
+describeHand BothHands = "both hands"
+
+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 EqProp via EqEqProp 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
+
+class HasInventory s a | s -> a where
+  inventory :: Lens' s a
+  {-# MINIMAL inventory #-}
+
+-- | Representation for where in the inventory an item might be
+data InventoryPosition
+  = Backpack
+  | InHand Hand
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary InventoryPosition
+
+-- | Return a human-readable description of the given 'InventoryPosition'
+describeInventoryPosition :: InventoryPosition -> Text
+describeInventoryPosition Backpack       = "In backpack"
+describeInventoryPosition (InHand hand)  = "Wielded, in " <> describeHand hand
+
+-- | Given a position in the inventory, return a traversal on the inventory over
+-- all the items in that position
+inventoryPosition :: InventoryPosition -> Traversal' Inventory Item
+inventoryPosition Backpack = backpack . traversed
+inventoryPosition (InHand LeftHand) = wielded . leftHand . _Just . wieldedItem
+inventoryPosition (InHand RightHand) = wielded . leftHand . _Just . wieldedItem
+inventoryPosition (InHand BothHands) = wielded . doubleHanded . wieldedItem
+
+-- | A fold over all the items in the inventory accompanied by their position in
+-- the inventory
+--
+-- Invariant: This will return items in the same order as 'items'
+itemsWithPosition :: Fold Inventory (InventoryPosition, Item)
+itemsWithPosition = folding $ (<>) <$> backpackItems <*> handItems
+  where
+    backpackItems = toListOf $ backpack . folded . to (Backpack ,)
+    handItems inv = case inv ^. wielded of
+       DoubleHanded i -> pure (InHand BothHands, i ^. wieldedItem)
+       Hands l r -> (l ^.. folded . wieldedItem . to (InHand LeftHand ,))
+                 <> (r ^.. folded . wieldedItem . to (InHand RightHand ,))
+
+-- | Remove the first item equal to 'Item' from the given position in the
+-- inventory
+removeItemFromPosition :: InventoryPosition -> Item -> Inventory -> Inventory
+removeItemFromPosition Backpack item inv
+  = inv & backpack %~ removeFirst (== item)
+removeItemFromPosition (InHand LeftHand) item inv
+  = inv & wielded . leftHand %~ filter ((/= item) . view wieldedItem)
+removeItemFromPosition (InHand RightHand) item inv
+  = inv & wielded . rightHand %~ filter ((/= item) . view wieldedItem)
+removeItemFromPosition (InHand BothHands) item inv
+  | has (wielded . doubleHanded . wieldedItem . filtered (== item)) inv
+  = inv & wielded .~ nothingWielded
+  | otherwise
+  = inv
diff --git a/users/aspen/xanthous/src/Xanthous/Entities/Creature.hs b/users/aspen/xanthous/src/Xanthous/Entities/Creature.hs
new file mode 100644
index 000000000000..3ea610795e98
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Entities/Creature.hs
@@ -0,0 +1,88 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Creature
+  ( -- * Creature
+    Creature(..)
+    -- ** Lenses
+  , creatureType
+  , hitpoints
+  , hippocampus
+  , inventory
+
+    -- ** Creature functions
+  , damage
+  , isDead
+  , visionRadius
+
+    -- * Hippocampus
+  , Hippocampus(..)
+    -- ** Lenses
+  , destination
+    -- ** Destination
+  , Destination(..)
+  , destinationFromPos
+    -- *** Lenses
+  , destinationPosition
+  , destinationProgress
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Test.QuickCheck
+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
+import           Xanthous.Util.QuickCheck (GenericArbitrary(..))
+import           Xanthous.Entities.Common (Inventory, HasInventory(..))
+--------------------------------------------------------------------------------
+
+data Creature = Creature
+  { _creatureType   :: !CreatureType
+  , _hitpoints      :: !Hitpoints
+  , _hippocampus    :: !Hippocampus
+  , _inventory      :: !Inventory
+  }
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Draw via DrawRawCharPriority "_creatureType" 1000 Creature
+  deriving Arbitrary via GenericArbitrary Creature
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       Creature
+makeFieldsNoPrefix ''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
+
+--------------------------------------------------------------------------------
+
+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/aspen/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs b/users/aspen/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs
new file mode 100644
index 000000000000..d13ea8055c2b
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs
@@ -0,0 +1,71 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Creature.Hippocampus
+  (-- * Hippocampus
+    Hippocampus(..)
+  , initialHippocampus
+    -- ** Lenses
+  , destination
+  , greetedCharacter
+    -- ** 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
+--------------------------------------------------------------------------------
+
+
+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)
+  , -- | Has this creature greeted the character in any way yet?
+    --
+    -- Some creature types ignore this field
+    _greetedCharacter :: !Bool
+  }
+  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
+  { _destination      = Nothing
+  , _greetedCharacter = False
+  }
diff --git a/users/aspen/xanthous/src/Xanthous/Entities/Draw/Util.hs b/users/aspen/xanthous/src/Xanthous/Entities/Draw/Util.hs
new file mode 100644
index 000000000000..aa6c5fa4fc47
--- /dev/null
+++ b/users/aspen/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/aspen/xanthous/src/Xanthous/Entities/Entities.hs b/users/aspen/xanthous/src/Xanthous/Entities/Entities.hs
new file mode 100644
index 000000000000..a0c037a1b4ed
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Entities/Entities.hs
@@ -0,0 +1,63 @@
+{-# 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.Entities.Marker
+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
+    , SomeEntity <$> arbitrary @Marker
+    ]
+
+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"
+      "Marker" -> SomeEntity @Marker <$> 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/aspen/xanthous/src/Xanthous/Entities/Entities.hs-boot b/users/aspen/xanthous/src/Xanthous/Entities/Entities.hs-boot
new file mode 100644
index 000000000000..519a862c6a5a
--- /dev/null
+++ b/users/aspen/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/aspen/xanthous/src/Xanthous/Entities/Environment.hs b/users/aspen/xanthous/src/Xanthous/Entities/Environment.hs
new file mode 100644
index 000000000000..b45a91eabed2
--- /dev/null
+++ b/users/aspen/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/aspen/xanthous/src/Xanthous/Entities/Item.hs b/users/aspen/xanthous/src/Xanthous/Entities/Item.hs
new file mode 100644
index 000000000000..eadd62569663
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Entities/Item.hs
@@ -0,0 +1,76 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE RecordWildCards #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Item
+  ( Item(..)
+  , itemType
+  , density
+  , volume
+  , newWithType
+  , isEdible
+  , weight
+  , fullDescription
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+import           Test.QuickCheck (Arbitrary, CoArbitrary, Function)
+import           Data.Aeson (ToJSON, FromJSON)
+import           Data.Aeson.Generic.DerivingVia
+import           Control.Monad.Random (MonadRandom)
+--------------------------------------------------------------------------------
+import           Xanthous.Entities.RawTypes (ItemType)
+import qualified Xanthous.Entities.RawTypes as Raw
+import           Xanthous.Game.State
+import           Xanthous.Data (Grams, Per, Cubic, Meters, (|*|))
+import           Xanthous.Util.QuickCheck (GenericArbitrary(GenericArbitrary))
+import           Xanthous.Random (choose, FiniteInterval(..))
+--------------------------------------------------------------------------------
+
+data Item = Item
+  { _itemType :: ItemType
+  , _density  :: Grams `Per` Cubic Meters
+  , _volume   :: Cubic Meters
+  }
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Draw via DrawRawChar "_itemType" Item
+  deriving Arbitrary via GenericArbitrary Item
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       Item
+makeLenses ''Item
+
+-- deriving via (Brainless Item) instance Brain Item
+instance Brain Item where step = brainVia Brainless
+
+instance Entity Item where
+  description = view $ itemType . Raw.description
+  entityChar = view $ itemType . Raw.char
+  entityCollision = const Nothing
+
+newWithType :: MonadRandom m => ItemType -> m Item
+newWithType _itemType = do
+  _density <- choose . FiniteInterval $ _itemType ^. Raw.density
+  _volume  <- choose . FiniteInterval $ _itemType ^. Raw.volume
+  pure Item {..}
+
+isEdible :: Item -> Bool
+isEdible = Raw.isEdible . view itemType
+
+-- | The weight of this item, calculated by multiplying its volume by the
+-- density of its material
+weight :: Item -> Grams
+weight item = (item ^. density) |*| (item ^. volume)
+
+-- | Describe the item in full detail
+fullDescription :: Item -> Text
+fullDescription item = unlines
+  [ item ^. itemType . Raw.description
+  , ""
+  , item ^. itemType . Raw.longDescription
+  , ""
+  , "volume: " <> tshow (item ^. volume)
+  , "density: " <> tshow (item ^. density)
+  , "weight: " <> tshow (weight item)
+  ]
diff --git a/users/aspen/xanthous/src/Xanthous/Entities/Marker.hs b/users/aspen/xanthous/src/Xanthous/Entities/Marker.hs
new file mode 100644
index 000000000000..14d02872ed4e
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Entities/Marker.hs
@@ -0,0 +1,41 @@
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Marker ( Marker(..) ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Data.Aeson
+import           Test.QuickCheck
+import qualified Graphics.Vty.Attributes as Vty
+import qualified Graphics.Vty.Image as Vty
+import           Brick.Widgets.Core (raw)
+--------------------------------------------------------------------------------
+import           Xanthous.Game.State
+import           Xanthous.Data.Entities (EntityAttributes(..))
+--------------------------------------------------------------------------------
+
+-- | Mark on the map - for use in debugging / development only.
+newtype Marker = Marker Text
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (Semigroup, Monoid, ToJSON, FromJSON, Arbitrary) via Text
+
+instance Brain Marker where step = brainVia Brainless
+
+instance Entity Marker where
+  entityAttributes = const EntityAttributes
+    { _blocksVision = False
+    , _blocksObject = False
+    , _collision = Stop
+    }
+  description (Marker m) = "[M] " <> m
+  entityChar = const $ "X" & style .~ markerStyle
+  entityCollision = const Nothing
+
+instance Draw Marker where
+  draw = const . raw $ Vty.char markerStyle 'X'
+  drawPriority = const maxBound
+
+markerStyle :: Vty.Attr
+markerStyle = Vty.defAttr
+  `Vty.withForeColor` Vty.red
+  `Vty.withBackColor` Vty.black
diff --git a/users/aspen/xanthous/src/Xanthous/Entities/RawTypes.hs b/users/aspen/xanthous/src/Xanthous/Entities/RawTypes.hs
new file mode 100644
index 000000000000..a7021d76cf65
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Entities/RawTypes.hs
@@ -0,0 +1,286 @@
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.RawTypes
+  (
+    EntityRaw(..)
+  , _Creature
+  , _Item
+
+    -- * Creatures
+  , CreatureType(..)
+  , hostile
+    -- ** Generation parameters
+  , CreatureGenerateParams(..)
+  , canGenerate
+    -- ** Language
+  , LanguageName(..)
+  , getLanguage
+    -- ** Attacks
+  , Attack(..)
+
+    -- * Items
+  , ItemType(..)
+    -- ** Item sub-types
+    -- *** Edible
+  , EdibleItem(..)
+  , isEdible
+    -- *** Wieldable
+  , WieldableItem(..)
+  , isWieldable
+
+    -- * Lens classes
+  , HasAttackMessage(..)
+  , HasAttacks(..)
+  , HasChance(..)
+  , HasChar(..)
+  , HasCreatureAttackMessage(..)
+  , HasDamage(..)
+  , HasDensity(..)
+  , HasDescription(..)
+  , HasEatMessage(..)
+  , HasEdible(..)
+  , HasEntityName(..)
+  , HasEquippedItem(..)
+  , HasFriendly(..)
+  , HasGenerateParams(..)
+  , HasHitpointsHealed(..)
+  , HasLanguage(..)
+  , HasLevelRange(..)
+  , HasLongDescription(..)
+  , HasMaxHitpoints(..)
+  , HasName(..)
+  , HasSayVerb(..)
+  , HasSpeed(..)
+  , HasVolume(..)
+  , HasWieldable(..)
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+import           Test.QuickCheck
+import           Data.Aeson.Generic.DerivingVia
+import           Data.Aeson (ToJSON, FromJSON)
+import           Data.Interval (Interval, lowerBound', upperBound')
+import qualified Data.Interval as Interval
+--------------------------------------------------------------------------------
+import           Xanthous.Messages (Message(..))
+import           Xanthous.Data (TicksPerTile, Hitpoints, Per, Grams, Cubic, Meters)
+import           Xanthous.Data.EntityChar
+import           Xanthous.Util.QuickCheck
+import           Xanthous.Generators.Speech (Language, gormlak, english)
+import           Xanthous.Orphans ()
+import           Xanthous.Util (EqProp, EqEqProp(..))
+--------------------------------------------------------------------------------
+
+-- | Identifiers for languages that creatures can speak.
+--
+-- Non-verbal or non-sentient creatures have Nothing as their language
+--
+-- At some point, we will likely want to make languages be defined in data files
+-- somewhere, and reference them that way instead.
+data LanguageName = Gormlak | English
+  deriving stock (Show, Eq, Ord, Generic, Enum, Bounded)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary LanguageName
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ AllNullaryToStringTag 'True ]
+                       LanguageName
+
+-- | Resolve a 'LanguageName' into an actual 'Language'
+getLanguage :: LanguageName -> Language
+getLanguage Gormlak = gormlak
+getLanguage English = english
+
+-- | Natural attacks for creature types
+data Attack = Attack
+  { -- | the @{{creature}}@ @{{description}}@
+    _description :: !Message
+    -- | Damage dealt
+  , _damage      :: !Hitpoints
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary Attack
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1]
+                        , OmitNothingFields 'True
+                        ]
+                       Attack
+makeFieldsNoPrefix ''Attack
+
+-- | Description for generating an item equipped to a creature
+data CreatureEquippedItem = CreatureEquippedItem
+  { -- | Name of the entity type to generate
+    _entityName :: !Text
+    -- | Chance of generating the item when generating the creature
+    --
+    -- A chance of 1.0 will always generate the item
+  , _chance :: !Double
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary CreatureEquippedItem
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1]
+                        , OmitNothingFields 'True
+                        ]
+                       CreatureEquippedItem
+makeFieldsNoPrefix ''CreatureEquippedItem
+
+
+data CreatureGenerateParams = CreatureGenerateParams
+  { -- | Range of dungeon levels at which to generate this creature
+    _levelRange :: !(Interval Word)
+    -- | Item equipped to the creature
+  , _equippedItem :: !(Maybe CreatureEquippedItem)
+  }
+  deriving stock (Eq, Show, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary CreatureGenerateParams
+  deriving EqProp via EqEqProp CreatureGenerateParams
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       CreatureGenerateParams
+makeFieldsNoPrefix ''CreatureGenerateParams
+
+instance Ord CreatureGenerateParams where
+  compare
+    = (compare `on` lowerBound' . _levelRange)
+    <> (compare `on` upperBound' . _levelRange)
+    <> (compare `on` _equippedItem)
+
+-- | Can a creature with these generate params be generated on this level?
+canGenerate
+  :: Word -- ^ Level number
+  -> CreatureGenerateParams
+  -> Bool
+canGenerate levelNumber gps = Interval.member levelNumber $ gps ^. levelRange
+
+data CreatureType = CreatureType
+  { _name           :: !Text
+  , _description    :: !Text
+  , _char           :: !EntityChar
+  , _maxHitpoints   :: !Hitpoints
+  , _friendly       :: !Bool
+  , _speed          :: !TicksPerTile
+  , _language       :: !(Maybe LanguageName)
+  , -- | The verb, in present tense, for when the creature says something
+    _sayVerb        :: !(Maybe Text)
+  , -- | The creature's natural attacks
+    _attacks        :: !(NonNull (Vector Attack))
+    -- | Parameters for generating the creature in levels
+  , _generateParams :: !(Maybe CreatureGenerateParams)
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary CreatureType
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1]
+                        , OmitNothingFields 'True
+                        ]
+                       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
+    -- | Message to use when the character is using this item to attack a
+    --  creature.
+    --
+    -- Grammatically, this should be of the form "slash at the
+    -- {{creature.creatureType.name}} with your dagger"
+    --
+    -- = Parameters
+    --
+    -- [@creature@ (type: 'Creature')] The creature being attacked
+  , _attackMessage :: !(Maybe Message)
+    -- | Message to use when a creature is using this item to attack the
+    -- character.
+    --
+    -- Grammatically, should be of the form "The creature slashes you with its
+    -- dagger".
+    --
+    -- = Parameters
+    --
+    -- [@creature@ (type: 'Creature')] The creature doing the attacking
+    -- [@item@ (type: 'Item')] The item itself
+  , _creatureAttackMessage :: !(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
+  , _density         :: !(Interval (Grams `Per` Cubic Meters))
+  , _volume          :: !(Interval (Cubic Meters))
+  , _edible          :: !(Maybe EdibleItem)
+  , _wieldable       :: !(Maybe WieldableItem)
+  }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary ItemType
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       ItemType
+makeFieldsNoPrefix ''ItemType
+
+instance Ord ItemType where
+  compare x y
+    = compareOf name x y
+    <> compareOf description x y
+    <> compareOf longDescription x y
+    <> compareOf char x y
+    <> compareOf (density . to extractInterval) x y
+    <> compareOf (volume . to extractInterval) x y
+    <> compareOf edible x y
+    <> compareOf wieldable x y
+    where
+      compareOf l = comparing (view l)
+      extractInterval = lowerBound' &&& upperBound'
+
+-- | 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/aspen/xanthous/src/Xanthous/Entities/Raws.hs b/users/aspen/xanthous/src/Xanthous/Entities/Raws.hs
new file mode 100644
index 000000000000..10f0d831934e
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Entities/Raws.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Raws
+  ( raws
+  , raw
+  , RawType(..)
+  , rawsWithType
+  ) where
+--------------------------------------------------------------------------------
+import           Data.FileEmbed
+import qualified Data.Yaml as Yaml
+import           Xanthous.Prelude
+import           System.FilePath.Posix
+--------------------------------------------------------------------------------
+import           Xanthous.Entities.RawTypes
+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
+
+--------------------------------------------------------------------------------
diff --git a/users/aspen/xanthous/src/Xanthous/Entities/Raws/broken-dagger.yaml b/users/aspen/xanthous/src/Xanthous/Entities/Raws/broken-dagger.yaml
new file mode 100644
index 000000000000..12c76fc14b2e
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Entities/Raws/broken-dagger.yaml
@@ -0,0 +1,24 @@
+Item:
+  name: broken dagger
+  description: a short, broken dagger
+  longDescription: A short dagger with a twisted, chipped blade
+  char:
+    char: †
+    style:
+      foreground: black
+  wieldable:
+    damage: 3
+    attackMessage:
+      - slash at the {{creature.creatureType.name}} with your dagger
+      - stab the {{creature.creatureType.name}} with your dagger
+    creatureAttackMessage:
+      - The {{creature.creatureType.name}} slashes at you with its dagger.
+      - The {{creature.creatureType.name}} stabs you with its dagger.
+  # Just the steel, not the handle, for now
+  density: [7750 , 8050000]
+  # 15cm – 45cm
+  # ×
+  # 2cm – 3cm
+  # ×
+  # .5cm – 1cm
+  volume: [0.15, 1.35]
diff --git a/users/aspen/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml b/users/aspen/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml
new file mode 100644
index 000000000000..ad3d9cb147da
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml
@@ -0,0 +1,20 @@
+Creature:
+  name: gormlak
+  description: a gormlak
+  longDescription: |
+    A chittering imp-like creature with bright yellow horns and sharp claws. It
+    adores shiny objects and gathers in swarms.
+  char:
+    char: g
+    style:
+      foreground: red
+  maxHitpoints: 5
+  speed: 125
+  friendly: false
+  language: Gormlak
+  sayVerb: yells
+  attacks:
+  - description:
+      - claws you
+      - slashes you with its claws
+    damage: 1
diff --git a/users/aspen/xanthous/src/Xanthous/Entities/Raws/husk.yaml b/users/aspen/xanthous/src/Xanthous/Entities/Raws/husk.yaml
new file mode 100644
index 000000000000..cdfcde616d21
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Entities/Raws/husk.yaml
@@ -0,0 +1,26 @@
+Creature:
+  name: husk
+  description: an empty husk of some humanoid creature
+  longDescription: |
+    An empty husk of a humanoid creature. All semblance of sentience has long
+    left its eyes; instead it shambles about aimlessly, always hungering for the
+    warmth of life.
+  char:
+    char: h
+    style:
+      foreground: black
+  maxHitpoints: 6
+  speed: 110
+  friendly: false
+  attacks:
+  - description:
+      - swings its arms at you
+      - elbows you
+    damage: 1
+  - description: kicks you
+    damage: 2
+  generateParams:
+    levelRange: [1, PosInf]
+    equippedItem:
+      entityName: broken-dagger
+      chance: 0.9
diff --git a/users/aspen/xanthous/src/Xanthous/Entities/Raws/noodles.yaml b/users/aspen/xanthous/src/Xanthous/Entities/Raws/noodles.yaml
new file mode 100644
index 000000000000..c0501a18a8e0
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Entities/Raws/noodles.yaml
@@ -0,0 +1,14 @@
+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!
+  density: 500000
+  volume: 0.001
diff --git a/users/aspen/xanthous/src/Xanthous/Entities/Raws/ooze.yaml b/users/aspen/xanthous/src/Xanthous/Entities/Raws/ooze.yaml
new file mode 100644
index 000000000000..fe427c94abf7
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Entities/Raws/ooze.yaml
@@ -0,0 +1,15 @@
+Creature:
+  name: ooze
+  description: an ooze
+  longDescription: |
+    A jiggling, amorphous, bright green caustic blob
+  char:
+    char: o
+    style:
+      foreground: green
+  maxHitpoints: 3
+  speed: 100
+  friendly: false
+  attacks:
+  - description: slams into you
+    damage: 1
diff --git a/users/aspen/xanthous/src/Xanthous/Entities/Raws/rock.yaml b/users/aspen/xanthous/src/Xanthous/Entities/Raws/rock.yaml
new file mode 100644
index 000000000000..3f4e133fe286
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Entities/Raws/rock.yaml
@@ -0,0 +1,10 @@
+Item:
+  name: rock
+  description: a rock
+  longDescription: a medium-sized rock made out of some unknown stone
+  char: .
+  wieldable:
+    damage: 1
+    attackMessage: hit the {{creature.creatureType.name}} in the head with your rock
+  density: [ 1500000, 2500000 ]
+  volume: [ 0.000125, 0.001 ]
diff --git a/users/aspen/xanthous/src/Xanthous/Entities/Raws/stick.yaml b/users/aspen/xanthous/src/Xanthous/Entities/Raws/stick.yaml
new file mode 100644
index 000000000000..7f9e1faffedb
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Entities/Raws/stick.yaml
@@ -0,0 +1,22 @@
+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:
+      - bonk the {{creature.creatureType.name}} over the head with your stick
+      - bash the {{creature.creatureType.name}} on the noggin with your stick
+      - whack the {{creature.creatureType.name}} with your stick
+    creatureAttackMessage:
+      - The {{creature.creatureType.name}} bonks you over the head with its stick.
+      - The {{creature.creatureType.name}} bashes you on the noggin with its stick.
+      - The {{creature.creatureType.name}} whacks you with its stick.
+  # https://www.sciencedirect.com/topics/agricultural-and-biological-sciences/wood-density
+  # it's a hard stick. so it's dense wood.
+  density: 890000 # g/m³
+  volume: [ 0.003, 0.006 ] # ≈3.5 cm radius × ≈1m length
diff --git a/users/aspen/xanthous/src/Xanthous/Game.hs b/users/aspen/xanthous/src/Xanthous/Game.hs
new file mode 100644
index 000000000000..89c23f0de850
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Game.hs
@@ -0,0 +1,73 @@
+module Xanthous.Game
+  ( GameState(..)
+  , levels
+  , entities
+  , revealedPositions
+  , messageHistory
+  , randomGen
+  , promptState
+  , GamePromptState(..)
+
+  , getInitialState
+  , initialStateFromSeed
+
+  , positionedCharacter
+  , character
+  , characterPosition
+  , updateCharacterVision
+  , characterVisiblePositions
+  , entitiesAtCharacter
+  , revealedEntitiesAtPosition
+
+    -- * 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/aspen/xanthous/src/Xanthous/Game/Arbitrary.hs b/users/aspen/xanthous/src/Xanthous/Game/Arbitrary.hs
new file mode 100644
index 000000000000..679bfe54597f
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Game/Arbitrary.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE RecordWildCards #-}
+--------------------------------------------------------------------------------
+module Xanthous.Game.Arbitrary where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding (foldMap)
+--------------------------------------------------------------------------------
+import           Test.QuickCheck
+import           System.Random
+import           Data.Foldable (foldMap)
+--------------------------------------------------------------------------------
+import           Xanthous.Data.Levels
+import qualified Xanthous.Data.EntityMap as EntityMap
+import           Xanthous.Entities.Entities ()
+import           Xanthous.Entities.Character
+import           Xanthous.Game.State
+import           Xanthous.Orphans ()
+import           Xanthous.Util.QuickCheck (GenericArbitrary(..))
+--------------------------------------------------------------------------------
+
+deriving via GenericArbitrary GameLevel instance Arbitrary GameLevel
+
+instance Arbitrary GameState where
+  arbitrary = do
+    chr <- arbitrary @Character
+    _upStaircasePosition <- arbitrary
+    _messageHistory <- arbitrary
+    levs <- arbitrary @(Levels GameLevel)
+    _levelRevealedPositions <-
+      fmap setFromList
+      . sublistOf
+      . foldMap (EntityMap.positions . _levelEntities)
+      $ levs
+    let (_characterEntityID, _levelEntities) =
+          EntityMap.insertAtReturningID _upStaircasePosition (SomeEntity chr)
+          $ levs ^. current . levelEntities
+        _levels = levs & current .~ GameLevel {..}
+    _randomGen <- mkStdGen <$> arbitrary
+    let _promptState = NoPrompt -- TODO
+    _activePanel <- arbitrary
+    _debugState <- arbitrary
+    let _autocommand = NoAutocommand
+    _memo <- arbitrary
+    _savefile <- arbitrary
+    pure $ GameState {..}
+
+
+instance CoArbitrary GameLevel
+instance Function GameLevel
+instance CoArbitrary GameState
+instance Function GameState
diff --git a/users/aspen/xanthous/src/Xanthous/Game/Draw.hs b/users/aspen/xanthous/src/Xanthous/Game/Draw.hs
new file mode 100644
index 000000000000..291dfd8b5e46
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Game/Draw.hs
@@ -0,0 +1,224 @@
+--------------------------------------------------------------------------------
+module Xanthous.Game.Draw
+  ( drawGame
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Brick hiding (loc, on)
+import           Brick.Widgets.Border
+import           Brick.Widgets.Border.Style
+import           Brick.Widgets.Edit
+import           Control.Monad.State.Lazy (evalState)
+import           Control.Monad.State.Class ( get, MonadState, gets )
+--------------------------------------------------------------------------------
+import           Xanthous.Data
+import           Xanthous.Data.App (ResourceName, Panel(..))
+import qualified Xanthous.Data.App as Resource
+import qualified Xanthous.Data.EntityMap as EntityMap
+import           Xanthous.Game.State
+import           Xanthous.Entities.Common (Wielded(..), wielded, backpack)
+import           Xanthous.Entities.Character
+import           Xanthous.Entities.Item (Item)
+import           Xanthous.Game
+                 ( characterPosition
+                 , character
+                 , revealedEntitiesAtPosition
+                 )
+import           Xanthous.Game.Prompt
+import           Xanthous.Orphans ()
+import Brick.Widgets.Center (hCenter)
+import Xanthous.Command (Keybinding (..), keybindings, Command, commandIsHidden)
+import Graphics.Vty.Input.Events (Modifier(..))
+import Graphics.Vty.Input (Key(..))
+import Brick.Widgets.Table
+--------------------------------------------------------------------------------
+
+cursorPosition :: GameState -> Widget ResourceName -> Widget ResourceName
+cursorPosition game
+  | WaitingPrompt _ (Prompt _ _ (preview promptStatePosition -> Just pos) _ _)
+    <- game ^. promptState
+  = showCursor Resource.Prompt (pos ^. loc)
+  | otherwise
+  = showCursor Resource.Character (game ^. characterPosition . loc)
+
+drawMessages :: MessageHistory -> Widget ResourceName
+drawMessages = txtWrap . (<> " ") . unwords . reverse . oextract
+
+drawPromptState :: GamePromptState m -> Widget ResourceName
+drawPromptState NoPrompt = emptyWidget
+drawPromptState (WaitingPrompt msg (Prompt _ pt ps pri _)) =
+  case (pt, ps, pri) of
+    (SStringPrompt, StringPromptState edit, mDef) ->
+      txt msg
+      <+> txt (maybe "" (\def -> "(default: " <> def <> ") ") mDef)
+      <+> renderEditor (txt . fold) True edit
+    (SDirectionPrompt, DirectionPromptState, _) -> txtWrap msg
+    (SMenu, _, menuItems) ->
+      txtWrap msg
+      <=> foldl' (<=>) emptyWidget (map drawMenuItem $ itoList menuItems)
+    _ -> txtWrap msg
+  where
+    drawMenuItem (chr, MenuOption m _) =
+      str ("[" <> pure chr <> "] ") <+> txtWrap m
+
+drawEntities
+  :: forall m. MonadState GameState m
+  => m (Widget ResourceName)
+drawEntities = do
+  allEnts <- use entities
+  let entityPositions = EntityMap.positions allEnts
+      maxY = fromMaybe 0 $ maximumOf (folded . y) entityPositions
+      maxX = fromMaybe 0 $ maximumOf (folded . x) entityPositions
+      rows = traverse mkRow [0..maxY]
+      mkRow rowY = hBox <$> traverse (renderEntityAt . flip Position rowY) [0..maxX]
+      renderEntityAt pos
+        = renderTopEntity pos <$> revealedEntitiesAtPosition pos
+      renderTopEntity pos ents
+        = let neighbors = EntityMap.neighbors pos allEnts
+          in maybe (str " ") (drawWithNeighbors neighbors)
+             $ maximumBy (compare `on` drawPriority)
+             <$> fromNullable ents
+  vBox <$> rows
+
+drawMap :: MonadState GameState m => m (Widget ResourceName)
+drawMap = do
+  cursorPos <- gets cursorPosition
+  viewport Resource.MapViewport Both . cursorPos <$> drawEntities
+
+bullet :: Char
+bullet = '•'
+
+drawInventoryPanel :: GameState -> Widget ResourceName
+drawInventoryPanel game
+  =   drawWielded  (game ^. character . inventory . wielded)
+  <=> drawBackpack (game ^. character . inventory . backpack)
+  where
+    drawWielded (Hands Nothing Nothing) = emptyWidget
+    drawWielded (DoubleHanded i) =
+      txtWrap $ "You are holding " <> description i <> " in both hands"
+    drawWielded (Hands l r) = drawHand "left" l <=> drawHand "right" r
+    drawHand side = maybe emptyWidget $ \i ->
+      txtWrap ( "You are holding "
+              <> description i
+              <> " in your " <> side <> " hand"
+              )
+      <=> txt " "
+
+    drawBackpack :: Vector Item -> Widget ResourceName
+    drawBackpack Empty = txtWrap "Your backpack is empty right now."
+    drawBackpack backpackItems
+      = txtWrap ( "You are currently carrying the following items in your "
+                <> "backpack:")
+        <=> txt " "
+        <=> foldl' (<=>) emptyWidget
+            (map
+              (txtWrap . ((bullet <| " ") <>) . description)
+              backpackItems)
+
+drawHelpPanel :: Widget ResourceName
+drawHelpPanel
+  = txtWrap "To move in a direction or attack, use vi keys (hjklyubn):"
+  <=> txt " "
+  <=> hCenter keyStar
+  <=> txt " "
+  <=> cmds
+  where
+    keyStar
+      =   txt "y k u"
+      <=> txt " \\|/"
+      <=> txt "h-.-l"
+      <=> txt " /|\\"
+      <=> txt "b j n"
+
+    cmds
+      = renderTable
+      . alignRight 0
+      . setDefaultRowAlignment AlignTop
+      . surroundingBorder False
+      . rowBorders False
+      . columnBorders False
+      . table $ help <&> \(key, cmd) -> [ txt $ key <> " : "
+                                       , hLimitPercent 100 $ txtWrap cmd]
+
+    help =
+      extraHelp <>
+      keybindings
+        ^.. ifolded
+          . filtered (not . commandIsHidden)
+          . withIndex
+          . to (bimap displayKeybinding displayCommand)
+    extraHelp
+      = [("Shift-Dir", "Auto-move")]
+
+    displayCommand = tshow @Command
+    displayKeybinding (Keybinding k mods) = foldMap showMod mods <> showKey k
+
+    showMod MCtrl  = "Ctrl-"
+    showMod MShift = "Shift-"
+    showMod MAlt   = "Alt-"
+    showMod MMeta  = "Meta-"
+
+    showKey (KChar c) = pack [c]
+    showKey KEsc = "<Esc>"
+    showKey KBS = "<Backspace>"
+    showKey KEnter = "<Enter>"
+    showKey KLeft = "<Left>"
+    showKey KRight = "<Right>"
+    showKey KUp = "<Up>"
+    showKey KDown = "<Down>"
+    showKey KUpLeft = "<UpLeft>"
+    showKey KUpRight = "<UpRight>"
+    showKey KDownLeft = "<DownLeft>"
+    showKey KDownRight = "<DownRight>"
+    showKey KCenter = "<Center>"
+    showKey (KFun n) = "<F" <> tshow n <> ">"
+    showKey KBackTab = "<BackTab>"
+    showKey KPrtScr = "<PrtScr>"
+    showKey KPause = "<Pause>"
+    showKey KIns = "<Ins>"
+    showKey KHome = "<Home>"
+    showKey KPageUp = "<PageUp>"
+    showKey KDel = "<Del>"
+    showKey KEnd = "<End>"
+    showKey KPageDown = "<PageDown>"
+    showKey KBegin = "<Begin>"
+    showKey KMenu = "<Menu>"
+
+drawPanel :: GameState -> Panel -> Widget ResourceName
+drawPanel game panel
+  = border
+  . hLimit 35
+  . viewport (Resource.Panel panel) Vertical
+  $ case panel of
+      HelpPanel -> drawHelpPanel
+      InventoryPanel -> drawInventoryPanel game
+      ItemDescriptionPanel desc -> txtWrap desc
+
+drawCharacterInfo :: Character -> Widget ResourceName
+drawCharacterInfo ch = txt " " <+> charName <+> charHitpoints
+  where
+    charName | Just n <- ch ^. characterName
+             = txt $ n <> " "
+             | otherwise
+             = emptyWidget
+    charHitpoints
+        = txt "Hitpoints: "
+      <+> txt (tshow $ let Hitpoints hp = characterHitpoints ch in hp)
+
+drawGame :: GameState -> [Widget ResourceName]
+drawGame = evalState $ do
+  game <- get
+  drawnMap <- drawMap
+  pure
+    . pure
+    . withBorderStyle unicode
+    $ case game ^. promptState of
+        NoPrompt -> drawMessages (game ^. messageHistory)
+        _ -> emptyWidget
+    <=> drawPromptState (game ^. promptState)
+    <=>
+    (maybe emptyWidget (drawPanel game) (game ^. activePanel)
+    <+> border drawnMap
+    )
+    <=> drawCharacterInfo (game ^. character)
diff --git a/users/aspen/xanthous/src/Xanthous/Game/Env.hs b/users/aspen/xanthous/src/Xanthous/Game/Env.hs
new file mode 100644
index 000000000000..5d7b275c8a0b
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Game/Env.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Game.Env
+  ( Config(..)
+  , defaultConfig
+  , disableSaving
+  , GameEnv(..)
+  , eventChan
+  , config
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Brick.BChan (BChan)
+import Xanthous.Data.App (AppEvent)
+--------------------------------------------------------------------------------
+
+data Config = Config
+  { _disableSaving :: Bool
+  }
+  deriving stock (Generic, Show, Eq)
+makeLenses ''Config
+{-# ANN Config ("HLint: ignore Use newtype instead of data" :: String) #-}
+
+defaultConfig :: Config
+defaultConfig = Config
+  { _disableSaving = False
+  }
+
+--------------------------------------------------------------------------------
+
+data GameEnv = GameEnv
+  { _eventChan :: BChan AppEvent
+  , _config :: Config
+  }
+  deriving stock (Generic)
+makeLenses ''GameEnv
diff --git a/users/aspen/xanthous/src/Xanthous/Game/Lenses.hs b/users/aspen/xanthous/src/Xanthous/Game/Lenses.hs
new file mode 100644
index 000000000000..c692a3b47944
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Game/Lenses.hs
@@ -0,0 +1,178 @@
+{-# LANGUAGE RecordWildCards       #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE AllowAmbiguousTypes   #-}
+--------------------------------------------------------------------------------
+module Xanthous.Game.Lenses
+  ( clearMemo
+  , positionedCharacter
+  , character
+  , characterPosition
+  , updateCharacterVision
+  , characterVisiblePositions
+  , characterVisibleEntities
+  , positionIsCharacterVisible
+  , getInitialState
+  , initialStateFromSeed
+  , entitiesAtCharacter
+  , revealedEntitiesAtPosition
+  , hearingRadius
+
+    -- * Collisions
+  , Collision(..)
+  , entitiesCollision
+  , collisionAt
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           System.Random
+import           Control.Monad.State
+import           Control.Monad.Random (getRandom)
+--------------------------------------------------------------------------------
+import           Xanthous.Game.State
+import qualified Xanthous.Game.Memo as Memo
+import           Xanthous.Data
+import           Xanthous.Data.Levels
+import qualified Xanthous.Data.EntityMap as EntityMap
+import           Xanthous.Data.EntityMap.Graphics
+                 (visiblePositions, visibleEntities)
+import           Xanthous.Data.VectorBag
+import           Xanthous.Entities.Character (Character, mkCharacter)
+import           {-# SOURCE #-} Xanthous.Entities.Entities ()
+import           Xanthous.Game.Memo (emptyMemoState, MemoState)
+import           Xanthous.Data.Memo (fillWithM, Memoized)
+--------------------------------------------------------------------------------
+
+getInitialState :: IO GameState
+getInitialState = initialStateFromSeed <$> getRandom
+
+initialStateFromSeed :: Int -> GameState
+initialStateFromSeed seed =
+  let _randomGen = mkStdGen seed
+      chr = mkCharacter
+      _upStaircasePosition = Position 0 0
+      (_characterEntityID, _levelEntities)
+        = EntityMap.insertAtReturningID
+          _upStaircasePosition
+          (SomeEntity chr)
+          mempty
+      _levelRevealedPositions = mempty
+      level = GameLevel {..}
+      _levels = oneLevel level
+      _messageHistory = mempty
+      _promptState = NoPrompt
+      _activePanel = Nothing
+      _debugState = DebugState
+        { _allRevealed = False
+        }
+      _savefile = Nothing
+      _autocommand = NoAutocommand
+      _memo = emptyMemoState
+  in GameState {..}
+
+clearMemo :: MonadState GameState m => Lens' MemoState (Memoized k v) -> m ()
+clearMemo l = memo %= Memo.clear l
+
+positionedCharacter :: Lens' GameState (Positioned Character)
+positionedCharacter = lens getPositionedCharacter setPositionedCharacter
+  where
+    setPositionedCharacter :: GameState -> Positioned Character -> GameState
+    setPositionedCharacter game chr
+      = game
+      &  entities . at (game ^. characterEntityID)
+      ?~ fmap SomeEntity chr
+
+    getPositionedCharacter :: GameState -> Positioned Character
+    getPositionedCharacter game
+      = over positioned
+        ( fromMaybe (error "Invariant error: Character was not a character!")
+        . downcastEntity
+        )
+      . fromMaybe (error "Invariant error: Character not found!")
+      $ EntityMap.lookupWithPosition
+        (game ^. characterEntityID)
+        (game ^. entities)
+
+
+character :: Lens' GameState Character
+character = positionedCharacter . positioned
+
+characterPosition :: Lens' GameState Position
+characterPosition = positionedCharacter . position
+
+-- TODO make this dynamic
+visionRadius :: Word
+visionRadius = 12
+
+-- TODO make this dynamic
+hearingRadius :: Word
+hearingRadius = 12
+
+-- | Update the revealed entities at the character's position based on their
+-- vision
+updateCharacterVision :: GameState -> GameState
+updateCharacterVision = execState $ do
+  positions <- characterVisiblePositions
+  revealedPositions <>= positions
+
+characterVisiblePositions :: MonadState GameState m => m (Set Position)
+characterVisiblePositions = do
+  charPos <- use characterPosition
+  fillWithM
+    (memo . Memo.characterVisiblePositions)
+    charPos
+    (uses entities $ visiblePositions charPos visionRadius)
+
+characterVisibleEntities :: GameState -> EntityMap.EntityMap SomeEntity
+characterVisibleEntities game =
+  let charPos = game ^. characterPosition
+  in visibleEntities charPos visionRadius $ game ^. entities
+
+positionIsCharacterVisible :: MonadState GameState m => Position -> m Bool
+positionIsCharacterVisible p = (p `elem`) <$> characterVisiblePositions
+-- ^ TODO optimize
+
+entitiesCollision
+  :: ( Functor f
+    , forall xx. MonoFoldable (f xx)
+    , Element (f SomeEntity) ~ SomeEntity
+    , Element (f (Maybe Collision)) ~ Maybe Collision
+    , Show (f (Maybe Collision))
+    , Show (f SomeEntity)
+    )
+  => f SomeEntity
+  -> Maybe Collision
+entitiesCollision = join . maximumMay . fmap entityCollision
+
+collisionAt :: MonadState GameState m => Position -> m (Maybe Collision)
+collisionAt p = uses (entities . EntityMap.atPosition p) entitiesCollision
+
+entitiesAtCharacter :: Lens' GameState (VectorBag SomeEntity)
+entitiesAtCharacter = lens getter setter
+  where
+    getter gs = gs ^. entities . EntityMap.atPosition (gs ^. characterPosition)
+    setter gs ents = gs
+      & entities . EntityMap.atPosition (gs ^. characterPosition) .~ ents
+
+-- | Returns all entities at the given position that are revealed to the
+-- character.
+--
+-- Concretely, this is either entities that are *currently* visible to the
+-- character, or entities, that are immobile and that the character has seen
+-- before
+revealedEntitiesAtPosition
+  :: MonadState GameState m
+  => Position
+  -> m (VectorBag SomeEntity)
+revealedEntitiesAtPosition p = do
+  allRev <- use $ debugState . allRevealed
+  cvps <- characterVisiblePositions
+  entitiesAtPosition <- use $ entities . EntityMap.atPosition p
+  revealed <- use revealedPositions
+  let immobileEntitiesAtPosition = filter (not . entityCanMove) entitiesAtPosition
+  pure $ if | allRev || p `member` cvps
+              -> entitiesAtPosition
+            | p `member` revealed
+              -> immobileEntitiesAtPosition
+            | otherwise
+              -> mempty
diff --git a/users/aspen/xanthous/src/Xanthous/Game/Memo.hs b/users/aspen/xanthous/src/Xanthous/Game/Memo.hs
new file mode 100644
index 000000000000..154063b5dde2
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Game/Memo.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- | Memoized versions of calculations
+--------------------------------------------------------------------------------
+module Xanthous.Game.Memo
+  ( MemoState
+  , emptyMemoState
+  , clear
+    -- ** Memo lenses
+  , characterVisiblePositions
+
+    -- * Memoized values
+  , Memoized(UnMemoized)
+  , memoizeWith
+  , getMemoized
+  , runMemoized
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Data.Aeson (ToJSON, FromJSON)
+import Data.Aeson.Generic.DerivingVia
+import Test.QuickCheck (CoArbitrary, Function, Arbitrary)
+--------------------------------------------------------------------------------
+import Xanthous.Data (Position)
+import Xanthous.Data.Memo
+import Xanthous.Util.QuickCheck (GenericArbitrary(GenericArbitrary))
+--------------------------------------------------------------------------------
+
+-- | Memoized calculations on the game state
+data MemoState = MemoState
+  { -- | Memoized version of 'Xanthous.Game.Lenses.characterVisiblePositions',
+    -- memoized with the position of the character
+    _characterVisiblePositions :: Memoized Position (Set Position)
+  }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary MemoState
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           MemoState
+makeLenses ''MemoState
+
+emptyMemoState :: MemoState
+emptyMemoState = MemoState { _characterVisiblePositions = UnMemoized }
+{-# INLINE emptyMemoState #-}
+
+clear :: ASetter' MemoState (Memoized key val) -> MemoState -> MemoState
+clear = flip set UnMemoized
+{-# INLINE clear #-}
+
+{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-}
diff --git a/users/aspen/xanthous/src/Xanthous/Game/Prompt.hs b/users/aspen/xanthous/src/Xanthous/Game/Prompt.hs
new file mode 100644
index 000000000000..2d6c0a280f41
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Game/Prompt.hs
@@ -0,0 +1,359 @@
+{-# LANGUAGE DeriveFunctor        #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE StandaloneDeriving   #-}
+{-# LANGUAGE GADTs                #-}
+--------------------------------------------------------------------------------
+module Xanthous.Game.Prompt
+  ( PromptType(..)
+  , SPromptType(..)
+  , SingPromptType(..)
+  , PromptCancellable(..)
+  , PromptResult(..)
+  , PromptState(..)
+  , promptStatePosition
+  , MenuOption(..)
+  , mkMenuItems
+  , PromptInput
+  , Prompt(..)
+  , mkPrompt
+  , mkStringPrompt
+  , mkStringPromptWithDefault
+  , mkMenu
+  , mkPointOnMapPrompt
+  , mkFirePrompt
+  , isCancellable
+  , submitPrompt
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Brick.Widgets.Edit (Editor, editorText, getEditContents)
+import           Test.QuickCheck
+import           Test.QuickCheck.Arbitrary.Generic
+--------------------------------------------------------------------------------
+import           Xanthous.Util (smallestNotIn, AlphaChar (..))
+import           Xanthous.Data (Direction, Position, Tiles)
+import           Xanthous.Data.App (ResourceName)
+import qualified Xanthous.Data.App as Resource
+--------------------------------------------------------------------------------
+
+data PromptType where
+  StringPrompt    :: PromptType
+  Confirm         :: PromptType
+  Menu            :: Type -> PromptType
+  DirectionPrompt :: PromptType
+  PointOnMap      :: PromptType
+  -- | Throw an item or fire a projectile weapon. Prompt is to select the
+  -- direction
+  Fire            :: PromptType
+  Continue        :: PromptType
+  deriving stock (Generic)
+
+instance Show PromptType where
+  show StringPrompt = "StringPrompt"
+  show Confirm = "Confirm"
+  show (Menu _) = "Menu"
+  show DirectionPrompt = "DirectionPrompt"
+  show PointOnMap = "PointOnMap"
+  show Continue = "Continue"
+  show Fire = "Fire"
+
+data SPromptType :: PromptType -> Type where
+  SStringPrompt    :: SPromptType 'StringPrompt
+  SConfirm         :: SPromptType 'Confirm
+  SMenu            :: SPromptType ('Menu a)
+  SDirectionPrompt :: SPromptType 'DirectionPrompt
+  SPointOnMap      :: SPromptType 'PointOnMap
+  SContinue        :: SPromptType 'Continue
+  SFire            :: SPromptType 'Fire
+
+instance NFData (SPromptType pt) where
+  rnf SStringPrompt = ()
+  rnf SConfirm = ()
+  rnf SMenu = ()
+  rnf SDirectionPrompt = ()
+  rnf SPointOnMap = ()
+  rnf SContinue = ()
+  rnf SFire = ()
+
+class SingPromptType pt where singPromptType :: SPromptType pt
+instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt
+instance SingPromptType 'Confirm where singPromptType = SConfirm
+instance SingPromptType 'DirectionPrompt where singPromptType = SDirectionPrompt
+instance SingPromptType 'PointOnMap where singPromptType = SPointOnMap
+instance SingPromptType 'Continue where singPromptType = SContinue
+instance SingPromptType 'Fire where singPromptType = SFire
+
+instance Show (SPromptType pt) where
+  show SStringPrompt    = "SStringPrompt"
+  show SConfirm         = "SConfirm"
+  show SMenu            = "SMenu"
+  show SDirectionPrompt = "SDirectionPrompt"
+  show SPointOnMap      = "SPointOnMap"
+  show SContinue        = "SContinue"
+  show SFire            = "SFire"
+
+data PromptCancellable
+  = Cancellable
+  | Uncancellable
+  deriving stock (Show, Eq, Ord, Enum, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+
+instance Arbitrary PromptCancellable where
+  arbitrary = genericArbitrary
+
+data PromptResult (pt :: PromptType) where
+  StringResult     :: Text      -> PromptResult 'StringPrompt
+  ConfirmResult    :: Bool      -> PromptResult 'Confirm
+  MenuResult       :: forall a. a    -> PromptResult ('Menu a)
+  DirectionResult  :: Direction -> PromptResult 'DirectionPrompt
+  PointOnMapResult :: Position  -> PromptResult 'PointOnMap
+  FireResult       :: Position  -> PromptResult 'Fire
+  ContinueResult   ::             PromptResult 'Continue
+
+instance Arbitrary (PromptResult 'StringPrompt) where
+  arbitrary = StringResult <$> arbitrary
+
+instance Arbitrary (PromptResult 'Confirm) where
+  arbitrary = ConfirmResult <$> arbitrary
+
+instance Arbitrary a => Arbitrary (PromptResult ('Menu a)) where
+  arbitrary = MenuResult <$> arbitrary
+
+instance Arbitrary (PromptResult 'DirectionPrompt) where
+  arbitrary = DirectionResult <$> arbitrary
+
+instance Arbitrary (PromptResult 'PointOnMap) where
+  arbitrary = PointOnMapResult <$> arbitrary
+
+instance Arbitrary (PromptResult 'Continue) where
+  arbitrary = pure ContinueResult
+
+instance Arbitrary (PromptResult 'Fire) where
+  arbitrary = FireResult <$> arbitrary
+
+--------------------------------------------------------------------------------
+
+data PromptState pt where
+  StringPromptState
+    :: Editor Text ResourceName     -> PromptState 'StringPrompt
+  DirectionPromptState  ::            PromptState 'DirectionPrompt
+  ContinuePromptState   ::            PromptState 'Continue
+  ConfirmPromptState    ::            PromptState 'Confirm
+  MenuPromptState       :: forall a.       PromptState ('Menu a)
+  PointOnMapPromptState :: Position -> PromptState 'PointOnMap
+  FirePromptState       :: Position -> PromptState 'Fire
+
+instance NFData (PromptState pt) where
+  rnf sps@(StringPromptState ed) = sps `deepseq` ed `deepseq` ()
+  rnf DirectionPromptState = ()
+  rnf ContinuePromptState = ()
+  rnf ConfirmPromptState = ()
+  rnf MenuPromptState = ()
+  rnf pomps@(PointOnMapPromptState pos) = pomps `deepseq` pos `deepseq` ()
+  rnf fps@(FirePromptState pos) = fps `deepseq` pos `deepseq` ()
+
+instance Arbitrary (PromptState 'StringPrompt) where
+  arbitrary = StringPromptState <$> arbitrary
+
+instance Arbitrary (PromptState 'DirectionPrompt) where
+  arbitrary = pure DirectionPromptState
+
+instance Arbitrary (PromptState 'Continue) where
+  arbitrary = pure ContinuePromptState
+
+instance Arbitrary (PromptState ('Menu a)) where
+  arbitrary = pure MenuPromptState
+
+instance Arbitrary (PromptState 'Fire) where
+  arbitrary = FirePromptState <$> arbitrary
+
+instance CoArbitrary (PromptState 'StringPrompt) where
+  coarbitrary (StringPromptState ed) = coarbitrary ed
+
+instance CoArbitrary (PromptState 'DirectionPrompt) where
+  coarbitrary DirectionPromptState = coarbitrary ()
+
+instance CoArbitrary (PromptState 'Continue) where
+  coarbitrary ContinuePromptState = coarbitrary ()
+
+instance CoArbitrary (PromptState ('Menu a)) where
+  coarbitrary MenuPromptState = coarbitrary ()
+
+instance CoArbitrary (PromptState 'Fire) where
+  coarbitrary (FirePromptState pos) = coarbitrary pos
+
+deriving stock instance Show (PromptState pt)
+
+-- | Traversal over the position for the prompt types with positions in their
+-- prompt state (currently 'Fire' and 'PointOnMap')
+promptStatePosition :: forall pt. Traversal' (PromptState pt) Position
+promptStatePosition _ ps@(StringPromptState _) = pure ps
+promptStatePosition _ DirectionPromptState = pure DirectionPromptState
+promptStatePosition _ ContinuePromptState = pure ContinuePromptState
+promptStatePosition _ ConfirmPromptState = pure ConfirmPromptState
+promptStatePosition _ MenuPromptState = pure MenuPromptState
+promptStatePosition f (PointOnMapPromptState p) = PointOnMapPromptState <$> f p
+promptStatePosition f (FirePromptState p) = FirePromptState <$> f p
+
+data MenuOption a = MenuOption Text a
+  deriving stock (Eq, Generic, Functor)
+  deriving anyclass (NFData, CoArbitrary, Function)
+
+instance Comonad MenuOption where
+  extract (MenuOption _ x) = x
+  extend cok mo@(MenuOption text _) = MenuOption text (cok mo)
+
+mkMenuItems :: (MonoFoldable f, Element f ~ (Char, MenuOption a))
+            => f
+            -> Map Char (MenuOption a)
+mkMenuItems = flip foldl' mempty $ \items (chr, option) ->
+  let chr' = if has (ix chr) items
+             then getAlphaChar . smallestNotIn . map AlphaChar $ keys items
+             else chr
+  in items & at chr' ?~ option
+
+instance Show (MenuOption a) where
+  show (MenuOption m _) = show m
+
+type family PromptInput (pt :: PromptType) :: Type where
+  PromptInput ('Menu a)     = Map Char (MenuOption a)
+  PromptInput 'PointOnMap   = Position -- Character pos
+  PromptInput 'Fire         = (Position, Tiles) -- Nearest enemy, range
+  PromptInput 'StringPrompt = Maybe Text -- Default value
+  PromptInput _ = ()
+
+data Prompt (m :: Type -> Type) where
+  Prompt
+    :: forall (pt :: PromptType)
+        (m :: Type -> Type).
+      PromptCancellable
+    -> SPromptType pt
+    -> PromptState pt
+    -> PromptInput pt
+    -> (PromptResult pt -> m ())
+    -> Prompt m
+
+instance Show (Prompt m) where
+  show (Prompt c pt ps pri _)
+    = "(Prompt "
+    <> show c <> " "
+    <> show pt <> " "
+    <> show ps <> " "
+    <> showPri
+    <> " <function>)"
+    where showPri = case pt of
+            SMenu -> show pri
+            _ -> "()"
+
+instance NFData (Prompt m) where
+  rnf (Prompt c SMenu ps pri cb)
+            = c
+    `deepseq` ps
+    `deepseq` pri
+    `seq` cb
+    `seq` ()
+  rnf (Prompt c spt ps pri cb)
+            = c
+    `deepseq` spt
+    `deepseq` ps
+    `deepseq` pri
+    `seq` cb
+    `seq` ()
+
+instance CoArbitrary (m ()) => CoArbitrary (Prompt m) where
+  coarbitrary (Prompt c SStringPrompt ps pri cb) =
+    variant @Int 1 . coarbitrary (c, ps, pri, cb)
+  coarbitrary (Prompt c SConfirm _ pri cb) = -- TODO fill in prompt state
+    variant @Int 2 . coarbitrary (c, pri, cb)
+  coarbitrary (Prompt c SMenu _ps _pri _cb) =
+    variant @Int 3 . coarbitrary c {-, ps, pri, cb -}
+  coarbitrary (Prompt c SDirectionPrompt ps pri cb) =
+    variant @Int 4 . coarbitrary (c, ps, pri, cb)
+  coarbitrary (Prompt c SPointOnMap _ pri cb) = -- TODO fill in prompt state
+    variant @Int 5 . coarbitrary (c, pri, cb)
+  coarbitrary (Prompt c SContinue ps pri cb) =
+    variant @Int 6 . coarbitrary (c, ps, pri, cb)
+  coarbitrary (Prompt c SFire ps pri cb) =
+    variant @Int 7 . coarbitrary (c, ps, pri, cb)
+
+-- instance Function (Prompt m) where
+--   function = functionMap toTuple _fromTuple
+--     where
+--       toTuple (Prompt c pt ps pri cb) = (c, pt, ps, pri, cb)
+
+
+mkPrompt
+  :: (PromptInput pt ~ ())
+  => PromptCancellable       -- ^ Is the prompt cancellable or not?
+  -> SPromptType pt          -- ^ The type of the prompt
+  -> (PromptResult pt -> m ()) -- ^ Function to call when the prompt is complete
+  -> Prompt m
+mkPrompt c pt@SDirectionPrompt cb = Prompt c pt DirectionPromptState () cb
+mkPrompt c pt@SContinue cb = Prompt c pt ContinuePromptState () cb
+mkPrompt c pt@SConfirm cb = Prompt c pt ConfirmPromptState () cb
+
+mkStringPrompt
+  :: PromptCancellable                  -- ^ Is the prompt cancellable or not?
+  -> (PromptResult 'StringPrompt -> m ()) -- ^ Function to call when the prompt is complete
+  -> Prompt m
+mkStringPrompt c =
+  let ps = StringPromptState $ editorText Resource.Prompt (Just 1) ""
+  in Prompt c SStringPrompt ps Nothing
+
+mkStringPromptWithDefault
+  :: PromptCancellable                  -- ^ Is the prompt cancellable or not?
+  -> Text                               -- ^ Default value for the prompt
+  -> (PromptResult 'StringPrompt -> m ()) -- ^ Function to call when the prompt is complete
+  -> Prompt m
+mkStringPromptWithDefault c def =
+  let ps = StringPromptState $ editorText Resource.Prompt (Just 1) ""
+  in Prompt c SStringPrompt ps (Just def)
+
+mkMenu
+  :: forall a m.
+    PromptCancellable
+  -> Map Char (MenuOption a) -- ^ Menu items
+  -> (PromptResult ('Menu a) -> m ())
+  -> Prompt m
+mkMenu c = Prompt c SMenu MenuPromptState
+
+mkPointOnMapPrompt
+  :: PromptCancellable
+  -> Position
+  -> (PromptResult 'PointOnMap -> m ())
+  -> Prompt m
+mkPointOnMapPrompt c pos = Prompt c SPointOnMap (PointOnMapPromptState pos) pos
+
+mkFirePrompt
+  :: PromptCancellable
+  -> Position -- ^ Initial position
+  -> Tiles    -- ^ Range
+  -> (PromptResult 'Fire -> m ())
+  -> Prompt m
+mkFirePrompt c pos range = Prompt c SFire (FirePromptState pos) (pos, range)
+
+isCancellable :: Prompt m -> Bool
+isCancellable (Prompt Cancellable _ _ _ _)   = True
+isCancellable (Prompt Uncancellable _ _ _ _) = False
+
+submitPrompt :: Applicative m => Prompt m -> m ()
+submitPrompt (Prompt _ pt ps pri cb) =
+  case (pt, ps, pri) of
+    (SStringPrompt, StringPromptState edit, mDef) ->
+      let inputVal = mconcat . getEditContents $ edit
+          val | null inputVal, Just def <- mDef = def
+              | otherwise = inputVal
+      in cb $ StringResult val
+    (SDirectionPrompt, DirectionPromptState, _) ->
+      pure () -- Don't use submit with a direction prompt
+    (SContinue, ContinuePromptState, _) ->
+      cb ContinueResult
+    (SMenu, MenuPromptState, _) ->
+      pure () -- Don't use submit with a menu prompt
+    (SPointOnMap, PointOnMapPromptState pos, _) ->
+      cb $ PointOnMapResult pos
+    (SConfirm, ConfirmPromptState, _) ->
+      cb $ ConfirmResult True
+    (SFire, FirePromptState pos, _) ->
+      cb $ FireResult pos
diff --git a/users/aspen/xanthous/src/Xanthous/Game/State.hs b/users/aspen/xanthous/src/Xanthous/Game/State.hs
new file mode 100644
index 000000000000..13b1ba158818
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Game/State.hs
@@ -0,0 +1,572 @@
+{-# LANGUAGE StandaloneDeriving   #-}
+{-# LANGUAGE RecordWildCards      #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TemplateHaskell      #-}
+{-# LANGUAGE GADTs                #-}
+{-# LANGUAGE AllowAmbiguousTypes  #-}
+--------------------------------------------------------------------------------
+module Xanthous.Game.State
+  ( GameState(..)
+  , entities
+  , levels
+  , revealedPositions
+  , messageHistory
+  , randomGen
+  , activePanel
+  , promptState
+  , characterEntityID
+  , autocommand
+  , savefile
+  , memo
+  , GamePromptState(..)
+
+    -- * Game Level
+  , GameLevel(..)
+  , levelEntities
+  , upStaircasePosition
+  , levelRevealedPositions
+
+    -- * Messages
+  , MessageHistory(..)
+  , HasMessages(..)
+  , HasTurn(..)
+  , HasDisplayedTurn(..)
+  , pushMessage
+  , previousMessage
+  , nextTurn
+
+    -- * Autocommands
+  , Autocommand(..)
+  , AutocommandState(..)
+  , _NoAutocommand
+  , _ActiveAutocommand
+
+    -- * App monad
+  , AppT(..)
+  , AppM
+  , runAppT
+
+    -- * Entities
+  , Draw(..)
+  , Brain(..)
+  , Brainless(..)
+  , brainVia
+  , Collision(..)
+  , Entity(..)
+  , SomeEntity(..)
+  , downcastEntity
+  , _SomeEntity
+  , entityIs
+  , entityTypeName
+
+    -- ** Vias
+  , Color(..)
+  , DrawNothing(..)
+  , DrawRawChar(..)
+  , DrawRawCharPriority(..)
+  , DrawCharacter(..)
+  , DrawStyledCharacter(..)
+  , DeriveEntity(..)
+    -- ** Field classes
+  , HasChar(..)
+  , HasStyle(..)
+
+    -- * Debug State
+  , DebugState(..)
+  , debugState
+  , allRevealed
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Data.List.NonEmpty ( NonEmpty((:|)))
+import qualified Data.List.NonEmpty as NonEmpty
+import           Data.Typeable
+import           Data.Coerce
+import           System.Random
+import           Test.QuickCheck
+import           Test.QuickCheck.Arbitrary.Generic
+import           Control.Monad.Random.Class
+import           Control.Monad.State
+import           Control.Monad.Trans.Control (MonadTransControl(..))
+import           Control.Monad.Trans.Compose
+import           Control.Monad.Morph (MFunctor(..))
+import           Brick (EventM, Widget, raw, str, emptyWidget)
+import           Data.Aeson (ToJSON(..), FromJSON(..), Value(Null))
+import qualified Data.Aeson as JSON
+import           Data.Aeson.Generic.DerivingVia
+import           Data.Generics.Product.Fields
+import qualified Graphics.Vty.Attributes as Vty
+import qualified Graphics.Vty.Image as Vty
+--------------------------------------------------------------------------------
+import           Xanthous.Util (KnownBool(..))
+import           Xanthous.Data
+import           Xanthous.Data.App
+import           Xanthous.Data.Levels
+import           Xanthous.Data.EntityMap (EntityMap, EntityID)
+import           Xanthous.Data.EntityChar
+import           Xanthous.Data.VectorBag
+import           Xanthous.Data.Entities
+import           Xanthous.Orphans ()
+import           Xanthous.Game.Prompt
+import           Xanthous.Game.Env
+import           Xanthous.Game.Memo (MemoState)
+--------------------------------------------------------------------------------
+
+data MessageHistory
+  = MessageHistory
+  { _messages      :: Map Word (NonEmpty Text)
+  , _turn          :: Word
+  , _displayedTurn :: Maybe Word
+  }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary MessageHistory
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           MessageHistory
+makeFieldsNoPrefix ''MessageHistory
+
+instance Semigroup MessageHistory where
+  (MessageHistory msgs₁ turn₁ dt₁) <> (MessageHistory msgs₂ turn₂ dt₂) =
+    MessageHistory (msgs₁ <> msgs₂) (max turn₁ turn₂) $ case (dt₁, dt₂) of
+      (_, Nothing)      -> Nothing
+      (Just t, _)       -> Just t
+      (Nothing, Just t) -> Just t
+
+instance Monoid MessageHistory where
+  mempty = MessageHistory mempty 0 Nothing
+
+type instance Element MessageHistory = [Text]
+instance MonoFunctor MessageHistory where
+  omap f mh@(MessageHistory _ t _) =
+    mh & messages . at t %~ (NonEmpty.nonEmpty . f . toList =<<)
+
+instance MonoComonad MessageHistory where
+  oextract (MessageHistory ms t dt) = maybe [] toList $ ms ^. at (fromMaybe t dt)
+  oextend cok mh@(MessageHistory _ t dt) =
+    mh & messages . at (fromMaybe t dt) .~ NonEmpty.nonEmpty (cok mh)
+
+pushMessage :: Text -> MessageHistory -> MessageHistory
+pushMessage msg mh@(MessageHistory _ turn' _) =
+  mh
+  & messages . at turn' %~ \case
+    Nothing -> Just $ msg :| mempty
+    Just msgs -> Just $ msg <| msgs
+  & displayedTurn .~ Nothing
+
+nextTurn :: MessageHistory -> MessageHistory
+nextTurn = (turn +~ 1) . (displayedTurn .~ Nothing)
+
+previousMessage :: MessageHistory -> MessageHistory
+previousMessage mh = mh & displayedTurn .~ maximumOf
+  (messages . ifolded . asIndex . filtered (< mh ^. turn))
+  mh
+
+
+--------------------------------------------------------------------------------
+
+data GamePromptState m where
+  NoPrompt :: GamePromptState m
+  WaitingPrompt :: Text -> Prompt m -> GamePromptState m
+  deriving stock (Show, Generic)
+  deriving anyclass (NFData)
+
+-- | Non-injective! We never try to serialize waiting prompts, since:
+--
+--  * they contain callback functions
+--  * we can't save the game when in a prompt anyway
+instance ToJSON (GamePromptState m) where
+  toJSON _ = Null
+
+-- | Always expects Null
+instance FromJSON (GamePromptState m) where
+  parseJSON Null = pure NoPrompt
+  parseJSON _ = fail "Invalid GamePromptState; expected null"
+
+instance CoArbitrary (GamePromptState m) where
+  coarbitrary NoPrompt = variant @Int 1
+  coarbitrary (WaitingPrompt txt _) = variant @Int 2 . coarbitrary txt
+
+instance Function (GamePromptState m) where
+  function = functionMap onlyNoPrompt (const NoPrompt)
+    where
+      onlyNoPrompt NoPrompt = ()
+      onlyNoPrompt (WaitingPrompt _ _) =
+        error "Can't handle prompts in Function!"
+
+--------------------------------------------------------------------------------
+
+newtype AppT m a
+  = AppT { unAppT :: ReaderT GameEnv (StateT GameState m) a }
+  deriving ( Functor
+           , Applicative
+           , Monad
+           , MonadState GameState
+           , MonadReader GameEnv
+           , MonadIO
+           )
+       via (ReaderT GameEnv (StateT GameState m))
+  deriving ( MonadTrans
+           , MFunctor
+           )
+       via (ReaderT GameEnv `ComposeT` StateT GameState)
+
+type AppM = AppT (EventM ResourceName)
+
+--------------------------------------------------------------------------------
+
+class Draw a where
+  drawWithNeighbors :: Neighbors (VectorBag SomeEntity) -> a -> Widget n
+  drawWithNeighbors = const draw
+
+  draw :: a -> Widget n
+  draw = drawWithNeighbors $ pure mempty
+
+  -- | higher priority gets drawn on top
+  drawPriority :: a -> Word
+  drawPriority = const minBound
+
+instance Draw a => Draw (Positioned a) where
+  drawWithNeighbors ns (Positioned _ a) = drawWithNeighbors ns a
+  draw (Positioned _ a) = draw a
+
+newtype DrawCharacter (char :: Symbol) (a :: Type) where
+  DrawCharacter :: a -> DrawCharacter char a
+
+instance KnownSymbol char => Draw (DrawCharacter char a) where
+  draw _ = str $ symbolVal @char Proxy
+
+data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White
+
+class KnownColor (color :: Color) where
+  colorVal :: forall proxy. proxy color -> Vty.Color
+
+instance KnownColor 'Black where colorVal _ = Vty.black
+instance KnownColor 'Red where colorVal _ = Vty.red
+instance KnownColor 'Green where colorVal _ = Vty.green
+instance KnownColor 'Yellow where colorVal _ = Vty.yellow
+instance KnownColor 'Blue where colorVal _ = Vty.blue
+instance KnownColor 'Magenta where colorVal _ = Vty.magenta
+instance KnownColor 'Cyan where colorVal _ = Vty.cyan
+instance KnownColor 'White where colorVal _ = Vty.white
+
+class KnownMaybeColor (maybeColor :: Maybe Color) where
+  maybeColorVal :: forall proxy. proxy maybeColor -> Maybe Vty.Color
+
+instance KnownMaybeColor 'Nothing where maybeColorVal _ = Nothing
+instance KnownColor color => KnownMaybeColor ('Just color) where
+  maybeColorVal _ = Just $ colorVal @color Proxy
+
+newtype DrawStyledCharacter (fg :: Maybe Color) (bg :: Maybe Color) (char :: Symbol) (a :: Type) where
+  DrawStyledCharacter :: a -> DrawStyledCharacter fg bg char a
+
+instance
+  ( KnownMaybeColor fg
+  , KnownMaybeColor bg
+  , KnownSymbol char
+  )
+  => Draw (DrawStyledCharacter fg bg char a) where
+  draw _ = raw $ Vty.string attr $ symbolVal @char Proxy
+    where attr = Vty.Attr
+            { Vty.attrStyle = Vty.Default
+            , Vty.attrForeColor = maybe Vty.Default Vty.SetTo
+                                  $ maybeColorVal @fg Proxy
+            , Vty.attrBackColor = maybe Vty.Default Vty.SetTo
+                                  $ maybeColorVal @bg Proxy
+            , Vty.attrURL = Vty.Default
+            }
+
+instance Draw EntityChar where
+  draw EntityChar{..} = raw $ Vty.string _style [_char]
+
+--------------------------------------------------------------------------------
+
+newtype DrawNothing (a :: Type) = DrawNothing a
+
+instance Draw (DrawNothing a) where
+  draw = const emptyWidget
+  drawPriority = const 0
+
+newtype DrawRawChar (rawField :: Symbol) (a :: Type) = DrawRawChar a
+
+instance
+  forall rawField a raw.
+  ( HasField rawField a a raw raw
+  , HasChar raw EntityChar
+  ) => Draw (DrawRawChar rawField a) where
+  draw (DrawRawChar e) = draw $ e ^. field @rawField . char
+
+newtype DrawRawCharPriority
+  (rawField :: Symbol)
+  (priority :: Nat)
+  (a :: Type)
+  = DrawRawCharPriority a
+
+instance
+  forall rawField priority a raw.
+  ( HasField rawField a a raw raw
+  , KnownNat priority
+  , HasChar raw EntityChar
+  ) => Draw (DrawRawCharPriority rawField priority a) where
+  draw (DrawRawCharPriority e) = draw $ e ^. field @rawField . char
+  drawPriority = const . fromIntegral $ natVal @priority Proxy
+
+
+--------------------------------------------------------------------------------
+
+class Brain a where
+  step :: Ticks -> Positioned a -> AppM (Positioned a)
+  -- | Does this entity ever move on its own?
+  entityCanMove :: a -> Bool
+  entityCanMove = const False
+
+newtype Brainless a = Brainless a
+
+instance Brain (Brainless a) where
+  step = const pure
+
+-- | Workaround for the inability to use DerivingVia on Brain due to the lack of
+-- higher-order roles (specifically AppT not having its last type argument have
+-- role representational bc of StateT)
+brainVia
+  :: forall brain entity. (Coercible entity brain, Brain brain)
+  => (entity -> brain) -- ^ constructor, ignored
+  -> (Ticks -> Positioned entity -> AppM (Positioned entity))
+brainVia _ ticks = fmap coerce . step ticks . coerce @_ @(Positioned brain)
+
+--------------------------------------------------------------------------------
+
+class ( Show a, Eq a, Ord a, NFData a
+      , ToJSON a, FromJSON a
+      , Draw a, Brain a
+      ) => Entity a where
+  entityAttributes :: a -> EntityAttributes
+  entityAttributes = const defaultEntityAttributes
+  description :: a -> Text
+  entityChar :: a -> EntityChar
+  entityCollision :: a -> Maybe Collision
+  entityCollision = const $ Just Stop
+
+data SomeEntity where
+  SomeEntity :: forall a. (Entity a, Typeable a) => a -> SomeEntity
+
+instance Show SomeEntity where
+  show (SomeEntity e) = "SomeEntity (" <> show e <> ")"
+
+instance Eq SomeEntity where
+  (SomeEntity (a :: ea)) == (SomeEntity (b :: eb)) = case eqT @ea @eb of
+    Just Refl -> a == b
+    _ -> False
+
+instance Ord SomeEntity where
+  compare (SomeEntity (a :: ea)) (SomeEntity (b :: eb)) = case eqT @ea @eb of
+    Just Refl -> compare a b
+    _ -> compare (typeRep $ Proxy @ea) (typeRep $ Proxy @eb)
+
+
+instance NFData SomeEntity where
+  rnf (SomeEntity ent) = ent `deepseq` ()
+
+instance ToJSON SomeEntity where
+  toJSON (SomeEntity ent) = entityToJSON ent
+    where
+      entityToJSON :: forall entity. (Entity entity, Typeable entity)
+                   => entity -> JSON.Value
+      entityToJSON entity = JSON.object
+        [ "type" JSON..= tshow (typeRep @_ @entity Proxy)
+        , "data" JSON..= toJSON entity
+        ]
+
+instance Draw SomeEntity where
+  drawWithNeighbors ns (SomeEntity ent) = drawWithNeighbors ns ent
+  drawPriority (SomeEntity ent) = drawPriority ent
+
+instance Brain SomeEntity where
+  step ticks (Positioned p (SomeEntity ent)) =
+    fmap SomeEntity <$> step ticks (Positioned p ent)
+  entityCanMove (SomeEntity ent) = entityCanMove ent
+
+downcastEntity :: forall (a :: Type). (Typeable a) => SomeEntity -> Maybe a
+downcastEntity (SomeEntity e) = cast e
+
+entityIs :: forall (a :: Type). (Typeable a) => SomeEntity -> Bool
+entityIs = isJust . downcastEntity @a
+
+_SomeEntity :: forall a. (Entity a, Typeable a) => Prism' SomeEntity a
+_SomeEntity = prism' SomeEntity downcastEntity
+
+-- | Get the name of the type of 'SomeEntity' as a string
+entityTypeName :: SomeEntity -> Text
+entityTypeName (SomeEntity e) = pack . tyConName . typeRepTyCon $ typeOf e
+
+newtype DeriveEntity
+  (blocksVision :: Bool)
+  (description :: Symbol)
+  (entityChar :: Symbol)
+  (entity :: Type)
+  = DeriveEntity entity
+  deriving newtype (Show, Eq, Ord, NFData, ToJSON, FromJSON, Draw)
+
+instance Brain entity => Brain (DeriveEntity b d c entity) where
+  step = brainVia $ \(DeriveEntity e) -> e
+
+instance
+  ( KnownBool blocksVision
+  , KnownSymbol description
+  , KnownSymbol entityChar
+  , Show entity, Eq entity, Ord entity, NFData entity
+  , ToJSON entity, FromJSON entity
+  , Draw entity, Brain entity
+  )
+  => Entity (DeriveEntity blocksVision description entityChar entity) where
+  entityAttributes _ = defaultEntityAttributes
+    & blocksVision .~ boolVal @blocksVision
+  description _ = pack . symbolVal $ Proxy @description
+  entityChar _ = fromString . symbolVal $ Proxy @entityChar
+
+--------------------------------------------------------------------------------
+
+data GameLevel = GameLevel
+  { _levelEntities :: !(EntityMap SomeEntity)
+  , _upStaircasePosition :: !Position
+  , _levelRevealedPositions :: !(Set Position)
+  }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData)
+  deriving (ToJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           GameLevel
+
+--------------------------------------------------------------------------------
+
+data Autocommand
+  = AutoMove Direction
+  | AutoRest
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, Hashable, ToJSON, FromJSON, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary Autocommand
+{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
+
+data AutocommandState
+  = NoAutocommand
+  | ActiveAutocommand Autocommand (Async ())
+  deriving stock (Eq, Ord, Generic)
+  deriving anyclass (Hashable)
+
+instance Show AutocommandState where
+  show NoAutocommand = "NoAutocommand"
+  show (ActiveAutocommand ac _) =
+    "(ActiveAutocommand " <> show ac <> " <Async>)"
+
+instance ToJSON AutocommandState where
+  toJSON = const Null
+
+instance FromJSON AutocommandState where
+  parseJSON Null = pure NoAutocommand
+  parseJSON _ = fail "Invalid AutocommandState; expected null"
+
+instance NFData AutocommandState where
+  rnf NoAutocommand = ()
+  rnf (ActiveAutocommand ac t) = ac `deepseq` t `seq` ()
+
+instance CoArbitrary AutocommandState where
+  coarbitrary NoAutocommand = variant @Int 1
+  coarbitrary (ActiveAutocommand ac t)
+    = variant @Int 2
+    . coarbitrary ac
+    . coarbitrary (hash t)
+
+instance Function AutocommandState where
+  function = functionMap onlyNoAC (const NoAutocommand)
+    where
+      onlyNoAC NoAutocommand = ()
+      onlyNoAC _ = error "Can't handle autocommands in Function"
+
+--------------------------------------------------------------------------------
+
+
+data DebugState = DebugState
+  { _allRevealed :: !Bool
+  }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           DebugState
+{-# ANN DebugState ("HLint: ignore Use newtype instead of data" :: String) #-}
+
+instance Arbitrary DebugState where
+  arbitrary = genericArbitrary
+
+data GameState = GameState
+  { _levels            :: !(Levels GameLevel)
+  , _characterEntityID :: !EntityID
+  , _messageHistory    :: !MessageHistory
+  , _randomGen         :: !StdGen
+
+    -- | The active panel displayed in the UI, if any
+  , _activePanel       :: !(Maybe Panel)
+
+  , _promptState       :: !(GamePromptState AppM)
+  , _debugState        :: !DebugState
+  , _autocommand       :: !AutocommandState
+
+  -- | The path to the savefile that was loaded for this game, if any
+  , _savefile          :: !(Maybe FilePath)
+
+  , _memo              :: MemoState
+  }
+  deriving stock (Show, Generic)
+  deriving anyclass (NFData)
+  deriving (ToJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           GameState
+
+makeLenses ''GameLevel
+makeLenses ''GameState
+
+entities :: Lens' GameState (EntityMap SomeEntity)
+entities = levels . current . levelEntities
+
+revealedPositions :: Lens' GameState (Set Position)
+revealedPositions = levels . current . levelRevealedPositions
+
+instance Eq GameState where
+  (==) = (==) `on` \gs ->
+    ( gs ^. entities
+    , gs ^. revealedPositions
+    , gs ^. characterEntityID
+    , gs ^. messageHistory
+    , gs ^. activePanel
+    , gs ^. debugState
+    )
+
+--------------------------------------------------------------------------------
+
+runAppT :: Monad m => AppT m a -> GameEnv -> GameState -> m (a, GameState)
+runAppT appt env initialState
+  = flip runStateT initialState
+  . flip runReaderT env
+  . unAppT
+  $ appt
+
+instance (Monad m) => MonadRandom (AppT m) where
+  getRandomR rng = randomGen %%= randomR rng
+  getRandom = randomGen %%= random
+  getRandomRs rng = uses randomGen $ randomRs rng
+  getRandoms = uses randomGen randoms
+
+instance MonadTransControl AppT where
+  type StT AppT a = (a, GameState)
+  liftWith f
+    = AppT
+    . ReaderT $ \e
+    -> StateT $ \s
+    -> (,s) <$> f (\action -> runAppT action e s)
+  restoreT = AppT . ReaderT . const . StateT . const
+
+--------------------------------------------------------------------------------
+
+makeLenses ''DebugState
+makePrisms ''AutocommandState
diff --git a/users/aspen/xanthous/src/Xanthous/Generators/Level.hs b/users/aspen/xanthous/src/Xanthous/Generators/Level.hs
new file mode 100644
index 000000000000..fc57402e7d8e
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Generators/Level.hs
@@ -0,0 +1,172 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE GADTs           #-}
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Generators.Level
+  ( generate
+  , Generator(..)
+  , SGenerator(..)
+  , GeneratorInput(..)
+  , generateFromInput
+  , parseGeneratorInput
+  , showCells
+  , Level(..)
+  , levelWalls
+  , levelItems
+  , levelCreatures
+  , levelDoors
+  , levelCharacterPosition
+  , levelTutorialMessage
+  , levelExtra
+  , generateLevel
+  , levelToEntityMap
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+import           Data.Array.Unboxed
+import qualified Options.Applicative as Opt
+import           Control.Monad.Random
+--------------------------------------------------------------------------------
+import qualified Xanthous.Generators.Level.CaveAutomata as CaveAutomata
+import qualified Xanthous.Generators.Level.Dungeon as Dungeon
+import           Xanthous.Generators.Level.Util
+import           Xanthous.Generators.Level.LevelContents
+import           Xanthous.Generators.Level.Village as Village
+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(..))
+import           Linear.V2
+--------------------------------------------------------------------------------
+
+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 sgen <$> parseParams)
+          (Opt.progDesc desc)
+        )
+
+
+showCells :: Cells -> Text
+showCells arr =
+  let (V2 minX minY, V2 maxX maxY) = bounds arr
+      showCellVal True = "x"
+      showCellVal False = " "
+      showCell = showCellVal . (arr !)
+      row r = foldMap (showCell . (`V2` 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@(V2 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)
+  , _levelExtra             :: !(EntityMap SomeEntity) -- ^ TODO this is a bit of a hack...
+  , _levelCharacterPosition :: !Position
+  }
+  deriving stock (Generic)
+  deriving anyclass (NFData)
+makeLenses ''Level
+
+generateLevel
+  :: MonadRandom m
+  => SGenerator gen
+  -> Params gen
+  -> Dimensions
+  -> Word -- ^ Level number, starting at 0
+  -> m Level
+generateLevel gen ps dims num = do
+  rand <- mkStdGen <$> getRandom
+  let cells = generate gen ps dims rand
+      _levelWalls = cellsToWalls cells
+  village <- generateVillage cells gen
+  let _levelExtra = village
+  _levelItems <- randomItems cells
+  _levelCreatures <- randomCreatures num cells
+  _levelDoors <- randomDoors cells
+  _levelCharacterPosition <- chooseCharacterPosition cells
+  let upStaircase = _EntityMap # [(_levelCharacterPosition, UpStaircase)]
+  downStaircase <- placeDownStaircase cells
+  let _levelStaircases = upStaircase <> downStaircase
+  _levelTutorialMessage <-
+    if num == 0
+    then tutorialMessage cells _levelCharacterPosition
+    else pure mempty
+  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)
+  <> (level ^. levelExtra)
+
+generateVillage
+  :: MonadRandom m
+  => Cells -- ^ Wall positions
+  -> SGenerator gen
+  -> m (EntityMap SomeEntity)
+generateVillage wallPositions SCaveAutomata = Village.fromCave wallPositions
+generateVillage _ _ = pure mempty
diff --git a/users/aspen/xanthous/src/Xanthous/Generators/Level/CaveAutomata.hs b/users/aspen/xanthous/src/Xanthous/Generators/Level/CaveAutomata.hs
new file mode 100644
index 000000000000..03d534ca39b3
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Generators/Level/CaveAutomata.hs
@@ -0,0 +1,112 @@
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Generators.Level.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.Level.Util
+import           Linear.V2
+--------------------------------------------------------------------------------
+
+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"
+      )
+  <**> Opt.helper
+  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, V2 (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/aspen/xanthous/src/Xanthous/Generators/Level/Dungeon.hs b/users/aspen/xanthous/src/Xanthous/Generators/Level/Dungeon.hs
new file mode 100644
index 000000000000..0be7c0435c5a
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Generators/Level/Dungeon.hs
@@ -0,0 +1,190 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Generators.Level.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, distance)
+import           Xanthous.Generators.Level.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 (V2 x y) True
+
+corridorBetween :: MonadRandom m => Room -> Room -> m [V2 Word]
+corridorBetween originRoom destinationRoom
+  = straightLine <$> origin <*> destination
+  where
+    origin = choose . NE.fromList =<< originEdge
+    destination = choose . NE.fromList =<< 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
diff --git a/users/aspen/xanthous/src/Xanthous/Generators/Level/LevelContents.hs b/users/aspen/xanthous/src/Xanthous/Generators/Level/LevelContents.hs
new file mode 100644
index 000000000000..4f8a2f42ee16
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Generators/Level/LevelContents.hs
@@ -0,0 +1,182 @@
+{-# LANGUAGE RecordWildCards #-}
+--------------------------------------------------------------------------------
+module Xanthous.Generators.Level.LevelContents
+  ( chooseCharacterPosition
+  , randomItems
+  , randomCreatures
+  , randomDoors
+  , placeDownStaircase
+  , tutorialMessage
+  , entityFromRaw
+  ) 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           Linear.V2
+--------------------------------------------------------------------------------
+import           Xanthous.Generators.Level.Util
+import           Xanthous.Random hiding (chance)
+import qualified Xanthous.Random as Random
+import           Xanthous.Data
+                 ( positionFromV2,  Position, _Position
+                 , rotations, arrayNeighbors, Neighbors(..)
+                 , neighborPositions
+                 )
+import           Xanthous.Data.EntityMap (EntityMap, _EntityMap)
+import           Xanthous.Entities.Raws (rawsWithType, RawType, raw)
+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)
+import           Xanthous.Entities.RawTypes
+import           Xanthous.Entities.Creature.Hippocampus (initialHippocampus)
+import           Xanthous.Entities.Common (inRightHand, asWieldedItem, wielded)
+import           Xanthous.Game.State (SomeEntity(SomeEntity))
+--------------------------------------------------------------------------------
+
+chooseCharacterPosition :: MonadRandom m => Cells -> m Position
+chooseCharacterPosition = randomPosition
+
+randomItems :: MonadRandom m => Cells -> m (EntityMap Item)
+randomItems = randomEntities (fmap Identity . 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 positionFromV2 . 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
+  => Word -- ^ Level number, starting at 0
+  -> Cells
+  -> m (EntityMap Creature)
+randomCreatures levelNumber
+  = randomEntities maybeNewCreature (0.0007, 0.002)
+  where
+    maybeNewCreature cType
+      | maybe True (canGenerate levelNumber) $ cType ^. generateParams
+      = Just <$> newCreatureWithType cType
+      | otherwise
+      = pure Nothing
+
+newCreatureWithType :: MonadRandom m => CreatureType -> m Creature
+newCreatureWithType _creatureType = do
+  let _hitpoints = _creatureType ^. maxHitpoints
+      _hippocampus = initialHippocampus
+
+  equipped <- fmap join
+            . traverse genEquipped
+            $ _creatureType
+            ^.. generateParams . _Just . equippedItem . _Just
+  let _inventory = maybe id (\ei -> wielded .~ inRightHand ei) (headMay equipped) mempty
+  pure Creature.Creature {..}
+  where
+    genEquipped cei = do
+      doGen <- Random.chance $ cei ^. chance
+      let entName = cei ^. entityName
+          itemType =
+            fromMaybe (error $ "raw \"" <> unpack entName <> "\" not of type Item")
+            . preview _Item
+            . fromMaybe (error $ "Could not find raw: " <> unpack entName)
+            $ raw entName
+      item <- Item.newWithType itemType
+      if doGen
+        then pure [fromMaybe (error $ "raw \"" <> unpack entName <> "\" not wieldable")
+                  $ preview asWieldedItem item]
+        else pure []
+
+
+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
+            (\pt -> not $ valid ! (fromIntegral <$> pt))
+            (circle (pos ^. _Position) dist)
+
+randomEntities
+  :: forall entity raw m t. (MonadRandom m, RawType raw, Functor t, Foldable t)
+  => (raw -> m (t 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
+        r <- choose raws
+        entities <- newWithType r
+        pure $ (pos, ) <$> entities
+      pure $ _EntityMap # (entities >>= toList)
+
+randomPosition :: MonadRandom m => Cells -> m Position
+randomPosition = fmap positionFromV2 . choose . impureNonNull . cellCandidates
+
+-- cellCandidates :: Cells -> Cells
+cellCandidates :: Cells -> Set (V2 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
+
+entityFromRaw :: MonadRandom m => EntityRaw -> m SomeEntity
+entityFromRaw (Creature ct) = SomeEntity <$> newCreatureWithType ct
+entityFromRaw (Item it) = SomeEntity <$> Item.newWithType it
diff --git a/users/aspen/xanthous/src/Xanthous/Generators/Level/Util.hs b/users/aspen/xanthous/src/Xanthous/Generators/Level/Util.hs
new file mode 100644
index 000000000000..0008eb965c42
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Generators/Level/Util.hs
@@ -0,0 +1,236 @@
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+--------------------------------------------------------------------------------
+module Xanthous.Generators.Level.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           Linear.V2
+--------------------------------------------------------------------------------
+import           Xanthous.Util (foldlMapM', maximum1, minimum1)
+import           Xanthous.Data (Dimensions, width, height)
+--------------------------------------------------------------------------------
+
+type MCells s = STUArray s (V2 Word) Bool
+type Cells = UArray (V2 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 (V2 i j) val
+  pure res
+
+initializeEmpty :: RandomGen g => Dimensions -> CellM g s (MCells s)
+initializeEmpty dims =
+  lift $ newArray (0, V2 (dims ^. width) (dims ^. height)) False
+
+-- | Returns the number of neighbors of the given point in the given array that
+-- are True.
+--
+-- Behavior if point is out-of-bounds for the array is undefined, but will not
+-- error
+numAliveNeighborsM
+  :: forall a i m
+  . (MArray a Bool m, Ix i, Integral i)
+  => a (V2 i) Bool
+  -> V2 i
+  -> m Word
+numAliveNeighborsM cells pt@(V2 x y) = do
+  cellBounds <- getBounds cells
+  getSum <$> foldlMapM'
+    (fmap (Sum . fromIntegral . fromEnum) . boundedGet cellBounds)
+    neighborPositions
+
+  where
+    boundedGet :: (V2 i, V2 i) -> (Int, Int) -> m Bool
+    boundedGet bnds _
+      | not (inRange bnds pt)
+      = pure True
+    boundedGet (V2 minX minY, V2 maxX maxY) (i, j)
+      | (x <= minX && i < 0)
+      || (y <= minY && j < 0)
+      || (x >= maxX && i > 0)
+      || (y >= maxY && j > 0)
+      = pure True
+      | otherwise =
+        let nx = fromIntegral $ fromIntegral x + i
+            ny = fromIntegral $ fromIntegral y + j
+        in readArray cells $ V2 nx ny
+
+-- | Returns the number of neighbors of the given point in the given array that
+-- are True.
+--
+-- Behavior if point is out-of-bounds for the array is undefined, but will not
+-- error
+numAliveNeighbors
+  :: forall a i
+  . (IArray a Bool, Ix i, Integral i)
+  => a (V2 i) Bool
+  -> V2 i
+  -> Word
+numAliveNeighbors cells pt@(V2 x y) =
+  let cellBounds = bounds cells
+  in getSum $ foldMap
+      (Sum . fromIntegral . fromEnum . boundedGet cellBounds)
+      neighborPositions
+
+  where
+    boundedGet :: (V2 i, V2 i) -> (Int, Int) -> Bool
+    boundedGet bnds _
+      | not (inRange bnds pt)
+      = True
+    boundedGet (V2 minX minY, V2 maxX maxY) (i, j)
+      | (x <= minX && i < 0)
+      || (y <= minY && j < 0)
+      || (x >= maxX && i > 0)
+      || (y >= maxY && j > 0)
+      = True
+      | otherwise =
+        let nx = fromIntegral $ fromIntegral x + i
+            ny = fromIntegral $ fromIntegral y + j
+        in cells ! V2 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) => a (V2 i) Bool -> m ()
+fillOuterEdgesM arr = do
+  (V2 minX minY, V2 maxX maxY) <- getBounds arr
+  for_ (range (minX, maxX)) $ \x -> do
+    writeArray arr (V2 x minY) True
+    writeArray arr (V2 x maxY) True
+  for_ (range (minY, maxY)) $ \y -> do
+    writeArray arr (V2 minX y) True
+    writeArray arr (V2 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.
+            ( IArray a Bool
+            , Ix i
+            , Enum i
+            , Bounded i
+            , Eq i
+            )
+          => a (V2 i) Bool -- ^ array
+          -> (V2 i)        -- ^ position
+          -> Set (V2 i)
+floodFill = go mempty
+  where
+    go :: Set (V2 i) -> a (V2 i) Bool -> (V2 i) -> Set (V2 i)
+    go res arr@(bounds -> arrBounds) idx@(V2 x y)
+      | not (inRange arrBounds idx) =  res
+      | not (arr ! idx) =  res
+      | otherwise =
+        let neighbors
+              = filter (inRange arrBounds)
+              . filter (/= idx)
+              . filter (`notMember` res)
+              $ V2
+              <$> [(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 <> (let r' = r & contains idx' .~ True
+                               in r' `seq` go r' arr idx')
+                     else r)
+           (res & contains idx .~ True) neighbors
+{-# SPECIALIZE floodFill :: UArray (V2 Word) Bool -> (V2 Word) -> Set (V2 Word) #-}
+
+-- | Gives a list of all the disconnected regions in a cell array, represented
+-- each as lists of points
+regions :: forall a i.
+          ( IArray a Bool
+          , Ix i
+          , Enum i
+          , Bounded i
+          , Eq i
+          )
+        => a (V2 i) Bool
+        -> [Set (V2 i)]
+regions arr
+  | Just firstPoint <- findFirstPoint arr =
+      let region = floodFill arr firstPoint
+          arr' = fillAll region arr
+      in region : regions arr'
+  | otherwise = []
+  where
+    findFirstPoint :: a (V2 i) Bool -> Maybe (V2 i)
+    findFirstPoint = fmap fst . headMay . filter snd . assocs
+{-# SPECIALIZE regions :: UArray (V2 Word) Bool -> [Set (V2 Word)] #-}
+
+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/aspen/xanthous/src/Xanthous/Generators/Level/Village.hs b/users/aspen/xanthous/src/Xanthous/Generators/Level/Village.hs
new file mode 100644
index 000000000000..ab7de95e6806
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Generators/Level/Village.hs
@@ -0,0 +1,126 @@
+--------------------------------------------------------------------------------
+module Xanthous.Generators.Level.Village
+  ( fromCave
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding (any, failing, toList)
+--------------------------------------------------------------------------------
+import           Control.Monad.Random (MonadRandom)
+import           Control.Monad.State (execStateT, MonadState, modify)
+import           Control.Monad.Trans.Maybe
+import           Control.Parallel.Strategies
+import           Data.Array.IArray
+import           Data.Foldable (any, toList)
+--------------------------------------------------------------------------------
+import           Xanthous.Data
+import           Xanthous.Data.EntityMap (EntityMap)
+import qualified Xanthous.Data.EntityMap as EntityMap
+import           Xanthous.Entities.Environment
+import           Xanthous.Generators.Level.Util
+import           Xanthous.Game.State (SomeEntity(..))
+import           Xanthous.Random
+--------------------------------------------------------------------------------
+
+fromCave :: MonadRandom m
+         => Cells -- ^ The positions of all the walls
+         -> m (EntityMap SomeEntity)
+fromCave wallPositions = execStateT (fromCave' wallPositions) mempty
+
+fromCave' :: forall m. (MonadRandom m, MonadState (EntityMap SomeEntity) m)
+          => Cells
+          -> m ()
+fromCave' wallPositions = failing (pure ()) $ do
+  Just villageRegion <-
+    choose
+    . (`using` parTraversable rdeepseq)
+    . weightedBy (\reg -> let circSize = length $ circumference reg
+                         in if circSize == 50
+                            then (1.0 :: Double)
+                            else 1.0 / (fromIntegral . abs $ circSize - 50))
+    $ regions closedHallways
+
+  let circ = setFromList . circumference $ villageRegion
+
+  centerPoints <- chooseSubset (0.1 :: Double) $ toList circ
+
+  roomTiles <- foldM
+              (flip $ const $ stepOut circ)
+              (map pure centerPoints)
+              [0 :: Int ..2]
+
+  let roomWalls = circumference . setFromList @(Set _) <$> roomTiles
+      allWalls = join roomWalls
+
+  doorPositions <- fmap join . for roomWalls $ \room ->
+    let candidates = filter (`notMember` circ) room
+    in fmap toList . choose $ ChooseElement candidates
+
+  let entryways =
+        filter (\pt ->
+                  let ncs = neighborCells pt
+                  in any ((&&) <$> (not . (wallPositions !))
+                              <*> (`notMember` villageRegion)) ncs
+                   && any ((&&) <$> (`member` villageRegion)
+                              <*> (`notElem` allWalls)) ncs)
+                  $ toList villageRegion
+
+  Just entryway <- choose $ ChooseElement entryways
+
+  for_ (filter ((&&) <$> (`notElem` doorPositions) <*> (/= entryway)) allWalls)
+    $ insertEntity Wall
+  for_ (filter (/= entryway) doorPositions) $ insertEntity unlockedDoor
+  insertEntity unlockedDoor entryway
+
+
+  where
+    insertEntity e pt = modify $ EntityMap.insertAt (ptToPos pt) $ SomeEntity e
+    ptToPos pt = _Position # (fromIntegral <$> pt)
+
+    stepOut :: Set (V2 Word) -> [[V2 Word]] -> MaybeT m [[V2 Word]]
+    stepOut circ rooms = for rooms $ \room ->
+      let nextLevels = hashNub $ toList . neighborCells =<< room
+      in pure
+         . (<> room)
+         $ filter ((&&) <$> (`notMember` circ) <*> (`notElem` join rooms))
+         nextLevels
+
+    circumference pts =
+      filter (any (`notMember` pts) . neighborCells) $ toList pts
+    closedHallways = closeHallways livePositions
+    livePositions = amap not wallPositions
+
+--------------------------------------------------------------------------------
+
+closeHallways :: Cells -> Cells
+closeHallways livePositions =
+  livePositions // mapMaybe closeHallway (assocs livePositions)
+  where
+    closeHallway (_, False) = Nothing
+    closeHallway (pos, _)
+      | isHallway pos = Just (pos, False)
+      | otherwise     = Nothing
+    isHallway pos = any ((&&) <$> not . view left <*> not . view right)
+      . rotations
+      . fmap (fromMaybe False)
+      $ arrayNeighbors livePositions pos
+
+failing :: Monad m => m a -> MaybeT m a -> m a
+failing result = (maybe result pure =<<) . runMaybeT
+
+{-
+
+import Xanthous.Generators.Village
+import Xanthous.Generators
+import Xanthous.Data
+import System.Random
+import qualified Data.Text
+import qualified Xanthous.Generators.CaveAutomata as CA
+let gi = GeneratorInput SCaveAutomata CA.defaultParams
+wallPositions <- generateFromInput gi (Dimensions 80 50) <$> getStdGen
+putStrLn . Data.Text.unpack $ showCells wallPositions
+
+import Data.Array.IArray
+let closedHallways = closeHallways . amap not $ wallPositions
+putStrLn . Data.Text.unpack . showCells $ amap not closedHallways
+
+-}
diff --git a/users/aspen/xanthous/src/Xanthous/Generators/Speech.hs b/users/aspen/xanthous/src/Xanthous/Generators/Speech.hs
new file mode 100644
index 000000000000..8abc00b6a2fc
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Generators/Speech.hs
@@ -0,0 +1,181 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedLists #-}
+--------------------------------------------------------------------------------
+module Xanthous.Generators.Speech
+  ( -- * Language definition
+    Language(..)
+    -- ** Lenses
+  , phonotactics
+  , syllablesPerWord
+
+    -- ** Phonotactics
+  , Phonotactics(..)
+    -- *** Lenses
+  , onsets
+  , nuclei
+  , codas
+  , numOnsets
+  , numNuclei
+  , numCodas
+
+    -- * Language generation
+  , syllable
+  , word
+
+    -- * Languages
+  , english
+  , gormlak
+
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding (replicateM)
+import           Data.Interval (Interval, (<=..<=))
+import qualified Data.Interval as Interval
+import           Control.Monad.Random.Class (MonadRandom)
+import           Xanthous.Random (chooseRange, choose, ChooseElement (..), Weighted (Weighted))
+import           Control.Monad (replicateM)
+import           Test.QuickCheck (Arbitrary, CoArbitrary, Function)
+import           Test.QuickCheck.Instances.Text ()
+import           Data.List.NonEmpty (NonEmpty)
+--------------------------------------------------------------------------------
+
+newtype Phoneme = Phoneme Text
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving newtype (IsString, Semigroup, Monoid, Arbitrary)
+
+-- | The phonotactics of a language
+--
+-- The phonotactics of a language represent the restriction on the phonemes in
+-- the syllables of a language.
+--
+-- Syllables in a language consist of an onset, a nucleus, and a coda (the
+-- nucleus and the coda together representing the "rhyme" of the syllable).
+data Phonotactics = Phonotactics
+  { _onsets    :: [Phoneme] -- ^ The permissible onsets, or consonant clusters
+                           --   at the beginning of a syllable
+  , _nuclei    :: [Phoneme] -- ^ The permissible nuclei, or vowel clusters in
+                           --   the middle of a syllable
+  , _codas     :: [Phoneme] -- ^ The permissible codas, or consonant clusters at
+                           --   the end of a syllable
+  , _numOnsets :: Interval Word -- ^ The range of number of allowable onsets
+  , _numNuclei :: Interval Word -- ^ The range of number of allowable nuclei
+  , _numCodas  :: Interval Word -- ^ The range of number of allowable codas
+  }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData)
+makeLenses ''Phonotactics
+
+-- | Randomly generate a syllable with the given 'Phonotactics'
+syllable :: MonadRandom m => Phonotactics -> m Text
+syllable phonotactics = do
+  let genPart num choices = do
+        n <- fromIntegral . fromMaybe 0 <$> chooseRange (phonotactics ^. num)
+        fmap (fromMaybe mempty . mconcat)
+          . replicateM n
+          . choose . ChooseElement
+          $ phonotactics ^. choices
+
+  (Phoneme onset) <- genPart numOnsets onsets
+  (Phoneme nucleus) <- genPart numNuclei nuclei
+  (Phoneme coda) <- genPart numCodas codas
+
+  pure $ onset <> nucleus <> coda
+
+-- | A definition for a language
+--
+-- Currently this provides enough information to generate multi-syllabic words,
+-- but in the future will likely also include grammar-related things.
+data Language = Language
+  { _phonotactics :: Phonotactics
+  , _syllablesPerWord :: Weighted Int NonEmpty Int
+  }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData)
+makeLenses ''Language
+
+word :: MonadRandom m => Language -> m Text
+word lang = do
+  numSyllables <- choose $ lang ^. syllablesPerWord
+  mconcat <$> replicateM numSyllables (syllable $ lang ^. phonotactics)
+
+--------------------------------------------------------------------------------
+
+-- <https://en.wikipedia.org/wiki/English_phonology#Phonotactics>
+englishPhonotactics :: Phonotactics
+englishPhonotactics = Phonotactics
+  { _onsets = [ "pl" , "bl" , "kl" , "gl" , "pr" , "br" , "tr" , "dr" , "kr"
+              , "gr" , "tw" , "dw" , "gw" , "kw" , "pw"
+
+              , "fl" , "sl" , {- "thl", -} "shl" {- , "vl" -}
+              , "p", "b", "t", "d", "k", "ɡ", "m", "n", "f", "v", "th", "s"
+              , "z", "h", "l", "w"
+
+              , "sp", "st", "sk"
+
+              , "sm", "sn"
+
+              , "sf", "sth"
+
+              , "spl", "skl", "spr", "str", "skr", "skw", "sm", "sp", "st", "sk"
+              ]
+  , _nuclei = [ "a", "e", "i", "o", "u", "ur", "ar", "or", "ear", "are", "ure"
+              , "oa", "ee", "oo", "ei", "ie", "oi", "ou"
+              ]
+  , _codas = [ "m", "n", "ng", "p", "t", "tsh", "k", "f", "sh", "s", "th", "x"
+             , "v", "z", "zh", "l", "r", "w"
+
+             , "lk", "lb", "lt", "ld", "ltsh", "ldsh", "lk"
+             , "rp", "rb", "rt", "rd", "rtsh", "rdsh", "rk", "rɡ"
+             , "lf", "lv", "lth", "ls", "lz", "lsh", "lth"
+             , "rf", "rv", "rth", "rs", "rz", "rth"
+             , "lm", "ln"
+             , "rm", "rn", "rl"
+             , "mp", "nt", "nd", "nth", "nsh", "nk"
+             , "mf", "ms", "mth", "nf", "nth", "ns", "nz", "nth"
+             , "ft", "sp", "st", "sk"
+             , "fth"
+             , "pt", "kt"
+             , "pth", "ps", "th", "ts", "dth", "dz", "ks"
+             , "lpt", "lps", "lfth", "lts", "lst", "lkt", "lks"
+             , "rmth", "rpt", "rps", "rts", "rst", "rkt"
+             , "mpt", "mps", "ndth", "nkt", "nks", "nkth"
+             , "ksth", "kst"
+             ]
+  , _numOnsets = 0 <=..<= 1
+  , _numNuclei = Interval.singleton 1
+  , _numCodas  = 0 <=..<= 1
+  }
+
+english :: Language
+english = Language
+  { _phonotactics = englishPhonotactics
+  , _syllablesPerWord = Weighted [(20, 1),
+                                  (7,  2),
+                                  (2,  3),
+                                  (1,  4)]
+  }
+
+gormlakPhonotactics :: Phonotactics
+gormlakPhonotactics = Phonotactics
+ { _onsets = [ "h", "l", "g", "b", "m", "n", "ng"
+             , "gl", "bl", "fl"
+             ]
+ , _numOnsets = Interval.singleton 1
+ , _nuclei = [ "a", "o", "aa", "u" ]
+ , _numNuclei = Interval.singleton 1
+ , _codas = [ "r", "l", "g", "m", "n"
+            , "rl", "gl", "ml", "rm"
+            , "n", "k"
+            ]
+ , _numCodas = Interval.singleton 1
+ }
+
+gormlak :: Language
+gormlak = Language
+  { _phonotactics = gormlakPhonotactics
+  , _syllablesPerWord = Weighted [ (5, 2)
+                                 , (5, 1)
+                                 , (1, 3)
+                                 ]
+  }
diff --git a/users/aspen/xanthous/src/Xanthous/Messages.hs b/users/aspen/xanthous/src/Xanthous/Messages.hs
new file mode 100644
index 000000000000..c273d650821b
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Messages.hs
@@ -0,0 +1,114 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Messages
+  ( Message(..)
+  , resolve
+  , MessageMap(..)
+  , lookupMessage
+
+    -- * Game messages
+  , messages
+  , render
+  , render_
+  , lookup
+  , message
+  , message_
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude hiding (lookup)
+--------------------------------------------------------------------------------
+import           Control.Monad.Random.Class (MonadRandom)
+import           Data.Aeson (FromJSON, ToJSON, toJSON, object)
+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.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 =
+    frequency [ (10, Single <$> arbitrary)
+              , (1, Choice <$> arbitrary)
+              ]
+  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
+
+-- | Render a message with an empty set of params
+render_ :: (MonadRandom m) => Message -> m Text
+render_ msg = render msg $ object []
+
+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/aspen/xanthous/src/Xanthous/Messages/Template.hs b/users/aspen/xanthous/src/Xanthous/Messages/Template.hs
new file mode 100644
index 000000000000..5176880355f4
--- /dev/null
+++ b/users/aspen/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 . pack . 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/aspen/xanthous/src/Xanthous/Monad.hs b/users/aspen/xanthous/src/Xanthous/Monad.hs
new file mode 100644
index 000000000000..db602de56f3a
--- /dev/null
+++ b/users/aspen/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/aspen/xanthous/src/Xanthous/Orphans.hs b/users/aspen/xanthous/src/Xanthous/Orphans.hs
new file mode 100644
index 000000000000..66004163f6ea
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Orphans.hs
@@ -0,0 +1,495 @@
+{-# LANGUAGE RecordWildCards       #-}
+{-# LANGUAGE StandaloneDeriving    #-}
+{-# LANGUAGE UndecidableInstances  #-}
+{-# LANGUAGE PackageImports        #-}
+{-# OPTIONS_GHC -Wno-orphans       #-}
+{-# OPTIONS_GHC -Wno-type-defaults #-}
+--------------------------------------------------------------------------------
+module Xanthous.Orphans
+  ( ppTemplate
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding (elements, (.=))
+--------------------------------------------------------------------------------
+import           Data.Aeson hiding (Key)
+import qualified Data.Aeson.KeyMap as KM
+import           Data.Aeson.Types (typeMismatch)
+import           Data.List.NonEmpty (NonEmpty(..))
+import qualified Graphics.Vty.Input
+import           Graphics.Vty.Attributes
+import           Brick.Widgets.Edit
+import           Data.Text.Zipper.Generic (GenericTextZipper)
+import           Brick.Widgets.Core (getName)
+import           System.Random.Internal (StdGen (..))
+import           System.Random.SplitMix (SMGen ())
+import           Test.QuickCheck
+-- import           Test.QuickCheck.Arbitrary.Generic (Arg ())
+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 qualified Data.Interval as Interval
+import           Data.Interval ( Interval, Extended (..), Boundary (..)
+                               , lowerBound', upperBound', (<=..<), (<=..<=)
+                               , interval)
+import           Test.QuickCheck.Checkers (EqProp ((=-=)))
+--------------------------------------------------------------------------------
+import           Xanthous.Util.JSON
+import           Xanthous.Util.QuickCheck
+import           Xanthous.Util (EqEqProp(EqEqProp))
+import qualified Graphics.Vty.Input.Events
+--------------------------------------------------------------------------------
+
+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 = scale (`div` 10) $ sized node
+    where
+      node n | n > 0 = oneof $ leaves ++ branches (n `div` 4)
+      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 = scale (`div` 8) $ 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
+
+deriving via (EqEqProp Attr) instance EqProp Attr
+
+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
+
+deriving anyclass instance Hashable Graphics.Vty.Input.Events.Key
+deriving anyclass instance Hashable Graphics.Vty.Input.Events.Modifier
+
+--------------------------------------------------------------------------------
+
+instance (SemiSequence a, Arbitrary (Element a), Arbitrary a)
+         => Arbitrary (NonNull a) where
+  arbitrary = ncons <$> arbitrary <*> arbitrary
+
+instance ToJSON a => ToJSON (NonNull a) where
+  toJSON = toJSON . toNullable
+
+instance (FromJSON a, MonoFoldable a) => FromJSON (NonNull a) where
+  parseJSON = maybe (fail "Found empty list") pure . fromNullable <=< parseJSON
+
+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` ()
+
+deriving via (ReadShowJSON SMGen) instance ToJSON SMGen
+deriving via (ReadShowJSON SMGen) instance FromJSON SMGen
+
+instance ToJSON StdGen where
+  toJSON = toJSON . unStdGen
+  toEncoding = toEncoding . unStdGen
+
+instance FromJSON StdGen where
+  parseJSON = fmap StdGen . parseJSON
+
+--------------------------------------------------------------------------------
+
+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
+
+instance Function StdGen where
+  function = functionMap unStdGen StdGen
+
+instance Function SMGen where
+  function = functionShow
+
+--------------------------------------------------------------------------------
+
+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)
+
+--------------------------------------------------------------------------------
+
+instance CoArbitrary Boundary
+instance Function Boundary
+
+instance Arbitrary a => Arbitrary (Extended a) where
+  arbitrary = oneof [ pure NegInf
+                    , pure PosInf
+                    , Finite <$> arbitrary
+                    ]
+
+instance CoArbitrary a => CoArbitrary (Extended a) where
+  coarbitrary NegInf = variant 1
+  coarbitrary PosInf = variant 2
+  coarbitrary (Finite x) = variant 3 . coarbitrary x
+
+instance (Function a) => Function (Extended a) where
+  function = functionMap g h
+    where
+     g NegInf = Left True
+     g (Finite a) = Right a
+     g PosInf = Left False
+     h (Left False) = PosInf
+     h (Left True) = NegInf
+     h (Right a) = Finite a
+
+instance ToJSON a => ToJSON (Extended a) where
+  toJSON NegInf = String "NegInf"
+  toJSON PosInf = String "PosInf"
+  toJSON (Finite x) = toJSON x
+
+instance FromJSON a => FromJSON (Extended a) where
+  parseJSON (String "NegInf") = pure NegInf
+  parseJSON (String "PosInf") = pure PosInf
+  parseJSON val               = Finite <$> parseJSON val
+
+instance (EqProp a, Show a) => EqProp (Extended a) where
+  NegInf =-= NegInf = property True
+  PosInf =-= PosInf = property True
+  (Finite x) =-= (Finite y) = x =-= y
+  x =-= y = counterexample (show x <> " /= " <> show y) False
+
+instance Arbitrary Interval.Boundary where
+  arbitrary = elements [ Interval.Open , Interval.Closed ]
+
+instance (Ord r, Arbitrary r) => Arbitrary (Interval r) where
+  arbitrary = do
+    lower <- arbitrary
+    upper <- arbitrary
+    pure $ (if upper < lower then flip else id)
+      Interval.interval
+      lower
+      upper
+
+instance CoArbitrary a => CoArbitrary (Interval a) where
+  coarbitrary int = coarbitrary (lowerBound' int) . coarbitrary (upperBound' int)
+
+instance (Function a, Ord a) => Function (Interval a) where
+  function = functionMap g h
+    where
+      g = lowerBound' &&& upperBound'
+      h = uncurry interval
+
+deriving via (EqEqProp (Interval a)) instance Eq a => (EqProp (Interval a))
+
+instance ToJSON a => ToJSON (Interval a) where
+  toJSON x = Array . fromList $
+    [ object [ lowerKey .= lowerVal ]
+    , object [ upperKey .= upperVal ]
+    ]
+    where
+      (lowerVal, lowerBoundary) = lowerBound' x
+      (upperVal, upperBoundary) = upperBound' x
+      upperKey = boundaryToKey upperBoundary
+      lowerKey = boundaryToKey lowerBoundary
+      boundaryToKey Open = "Excluded"
+      boundaryToKey Closed = "Included"
+
+instance forall a. (FromJSON a, Ord a) => FromJSON (Interval a) where
+  parseJSON x =
+    boundPairWithBoundary x
+      <|> boundPairWithoutBoundary x
+      <|> singleVal x
+    where
+      boundPairWithBoundary = withArray "Bound pair" $ \arr -> do
+        checkLength arr
+        lower <- parseBound $ arr ^?! ix 0
+        upper <- parseBound $ arr ^?! ix 1
+        pure $ interval lower upper
+      parseBound = withObject "Bound" $ \obj -> do
+        when (KM.size obj /= 1) $ fail "Expected an object with a single key"
+        let [(k, v)] = obj ^@.. ifolded
+        boundary <- case k of
+          "Excluded" -> pure Open
+          "Open"     -> pure Open
+          "Included" -> pure Closed
+          "Closed"   -> pure Closed
+          _          -> fail "Invalid boundary specification"
+        val <- parseJSON v
+        pure (val, boundary)
+      boundPairWithoutBoundary = withArray "Bound pair" $ \arr -> do
+        checkLength arr
+        lower <- parseJSON $ arr ^?! ix 0
+        upper <- parseJSON $ arr ^?! ix 1
+        pure $ lower <=..< upper
+      singleVal v = do
+        val <- parseJSON v
+        pure $ val <=..<= val
+      checkLength arr =
+        when (length arr /= 2) $ fail "Expected array of length 2"
+
+--------------------------------------------------------------------------------
+
+deriving anyclass instance NFData Graphics.Vty.Input.Key
+deriving anyclass instance NFData Graphics.Vty.Input.Modifier
diff --git a/users/aspen/xanthous/src/Xanthous/Physics.hs b/users/aspen/xanthous/src/Xanthous/Physics.hs
new file mode 100644
index 000000000000..37530cbbc21b
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Physics.hs
@@ -0,0 +1,71 @@
+--------------------------------------------------------------------------------
+module Xanthous.Physics
+  ( throwDistance
+  , bluntThrowDamage
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+import Xanthous.Data
+       ( Meters
+       , (:**:)(..)
+       , Square
+       , Grams
+       , (|*|)
+       , (|/|)
+       , Hitpoints
+       , Per (..)
+       , squared
+       , Uno(..), (|+|)
+       )
+--------------------------------------------------------------------------------
+
+-- university shotputter can put a 16 lb shot about 14 meters
+-- ≈ 7.25 kg 14 meters
+-- 14m = x / (7.25kg × y + z)²
+-- 14m = x / (7250g × y + z)²
+--
+-- we don't want to scale down too much:
+--
+-- 10 kg 10 meters
+-- = 10000 g 10 meters
+--
+-- 15 kg w meters
+-- = 15000 g w meters
+--
+-- 14m = x / (7250g × y + z)²
+-- 10m = x / (10000g × y + z)²
+-- wm = x / (15000g × y + z)²
+--
+-- w≈0.527301 ∧ y≈0.000212178 sqrt(x) ∧ z≈1.80555 sqrt(x) ∧ 22824.1 sqrt(x)!=0
+--
+-- x = 101500
+-- y = 0.0675979
+-- z = 575.231
+--
+
+-- TODO make this dynamic
+strength :: Meters :**: Square Grams
+strength = Times 10150000
+
+yCoeff :: Uno Double
+yCoeff = Uno 0.0675979
+
+zCoeff :: Uno Double
+zCoeff = Uno 575.231
+
+-- | Calculate the maximum distance an object with the given weight can be
+-- thrown
+throwDistance
+  :: Grams  -- ^ Weight of the object
+  -> Meters -- ^ Max distance thrown
+throwDistance weight = strength |/| squared (weight |*| yCoeff |+| zCoeff)
+
+-- | Returns the damage dealt by a blunt object with the given weight when
+-- thrown
+bluntThrowDamage
+  :: Grams
+  -> Hitpoints
+bluntThrowDamage weight = throwDamageRatio |*| weight
+  where
+    throwDamageRatio :: Hitpoints `Per` Grams
+    throwDamageRatio = Rate $ 1 / 5000
diff --git a/users/aspen/xanthous/src/Xanthous/Prelude.hs b/users/aspen/xanthous/src/Xanthous/Prelude.hs
new file mode 100644
index 000000000000..2cb4299303ba
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Prelude.hs
@@ -0,0 +1,48 @@
+--------------------------------------------------------------------------------
+module Xanthous.Prelude
+  ( module ClassyPrelude
+  , Type
+  , Constraint
+  , module GHC.TypeLits
+  , module Control.Lens
+  , module Data.Void
+  , module Control.Comonad
+  , module Witherable
+  , fail
+
+  , (&!)
+
+    -- * Classy-Prelude addons
+  , ninsertSet
+  , ndeleteSet
+  , toVector
+  ) where
+--------------------------------------------------------------------------------
+import ClassyPrelude hiding
+  ( return, (<|), unsnoc, uncons, cons, snoc, index, (<.>), Index, say
+  , catMaybes, filter, mapMaybe, hashNub, ordNub
+  , Memoized, runMemoized
+  )
+import Data.Kind
+import GHC.TypeLits hiding (Text)
+import Control.Lens hiding (levels, Level)
+import Data.Void
+import Control.Comonad
+import Witherable
+import Control.Monad.Fail (fail)
+--------------------------------------------------------------------------------
+
+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
+
+infixl 1 &!
+(&!) :: a -> (a -> b) -> b
+(&!) = flip ($!)
diff --git a/users/aspen/xanthous/src/Xanthous/Random.hs b/users/aspen/xanthous/src/Xanthous/Random.hs
new file mode 100644
index 000000000000..329b321b8bda
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Random.hs
@@ -0,0 +1,186 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+--------------------------------------------------------------------------------
+module Xanthous.Random
+  ( Choose(..)
+  , ChooseElement(..)
+  , Weighted(..)
+  , evenlyWeighted
+  , weightedBy
+  , subRand
+  , chance
+  , chooseSubset
+  , chooseRange
+  , FiniteInterval(..)
+  ) 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.Functor.Compose
+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
+import           Data.Interval ( Interval, lowerBound', Extended (Finite)
+                               , upperBound', Boundary (Closed), lowerBound, upperBound
+                               )
+--------------------------------------------------------------------------------
+
+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))
+  deriving (Functor, Foldable) via (t `Compose` (,) w)
+
+deriving newtype instance Eq (t (w, a)) => Eq (Weighted w t a)
+deriving newtype instance Show (t (w, a)) => Show (Weighted w t a)
+deriving newtype instance NFData (t (w, a)) => NFData (Weighted w t a)
+
+instance Traversable t => Traversable (Weighted w t) where
+  traverse f (Weighted twa) = Weighted <$> (traverse . traverse) f twa
+
+evenlyWeighted :: [a] -> Weighted Int [] a
+evenlyWeighted = Weighted . itoList
+
+-- | Weight the elements of some functor by a function. Larger values of 'w' per
+-- its 'Ord' instance will be more likely to be generated
+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
+
+-- | Choose a random subset of *about* @w@ of the elements of the given
+-- 'Witherable' structure
+chooseSubset :: ( Num w, Ord w, Distribution Uniform w, Excludable w
+               , Witherable t
+               , MonadRandom m
+               ) => w -> t a -> m (t a)
+chooseSubset = filterA . const . chance
+
+-- | Choose a random @n@ in the given interval
+chooseRange
+  :: ( MonadRandom m
+    , Distribution Uniform n
+    , Enum n
+    , Bounded n
+    , Ord n
+    )
+  => Interval n
+  -> m (Maybe n)
+chooseRange int = traverse sample distribution
+  where
+    (lower, lowerBoundary) = lowerBound' int
+    lowerR = case lower of
+      Finite x -> if lowerBoundary == Closed
+                 then x
+                 else succ x
+      _ -> minBound
+    (upper, upperBoundary) = upperBound' int
+    upperR = case upper of
+      Finite x -> if upperBoundary == Closed
+                 then x
+                 else pred x
+      _ -> maxBound
+    distribution
+      | lowerR <= upperR = Just $ Uniform lowerR upperR
+      | otherwise = Nothing
+
+instance ( Distribution Uniform n
+         , Enum n
+         , Bounded n
+         , Ord n
+         )
+         => Choose (Interval n) where
+  type RandomResult (Interval n) = n
+  choose = fmap (fromMaybe $ error "Invalid interval") . chooseRange
+
+newtype FiniteInterval a
+  = FiniteInterval { unwrapFiniteInterval :: (Interval a) }
+
+instance ( Distribution Uniform n
+         , Ord n
+         )
+         => Choose (FiniteInterval n) where
+  type RandomResult (FiniteInterval n) = n
+  -- TODO broken with open/closed right now
+  choose
+    = sample
+    . uncurry Uniform
+    . over both getFinite
+    . (lowerBound &&& upperBound)
+    . unwrapFiniteInterval
+    where
+      getFinite (Finite x) = x
+      getFinite _ = error "Infinite value"
+
+--------------------------------------------------------------------------------
+
+bools :: NonEmpty Bool
+bools = True :| [False]
diff --git a/users/aspen/xanthous/src/Xanthous/Util.hs b/users/aspen/xanthous/src/Xanthous/Util.hs
new file mode 100644
index 000000000000..f918340f055b
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Util.hs
@@ -0,0 +1,351 @@
+{-# 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
+  , removeFirst
+  , maximum1
+  , minimum1
+
+    -- * Combinators
+  , times, times_, endoTimes
+
+    -- * State utilities
+  , modifyK, modifyKL, useListOf
+
+    -- * Type-level programming utils
+  , KnownBool(..)
+
+    -- *
+  , AlphaChar(..)
+  ) 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
+import           Control.Monad.State.Class
+import           Control.Monad.State (evalState)
+--------------------------------------------------------------------------------
+
+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
+
+-- | Returns whether the third argument is in the range given by the first two
+-- arguments, inclusive
+--
+-- >>> between (0 :: Int) 2 2
+-- True
+--
+-- >>> between (0 :: Int) 2 3
+-- False
+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)
+
+-- | Remove the first element in a sequence that matches a given predicate
+removeFirst :: IsSequence seq => (Element seq -> Bool) -> seq -> seq
+removeFirst p
+  = flip evalState False
+  . filterM (\x -> do
+                found <- get
+                let matches = p x
+                when matches $ put True
+                pure $ found || not matches)
+
+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)
+
+-- | Multiply an endomorphism by an integral
+--
+-- >>> endoTimes (4 :: Int) succ (5 :: Int)
+-- 9
+endoTimes :: Integral n => n -> (a -> a) -> a -> a
+endoTimes n f = appEndo $ stimes n (Endo f)
+
+--------------------------------------------------------------------------------
+
+-- | 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
+
+--------------------------------------------------------------------------------
+
+-- | Modify some monadic state via the application of a kleisli endomorphism on
+-- the state itself
+--
+-- Note that any changes made to the state during execution of @k@ will be
+-- overwritten
+--
+-- @@
+-- modifyK pure === pure ()
+-- @@
+modifyK :: MonadState s m => (s -> m s) -> m ()
+modifyK k = get >>= k >>= put
+
+-- | Modify some monadic state via the application of a kleisli endomorphism on
+-- the target of a lens
+--
+-- Note that any changes made to the state during execution of @k@ will be
+-- overwritten
+--
+-- @@
+-- modifyKL id pure === pure ()
+-- @@
+modifyKL :: MonadState s m => LensLike m s s a b -> (a -> m b) -> m ()
+modifyKL l k = get >>= traverseOf l k >>= put
+
+-- | Use a list of all the targets of a 'Fold' in the current state
+--
+-- @@
+-- evalState (useListOf folded) === toList
+-- @@
+useListOf :: MonadState s m => Getting (Endo [a]) s a -> m [a]
+useListOf = gets . toListOf
+
+--------------------------------------------------------------------------------
+
+-- | A newtype wrapper around 'Char' whose 'Enum' and 'Bounded' instances only
+-- include the characters @[a-zA-Z]@
+--
+-- >>> succ (AlphaChar 'z')
+-- 'A'
+newtype AlphaChar = AlphaChar { getAlphaChar :: Char }
+  deriving stock Show
+  deriving (Eq, Ord) via Char
+
+instance Enum AlphaChar where
+  toEnum n
+    | between 0 25 n
+    = AlphaChar . toEnum $ n + fromEnum 'a'
+    | between 26 51 n
+    = AlphaChar . toEnum $ n - 26 + fromEnum 'A'
+    | otherwise
+    = error $ "Tag " <> show n <> " out of range [0, 51] for enum AlphaChar"
+  fromEnum (AlphaChar chr)
+    | between 'a' 'z' chr
+    = fromEnum chr - fromEnum 'a'
+    | between 'A' 'Z' chr
+    = fromEnum chr - fromEnum 'A'
+    | otherwise
+    = error $ "Invalid value for alpha char: " <> show chr
+
+instance Bounded AlphaChar where
+  minBound = AlphaChar 'a'
+  maxBound = AlphaChar 'Z'
diff --git a/users/aspen/xanthous/src/Xanthous/Util/Comonad.hs b/users/aspen/xanthous/src/Xanthous/Util/Comonad.hs
new file mode 100644
index 000000000000..9e158cc8e2d4
--- /dev/null
+++ b/users/aspen/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/aspen/xanthous/src/Xanthous/Util/Graph.hs b/users/aspen/xanthous/src/Xanthous/Util/Graph.hs
new file mode 100644
index 000000000000..8e5c04f4bfa9
--- /dev/null
+++ b/users/aspen/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/aspen/xanthous/src/Xanthous/Util/Graphics.hs b/users/aspen/xanthous/src/Xanthous/Util/Graphics.hs
new file mode 100644
index 000000000000..0cb009f45ad0
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Util/Graphics.hs
@@ -0,0 +1,177 @@
+{-# 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)
+       => V2 i -- ^ center
+       -> i    -- ^ radius
+       -> [V2 i]
+circle (V2 x₀ y₀) radius
+  -- Four initial points, plus the generated points
+  = V2 x₀ (y₀ + radius)
+  : V2 x₀ (y₀ - radius)
+  : V2 (x₀ + radius) y₀
+  : V2 (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 (V2 x y)
+        = [ V2 (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 (V2 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 (V2 i)
+  }
+makeLenses ''FillState
+
+runFillState :: NonEmpty (V2 i) -> State (FillState i) a -> [V2 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)
+             => V2 i -- ^ center
+             -> i    -- ^ radius
+             -> [V2 i]
+filledCircle center radius =
+  case NE.nonEmpty (circle center 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 = V2 x y
+              next = V2 x $ succ y
+          whenM (use inCircle) $ result %= NE.cons pt
+
+          when (pt `elem` circumference && next `notElem` circumference)
+            $ inCircle %= not
+
+      where
+        (V2 minX minY, V2 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) => V2 i -> V2 i -> [V2 i]
+line pa@(V2 xa ya) pb@(V2 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 view _yx else id
+    [V2 x₁ y₁, V2 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 (V2 xTemp yTemp, (xTemp + 1, newY, newError))
+      where
+        tempError        = err + δy
+        (newY, newError) = if (2 * tempError) >= δx
+                           then (yTemp + ystep, tempError - δx)
+                           else (yTemp, tempError)
+{-# SPECIALIZE line :: V2 Int -> V2 Int -> [V2 Int] #-}
+{-# SPECIALIZE line :: V2 Word -> V2 Word -> [V2 Word] #-}
+
+straightLine :: (Num i, Ord i) => V2 i -> V2 i -> [V2 i]
+straightLine pa@(V2 xa _) pb@(V2 _ yb) = line pa midpoint ++ line midpoint pb
+  where midpoint = V2 xa yb
+
+delaunay
+  :: (Ord n, Fractional n)
+  => NonEmpty (V2 n, p)
+  -> [((V2 n, p), (V2 n, p))]
+delaunay
+  = map (over both fromPoint)
+  . Geometry.edgesAsPoints
+  . 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) => [V2 i] -> String
+renderBooleanGraphics [] = ""
+renderBooleanGraphics (pt : pts') = intercalate "\n" rows
+  where
+    rows = row <$> [minX..maxX]
+    row x = [minY..maxY] <&> \y -> if V2 x y `member` ptSet then 'X' else ' '
+    (V2 minX minY, V2 maxX maxY) = minmaxes pts
+    pts = pt :| pts'
+    ptSet :: Set (V2 i)
+    ptSet = setFromList $ toList pts
+
+showBooleanGraphics :: forall i. (Num i, Ord i, Enum i) => [V2 i] -> IO ()
+showBooleanGraphics = putStrLn . pack . renderBooleanGraphics
+
+minmaxes :: forall i. (Ord i) => NonEmpty (V2 i) -> (V2 i, V2 i)
+minmaxes xs =
+  ( V2 (minimum1Of (traverse1 . _x) xs)
+       (minimum1Of (traverse1 . _y) xs)
+  , V2 (maximum1Of (traverse1 . _x) xs)
+       (maximum1Of (traverse1 . _y) xs)
+  )
diff --git a/users/aspen/xanthous/src/Xanthous/Util/Inflection.hs b/users/aspen/xanthous/src/Xanthous/Util/Inflection.hs
new file mode 100644
index 000000000000..724f2339dd21
--- /dev/null
+++ b/users/aspen/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/aspen/xanthous/src/Xanthous/Util/JSON.hs b/users/aspen/xanthous/src/Xanthous/Util/JSON.hs
new file mode 100644
index 000000000000..91d1328e4a10
--- /dev/null
+++ b/users/aspen/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/aspen/xanthous/src/Xanthous/Util/Optparse.hs b/users/aspen/xanthous/src/Xanthous/Util/Optparse.hs
new file mode 100644
index 000000000000..dfa65372351d
--- /dev/null
+++ b/users/aspen/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/aspen/xanthous/src/Xanthous/Util/QuickCheck.hs b/users/aspen/xanthous/src/Xanthous/Util/QuickCheck.hs
new file mode 100644
index 000000000000..aa881b322779
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Util/QuickCheck.hs
@@ -0,0 +1,32 @@
+{-# 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
+--------------------------------------------------------------------------------
+
+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
diff --git a/users/aspen/xanthous/src/Xanthous/keybindings.yaml b/users/aspen/xanthous/src/Xanthous/keybindings.yaml
new file mode 100644
index 000000000000..cffb27cb03f6
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/keybindings.yaml
@@ -0,0 +1,22 @@
+q: Quit
+?: Help
+.: Wait
+C-p: PreviousMessage
+',': PickUp
+d: Drop
+o: Open
+c: Close
+;: Look
+e: Eat
+S: Save
+r: Read
+i: ShowInventory
+I: DescribeInventory
+w: Wield
+f: Fire
+'<': GoUp
+'>': GoDown
+R: Rest
+
+# Debug commands
+M-r: ToggleRevealAll
diff --git a/users/aspen/xanthous/src/Xanthous/messages.yaml b/users/aspen/xanthous/src/Xanthous/messages.yaml
new file mode 100644
index 000000000000..bc08ec1ad24d
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/messages.yaml
@@ -0,0 +1,161 @@
+welcome: Welcome to Xanthous, {{characterName}}! It's dangerous out there, why not stay inside? Press ? for help.
+dead:
+  - You have died...
+  - You die...
+  - You perish...
+  - You have perished...
+
+generic:
+  continue: Press enter to continue...
+
+save:
+  disabled: "Sorry, saving is currently disabled"
+  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}}
+  say:
+    creature:
+      visible: The {{creature.creatureType.name}} {{creature.creatureType.sayVerb}} "{{message}}"
+      invisible: You hear something yell "{{message}}" in the distance
+
+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? "
+  body:
+    knuckles:
+      calluses:
+      - You've started developing calluses on your knuckles from all the punching you've been doing.
+      - You've been fighting with your fists so much they're starting to develop calluses.
+
+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!
+  fistExtraSelfDamage:
+    - You hurt your already-bloody fists with the strike!
+    - Ouch! Your fists were already bleeding!
+  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:
+    natural: The {{creature.creatureType.name}} {{attackDescription}}.
+    genericWeapon: The {{creature.creatureType.name}} attacks you with its {{item.itemType.name}}.
+  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}}\""
+
+inventory:
+  describe:
+    select: Select an item in your inventory to describe
+    nothing: You aren't carrying anything
+
+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?
+  hand: Wield in which hand?
+  wielded: You wield the {{item.wieldedItem.itemType.name}} in {{hand}}
+
+fire:
+  nothing:
+    - You don't currently have anything you can throw
+    - You don't have anything to throw
+  zeroRange:
+    - That item is too heavy to throw!
+    - That's too heavy to throw
+    - You're not strong enough to throw that any meaningful distance
+  menu: What would you like to throw?
+  target: Choose a target
+  atRange:
+    - It's too heavy for you to throw any further than this
+  fired:
+    noTarget:
+      - You throw the {{item.itemType.name}} at the ground
+    noDamage:
+      - You throw the {{item.itemType.name}} at the {{creature.creatureType.name}}. It doesn't seem to care.
+      - You throw the {{item.itemType.name}} at the {{creature.creatureType.name}}. It doesn't seem to do anything.
+      - You throw the {{item.itemType.name}} at the {{creature.creatureType.name}}. It doesn't seem to hurt it.
+    someDamage:
+      - You throw the {{item.itemType.name}} at the {{creature.creatureType.name}}. It hits it on the head!.
+
+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.
+
+autocommands:
+  enemyInSight: There's a {{firstEntity.creatureType.name}} nearby!
+  resting: Resting...
+  doneResting: Done resting
+###
+
+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 ,.
diff --git a/users/aspen/xanthous/test/Spec.hs b/users/aspen/xanthous/test/Spec.hs
new file mode 100644
index 000000000000..51758d6a25ec
--- /dev/null
+++ b/users/aspen/xanthous/test/Spec.hs
@@ -0,0 +1,61 @@
+--------------------------------------------------------------------------------
+import           Test.Prelude
+--------------------------------------------------------------------------------
+import qualified Xanthous.CommandSpec
+import qualified Xanthous.Data.EntitiesSpec
+import qualified Xanthous.Data.EntityCharSpec
+import qualified Xanthous.Data.EntityMap.GraphicsSpec
+import qualified Xanthous.Data.EntityMapSpec
+import qualified Xanthous.Data.LevelsSpec
+import qualified Xanthous.Data.MemoSpec
+import qualified Xanthous.Data.NestedMapSpec
+import qualified Xanthous.DataSpec
+import qualified Xanthous.Entities.CommonSpec
+import qualified Xanthous.Entities.RawsSpec
+import qualified Xanthous.Entities.RawTypesSpec
+import qualified Xanthous.Entities.CharacterSpec
+import qualified Xanthous.GameSpec
+import qualified Xanthous.Game.StateSpec
+import qualified Xanthous.Game.PromptSpec
+import qualified Xanthous.Generators.Level.UtilSpec
+import qualified Xanthous.MessageSpec
+import qualified Xanthous.Messages.TemplateSpec
+import qualified Xanthous.OrphansSpec
+import qualified Xanthous.RandomSpec
+import qualified Xanthous.Util.GraphSpec
+import qualified Xanthous.Util.GraphicsSpec
+import qualified Xanthous.Util.InflectionSpec
+import qualified Xanthous.UtilSpec
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMainWithRerun test
+
+test :: TestTree
+test = testGroup "Xanthous"
+  [ Xanthous.CommandSpec.test
+  , Xanthous.Data.EntitiesSpec.test
+  , Xanthous.Data.EntityMap.GraphicsSpec.test
+  , Xanthous.Data.EntityMapSpec.test
+  , Xanthous.Data.LevelsSpec.test
+  , Xanthous.Data.MemoSpec.test
+  , Xanthous.Data.NestedMapSpec.test
+  , Xanthous.DataSpec.test
+  , Xanthous.Entities.CommonSpec.test
+  , Xanthous.Entities.RawsSpec.test
+  , Xanthous.Entities.CharacterSpec.test
+  , Xanthous.Entities.RawTypesSpec.test
+  , Xanthous.GameSpec.test
+  , Xanthous.Game.StateSpec.test
+  , Xanthous.Game.PromptSpec.test
+  , Xanthous.Generators.Level.UtilSpec.test
+  , Xanthous.MessageSpec.test
+  , Xanthous.Messages.TemplateSpec.test
+  , Xanthous.OrphansSpec.test
+  , Xanthous.RandomSpec.test
+  , Xanthous.Util.GraphSpec.test
+  , Xanthous.Util.GraphicsSpec.test
+  , Xanthous.Util.InflectionSpec.test
+  , Xanthous.UtilSpec.test
+  , Xanthous.Data.EntityCharSpec.test
+  ]
diff --git a/users/aspen/xanthous/test/Test/Prelude.hs b/users/aspen/xanthous/test/Test/Prelude.hs
new file mode 100644
index 000000000000..75c1ebf5e76a
--- /dev/null
+++ b/users/aspen/xanthous/test/Test/Prelude.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+--------------------------------------------------------------------------------
+module Test.Prelude
+  ( module Xanthous.Prelude
+  , module Test.Tasty
+  , module Test.Tasty.HUnit
+  , module Test.Tasty.QuickCheck
+  , module Test.Tasty.Ingredients.Rerun
+  , module Test.QuickCheck.Classes
+  , testBatch
+  , jsonRoundTrip
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding (assert, elements)
+--------------------------------------------------------------------------------
+import           Test.Tasty
+import           Test.Tasty.QuickCheck
+import           Test.Tasty.HUnit
+import           Test.Tasty.Ingredients.Rerun
+import           Test.QuickCheck.Classes
+import           Test.QuickCheck.Checkers (TestBatch, EqProp ((=-=)))
+import           Test.QuickCheck.Instances.ByteString ()
+--------------------------------------------------------------------------------
+import qualified Data.Aeson as JSON
+import           Data.Aeson (ToJSON, FromJSON)
+--------------------------------------------------------------------------------
+
+testBatch :: TestBatch -> TestTree
+testBatch (name, tests) = testGroup name $ uncurry testProperty <$> tests
+
+jsonRoundTrip
+  :: forall a. (ToJSON a, FromJSON a, EqProp a, Arbitrary a, Show a) => TestTree
+jsonRoundTrip = testProperty "JSON round trip" $ \(x :: a) ->
+  JSON.decode (JSON.encode x) =-= Just x
diff --git a/users/aspen/xanthous/test/Xanthous/CommandSpec.hs b/users/aspen/xanthous/test/Xanthous/CommandSpec.hs
new file mode 100644
index 000000000000..13f69a808d02
--- /dev/null
+++ b/users/aspen/xanthous/test/Xanthous/CommandSpec.hs
@@ -0,0 +1,40 @@
+--------------------------------------------------------------------------------
+module Xanthous.CommandSpec (main, test) where
+--------------------------------------------------------------------------------
+import           Test.Prelude
+--------------------------------------------------------------------------------
+import           Xanthous.Command
+--------------------------------------------------------------------------------
+import           Data.Aeson (fromJSON, Value(String))
+import qualified Data.Aeson as A
+import           Graphics.Vty.Input (Key(..), Modifier(..))
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.CommandSpec"
+  [ testGroup "keybindings"
+    [ testCase "all are valid" $ keybindings `deepseq` pure ()
+    , testProperty "all non-move commands are bound" $ \cmd ->
+        let isn'tMove = case cmd of
+                          Move _ -> False
+                          StartAutoMove _ -> False
+                          _ -> True
+        in isn'tMove ==> member cmd commands
+    ]
+  , testGroup "instance FromJSON Keybinding" $
+    [ ("q", Keybinding (KChar 'q') [])
+    , ("<up>", Keybinding KUp [])
+    , ("<left>", Keybinding KLeft [])
+    , ("<right>", Keybinding KRight [])
+    , ("<down>", Keybinding KDown [])
+    , ("S-q", Keybinding (KChar 'q') [MShift])
+    , ("C-S-q", Keybinding (KChar 'q') [MCtrl, MShift])
+    , ("m-<UP>", Keybinding KUp [MMeta])
+    , ("S", Keybinding (KChar 'S') [])
+    ] <&> \(s, kb) ->
+      testCase (fromString $ unpack s <> " -> " <> show kb)
+       $ fromJSON (String s) @?= A.Success kb
+  ]
diff --git a/users/aspen/xanthous/test/Xanthous/Data/EntitiesSpec.hs b/users/aspen/xanthous/test/Xanthous/Data/EntitiesSpec.hs
new file mode 100644
index 000000000000..e403503743c0
--- /dev/null
+++ b/users/aspen/xanthous/test/Xanthous/Data/EntitiesSpec.hs
@@ -0,0 +1,28 @@
+--------------------------------------------------------------------------------
+module Xanthous.Data.EntitiesSpec (main, test) where
+--------------------------------------------------------------------------------
+import           Test.Prelude
+--------------------------------------------------------------------------------
+import qualified Data.Aeson as JSON
+--------------------------------------------------------------------------------
+import           Xanthous.Data.Entities
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Data.Entities"
+  [ testGroup "Collision"
+    [ testProperty "JSON round-trip" $ \(c :: Collision) ->
+        JSON.decode (JSON.encode c) === Just c
+    , testGroup "JSON encoding examples"
+      [ testCase "Stop" $ JSON.encode Stop @?= "\"Stop\""
+      , testCase "Combat" $ JSON.encode Combat @?= "\"Combat\""
+      ]
+    ]
+  , testGroup "EntityAttributes"
+    [ testProperty "JSON round-trip" $ \(ea :: EntityAttributes) ->
+        JSON.decode (JSON.encode ea) === Just ea
+    ]
+  ]
diff --git a/users/aspen/xanthous/test/Xanthous/Data/EntityCharSpec.hs b/users/aspen/xanthous/test/Xanthous/Data/EntityCharSpec.hs
new file mode 100644
index 000000000000..9e8024c9d223
--- /dev/null
+++ b/users/aspen/xanthous/test/Xanthous/Data/EntityCharSpec.hs
@@ -0,0 +1,18 @@
+--------------------------------------------------------------------------------
+module Xanthous.Data.EntityCharSpec where
+--------------------------------------------------------------------------------
+import           Test.Prelude
+--------------------------------------------------------------------------------
+import qualified Data.Aeson as JSON
+--------------------------------------------------------------------------------
+import           Xanthous.Data.EntityChar
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Data.EntityChar"
+  [ testProperty "JSON round-trip" $ \(ec :: EntityChar) ->
+      JSON.decode (JSON.encode ec) === Just ec
+  ]
diff --git a/users/aspen/xanthous/test/Xanthous/Data/EntityMap/GraphicsSpec.hs b/users/aspen/xanthous/test/Xanthous/Data/EntityMap/GraphicsSpec.hs
new file mode 100644
index 000000000000..fd37548ce864
--- /dev/null
+++ b/users/aspen/xanthous/test/Xanthous/Data/EntityMap/GraphicsSpec.hs
@@ -0,0 +1,57 @@
+--------------------------------------------------------------------------------
+module Xanthous.Data.EntityMap.GraphicsSpec (main, test) where
+--------------------------------------------------------------------------------
+import Test.Prelude
+import Data.Aeson
+--------------------------------------------------------------------------------
+import Xanthous.Game.State
+import Xanthous.Data
+import Xanthous.Data.EntityMap
+import Xanthous.Data.EntityMap.Graphics
+import Xanthous.Entities.Environment (Wall(..))
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Data.EntityMap.Graphics"
+  [ testGroup "visiblePositions"
+    [ testProperty "one step in each cardinal direction is always visible"
+      $ \pos (Cardinal dir) (Positive r) (wallPositions :: Set Position)->
+          pos `notMember` wallPositions ==>
+          let em = review _EntityMap . map (, Wall) . toList $ wallPositions
+              em' = em & atPosition (move dir pos) %~ (Wall <|)
+              poss = visiblePositions pos r em'
+          in counterexample ("visiblePositions: " <> show poss)
+             $ move dir pos `member` poss
+    , testGroup "bugs"
+      [ testCase "non-contiguous bug 1"
+        $ let charPos = Position 20 20
+              gormlakPos = Position 17 19
+              em = insertAt gormlakPos TestEntity
+                   . insertAt charPos TestEntity
+                   $ mempty
+              visPositions = visiblePositions charPos 12 em
+          in (gormlakPos `member` visPositions) @?
+             ( "not ("
+             <> show gormlakPos <> " `member` "
+             <> show visPositions
+             <> ")"
+             )
+      ]
+    ]
+  ]
+
+--------------------------------------------------------------------------------
+
+data TestEntity = TestEntity
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (ToJSON, FromJSON, NFData)
+
+instance Brain TestEntity where
+  step _ = pure
+instance Draw TestEntity
+instance Entity TestEntity where
+  description _ = ""
+  entityChar _ = "e"
diff --git a/users/aspen/xanthous/test/Xanthous/Data/EntityMapSpec.hs b/users/aspen/xanthous/test/Xanthous/Data/EntityMapSpec.hs
new file mode 100644
index 000000000000..7c5cad019616
--- /dev/null
+++ b/users/aspen/xanthous/test/Xanthous/Data/EntityMapSpec.hs
@@ -0,0 +1,69 @@
+{-# LANGUAGE ApplicativeDo #-}
+--------------------------------------------------------------------------------
+module Xanthous.Data.EntityMapSpec where
+--------------------------------------------------------------------------------
+import           Test.Prelude
+--------------------------------------------------------------------------------
+import qualified Data.Aeson as JSON
+--------------------------------------------------------------------------------
+import           Xanthous.Data.EntityMap
+import           Xanthous.Data (Positioned(..))
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = localOption (QuickCheckTests 20)
+  $ testGroup "Xanthous.Data.EntityMap"
+  [ testBatch $ monoid @(EntityMap Int) mempty
+  , testGroup "Deduplicate"
+    [ testGroup "Semigroup laws"
+      [ testProperty "associative" $ \(a :: Deduplicate (EntityMap Int)) b c ->
+          a <> (b <> c) === (a <> b) <> c
+      ]
+    ]
+  , testGroup "Eq laws"
+    [ testProperty "reflexivity" $ \(em :: EntityMap Int) ->
+        em == em
+    , testProperty "symmetric" $ \(em₁ :: EntityMap Int) em₂ ->
+        (em₁ == em₂) == (em₂ == em₁)
+    , testProperty "transitive" $ \(em₁ :: EntityMap Int) em₂ em₃ ->
+        if (em₁ == em₂ && em₂ == em₃)
+        then (em₁ == em₃)
+        else True
+    ]
+  , testGroup "JSON encoding/decoding"
+    [ testProperty "round-trips" $ \(em :: EntityMap Int) ->
+        let em' = JSON.decode (JSON.encode em)
+        in counterexample (show (em' ^? _Just . lastID, em ^. lastID
+                                , em' ^? _Just . byID == em ^. byID . re _Just
+                                , em' ^? _Just . byPosition == em ^. byPosition . re _Just
+                                , em' ^? _Just . _EntityMap == em ^. _EntityMap . re _Just
+                                ))
+           $ em' === Just em
+    , testProperty "Preserves IDs" $ \(em :: EntityMap Int) ->
+        let Just em' = JSON.decode $ JSON.encode em
+        in toEIDsAndPositioned em' === toEIDsAndPositioned em
+    ]
+
+  , localOption (QuickCheckTests 50)
+  $ testGroup "atPosition"
+    [ testProperty "setget" $ \pos (em :: EntityMap Int) es ->
+        view (atPosition pos) (set (atPosition pos) es em) === es
+    , testProperty "getset" $ \pos (em :: EntityMap Int) ->
+        set (atPosition pos) (view (atPosition pos) em) em === em
+    , testProperty "setset" $ \pos (em :: EntityMap Int) es ->
+        (set (atPosition pos) es . set (atPosition pos) es) em
+        ===
+        set (atPosition pos) es em
+      -- testProperty "lens laws" $ \pos -> isLens $ atPosition @Int pos
+    , testProperty "preserves IDs" $ \(em :: EntityMap Int) e1 e2 p ->
+        let (eid, em') = insertAtReturningID p e1 em
+            em'' = em' & atPosition p %~ (e2 <|)
+        in
+          counterexample ("em': " <> show em')
+          . counterexample ("em'': " <> show em'')
+          $ em'' ^. at eid === Just (Positioned p e1)
+    ]
+  ]
diff --git a/users/aspen/xanthous/test/Xanthous/Data/LevelsSpec.hs b/users/aspen/xanthous/test/Xanthous/Data/LevelsSpec.hs
new file mode 100644
index 000000000000..a7528331627d
--- /dev/null
+++ b/users/aspen/xanthous/test/Xanthous/Data/LevelsSpec.hs
@@ -0,0 +1,66 @@
+--------------------------------------------------------------------------------
+module Xanthous.Data.LevelsSpec (main, test) where
+--------------------------------------------------------------------------------
+import Test.Prelude
+--------------------------------------------------------------------------------
+import qualified Data.Aeson as JSON
+--------------------------------------------------------------------------------
+import Xanthous.Util (between)
+import Xanthous.Data.Levels
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Data.Levels"
+  [ testGroup "current"
+    [ testProperty "view is extract" $ \(levels :: Levels Int) ->
+        levels ^. current === extract levels
+    , testProperty "set replaces current" $ \(levels :: Levels Int) new ->
+        extract (set current new levels) === new
+    , testProperty "set extract is id" $ \(levels :: Levels Int) ->
+        set current (extract levels) levels === levels
+    , testProperty "set y ∘ set x ≡ set y" $ \(levels :: Levels Int) x y ->
+        set current y (set current x levels) === set current y levels
+    ]
+  , localOption (QuickCheckTests 20)
+  $ testBatch $ semigroup @(Levels Int) (error "unused", 1 :: Int)
+  , testGroup "next/prev"
+    [ testGroup "nextLevel"
+      [ testProperty "seeks forwards" $ \(levels :: Levels Int) genned ->
+          (pos . runIdentity . nextLevel (Identity genned) $ levels)
+          === pos levels + 1
+      , testProperty "maintains the invariant" $ \(levels :: Levels Int) genned ->
+          let levels' = runIdentity . nextLevel (Identity genned) $ levels
+          in between 0 (toEnum $ length levels') $ pos levels'
+      , testProperty "extract is total" $ \(levels :: Levels Int) genned ->
+          let levels' = runIdentity . nextLevel (Identity genned) $ levels
+          in total $ extract levels'
+      , testProperty "uses the generated level as the next level"
+        $ \(levels :: Levels Int) genned ->
+          let levels' = seek (toEnum $ length levels - 1) levels
+              levels'' = runIdentity . nextLevel (Identity genned) $ levels'
+          in counterexample (show levels'')
+             $ extract levels'' === genned
+      ]
+    , testGroup "prevLevel"
+      [ testProperty "seeks backwards" $ \(levels :: Levels Int) ->
+          case prevLevel levels of
+            Nothing -> property Discard
+            Just levels' -> pos levels' === pos levels - 1
+      , testProperty "maintains the invariant" $ \(levels :: Levels Int) ->
+          case prevLevel levels of
+            Nothing -> property Discard
+            Just levels' -> property $ between 0 (toEnum $ length levels') $ pos levels'
+      , testProperty "extract is total" $ \(levels :: Levels Int) ->
+          case prevLevel levels of
+            Nothing -> property Discard
+            Just levels' -> total $ extract levels'
+      ]
+    ]
+  , testGroup "JSON"
+    [ testProperty "toJSON/parseJSON round-trip" $ \(levels :: Levels Int) ->
+        JSON.decode (JSON.encode levels) === Just levels
+    ]
+  ]
diff --git a/users/aspen/xanthous/test/Xanthous/Data/MemoSpec.hs b/users/aspen/xanthous/test/Xanthous/Data/MemoSpec.hs
new file mode 100644
index 000000000000..ad81f1984d8f
--- /dev/null
+++ b/users/aspen/xanthous/test/Xanthous/Data/MemoSpec.hs
@@ -0,0 +1,19 @@
+--------------------------------------------------------------------------------
+module Xanthous.Data.MemoSpec (main, test) where
+--------------------------------------------------------------------------------
+import Test.Prelude
+import Test.QuickCheck.Instances.Text ()
+--------------------------------------------------------------------------------
+import Xanthous.Data.Memo
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Data.MemoSpec"
+  [ testGroup "getMemoized"
+    [ testProperty "when key matches" $ \k v ->
+        getMemoized @Int @Int k (memoizeWith k v) === Just v
+    ]
+  ]
diff --git a/users/aspen/xanthous/test/Xanthous/Data/NestedMapSpec.hs b/users/aspen/xanthous/test/Xanthous/Data/NestedMapSpec.hs
new file mode 100644
index 000000000000..acf7a67268f4
--- /dev/null
+++ b/users/aspen/xanthous/test/Xanthous/Data/NestedMapSpec.hs
@@ -0,0 +1,20 @@
+--------------------------------------------------------------------------------
+module Xanthous.Data.NestedMapSpec (main, test) where
+--------------------------------------------------------------------------------
+import           Test.Prelude
+--------------------------------------------------------------------------------
+import           Test.QuickCheck.Instances.Semigroup ()
+--------------------------------------------------------------------------------
+import qualified Xanthous.Data.NestedMap as NM
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Data.NestedMap"
+  [ testProperty "insert/lookup" $ \nm ks v ->
+      let nm' = NM.insert ks v nm
+      in counterexample ("inserted: " <> show nm')
+         $ NM.lookup @Map @Int @Int ks nm' === Just (NM.Val v)
+  ]
diff --git a/users/aspen/xanthous/test/Xanthous/DataSpec.hs b/users/aspen/xanthous/test/Xanthous/DataSpec.hs
new file mode 100644
index 000000000000..9e67505ba928
--- /dev/null
+++ b/users/aspen/xanthous/test/Xanthous/DataSpec.hs
@@ -0,0 +1,109 @@
+--------------------------------------------------------------------------------
+module Xanthous.DataSpec (main, test) where
+--------------------------------------------------------------------------------
+import Test.Prelude hiding (Right, Left, Down, toList, all)
+import Data.Group
+import Data.Foldable (toList, all)
+--------------------------------------------------------------------------------
+import Xanthous.Data
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Data"
+  [ testGroup "Position"
+    [ testBatch $ monoid @Position mempty
+    , testProperty "group laws" $ \(pos :: Position) ->
+        pos <> invert pos == mempty && invert pos <> pos == mempty
+    , testGroup "stepTowards laws"
+      [ testProperty "takes only one step" $ \src tgt ->
+          src /= tgt ==>
+            isUnit (src `diffPositions` (src `stepTowards` tgt))
+      -- , testProperty "moves in the right direction" $ \src tgt ->
+      --     stepTowards src tgt == move (directionOf src tgt) src
+      ]
+    , testProperty "directionOf laws" $ \pos dir ->
+        directionOf pos (move dir pos) == dir
+    , testProperty "diffPositions is add inverse" $ \(pos₁ :: Position) pos₂ ->
+        diffPositions pos₁ pos₂ == addPositions pos₁ (invert pos₂)
+    , testGroup "isUnit"
+      [ testProperty "double direction is never unit" $ \dir ->
+          not . isUnit $ move dir (asPosition dir)
+      , testCase "examples" $ do
+          isUnit (Position @Int 1 1) @? "not . isUnit $ Position 1 1"
+          isUnit (Position @Int 0 (-1)) @? "not . isUnit $ Position 0 (-1)"
+          (not . isUnit) (Position @Int 1 13) @? "isUnit $ Position 1 13"
+      ]
+    ]
+
+  , testGroup "Direction"
+    [ testProperty "opposite is involutive" $ \(dir :: Direction) ->
+        opposite (opposite dir) == dir
+    , testProperty "opposite provides inverse" $ \dir ->
+        invert (asPosition dir) === asPosition (opposite dir)
+    , testProperty "asPosition isUnit" $ \dir ->
+        dir /= Here ==> isUnit (asPosition dir)
+    , testGroup "Move"
+      [ testCase "Up"        $ move Up mempty        @?= Position @Int 0 (-1)
+      , testCase "Down"      $ move Down mempty      @?= Position @Int 0 1
+      , testCase "Left"      $ move Left mempty      @?= Position @Int (-1) 0
+      , testCase "Right"     $ move Right mempty     @?= Position @Int 1 0
+      , testCase "UpLeft"    $ move UpLeft mempty    @?= Position @Int (-1) (-1)
+      , testCase "UpRight"   $ move UpRight mempty   @?= Position @Int 1 (-1)
+      , testCase "DownLeft"  $ move DownLeft mempty  @?= Position @Int (-1) 1
+      , testCase "DownRight" $ move DownRight mempty @?= Position @Int 1 1
+      ]
+    ]
+
+  , testGroup "Corner"
+    [ testGroup "instance Opposite"
+      [ testProperty "involutive" $ \(corner :: Corner) ->
+          opposite (opposite corner) === corner
+      ]
+    ]
+
+  , testGroup "Edge"
+    [ testGroup "instance Opposite"
+      [ testProperty "involutive" $ \(edge :: Edge) ->
+          opposite (opposite edge) === edge
+      ]
+    ]
+
+  , testGroup "Box"
+    [ testGroup "boxIntersects"
+      [ testProperty "True" $ \dims ->
+          boxIntersects (Box @Word (V2 1 1) (V2 2 2))
+                        (Box (V2 2 2) dims)
+      , testProperty "False" $ \dims ->
+          not $ boxIntersects (Box @Word (V2 1 1) (V2 2 2))
+                            (Box (V2 4 2) dims)
+      ]
+    ]
+
+  , testGroup "Neighbors"
+    [ testGroup "rotations"
+      [ testProperty "always has the same members"
+        $ \(neighs :: Neighbors Int) ->
+          all (\ns -> sort (toList ns) == sort (toList neighs))
+          $ rotations neighs
+      , testProperty "all rotations have the same rotations"
+        $ \(neighs :: Neighbors Int) ->
+          let rots = rotations neighs
+          in all (\ns -> sort (toList $ rotations ns) == sort (toList rots))
+             rots
+      ]
+    ]
+
+  , testGroup "units"
+    [ testGroup "unit suffixes"
+      [ testCase "density"
+        $ tshow (10000 :: Grams `Per` Cubic Meters) @?= "10000.0 g/m³"
+      , testCase "volume"
+        $ tshow (5 :: Cubic Meters) @?= "5.0 m³"
+      , testCase "area"
+        $ tshow (5 :: Square Meters) @?= "5.0 m²"
+      ]
+    ]
+  ]
diff --git a/users/aspen/xanthous/test/Xanthous/Entities/CharacterSpec.hs b/users/aspen/xanthous/test/Xanthous/Entities/CharacterSpec.hs
new file mode 100644
index 000000000000..734cce1efbbe
--- /dev/null
+++ b/users/aspen/xanthous/test/Xanthous/Entities/CharacterSpec.hs
@@ -0,0 +1,24 @@
+{-# OPTIONS_GHC -Wno-type-defaults #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.CharacterSpec (main, test) where
+--------------------------------------------------------------------------------
+import           Test.Prelude
+--------------------------------------------------------------------------------
+import           Xanthous.Entities.Character
+import           Xanthous.Util (endoTimes)
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Entities.CharacterSpec"
+  [ testGroup "Knuckles"
+    [ testBatch $ monoid @Knuckles mempty
+    , testGroup "damageKnuckles"
+      [ testCase "caps at 5" $
+          let knuckles' = endoTimes 6 damageKnuckles mempty
+          in _knuckleDamage knuckles' @?= 5
+      ]
+    ]
+  ]
diff --git a/users/aspen/xanthous/test/Xanthous/Entities/CommonSpec.hs b/users/aspen/xanthous/test/Xanthous/Entities/CommonSpec.hs
new file mode 100644
index 000000000000..a6f8401cf75b
--- /dev/null
+++ b/users/aspen/xanthous/test/Xanthous/Entities/CommonSpec.hs
@@ -0,0 +1,65 @@
+--------------------------------------------------------------------------------
+module Xanthous.Entities.CommonSpec (main, test) where
+--------------------------------------------------------------------------------
+import           Test.Prelude
+import           Data.Vector.Lens (toVectorOf)
+--------------------------------------------------------------------------------
+import           Xanthous.Entities.Common
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+newtype OneHand = OneHand Hand
+  deriving stock Show
+
+instance Arbitrary OneHand where
+  arbitrary = OneHand <$> elements [LeftHand, RightHand]
+
+otherHand :: Hand -> Hand
+otherHand LeftHand = RightHand
+otherHand RightHand = LeftHand
+otherHand BothHands = error "OtherHand BothHands"
+
+test :: TestTree
+test = testGroup "Xanthous.Entities.CommonSpec"
+  [ testGroup "Inventory"
+    [ testProperty "items === itemsWithPosition . _2" $ \inv ->
+        inv ^.. items === inv ^.. itemsWithPosition . _2
+    , testGroup "removeItemFromPosition" $
+      let rewield w inv =
+            let (old, inv') = inv & wielded <<.~ w
+            in inv' & backpack <>~ toVectorOf (wieldedItems . wieldedItem) old
+      in [ (Backpack, \item -> backpack %~ (item ^. wieldedItem <|))
+         , (InHand LeftHand, rewield . inLeftHand)
+         , (InHand RightHand, rewield . inRightHand)
+         , (InHand BothHands, rewield . review doubleHanded)
+         ] <&> \(pos, addItem) ->
+           testProperty (show pos) $ \inv item ->
+             let inv' = addItem item inv
+                 inv'' = removeItemFromPosition pos (item ^. wieldedItem) inv'
+             in inv'' ^.. items === inv ^.. items
+    ]
+  , testGroup "Wielded items"
+    [ testGroup "wieldInHand"
+      [ testProperty "puts the item in the hand" $ \w hand item ->
+          let (_, w') = wieldInHand hand item w
+          in itemsInHand hand w' === [item]
+      , testProperty "returns items in both hands when wielding double-handed"
+        $ \lh rh newItem ->
+          let w = Hands (Just lh) (Just rh)
+              (prevItems, _) = wieldInHand BothHands newItem w
+          in prevItems === [lh, rh]
+      , testProperty "wielding in one hand leaves the item in the other hand"
+        $ \(OneHand h) existingItem newItem ->
+          let (_, w) = wieldInHand h existingItem nothingWielded
+              (prevItems, w') = wieldInHand (otherHand h) newItem w
+          in   prevItems === []
+          .&&. sort (w' ^.. wieldedItems) === sort [existingItem, newItem]
+      , testProperty "always leaves the same items overall" $ \w hand item ->
+          let (prevItems, w') = wieldInHand hand item w
+          in  sort (prevItems <> (w' ^.. wieldedItems))
+          === sort (item : w ^.. wieldedItems)
+      ]
+    ]
+  ]
diff --git a/users/aspen/xanthous/test/Xanthous/Entities/RawTypesSpec.hs b/users/aspen/xanthous/test/Xanthous/Entities/RawTypesSpec.hs
new file mode 100644
index 000000000000..e23f7faba3a6
--- /dev/null
+++ b/users/aspen/xanthous/test/Xanthous/Entities/RawTypesSpec.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE RecordWildCards #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.RawTypesSpec (main, test) where
+--------------------------------------------------------------------------------
+import           Test.Prelude
+--------------------------------------------------------------------------------
+import           Data.Interval (Extended(..), (<=..<=))
+--------------------------------------------------------------------------------
+import           Xanthous.Entities.RawTypes
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Entities.RawTypesSpec"
+  [ testGroup "CreatureGenerateParams"
+    [ testGroup "Ord laws"
+      [ testProperty "comparability" $ \(a :: CreatureGenerateParams) b ->
+          a <= b || b <= a
+      , testProperty "transitivity" $ \(a :: CreatureGenerateParams) b c ->
+          a <= b && b <= c ==> a <= c
+      , testProperty "reflexivity" $ \(a :: CreatureGenerateParams) ->
+          a <= a
+      , testProperty "antisymmetry" $ \(a :: CreatureGenerateParams) b ->
+          (a <= b && b <= a) == (a == b)
+      ]
+    , testGroup "canGenerate" $
+      let makeParams minB maxB =
+            let _levelRange = maybe NegInf Finite minB <=..<= maybe PosInf Finite maxB
+                _equippedItem = Nothing
+            in CreatureGenerateParams {..}
+      in
+        [ testProperty "no bounds" $ \level ->
+            let gps = makeParams Nothing Nothing
+            in canGenerate level gps
+        , testProperty "min bound" $ \level minB ->
+            let gps = makeParams (Just minB) Nothing
+            in canGenerate level gps === (level >= minB)
+        , testProperty "max bound" $ \level maxB ->
+            let gps = makeParams Nothing (Just maxB)
+            in canGenerate level gps === (level <= maxB)
+        ]
+    ]
+  ]
diff --git a/users/aspen/xanthous/test/Xanthous/Entities/RawsSpec.hs b/users/aspen/xanthous/test/Xanthous/Entities/RawsSpec.hs
new file mode 100644
index 000000000000..b6c80be51be7
--- /dev/null
+++ b/users/aspen/xanthous/test/Xanthous/Entities/RawsSpec.hs
@@ -0,0 +1,30 @@
+-- |
+
+module Xanthous.Entities.RawsSpec (main, test) where
+
+import Test.Prelude
+import Xanthous.Entities.Raws
+import Xanthous.Entities.RawTypes
+       (_Creature, entityName, generateParams, HasEquippedItem (equippedItem))
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Entities.Raws"
+  [ testGroup "raws"
+    [ testCase "are all valid" $ raws `deepseq` pure ()
+    , testCase "all CreatureEquippedItems reference existent entity names" $
+      let notFound
+            = raws
+              ^.. folded
+              . _Creature
+              . generateParams
+              . _Just
+              . equippedItem
+              . _Just
+              . entityName
+              . filtered (isNothing . raw)
+      in null notFound @? ("Some entities weren't found: " <> show notFound)
+    ]
+  ]
diff --git a/users/aspen/xanthous/test/Xanthous/Game/PromptSpec.hs b/users/aspen/xanthous/test/Xanthous/Game/PromptSpec.hs
new file mode 100644
index 000000000000..d7a3df4acafa
--- /dev/null
+++ b/users/aspen/xanthous/test/Xanthous/Game/PromptSpec.hs
@@ -0,0 +1,19 @@
+--------------------------------------------------------------------------------
+module Xanthous.Game.PromptSpec (main, test) where
+--------------------------------------------------------------------------------
+import           Test.Prelude
+--------------------------------------------------------------------------------
+import           Xanthous.Game.Prompt
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Game.PromptSpec"
+  [ testGroup "mkMenuItems"
+    [ testCase "with duplicate items"
+      $ mkMenuItems @[_] [('a', MenuOption @Int "a" 1), ('a', MenuOption "a" 2)]
+        @?= mapFromList [('a', MenuOption "a" 1), ('b', MenuOption "a" 2)]
+    ]
+  ]
diff --git a/users/aspen/xanthous/test/Xanthous/Game/StateSpec.hs b/users/aspen/xanthous/test/Xanthous/Game/StateSpec.hs
new file mode 100644
index 000000000000..34584f73b2ad
--- /dev/null
+++ b/users/aspen/xanthous/test/Xanthous/Game/StateSpec.hs
@@ -0,0 +1,30 @@
+--------------------------------------------------------------------------------
+module Xanthous.Game.StateSpec (main, test) where
+--------------------------------------------------------------------------------
+import           Test.Prelude
+--------------------------------------------------------------------------------
+import           Xanthous.Game.State
+import           Xanthous.Entities.Raws (raws)
+import           Xanthous.Generators.Level.LevelContents (entityFromRaw)
+import           Control.Monad.Random (evalRandT)
+import           System.Random (getStdGen)
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Game.StateSpec"
+  [ testGroup "entityTypeName"
+    [ testCase "for a creature" $ do
+        let gormlakRaw = raws ^?! ix "gormlak"
+        creature <- runRand $ entityFromRaw gormlakRaw
+        entityTypeName creature @?= "Creature"
+    , testCase "for an item" $ do
+        let stickRaw = raws ^?! ix "stick"
+        item <- runRand $ entityFromRaw stickRaw
+        entityTypeName item @?= "Item"
+    ]
+  ]
+  where
+    runRand x = evalRandT x =<< getStdGen
diff --git a/users/aspen/xanthous/test/Xanthous/GameSpec.hs b/users/aspen/xanthous/test/Xanthous/GameSpec.hs
new file mode 100644
index 000000000000..2fa8527d0e59
--- /dev/null
+++ b/users/aspen/xanthous/test/Xanthous/GameSpec.hs
@@ -0,0 +1,55 @@
+module Xanthous.GameSpec where
+
+import Test.Prelude hiding (Down)
+import Xanthous.Game
+import Xanthous.Game.State
+import Control.Lens.Properties
+import Xanthous.Data (move, Direction(Down))
+import Xanthous.Data.EntityMap (atPosition)
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test
+  = localOption (QuickCheckTests 10)
+  . localOption (QuickCheckMaxSize 10)
+  $ testGroup "Xanthous.Game"
+  [ testGroup "positionedCharacter"
+    [ testProperty "lens laws" $ isLens positionedCharacter
+    , testCase "updates the position of the character" $ do
+      initialGame <- getInitialState
+      let initialPos = initialGame ^. characterPosition
+          updatedGame = initialGame & characterPosition %~ move Down
+          updatedPos = updatedGame ^. characterPosition
+      updatedPos @?= move Down initialPos
+      updatedGame ^. entities . atPosition initialPos @?= fromList []
+      updatedGame ^. entities . atPosition updatedPos
+        @?= fromList [SomeEntity $ initialGame ^. character]
+    ]
+  , testGroup "characterPosition"
+    [ testProperty "lens laws" $ isLens characterPosition
+    ]
+  , testGroup "character"
+    [ testProperty "lens laws" $ isLens character
+    ]
+  , testGroup "MessageHistory"
+    [ testGroup "MonoComonad laws"
+      [ testProperty "oextend oextract ≡ id"
+        $ \(mh :: MessageHistory) -> oextend oextract mh === mh
+      , testProperty "oextract ∘ oextend f ≡ f"
+        $ \(mh :: MessageHistory) f -> (oextract . oextend f) mh === f mh
+      , testProperty "oextend f ∘ oextend g ≡ oextend (f . oextend g)"
+        $ \(mh :: MessageHistory) f g ->
+          (oextend f . oextend g) mh === oextend (f . oextend g) mh
+      ]
+    ]
+  , testGroup "Saving the game"
+    [ testProperty "forms a prism" $ isPrism saved
+    , testProperty "round-trips" $ \gs ->
+        loadGame (saveGame gs) === Just gs
+    , testProperty "preserves the character ID" $ \gs ->
+        let Just gs' = loadGame $ saveGame gs
+        in gs' ^. character === gs ^. character
+    ]
+  ]
diff --git a/users/aspen/xanthous/test/Xanthous/Generators/Level/UtilSpec.hs b/users/aspen/xanthous/test/Xanthous/Generators/Level/UtilSpec.hs
new file mode 100644
index 000000000000..b53c657f7559
--- /dev/null
+++ b/users/aspen/xanthous/test/Xanthous/Generators/Level/UtilSpec.hs
@@ -0,0 +1,127 @@
+{-# LANGUAGE PackageImports #-}
+--------------------------------------------------------------------------------
+module Xanthous.Generators.Level.UtilSpec (main, test) where
+--------------------------------------------------------------------------------
+import Test.Prelude
+import System.Random (mkStdGen)
+import Control.Monad.Random (runRandT)
+import Data.Array.ST (STUArray, runSTUArray, thaw)
+import Data.Array.IArray (bounds, array)
+import Data.Array.MArray (newArray, readArray, writeArray)
+import Data.Array (Array, range, listArray, Ix)
+import Control.Monad.ST (ST, runST)
+import "checkers" Test.QuickCheck.Instances.Array ()
+import Linear.V2
+--------------------------------------------------------------------------------
+import Xanthous.Util
+import Xanthous.Data (width, height)
+--------------------------------------------------------------------------------
+import Xanthous.Generators.Level.Util
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+--------------------------------------------------------------------------------
+
+newtype GenArray a b = GenArray (Array a b)
+  deriving stock (Show, Eq)
+
+instance (Ix a, Arbitrary a, CoArbitrary a, Arbitrary b)
+       => Arbitrary (GenArray a b) where
+  arbitrary = GenArray <$> do
+    (mkElem :: a -> b) <- arbitrary
+    minDims <- arbitrary
+    maxDims <- arbitrary
+    let bnds = (minDims, maxDims)
+    pure $ listArray bnds $ mkElem <$> range bnds
+
+test :: TestTree
+test = testGroup "Xanthous.Generators.Util"
+  [ testGroup "randInitialize"
+    [ testProperty "returns an array of the correct dimensions"
+      $ \dims seed aliveChance ->
+        let gen = mkStdGen seed
+            res = runSTUArray
+                $ fmap fst
+                $ flip runRandT gen
+                $ randInitialize dims aliveChance
+        in bounds res === (0, V2 (dims ^. width) (dims ^. height))
+    ]
+  , testGroup "numAliveNeighborsM"
+    [ testProperty "maxes out at 8"
+      $ \(GenArray (arr :: Array (V2 Word) Bool)) loc ->
+        let
+          act :: forall s. ST s Word
+          act = do
+            mArr <- thaw @_ @_ @_ @(STUArray s) arr
+            numAliveNeighborsM mArr loc
+          res = runST act
+        in counterexample (show res) $ between 0 8 res
+    , testCase "on the outer x edge" $
+      let act :: forall s. ST s Word
+          act = do
+            cells <- thaw @_ @_ @_ @(STUArray s) $ array @Array @Bool @(V2 Word)
+              (V2 0 0, V2 2 2)
+              [ (V2 0 0, True),  (V2 1 0, True),  (V2 2 0, True)
+              , (V2 0 1, False), (V2 1 1, False), (V2 2 1, True)
+              , (V2 0 2, True),  (V2 1 2, True),  (V2 2 2, True)
+              ]
+            numAliveNeighborsM cells (V2 0 1)
+          res = runST act
+      in res @?= 7
+    , testCase "on the outer y edge" $
+      let act :: forall s. ST s Word
+          act = do
+            cells <- thaw @_ @_ @_ @(STUArray s) $ array @Array @Bool @(V2 Word)
+              (V2 0 0, V2 2 2)
+              [ (V2 0 0, True),  (V2 1 0, True),  (V2 2 0, True)
+              , (V2 0 1, False), (V2 1 1, False), (V2 2 1, True)
+              , (V2 0 2, True),  (V2 1 2, True),  (V2 2 2, True)
+              ]
+            numAliveNeighborsM cells (V2 1 0)
+          res = runST act
+      in res @?= 6
+    ]
+  , testGroup "numAliveNeighbors"
+    [ testProperty "is equivalient to runST . numAliveNeighborsM . thaw" $
+      \(GenArray (arr :: Array (V2 Word) Bool)) loc ->
+        let
+          act :: forall s. ST s Word
+          act = do
+            mArr <- thaw @_ @_ @_ @(STUArray s) arr
+            numAliveNeighborsM mArr loc
+          res = runST act
+        in numAliveNeighbors arr loc === res
+    , testCase "on the outer x edge" $
+      let cells =
+            array @Array @Bool @(V2 Word)
+            (V2 0 0, V2 2 2)
+            [ (V2 0 0, True),  (V2 1 0, True),  (V2 2 0, True)
+            , (V2 0 1, False), (V2 1 1, False), (V2 2 1, True)
+            , (V2 0 2, True),  (V2 1 2, True),  (V2 2 2, True)
+            ]
+      in numAliveNeighbors cells (V2 0 1) @?= 7
+    , testCase "on the outer y edge" $
+      let cells =
+            array @Array @Bool @(V2 Word)
+            (V2 0 0, V2 2 2)
+            [ (V2 0 0, True),  (V2 1 0, True),  (V2 2 0, True)
+            , (V2 0 1, False), (V2 1 1, False), (V2 2 1, True)
+            , (V2 0 2, True),  (V2 1 2, True),  (V2 2 2, True)
+            ]
+      in numAliveNeighbors cells (V2 1 0) @?= 6
+    ]
+  , testGroup "cloneMArray"
+      [ testCase "clones the array" $ runST $
+          let
+            go :: forall s. ST s Assertion
+            go = do
+              arr <- newArray @(STUArray s) (0 :: Int, 5) (1 :: Int)
+              arr' <- cloneMArray @_ @(STUArray s) arr
+              writeArray arr' 0 1234
+              x <- readArray arr 0
+              pure $ x @?= 1
+          in go
+      ]
+  ]
diff --git a/users/aspen/xanthous/test/Xanthous/MessageSpec.hs b/users/aspen/xanthous/test/Xanthous/MessageSpec.hs
new file mode 100644
index 000000000000..2068e338bafe
--- /dev/null
+++ b/users/aspen/xanthous/test/Xanthous/MessageSpec.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE OverloadedLists #-}
+module Xanthous.MessageSpec ( main, test ) where
+
+import Test.Prelude
+import Xanthous.Messages
+import Data.Aeson
+import Text.Mustache
+import Control.Lens.Properties
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Messages"
+  [ testGroup "Message"
+    [ testGroup "JSON decoding"
+      [ testCase "Single"
+        $ decode "\"Test Single Template\""
+        @?= Just (Single
+                  $ compileMustacheText "template" "Test Single Template"
+                  ^?! _Right)
+      , testCase "Choice"
+        $ decode "[\"Choice 1\", \"Choice 2\"]"
+        @?= Just
+            (Choice
+            [ compileMustacheText "template" "Choice 1" ^?! _Right
+            , compileMustacheText "template" "Choice 2" ^?! _Right
+            ])
+      ]
+    ]
+  , localOption (QuickCheckTests 50)
+  . localOption (QuickCheckMaxSize 10)
+  $ testGroup "MessageMap"
+    [ testGroup "instance Ixed"
+        [ testProperty "traversal laws" $ \k ->
+            isTraversal $ ix @MessageMap k
+        , testCase "preview when exists" $
+          let
+            Right tpl = compileMustacheText "foo" "bar"
+            msg = Single tpl
+            mm = Nested [("foo", Direct msg)]
+          in mm ^? ix ["foo"] @?= Just msg
+        ]
+    , testGroup "lookupMessage"
+      [ testProperty "is equivalent to preview ix" $ \msgMap path ->
+          lookupMessage path msgMap === msgMap ^? ix path
+      ]
+    ]
+
+  , testGroup "Messages"
+    [ testCase "are all valid" $ messages `deepseq` pure ()
+    ]
+
+  , testGroup "Template"
+    [ testGroup "eq"
+      [ testProperty "reflexive" $ \(tpl :: Template) -> tpl == tpl
+      ]
+    ]
+  ]
diff --git a/users/aspen/xanthous/test/Xanthous/Messages/TemplateSpec.hs b/users/aspen/xanthous/test/Xanthous/Messages/TemplateSpec.hs
new file mode 100644
index 000000000000..2a3873c3b016
--- /dev/null
+++ b/users/aspen/xanthous/test/Xanthous/Messages/TemplateSpec.hs
@@ -0,0 +1,80 @@
+--------------------------------------------------------------------------------
+module Xanthous.Messages.TemplateSpec (main, test) where
+--------------------------------------------------------------------------------
+import Test.Prelude
+import Test.QuickCheck.Instances.Text ()
+import Data.List.NonEmpty (NonEmpty(..))
+import Data.Function (fix)
+--------------------------------------------------------------------------------
+import Xanthous.Messages.Template
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Messages.Template"
+  [ testGroup "parsing"
+    [ testProperty "literals" $ forAll genLiteral $ \s ->
+        testParse template s === Right (Literal s)
+    , parseCase "escaped curlies"
+      "foo\\{"
+      $ Literal "foo{"
+    , parseCase "simple substitution"
+      "foo {{bar}}"
+      $ Literal "foo " `Concat` Subst (SubstPath $ "bar" :| [])
+    , parseCase "substitution with filters"
+      "foo {{bar | baz}}"
+      $ Literal "foo "
+      `Concat` Subst (SubstFilter (SubstPath $ "bar" :| [])
+                                  (FilterName "baz"))
+    , parseCase "substitution with multiple filters"
+      "foo {{bar | baz | qux}}"
+      $ Literal "foo "
+      `Concat` Subst (SubstFilter (SubstFilter (SubstPath $ "bar" :| [])
+                                                (FilterName "baz"))
+                                  (FilterName "qux"))
+    , parseCase "two substitutions and a literal"
+      "{{a}}{{b}}c"
+      $ Subst (SubstPath $ "a" :| [])
+      `Concat` Subst (SubstPath $ "b" :| [])
+      `Concat` Literal "c"
+    , localOption (QuickCheckTests 10)
+    $ testProperty "round-trips with ppTemplate" $ \tpl ->
+        testParse template (ppTemplate tpl) === Right tpl
+    ]
+  , testBatch $ monoid @Template mempty
+  , testGroup "rendering"
+    [ testProperty "rendering literals renders literally"
+      $ forAll genLiteral $ \s fs vs ->
+        render fs vs (Literal s) === Right s
+    , testProperty "rendering substitutions renders substitutions"
+      $ forAll genPath $ \ident val fs ->
+        let tpl = Subst (SubstPath ident)
+            tvs = varsWith ident val
+        in render fs tvs tpl === Right val
+    , testProperty "filters filter" $ forAll genPath
+      $ \ident filterName filterFn val ->
+        let tpl = Subst (SubstFilter (SubstPath ident) filterName)
+            fs = mapFromList [(filterName, filterFn)]
+            vs = varsWith ident val
+        in render fs vs tpl === Right (filterFn val)
+    ]
+  ]
+  where
+    genLiteral = pack . filter (`notElem` ['\\', '{']) <$> arbitrary
+    parseCase name input expected =
+      testCase name $ testParse template input @?= Right expected
+    testParse p = over _Left errorBundlePretty . runParser p "<test>"
+    genIdentifier = pack @Text <$> listOf1 (elements identifierChars)
+    identifierChars = ['a'..'z'] <> ['A'..'Z'] <> ['-', '_']
+
+    varsWith (p :| []) val = vars [(p, Val val)]
+    varsWith (phead :| ps) val = vars . pure . (phead ,) . flip fix ps $
+      \next pth -> case pth of
+          [] -> Val val
+          p : ps' -> nested [(p, next ps')]
+
+    genPath = (:|) <$> genIdentifier <*> listOf genIdentifier
+
+--
diff --git a/users/aspen/xanthous/test/Xanthous/OrphansSpec.hs b/users/aspen/xanthous/test/Xanthous/OrphansSpec.hs
new file mode 100644
index 000000000000..0d800e8a91de
--- /dev/null
+++ b/users/aspen/xanthous/test/Xanthous/OrphansSpec.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE OverloadedLists #-}
+--------------------------------------------------------------------------------
+module Xanthous.OrphansSpec where
+--------------------------------------------------------------------------------
+import           Test.Prelude
+--------------------------------------------------------------------------------
+import           Text.Mustache
+import           Text.Megaparsec (errorBundlePretty)
+import           Graphics.Vty.Attributes
+import qualified Data.Aeson as JSON
+import           Data.Interval (Interval, (<=..<=), (<=..<), (<..<=))
+import           Data.Aeson ( ToJSON(toJSON), object, Value(Array) )
+import           Data.Aeson.Types (fromJSON)
+import           Data.IntegerInterval (Extended(Finite))
+--------------------------------------------------------------------------------
+import           Xanthous.Orphans
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Orphans"
+  [ localOption (QuickCheckTests 50)
+  . localOption (QuickCheckMaxSize 10)
+  $ testGroup "Template"
+    [ testProperty "ppTemplate / compileMustacheText " \tpl ->
+        let src = ppTemplate tpl
+            res :: Either String Template
+            res = over _Left errorBundlePretty
+                $ compileMustacheText (templateActual tpl) src
+            expected = templateCache tpl ^?! at (templateActual tpl)
+        in
+          counterexample (unpack src)
+          $ Right expected === do
+            (Template actual cache) <- res
+            maybe (Left "Template not found") Right $ cache ^? at actual
+    , testProperty "JSON round trip" $ \(tpl :: Template) ->
+        counterexample (unpack $ ppTemplate tpl)
+        $ JSON.decode (JSON.encode tpl) === Just tpl
+    ]
+  , testGroup "Attr"
+    [ jsonRoundTrip @Attr ]
+  , testGroup "Extended"
+    [ jsonRoundTrip @(Extended Int) ]
+  , testGroup "Interval"
+    [ testGroup "JSON"
+      [ jsonRoundTrip @(Interval Int)
+      , testCase "parses a single value as a length-1 interval" $
+          getSuccess (fromJSON $ toJSON (1 :: Int))
+          @?= Just (Finite (1 :: Int) <=..<= Finite 1)
+      , testCase "parses a pair of values as a single-ended interval" $
+          getSuccess (fromJSON $ toJSON ([1, 2] :: [Int]))
+          @?= Just (Finite (1 :: Int) <=..< Finite (2 :: Int))
+      , testCase "parses the full included/excluded syntax" $
+          getSuccess (fromJSON $ Array [ object [ "Excluded" JSON..= (1 :: Int) ]
+                                       , object [ "Included" JSON..= (4 :: Int) ]
+                                       ])
+          @?= Just (Finite (1 :: Int) <..<= Finite (4 :: Int))
+      , testCase "parses open/closed as aliases" $
+          getSuccess (fromJSON $ Array [ object [ "Open" JSON..= (1 :: Int) ]
+                                       , object [ "Closed" JSON..= (4 :: Int) ]
+                                       ])
+          @?= Just (Finite (1 :: Int) <..<= Finite (4 :: Int))
+      ]
+    ]
+  ]
+  where
+    getSuccess :: JSON.Result a -> Maybe a
+    getSuccess (JSON.Error _) = Nothing
+    getSuccess (JSON.Success r) = Just r
diff --git a/users/aspen/xanthous/test/Xanthous/RandomSpec.hs b/users/aspen/xanthous/test/Xanthous/RandomSpec.hs
new file mode 100644
index 000000000000..c88bd9562928
--- /dev/null
+++ b/users/aspen/xanthous/test/Xanthous/RandomSpec.hs
@@ -0,0 +1,45 @@
+--------------------------------------------------------------------------------
+module Xanthous.RandomSpec (main, test) where
+--------------------------------------------------------------------------------
+import Test.Prelude
+--------------------------------------------------------------------------------
+import Control.Monad.Random
+--------------------------------------------------------------------------------
+import           Xanthous.Random
+import           Xanthous.Orphans ()
+import qualified Data.Interval as Interval
+import           Data.Interval (Interval, Extended (Finite), (<=..<=))
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Random"
+  [ testGroup "chooseSubset"
+    [ testProperty "chooses a subset"
+      $ \(l :: [Int]) (Positive (r :: Double)) -> randomTest $ do
+        ss <- chooseSubset r l
+        pure $ all (`elem` l) ss
+    ]
+  , testGroup "chooseRange"
+    [ testProperty "chooses in the range"
+      $ \(rng :: Interval Int) ->
+        not (Interval.null rng)
+        ==> randomTest ( do
+                chooseRange rng >>= \case
+                  Just r -> pure
+                           . counterexample (show r)
+                           $ r `Interval.member` rng
+                  Nothing -> pure $ property Discard
+            )
+    , testProperty "nonEmpty range is never empty"
+      $ \ (lower :: Int) (NonZero diff) -> randomTest $ do
+        let upper = lower + diff
+        r <- chooseRange (Finite lower <=..<= Finite upper)
+        pure $ isJust r
+
+    ]
+  ]
+  where
+    randomTest prop = evalRandT prop . mkStdGen =<< arbitrary
diff --git a/users/aspen/xanthous/test/Xanthous/Util/GraphSpec.hs b/users/aspen/xanthous/test/Xanthous/Util/GraphSpec.hs
new file mode 100644
index 000000000000..35ff090b28b9
--- /dev/null
+++ b/users/aspen/xanthous/test/Xanthous/Util/GraphSpec.hs
@@ -0,0 +1,39 @@
+module Xanthous.Util.GraphSpec (main, test) where
+--------------------------------------------------------------------------------
+import Test.Prelude
+--------------------------------------------------------------------------------
+import Xanthous.Util.Graph
+import Data.Graph.Inductive.Basic
+import Data.Graph.Inductive.Graph (labNodes, size, order)
+import Data.Graph.Inductive.PatriciaTree
+import Data.Graph.Inductive.Arbitrary
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Util.Graph"
+  [ testGroup "mstSubGraph"
+    [ testProperty "always produces a subgraph"
+        $ \(CG _ (graph :: Gr Int Int)) ->
+          let msg = mstSubGraph $ undir graph
+          in counterexample (show msg)
+            $ msg `isSubGraphOf` undir graph
+    , testProperty "returns a graph with the same nodes"
+        $ \(CG _ (graph :: Gr Int Int)) ->
+          let msg = mstSubGraph graph
+          in counterexample (show msg)
+            $ labNodes msg === labNodes graph
+    , testProperty "has nodes - 1 edges"
+        $ \(CG _ (graph :: Gr Int Int)) ->
+          order graph > 1 ==>
+          let msg = mstSubGraph graph
+          in counterexample (show msg)
+            $ size msg === order graph - 1
+    , testProperty "always produces a simple graph"
+        $ \(CG _ (graph :: Gr Int Int)) ->
+          let msg = mstSubGraph graph
+          in counterexample (show msg) $ isSimple msg
+    ]
+  ]
diff --git a/users/aspen/xanthous/test/Xanthous/Util/GraphicsSpec.hs b/users/aspen/xanthous/test/Xanthous/Util/GraphicsSpec.hs
new file mode 100644
index 000000000000..61e589280362
--- /dev/null
+++ b/users/aspen/xanthous/test/Xanthous/Util/GraphicsSpec.hs
@@ -0,0 +1,72 @@
+module Xanthous.Util.GraphicsSpec (main, test) where
+--------------------------------------------------------------------------------
+import Test.Prelude hiding (head)
+--------------------------------------------------------------------------------
+import Data.List (nub, head)
+import Data.Set (isSubsetOf)
+import Linear.V2
+--------------------------------------------------------------------------------
+import Xanthous.Util.Graphics
+import Xanthous.Util
+import Xanthous.Orphans ()
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Util.Graphics"
+  [ testGroup "circle"
+    [ testCase "radius 1, origin 2,2"
+      {-
+        |   | 0 | 1 | 2 | 3 |
+        |---+---+---+---+---|
+        | 0 |   |   |   |   |
+        | 1 |   |   | x |   |
+        | 2 |   | x |   | x |
+        | 3 |   |   | x |   |
+      -}
+      $ (sort . unique @[] @[_]) (circle @Int (V2 2 2) 1)
+      @?= [ V2 1 2
+          , V2 2 1, V2 2 3
+          , V2 3 2
+          ]
+    , testCase "radius 12, origin 0"
+      $   (sort . nub) (circle @Int 0 12)
+      @?= (sort . nub)
+          [ V2 (-12) (-4), V2 (-12) (-3), V2 (-12) (-2), V2 (-12) (-1)
+          , V2 (-12) 0, V2 (-12) 1, V2 (-12) 2, V2 (-12) 3, V2 (-12) 4
+          , V2 (-11) (-6), V2 (-11) (-5), V2 (-11) 5, V2 (-11) 6, V2 (-10) (-7)
+          , V2 (-10) 7, V2 (-9) (-9), V2 (-9) (-8), V2 (-9) 8, V2 (-9) 9
+          , V2 (-8) (-9), V2 (-8) 9, V2 (-7) (-10), V2 (-7) 10, V2 (-6) (-11)
+          , V2 (-6) 11, V2 (-5) (-11), V2 (-5) 11, V2 (-4) (-12), V2 (-4) 12
+          , V2 (-3) (-12), V2 (-3) 12, V2 (-2) (-12), V2 (-2) 12, V2 (-1) (-12)
+          , V2 (-1) 12, V2 0 (-12), V2 0 12, V2 1 (-12), V2 1 12, V2 2 (-12)
+          , V2 2 12, V2 3 (-12), V2 3 12, V2 4 (-12), V2 4 12, V2 5 (-11)
+          , V2 5 11, V2 6 (-11), V2 6 11, V2 7 (-10), V2 7 10, V2 8 (-9), V2 8 9
+          , V2 9 (-9), V2 9 (-8), V2 9 8, V2 9 9, V2 10 (-7), V2 10 7
+          , V2 11 (-6), V2 11 (-5), V2 11 5, V2 11 6, V2 12 (-4), V2 12 (-3)
+          , V2 12 (-2), V2 12 (-1), V2 12 0, V2 12 1, V2 12 2, V2 12 3, V2 12 4
+          ]
+    ]
+  , testGroup "filledCircle"
+    [ testProperty "is a superset of circle" $ \center radius ->
+        let circ = circle @Int center radius
+            filledCirc = filledCircle center radius
+        in counterexample ( "circle: " <> show circ
+                           <> "\nfilledCircle: " <> show filledCirc)
+          $ setFromList circ `isSubsetOf` setFromList filledCirc
+    -- TODO later
+    -- , testProperty "is always contiguous" $ \center radius ->
+    --     let filledCirc = filledCircle center radius
+    --     in counterexample (renderBooleanGraphics filledCirc) $
+    ]
+  , testGroup "line"
+    [ testProperty "starts and ends at the start and end points" $ \start end ->
+        let ℓ = line @Int start end
+        in counterexample ("line: " <> show ℓ)
+        $ length ℓ > 2 ==> (head ℓ === start) .&&. (head (reverse ℓ) === end)
+    ]
+  ]
+
+--------------------------------------------------------------------------------
diff --git a/users/aspen/xanthous/test/Xanthous/Util/InflectionSpec.hs b/users/aspen/xanthous/test/Xanthous/Util/InflectionSpec.hs
new file mode 100644
index 000000000000..fad841043152
--- /dev/null
+++ b/users/aspen/xanthous/test/Xanthous/Util/InflectionSpec.hs
@@ -0,0 +1,18 @@
+module Xanthous.Util.InflectionSpec (main, test) where
+
+import Test.Prelude
+import Xanthous.Util.Inflection
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Util.Inflection"
+  [ testGroup "toSentence"
+    [ testCase "empty"  $ toSentence [] @?= ""
+    , testCase "single" $ toSentence ["x"] @?= "x"
+    , testCase "two"    $ toSentence ["x", "y"] @?= "x and y"
+    , testCase "three"  $ toSentence ["x", "y", "z"] @?= "x, y, and z"
+    , testCase "four"   $ toSentence ["x", "y", "z", "w"] @?= "x, y, z, and w"
+    ]
+  ]
diff --git a/users/aspen/xanthous/test/Xanthous/UtilSpec.hs b/users/aspen/xanthous/test/Xanthous/UtilSpec.hs
new file mode 100644
index 000000000000..684a03b2c7a0
--- /dev/null
+++ b/users/aspen/xanthous/test/Xanthous/UtilSpec.hs
@@ -0,0 +1,46 @@
+module Xanthous.UtilSpec (main, test) where
+
+import Test.Prelude
+import Xanthous.Util
+import Control.Monad.State.Lazy (execState)
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Util"
+  [ testGroup "smallestNotIn"
+    [ testCase "examples" $ do
+        smallestNotIn [7 :: Word, 3, 7] @?= 0
+        smallestNotIn [7 :: Word, 0, 1, 3, 7] @?= 2
+    , testProperty "returns an element not in the list" $ \(xs :: [Word]) ->
+        smallestNotIn xs `notElem` xs
+    , testProperty "pred return is in the list" $ \(xs :: [Word]) ->
+        let res = smallestNotIn xs
+        in res /= 0 ==> pred res `elem` xs
+    , testProperty "ignores order" $ \(xs :: [Word]) ->
+        forAll (shuffle xs) $ \shuffledXs ->
+          smallestNotIn xs === smallestNotIn shuffledXs
+    ]
+  , testGroup "takeWhileInclusive"
+    [ testProperty "takeWhileInclusive (const True) ≡ id"
+      $ \(xs :: [Int]) -> takeWhileInclusive (const True) xs === xs
+    ]
+  , testGroup "endoTimes"
+    [ testCase "endoTimes 4 succ 5"
+      $ endoTimes (4 :: Int) succ (5 :: Int) @?= 9
+    ]
+  , testGroup "modifyKL"
+    [ testCase "_1 += 1"
+      $ execState (modifyKL _1 $ pure . succ) (1 :: Int, 2 :: Int) @?= (2, 2)
+    ]
+  , testGroup "removeFirst"
+    [ testCase "example" $
+      removeFirst @[Int] (> 5) [1..10] @?= [1, 2, 3, 4, 5, 7, 8, 9, 10]
+    , testProperty "the result is the right length" $ \(xs :: [Int]) p ->
+        length (removeFirst p xs) `elem` [length xs, length xs - 1]
+    ]
+  , testGroup "AlphaChar"
+    [ testCase "succ 'z'" $ succ (AlphaChar 'z') @?= AlphaChar 'A'
+    ]
+  ]
diff --git a/users/aspen/xanthous/xanthous.cabal b/users/aspen/xanthous/xanthous.cabal
new file mode 100644
index 000000000000..12222c26732f
--- /dev/null
+++ b/users/aspen/xanthous/xanthous.cabal
@@ -0,0 +1,529 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.35.0.
+--
+-- see: https://github.com/sol/hpack
+--
+-- hash: b3bf8e65d621856081832c9d3c8e8ad38799e23a7f5084dc4f972daa654a0ff3
+
+name:           xanthous
+version:        0.1.0.0
+synopsis:       A WIP TUI RPG
+description:    Please see the README on GitHub at <https://github.com/glittershark/xanthous>
+category:       Game
+homepage:       https://github.com/glittershark/xanthous#readme
+bug-reports:    https://github.com/glittershark/xanthous/issues
+author:         Griffin Smith
+maintainer:     root@gws.fyi
+copyright:      2019 Griffin Smith
+license:        GPL-3
+license-file:   LICENSE
+build-type:     Simple
+extra-source-files:
+    README.org
+
+source-repository head
+  type: git
+  location: https://github.com/glittershark/xanthous
+
+library
+  exposed-modules:
+      Data.Aeson.Generic.DerivingVia
+      Xanthous.AI.Gormlak
+      Xanthous.App
+      Xanthous.App.Autocommands
+      Xanthous.App.Common
+      Xanthous.App.Prompt
+      Xanthous.App.Time
+      Xanthous.Command
+      Xanthous.Data
+      Xanthous.Data.App
+      Xanthous.Data.Entities
+      Xanthous.Data.EntityChar
+      Xanthous.Data.EntityMap
+      Xanthous.Data.EntityMap.Graphics
+      Xanthous.Data.Levels
+      Xanthous.Data.Memo
+      Xanthous.Data.NestedMap
+      Xanthous.Data.VectorBag
+      Xanthous.Entities.Character
+      Xanthous.Entities.Common
+      Xanthous.Entities.Creature
+      Xanthous.Entities.Creature.Hippocampus
+      Xanthous.Entities.Draw.Util
+      Xanthous.Entities.Entities
+      Xanthous.Entities.Environment
+      Xanthous.Entities.Item
+      Xanthous.Entities.Marker
+      Xanthous.Entities.Raws
+      Xanthous.Entities.RawTypes
+      Xanthous.Game
+      Xanthous.Game.Arbitrary
+      Xanthous.Game.Draw
+      Xanthous.Game.Env
+      Xanthous.Game.Lenses
+      Xanthous.Game.Memo
+      Xanthous.Game.Prompt
+      Xanthous.Game.State
+      Xanthous.Generators.Level
+      Xanthous.Generators.Level.CaveAutomata
+      Xanthous.Generators.Level.Dungeon
+      Xanthous.Generators.Level.LevelContents
+      Xanthous.Generators.Level.Util
+      Xanthous.Generators.Level.Village
+      Xanthous.Generators.Speech
+      Xanthous.Messages
+      Xanthous.Messages.Template
+      Xanthous.Monad
+      Xanthous.Orphans
+      Xanthous.Physics
+      Xanthous.Prelude
+      Xanthous.Random
+      Xanthous.Util
+      Xanthous.Util.Comonad
+      Xanthous.Util.Graph
+      Xanthous.Util.Graphics
+      Xanthous.Util.Inflection
+      Xanthous.Util.JSON
+      Xanthous.Util.Optparse
+      Xanthous.Util.QuickCheck
+  other-modules:
+      Paths_xanthous
+  hs-source-dirs:
+      src
+  default-extensions:
+      BlockArguments
+      ConstraintKinds
+      DataKinds
+      DeriveAnyClass
+      DeriveGeneric
+      DerivingStrategies
+      DerivingVia
+      FlexibleContexts
+      FlexibleInstances
+      FunctionalDependencies
+      GADTSyntax
+      GeneralizedNewtypeDeriving
+      KindSignatures
+      StandaloneKindSignatures
+      LambdaCase
+      MultiWayIf
+      NoImplicitPrelude
+      NoStarIsType
+      OverloadedStrings
+      PolyKinds
+      RankNTypes
+      ScopedTypeVariables
+      TupleSections
+      TypeApplications
+      TypeFamilies
+      TypeOperators
+      ViewPatterns
+  ghc-options: -Wall -fconstraint-solver-iterations=6
+  build-depends:
+      JuicyPixels
+    , MonadRandom
+    , QuickCheck
+    , Rasterific
+    , aeson
+    , array
+    , async
+    , base
+    , bifunctors
+    , brick
+    , checkers
+    , classy-prelude
+    , comonad
+    , comonad-extras
+    , constraints
+    , containers
+    , criterion
+    , data-default
+    , data-interval
+    , deepseq
+    , directory
+    , fgl
+    , fgl-arbitrary
+    , file-embed
+    , filepath
+    , generic-arbitrary
+    , generic-lens
+    , groups
+    , hgeometry
+    , hgeometry-combinatorial
+    , lens
+    , lifted-async
+    , linear
+    , megaparsec
+    , mmorph
+    , monad-control
+    , mtl
+    , optparse-applicative
+    , parallel
+    , parser-combinators
+    , pointed
+    , quickcheck-instances
+    , quickcheck-text
+    , random
+    , random-extras
+    , random-fu
+    , random-source
+    , raw-strings-qq
+    , reflection
+    , semigroupoids
+    , semigroups
+    , splitmix
+    , stache
+    , streams
+    , text
+    , text-zipper
+    , tomland
+    , transformers
+    , vector
+    , vty
+    , witherable
+    , yaml
+    , zlib
+  default-language: Haskell2010
+
+executable xanthous
+  main-is: Main.hs
+  other-modules:
+      Paths_xanthous
+  hs-source-dirs:
+      app
+  default-extensions:
+      BlockArguments
+      ConstraintKinds
+      DataKinds
+      DeriveAnyClass
+      DeriveGeneric
+      DerivingStrategies
+      DerivingVia
+      FlexibleContexts
+      FlexibleInstances
+      FunctionalDependencies
+      GADTSyntax
+      GeneralizedNewtypeDeriving
+      KindSignatures
+      StandaloneKindSignatures
+      LambdaCase
+      MultiWayIf
+      NoImplicitPrelude
+      NoStarIsType
+      OverloadedStrings
+      PolyKinds
+      RankNTypes
+      ScopedTypeVariables
+      TupleSections
+      TypeApplications
+      TypeFamilies
+      TypeOperators
+      ViewPatterns
+  ghc-options: -Wall -fconstraint-solver-iterations=6 -threaded -rtsopts -with-rtsopts=-N -O2
+  build-depends:
+      JuicyPixels
+    , MonadRandom
+    , QuickCheck
+    , Rasterific
+    , aeson
+    , array
+    , async
+    , base
+    , bifunctors
+    , brick
+    , checkers
+    , classy-prelude
+    , comonad
+    , comonad-extras
+    , constraints
+    , containers
+    , criterion
+    , data-default
+    , data-interval
+    , deepseq
+    , directory
+    , fgl
+    , fgl-arbitrary
+    , file-embed
+    , filepath
+    , generic-arbitrary
+    , generic-lens
+    , groups
+    , hgeometry
+    , hgeometry-combinatorial
+    , lens
+    , lifted-async
+    , linear
+    , megaparsec
+    , mmorph
+    , monad-control
+    , mtl
+    , optparse-applicative
+    , parallel
+    , parser-combinators
+    , pointed
+    , quickcheck-instances
+    , quickcheck-text
+    , random
+    , random-extras
+    , random-fu
+    , random-source
+    , raw-strings-qq
+    , reflection
+    , semigroupoids
+    , semigroups
+    , splitmix
+    , stache
+    , streams
+    , text
+    , text-zipper
+    , tomland
+    , transformers
+    , vector
+    , vty
+    , witherable
+    , xanthous
+    , yaml
+    , zlib
+  default-language: Haskell2010
+
+test-suite test
+  type: exitcode-stdio-1.0
+  main-is: Spec.hs
+  other-modules:
+      Test.Prelude
+      Xanthous.CommandSpec
+      Xanthous.Data.EntitiesSpec
+      Xanthous.Data.EntityCharSpec
+      Xanthous.Data.EntityMap.GraphicsSpec
+      Xanthous.Data.EntityMapSpec
+      Xanthous.Data.LevelsSpec
+      Xanthous.Data.MemoSpec
+      Xanthous.Data.NestedMapSpec
+      Xanthous.DataSpec
+      Xanthous.Entities.CharacterSpec
+      Xanthous.Entities.CommonSpec
+      Xanthous.Entities.RawsSpec
+      Xanthous.Entities.RawTypesSpec
+      Xanthous.Game.PromptSpec
+      Xanthous.Game.StateSpec
+      Xanthous.GameSpec
+      Xanthous.Generators.Level.UtilSpec
+      Xanthous.Messages.TemplateSpec
+      Xanthous.MessageSpec
+      Xanthous.OrphansSpec
+      Xanthous.RandomSpec
+      Xanthous.Util.GraphicsSpec
+      Xanthous.Util.GraphSpec
+      Xanthous.Util.InflectionSpec
+      Xanthous.UtilSpec
+      Paths_xanthous
+  hs-source-dirs:
+      test
+  default-extensions:
+      BlockArguments
+      ConstraintKinds
+      DataKinds
+      DeriveAnyClass
+      DeriveGeneric
+      DerivingStrategies
+      DerivingVia
+      FlexibleContexts
+      FlexibleInstances
+      FunctionalDependencies
+      GADTSyntax
+      GeneralizedNewtypeDeriving
+      KindSignatures
+      StandaloneKindSignatures
+      LambdaCase
+      MultiWayIf
+      NoImplicitPrelude
+      NoStarIsType
+      OverloadedStrings
+      PolyKinds
+      RankNTypes
+      ScopedTypeVariables
+      TupleSections
+      TypeApplications
+      TypeFamilies
+      TypeOperators
+      ViewPatterns
+  ghc-options: -Wall -fconstraint-solver-iterations=6 -threaded -rtsopts -with-rtsopts=-N -O0
+  build-depends:
+      JuicyPixels
+    , MonadRandom
+    , QuickCheck
+    , Rasterific
+    , aeson
+    , array
+    , async
+    , base
+    , bifunctors
+    , brick
+    , checkers
+    , classy-prelude
+    , comonad
+    , comonad-extras
+    , constraints
+    , containers
+    , criterion
+    , data-default
+    , data-interval
+    , deepseq
+    , directory
+    , fgl
+    , fgl-arbitrary
+    , file-embed
+    , filepath
+    , generic-arbitrary
+    , generic-lens
+    , groups
+    , hgeometry
+    , hgeometry-combinatorial
+    , lens
+    , lens-properties
+    , lifted-async
+    , linear
+    , megaparsec
+    , mmorph
+    , monad-control
+    , mtl
+    , optparse-applicative
+    , parallel
+    , parser-combinators
+    , pointed
+    , quickcheck-instances
+    , quickcheck-text
+    , random
+    , random-extras
+    , random-fu
+    , random-source
+    , raw-strings-qq
+    , reflection
+    , semigroupoids
+    , semigroups
+    , splitmix
+    , stache
+    , streams
+    , tasty
+    , tasty-hunit
+    , tasty-quickcheck
+    , tasty-rerun
+    , text
+    , text-zipper
+    , tomland
+    , transformers
+    , vector
+    , vty
+    , witherable
+    , xanthous
+    , yaml
+    , zlib
+  default-language: Haskell2010
+
+benchmark benchmark
+  type: exitcode-stdio-1.0
+  main-is: Bench.hs
+  other-modules:
+      Bench.Prelude
+      Xanthous.Generators.UtilBench
+      Xanthous.RandomBench
+      Paths_xanthous
+  hs-source-dirs:
+      bench
+  default-extensions:
+      BlockArguments
+      ConstraintKinds
+      DataKinds
+      DeriveAnyClass
+      DeriveGeneric
+      DerivingStrategies
+      DerivingVia
+      FlexibleContexts
+      FlexibleInstances
+      FunctionalDependencies
+      GADTSyntax
+      GeneralizedNewtypeDeriving
+      KindSignatures
+      StandaloneKindSignatures
+      LambdaCase
+      MultiWayIf
+      NoImplicitPrelude
+      NoStarIsType
+      OverloadedStrings
+      PolyKinds
+      RankNTypes
+      ScopedTypeVariables
+      TupleSections
+      TypeApplications
+      TypeFamilies
+      TypeOperators
+      ViewPatterns
+  ghc-options: -Wall -fconstraint-solver-iterations=6 -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      JuicyPixels
+    , MonadRandom
+    , QuickCheck
+    , Rasterific
+    , aeson
+    , array
+    , async
+    , base
+    , bifunctors
+    , brick
+    , checkers
+    , classy-prelude
+    , comonad
+    , comonad-extras
+    , constraints
+    , containers
+    , criterion
+    , data-default
+    , data-interval
+    , deepseq
+    , directory
+    , fgl
+    , fgl-arbitrary
+    , file-embed
+    , filepath
+    , generic-arbitrary
+    , generic-lens
+    , groups
+    , hgeometry
+    , hgeometry-combinatorial
+    , lens
+    , lifted-async
+    , linear
+    , megaparsec
+    , mmorph
+    , monad-control
+    , mtl
+    , optparse-applicative
+    , parallel
+    , parser-combinators
+    , pointed
+    , quickcheck-instances
+    , quickcheck-text
+    , random
+    , random-extras
+    , random-fu
+    , random-source
+    , raw-strings-qq
+    , reflection
+    , semigroupoids
+    , semigroups
+    , splitmix
+    , stache
+    , streams
+    , text
+    , text-zipper
+    , tomland
+    , transformers
+    , vector
+    , vty
+    , witherable
+    , xanthous
+    , yaml
+    , zlib
+  default-language: Haskell2010