refactor(users/glittershark): Rename to grfn r/2485

Rename my //users directory and all places that refer to glittershark to
grfn, including nix references and documentation.

This may require some extra attention inside of gerrit's database after
it lands to allow me to actually push things.

Change-Id: I4728b7ec2c60024392c1c1fa6e0d4a59b3e266fa
Reviewed-on: https://cl.tvl.fyi/c/depot/+/2933
Tested-by: BuildkiteCI
Reviewed-by: tazjin <mail@tazj.in>
Reviewed-by: lukegb <lukegb@tvl.fyi>
Reviewed-by: glittershark <grfn@gws.fyi>

102 files changed, 10558 insertions, 0 deletions

diff --git a/users/grfn/xanthous/.envrc b/users/grfn/xanthous/.envrc
new file mode 100644
index 000000000000..be81feddb1a5
--- /dev/null
+++ b/users/grfn/xanthous/.envrc
@@ -0,0 +1 @@
+eval "$(lorri direnv)"
\ No newline at end of file
diff --git a/users/grfn/xanthous/.github/actions/nix-build/Dockerfile b/users/grfn/xanthous/.github/actions/nix-build/Dockerfile
new file mode 100644
index 000000000000..cfe8e35df091
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/.github/actions/nix-build/entrypoint.sh b/users/grfn/xanthous/.github/actions/nix-build/entrypoint.sh
new file mode 100755
index 000000000000..cb7aca541a3f
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/.github/workflows/haskell.yml b/users/grfn/xanthous/.github/workflows/haskell.yml
new file mode 100644
index 000000000000..df82de3e8caf
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/.gitignore b/users/grfn/xanthous/.gitignore
new file mode 100644
index 000000000000..74014978ffac
--- /dev/null
+++ b/users/grfn/xanthous/.gitignore
@@ -0,0 +1,34 @@
+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~
+.HTF/
+.ghc.environment.*
+
+
+# from nix-build
+result
+
+# grr
+*_flymake.hs
+
+# app-specific
+debug.log
+data
diff --git a/users/grfn/xanthous/LICENSE b/users/grfn/xanthous/LICENSE
new file mode 100644
index 000000000000..45644ff76449
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/README.org b/users/grfn/xanthous/README.org
new file mode 100644
index 000000000000..7e1fedb069b1
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/Setup.hs b/users/grfn/xanthous/Setup.hs
new file mode 100644
index 000000000000..9a994af677b0
--- /dev/null
+++ b/users/grfn/xanthous/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/users/grfn/xanthous/bench/Bench.hs b/users/grfn/xanthous/bench/Bench.hs
new file mode 100644
index 000000000000..5889618ee432
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/bench/Bench/Prelude.hs b/users/grfn/xanthous/bench/Bench/Prelude.hs
new file mode 100644
index 000000000000..c553abd6d5d0
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/bench/Xanthous/Generators/UtilBench.hs b/users/grfn/xanthous/bench/Xanthous/Generators/UtilBench.hs
new file mode 100644
index 000000000000..56310e691c33
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/bench/Xanthous/RandomBench.hs b/users/grfn/xanthous/bench/Xanthous/RandomBench.hs
new file mode 100644
index 000000000000..fae4af92a7a5
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/build/generic-arbitrary-export-garbitrary.patch b/users/grfn/xanthous/build/generic-arbitrary-export-garbitrary.patch
new file mode 100644
index 000000000000..f0c936bfca18
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/build/hgeometry-fix-haddock.patch b/users/grfn/xanthous/build/hgeometry-fix-haddock.patch
new file mode 100644
index 000000000000..748c65b3e0db
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/build/update-comonad-extras.patch b/users/grfn/xanthous/build/update-comonad-extras.patch
new file mode 100644
index 000000000000..cd1dbe24d361
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/default.nix b/users/grfn/xanthous/default.nix
new file mode 100644
index 000000000000..0b89a50afb9e
--- /dev/null
+++ b/users/grfn/xanthous/default.nix
@@ -0,0 +1,7 @@
+{ pkgs ? (import ../../../. {}).third_party
+, lib ? pkgs.lib
+, ...
+}:
+pkgs.haskell.lib.failOnAllWarnings (
+  pkgs.haskellPackages.callPackage (import ./pkg.nix { inherit pkgs; }) {}
+)
diff --git a/users/grfn/xanthous/hie.yaml b/users/grfn/xanthous/hie.yaml
new file mode 100644
index 000000000000..49f8ec1fbb3d
--- /dev/null
+++ b/users/grfn/xanthous/hie.yaml
@@ -0,0 +1,10 @@
+cradle:
+  cabal:
+    - path: './src'
+      component: 'lib:xanthous'
+    - path: './test'
+      component: 'test:test'
+    - path: './src'
+      component: 'exe:xanthous'
+    - path: './bench'
+      component: 'bench:benchmark'
diff --git a/users/grfn/xanthous/nixpkgs.nix b/users/grfn/xanthous/nixpkgs.nix
new file mode 100644
index 000000000000..7d7c16440545
--- /dev/null
+++ b/users/grfn/xanthous/nixpkgs.nix
@@ -0,0 +1,3 @@
+args:
+let pkgs = (import ../../../. args).third_party;
+in pkgs // { inherit pkgs; }
diff --git a/users/grfn/xanthous/package.yaml b/users/grfn/xanthous/package.yaml
new file mode 100644
index 000000000000..e8cda59692a4
--- /dev/null
+++ b/users/grfn/xanthous/package.yaml
@@ -0,0 +1,153 @@
+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
+- deepseq
+- directory
+- fgl
+- fgl-arbitrary
+- file-embed
+- filepath
+- generic-arbitrary
+- generic-monoid
+- 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
+- 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
+- LambdaCase
+- MultiWayIf
+- NoImplicitPrelude
+- NoStarIsType
+- OverloadedStrings
+- PolyKinds
+- RankNTypes
+- ScopedTypeVariables
+- TupleSections
+- TypeApplications
+- TypeFamilies
+- TypeOperators
+- ViewPatterns
+
+ghc-options:
+- -Wall
+
+library:
+  source-dirs: src
+
+executable:
+  source-dirs: src
+  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
+    - lens-properties
+
+benchmarks:
+  benchmark:
+    main: Bench.hs
+    source-dirs: bench
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - xanthous
+    - criterion
diff --git a/users/grfn/xanthous/pkg.nix b/users/grfn/xanthous/pkg.nix
new file mode 100644
index 000000000000..16a6500866a7
--- /dev/null
+++ b/users/grfn/xanthous/pkg.nix
@@ -0,0 +1,16 @@
+{ depot ? (import ../../../. {})
+, pkgs ? depot.third_party.nixpkgs
+, ... }:
+
+let
+  ignore = depot.third_party.gitignoreSource.gitignoreFilter ./.;
+in import (pkgs.haskellPackages.haskellSrc2nix {
+  name = "xanthous";
+  src = builtins.path {
+    name = "xanthous-source";
+    path = ./.;
+    filter = path: type: ignore path type
+      || builtins.baseNameOf path == "package.yaml";
+  };
+  extraCabal2nixOptions = "--hpack";
+})
diff --git a/users/grfn/xanthous/shell.nix b/users/grfn/xanthous/shell.nix
new file mode 100644
index 000000000000..29a4952106a1
--- /dev/null
+++ b/users/grfn/xanthous/shell.nix
@@ -0,0 +1,16 @@
+{ pkgs ? (import ../../../. {}).third_party, ... }:
+
+(pkgs.haskellPackages.extend (pkgs.haskell.lib.packageSourceOverrides {
+  xanthous = pkgs.gitignoreSource ./.;
+})).shellFor {
+  packages = p: [p.xanthous];
+  withHoogle = true;
+  doBenchmark = true;
+  buildInputs = with pkgs.haskellPackages; [
+    cabal-install
+    ghc-prof-flamegraph
+    hp2pretty
+    hlint
+    haskell-language-server
+  ];
+}
diff --git a/users/grfn/xanthous/src/Data/Aeson/Generic/DerivingVia.hs b/users/grfn/xanthous/src/Data/Aeson/Generic/DerivingVia.hs
new file mode 100644
index 000000000000..34f2a9403892
--- /dev/null
+++ b/users/grfn/xanthous/src/Data/Aeson/Generic/DerivingVia.hs
@@ -0,0 +1,167 @@
+{-# 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 family All (p :: Type -> Constraint) (xs :: [k]) :: Constraint 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/grfn/xanthous/src/Main.hs b/users/grfn/xanthous/src/Main.hs
new file mode 100644
index 000000000000..dcd31afff9c7
--- /dev/null
+++ b/users/grfn/xanthous/src/Main.hs
@@ -0,0 +1,159 @@
+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           Xanthous.App
+import           Xanthous.Generators
+                 ( GeneratorInput
+                 , parseGeneratorInput
+                 , generateFromInput
+                 , showCells
+                 )
+import qualified Xanthous.Entities.Character as Character
+import           Xanthous.Generators.Util (regions)
+import           Xanthous.Generators.LevelContents
+import           Xanthous.Data (Dimensions, Dimensions'(Dimensions))
+import           Data.Array.IArray ( amap )
+--------------------------------------------------------------------------------
+
+data RunParams = RunParams
+  { seed :: Maybe Int
+  , characterName :: Maybe Text
+  }
+  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"
+        )
+      ))
+
+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 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 gameState
+
+runGame :: RunType -> Game.GameState -> IO ()
+runGame rt gameState = do
+  eventChan <- Brick.BChan.newBChan 10
+  let gameEnv = GameEnv eventChan
+  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/grfn/xanthous/src/Xanthous/AI/Gormlak.hs b/users/grfn/xanthous/src/Xanthous/AI/Gormlak.hs
new file mode 100644
index 000000000000..a6cc789d6894
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/AI/Gormlak.hs
@@ -0,0 +1,124 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE UndecidableInstances #-}
+--------------------------------------------------------------------------------
+module Xanthous.AI.Gormlak
+  ( HasVisionRadius(..)
+  , GormlakBrain(..)
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding (lines)
+--------------------------------------------------------------------------------
+import           Control.Monad.State
+import           Control.Monad.Random
+import           Data.Aeson (object)
+import qualified Data.Aeson as A
+import           Data.Generics.Product.Fields
+--------------------------------------------------------------------------------
+import           Xanthous.Data
+                 ( Positioned(..), positioned, position
+                 , diffPositions, stepTowards, isUnit
+                 , Ticks, (|*|), invertedRate
+                 )
+import           Xanthous.Data.EntityMap
+import           Xanthous.Entities.Creature.Hippocampus
+import           Xanthous.Entities.Character (Character)
+import qualified Xanthous.Entities.Character as Character
+import qualified Xanthous.Entities.RawTypes as Raw
+import           Xanthous.Entities.RawTypes (CreatureType)
+import           Xanthous.Game.State
+import           Xanthous.Game.Lenses
+                 ( entitiesCollision, collisionAt
+                 , character, characterPosition
+                 )
+import           Xanthous.Data.EntityMap.Graphics (linesOfSight, canSee)
+import           Xanthous.Random
+import           Xanthous.Monad (say)
+--------------------------------------------------------------------------------
+
+--  TODO move the following two classes to a more central location
+
+class HasVisionRadius a where visionRadius :: a -> Word
+
+type IsCreature entity =
+  ( HasVisionRadius entity
+  , HasField "_hippocampus" entity entity Hippocampus Hippocampus
+  , HasField "_creatureType" entity entity CreatureType CreatureType
+  , A.ToJSON entity
+  )
+
+--------------------------------------------------------------------------------
+
+stepGormlak
+  :: forall entity m.
+    ( MonadState GameState m, MonadRandom m
+    , IsCreature entity
+    )
+  => Ticks
+  -> Positioned entity
+  -> m (Positioned entity)
+stepGormlak ticks pe@(Positioned pos creature) = do
+  dest <- maybe (selectDestination pos creature) pure
+         $ creature ^. field @"_hippocampus" . destination
+  let progress' =
+        dest ^. destinationProgress
+        + creature ^. field @"_creatureType" . Raw.speed . invertedRate |*| ticks
+  if progress' < 1
+    then pure
+         $ pe
+         & positioned . field @"_hippocampus" . destination
+         ?~ (dest & destinationProgress .~ progress')
+    else do
+      let newPos = dest ^. destinationPosition
+          remainingSpeed = progress' - 1
+      newDest <- selectDestination newPos creature
+                <&> destinationProgress +~ remainingSpeed
+      let pe' = pe & positioned . field @"_hippocampus" . destination ?~ newDest
+      collisionAt newPos >>= \case
+        Nothing -> pure $ pe' & position .~ newPos
+        Just Stop -> pure pe'
+        Just Combat -> do
+          ents <- use $ entities . atPosition newPos
+          when (any (entityIs @Character) ents) attackCharacter
+          pure pe'
+  where
+    selectDestination pos' creature' = destinationFromPos <$> do
+      canSeeCharacter <- uses entities $ canSee (entityIs @Character) pos' vision
+      if canSeeCharacter
+        then do
+          charPos <- use characterPosition
+          if isUnit (pos' `diffPositions` charPos)
+            then attackCharacter $> pos'
+            else pure $ pos' `stepTowards` charPos
+      else do
+        lines <- map (takeWhile (isNothing . entitiesCollision . map snd . snd)
+                    -- the first item on these lines is always the creature itself
+                    . fromMaybe mempty . tailMay)
+                . linesOfSight pos' (visionRadius creature')
+                <$> use entities
+        line <- choose $ weightedBy length lines
+        pure $ fromMaybe pos' $ fmap fst . headMay =<< line
+
+    vision = visionRadius creature
+    attackCharacter = do
+      say ["combat", "creatureAttack"] $ object [ "creature" A..= creature ]
+      character %= Character.damage 1
+
+newtype GormlakBrain entity = GormlakBrain { _unGormlakBrain :: entity }
+
+instance (IsCreature entity) => Brain (GormlakBrain entity) where
+  step ticks
+    = fmap (fmap GormlakBrain)
+    . stepGormlak ticks
+    . fmap _unGormlakBrain
+  entityCanMove = const True
+
+--------------------------------------------------------------------------------
+
+-- instance Brain Creature where
+--   step = brainVia GormlakBrain
+--   entityCanMove = const True
+
+-- instance Entity Creature where
+--   blocksVision _ = False
+--   description = view $ Creature.creatureType . Raw.description
+--   entityChar = view $ Creature.creatureType . char
diff --git a/users/grfn/xanthous/src/Xanthous/App.hs b/users/grfn/xanthous/src/Xanthous/App.hs
new file mode 100644
index 000000000000..9091961b725c
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/App.hs
@@ -0,0 +1,469 @@
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE RecordWildCards      #-}
+--------------------------------------------------------------------------------
+module Xanthous.App
+  ( makeApp
+  , RunType(..)
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+import           Brick hiding (App, halt, continue, raw)
+import qualified Brick
+import           Graphics.Vty.Attributes (defAttr)
+import           Graphics.Vty.Input.Events (Event(EvKey))
+import           Control.Monad.State (get, gets)
+import           Control.Monad.State.Class (modify)
+import           Data.Aeson (object, ToJSON)
+import qualified Data.Aeson as A
+import qualified Data.Vector as V
+import           System.Exit
+import           System.Directory (doesFileExist)
+import           Data.List.NonEmpty (NonEmpty(..))
+--------------------------------------------------------------------------------
+import           Xanthous.App.Common
+import           Xanthous.App.Time
+import           Xanthous.App.Prompt
+import           Xanthous.App.Autocommands
+import           Xanthous.Command
+import           Xanthous.Data
+                 ( move
+                 , Dimensions'(Dimensions)
+                 , positioned
+                 , position
+                 , Position
+                 , (|*|)
+                 )
+import           Xanthous.Data.App (ResourceName, Panel(..), AppEvent(..))
+import qualified Xanthous.Data.EntityMap as EntityMap
+import           Xanthous.Data.Levels (prevLevel, nextLevel)
+import qualified Xanthous.Data.Levels as Levels
+import           Xanthous.Data.Entities (blocksObject)
+import           Xanthous.Game
+import           Xanthous.Game.State
+import           Xanthous.Game.Env
+import           Xanthous.Game.Draw (drawGame)
+import           Xanthous.Game.Prompt
+import qualified Xanthous.Messages as Messages
+import           Xanthous.Random
+import           Xanthous.Util (removeVectorIndex)
+import           Xanthous.Util.Inflection (toSentence)
+--------------------------------------------------------------------------------
+import qualified Xanthous.Entities.Character as Character
+import           Xanthous.Entities.Character hiding (pickUpItem)
+import           Xanthous.Entities.Item (Item)
+import qualified Xanthous.Entities.Item as Item
+import           Xanthous.Entities.Creature (Creature)
+import qualified Xanthous.Entities.Creature as Creature
+import           Xanthous.Entities.Environment
+                 (Door, open, closed, locked, GroundMessage(..), Staircase(..))
+import           Xanthous.Entities.RawTypes
+                 ( edible, eatMessage, hitpointsHealed
+                 , attackMessage
+                 )
+import           Xanthous.Generators
+import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
+import qualified Xanthous.Generators.Dungeon as Dungeon
+--------------------------------------------------------------------------------
+
+type App = Brick.App GameState AppEvent ResourceName
+
+data RunType = NewGame | LoadGame
+  deriving stock (Eq)
+
+makeApp :: GameEnv -> RunType -> IO App
+makeApp env rt = pure $ Brick.App
+  { appDraw = drawGame
+  , appChooseCursor = const headMay
+  , appHandleEvent = \game event -> runAppM (handleEvent event) env game
+  , appStartEvent = case rt of
+      NewGame -> runAppM (startEvent >> get) env
+      LoadGame -> pure
+  , appAttrMap = const $ attrMap defAttr []
+  }
+
+runAppM :: AppM a -> GameEnv -> GameState -> EventM ResourceName a
+runAppM appm ge = fmap fst . runAppT appm ge
+
+startEvent :: AppM ()
+startEvent = do
+  initLevel
+  modify updateCharacterVision
+  use (character . characterName) >>= \case
+    Nothing -> prompt_ @'StringPrompt ["character", "namePrompt"] Uncancellable
+      $ \(StringResult s) -> do
+        character . characterName ?= s
+        say ["welcome"] =<< use character
+    Just n -> say ["welcome"] $ object [ "characterName" A..= n ]
+
+initLevel :: AppM ()
+initLevel = do
+  level <- genLevel 0
+  entities <>= levelToEntityMap level
+  characterPosition .= level ^. levelCharacterPosition
+
+--------------------------------------------------------------------------------
+
+handleEvent :: BrickEvent ResourceName AppEvent -> AppM (Next GameState)
+handleEvent ev = use promptState >>= \case
+  NoPrompt -> handleNoPromptEvent ev
+  WaitingPrompt msg pr -> handlePromptEvent msg pr ev
+
+
+handleNoPromptEvent :: BrickEvent ResourceName AppEvent -> AppM (Next GameState)
+handleNoPromptEvent (VtyEvent (EvKey k mods))
+  | Just command <- commandFromKey k mods
+  = do messageHistory %= nextTurn
+       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 (Move dir) = do
+  newPos <- uses characterPosition $ move dir
+  collisionAt newPos >>= \case
+    Nothing -> do
+      characterPosition .= newPos
+      stepGameBy =<< uses (character . speed) (|*| 1)
+      describeEntitiesAt newPos
+    Just Combat -> attackAt newPos
+    Just Stop -> pure ()
+  continue
+
+handleCommand PickUp = do
+  pos <- use characterPosition
+  uses entities (entitiesAtPositionWithType @Item pos) >>= \case
+    [] -> say_ ["pickUp", "nothingToPickUp"]
+    [item] -> pickUpItem item
+    items' ->
+      menu_ ["pickUp", "menu"] Cancellable (entityMenu_ items')
+      $ \(MenuResult item) -> pickUpItem item
+  continue
+  where
+    pickUpItem (itemID, item) = do
+      character %= Character.pickUpItem item
+      entities . at itemID .= Nothing
+      say ["pickUp", "pickUp"] $ object [ "item" A..= item ]
+      stepGameBy 100 -- TODO
+
+handleCommand Drop = do
+  selectItemFromInventory_ ["drop", "menu"] Cancellable id
+    (say_ ["drop", "nothing"])
+    $ \(MenuResult item) -> do
+      entitiesAtCharacter %= (SomeEntity item <|)
+      say ["drop", "dropped"] $ object [ "item" A..= item ]
+  continue
+
+handleCommand PreviousMessage = do
+  messageHistory %= previousMessage
+  continue
+
+handleCommand Open = do
+  prompt_ @'DirectionPrompt ["open", "prompt"] Cancellable
+    $ \(DirectionResult dir) -> do
+      pos <- move dir <$> use characterPosition
+      doors <- uses entities $ entitiesAtPositionWithType @Door pos
+      if | null doors -> say_ ["open", "nothingToOpen"]
+         | any (view $ _2 . locked) doors -> say_ ["open", "locked"]
+         | all (view $ _2 . open) doors   -> say_ ["open", "alreadyOpen"]
+         | otherwise -> do
+             for_ doors $ \(eid, _) ->
+               entities . ix eid . positioned . _SomeEntity . open .= True
+             say_ ["open", "success"]
+      pure ()
+  stepGame -- TODO
+  continue
+
+handleCommand Close = do
+  prompt_ @'DirectionPrompt ["close", "prompt"] Cancellable
+    $ \(DirectionResult dir) -> do
+      pos <- move dir <$> use characterPosition
+      (nonDoors, doors) <- uses entities
+        $ partitionEithers
+        . toList
+        . map ( (matching . aside $ _SomeEntity @Door)
+              . over _2 (view positioned)
+              )
+        . EntityMap.atPositionWithIDs pos
+      if | null doors -> say_ ["close", "nothingToClose"]
+         | all (view $ _2 . closed) doors -> say_ ["close", "alreadyClosed"]
+         | any (view blocksObject . entityAttributes . snd) nonDoors ->
+           say ["close", "blocked"]
+           $ object [ "entityDescriptions"
+                      A..= ( toSentence
+                           . map description
+                           . filter (view blocksObject . entityAttributes)
+                           . map snd
+                           ) nonDoors
+                    , "blockOrBlocks"
+                      A..= ( if length nonDoors == 1
+                             then "blocks"
+                             else "block"
+                           :: Text)
+                    ]
+         | otherwise -> do
+             for_ doors $ \(eid, _) ->
+               entities . ix eid . positioned . _SomeEntity . closed .= True
+             for_ nonDoors $ \(eid, _) ->
+               entities . ix eid . position %= move dir
+             say_ ["close", "success"]
+      pure ()
+  stepGame -- TODO
+  continue
+
+handleCommand Look = do
+  prompt_ @'PointOnMap ["look", "prompt"] Cancellable
+    $ \(PointOnMapResult pos) ->
+      gets (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 Wield = do
+  selectItemFromInventory_ ["wield", "menu"] Cancellable asWieldedItem
+    (say_ ["wield", "nothing"])
+    $ \(MenuResult item) -> do
+      prevItems <- character . inventory . wielded <<.= inRightHand item
+      character . inventory . backpack
+        <>= fromList (prevItems ^.. wieldedItems . wieldedItem)
+      say ["wield", "wielded"] item
+  continue
+
+handleCommand Save = do
+  -- TODO default save locations / config file?
+  prompt_ @'StringPrompt ["save", "location"] Cancellable
+    $ \(StringResult filename) -> do
+       exists <- liftIO . doesFileExist $ unpack filename
+       if exists
+       then confirm ["save", "overwrite"] (object ["filename" A..= filename])
+            $ doSave filename
+       else doSave filename
+  continue
+  where
+    doSave filename = do
+      src <- gets saveGame
+      lift . liftIO $ do
+        writeFile (unpack filename) $ toStrict src
+        exitSuccess
+
+handleCommand GoUp = do
+  hasStairs <- uses entitiesAtCharacter $ elem (SomeEntity UpStaircase)
+  if hasStairs
+  then uses levels prevLevel >>= \case
+    Just levs' -> levels .= levs'
+    Nothing ->
+      -- TODO in nethack, this leaves the game. Maybe something similar here?
+      say_ ["cant", "goUp"]
+  else say_ ["cant", "goUp"]
+
+  continue
+
+handleCommand GoDown = do
+  hasStairs <- uses entitiesAtCharacter $ elem (SomeEntity DownStaircase)
+
+  if hasStairs
+  then do
+    levs <- use levels
+    let newLevelNum = Levels.pos levs + 1
+    levs' <- nextLevel (levelToGameLevel <$> genLevel newLevelNum) levs
+    cEID <- use characterEntityID
+    pCharacter <- entities . at cEID <<.= Nothing
+    levels .= levs'
+    entities . at cEID .= pCharacter
+    characterPosition .= extract levs' ^. upStaircasePosition
+  else say_ ["cant", "goDown"]
+
+  continue
+
+handleCommand (StartAutoMove dir) = do
+  runAutocommand $ AutoMove dir
+  continue
+
+--
+
+handleCommand ToggleRevealAll = do
+  val <- debugState . allRevealed <%= not
+  say ["debug", "toggleRevealAll"] $ object [ "revealAll" A..= val ]
+  continue
+
+--------------------------------------------------------------------------------
+attackAt :: Position -> AppM ()
+attackAt pos =
+  uses entities (entitiesAtPositionWithType @Creature pos) >>= \case
+    Empty               -> say_ ["combat", "nothingToAttack"]
+    (creature :< Empty) -> attackCreature creature
+    creatures ->
+      menu_ ["combat", "menu"] Cancellable (entityMenu_ creatures)
+      $ \(MenuResult creature) -> attackCreature creature
+ where
+  attackCreature (creatureID, creature) = do
+    charDamage <- uses character characterDamage
+    let creature' = Creature.damage charDamage creature
+        msgParams = object ["creature" A..= creature']
+    if Creature.isDead creature'
+      then do
+        say ["combat", "killed"] msgParams
+        entities . at creatureID .= Nothing
+      else do
+        msg <- uses character getAttackMessage
+        message msg msgParams
+        entities . ix creatureID . positioned .= SomeEntity creature'
+
+    whenM (uses character $ isNothing . weapon)
+      $ whenM (chance (0.08 :: Float)) $ do
+        say_ ["combat", "fistSelfDamage"]
+        character %= Character.damage 1
+
+    stepGame -- TODO
+  weapon chr = chr ^? inventory . wielded . wieldedItems . wieldableItem
+  getAttackMessage chr =
+    case weapon chr of
+      Just wi ->
+        fromMaybe (Messages.lookup ["combat", "hit", "generic"])
+        $ wi ^. attackMessage
+      Nothing ->
+        Messages.lookup ["combat", "hit", "fists"]
+
+entityMenu_
+  :: (Comonad w, Entity entity)
+  => [w entity]
+  -> Map Char (MenuOption (w entity))
+entityMenu_ = mkMenuItems @[_] . map entityMenuItem
+  where
+    entityMenuItem wentity
+      = let entity = extract wentity
+      in (entityMenuChar entity, MenuOption (description entity) wentity)
+
+
+entityMenuChar :: Entity a => a -> Char
+entityMenuChar entity
+  = let ec = entityChar entity ^. char
+    in if ec `elem` (['a'..'z'] ++ ['A'..'Z'])
+        then ec
+        else 'a'
+
+-- | Prompt with an item to select out of the inventory, remove it from the
+-- inventory, and call callback with it
+selectItemFromInventory
+  :: forall item params.
+    (ToJSON params)
+  => [Text]            -- ^ Menu message
+  -> params            -- ^ Menu message params
+  -> PromptCancellable -- ^ Is the menu cancellable?
+  -> Prism' Item item  -- ^ Attach some extra information to the item, in a
+                      --   recoverable fashion. Prism vs iso so we can discard
+                      --   items.
+  -> AppM ()            -- ^ Action to take if there are no items matching
+  -> (PromptResult ('Menu item) -> AppM ())
+  -> AppM ()
+selectItemFromInventory msgPath msgParams cancellable extraInfo onEmpty cb =
+  uses (character . inventory . backpack)
+       (V.mapMaybe $ preview extraInfo)
+    >>= \case
+      Empty -> onEmpty
+      items' ->
+        menu msgPath msgParams cancellable (itemMenu items')
+        $ \(MenuResult (idx, item)) -> do
+          character . inventory . backpack %= removeVectorIndex idx
+          cb $ MenuResult item
+  where
+    itemMenu = mkMenuItems . imap itemMenuItem
+    itemMenuItem idx extraInfoItem =
+      let item = extraInfo # extraInfoItem
+      in ( entityMenuChar item
+         , MenuOption (description item) (idx, extraInfoItem))
+
+selectItemFromInventory_
+  :: forall item.
+    [Text]            -- ^ Menu message
+  -> PromptCancellable -- ^ Is the menu cancellable?
+  -> Prism' Item item  -- ^ Attach some extra information to the item, in a
+                      --   recoverable fashion. Prism vs iso so we can discard
+                      --   items.
+  -> AppM ()            -- ^ Action to take if there are no items matching
+  -> (PromptResult ('Menu item) -> AppM ())
+  -> AppM ()
+selectItemFromInventory_ msgPath = selectItemFromInventory msgPath ()
+
+-- entityMenu :: Entity entity => [entity] -> Map Char (MenuOption entity)
+-- entityMenu = map (map runIdentity) . entityMenu_ . fmap Identity
+
+showPanel :: Panel -> AppM ()
+showPanel panel = do
+  activePanel ?= panel
+  prompt_ @'Continue ["generic", "continue"] Uncancellable
+    . const
+    $ activePanel .= Nothing
+
+--------------------------------------------------------------------------------
+
+genLevel
+  :: Int -- ^ level number
+  -> AppM Level
+genLevel _num = do
+  let dims = Dimensions 80 80
+  generator <- choose $ CaveAutomata :| [Dungeon]
+  level <- case generator of
+    CaveAutomata -> generateLevel SCaveAutomata CaveAutomata.defaultParams dims
+    Dungeon -> generateLevel SDungeon Dungeon.defaultParams dims
+  pure $!! level
+
+levelToGameLevel :: Level -> GameLevel
+levelToGameLevel level =
+  let _levelEntities = levelToEntityMap level
+      _upStaircasePosition = level ^. levelCharacterPosition
+      _levelRevealedPositions = mempty
+  in GameLevel {..}
diff --git a/users/grfn/xanthous/src/Xanthous/App/Autocommands.hs b/users/grfn/xanthous/src/Xanthous/App/Autocommands.hs
new file mode 100644
index 000000000000..f393a0e2ea9a
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/App/Autocommands.hs
@@ -0,0 +1,64 @@
+--------------------------------------------------------------------------------
+module Xanthous.App.Autocommands
+  ( runAutocommand
+  , autoStep
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Control.Concurrent (threadDelay)
+import qualified Data.Aeson as A
+import           Data.Aeson (object)
+import           Data.List.NonEmpty (nonEmpty)
+import qualified Data.List.NonEmpty as NE
+import           Control.Monad.State (gets)
+--------------------------------------------------------------------------------
+import           Xanthous.App.Common
+import           Xanthous.App.Time
+import           Xanthous.Data
+import           Xanthous.Data.App
+import           Xanthous.Entities.Character (speed)
+import           Xanthous.Entities.Creature (Creature, creatureType)
+import           Xanthous.Entities.RawTypes (hostile)
+import           Xanthous.Game.State
+--------------------------------------------------------------------------------
+
+autoStep :: Autocommand -> AppM ()
+autoStep (AutoMove dir) = do
+  newPos <- uses characterPosition $ move dir
+  collisionAt newPos >>= \case
+    Nothing -> do
+      characterPosition .= newPos
+      stepGameBy =<< uses (character . speed) (|*| 1)
+      describeEntitiesAt newPos
+      maybeVisibleEnemies <- nonEmpty <$> enemiesInSight
+      for_ maybeVisibleEnemies $ \visibleEnemies -> do
+        say ["autoMove", "enemyInSight"]
+          $ object [ "firstEntity" A..= NE.head visibleEnemies ]
+        cancelAutocommand
+    Just _ -> cancelAutocommand
+  where
+    enemiesInSight :: AppM [Creature]
+    enemiesInSight = do
+      ents <- gets characterVisibleEntities
+      pure $ ents
+         ^.. folded
+           . _SomeEntity @Creature
+           . filtered (view $ creatureType . hostile)
+
+--------------------------------------------------------------------------------
+
+autocommandIntervalμs :: Int
+autocommandIntervalμs = 1000 * 50 -- 50 ms
+
+runAutocommand :: Autocommand -> AppM ()
+runAutocommand ac = do
+  env <- ask
+  tid <- liftIO . async $ runReaderT go env
+  autocommand .= ActiveAutocommand ac tid
+  where
+    go = everyμs autocommandIntervalμs $ sendEvent AutoContinue
+
+-- | Perform 'act' every μs microseconds forever
+everyμs :: MonadIO m => Int -> m () -> m ()
+everyμs μs act = act >> liftIO (threadDelay μs) >> everyμs μs act
diff --git a/users/grfn/xanthous/src/Xanthous/App/Common.hs b/users/grfn/xanthous/src/Xanthous/App/Common.hs
new file mode 100644
index 000000000000..69ba6f0e0596
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/src/Xanthous/App/Prompt.hs b/users/grfn/xanthous/src/Xanthous/App/Prompt.hs
new file mode 100644
index 000000000000..9b5a3bf24fa7
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/App/Prompt.hs
@@ -0,0 +1,161 @@
+{-# LANGUAGE UndecidableInstances #-}
+--------------------------------------------------------------------------------
+module Xanthous.App.Prompt
+  ( handlePromptEvent
+  , clearPrompt
+  , prompt
+  , prompt_
+  , confirm_
+  , confirm
+  , menu
+  , menu_
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Brick (BrickEvent(..), Next)
+import           Brick.Widgets.Edit (handleEditorEvent)
+import           Data.Aeson (ToJSON, object)
+import           Graphics.Vty.Input.Events (Event(EvKey), Key(..))
+import           GHC.TypeLits (ErrorMessage(..))
+--------------------------------------------------------------------------------
+import           Xanthous.App.Common
+import           Xanthous.Data (move)
+import           Xanthous.Command (directionFromChar)
+import           Xanthous.Data.App (ResourceName, AppEvent)
+import           Xanthous.Game.Prompt
+import           Xanthous.Game.State
+import qualified Xanthous.Messages as Messages
+--------------------------------------------------------------------------------
+
+handlePromptEvent
+  :: Text -- ^ Prompt message
+  -> Prompt AppM
+  -> BrickEvent ResourceName AppEvent
+  -> AppM (Next GameState)
+
+handlePromptEvent _ (Prompt Cancellable _ _ _ _) (VtyEvent (EvKey KEsc []))
+  = clearPrompt >> continue
+handlePromptEvent _ pr (VtyEvent (EvKey KEnter []))
+  = clearPrompt >> submitPrompt pr >> continue
+
+handlePromptEvent _ pr@(Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'y') []))
+  = clearPrompt >> submitPrompt pr >> continue
+
+handlePromptEvent _ (Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'n') []))
+  = clearPrompt >> continue
+
+handlePromptEvent
+  msg
+  (Prompt c SStringPrompt (StringPromptState edit) pri cb)
+  (VtyEvent ev)
+  = do
+    edit' <- lift $ handleEditorEvent ev edit
+    let prompt' = Prompt c SStringPrompt (StringPromptState edit') pri cb
+    promptState .= WaitingPrompt msg prompt'
+    continue
+
+handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ cb)
+  (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) []))
+  = clearPrompt >> cb (DirectionResult dir) >> continue
+handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ _) _ = continue
+
+handlePromptEvent _ (Prompt _ SMenu _ items' cb) (VtyEvent (EvKey (KChar chr) []))
+  | Just (MenuOption _ res) <- items' ^. at chr
+  = clearPrompt >> cb (MenuResult res) >> continue
+  | otherwise
+  = continue
+
+handlePromptEvent
+  msg
+  (Prompt c SPointOnMap (PointOnMapPromptState pos) pri cb)
+  (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) []))
+  = let pos' = move dir pos
+        prompt' = Prompt c SPointOnMap (PointOnMapPromptState pos') pri cb
+    in promptState .= WaitingPrompt msg prompt'
+       >> continue
+handlePromptEvent _ (Prompt _ SPointOnMap _ _ _) _ = continue
+
+handlePromptEvent
+  _
+  (Prompt Cancellable _ _ _ _)
+  (VtyEvent (EvKey (KChar 'q') []))
+  = clearPrompt >> continue
+handlePromptEvent _ _ _ = continue
+
+clearPrompt :: AppM ()
+clearPrompt = promptState .= NoPrompt
+
+class NotMenu (pt :: PromptType)
+instance NotMenu 'StringPrompt
+instance NotMenu 'Confirm
+instance NotMenu 'DirectionPrompt
+instance NotMenu 'PointOnMap
+instance NotMenu 'Continue
+instance TypeError ('Text "Cannot use `prompt` or `prompt_` for menu prompts"
+                    ':$$: 'Text "Use `menu` or `menu_` instead")
+         => NotMenu ('Menu a)
+
+prompt
+  :: forall (pt :: PromptType) (params :: Type).
+    (ToJSON params, SingPromptType pt, NotMenu pt)
+  => [Text]                     -- ^ Message key
+  -> params                     -- ^ Message params
+  -> PromptCancellable
+  -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler
+  -> AppM ()
+prompt msgPath params cancellable cb = do
+  let pt = singPromptType @pt
+  msg <- Messages.message msgPath params
+  p <- case pt of
+    SPointOnMap -> do
+      charPos <- use characterPosition
+      pure $ mkPointOnMapPrompt cancellable charPos cb
+    SStringPrompt -> pure $ mkPrompt cancellable pt cb
+    SConfirm -> pure $ mkPrompt cancellable pt cb
+    SDirectionPrompt -> pure $ mkPrompt cancellable pt cb
+    SContinue -> pure $ mkPrompt cancellable pt cb
+    SMenu -> error "unreachable"
+  promptState .= WaitingPrompt msg p
+
+prompt_
+  :: forall (pt :: PromptType).
+    (SingPromptType pt, NotMenu pt)
+  => [Text] -- ^ Message key
+  -> PromptCancellable
+  -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler
+  -> AppM ()
+prompt_ msg = prompt msg $ object []
+
+confirm
+  :: ToJSON params
+  => [Text] -- ^ Message key
+  -> params
+  -> AppM ()
+  -> AppM ()
+confirm msgPath params
+  = prompt @'Confirm msgPath params Cancellable . const
+
+confirm_ :: [Text] -> AppM () -> AppM ()
+confirm_ msgPath = confirm msgPath $ object []
+
+menu :: forall (a :: Type) (params :: Type).
+       (ToJSON params)
+     => [Text]                            -- ^ Message key
+     -> params                            -- ^ Message params
+     -> PromptCancellable
+     -> Map Char (MenuOption a)           -- ^ Menu items
+     -> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler
+     -> AppM ()
+menu msgPath params cancellable items' cb = do
+  msg <- Messages.message msgPath params
+  let p = mkMenu cancellable items' cb
+  promptState .= WaitingPrompt msg p
+
+menu_ :: forall (a :: Type).
+        [Text]                            -- ^ Message key
+      -> PromptCancellable
+      -> Map Char (MenuOption a)           -- ^ Menu items
+      -> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler
+      -> AppM ()
+menu_ msgPath = menu msgPath $ object []
diff --git a/users/grfn/xanthous/src/Xanthous/App/Time.hs b/users/grfn/xanthous/src/Xanthous/App/Time.hs
new file mode 100644
index 000000000000..b17348f3853e
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/App/Time.hs
@@ -0,0 +1,40 @@
+--------------------------------------------------------------------------------
+module Xanthous.App.Time
+  ( stepGame
+  , stepGameBy
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           System.Exit
+--------------------------------------------------------------------------------
+import           Xanthous.Data (Ticks)
+import           Xanthous.App.Prompt
+import qualified Xanthous.Data.EntityMap as EntityMap
+import           Xanthous.Entities.Character (isDead)
+import           Xanthous.Game.State
+import           Xanthous.Game.Prompt
+import           Xanthous.Game.Lenses
+import           Control.Monad.State (modify)
+--------------------------------------------------------------------------------
+
+
+stepGameBy :: Ticks -> AppM ()
+stepGameBy ticks = do
+  ents <- uses entities EntityMap.toEIDsAndPositioned
+  for_ ents $ \(eid, pEntity) -> do
+    pEntity' <- step ticks pEntity
+    entities . ix eid .= pEntity'
+
+  modify updateCharacterVision
+
+  whenM (uses character isDead)
+    . prompt_ @'Continue ["dead"] Uncancellable
+    . const . lift . liftIO
+    $ exitSuccess
+
+ticksPerTurn :: Ticks
+ticksPerTurn = 100
+
+stepGame :: AppM ()
+stepGame = stepGameBy ticksPerTurn
diff --git a/users/grfn/xanthous/src/Xanthous/Command.hs b/users/grfn/xanthous/src/Xanthous/Command.hs
new file mode 100644
index 000000000000..37025dd37ad2
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Command.hs
@@ -0,0 +1,73 @@
+--------------------------------------------------------------------------------
+module Xanthous.Command where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude hiding (Left, Right, Down)
+--------------------------------------------------------------------------------
+import Graphics.Vty.Input (Key(..), Modifier(..))
+import qualified Data.Char as Char
+--------------------------------------------------------------------------------
+import Xanthous.Data (Direction(..))
+--------------------------------------------------------------------------------
+
+data Command
+  = Quit
+  | Move Direction
+  | StartAutoMove Direction
+  | PreviousMessage
+  | PickUp
+  | Drop
+  | Open
+  | Close
+  | Wait
+  | Eat
+  | Look
+  | Save
+  | Read
+  | ShowInventory
+  | Wield
+  | GoUp
+  | GoDown
+
+    -- | TODO replace with `:` commands
+  | ToggleRevealAll
+
+commandFromKey :: Key -> [Modifier] -> Maybe Command
+commandFromKey (KChar 'q') [] = Just Quit
+commandFromKey (KChar '.') [] = Just Wait
+commandFromKey (KChar (directionFromChar -> Just dir)) [] = Just $ Move dir
+commandFromKey (KChar c) []
+  | Char.isUpper c
+  , Just dir <- directionFromChar $ Char.toLower c
+  = Just $ StartAutoMove dir
+commandFromKey (KChar 'p') [MCtrl] = Just PreviousMessage
+commandFromKey (KChar ',') [] = Just PickUp
+commandFromKey (KChar 'd') [] = Just Drop
+commandFromKey (KChar 'o') [] = Just Open
+commandFromKey (KChar 'c') [] = Just Close
+commandFromKey (KChar ';') [] = Just Look
+commandFromKey (KChar 'e') [] = Just Eat
+commandFromKey (KChar 'S') [] = Just Save
+commandFromKey (KChar 'r') [] = Just Read
+commandFromKey (KChar 'i') [] = Just ShowInventory
+commandFromKey (KChar 'w') [] = Just Wield
+commandFromKey (KChar '<') [] = Just GoUp
+commandFromKey (KChar '>') [] = Just GoDown
+
+-- DEBUG COMMANDS --
+commandFromKey (KChar 'r') [MMeta] = Just ToggleRevealAll
+
+commandFromKey _ _ = Nothing
+
+--------------------------------------------------------------------------------
+
+directionFromChar :: Char -> Maybe Direction
+directionFromChar 'h' = Just Left
+directionFromChar 'j' = Just Down
+directionFromChar 'k' = Just Up
+directionFromChar 'l' = Just Right
+directionFromChar 'y' = Just UpLeft
+directionFromChar 'u' = Just UpRight
+directionFromChar 'b' = Just DownLeft
+directionFromChar 'n' = Just DownRight
+directionFromChar '.' = Just Here
+directionFromChar _   = Nothing
diff --git a/users/grfn/xanthous/src/Xanthous/Data.hs b/users/grfn/xanthous/src/Xanthous/Data.hs
new file mode 100644
index 000000000000..c9c11b553b67
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Data.hs
@@ -0,0 +1,590 @@
+{-# LANGUAGE PartialTypeSignatures  #-}
+{-# LANGUAGE StandaloneDeriving     #-}
+{-# LANGUAGE RoleAnnotations        #-}
+{-# LANGUAGE RecordWildCards        #-}
+{-# LANGUAGE DeriveTraversable      #-}
+{-# LANGUAGE DeriveFoldable         #-}
+{-# LANGUAGE DeriveFunctor          #-}
+{-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE NoTypeSynonymInstances #-}
+{-# LANGUAGE DuplicateRecordFields  #-}
+--------------------------------------------------------------------------------
+-- | Common data types for Xanthous
+--------------------------------------------------------------------------------
+module Xanthous.Data
+  ( Opposite(..)
+
+    -- *
+  , Position'(..)
+  , Position
+  , x
+  , y
+
+    -- **
+  , Positioned(..)
+  , _Positioned
+  , position
+  , positioned
+  , loc
+  , _Position
+  , positionFromPair
+  , positionFromV2
+  , addPositions
+  , diffPositions
+  , stepTowards
+  , isUnit
+
+    -- * Boxes
+  , Box(..)
+  , topLeftCorner
+  , bottomRightCorner
+  , setBottomRightCorner
+  , dimensions
+  , inBox
+  , boxIntersects
+  , boxCenter
+  , boxEdge
+  , module Linear.V2
+
+    -- *
+  , Per(..)
+  , invertRate
+  , invertedRate
+  , (|*|)
+  , Ticks(..)
+  , Tiles(..)
+  , TicksPerTile
+  , TilesPerTick
+  , timesTiles
+
+    -- *
+  , Dimensions'(..)
+  , Dimensions
+  , HasWidth(..)
+  , HasHeight(..)
+
+    -- *
+  , Direction(..)
+  , move
+  , asPosition
+  , directionOf
+  , Cardinal(..)
+
+    -- *
+  , Corner(..)
+  , Edge(..)
+  , cornerEdges
+
+    -- *
+  , Neighbors(..)
+  , edges
+  , neighborDirections
+  , neighborPositions
+  , 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           Xanthous.Util (EqEqProp(..), EqProp, between)
+import           Xanthous.Util.QuickCheck (GenericArbitrary(..))
+import           Xanthous.Orphans ()
+import           Xanthous.Util.Graphics
+--------------------------------------------------------------------------------
+
+-- | opposite ∘ opposite ≡ id
+class Opposite x where
+  opposite :: x -> x
+
+--------------------------------------------------------------------------------
+
+-- fromScalar ∘ scalar ≡ id
+class Scalar a where
+  scalar :: a -> Double
+  fromScalar :: Double -> a
+
+instance Scalar Double where
+  scalar = id
+  fromScalar = id
+
+newtype ScalarIntegral a = ScalarIntegral a
+  deriving newtype (Eq, Ord, Num, Enum, Real, Integral)
+instance Integral a => Scalar (ScalarIntegral a) where
+  scalar = fromIntegral
+  fromScalar = floor
+
+deriving via (ScalarIntegral Integer) instance Scalar Integer
+deriving via (ScalarIntegral Word) instance Scalar Word
+
+--------------------------------------------------------------------------------
+
+data Position' a where
+  Position :: { _x :: a
+             , _y :: a
+             } -> (Position' a)
+  deriving stock (Show, Eq, Generic, Ord, Functor, Foldable, Traversable)
+  deriving anyclass (NFData, Hashable, CoArbitrary, Function)
+  deriving EqProp via EqEqProp (Position' a)
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       (Position' a)
+
+x, y :: Lens' (Position' a) a
+x = lens (\(Position xx _) -> xx) (\(Position _ yy) xx -> Position xx yy)
+y = lens (\(Position _ yy) -> yy) (\(Position xx _) yy -> Position xx yy)
+
+type Position = Position' Int
+
+instance Arbitrary a => Arbitrary (Position' a) where
+  arbitrary = genericArbitrary
+  shrink (Position px py) = Position <$> shrink px <*> shrink py
+
+
+instance Num a => Semigroup (Position' a) where
+  (Position x₁ y₁) <> (Position x₂ y₂) = Position (x₁ + x₂) (y₁ + y₂)
+
+instance Num a => Monoid (Position' a) where
+  mempty = Position 0 0
+
+instance Num a => Group (Position' a) where
+  invert (Position px py) = Position (negate px) (negate py)
+
+-- | Positions convert to scalars by discarding their orientation and just
+-- measuring the length from the origin
+instance (Ord a, Num a, Scalar a) => Scalar (Position' a) where
+  scalar = fromIntegral . length . line 0 . 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 Arbitrary via GenericArbitrary Direction
+
+instance Opposite Direction where
+  opposite Up        = Down
+  opposite Down      = Up
+  opposite Left      = Right
+  opposite Right     = Left
+  opposite UpLeft    = DownRight
+  opposite UpRight   = DownLeft
+  opposite DownLeft  = UpRight
+  opposite DownRight = UpLeft
+  opposite Here      = Here
+
+move :: Num a => Direction -> Position' a -> Position' a
+move Up        = y -~ 1
+move Down      = y +~ 1
+move Left      = x -~ 1
+move Right     = x +~ 1
+move UpLeft    = move Up . move Left
+move UpRight   = move Up . move Right
+move DownLeft  = move Down . move Left
+move DownRight = move Down . move Right
+move Here      = id
+
+asPosition :: Direction -> Position
+asPosition dir = move dir mempty
+
+-- | Returns the direction that a given position is from a given source position
+directionOf
+  :: Position -- ^ Source
+  -> Position -- ^ Target
+  -> Direction
+directionOf (Position x₁ y₁) (Position x₂ y₂) =
+  case (x₁ `compare` x₂, y₁ `compare` y₂) of
+    (EQ, EQ) -> Here
+    (EQ, LT) -> Down
+    (EQ, GT) -> Up
+    (LT, EQ) -> Right
+    (GT, EQ) -> Left
+
+    (LT, LT) -> DownRight
+    (GT, LT) -> DownLeft
+
+    (LT, GT) -> UpRight
+    (GT, GT) -> UpLeft
+
+-- | Take one (potentially diagonal) step towards the given position
+--
+-- ∀ src tgt. isUnit (src `diffPositions` (src `stepTowards tgt`))
+stepTowards
+  :: Position -- ^ Source
+  -> Position -- ^ Target
+  -> Position
+stepTowards (view _Position -> p₁) (view _Position -> p₂)
+  | p₁ == p₂ = _Position # p₁
+  | otherwise =
+    let (_:p:_) = line p₁ p₂
+    in _Position # p
+
+-- | Newtype controlling arbitrary generation to only include cardinal
+-- directions ('Up', 'Down', 'Left', 'Right')
+newtype Cardinal = Cardinal { getCardinal :: Direction }
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, Function, CoArbitrary)
+  deriving newtype (Opposite)
+
+instance Arbitrary Cardinal where
+  arbitrary = Cardinal <$> elements [Up, Down, Left, Right]
+
+--------------------------------------------------------------------------------
+
+data Corner
+  = TopLeft
+  | TopRight
+  | BottomLeft
+  | BottomRight
+  deriving stock (Show, Eq, Ord, Enum, Bounded, Generic)
+  deriving Arbitrary via GenericArbitrary Corner
+
+instance Opposite Corner where
+  opposite TopLeft = BottomRight
+  opposite TopRight = BottomLeft
+  opposite BottomLeft = TopRight
+  opposite BottomRight = TopLeft
+
+data Edge
+  = TopEdge
+  | LeftEdge
+  | RightEdge
+  | BottomEdge
+  deriving stock (Show, Eq, Ord, Enum, Bounded, Generic)
+  deriving Arbitrary via GenericArbitrary Edge
+
+instance Opposite Edge where
+  opposite TopEdge = BottomEdge
+  opposite BottomEdge = TopEdge
+  opposite LeftEdge = RightEdge
+  opposite RightEdge = LeftEdge
+
+cornerEdges :: Corner -> (Edge, Edge)
+cornerEdges TopLeft = (TopEdge, LeftEdge)
+cornerEdges TopRight = (TopEdge, RightEdge)
+cornerEdges BottomLeft = (BottomEdge, LeftEdge)
+cornerEdges BottomRight = (BottomEdge, RightEdge)
+
+--------------------------------------------------------------------------------
+
+data Neighbors a = Neighbors
+  { _topLeft
+  , _top
+  , _topRight
+  , _left
+  , _right
+  , _bottomLeft
+  , _bottom
+  , _bottomRight :: a
+  }
+  deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function, MonoFoldable)
+  deriving Arbitrary via GenericArbitrary (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 (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON) via Double
+  deriving (Semigroup, Monoid) via Product Double
+instance Arbitrary (Per a b) where arbitrary = genericArbitrary
+
+invertRate :: a `Per` b -> b `Per` a
+invertRate (Rate p) = Rate $ 1 / p
+
+invertedRate :: Iso (a `Per` b) (b' `Per` a') (b `Per` a) (a' `Per` b')
+invertedRate = iso invertRate invertRate
+
+infixl 7 |*|
+(|*|) :: (Scalar a, Scalar b) => a `Per` b -> b -> a
+(|*|) (Rate rate) b = fromScalar $ rate * scalar b
+
+newtype Ticks = Ticks Word
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (Num, Ord, Bounded, Enum, Integral, Real, ToJSON, FromJSON) via Word
+  deriving (Semigroup, Monoid) via (Sum Word)
+  deriving Scalar via ScalarIntegral Ticks
+instance Arbitrary Ticks where arbitrary = genericArbitrary
+
+newtype Tiles = Tiles Double
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (Num, Ord, Enum, Real, ToJSON, FromJSON, Scalar) via Double
+  deriving (Semigroup, Monoid) via (Sum Double)
+instance Arbitrary Tiles where arbitrary = genericArbitrary
+
+type TicksPerTile = Ticks `Per` Tiles
+type TilesPerTick = Tiles `Per` Ticks
+
+timesTiles :: TicksPerTile -> Tiles -> Ticks
+timesTiles = (|*|)
+
+--------------------------------------------------------------------------------
+
+newtype Hitpoints = Hitpoints Word
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (Arbitrary, Num, Ord, Bounded, Enum, Integral, Real, ToJSON, FromJSON)
+       via Word
+  deriving (Semigroup, Monoid) via Sum Word
+
+--------------------------------------------------------------------------------
+
+data Box a = Box
+  { _topLeftCorner :: V2 a
+  , _dimensions    :: V2 a
+  }
+  deriving stock (Show, Eq, Ord, Functor, Generic)
+  deriving Arbitrary via GenericArbitrary (Box a)
+makeFieldsNoPrefix ''Box
+
+bottomRightCorner :: Num a => Box a -> V2 a
+bottomRightCorner box =
+  V2 (box ^. topLeftCorner . L._x + box ^. dimensions . L._x)
+     (box ^. topLeftCorner . L._y + box ^. dimensions . L._y)
+
+setBottomRightCorner :: (Num a, Ord a) => Box a -> V2 a -> Box a
+setBottomRightCorner box br@(V2 brx bry)
+  | brx < box ^. topLeftCorner . L._x || bry < box ^. topLeftCorner . L._y
+  = box & topLeftCorner .~ br
+        & dimensions . L._x .~ ((box ^. topLeftCorner . L._x) - brx)
+        & dimensions . L._y .~ ((box ^. topLeftCorner . L._y) - bry)
+  | otherwise
+  = box & dimensions . L._x .~ (brx - (box ^. topLeftCorner . L._x))
+        & dimensions . L._y .~ (bry - (box ^. topLeftCorner . L._y))
+
+inBox :: (Ord a, Num a) => Box a -> V2 a -> Bool
+inBox box pt = flip all [L._x, L._y] $ \component ->
+  between (box ^. topLeftCorner . component)
+          (box ^. to bottomRightCorner . component)
+          (pt ^. component)
+
+boxIntersects :: (Ord a, Num a) => Box a -> Box a -> Bool
+boxIntersects box₁ box₂
+  = any (inBox box₁) [box₂ ^. topLeftCorner, bottomRightCorner box₂]
+
+boxCenter :: (Fractional a) => Box a -> V2 a
+boxCenter box = V2 cx cy
+ where
+   cx = box ^. topLeftCorner . L._x + (box ^. dimensions . L._x / 2)
+   cy = box ^. topLeftCorner . L._y + (box ^. dimensions . L._y / 2)
+
+boxEdge :: (Enum a, Num a) => Box a -> Edge -> [V2 a]
+boxEdge box LeftEdge =
+  V2 (box ^. topLeftCorner . L._x)
+  <$> [box ^. topLeftCorner . L._y .. box ^. to bottomRightCorner . L._y]
+boxEdge box RightEdge =
+  V2 (box ^. to bottomRightCorner . L._x)
+  <$> [box ^. to bottomRightCorner . L._y .. box ^. to bottomRightCorner . L._y]
+boxEdge box TopEdge =
+  flip V2 (box ^. topLeftCorner . L._y)
+  <$> [box ^. topLeftCorner . L._x .. box ^. to bottomRightCorner . L._x]
+boxEdge box BottomEdge =
+  flip V2 (box ^. to bottomRightCorner . L._y)
+  <$> [box ^. topLeftCorner . L._x .. box ^. to bottomRightCorner . L._x]
diff --git a/users/grfn/xanthous/src/Xanthous/Data/App.hs b/users/grfn/xanthous/src/Xanthous/Data/App.hs
new file mode 100644
index 000000000000..0361d2a59ed5
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Data/App.hs
@@ -0,0 +1,39 @@
+--------------------------------------------------------------------------------
+module Xanthous.Data.App
+  ( Panel(..)
+  , ResourceName(..)
+  , AppEvent(..)
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Test.QuickCheck
+import Data.Aeson (ToJSON, FromJSON)
+--------------------------------------------------------------------------------
+import Xanthous.Util.QuickCheck
+--------------------------------------------------------------------------------
+
+-- | Enum for "panels" displayed in the game's UI.
+data Panel
+  = InventoryPanel -- ^ A panel displaying the character's inventory
+  deriving stock (Show, Eq, Ord, Generic, Enum, Bounded)
+  deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON)
+  deriving Arbitrary via GenericArbitrary Panel
+
+
+data ResourceName
+  = MapViewport -- ^ The main viewport where we display the game content
+  | Character   -- ^ The character
+  | MessageBox  -- ^ The box where we display messages to the user
+  | Prompt      -- ^ The game's prompt
+  | Panel Panel -- ^ A panel in the game
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON)
+  deriving Arbitrary via GenericArbitrary ResourceName
+
+data AppEvent
+  = AutoContinue -- ^ Continue whatever autocommand has been requested by the
+                 --   user
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON)
+  deriving Arbitrary via GenericArbitrary AppEvent
diff --git a/users/grfn/xanthous/src/Xanthous/Data/Entities.hs b/users/grfn/xanthous/src/Xanthous/Data/Entities.hs
new file mode 100644
index 000000000000..39953410f2f3
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/src/Xanthous/Data/EntityChar.hs b/users/grfn/xanthous/src/Xanthous/Data/EntityChar.hs
new file mode 100644
index 000000000000..855a3462daee
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/src/Xanthous/Data/EntityMap.hs b/users/grfn/xanthous/src/Xanthous/Data/EntityMap.hs
new file mode 100644
index 000000000000..d24defa841ab
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Data/EntityMap.hs
@@ -0,0 +1,272 @@
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE DeriveTraversable  #-}
+{-# LANGUAGE TupleSections      #-}
+{-# LANGUAGE TemplateHaskell    #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveFunctor      #-}
+--------------------------------------------------------------------------------
+module Xanthous.Data.EntityMap
+  ( EntityMap
+  , _EntityMap
+  , EntityID
+  , emptyEntityMap
+  , insertAt
+  , insertAtReturningID
+  , fromEIDsAndPositioned
+  , toEIDsAndPositioned
+  , atPosition
+  , atPositionWithIDs
+  , positions
+  , lookup
+  , lookupWithPosition
+  -- , positionedEntities
+  , neighbors
+  , Deduplicate(..)
+
+  -- * debug
+  , byID
+  , byPosition
+  , lastID
+
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude hiding (lookup)
+import Xanthous.Data
+  ( Position
+  , Positioned(..)
+  , positioned
+  , Neighbors(..)
+  , neighborPositions
+  )
+import Xanthous.Data.VectorBag
+import Xanthous.Orphans ()
+import Xanthous.Util (EqEqProp(..))
+--------------------------------------------------------------------------------
+import Data.Monoid (Endo(..))
+import Test.QuickCheck (Arbitrary(..), CoArbitrary, Function)
+import Test.QuickCheck.Checkers (EqProp)
+import Test.QuickCheck.Instances.UnorderedContainers ()
+import Test.QuickCheck.Instances.Vector ()
+import Text.Show (showString, showParen)
+import Data.Aeson
+--------------------------------------------------------------------------------
+
+type EntityID = Word32
+type NonNullSet a = NonNull (Set a)
+
+data EntityMap a where
+  EntityMap ::
+    { _byPosition :: Map Position (NonNullSet EntityID)
+    , _byID       :: HashMap EntityID (Positioned a)
+    , _lastID     :: EntityID
+    } -> EntityMap a
+  deriving stock (Functor, Foldable, Traversable, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+deriving via (EqEqProp (EntityMap a)) instance (Eq a, Ord a) => EqProp (EntityMap a)
+makeLenses ''EntityMap
+
+instance ToJSON a => ToJSON (EntityMap a) where
+  toJSON = toJSON . toEIDsAndPositioned
+
+
+instance FromJSON a => FromJSON (EntityMap a) where
+  parseJSON = fmap (fromEIDsAndPositioned @[_]) . parseJSON
+
+byIDInvariantError :: forall a. a
+byIDInvariantError = error $ "Invariant violation: All EntityIDs in byPosition "
+  <> "must point to entityIDs in byID"
+
+instance (Ord a, Eq a) => Eq (EntityMap a) where
+  -- em₁ == em₂ = em₁ ^. _EntityMap == em₂ ^. _EntityMap
+  (==) = (==) `on` view (_EntityMap . to sort)
+
+deriving stock instance (Ord a) => Ord (EntityMap a)
+
+instance Show a => Show (EntityMap a) where
+  showsPrec pr em
+    = showParen (pr > 10)
+    $ showString
+    . ("fromEIDsAndPositioned " <>)
+    . show
+    . toEIDsAndPositioned
+    $ em
+
+instance Arbitrary a => Arbitrary (EntityMap a) where
+  arbitrary = review _EntityMap <$> arbitrary
+  shrink em = review _EntityMap <$> shrink (em ^. _EntityMap)
+
+type instance Index (EntityMap a) = EntityID
+type instance IxValue (EntityMap a) = (Positioned a)
+instance Ixed (EntityMap a) where ix eid = at eid . traverse
+
+instance At (EntityMap a) where
+  at eid = lens (view $ byID . at eid) setter
+    where
+      setter :: EntityMap a -> Maybe (Positioned a) -> EntityMap a
+      setter m Nothing = fromMaybe m $ do
+        Positioned pos _ <- m ^. byID . at eid
+        pure $ m
+          & removeEIDAtPos pos
+          & byID . at eid .~ Nothing
+      setter m (Just pe@(Positioned pos _)) = m
+        & (case lookupWithPosition eid m of
+             Nothing -> id
+             Just (Positioned origPos _) -> removeEIDAtPos origPos
+          )
+        & byID . at eid ?~ pe
+        & byPosition . at pos %~ \case
+            Nothing -> Just $ opoint eid
+            Just es -> Just $ ninsertSet eid es
+      removeEIDAtPos pos =
+        byPosition . at pos %~ (>>= fromNullable . ndeleteSet eid)
+
+instance Semigroup (EntityMap a) where
+  em₁ <> em₂ = alaf Endo foldMap (uncurry insertAt) (em₂ ^. _EntityMap) em₁
+
+instance Monoid (EntityMap a) where
+  mempty = emptyEntityMap
+
+instance FunctorWithIndex EntityID EntityMap
+
+instance FoldableWithIndex EntityID EntityMap
+
+instance TraversableWithIndex EntityID EntityMap where
+  itraversed = byID . itraversed . rmap sequenceA . distrib
+  itraverse = itraverseOf itraversed
+
+type instance Element (EntityMap a) = a
+instance MonoFoldable (EntityMap a)
+
+emptyEntityMap :: EntityMap a
+emptyEntityMap = EntityMap mempty mempty 0
+
+newtype Deduplicate a = Deduplicate (EntityMap a)
+  deriving stock (Show, Traversable, Generic)
+  deriving newtype (Eq, Functor, Foldable, EqProp, Arbitrary)
+
+instance Semigroup (Deduplicate a) where
+  (Deduplicate em₁) <> (Deduplicate em₂) =
+    let _byID = em₁ ^. byID <> em₂ ^. byID
+        _byPosition = mempty &~ do
+          ifor_ _byID $ \eid (Positioned pos _) ->
+            at pos %= \case
+              Just eids -> Just $ ninsertSet eid eids
+              Nothing -> Just $ opoint eid
+        _lastID = fromMaybe 1 $ maximumOf (ifolded . asIndex) _byID
+    in Deduplicate EntityMap{..}
+
+
+--------------------------------------------------------------------------------
+
+_EntityMap :: Iso' (EntityMap a) [(Position, a)]
+_EntityMap = iso hither yon
+  where
+    hither :: EntityMap a -> [(Position, a)]
+    hither em = do
+       (pos, eids) <- em ^. byPosition . _Wrapped
+       eid <- toList eids
+       ent <- em ^.. byID . at eid . folded . positioned
+       pure (pos, ent)
+    yon :: [(Position, a)] -> EntityMap a
+    yon poses = alaf Endo foldMap (uncurry insertAt) poses emptyEntityMap
+
+
+insertAtReturningID :: forall a. Position -> a -> EntityMap a -> (EntityID, EntityMap a)
+insertAtReturningID pos e em =
+  let (eid, em') = em & lastID <+~ 1
+  in em'
+     & byID . at eid ?~ Positioned pos e
+     & byPosition . at pos %~ \case
+       Nothing -> Just $ opoint eid
+       Just es -> Just $ ninsertSet eid es
+     & (eid, )
+
+insertAt :: forall a. Position -> a -> EntityMap a -> EntityMap a
+insertAt pos e = snd . insertAtReturningID pos e
+
+atPosition :: forall a. (Ord a, Show a) => Position -> Lens' (EntityMap a) (VectorBag a)
+atPosition pos = lens getter setter
+  where
+    getter em =
+      let eids :: VectorBag EntityID
+          eids = maybe mempty (VectorBag . toVector . toNullable)
+                 $ em ^. byPosition . at pos
+      in getEIDAssume em <$> eids
+    setter em Empty = em & byPosition . at pos .~ Nothing
+    setter em (sort -> entities) =
+      let origEIDs = maybe Empty toNullable $ em ^. byPosition . at pos
+          origEntitiesWithIDs =
+            sortOn snd $ toList origEIDs <&> \eid -> (eid, getEIDAssume em eid)
+          go alles₁@((eid, e₁) :< es₁) -- orig
+             (e₂ :< es₂)               -- new
+            | e₁ == e₂
+              -- same, do nothing
+            = let (eids, lastEID, byID') = go es₁ es₂
+              in (insertSet eid eids, lastEID, byID')
+            | otherwise
+              -- e₂ is new, generate a new ID for it
+            = let (eids, lastEID, byID') = go alles₁ es₂
+                  eid' = succ lastEID
+              in (insertSet eid' eids, eid', byID' & at eid' ?~ Positioned pos e₂)
+          go Empty Empty = (mempty, em ^. lastID, em ^. byID)
+          go orig Empty =
+            let byID' = foldr deleteMap (em ^. byID) $ map fst orig
+            in (mempty, em ^. lastID, byID')
+          go Empty (new :< news) =
+            let (eids, lastEID, byID') = go Empty news
+                eid' = succ lastEID
+            in (insertSet eid' eids, eid', byID' & at eid' ?~ Positioned pos new)
+          go _ _ = error "unreachable"
+          (eidsAtPosition, newLastID, newByID) = go origEntitiesWithIDs entities
+      in em & byPosition . at pos .~ fromNullable eidsAtPosition
+            & byID .~ newByID
+            & lastID .~ newLastID
+
+getEIDAssume :: EntityMap a -> EntityID -> a
+getEIDAssume em eid = fromMaybe byIDInvariantError
+  $ em ^? byID . ix eid . positioned
+
+atPositionWithIDs :: Position -> EntityMap a -> Vector (EntityID, Positioned a)
+atPositionWithIDs pos em =
+  let eids = maybe mempty (toVector . toNullable)
+             $ em ^. byPosition . at pos
+  in (id &&& Positioned pos . getEIDAssume em) <$> eids
+
+fromEIDsAndPositioned
+  :: forall mono a. (MonoFoldable mono, Element mono ~ (EntityID, Positioned a))
+  => mono
+  -> EntityMap a
+fromEIDsAndPositioned eps = newLastID $ alaf Endo foldMap insert' eps mempty
+  where
+    insert' (eid, pe@(Positioned pos _))
+      = (byID . at eid ?~ pe)
+      . (byPosition . at pos %~ \case
+            Just eids -> Just $ ninsertSet eid eids
+            Nothing   -> Just $ opoint eid
+        )
+    newLastID em = em & lastID
+      .~ fromMaybe 1
+         (maximumOf (ifolded . asIndex) (em ^. byID))
+
+toEIDsAndPositioned :: EntityMap a -> [(EntityID, Positioned a)]
+toEIDsAndPositioned = itoListOf $ byID . ifolded
+
+positions :: EntityMap a -> [Position]
+positions = toListOf $ byPosition . to keys . folded
+
+lookupWithPosition :: EntityID -> EntityMap a -> Maybe (Positioned a)
+lookupWithPosition eid = view $ byID . at eid
+
+lookup :: EntityID -> EntityMap a -> Maybe a
+lookup eid = fmap (view positioned) . lookupWithPosition eid
+
+-- unlawful :(
+-- positionedEntities :: IndexedTraversal EntityID (EntityMap a) (EntityMap b) (Positioned a) (Positioned b)
+-- positionedEntities = byID . itraversed
+
+neighbors :: (Ord a, Show a) => Position -> EntityMap a -> Neighbors (VectorBag a)
+neighbors pos em = (\p -> view (atPosition p) em) <$> neighborPositions pos
+
+--------------------------------------------------------------------------------
+makeWrapped ''Deduplicate
diff --git a/users/grfn/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs b/users/grfn/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs
new file mode 100644
index 000000000000..19e7b0cdf086
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs
@@ -0,0 +1,64 @@
+--------------------------------------------------------------------------------
+module Xanthous.Data.EntityMap.Graphics
+  ( visiblePositions
+  , visibleEntities
+  , linesOfSight
+  , canSee
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude hiding (lines)
+--------------------------------------------------------------------------------
+import Xanthous.Util (takeWhileInclusive)
+import Xanthous.Data
+import Xanthous.Data.Entities
+import Xanthous.Data.EntityMap
+import Xanthous.Game.State
+import Xanthous.Util.Graphics (circle, line)
+--------------------------------------------------------------------------------
+
+-- | Returns a set of positions that are visible, when taking into account
+-- 'blocksVision', from the given position, within the given radius.
+visiblePositions
+  :: Entity e
+  => Position
+  -> Word -- ^ Vision radius
+  -> EntityMap e
+  -> Set Position
+visiblePositions pos radius
+  = setFromList . positions . visibleEntities pos radius
+
+-- | Returns a list of individual lines of sight, each of which is a list of
+-- entities at positions on that line of sight
+linesOfSight
+  :: forall e. Entity e
+  => Position
+  -> Word
+  -> EntityMap e
+  -> [[(Position, Vector (EntityID, e))]]
+linesOfSight (view _Position -> pos) visionRadius em
+  = entitiesOnLines
+  <&> takeWhileInclusive
+      (none (view blocksVision . entityAttributes . snd) . snd)
+  where
+    radius = circle pos $ fromIntegral visionRadius
+    lines = line pos <$> radius
+    entitiesOnLines :: [[(Position, Vector (EntityID, e))]]
+    entitiesOnLines = lines <&> map getPositionedAt
+    getPositionedAt :: V2 Int -> (Position, Vector (EntityID, e))
+    getPositionedAt p =
+      let ppos = _Position # p
+      in (ppos, over _2 (view positioned) <$> atPositionWithIDs ppos em)
+
+-- | Given a point and a radius of vision, returns a list of all entities that
+-- are *visible* (eg, not blocked by an entity that obscures vision) from that
+-- point
+visibleEntities :: Entity e => Position -> Word -> EntityMap e -> EntityMap e
+visibleEntities pos visionRadius
+  = fromEIDsAndPositioned
+  . foldMap (\(p, es) -> over _2 (Positioned p) <$> es)
+  . fold
+  . linesOfSight pos visionRadius
+
+canSee :: Entity e => (e -> Bool) -> Position -> Word -> EntityMap e -> Bool
+canSee match pos radius = any match . visibleEntities pos radius
+-- ^ this might be optimizable
diff --git a/users/grfn/xanthous/src/Xanthous/Data/Levels.hs b/users/grfn/xanthous/src/Xanthous/Data/Levels.hs
new file mode 100644
index 000000000000..efc0f53acecf
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Data/Levels.hs
@@ -0,0 +1,170 @@
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Data.Levels
+  ( Levels
+  , allLevels
+  , nextLevel
+  , prevLevel
+  , mkLevels1
+  , mkLevels
+  , oneLevel
+  , current
+  , ComonadStore(..)
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding ((<.>), Empty, foldMap)
+import           Xanthous.Util (between, EqProp, EqEqProp(..))
+import           Xanthous.Util.Comonad (current)
+import           Xanthous.Orphans ()
+--------------------------------------------------------------------------------
+import           Control.Comonad.Store
+import           Control.Comonad.Store.Zipper
+import           Data.Aeson (ToJSON(..), FromJSON(..))
+import           Data.Aeson.Generic.DerivingVia
+import           Data.Functor.Apply
+import           Data.Foldable (foldMap)
+import           Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as NE
+import           Data.Maybe (fromJust)
+import           Data.Sequence (Seq((:<|), Empty))
+import           Data.Semigroup.Foldable.Class
+import           Data.Text (replace)
+import           Test.QuickCheck
+--------------------------------------------------------------------------------
+
+-- | Collection of levels plus a pointer to the current level
+--
+-- Navigation is via the 'Comonad' instance. We can get the current level with
+-- 'extract':
+--
+--     extract @Levels :: Levels level -> level
+--
+-- For access to and modification of the level, use
+-- 'Xanthous.Util.Comonad.current'
+newtype Levels a = Levels { levelZipper :: Zipper Seq a }
+    deriving stock (Generic)
+    deriving (Functor, Comonad, Foldable) via (Zipper Seq)
+    deriving (ComonadStore Int) via (Zipper Seq)
+
+type instance Element (Levels a) = a
+instance MonoFoldable (Levels a)
+instance MonoFunctor (Levels a)
+instance MonoTraversable (Levels a)
+
+instance Traversable Levels where
+  traverse f (Levels z) = Levels <$> traverse f z
+
+instance Foldable1 Levels
+
+instance Traversable1 Levels where
+  traverse1 f (Levels z) = seek (pos z) . partialMkLevels <$> go (unzipper z)
+    where
+      go Empty = error "empty seq, unreachable"
+      go (x :<| xs) = (<|) <$> f x <.> go xs
+
+-- | Always takes the position of the latter element
+instance Semigroup (Levels a) where
+  levs₁ <> levs₂
+    = seek (pos levs₂)
+    . partialMkLevels
+    $ allLevels levs₁ <> allLevels levs₂
+
+-- | Make Levels from a Seq. Throws an error if the seq is not empty
+partialMkLevels :: Seq a -> Levels a
+partialMkLevels = Levels . fromJust . zipper
+
+-- | Make Levels from a possibly-empty structure
+mkLevels :: Foldable1 f => f level -> Maybe (Levels level)
+mkLevels = fmap Levels . zipper . foldMap pure
+
+-- | Make Levels from a non-empty structure
+mkLevels1 :: Foldable1 f => f level -> Levels level
+mkLevels1 = fromJust . mkLevels
+
+oneLevel :: a -> Levels a
+oneLevel = mkLevels1 . Identity
+
+-- | Get a sequence of all the levels
+allLevels :: Levels a -> Seq a
+allLevels = unzipper . levelZipper
+
+-- | Step to the next level, generating a new level if necessary using the given
+-- applicative action
+nextLevel
+  :: Applicative m
+  => m level -- ^ Generate a new level, if necessary
+  -> Levels level
+  -> m (Levels level)
+nextLevel genLevel levs
+  | pos levs + 1 < size (levelZipper levs)
+  = pure $ seeks succ levs
+  | otherwise
+  = genLevel <&> \level ->
+      seek (pos levs + 1) . partialMkLevels $ allLevels levs |> level
+
+-- | Go to the previous level. Returns Nothing if 'pos' is 0
+prevLevel :: Levels level -> Maybe (Levels level)
+prevLevel levs | pos levs == 0 = Nothing
+               | otherwise = Just $ seeks pred levs
+
+--------------------------------------------------------------------------------
+
+-- | alternate, slower representation of Levels we can Iso into to perform
+-- various operations
+data AltLevels a = AltLevels
+  { _levels :: NonEmpty a
+  , _currentLevel :: Int -- ^ invariant: is within the bounds of _levels
+  }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           (AltLevels a)
+makeLenses ''AltLevels
+
+alt :: Iso (Levels a) (Levels b) (AltLevels a) (AltLevels b)
+alt = iso hither yon
+  where
+    hither levs = AltLevels (NE.fromList . toList $ allLevels levs) (pos levs)
+    yon (AltLevels levs curr) = seek curr $ mkLevels1 levs
+
+instance Eq a => Eq (Levels a) where
+  (==) = (==) `on` view alt
+
+deriving via EqEqProp (Levels a) instance Eq a => EqProp (Levels a)
+
+instance Show a => Show (Levels a) where
+  show = unpack . replace "AltLevels" "Levels" . pack . show . view alt
+
+instance NFData a => NFData (Levels a) where
+  rnf = rnf . view alt
+
+instance ToJSON a => ToJSON (Levels a) where
+  toJSON = toJSON . view alt
+
+instance FromJSON a => FromJSON (Levels a) where
+  parseJSON = fmap (review alt) . parseJSON
+
+instance Arbitrary a => Arbitrary (AltLevels a) where
+  arbitrary = do
+    _levels <- arbitrary
+    _currentLevel <- choose (0, length _levels - 1)
+    pure AltLevels {..}
+  shrink als = do
+    _levels <- shrink $ als ^. levels
+    _currentLevel <- filter (between 0 $ length _levels - 1)
+                    $ shrink $ als ^. currentLevel
+    pure AltLevels {..}
+
+
+instance Arbitrary a => Arbitrary (Levels a) where
+  arbitrary = review alt <$> arbitrary
+  shrink = fmap (review alt) . shrink . view alt
+
+instance CoArbitrary a => CoArbitrary (Levels a) where
+  coarbitrary = coarbitrary . view alt
+
+instance Function a => Function (Levels a) where
+  function = functionMap (view alt) (review alt)
diff --git a/users/grfn/xanthous/src/Xanthous/Data/NestedMap.hs b/users/grfn/xanthous/src/Xanthous/Data/NestedMap.hs
new file mode 100644
index 000000000000..1b875d448302
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/src/Xanthous/Data/VectorBag.hs b/users/grfn/xanthous/src/Xanthous/Data/VectorBag.hs
new file mode 100644
index 000000000000..2e6d48062a45
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/src/Xanthous/Entities/Character.hs b/users/grfn/xanthous/src/Xanthous/Entities/Character.hs
new file mode 100644
index 000000000000..c18d726a4bfd
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Entities/Character.hs
@@ -0,0 +1,276 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Xanthous.Entities.Character
+  ( Character(..)
+  , characterName
+  , inventory
+  , characterDamage
+  , characterHitpoints'
+  , characterHitpoints
+  , hitpointRecoveryRate
+  , speed
+
+    -- * Inventory
+  , Inventory(..)
+  , backpack
+  , wielded
+  , items
+    -- ** Wielded items
+  , Wielded(..)
+  , hands
+  , leftHand
+  , rightHand
+  , inLeftHand
+  , inRightHand
+  , doubleHanded
+  , wieldedItems
+  , WieldedItem(..)
+  , wieldedItem
+  , wieldableItem
+  , asWieldedItem
+
+    -- *
+  , mkCharacter
+  , pickUpItem
+  , isDead
+  , damage
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Brick
+import           Data.Aeson.Generic.DerivingVia
+import           Data.Aeson (ToJSON, FromJSON)
+import           Data.Coerce (coerce)
+import           Test.QuickCheck
+import           Test.QuickCheck.Instances.Vector ()
+import           Test.QuickCheck.Arbitrary.Generic
+--------------------------------------------------------------------------------
+import           Xanthous.Util.QuickCheck
+import           Xanthous.Game.State
+import           Xanthous.Entities.Item
+import           Xanthous.Data
+                 ( TicksPerTile, Hitpoints, Per, Ticks, (|*|), positioned
+                 , Positioned(..)
+                 )
+import           Xanthous.Entities.RawTypes (WieldableItem, wieldable)
+import qualified Xanthous.Entities.RawTypes as Raw
+--------------------------------------------------------------------------------
+
+data WieldedItem = WieldedItem
+  { _wieldedItem :: Item
+  , _wieldableItem :: WieldableItem
+    -- ^ Invariant: item ^. itemType . wieldable ≡ Just wieldableItem
+  }
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           WieldedItem
+makeFieldsNoPrefix ''WieldedItem
+
+asWieldedItem :: Prism' Item WieldedItem
+asWieldedItem = prism' hither yon
+ where
+   yon item = WieldedItem item <$> item ^. itemType . wieldable
+   hither (WieldedItem item _) = item
+
+instance Brain WieldedItem where
+  step ticks (Positioned p wi) =
+    over positioned (\i -> WieldedItem i $ wi ^. wieldableItem)
+    <$> step ticks (Positioned p $ wi ^. wieldedItem)
+
+instance Draw WieldedItem where
+  draw = draw . view wieldedItem
+
+instance Entity WieldedItem where
+  entityAttributes = entityAttributes . view wieldedItem
+  description = description . view wieldedItem
+  entityChar = entityChar . view wieldedItem
+
+instance Arbitrary WieldedItem where
+  arbitrary = genericArbitrary <&> \wi ->
+    wi & wieldedItem . itemType . wieldable ?~ wi ^. wieldableItem
+
+data Wielded
+  = DoubleHanded WieldedItem
+  | Hands { _leftHand :: !(Maybe WieldedItem)
+          , _rightHand :: !(Maybe WieldedItem)
+          }
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary Wielded
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ 'SumEnc 'ObjWithSingleField ]
+           Wielded
+
+hands :: Prism' Wielded (Maybe WieldedItem, Maybe WieldedItem)
+hands = prism' (uncurry Hands) $ \case
+  Hands l r -> Just (l, r)
+  _ -> Nothing
+
+leftHand :: Traversal' Wielded WieldedItem
+leftHand = hands . _1 . _Just
+
+inLeftHand :: WieldedItem -> Wielded
+inLeftHand wi = Hands (Just wi) Nothing
+
+rightHand :: Traversal' Wielded WieldedItem
+rightHand = hands . _2 . _Just
+
+inRightHand :: WieldedItem -> Wielded
+inRightHand wi = Hands Nothing (Just wi)
+
+doubleHanded :: Prism' Wielded WieldedItem
+doubleHanded = prism' DoubleHanded $ \case
+  DoubleHanded i -> Just i
+  _ -> Nothing
+
+wieldedItems :: Traversal' Wielded WieldedItem
+wieldedItems k (DoubleHanded wielded) = DoubleHanded <$> k wielded
+wieldedItems k (Hands l r) = Hands <$> _Just k l <*> _Just k r
+
+data Inventory = Inventory
+  { _backpack :: Vector Item
+  , _wielded :: Wielded
+  }
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary Inventory
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           Inventory
+makeFieldsNoPrefix ''Inventory
+
+items :: Traversal' Inventory Item
+items k (Inventory bp w) = Inventory
+  <$> traversed k bp
+  <*> (wieldedItems . wieldedItem) k w
+
+type instance Element Inventory = Item
+
+instance MonoFunctor Inventory where
+  omap = over items
+
+instance MonoFoldable Inventory where
+  ofoldMap = foldMapOf items
+  ofoldr = foldrOf items
+  ofoldl' = foldlOf' items
+  otoList = toListOf items
+  oall = allOf items
+  oany = anyOf items
+  onull = nullOf items
+  ofoldr1Ex = foldr1Of items
+  ofoldl1Ex' = foldl1Of' items
+  headEx = headEx . toListOf items
+  lastEx = lastEx . toListOf items
+
+instance MonoTraversable Inventory where
+  otraverse = traverseOf items
+
+instance Semigroup Inventory where
+  inv₁ <> inv₂ =
+    let backpack' = inv₁ ^. backpack <> inv₂ ^. backpack
+        (wielded', backpack'') = case (inv₁ ^. wielded, inv₂ ^. wielded) of
+          (wielded₁, wielded₂@(DoubleHanded _)) ->
+            (wielded₂, backpack' <> fromList (wielded₁ ^.. wieldedItems . wieldedItem))
+          (wielded₁, wielded₂@(Hands (Just _) (Just _))) ->
+            (wielded₂, backpack' <> fromList (wielded₁ ^.. wieldedItems . wieldedItem))
+          (wielded₁, Hands Nothing Nothing) -> (wielded₁, backpack')
+          (Hands Nothing Nothing, wielded₂) -> (wielded₂, backpack')
+          (Hands (Just l₁) Nothing, Hands Nothing (Just r₂)) ->
+            (Hands (Just l₁) (Just r₂), backpack')
+          (wielded₁@(DoubleHanded _), wielded₂) ->
+            (wielded₁, backpack' <> fromList (wielded₂ ^.. wieldedItems . wieldedItem))
+          (Hands Nothing (Just r₁), Hands Nothing (Just r₂)) ->
+            (Hands Nothing (Just r₂), r₁ ^. wieldedItem <| backpack')
+          (Hands Nothing r₁, Hands (Just l₂) Nothing) ->
+            (Hands (Just l₂) r₁, backpack')
+          (Hands (Just l₁) Nothing, Hands (Just l₂) Nothing) ->
+            (Hands (Just l₂) Nothing, l₁ ^. wieldedItem <| backpack')
+          (Hands (Just l₁) (Just r₁), Hands Nothing (Just r₂)) ->
+            (Hands (Just l₁) (Just r₂), r₁ ^. wieldedItem <| backpack')
+          (Hands (Just l₁) (Just r₁), Hands (Just l₂) Nothing) ->
+            (Hands (Just l₂) (Just r₁), l₁ ^. wieldedItem <| backpack')
+    in Inventory backpack'' wielded'
+
+instance Monoid Inventory where
+  mempty = Inventory mempty $ Hands Nothing Nothing
+
+--------------------------------------------------------------------------------
+
+data Character = Character
+  { _inventory :: !Inventory
+  , _characterName :: !(Maybe Text)
+  , _characterHitpoints' :: !Double
+  , _speed :: TicksPerTile
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           Character
+makeLenses ''Character
+
+characterHitpoints :: Character -> Hitpoints
+characterHitpoints = views characterHitpoints' floor
+
+scrollOffset :: Int
+scrollOffset = 5
+
+instance Draw Character where
+  draw _ = visibleRegion rloc rreg $ str "@"
+    where
+      rloc = Location (negate scrollOffset, negate scrollOffset)
+      rreg = (2 * scrollOffset, 2 * scrollOffset)
+  drawPriority = const maxBound -- Character should always be on top, for now
+
+instance Brain Character where
+  step ticks = (pure .) $ positioned . characterHitpoints' %~ \hp ->
+    if hp > fromIntegral initialHitpoints
+    then hp
+    else hp + hitpointRecoveryRate |*| ticks
+
+instance Entity Character where
+  description _ = "yourself"
+  entityChar _ = "@"
+
+instance Arbitrary Character where
+  arbitrary = genericArbitrary
+
+initialHitpoints :: Hitpoints
+initialHitpoints = 10
+
+hitpointRecoveryRate :: Double `Per` Ticks
+hitpointRecoveryRate = 1.0 / (15 * coerce defaultSpeed)
+
+defaultSpeed :: TicksPerTile
+defaultSpeed = 100
+
+mkCharacter :: Character
+mkCharacter = Character
+  { _inventory = mempty
+  , _characterName = Nothing
+  , _characterHitpoints' = fromIntegral initialHitpoints
+  , _speed = defaultSpeed
+  }
+
+defaultCharacterDamage :: Hitpoints
+defaultCharacterDamage = 1
+
+-- | Returns the damage that the character currently does with an attack
+-- TODO use double-handed/left-hand/right-hand here
+characterDamage :: Character -> Hitpoints
+characterDamage
+  = fromMaybe defaultCharacterDamage
+  . preview (inventory . wielded . wieldedItems . wieldableItem . Raw.damage)
+
+isDead :: Character -> Bool
+isDead = (== 0) . characterHitpoints
+
+pickUpItem :: Item -> Character -> Character
+pickUpItem it = inventory . backpack %~ (it <|)
+
+damage :: Hitpoints -> Character -> Character
+damage (fromIntegral -> amount) = characterHitpoints' %~ \case
+  n | n <= amount -> 0
+    | otherwise  -> n - amount
diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Creature.hs b/users/grfn/xanthous/src/Xanthous/Entities/Creature.hs
new file mode 100644
index 000000000000..e95e9f0b985b
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Entities/Creature.hs
@@ -0,0 +1,92 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Creature
+  ( -- * Creature
+    Creature(..)
+    -- ** Lenses
+  , creatureType
+  , hitpoints
+  , hippocampus
+
+    -- ** Creature functions
+  , newWithType
+  , damage
+  , isDead
+  , visionRadius
+
+    -- * Hippocampus
+  , Hippocampus(..)
+    -- ** Lenses
+  , destination
+    -- ** Destination
+  , Destination(..)
+  , destinationFromPos
+    -- *** Lenses
+  , destinationPosition
+  , destinationProgress
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Test.QuickCheck
+import           Test.QuickCheck.Arbitrary.Generic
+import           Data.Aeson.Generic.DerivingVia
+import           Data.Aeson (ToJSON, FromJSON)
+--------------------------------------------------------------------------------
+import           Xanthous.AI.Gormlak
+import           Xanthous.Entities.RawTypes hiding
+                 (Creature, description, damage)
+import qualified Xanthous.Entities.RawTypes as Raw
+import           Xanthous.Game.State
+import           Xanthous.Data
+import           Xanthous.Data.Entities
+import           Xanthous.Entities.Creature.Hippocampus
+--------------------------------------------------------------------------------
+
+data Creature = Creature
+  { _creatureType :: !CreatureType
+  , _hitpoints    :: !Hitpoints
+  , _hippocampus  :: !Hippocampus
+  }
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Draw via DrawRawCharPriority "_creatureType" 1000 Creature
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       Creature
+instance Arbitrary Creature where arbitrary = genericArbitrary
+makeLenses ''Creature
+
+instance HasVisionRadius Creature where
+  visionRadius = const 50 -- TODO
+
+instance Brain Creature where
+  step = brainVia GormlakBrain
+  entityCanMove = const True
+
+instance Entity Creature where
+  entityAttributes _ = defaultEntityAttributes
+    & blocksObject .~ True
+  description = view $ creatureType . Raw.description
+  entityChar = view $ creatureType . char
+  entityCollision = const $ Just Combat
+
+--------------------------------------------------------------------------------
+
+newWithType :: CreatureType -> Creature
+newWithType _creatureType =
+  let _hitpoints = _creatureType ^. maxHitpoints
+      _hippocampus = initialHippocampus
+  in Creature {..}
+
+damage :: Hitpoints -> Creature -> Creature
+damage amount = hitpoints %~ \hp ->
+  if hp <= amount
+  then 0
+  else hp - amount
+
+isDead :: Creature -> Bool
+isDead = views hitpoints (== 0)
+
+{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-}
diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs b/users/grfn/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs
new file mode 100644
index 000000000000..501a5b597221
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Creature.Hippocampus
+  (-- * Hippocampus
+    Hippocampus(..)
+  , initialHippocampus
+    -- ** Lenses
+  , destination
+    -- ** Destination
+  , Destination(..)
+  , destinationFromPos
+    -- *** Lenses
+  , destinationPosition
+  , destinationProgress
+  )
+where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Data.Aeson.Generic.DerivingVia
+import           Data.Aeson (ToJSON, FromJSON)
+import           Test.QuickCheck
+import           Test.QuickCheck.Arbitrary.Generic
+--------------------------------------------------------------------------------
+import           Xanthous.Data
+import           Xanthous.Util.QuickCheck
+--------------------------------------------------------------------------------
+
+
+data Destination = Destination
+  { _destinationPosition :: !Position
+    -- | The progress towards the destination, tracked as an offset from the
+    -- creature's original position.
+    --
+    -- When this value reaches >= 1, the creature has reached their destination
+  , _destinationProgress :: !Tiles
+  }
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       Destination
+instance Arbitrary Destination where arbitrary = genericArbitrary
+makeLenses ''Destination
+
+destinationFromPos :: Position -> Destination
+destinationFromPos _destinationPosition =
+  let _destinationProgress = 0
+  in Destination{..}
+
+data Hippocampus = Hippocampus
+  { _destination :: !(Maybe Destination)
+  }
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary Hippocampus
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       Hippocampus
+makeLenses ''Hippocampus
+
+initialHippocampus :: Hippocampus
+initialHippocampus = Hippocampus Nothing
diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Draw/Util.hs b/users/grfn/xanthous/src/Xanthous/Entities/Draw/Util.hs
new file mode 100644
index 000000000000..aa6c5fa4fc47
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/src/Xanthous/Entities/Entities.hs b/users/grfn/xanthous/src/Xanthous/Entities/Entities.hs
new file mode 100644
index 000000000000..a0c037a1b4ed
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/src/Xanthous/Entities/Entities.hs-boot b/users/grfn/xanthous/src/Xanthous/Entities/Entities.hs-boot
new file mode 100644
index 000000000000..519a862c6a5a
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/src/Xanthous/Entities/Environment.hs b/users/grfn/xanthous/src/Xanthous/Entities/Environment.hs
new file mode 100644
index 000000000000..b45a91eabed2
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/src/Xanthous/Entities/Item.hs b/users/grfn/xanthous/src/Xanthous/Entities/Item.hs
new file mode 100644
index 000000000000..b50a5eab809d
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Entities/Item.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StandaloneDeriving #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Item
+  ( Item(..)
+  , itemType
+  , newWithType
+  , isEdible
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+import           Test.QuickCheck
+import           Data.Aeson (ToJSON, FromJSON)
+import           Data.Aeson.Generic.DerivingVia
+--------------------------------------------------------------------------------
+import           Xanthous.Entities.RawTypes hiding (Item, description, isEdible)
+import qualified Xanthous.Entities.RawTypes as Raw
+import           Xanthous.Game.State
+--------------------------------------------------------------------------------
+
+data Item = Item
+  { _itemType :: ItemType
+  }
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Draw via DrawRawChar "_itemType" Item
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       Item
+makeLenses ''Item
+
+{-# ANN Item ("HLint: ignore Use newtype instead of data" :: String )#-}
+
+-- deriving via (Brainless Item) instance Brain Item
+instance Brain Item where step = brainVia Brainless
+
+instance Arbitrary Item where
+  arbitrary = Item <$> arbitrary
+
+instance Entity Item where
+  description = view $ itemType . Raw.description
+  entityChar = view $ itemType . Raw.char
+  entityCollision = const Nothing
+
+newWithType :: ItemType -> Item
+newWithType = Item
+
+isEdible :: Item -> Bool
+isEdible = Raw.isEdible . view itemType
diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Marker.hs b/users/grfn/xanthous/src/Xanthous/Entities/Marker.hs
new file mode 100644
index 000000000000..14d02872ed4e
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs b/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs
new file mode 100644
index 000000000000..30039662f071
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs
@@ -0,0 +1,133 @@
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.RawTypes
+  (
+    EntityRaw(..)
+  , _Creature
+  , _Item
+
+    -- * Creatures
+  , CreatureType(..)
+  , hostile
+
+    -- * Items
+  , ItemType(..)
+    -- ** Item sub-types
+    -- *** Edible
+  , EdibleItem(..)
+  , isEdible
+    -- *** Wieldable
+  , WieldableItem(..)
+  , isWieldable
+
+    -- * Lens classes
+  , HasAttackMessage(..)
+  , HasChar(..)
+  , HasDamage(..)
+  , HasDescription(..)
+  , HasEatMessage(..)
+  , HasEdible(..)
+  , HasFriendly(..)
+  , HasHitpointsHealed(..)
+  , HasLongDescription(..)
+  , HasMaxHitpoints(..)
+  , HasName(..)
+  , HasSpeed(..)
+  , HasWieldable(..)
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+import Test.QuickCheck
+import Data.Aeson.Generic.DerivingVia
+import Data.Aeson (ToJSON, FromJSON)
+--------------------------------------------------------------------------------
+import Xanthous.Messages (Message(..))
+import Xanthous.Data (TicksPerTile, Hitpoints)
+import Xanthous.Data.EntityChar
+import Xanthous.Util.QuickCheck
+--------------------------------------------------------------------------------
+
+data CreatureType = CreatureType
+  { _name         :: !Text
+  , _description  :: !Text
+  , _char         :: !EntityChar
+  , _maxHitpoints :: !Hitpoints
+  , _friendly     :: !Bool
+  , _speed        :: !TicksPerTile
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary CreatureType
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       CreatureType
+makeFieldsNoPrefix ''CreatureType
+
+hostile :: Lens' CreatureType Bool
+hostile = friendly . involuted not
+
+--------------------------------------------------------------------------------
+
+data EdibleItem = EdibleItem
+  { _hitpointsHealed :: Int
+  , _eatMessage :: Maybe Message
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary EdibleItem
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       EdibleItem
+makeFieldsNoPrefix ''EdibleItem
+
+data WieldableItem = WieldableItem
+  { _damage :: !Hitpoints
+  , _attackMessage :: !(Maybe Message)
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary WieldableItem
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       WieldableItem
+makeFieldsNoPrefix ''WieldableItem
+
+--------------------------------------------------------------------------------
+
+data ItemType = ItemType
+  { _name            :: Text
+  , _description     :: Text
+  , _longDescription :: Text
+  , _char            :: EntityChar
+  , _edible          :: Maybe EdibleItem
+  , _wieldable       :: Maybe WieldableItem
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary ItemType
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       ItemType
+makeFieldsNoPrefix ''ItemType
+
+-- | Can this item be eaten?
+isEdible :: ItemType -> Bool
+isEdible = has $ edible . _Just
+
+-- | Can this item be used as a weapon?
+isWieldable :: ItemType -> Bool
+isWieldable = has $ wieldable . _Just
+
+--------------------------------------------------------------------------------
+
+data EntityRaw
+  = Creature CreatureType
+  | Item ItemType
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData)
+  deriving Arbitrary via GenericArbitrary EntityRaw
+  deriving (FromJSON)
+       via WithOptions '[ SumEnc ObjWithSingleField ]
+                       EntityRaw
+makePrisms ''EntityRaw
diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws.hs b/users/grfn/xanthous/src/Xanthous/Entities/Raws.hs
new file mode 100644
index 000000000000..d4cae7ccc299
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Entities/Raws.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Raws
+  ( raws
+  , raw
+  , RawType(..)
+  , rawsWithType
+  , entityFromRaw
+  ) where
+--------------------------------------------------------------------------------
+import           Data.FileEmbed
+import qualified Data.Yaml as Yaml
+import           Xanthous.Prelude
+import           System.FilePath.Posix
+--------------------------------------------------------------------------------
+import           Xanthous.Entities.RawTypes
+import           Xanthous.Game.State
+import qualified Xanthous.Entities.Creature as Creature
+import qualified Xanthous.Entities.Item as Item
+import           Xanthous.AI.Gormlak ()
+--------------------------------------------------------------------------------
+rawRaws :: [(FilePath, ByteString)]
+rawRaws = $(embedDir "src/Xanthous/Entities/Raws")
+
+raws :: HashMap Text EntityRaw
+raws
+  = mapFromList
+  . map (bimap
+         (pack . takeBaseName)
+         (either (error . Yaml.prettyPrintParseException) id
+          . Yaml.decodeEither'))
+  $ rawRaws
+
+raw :: Text -> Maybe EntityRaw
+raw n = raws ^. at n
+
+class RawType (a :: Type) where
+  _RawType :: Prism' EntityRaw a
+
+instance RawType CreatureType where
+  _RawType = prism' Creature $ \case
+    Creature c -> Just c
+    _ -> Nothing
+
+instance RawType ItemType where
+  _RawType = prism' Item $ \case
+    Item i -> Just i
+    _ -> Nothing
+
+rawsWithType :: forall a. RawType a => HashMap Text a
+rawsWithType = mapFromList . itoListOf (ifolded . _RawType) $ raws
+
+--------------------------------------------------------------------------------
+
+entityFromRaw :: EntityRaw -> SomeEntity
+entityFromRaw (Creature creatureType)
+  = SomeEntity $ Creature.newWithType creatureType
+entityFromRaw (Item itemType)
+  = SomeEntity $ Item.newWithType itemType
diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml
new file mode 100644
index 000000000000..2eac895190b3
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml
@@ -0,0 +1,13 @@
+Creature:
+  name: gormlak
+  description: a gormlak
+  longDescription: |
+    A chittering imp-like creature with bright yellow horns. It adores shiny objects
+    and gathers in swarms.
+  char:
+    char: g
+    style:
+      foreground: red
+  maxHitpoints: 5
+  speed: 125
+  friendly: false
diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws/noodles.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/noodles.yaml
new file mode 100644
index 000000000000..c3f19dce91d1
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Entities/Raws/noodles.yaml
@@ -0,0 +1,12 @@
+Item:
+  name: noodles
+  description: "a big bowl o' noodles"
+  longDescription: You know exactly what kind of noodles
+  char:
+    char: 'n'
+    style:
+      foreground: yellow
+  edible:
+    hitpointsHealed: 2
+    eatMessage:
+      - You slurp up the noodles. Yumm!
diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws/stick.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/stick.yaml
new file mode 100644
index 000000000000..bc7fde4d8b02
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Entities/Raws/stick.yaml
@@ -0,0 +1,14 @@
+Item:
+  name: stick
+  description: a wooden stick
+  longDescription: A sturdy branch broken off from some sort of tree
+  char:
+    char: ∤
+    style:
+      foreground: yellow
+  wieldable:
+    damage: 2
+    attackMessage:
+      - You bonk the {{creature.creatureType.name}} over the head with your stick.
+      - You bash the {{creature.creatureType.name}} on the noggin with your stick.
+      - You whack the {{creature.creatureType.name}} with your stick.
diff --git a/users/grfn/xanthous/src/Xanthous/Game.hs b/users/grfn/xanthous/src/Xanthous/Game.hs
new file mode 100644
index 000000000000..89c23f0de850
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs b/users/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs
new file mode 100644
index 000000000000..1b15ad4ffa64
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs
@@ -0,0 +1,51 @@
+{-# 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
+    pure $ GameState {..}
+
+
+instance CoArbitrary GameLevel
+instance Function GameLevel
+instance CoArbitrary GameState
+instance Function GameState
diff --git a/users/grfn/xanthous/src/Xanthous/Game/Draw.hs b/users/grfn/xanthous/src/Xanthous/Game/Draw.hs
new file mode 100644
index 000000000000..2375ae8c557e
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Game/Draw.hs
@@ -0,0 +1,143 @@
+--------------------------------------------------------------------------------
+module Xanthous.Game.Draw
+  ( drawGame
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+import           Brick hiding (loc, on)
+import           Brick.Widgets.Border
+import           Brick.Widgets.Border.Style
+import           Brick.Widgets.Edit
+--------------------------------------------------------------------------------
+import           Xanthous.Data
+import           Xanthous.Data.App (ResourceName, Panel(..))
+import qualified Xanthous.Data.App as Resource
+import qualified Xanthous.Data.EntityMap as EntityMap
+import           Xanthous.Game.State
+import           Xanthous.Entities.Character
+import           Xanthous.Entities.Item (Item)
+import           Xanthous.Game
+                 ( characterPosition
+                 , character
+                 , revealedEntitiesAtPosition
+                 )
+import           Xanthous.Game.Prompt
+import           Xanthous.Orphans ()
+--------------------------------------------------------------------------------
+
+cursorPosition :: GameState -> Widget ResourceName -> Widget ResourceName
+cursorPosition game
+  | WaitingPrompt _ (Prompt _ SPointOnMap (PointOnMapPromptState pos) _ _)
+    <- game ^. promptState
+  = showCursor Resource.Prompt (pos ^. loc)
+  | otherwise
+  = showCursor Resource.Character (game ^. characterPosition . loc)
+
+drawMessages :: MessageHistory -> Widget ResourceName
+drawMessages = txtWrap . (<> " ") . unwords . reverse . oextract
+
+drawPromptState :: GamePromptState m -> Widget ResourceName
+drawPromptState NoPrompt = emptyWidget
+drawPromptState (WaitingPrompt msg (Prompt _ pt ps pri _)) =
+  case (pt, ps, pri) of
+    (SStringPrompt, StringPromptState edit, _) ->
+      txtWrap msg <+> txt " " <+> renderEditor (txt . fold) True edit
+    (SDirectionPrompt, DirectionPromptState, _) -> txtWrap msg
+    (SContinue, _, _) -> txtWrap msg
+    (SMenu, _, menuItems) ->
+      txtWrap msg
+      <=> foldl' (<=>) emptyWidget (map drawMenuItem $ itoList menuItems)
+    _ -> txtWrap msg
+  where
+    drawMenuItem (chr, MenuOption m _) =
+      str ("[" <> pure chr <> "] ") <+> txtWrap m
+
+drawEntities
+  :: GameState
+  -> Widget ResourceName
+drawEntities game = vBox rows
+  where
+    allEnts = game ^. entities
+    entityPositions = EntityMap.positions allEnts
+    maxY = fromMaybe 0 $ maximumOf (folded . y) entityPositions
+    maxX = fromMaybe 0 $ maximumOf (folded . x) entityPositions
+    rows = mkRow <$> [0..maxY]
+    mkRow rowY = hBox $ renderEntityAt . flip Position rowY <$> [0..maxX]
+    renderEntityAt pos
+      = renderTopEntity pos $ revealedEntitiesAtPosition pos game
+    renderTopEntity pos ents
+      = let neighbors = EntityMap.neighbors pos allEnts
+        in maybe (str " ") (drawWithNeighbors neighbors)
+           $ maximumBy (compare `on` drawPriority)
+           <$> fromNullable ents
+
+drawMap :: GameState -> Widget ResourceName
+drawMap game
+  = viewport Resource.MapViewport Both
+  . cursorPosition game
+  $ drawEntities game
+
+bullet :: Char
+bullet = '•'
+
+drawInventoryPanel :: GameState -> Widget ResourceName
+drawInventoryPanel game
+  =   drawWielded  (game ^. character . inventory . wielded)
+  <=> drawBackpack (game ^. character . inventory . backpack)
+  where
+    drawWielded (Hands Nothing Nothing) = emptyWidget
+    drawWielded (DoubleHanded i) =
+      txtWrap $ "You are holding " <> description i <> " in both hands"
+    drawWielded (Hands l r) = drawHand "left" l <=> drawHand "right" r
+    drawHand side = maybe emptyWidget $ \i ->
+      txtWrap ( "You are holding "
+              <> description i
+              <> " in your " <> side <> " hand"
+              )
+      <=> txt " "
+
+    drawBackpack :: Vector Item -> Widget ResourceName
+    drawBackpack Empty = txtWrap "Your backpack is empty right now."
+    drawBackpack backpackItems
+      = txtWrap ( "You are currently carrying the following items in your "
+                <> "backpack:")
+        <=> txt " "
+        <=> foldl' (<=>) emptyWidget
+            (map
+              (txtWrap . ((bullet <| " ") <>) . description)
+              backpackItems)
+
+
+drawPanel :: GameState -> Panel -> Widget ResourceName
+drawPanel game panel
+  = border
+  . hLimit 35
+  . viewport (Resource.Panel panel) Vertical
+  . case panel of
+      InventoryPanel -> drawInventoryPanel
+  $ game
+
+drawCharacterInfo :: Character -> Widget ResourceName
+drawCharacterInfo ch = txt " " <+> charName <+> charHitpoints
+  where
+    charName | Just n <- ch ^. characterName
+             = txt $ n <> " "
+             | otherwise
+             = emptyWidget
+    charHitpoints
+        = txt "Hitpoints: "
+      <+> txt (tshow $ let Hitpoints hp = characterHitpoints ch in hp)
+
+drawGame :: GameState -> [Widget ResourceName]
+drawGame game
+  = pure
+  . withBorderStyle unicode
+  $ case game ^. promptState of
+       NoPrompt -> drawMessages (game ^. messageHistory)
+       _ -> emptyWidget
+  <=> drawPromptState (game ^. promptState)
+  <=>
+  (maybe emptyWidget (drawPanel game) (game ^. activePanel)
+  <+> border (drawMap game)
+  )
+  <=> drawCharacterInfo (game ^. character)
diff --git a/users/grfn/xanthous/src/Xanthous/Game/Env.hs b/users/grfn/xanthous/src/Xanthous/Game/Env.hs
new file mode 100644
index 000000000000..6e10d0f73581
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Game/Env.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Game.Env
+  ( GameEnv(..)
+  , eventChan
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Brick.BChan (BChan)
+import Xanthous.Data.App (AppEvent)
+--------------------------------------------------------------------------------
+
+data GameEnv = GameEnv
+  { _eventChan :: BChan AppEvent
+  }
+  deriving stock (Generic)
+makeLenses ''GameEnv
+{-# ANN GameEnv ("HLint: ignore Use newtype instead of data" :: String) #-}
diff --git a/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs b/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs
new file mode 100644
index 000000000000..6242b855f1cc
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs
@@ -0,0 +1,150 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+--------------------------------------------------------------------------------
+module Xanthous.Game.Lenses
+  ( positionedCharacter
+  , character
+  , characterPosition
+  , updateCharacterVision
+  , characterVisiblePositions
+  , characterVisibleEntities
+  , getInitialState
+  , initialStateFromSeed
+  , entitiesAtCharacter
+  , revealedEntitiesAtPosition
+
+    -- * Collisions
+  , Collision(..)
+  , entitiesCollision
+  , collisionAt
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           System.Random
+import           Control.Monad.State
+import           Control.Monad.Random (getRandom)
+--------------------------------------------------------------------------------
+import           Xanthous.Game.State
+import           Xanthous.Data
+import           Xanthous.Data.Levels
+import qualified Xanthous.Data.EntityMap as EntityMap
+import           Xanthous.Data.EntityMap.Graphics
+                 (visiblePositions, visibleEntities)
+import           Xanthous.Data.VectorBag
+import           Xanthous.Entities.Character (Character, mkCharacter)
+import           {-# SOURCE #-} Xanthous.Entities.Entities ()
+--------------------------------------------------------------------------------
+
+getInitialState :: IO GameState
+getInitialState = initialStateFromSeed <$> getRandom
+
+initialStateFromSeed :: Int -> GameState
+initialStateFromSeed seed =
+  let _randomGen = mkStdGen seed
+      chr = mkCharacter
+      _upStaircasePosition = Position 0 0
+      (_characterEntityID, _levelEntities)
+        = EntityMap.insertAtReturningID
+          _upStaircasePosition
+          (SomeEntity chr)
+          mempty
+      _levelRevealedPositions = mempty
+      level = GameLevel {..}
+      _levels = oneLevel level
+      _messageHistory = mempty
+      _promptState = NoPrompt
+      _activePanel = Nothing
+      _debugState = DebugState
+        { _allRevealed = False
+        }
+      _autocommand = NoAutocommand
+  in GameState {..}
+
+
+positionedCharacter :: Lens' GameState (Positioned Character)
+positionedCharacter = lens getPositionedCharacter setPositionedCharacter
+  where
+    setPositionedCharacter :: GameState -> Positioned Character -> GameState
+    setPositionedCharacter game chr
+      = game
+      &  entities . at (game ^. characterEntityID)
+      ?~ fmap SomeEntity chr
+
+    getPositionedCharacter :: GameState -> Positioned Character
+    getPositionedCharacter game
+      = over positioned
+        ( fromMaybe (error "Invariant error: Character was not a character!")
+        . downcastEntity
+        )
+      . fromMaybe (error "Invariant error: Character not found!")
+      $ EntityMap.lookupWithPosition
+        (game ^. characterEntityID)
+        (game ^. entities)
+
+
+character :: Lens' GameState Character
+character = positionedCharacter . positioned
+
+characterPosition :: Lens' GameState Position
+characterPosition = positionedCharacter . position
+
+visionRadius :: Word
+visionRadius = 12 -- TODO make this dynamic
+
+-- | Update the revealed entities at the character's position based on their
+-- vision
+updateCharacterVision :: GameState -> GameState
+updateCharacterVision game
+  = game & revealedPositions <>~ characterVisiblePositions game
+
+characterVisiblePositions :: GameState -> Set Position
+characterVisiblePositions game =
+  let charPos = game ^. characterPosition
+  in visiblePositions charPos visionRadius $ game ^. entities
+
+characterVisibleEntities :: GameState -> EntityMap.EntityMap SomeEntity
+characterVisibleEntities game =
+  let charPos = game ^. characterPosition
+  in visibleEntities charPos visionRadius $ game ^. entities
+
+entitiesCollision
+  :: ( Functor f
+    , forall xx. MonoFoldable (f xx)
+    , 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 :: Position -> GameState -> (VectorBag SomeEntity)
+revealedEntitiesAtPosition p gs
+  | p `member` characterVisiblePositions gs
+  = entitiesAtPosition
+  | p `member` (gs ^. revealedPositions)
+  = immobileEntitiesAtPosition
+  | otherwise
+  = mempty
+  where
+    entitiesAtPosition = gs ^. entities . EntityMap.atPosition p
+    immobileEntitiesAtPosition = filter (not . entityCanMove) entitiesAtPosition
diff --git a/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs b/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs
new file mode 100644
index 000000000000..30b5fe7545e0
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs
@@ -0,0 +1,289 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DeriveFunctor #-}
+--------------------------------------------------------------------------------
+module Xanthous.Game.Prompt
+  ( PromptType(..)
+  , SPromptType(..)
+  , SingPromptType(..)
+  , PromptCancellable(..)
+  , PromptResult(..)
+  , PromptState(..)
+  , MenuOption(..)
+  , mkMenuItems
+  , PromptInput
+  , Prompt(..)
+  , mkPrompt
+  , mkMenu
+  , mkPointOnMapPrompt
+  , isCancellable
+  , submitPrompt
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Brick.Widgets.Edit (Editor, editorText, getEditContents)
+import           Test.QuickCheck
+import           Test.QuickCheck.Arbitrary.Generic
+--------------------------------------------------------------------------------
+import           Xanthous.Util (smallestNotIn)
+import           Xanthous.Data (Direction, Position)
+import           Xanthous.Data.App (ResourceName)
+import qualified Xanthous.Data.App as Resource
+--------------------------------------------------------------------------------
+
+data PromptType where
+  StringPrompt    :: PromptType
+  Confirm         :: PromptType
+  Menu            :: Type -> PromptType
+  DirectionPrompt :: PromptType
+  PointOnMap      :: PromptType
+  Continue        :: PromptType
+  deriving stock (Generic)
+
+instance Show PromptType where
+  show StringPrompt = "StringPrompt"
+  show Confirm = "Confirm"
+  show (Menu _) = "Menu"
+  show DirectionPrompt = "DirectionPrompt"
+  show PointOnMap = "PointOnMap"
+  show Continue = "Continue"
+
+data SPromptType :: PromptType -> Type where
+  SStringPrompt    ::      SPromptType 'StringPrompt
+  SConfirm         ::      SPromptType 'Confirm
+  SMenu            ::      SPromptType ('Menu a)
+  SDirectionPrompt ::      SPromptType 'DirectionPrompt
+  SPointOnMap      ::      SPromptType 'PointOnMap
+  SContinue        ::      SPromptType 'Continue
+
+instance NFData (SPromptType pt) where
+  rnf SStringPrompt = ()
+  rnf SConfirm = ()
+  rnf SMenu = ()
+  rnf SDirectionPrompt = ()
+  rnf SPointOnMap = ()
+  rnf SContinue = ()
+
+class SingPromptType pt where singPromptType :: SPromptType pt
+instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt
+instance SingPromptType 'Confirm where singPromptType = SConfirm
+instance SingPromptType 'DirectionPrompt where singPromptType = SDirectionPrompt
+instance SingPromptType 'PointOnMap where singPromptType = SPointOnMap
+instance SingPromptType 'Continue where singPromptType = SContinue
+
+instance Show (SPromptType pt) where
+  show SStringPrompt    = "SStringPrompt"
+  show SConfirm         = "SConfirm"
+  show SMenu            = "SMenu"
+  show SDirectionPrompt = "SDirectionPrompt"
+  show SPointOnMap      = "SPointOnMap"
+  show SContinue        = "SContinue"
+
+data PromptCancellable
+  = Cancellable
+  | Uncancellable
+  deriving stock (Show, Eq, Ord, Enum, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+
+instance Arbitrary PromptCancellable where
+  arbitrary = genericArbitrary
+
+data PromptResult (pt :: PromptType) where
+  StringResult     :: Text      -> PromptResult 'StringPrompt
+  ConfirmResult    :: Bool      -> PromptResult 'Confirm
+  MenuResult       :: forall a. a    -> PromptResult ('Menu a)
+  DirectionResult  :: Direction -> PromptResult 'DirectionPrompt
+  PointOnMapResult :: Position  -> PromptResult 'PointOnMap
+  ContinueResult   ::             PromptResult 'Continue
+
+instance Arbitrary (PromptResult 'StringPrompt) where
+  arbitrary = StringResult <$> arbitrary
+
+instance Arbitrary (PromptResult 'Confirm) where
+  arbitrary = ConfirmResult <$> arbitrary
+
+instance Arbitrary a => Arbitrary (PromptResult ('Menu a)) where
+  arbitrary = MenuResult <$> arbitrary
+
+instance Arbitrary (PromptResult 'DirectionPrompt) where
+  arbitrary = DirectionResult <$> arbitrary
+
+instance Arbitrary (PromptResult 'PointOnMap) where
+  arbitrary = PointOnMapResult <$> arbitrary
+
+instance Arbitrary (PromptResult 'Continue) where
+  arbitrary = pure ContinueResult
+
+--------------------------------------------------------------------------------
+
+data PromptState pt where
+  StringPromptState
+    :: Editor Text ResourceName     -> PromptState 'StringPrompt
+  DirectionPromptState  ::            PromptState 'DirectionPrompt
+  ContinuePromptState   ::            PromptState 'Continue
+  ConfirmPromptState    ::            PromptState 'Confirm
+  MenuPromptState       :: forall a.       PromptState ('Menu a)
+  PointOnMapPromptState :: Position -> PromptState 'PointOnMap
+
+instance NFData (PromptState pt) where
+  rnf sps@(StringPromptState ed) = sps `deepseq` ed `deepseq` ()
+  rnf DirectionPromptState = ()
+  rnf ContinuePromptState = ()
+  rnf ConfirmPromptState = ()
+  rnf MenuPromptState = ()
+  rnf pomps@(PointOnMapPromptState pos) = pomps `deepseq` pos `deepseq` ()
+
+instance Arbitrary (PromptState 'StringPrompt) where
+  arbitrary = StringPromptState <$> arbitrary
+
+instance Arbitrary (PromptState 'DirectionPrompt) where
+  arbitrary = pure DirectionPromptState
+
+instance Arbitrary (PromptState 'Continue) where
+  arbitrary = pure ContinuePromptState
+
+instance Arbitrary (PromptState ('Menu a)) where
+  arbitrary = pure MenuPromptState
+
+instance CoArbitrary (PromptState 'StringPrompt) where
+  coarbitrary (StringPromptState ed) = coarbitrary ed
+
+instance CoArbitrary (PromptState 'DirectionPrompt) where
+  coarbitrary DirectionPromptState = coarbitrary ()
+
+instance CoArbitrary (PromptState 'Continue) where
+  coarbitrary ContinuePromptState = coarbitrary ()
+
+instance CoArbitrary (PromptState ('Menu a)) where
+  coarbitrary MenuPromptState = coarbitrary ()
+
+deriving stock instance Show (PromptState pt)
+
+data MenuOption a = MenuOption Text a
+  deriving stock (Eq, Generic, Functor)
+  deriving anyclass (NFData, CoArbitrary, Function)
+
+instance Comonad MenuOption where
+  extract (MenuOption _ x) = x
+  extend cok mo@(MenuOption text _) = MenuOption text (cok mo)
+
+mkMenuItems :: (MonoFoldable f, Element f ~ (Char, MenuOption a))
+            => f
+            -> Map Char (MenuOption a)
+mkMenuItems = flip foldl' mempty $ \items (chr, option) ->
+  let chr' = if has (ix chr) items
+             then smallestNotIn $ keys items
+             else chr
+  in items & at chr' ?~ option
+
+instance Show (MenuOption a) where
+  show (MenuOption m _) = show m
+
+type family PromptInput (pt :: PromptType) :: Type where
+  PromptInput ('Menu a) = Map Char (MenuOption a)
+  PromptInput 'PointOnMap = Position -- Character pos
+  PromptInput _ = ()
+
+data Prompt (m :: Type -> Type) where
+  Prompt
+    :: forall (pt :: PromptType)
+        (m :: Type -> Type).
+      PromptCancellable
+    -> SPromptType pt
+    -> PromptState pt
+    -> PromptInput pt
+    -> (PromptResult pt -> m ())
+    -> Prompt m
+
+instance Show (Prompt m) where
+  show (Prompt c pt ps pri _)
+    = "(Prompt "
+    <> show c <> " "
+    <> show pt <> " "
+    <> show ps <> " "
+    <> showPri
+    <> " <function>)"
+    where showPri = case pt of
+            SMenu -> show pri
+            _ -> "()"
+
+instance NFData (Prompt m) where
+  rnf (Prompt c SMenu ps pri cb)
+            = c
+    `deepseq` ps
+    `deepseq` pri
+    `seq` cb
+    `seq` ()
+  rnf (Prompt c spt ps pri cb)
+            = c
+    `deepseq` spt
+    `deepseq` ps
+    `deepseq` pri
+    `seq` cb
+    `seq` ()
+
+instance CoArbitrary (m ()) => CoArbitrary (Prompt m) where
+  coarbitrary (Prompt c SStringPrompt ps pri cb) =
+    variant @Int 1 . coarbitrary (c, ps, pri, cb)
+  coarbitrary (Prompt c SConfirm _ pri cb) = -- TODO fill in prompt state
+    variant @Int 2 . coarbitrary (c, pri, cb)
+  coarbitrary (Prompt c SMenu _ps _pri _cb) =
+    variant @Int 3 . coarbitrary c {-, ps, pri, cb -}
+  coarbitrary (Prompt c SDirectionPrompt ps pri cb) =
+    variant @Int 4 . coarbitrary (c, ps, pri, cb)
+  coarbitrary (Prompt c SPointOnMap _ pri cb) = -- TODO fill in prompt state
+    variant @Int 5 . coarbitrary (c, pri, cb)
+  coarbitrary (Prompt c SContinue ps pri cb) =
+    variant @Int 6 . coarbitrary (c, ps, pri, cb)
+
+-- instance Function (Prompt m) where
+--   function = functionMap toTuple _fromTuple
+--     where
+--       toTuple (Prompt c pt ps pri cb) = (c, pt, ps, pri, cb)
+
+
+mkPrompt :: (PromptInput pt ~ ()) => PromptCancellable -> SPromptType pt -> (PromptResult pt -> m ()) -> Prompt m
+mkPrompt c pt@SStringPrompt cb =
+  let ps = StringPromptState $ editorText Resource.Prompt (Just 1) ""
+  in Prompt c pt ps () cb
+mkPrompt c pt@SDirectionPrompt cb = Prompt c pt DirectionPromptState () cb
+mkPrompt c pt@SContinue cb = Prompt c pt ContinuePromptState () cb
+mkPrompt c pt@SConfirm cb = Prompt c pt ConfirmPromptState () cb
+
+mkMenu
+  :: forall a m.
+    PromptCancellable
+  -> Map Char (MenuOption a) -- ^ Menu items
+  -> (PromptResult ('Menu a) -> m ())
+  -> Prompt m
+mkMenu c = Prompt c SMenu MenuPromptState
+
+mkPointOnMapPrompt
+  :: PromptCancellable
+  -> Position
+  -> (PromptResult 'PointOnMap -> m ())
+  -> Prompt m
+mkPointOnMapPrompt c pos = Prompt c SPointOnMap (PointOnMapPromptState pos) pos
+
+isCancellable :: Prompt m -> Bool
+isCancellable (Prompt Cancellable _ _ _ _)   = True
+isCancellable (Prompt Uncancellable _ _ _ _) = False
+
+submitPrompt :: Applicative m => Prompt m -> m ()
+submitPrompt (Prompt _ pt ps _ cb) =
+  case (pt, ps) of
+    (SStringPrompt, StringPromptState edit) ->
+      cb . StringResult . mconcat . getEditContents $ edit
+    (SDirectionPrompt, DirectionPromptState) ->
+      pure () -- Don't use submit with a direction prompt
+    (SContinue, ContinuePromptState) ->
+      cb ContinueResult
+    (SMenu, MenuPromptState) ->
+      pure () -- Don't use submit with a menu prompt
+    (SPointOnMap, PointOnMapPromptState pos) ->
+      cb $ PointOnMapResult pos
+    (SConfirm, ConfirmPromptState) ->
+      cb $ ConfirmResult True
diff --git a/users/grfn/xanthous/src/Xanthous/Game/State.hs b/users/grfn/xanthous/src/Xanthous/Game/State.hs
new file mode 100644
index 000000000000..f614cad47339
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Game/State.hs
@@ -0,0 +1,558 @@
+{-# LANGUAGE StandaloneDeriving   #-}
+{-# LANGUAGE RecordWildCards      #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TemplateHaskell      #-}
+{-# LANGUAGE GADTs                #-}
+{-# LANGUAGE AllowAmbiguousTypes  #-}
+--------------------------------------------------------------------------------
+module Xanthous.Game.State
+  ( GameState(..)
+  , entities
+  , levels
+  , revealedPositions
+  , messageHistory
+  , randomGen
+  , activePanel
+  , promptState
+  , characterEntityID
+  , autocommand
+  , GamePromptState(..)
+
+    -- * Game Level
+  , GameLevel(..)
+  , levelEntities
+  , upStaircasePosition
+  , levelRevealedPositions
+
+    -- * Messages
+  , MessageHistory(..)
+  , HasMessages(..)
+  , HasTurn(..)
+  , HasDisplayedTurn(..)
+  , pushMessage
+  , previousMessage
+  , nextTurn
+
+    -- * Autocommands
+  , Autocommand(..)
+  , AutocommandState(..)
+  , _NoAutocommand
+  , _ActiveAutocommand
+
+    -- * App monad
+  , AppT(..)
+  , AppM
+  , runAppT
+
+    -- * Entities
+  , Draw(..)
+  , Brain(..)
+  , Brainless(..)
+  , brainVia
+  , Collision(..)
+  , Entity(..)
+  , SomeEntity(..)
+  , downcastEntity
+  , _SomeEntity
+  , entityIs
+    -- ** Vias
+  , Color(..)
+  , DrawNothing(..)
+  , DrawRawChar(..)
+  , DrawRawCharPriority(..)
+  , DrawCharacter(..)
+  , DrawStyledCharacter(..)
+  , DeriveEntity(..)
+    -- ** Field classes
+  , HasChar(..)
+  , HasStyle(..)
+
+    -- * Debug State
+  , DebugState(..)
+  , debugState
+  , allRevealed
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Data.List.NonEmpty ( NonEmpty((:|)))
+import qualified Data.List.NonEmpty as NonEmpty
+import           Data.Typeable
+import           Data.Coerce
+import           System.Random
+import           Test.QuickCheck
+import           Test.QuickCheck.Arbitrary.Generic
+import           Control.Monad.Random.Class
+import           Control.Monad.State
+import           Control.Monad.Trans.Control (MonadTransControl(..))
+import           Control.Monad.Trans.Compose
+import           Control.Monad.Morph (MFunctor(..))
+import           Brick (EventM, Widget, raw, str, emptyWidget)
+import           Data.Aeson (ToJSON(..), FromJSON(..), Value(Null))
+import qualified Data.Aeson as JSON
+import           Data.Aeson.Generic.DerivingVia
+import           Data.Generics.Product.Fields
+import qualified Graphics.Vty.Attributes as Vty
+import qualified Graphics.Vty.Image as Vty
+--------------------------------------------------------------------------------
+import           Xanthous.Util (KnownBool(..))
+import           Xanthous.Util.QuickCheck (GenericArbitrary(..))
+import           Xanthous.Data
+import           Xanthous.Data.App
+import           Xanthous.Data.Levels
+import           Xanthous.Data.EntityMap (EntityMap, EntityID)
+import           Xanthous.Data.EntityChar
+import           Xanthous.Data.VectorBag
+import           Xanthous.Data.Entities
+import           Xanthous.Orphans ()
+import           Xanthous.Game.Prompt
+import           Xanthous.Game.Env
+--------------------------------------------------------------------------------
+
+data MessageHistory
+  = MessageHistory
+  { _messages      :: Map Word (NonEmpty Text)
+  , _turn          :: Word
+  , _displayedTurn :: Maybe Word
+  }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary MessageHistory
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           MessageHistory
+makeFieldsNoPrefix ''MessageHistory
+
+instance Semigroup MessageHistory where
+  (MessageHistory msgs₁ turn₁ dt₁) <> (MessageHistory msgs₂ turn₂ dt₂) =
+    MessageHistory (msgs₁ <> msgs₂) (max turn₁ turn₂) $ case (dt₁, dt₂) of
+      (_, Nothing)      -> Nothing
+      (Just t, _)       -> Just t
+      (Nothing, Just t) -> Just t
+
+instance Monoid MessageHistory where
+  mempty = MessageHistory mempty 0 Nothing
+
+type instance Element MessageHistory = [Text]
+instance MonoFunctor MessageHistory where
+  omap f mh@(MessageHistory _ t _) =
+    mh & messages . at t %~ (NonEmpty.nonEmpty . f . toList =<<)
+
+instance MonoComonad MessageHistory where
+  oextract (MessageHistory ms t dt) = maybe [] toList $ ms ^. at (fromMaybe t dt)
+  oextend cok mh@(MessageHistory _ t dt) =
+    mh & messages . at (fromMaybe t dt) .~ NonEmpty.nonEmpty (cok mh)
+
+pushMessage :: Text -> MessageHistory -> MessageHistory
+pushMessage msg mh@(MessageHistory _ turn' _) =
+  mh
+  & messages . at turn' %~ \case
+    Nothing -> Just $ msg :| mempty
+    Just msgs -> Just $ msg <| msgs
+  & displayedTurn .~ Nothing
+
+nextTurn :: MessageHistory -> MessageHistory
+nextTurn = (turn +~ 1) . (displayedTurn .~ Nothing)
+
+previousMessage :: MessageHistory -> MessageHistory
+previousMessage mh = mh & displayedTurn .~ maximumOf
+  (messages . ifolded . asIndex . filtered (< mh ^. turn))
+  mh
+
+
+--------------------------------------------------------------------------------
+
+data GamePromptState m where
+  NoPrompt :: GamePromptState m
+  WaitingPrompt :: Text -> Prompt m -> GamePromptState m
+  deriving stock (Show, Generic)
+  deriving anyclass (NFData)
+
+-- | Non-injective! We never try to serialize waiting prompts, since:
+--
+--  * they contain callback functions
+--  * we can't save the game when in a prompt anyway
+instance ToJSON (GamePromptState m) where
+  toJSON _ = Null
+
+-- | Always expects Null
+instance FromJSON (GamePromptState m) where
+  parseJSON Null = pure NoPrompt
+  parseJSON _ = fail "Invalid GamePromptState; expected null"
+
+instance CoArbitrary (GamePromptState m) where
+  coarbitrary NoPrompt = variant @Int 1
+  coarbitrary (WaitingPrompt txt _) = variant @Int 2 . coarbitrary txt
+
+instance Function (GamePromptState m) where
+  function = functionMap onlyNoPrompt (const NoPrompt)
+    where
+      onlyNoPrompt NoPrompt = ()
+      onlyNoPrompt (WaitingPrompt _ _) =
+        error "Can't handle prompts in Function!"
+
+--------------------------------------------------------------------------------
+
+newtype AppT m a
+  = AppT { unAppT :: ReaderT GameEnv (StateT GameState m) a }
+  deriving ( Functor
+           , Applicative
+           , Monad
+           , MonadState GameState
+           , MonadReader GameEnv
+           , MonadIO
+           )
+       via (ReaderT GameEnv (StateT GameState m))
+  deriving ( MonadTrans
+           , MFunctor
+           )
+       via (ReaderT GameEnv `ComposeT` StateT GameState)
+
+type AppM = AppT (EventM ResourceName)
+
+--------------------------------------------------------------------------------
+
+class Draw a where
+  drawWithNeighbors :: Neighbors (VectorBag SomeEntity) -> a -> Widget n
+  drawWithNeighbors = const draw
+
+  draw :: a -> Widget n
+  draw = drawWithNeighbors $ pure mempty
+
+  -- | higher priority gets drawn on top
+  drawPriority :: a -> Word
+  drawPriority = const minBound
+
+instance Draw a => Draw (Positioned a) where
+  drawWithNeighbors ns (Positioned _ a) = drawWithNeighbors ns a
+  draw (Positioned _ a) = draw a
+
+newtype DrawCharacter (char :: Symbol) (a :: Type) where
+  DrawCharacter :: a -> DrawCharacter char a
+
+instance KnownSymbol char => Draw (DrawCharacter char a) where
+  draw _ = str $ symbolVal @char Proxy
+
+data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White
+
+class KnownColor (color :: Color) where
+  colorVal :: forall proxy. proxy color -> Vty.Color
+
+instance KnownColor 'Black where colorVal _ = Vty.black
+instance KnownColor 'Red where colorVal _ = Vty.red
+instance KnownColor 'Green where colorVal _ = Vty.green
+instance KnownColor 'Yellow where colorVal _ = Vty.yellow
+instance KnownColor 'Blue where colorVal _ = Vty.blue
+instance KnownColor 'Magenta where colorVal _ = Vty.magenta
+instance KnownColor 'Cyan where colorVal _ = Vty.cyan
+instance KnownColor 'White where colorVal _ = Vty.white
+
+class KnownMaybeColor (maybeColor :: Maybe Color) where
+  maybeColorVal :: forall proxy. proxy maybeColor -> Maybe Vty.Color
+
+instance KnownMaybeColor 'Nothing where maybeColorVal _ = Nothing
+instance KnownColor color => KnownMaybeColor ('Just color) where
+  maybeColorVal _ = Just $ colorVal @color Proxy
+
+newtype DrawStyledCharacter (fg :: Maybe Color) (bg :: Maybe Color) (char :: Symbol) (a :: Type) where
+  DrawStyledCharacter :: a -> DrawStyledCharacter fg bg char a
+
+instance
+  ( KnownMaybeColor fg
+  , KnownMaybeColor bg
+  , KnownSymbol char
+  )
+  => Draw (DrawStyledCharacter fg bg char a) where
+  draw _ = raw $ Vty.string attr $ symbolVal @char Proxy
+    where attr = Vty.Attr
+            { Vty.attrStyle = Vty.Default
+            , Vty.attrForeColor = maybe Vty.Default Vty.SetTo
+                                  $ maybeColorVal @fg Proxy
+            , Vty.attrBackColor = maybe Vty.Default Vty.SetTo
+                                  $ maybeColorVal @bg Proxy
+            , Vty.attrURL = Vty.Default
+            }
+
+instance Draw EntityChar where
+  draw EntityChar{..} = raw $ Vty.string _style [_char]
+
+--------------------------------------------------------------------------------
+
+newtype DrawNothing (a :: Type) = DrawNothing a
+
+instance Draw (DrawNothing a) where
+  draw = const emptyWidget
+  drawPriority = const 0
+
+newtype DrawRawChar (rawField :: Symbol) (a :: Type) = DrawRawChar a
+
+instance
+  forall rawField a raw.
+  ( HasField rawField a a raw raw
+  , HasChar raw EntityChar
+  ) => Draw (DrawRawChar rawField a) where
+  draw (DrawRawChar e) = draw $ e ^. field @rawField . char
+
+newtype DrawRawCharPriority
+  (rawField :: Symbol)
+  (priority :: Nat)
+  (a :: Type)
+  = DrawRawCharPriority a
+
+instance
+  forall rawField priority a raw.
+  ( HasField rawField a a raw raw
+  , KnownNat priority
+  , HasChar raw EntityChar
+  ) => Draw (DrawRawCharPriority rawField priority a) where
+  draw (DrawRawCharPriority e) = draw $ e ^. field @rawField . char
+  drawPriority = const . fromIntegral $ natVal @priority Proxy
+
+
+--------------------------------------------------------------------------------
+
+class Brain a where
+  step :: Ticks -> Positioned a -> AppM (Positioned a)
+  -- | Does this entity ever move on its own?
+  entityCanMove :: a -> Bool
+  entityCanMove = const False
+
+newtype Brainless a = Brainless a
+
+instance Brain (Brainless a) where
+  step = const pure
+
+-- | Workaround for the inability to use DerivingVia on Brain due to the lack of
+-- higher-order roles (specifically AppT not having its last type argument have
+-- role representational bc of StateT)
+brainVia
+  :: forall brain entity. (Coercible entity brain, Brain brain)
+  => (entity -> brain) -- ^ constructor, ignored
+  -> (Ticks -> Positioned entity -> AppM (Positioned entity))
+brainVia _ ticks = fmap coerce . step ticks . coerce @_ @(Positioned brain)
+
+--------------------------------------------------------------------------------
+
+class ( Show a, Eq a, Ord a, NFData a
+      , ToJSON a, FromJSON a
+      , Draw a, Brain a
+      ) => Entity a where
+  entityAttributes :: a -> EntityAttributes
+  entityAttributes = const defaultEntityAttributes
+  description :: a -> Text
+  entityChar :: a -> EntityChar
+  entityCollision :: a -> Maybe Collision
+  entityCollision = const $ Just Stop
+
+data SomeEntity where
+  SomeEntity :: forall a. (Entity a, Typeable a) => a -> SomeEntity
+
+instance Show SomeEntity where
+  show (SomeEntity e) = "SomeEntity (" <> show e <> ")"
+
+instance Eq SomeEntity where
+  (SomeEntity (a :: ea)) == (SomeEntity (b :: eb)) = case eqT @ea @eb of
+    Just Refl -> a == b
+    _ -> False
+
+instance Ord SomeEntity where
+  compare (SomeEntity (a :: ea)) (SomeEntity (b :: eb)) = case eqT @ea @eb of
+    Just Refl -> compare a b
+    _ -> compare (typeRep $ Proxy @ea) (typeRep $ Proxy @eb)
+
+
+instance NFData SomeEntity where
+  rnf (SomeEntity ent) = ent `deepseq` ()
+
+instance ToJSON SomeEntity where
+  toJSON (SomeEntity ent) = entityToJSON ent
+    where
+      entityToJSON :: forall entity. (Entity entity, Typeable entity)
+                   => entity -> JSON.Value
+      entityToJSON entity = JSON.object
+        [ "type" JSON..= tshow (typeRep @_ @entity Proxy)
+        , "data" JSON..= toJSON entity
+        ]
+
+instance Draw SomeEntity where
+  drawWithNeighbors ns (SomeEntity ent) = drawWithNeighbors ns ent
+  drawPriority (SomeEntity ent) = drawPriority ent
+
+instance Brain SomeEntity where
+  step ticks (Positioned p (SomeEntity ent)) =
+    fmap SomeEntity <$> step ticks (Positioned p ent)
+  entityCanMove (SomeEntity ent) = entityCanMove ent
+
+downcastEntity :: forall (a :: Type). (Typeable a) => SomeEntity -> Maybe a
+downcastEntity (SomeEntity e) = cast e
+
+entityIs :: forall (a :: Type). (Typeable a) => SomeEntity -> Bool
+entityIs = isJust . downcastEntity @a
+
+_SomeEntity :: forall a. (Entity a, Typeable a) => Prism' SomeEntity a
+_SomeEntity = prism' SomeEntity downcastEntity
+
+newtype DeriveEntity
+  (blocksVision :: Bool)
+  (description :: Symbol)
+  (entityChar :: Symbol)
+  (entity :: Type)
+  = DeriveEntity entity
+  deriving newtype (Show, Eq, Ord, NFData, ToJSON, FromJSON, Draw)
+
+instance Brain entity => Brain (DeriveEntity b d c entity) where
+  step = brainVia $ \(DeriveEntity e) -> e
+
+instance
+  ( KnownBool blocksVision
+  , KnownSymbol description
+  , KnownSymbol entityChar
+  , Show entity, Eq entity, Ord entity, NFData entity
+  , ToJSON entity, FromJSON entity
+  , Draw entity, Brain entity
+  )
+  => Entity (DeriveEntity blocksVision description entityChar entity) where
+  entityAttributes _ = defaultEntityAttributes
+    & blocksVision .~ boolVal @blocksVision
+  description _ = pack . symbolVal $ Proxy @description
+  entityChar _ = fromString . symbolVal $ Proxy @entityChar
+
+--------------------------------------------------------------------------------
+
+data GameLevel = GameLevel
+  { _levelEntities :: !(EntityMap SomeEntity)
+  , _upStaircasePosition :: !Position
+  , _levelRevealedPositions :: !(Set Position)
+  }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData)
+  deriving (ToJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           GameLevel
+
+--------------------------------------------------------------------------------
+
+data Autocommand
+  = AutoMove Direction
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, Hashable, ToJSON, FromJSON, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary Autocommand
+{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
+
+data AutocommandState
+  = NoAutocommand
+  | ActiveAutocommand Autocommand (Async ())
+  deriving stock (Eq, Ord, Generic)
+  deriving anyclass (Hashable)
+
+instance Show AutocommandState where
+  show NoAutocommand = "NoAutocommand"
+  show (ActiveAutocommand ac _) =
+    "(ActiveAutocommand " <> show ac <> " <Async>)"
+
+instance ToJSON AutocommandState where
+  toJSON = const Null
+
+instance FromJSON AutocommandState where
+  parseJSON Null = pure NoAutocommand
+  parseJSON _ = fail "Invalid AutocommandState; expected null"
+
+instance NFData AutocommandState where
+  rnf NoAutocommand = ()
+  rnf (ActiveAutocommand ac t) = ac `deepseq` t `seq` ()
+
+instance CoArbitrary AutocommandState where
+  coarbitrary NoAutocommand = variant @Int 1
+  coarbitrary (ActiveAutocommand ac t)
+    = variant @Int 2
+    . coarbitrary ac
+    . coarbitrary (hash t)
+
+instance Function AutocommandState where
+  function = functionMap onlyNoAC (const NoAutocommand)
+    where
+      onlyNoAC NoAutocommand = ()
+      onlyNoAC _ = error "Can't handle autocommands in Function"
+
+--------------------------------------------------------------------------------
+
+
+data DebugState = DebugState
+  { _allRevealed :: !Bool
+  }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           DebugState
+{-# ANN DebugState ("HLint: ignore Use newtype instead of data" :: String) #-}
+
+instance Arbitrary DebugState where
+  arbitrary = genericArbitrary
+
+data GameState = GameState
+  { _levels            :: !(Levels GameLevel)
+  , _characterEntityID :: !EntityID
+  , _messageHistory    :: !MessageHistory
+  , _randomGen         :: !StdGen
+
+    -- | The active panel displayed in the UI, if any
+  , _activePanel       :: !(Maybe Panel)
+
+  , _promptState       :: !(GamePromptState AppM)
+  , _debugState        :: !DebugState
+  , _autocommand       :: !AutocommandState
+  }
+  deriving stock (Show, Generic)
+  deriving anyclass (NFData)
+  deriving (ToJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           GameState
+
+makeLenses ''GameLevel
+makeLenses ''GameState
+
+entities :: Lens' GameState (EntityMap SomeEntity)
+entities = levels . current . levelEntities
+
+revealedPositions :: Lens' GameState (Set Position)
+revealedPositions = levels . current . levelRevealedPositions
+
+instance Eq GameState where
+  (==) = (==) `on` \gs ->
+    ( gs ^. entities
+    , gs ^. revealedPositions
+    , gs ^. characterEntityID
+    , gs ^. messageHistory
+    , gs ^. activePanel
+    , gs ^. debugState
+    )
+
+--------------------------------------------------------------------------------
+
+runAppT :: Monad m => AppT m a -> GameEnv -> GameState -> m (a, GameState)
+runAppT appt env initialState
+  = flip runStateT initialState
+  . flip runReaderT env
+  . unAppT
+  $ appt
+
+instance (Monad m) => MonadRandom (AppT m) where
+  getRandomR rng = randomGen %%= randomR rng
+  getRandom = randomGen %%= random
+  getRandomRs rng = uses randomGen $ randomRs rng
+  getRandoms = uses randomGen randoms
+
+instance MonadTransControl AppT where
+  type StT AppT a = (a, GameState)
+  liftWith f
+    = AppT
+    . ReaderT $ \e
+    -> StateT $ \s
+    -> (,s) <$> f (\action -> runAppT action e s)
+  restoreT = AppT . ReaderT . const . StateT . const
+
+--------------------------------------------------------------------------------
+
+makeLenses ''DebugState
+makePrisms ''AutocommandState
diff --git a/users/grfn/xanthous/src/Xanthous/Generators.hs b/users/grfn/xanthous/src/Xanthous/Generators.hs
new file mode 100644
index 000000000000..ef37070b6ede
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Generators.hs
@@ -0,0 +1,168 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE GADTs           #-}
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Generators
+  ( 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.CaveAutomata as CaveAutomata
+import qualified Xanthous.Generators.Dungeon as Dungeon
+import           Xanthous.Generators.Util
+import           Xanthous.Generators.LevelContents
+import           Xanthous.Generators.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 <$> pure 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
+  -> m Level
+generateLevel gen ps dims = 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 cells
+  _levelDoors <- randomDoors cells
+  _levelCharacterPosition <- chooseCharacterPosition cells
+  let upStaircase = _EntityMap # [(_levelCharacterPosition, UpStaircase)]
+  downStaircase <- placeDownStaircase cells
+  let _levelStaircases = upStaircase <> downStaircase
+  _levelTutorialMessage <- tutorialMessage cells _levelCharacterPosition
+  pure Level {..}
+
+levelToEntityMap :: Level -> EntityMap SomeEntity
+levelToEntityMap level
+  = (SomeEntity <$> level ^. levelWalls)
+  <> (SomeEntity <$> level ^. levelDoors)
+  <> (SomeEntity <$> level ^. levelItems)
+  <> (SomeEntity <$> level ^. levelCreatures)
+  <> (SomeEntity <$> level ^. levelTutorialMessage)
+  <> (SomeEntity <$> level ^. levelStaircases)
+  <> (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/grfn/xanthous/src/Xanthous/Generators/CaveAutomata.hs b/users/grfn/xanthous/src/Xanthous/Generators/CaveAutomata.hs
new file mode 100644
index 000000000000..be904662f3f7
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Generators/CaveAutomata.hs
@@ -0,0 +1,112 @@
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Generators.CaveAutomata
+  ( Params(..)
+  , defaultParams
+  , parseParams
+  , generate
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+import           Control.Monad.Random (RandomGen, runRandT)
+import           Data.Array.ST
+import           Data.Array.Unboxed
+import qualified Options.Applicative as Opt
+--------------------------------------------------------------------------------
+import           Xanthous.Util (between)
+import           Xanthous.Util.Optparse
+import           Xanthous.Data (Dimensions, width, height)
+import           Xanthous.Generators.Util
+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/grfn/xanthous/src/Xanthous/Generators/Dungeon.hs b/users/grfn/xanthous/src/Xanthous/Generators/Dungeon.hs
new file mode 100644
index 000000000000..f30713ce1182
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Generators/Dungeon.hs
@@ -0,0 +1,190 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Generators.Dungeon
+  ( Params(..)
+  , defaultParams
+  , parseParams
+  , generate
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding ((:>))
+--------------------------------------------------------------------------------
+import           Control.Monad.Random
+import           Data.Array.ST
+import           Data.Array.IArray (amap)
+import           Data.Stream.Infinite (Stream(..))
+import qualified Data.Stream.Infinite as Stream
+import qualified Data.Graph.Inductive.Graph as Graph
+import           Data.Graph.Inductive.PatriciaTree
+import qualified Data.List.NonEmpty as NE
+import           Data.Maybe (fromJust)
+import           Linear.V2
+import           Linear.Metric
+import qualified Options.Applicative as Opt
+--------------------------------------------------------------------------------
+import           Xanthous.Random
+import           Xanthous.Data hiding (x, y, _x, _y, edges)
+import           Xanthous.Generators.Util
+import           Xanthous.Util.Graphics (delaunay, straightLine)
+import           Xanthous.Util.Graph (mstSubGraph)
+--------------------------------------------------------------------------------
+
+data Params = Params
+  { _numRoomsRange :: (Word, Word)
+  , _roomDimensionRange :: (Word, Word)
+  , _connectednessRatioRange :: (Double, Double)
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+makeLenses ''Params
+
+defaultParams :: Params
+defaultParams = Params
+  { _numRoomsRange = (6, 8)
+  , _roomDimensionRange = (3, 12)
+  , _connectednessRatioRange = (0.1, 0.15)
+  }
+
+parseParams :: Opt.Parser Params
+parseParams = Params
+  <$> parseRange
+        "num-rooms"
+        "number of rooms to generate in the dungeon"
+        "ROOMS"
+        (defaultParams ^. numRoomsRange)
+  <*> parseRange
+        "room-size"
+        "size in tiles of one of the sides of a room"
+        "TILES"
+        (defaultParams ^. roomDimensionRange)
+  <*> parseRange
+        "connectedness-ratio"
+        ( "ratio of edges from the delaunay triangulation to re-add to the "
+        <> "minimum-spanning-tree")
+        "RATIO"
+        (defaultParams ^. connectednessRatioRange)
+  <**> Opt.helper
+  where
+    parseRange name desc metavar (defMin, defMax) =
+      (,)
+      <$> Opt.option Opt.auto
+          ( Opt.long ("min-" <> name)
+          <> Opt.value defMin
+          <> Opt.showDefault
+          <> Opt.help ("Minimum " <> desc)
+          <> Opt.metavar metavar
+          )
+      <*> Opt.option Opt.auto
+          ( Opt.long ("max-" <> name)
+          <> Opt.value defMax
+          <> Opt.showDefault
+          <> Opt.help ("Maximum " <> desc)
+          <> Opt.metavar metavar
+          )
+
+generate :: RandomGen g => Params -> Dimensions -> g -> Cells
+generate params dims gen
+  = amap not
+  $ runSTUArray
+  $ fmap fst
+  $ flip runRandT gen
+  $ generate' params dims
+
+--------------------------------------------------------------------------------
+
+generate' :: RandomGen g => Params -> Dimensions -> CellM g s (MCells s)
+generate' params dims = do
+  cells <- initializeEmpty dims
+  rooms <- genRooms params dims
+  for_ rooms $ fillRoom cells
+
+  let fullRoomGraph = delaunayRoomGraph rooms
+      mst = mstSubGraph fullRoomGraph
+      mstEdges = Graph.edges mst
+      nonMSTEdges = filter (\(n₁, n₂, _) -> (n₁, n₂) `notElem` mstEdges)
+                    $ Graph.labEdges fullRoomGraph
+
+  reintroEdgeCount <- floor . (* fromIntegral (length nonMSTEdges))
+                     <$> getRandomR (params ^. connectednessRatioRange)
+  let reintroEdges = take reintroEdgeCount nonMSTEdges
+      corridorGraph = Graph.insEdges reintroEdges mst
+
+  corridors <- traverse
+              ( uncurry corridorBetween
+              . over both (fromJust . Graph.lab corridorGraph)
+              ) $ Graph.edges corridorGraph
+
+  for_ (join corridors) $ \pt -> lift $ writeArray cells pt True
+
+  pure cells
+
+type Room = Box Word
+
+genRooms :: MonadRandom m => Params -> Dimensions -> m [Room]
+genRooms params dims = do
+  numRooms <- fromIntegral <$> getRandomR (params ^. numRoomsRange)
+  subRand . fmap (Stream.take numRooms . removeIntersecting []) . infinitely $ do
+    roomWidth <- getRandomR $ params ^. roomDimensionRange
+    roomHeight <- getRandomR $ params ^. roomDimensionRange
+    xPos <- getRandomR (0, dims ^. width - roomWidth)
+    yPos <- getRandomR (0, dims ^. height - roomHeight)
+    pure Box
+      { _topLeftCorner = V2 xPos yPos
+      , _dimensions = V2 roomWidth roomHeight
+      }
+  where
+    removeIntersecting seen (room :> rooms)
+      | any (boxIntersects room) seen
+      = removeIntersecting seen rooms
+      | otherwise
+      = room :> removeIntersecting (room : seen) rooms
+    streamRepeat x = x :> streamRepeat x
+    infinitely = sequence . streamRepeat
+
+delaunayRoomGraph :: [Room] -> Gr Room Double
+delaunayRoomGraph rooms =
+  Graph.insEdges edges . Graph.insNodes nodes $ Graph.empty
+  where
+    edges = map (\((n₁, room₁), (n₂, room₂)) -> (n₁, n₂, roomDist room₁ room₂))
+          . over (mapped . both) snd
+          . delaunay @Double
+          . NE.fromList
+          . map (\p@(_, room) -> (boxCenter $ fromIntegral <$> room, p))
+          $ nodes
+    nodes = zip [0..] rooms
+    roomDist = distance `on` (boxCenter . fmap fromIntegral)
+
+fillRoom :: MCells s -> Room -> CellM g s ()
+fillRoom cells room =
+  let V2 posx posy = room ^. topLeftCorner
+      V2 dimx dimy = room ^. dimensions
+  in for_ [posx .. posx + dimx] $ \x ->
+       for_ [posy .. posy + dimy] $ \y ->
+         lift $ writeArray cells (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/grfn/xanthous/src/Xanthous/Generators/LevelContents.hs b/users/grfn/xanthous/src/Xanthous/Generators/LevelContents.hs
new file mode 100644
index 000000000000..8ebcc7f4da83
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Generators/LevelContents.hs
@@ -0,0 +1,133 @@
+--------------------------------------------------------------------------------
+module Xanthous.Generators.LevelContents
+  ( chooseCharacterPosition
+  , randomItems
+  , randomCreatures
+  , randomDoors
+  , placeDownStaircase
+  , tutorialMessage
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding (any, toList)
+--------------------------------------------------------------------------------
+import           Control.Monad.Random
+import           Data.Array.IArray (amap, bounds, rangeSize, (!))
+import qualified Data.Array.IArray as Arr
+import           Data.Foldable (any, toList)
+import           Linear.V2
+--------------------------------------------------------------------------------
+import           Xanthous.Generators.Util
+import           Xanthous.Random
+import           Xanthous.Data
+                 ( positionFromV2,  Position, _Position
+                 , rotations, arrayNeighbors, Neighbors(..)
+                 , neighborPositions
+                 )
+import           Xanthous.Data.EntityMap (EntityMap, _EntityMap)
+import           Xanthous.Entities.Raws (rawsWithType, RawType)
+import qualified Xanthous.Entities.Item as Item
+import           Xanthous.Entities.Item (Item)
+import qualified Xanthous.Entities.Creature as Creature
+import           Xanthous.Entities.Creature (Creature)
+import           Xanthous.Entities.Environment
+                 (GroundMessage(..), Door(..), unlockedDoor, Staircase(..))
+import           Xanthous.Messages (message_)
+import           Xanthous.Util.Graphics (circle)
+--------------------------------------------------------------------------------
+
+chooseCharacterPosition :: MonadRandom m => Cells -> m Position
+chooseCharacterPosition = randomPosition
+
+randomItems :: MonadRandom m => Cells -> m (EntityMap Item)
+randomItems = randomEntities Item.newWithType (0.0004, 0.001)
+
+placeDownStaircase :: MonadRandom m => Cells -> m (EntityMap Staircase)
+placeDownStaircase cells = do
+  pos <- randomPosition cells
+  pure $ _EntityMap # [(pos, DownStaircase)]
+
+randomDoors :: MonadRandom m => Cells -> m (EntityMap Door)
+randomDoors cells = do
+  doorRatio <- getRandomR subsetRange
+  let numDoors = floor $ doorRatio * fromIntegral (length candidateCells)
+      doorPositions =
+        removeAdjacent . fmap 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 => Cells -> m (EntityMap Creature)
+randomCreatures = randomEntities Creature.newWithType (0.0007, 0.002)
+
+tutorialMessage :: MonadRandom m
+  => Cells
+  -> Position -- ^ CharacterPosition
+  -> m (EntityMap GroundMessage)
+tutorialMessage cells characterPosition = do
+  let distance = 2
+  pos <- fmap (fromMaybe (error "No valid positions for tutorial message?"))
+        . choose . ChooseElement
+        $ accessiblePositionsWithin distance cells characterPosition
+  msg <- message_ ["tutorial", "message1"]
+  pure $ _EntityMap # [(pos, GroundMessage msg)]
+  where
+    accessiblePositionsWithin :: Int -> Cells -> Position -> [Position]
+    accessiblePositionsWithin dist valid pos =
+      review _Position
+      <$> filter
+            (\pt -> not $ valid ! (fromIntegral <$> pt))
+            (circle (pos ^. _Position) dist)
+
+randomEntities
+  :: forall entity raw m. (MonadRandom m, RawType raw)
+  => (raw -> entity)
+  -> (Float, Float)
+  -> Cells
+  -> m (EntityMap entity)
+randomEntities newWithType sizeRange cells =
+  case fromNullable $ rawsWithType @raw of
+    Nothing -> pure mempty
+    Just raws -> do
+      let len = rangeSize $ bounds cells
+      (numEntities :: Int) <-
+        floor . (* fromIntegral len) <$> getRandomR sizeRange
+      entities <- for [0..numEntities] $ const $ do
+        pos <- randomPosition cells
+        raw <- choose raws
+        let entity = newWithType raw
+        pure (pos, entity)
+      pure $ _EntityMap # entities
+
+randomPosition :: MonadRandom m => Cells -> m Position
+randomPosition = fmap 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
diff --git a/users/grfn/xanthous/src/Xanthous/Generators/Util.hs b/users/grfn/xanthous/src/Xanthous/Generators/Util.hs
new file mode 100644
index 000000000000..88aadd5aadd9
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Generators/Util.hs
@@ -0,0 +1,220 @@
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+--------------------------------------------------------------------------------
+module Xanthous.Generators.Util
+  ( MCells
+  , Cells
+  , CellM
+  , randInitialize
+  , initializeEmpty
+  , numAliveNeighborsM
+  , numAliveNeighbors
+  , fillOuterEdgesM
+  , cloneMArray
+  , floodFill
+  , regions
+  , fillAll
+  , fillAllM
+  , fromPoints
+  , fromPointsM
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding (Foldable, toList, for_)
+--------------------------------------------------------------------------------
+import           Data.Array.ST
+import           Data.Array.Unboxed
+import           Control.Monad.ST
+import           Control.Monad.Random
+import           Data.Monoid
+import           Data.Foldable (Foldable, toList, for_)
+import qualified Data.Set as Set
+import           Data.Semigroup.Foldable
+import           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
+
+numAliveNeighborsM
+  :: forall a i m
+  . (MArray a Bool m, Ix i, Integral i)
+  => a (V2 i) Bool
+  -> V2 i
+  -> m Word
+numAliveNeighborsM cells (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 (V2 minX minY, V2 maxX maxY) (i, j)
+      | x <= minX
+        || y <= minY
+        || x >= maxX
+        || y >= maxY
+      = pure True
+      | otherwise =
+        let nx = fromIntegral $ fromIntegral x + i
+            ny = fromIntegral $ fromIntegral y + j
+        in readArray cells $ V2 nx ny
+
+numAliveNeighbors
+  :: forall a i
+  . (IArray a Bool, Ix i, Integral i)
+  => a (V2 i) Bool
+  -> V2 i
+  -> Word
+numAliveNeighbors cells (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 (V2 minX minY, V2 maxX maxY) (i, j)
+      | x <= minX
+        || y <= minY
+        || x >= maxX
+        || y >= maxY
+      = True
+      | otherwise =
+        let nx = fromIntegral $ fromIntegral x + i
+            ny = fromIntegral $ fromIntegral y + j
+        in cells ! 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/grfn/xanthous/src/Xanthous/Generators/Village.hs b/users/grfn/xanthous/src/Xanthous/Generators/Village.hs
new file mode 100644
index 000000000000..cc9c9d963f5c
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Generators/Village.hs
@@ -0,0 +1,125 @@
+module Xanthous.Generators.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.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/grfn/xanthous/src/Xanthous/Messages.hs b/users/grfn/xanthous/src/Xanthous/Messages.hs
new file mode 100644
index 000000000000..2b1b3da1e8c1
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Messages.hs
@@ -0,0 +1,107 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Messages
+  ( Message(..)
+  , resolve
+  , MessageMap(..)
+  , lookupMessage
+
+    -- * Game messages
+  , messages
+  , render
+  , lookup
+  , message
+  , message_
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude hiding (lookup)
+--------------------------------------------------------------------------------
+import           Control.Monad.Random.Class (MonadRandom)
+import           Data.Aeson (FromJSON, ToJSON, toJSON)
+import qualified Data.Aeson as JSON
+import           Data.Aeson.Generic.DerivingVia
+import           Data.FileEmbed
+import           Data.List.NonEmpty
+import           Test.QuickCheck hiding (choose)
+import           Test.QuickCheck.Arbitrary.Generic
+import           Test.QuickCheck.Instances.UnorderedContainers ()
+import           Text.Mustache
+import qualified Data.Yaml as Yaml
+--------------------------------------------------------------------------------
+import           Xanthous.Random
+import           Xanthous.Orphans ()
+--------------------------------------------------------------------------------
+
+data Message = Single Template | Choice (NonEmpty Template)
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (CoArbitrary, Function, NFData)
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ SumEnc UntaggedVal ]
+           Message
+
+instance Arbitrary Message where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
+resolve :: MonadRandom m => Message -> m Template
+resolve (Single t) = pure t
+resolve (Choice ts) = choose ts
+
+data MessageMap = Direct Message | Nested (HashMap Text MessageMap)
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (CoArbitrary, Function, NFData)
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ SumEnc UntaggedVal ]
+           MessageMap
+
+instance Arbitrary MessageMap where
+  arbitrary = frequency [ (10, Direct <$> arbitrary)
+                        , (1, Nested <$> arbitrary)
+                        ]
+
+lookupMessage :: [Text] -> MessageMap -> Maybe Message
+lookupMessage [] (Direct msg) = Just msg
+lookupMessage (k:ks) (Nested m) = lookupMessage ks =<< m ^. at k
+lookupMessage _ _ = Nothing
+
+type instance Index MessageMap = [Text]
+type instance IxValue MessageMap = Message
+instance Ixed MessageMap where
+  ix [] f (Direct msg) = Direct <$> f msg
+  ix (k:ks) f (Nested m) = case m ^. at k of
+    Just m' -> ix ks f m' <&> \m'' ->
+      Nested $ m & at k ?~ m''
+    Nothing -> pure $ Nested m
+  ix _ _ m = pure m
+
+--------------------------------------------------------------------------------
+
+rawMessages :: ByteString
+rawMessages = $(embedFile "src/Xanthous/messages.yaml")
+
+messages :: MessageMap
+messages
+  = either (error . Yaml.prettyPrintParseException) id
+  $ Yaml.decodeEither' rawMessages
+
+render :: (MonadRandom m, ToJSON params) => Message -> params -> m Text
+render msg params = do
+  tpl <- resolve msg
+  pure . toStrict . renderMustache tpl $ toJSON params
+
+lookup :: [Text] -> Message
+lookup path = fromMaybe notFound $ messages ^? ix path
+  where notFound
+          = Single
+          $ compileMustacheText "template" "Message not found"
+          ^?! _Right
+
+message :: (MonadRandom m, ToJSON params) => [Text] -> params -> m Text
+message path params = maybe notFound (`render` params) $ messages ^? ix path
+  where
+    notFound = pure "Message not found"
+
+message_ :: (MonadRandom m) => [Text] -> m Text
+message_ path = maybe notFound (`render` JSON.object []) $ messages ^? ix path
+  where
+    notFound = pure "Message not found"
diff --git a/users/grfn/xanthous/src/Xanthous/Messages/Template.hs b/users/grfn/xanthous/src/Xanthous/Messages/Template.hs
new file mode 100644
index 000000000000..5176880355f4
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/src/Xanthous/Monad.hs b/users/grfn/xanthous/src/Xanthous/Monad.hs
new file mode 100644
index 000000000000..db602de56f3a
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/src/Xanthous/Orphans.hs b/users/grfn/xanthous/src/Xanthous/Orphans.hs
new file mode 100644
index 000000000000..1fe9708edbe0
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Orphans.hs
@@ -0,0 +1,352 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE PackageImports #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+--------------------------------------------------------------------------------
+module Xanthous.Orphans
+  ( ppTemplate
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding (elements, (.=))
+--------------------------------------------------------------------------------
+import           Data.Aeson
+import           Data.Aeson.Types (typeMismatch)
+import           Data.List.NonEmpty (NonEmpty(..))
+import           Graphics.Vty.Attributes
+import           Brick.Widgets.Edit
+import           Data.Text.Zipper.Generic (GenericTextZipper)
+import           Brick.Widgets.Core (getName)
+import           System.Random.Internal (StdGen (..))
+import           System.Random.SplitMix (SMGen ())
+import           Test.QuickCheck
+import           "quickcheck-instances" Test.QuickCheck.Instances ()
+import           Text.Megaparsec (errorBundlePretty)
+import           Text.Megaparsec.Pos
+import           Text.Mustache
+import           Text.Mustache.Type ( showKey )
+import           Control.Monad.State
+import           Linear
+--------------------------------------------------------------------------------
+import           Xanthous.Util.JSON
+import           Xanthous.Util.QuickCheck
+--------------------------------------------------------------------------------
+
+instance forall s a.
+  ( Cons s s a a
+  , IsSequence s
+  , Element s ~ a
+  ) => Cons (NonNull s) (NonNull s) a a where
+  _Cons = prism hither yon
+    where
+      hither :: (a, NonNull s) -> NonNull s
+      hither (a, ns) =
+        let s = toNullable ns
+        in impureNonNull $ a <| s
+
+      yon :: NonNull s -> Either (NonNull s) (a, NonNull s)
+      yon ns = case nuncons ns of
+        (_, Nothing) -> Left ns
+        (x, Just xs) -> Right (x, xs)
+
+instance forall a. Cons (NonEmpty a) (NonEmpty a) a a where
+  _Cons = prism hither yon
+    where
+      hither :: (a, NonEmpty a) -> NonEmpty a
+      hither (a, x :| xs) = a :| (x : xs)
+
+      yon :: NonEmpty a -> Either (NonEmpty a) (a, NonEmpty a)
+      yon ns@(x :| xs) = case xs of
+        (y : ys) -> Right (x, y :| ys)
+        [] -> Left ns
+
+
+instance Arbitrary PName where
+  arbitrary = PName . pack <$> listOf1 (elements ['a'..'z'])
+
+instance Arbitrary Key where
+  arbitrary = Key <$> listOf1 arbSafeText
+    where arbSafeText = pack <$> listOf1 (elements ['a'..'z'])
+  shrink (Key []) = error "unreachable"
+  shrink k@(Key [_]) = pure k
+  shrink (Key (p:ps)) = Key . (p :) <$> shrink ps
+
+instance Arbitrary Pos where
+  arbitrary = mkPos . succ . abs <$> arbitrary
+  shrink (unPos -> 1) = []
+  shrink (unPos -> x) = mkPos <$> [x..1]
+
+instance Arbitrary Node where
+  arbitrary = sized node
+    where
+      node n | n > 0 = oneof $ leaves ++ branches (n `div` 2)
+      node _ = oneof leaves
+      branches n =
+        [ Section <$> arbitrary <*> subnodes n
+        , InvertedSection <$> arbitrary <*> subnodes n
+        ]
+      subnodes = fmap concatTextBlocks . listOf . node
+      leaves =
+        [ TextBlock . pack <$> listOf1 (elements ['a'..'z'])
+        , EscapedVar <$> arbitrary
+        , UnescapedVar <$> arbitrary
+        -- TODO fix pretty-printing of mustache partials
+        -- , Partial <$> arbitrary <*> arbitrary
+        ]
+  shrink = genericShrink
+
+concatTextBlocks :: [Node] -> [Node]
+concatTextBlocks [] = []
+concatTextBlocks [x] = [x]
+concatTextBlocks (TextBlock txt₁ : TextBlock txt₂ : xs)
+  = concatTextBlocks $ TextBlock (txt₁ <> txt₂) : concatTextBlocks xs
+concatTextBlocks (x : xs) = x : concatTextBlocks xs
+
+instance Arbitrary Template where
+  arbitrary = do
+    template <- concatTextBlocks <$> arbitrary
+    -- templateName <- arbitrary
+    -- rest <- arbitrary
+    let templateName = "template"
+        rest = mempty
+    pure $ Template
+      { templateActual = templateName
+      , templateCache = rest & at templateName ?~ template
+      }
+  shrink (Template actual cache) =
+    let Just tpl = cache ^. at actual
+    in do
+      cache' <- shrink cache
+      tpl' <- shrink tpl
+      actual' <- shrink actual
+      pure $ Template
+        { templateActual = actual'
+        , templateCache = cache' & at actual' ?~ tpl'
+        }
+
+instance CoArbitrary Template where
+  coarbitrary = coarbitrary . ppTemplate
+
+instance Function Template where
+  function = functionMap ppTemplate parseTemplatePartial
+    where
+      parseTemplatePartial txt
+        = compileMustacheText "template" txt ^?! _Right
+
+ppNode :: Map PName [Node] -> Node -> Text
+ppNode _ (TextBlock txt) = txt
+ppNode _ (EscapedVar k) = "{{" <> showKey k <> "}}"
+ppNode ctx (Section k body) =
+  let sk = showKey k
+  in "{{#" <> sk <> "}}" <> foldMap (ppNode ctx) body <> "{{/" <> sk <> "}}"
+ppNode _ (UnescapedVar k) = "{{{" <> showKey k <> "}}}"
+ppNode ctx (InvertedSection k body) =
+  let sk = showKey k
+  in "{{^" <> sk <> "}}" <> foldMap (ppNode ctx) body <> "{{/" <> sk <> "}}"
+ppNode _ (Partial n _) = "{{> " <> unPName n <> "}}"
+
+ppTemplate :: Template -> Text
+ppTemplate (Template actual cache) =
+  case cache ^. at actual of
+    Nothing -> error "Template not found?"
+    Just nodes -> foldMap (ppNode cache) nodes
+
+instance ToJSON Template where
+  toJSON = String . ppTemplate
+
+instance FromJSON Template where
+  parseJSON
+    = withText "Template"
+    $ either (fail . errorBundlePretty) pure
+    . compileMustacheText "template"
+
+deriving anyclass instance NFData Node
+deriving anyclass instance NFData Template
+
+instance FromJSON Color where
+  parseJSON (String "black")         = pure black
+  parseJSON (String "red")           = pure red
+  parseJSON (String "green")         = pure green
+  parseJSON (String "yellow")        = pure yellow
+  parseJSON (String "blue")          = pure blue
+  parseJSON (String "magenta")       = pure magenta
+  parseJSON (String "cyan")          = pure cyan
+  parseJSON (String "white")         = pure white
+  parseJSON (String "brightBlack")   = pure brightBlack
+  parseJSON (String "brightRed")     = pure brightRed
+  parseJSON (String "brightGreen")   = pure brightGreen
+  parseJSON (String "brightYellow")  = pure brightYellow
+  parseJSON (String "brightBlue")    = pure brightBlue
+  parseJSON (String "brightMagenta") = pure brightMagenta
+  parseJSON (String "brightCyan")    = pure brightCyan
+  parseJSON (String "brightWhite")   = pure brightWhite
+  parseJSON n@(Number _)             = Color240 <$> parseJSON n
+  parseJSON x                        = typeMismatch "Color" x
+
+instance ToJSON Color where
+  toJSON color
+    | color == black         = "black"
+    | color == red           = "red"
+    | color == green         = "green"
+    | color == yellow        = "yellow"
+    | color == blue          = "blue"
+    | color == magenta       = "magenta"
+    | color == cyan          = "cyan"
+    | color == white         = "white"
+    | color == brightBlack   = "brightBlack"
+    | color == brightRed     = "brightRed"
+    | color == brightGreen   = "brightGreen"
+    | color == brightYellow  = "brightYellow"
+    | color == brightBlue    = "brightBlue"
+    | color == brightMagenta = "brightMagenta"
+    | color == brightCyan    = "brightCyan"
+    | color == brightWhite   = "brightWhite"
+    | Color240 num <- color  = toJSON num
+    | otherwise             = error $ "unimplemented: " <> show color
+
+instance (Eq a, Show a, Read a, FromJSON a) => FromJSON (MaybeDefault a) where
+  parseJSON Null                   = pure Default
+  parseJSON (String "keepCurrent") = pure KeepCurrent
+  parseJSON x                      = SetTo <$> parseJSON x
+
+instance ToJSON a => ToJSON (MaybeDefault a) where
+  toJSON Default     = Null
+  toJSON KeepCurrent = String "keepCurrent"
+  toJSON (SetTo x)   = toJSON x
+
+--------------------------------------------------------------------------------
+
+instance Arbitrary Color where
+  arbitrary = oneof [ Color240 <$> choose (0, 239)
+                    , ISOColor <$> choose (0, 15)
+                    ]
+
+deriving anyclass instance CoArbitrary Color
+deriving anyclass instance Function Color
+
+instance (Eq a, Show a, Read a, Arbitrary a) => Arbitrary (MaybeDefault a) where
+  arbitrary = oneof [ pure Default
+                    , pure KeepCurrent
+                    , SetTo <$> arbitrary
+                    ]
+
+instance CoArbitrary a => CoArbitrary (MaybeDefault a) where
+  coarbitrary Default = variant @Int 1
+  coarbitrary KeepCurrent = variant @Int 2
+  coarbitrary (SetTo x) = variant @Int 3 . coarbitrary x
+
+instance (Eq a, Show a, Read a, Function a) => Function (MaybeDefault a) where
+  function = functionShow
+
+instance Arbitrary Attr where
+  arbitrary = do
+    attrStyle <- arbitrary
+    attrForeColor <- arbitrary
+    attrBackColor <- arbitrary
+    attrURL <- arbitrary
+    pure Attr {..}
+
+deriving anyclass instance CoArbitrary Attr
+deriving anyclass instance Function Attr
+
+instance ToJSON Attr where
+  toJSON Attr{..} = object
+    [ "style" .= maybeDefaultToJSONWith styleToJSON attrStyle
+    , "foreground" .= attrForeColor
+    , "background" .= attrBackColor
+    , "url" .= attrURL
+    ]
+    where
+      maybeDefaultToJSONWith _ Default = Null
+      maybeDefaultToJSONWith _ KeepCurrent = String "keepCurrent"
+      maybeDefaultToJSONWith tj (SetTo x) = tj x
+      styleToJSON style
+        | style == standout     = "standout"
+        | style == underline    = "underline"
+        | style == reverseVideo = "reverseVideo"
+        | style == blink        = "blink"
+        | style == dim          = "dim"
+        | style == bold         = "bold"
+        | style == italic       = "italic"
+        | otherwise            = toJSON style
+
+instance FromJSON Attr where
+  parseJSON = withObject "Attr" $ \obj -> do
+    attrStyle <- parseStyle =<< obj .:? "style" .!= Default
+    attrForeColor <- obj .:? "foreground" .!= Default
+    attrBackColor <- obj .:? "background" .!= Default
+    attrURL <- obj .:? "url" .!= Default
+    pure Attr{..}
+
+    where
+      parseStyle (SetTo (String "standout"))     = pure (SetTo standout)
+      parseStyle (SetTo (String "underline"))    = pure (SetTo underline)
+      parseStyle (SetTo (String "reverseVideo")) = pure (SetTo reverseVideo)
+      parseStyle (SetTo (String "blink"))        = pure (SetTo blink)
+      parseStyle (SetTo (String "dim"))          = pure (SetTo dim)
+      parseStyle (SetTo (String "bold"))         = pure (SetTo bold)
+      parseStyle (SetTo (String "italic"))       = pure (SetTo italic)
+      parseStyle (SetTo n@(Number _))            = SetTo <$> parseJSON n
+      parseStyle (SetTo v)                       = typeMismatch "Style" v
+      parseStyle Default                         = pure Default
+      parseStyle KeepCurrent                     = pure KeepCurrent
+
+deriving stock instance Ord Color
+deriving stock instance Ord a => Ord (MaybeDefault a)
+deriving stock instance Ord Attr
+
+--------------------------------------------------------------------------------
+
+instance NFData a => NFData (NonNull a) where
+  rnf xs = xs `seq` toNullable xs `deepseq` ()
+
+instance forall t name. (NFData t, Monoid t, NFData name)
+                 => NFData (Editor t name) where
+  rnf ed = getName @_ @name ed `deepseq` getEditContents ed `deepseq` ()
+
+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)
diff --git a/users/grfn/xanthous/src/Xanthous/Prelude.hs b/users/grfn/xanthous/src/Xanthous/Prelude.hs
new file mode 100644
index 000000000000..4d79b026f14a
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Prelude.hs
@@ -0,0 +1,47 @@
+--------------------------------------------------------------------------------
+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
+  )
+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/grfn/xanthous/src/Xanthous/Random.hs b/users/grfn/xanthous/src/Xanthous/Random.hs
new file mode 100644
index 000000000000..6d34109df7f8
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Random.hs
@@ -0,0 +1,118 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+--------------------------------------------------------------------------------
+module Xanthous.Random
+  ( Choose(..)
+  , ChooseElement(..)
+  , Weighted(..)
+  , evenlyWeighted
+  , weightedBy
+  , subRand
+  , chance
+  , chooseSubset
+  ) 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
+--------------------------------------------------------------------------------
+
+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)
+
+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
+
+--------------------------------------------------------------------------------
+
+bools :: NonEmpty Bool
+bools = True :| [False]
diff --git a/users/grfn/xanthous/src/Xanthous/Util.hs b/users/grfn/xanthous/src/Xanthous/Util.hs
new file mode 100644
index 000000000000..524ad4819dac
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Util.hs
@@ -0,0 +1,252 @@
+{-# LANGUAGE BangPatterns          #-}
+{-# LANGUAGE AllowAmbiguousTypes   #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+--------------------------------------------------------------------------------
+module Xanthous.Util
+  ( EqEqProp(..)
+  , EqProp(..)
+  , foldlMapM
+  , foldlMapM'
+  , between
+
+  , appendVia
+
+    -- * Foldable
+    -- ** Uniqueness
+    -- *** Predicates on uniqueness
+  , isUniqueOf
+  , isUnique
+    -- *** Removing all duplicate elements in n * log n time
+  , uniqueOf
+  , unique
+    -- *** Removing sequentially duplicate elements in linear time
+  , uniqOf
+  , uniq
+    -- ** Bag sequence algorithms
+  , takeWhileInclusive
+  , smallestNotIn
+  , removeVectorIndex
+  , maximum1
+  , minimum1
+
+    -- * Combinators
+  , times, times_
+
+    -- * Type-level programming utils
+  , KnownBool(..)
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding (foldr)
+--------------------------------------------------------------------------------
+import           Test.QuickCheck.Checkers
+import           Data.Foldable (foldr)
+import           Data.Monoid
+import           Data.Proxy
+import qualified Data.Vector as V
+import           Data.Semigroup (Max(..), Min(..))
+import           Data.Semigroup.Foldable
+--------------------------------------------------------------------------------
+
+newtype EqEqProp a = EqEqProp a
+  deriving newtype Eq
+
+instance Eq a => EqProp (EqEqProp a) where
+  (=-=) = eq
+
+foldlMapM :: forall g b a m. (Foldable g, Monoid b, Applicative m) => (a -> m b) -> g a -> m b
+foldlMapM f = foldr f' (pure mempty)
+  where
+    f' :: a -> m b -> m b
+    f' x = liftA2 mappend (f x)
+
+-- Strict in the monoidal accumulator. For monads strict
+-- in the left argument of bind, this will run in constant
+-- space.
+foldlMapM' :: forall g b a m. (Foldable g, Monoid b, Monad m) => (a -> m b) -> g a -> m b
+foldlMapM' f xs = foldr f' pure xs mempty
+  where
+  f' :: a -> (b -> m b) -> b -> m b
+  f' x k bl = do
+    br <- f x
+    let !b = mappend bl br
+    k b
+
+between
+  :: Ord a
+  => a -- ^ lower bound
+  -> a -- ^ upper bound
+  -> a -- ^ scrutinee
+  -> Bool
+between lower upper x = x >= lower && x <= upper
+
+-- |
+-- >>> appendVia Sum 1 2
+-- 3
+appendVia :: (Rewrapping s t, Semigroup s) => (Unwrapped s -> s) -> Unwrapped s -> Unwrapped s -> Unwrapped s
+appendVia wrap x y = op wrap $ wrap x <> wrap y
+
+--------------------------------------------------------------------------------
+
+-- | Returns True if the targets of the given 'Fold' are unique per the 'Ord' instance for @a@
+--
+-- >>> isUniqueOf (folded . _1) ([(1, 2), (2, 2), (3, 2)] :: [(Int, Int)])
+-- True
+--
+-- >>> isUniqueOf (folded . _2) ([(1, 2), (2, 2), (3, 2)] :: [(Int, Int)])
+-- False
+--
+-- @
+-- 'isUniqueOf' :: Ord a => 'Getter' s a     -> s -> 'Bool'
+-- 'isUniqueOf' :: Ord a => 'Fold' s a       -> s -> 'Bool'
+-- 'isUniqueOf' :: Ord a => 'Lens'' s a      -> s -> 'Bool'
+-- 'isUniqueOf' :: Ord a => 'Iso'' s a       -> s -> 'Bool'
+-- 'isUniqueOf' :: Ord a => 'Traversal'' s a -> s -> 'Bool'
+-- 'isUniqueOf' :: Ord a => 'Prism'' s a     -> s -> 'Bool'
+-- @
+isUniqueOf :: Ord a => Getting (Endo (Set a, Bool)) s a -> s -> Bool
+isUniqueOf aFold = orOf _2 . foldrOf aFold rejectUnique (mempty, True)
+ where
+  rejectUnique x (seen, acc)
+    | seen ^. contains x = (seen, False)
+    | otherwise          = (seen & contains x .~ True, acc)
+
+-- | Returns true if the given 'Foldable' container contains only unique
+-- elements, as determined by the 'Ord' instance for @a@
+--
+-- >>> isUnique ([3, 1, 2] :: [Int])
+-- True
+--
+-- >>> isUnique ([1, 1, 2, 2, 3, 1] :: [Int])
+-- False
+isUnique :: (Foldable f, Ord a) => f a -> Bool
+isUnique = isUniqueOf folded
+
+
+-- | O(n * log n). Returns a monoidal, 'Cons'able container (a list, a Set,
+-- etc.) consisting of the unique (per the 'Ord' instance for @a@) targets of
+-- the given 'Fold'
+--
+-- >>> uniqueOf (folded . _2) ([(1, 2), (2, 2), (3, 2), (4, 3)] :: [(Int, Int)]) :: [Int]
+-- [2,3]
+--
+-- @
+-- 'uniqueOf' :: Ord a => 'Getter' s a     -> s -> [a]
+-- 'uniqueOf' :: Ord a => 'Fold' s a       -> s -> [a]
+-- 'uniqueOf' :: Ord a => 'Lens'' s a      -> s -> [a]
+-- 'uniqueOf' :: Ord a => 'Iso'' s a       -> s -> [a]
+-- 'uniqueOf' :: Ord a => 'Traversal'' s a -> s -> [a]
+-- 'uniqueOf' :: Ord a => 'Prism'' s a     -> s -> [a]
+-- @
+uniqueOf
+  :: (Monoid c, Ord w, Cons c c w w) => Getting (Endo (Set w, c)) a w -> a -> c
+uniqueOf aFold = snd . foldrOf aFold rejectUnique (mempty, mempty)
+ where
+  rejectUnique x (seen, acc)
+    | seen ^. contains x = (seen, acc)
+    | otherwise          = (seen & contains x .~ True, cons x acc)
+
+-- | Returns a monoidal, 'Cons'able container (a list, a Set, etc.) consisting
+-- of the unique (per the 'Ord' instance for @a@) contents of the given
+-- 'Foldable' container
+--
+-- >>> unique [1, 1, 2, 2, 3, 1] :: [Int]
+-- [2,3,1]
+
+-- >>> unique [1, 1, 2, 2, 3, 1] :: Set Int
+-- fromList [3,2,1]
+unique :: (Foldable f, Cons c c a a, Ord a, Monoid c) => f a -> c
+unique = uniqueOf folded
+
+--------------------------------------------------------------------------------
+
+-- | O(n). Returns a monoidal, 'Cons'able container (a list, a Vector, etc.)
+-- consisting of the targets of the given 'Fold' with sequential duplicate
+-- elements removed
+--
+-- This function (sorry for the confusing name) differs from 'uniqueOf' in that
+-- it only compares /sequentially/ duplicate elements (and thus operates in
+-- linear time).
+-- cf 'Data.Vector.uniq' and POSIX @uniq@ for the name
+--
+-- >>> uniqOf (folded . _2) ([(1, 2), (2, 2), (3, 1), (4, 2)] :: [(Int, Int)]) :: [Int]
+-- [2,1,2]
+--
+-- @
+-- 'uniqOf' :: Eq a => 'Getter' s a     -> s -> [a]
+-- 'uniqOf' :: Eq a => 'Fold' s a       -> s -> [a]
+-- 'uniqOf' :: Eq a => 'Lens'' s a      -> s -> [a]
+-- 'uniqOf' :: Eq a => 'Iso'' s a       -> s -> [a]
+-- 'uniqOf' :: Eq a => 'Traversal'' s a -> s -> [a]
+-- 'uniqOf' :: Eq a => 'Prism'' s a     -> s -> [a]
+-- @
+uniqOf :: (Monoid c, Cons c c w w, Eq w) => Getting (Endo (Maybe w, c)) a w -> a -> c
+uniqOf aFold = snd . foldrOf aFold rejectSeen (Nothing, mempty)
+  where
+    rejectSeen x (Nothing, acc) = (Just x, x <| acc)
+    rejectSeen x tup@(Just a, acc)
+      | x == a     = tup
+      | otherwise = (Just x, x <| acc)
+
+-- | O(n). Returns a monoidal, 'Cons'able container (a list, a Vector, etc.)
+-- consisting of the targets of the given 'Foldable' container with sequential
+-- duplicate elements removed
+--
+-- This function (sorry for the confusing name) differs from 'unique' in that
+-- it only compares /sequentially/ unique elements (and thus operates in linear
+-- time).
+-- cf 'Data.Vector.uniq' and POSIX @uniq@ for the name
+--
+-- >>> uniq [1, 1, 1, 2, 2, 2, 3, 3, 1] :: [Int]
+-- [1,2,3,1]
+--
+-- >>> uniq [1, 1, 1, 2, 2, 2, 3, 3, 1] :: Vector Int
+-- [1,2,3,1]
+--
+uniq :: (Foldable f, Eq a, Cons c c a a, Monoid c) => f a -> c
+uniq = uniqOf folded
+
+-- | Like 'takeWhile', but inclusive
+takeWhileInclusive :: (a -> Bool) -> [a] -> [a]
+takeWhileInclusive _ [] = []
+takeWhileInclusive p (x:xs) = x : if p x then takeWhileInclusive p xs else []
+
+-- | Returns the smallest value not in a list
+smallestNotIn :: (Ord a, Bounded a, Enum a) => [a] -> a
+smallestNotIn xs = case uniq $ sort xs of
+  [] -> minBound
+  xs'@(x : _)
+    | x > minBound -> minBound
+    | otherwise
+    -> snd . headEx . filter (uncurry (/=)) $ zip (xs' ++ [minBound]) [minBound..]
+
+-- | Remove the element at the given index, if any, from the given vector
+removeVectorIndex :: Int -> Vector a -> Vector a
+removeVectorIndex idx vect =
+  let (before, after) = V.splitAt idx vect
+  in before <> fromMaybe Empty (tailMay after)
+
+maximum1 :: (Ord a, Foldable1 f) => f a -> a
+maximum1 = getMax . foldMap1 Max
+
+minimum1 :: (Ord a, Foldable1 f) => f a -> a
+minimum1 = getMin . foldMap1 Min
+
+times :: (Applicative f, Num n, Enum n) => n -> (n -> f b) -> f [b]
+times n f = traverse f [1..n]
+
+times_ :: (Applicative f, Num n, Enum n) => n -> f a -> f [a]
+times_ n fa = times n (const fa)
+
+--------------------------------------------------------------------------------
+
+-- | This class gives a boolean associated with a type-level bool, a'la
+-- 'KnownSymbol', 'KnownNat' etc.
+class KnownBool (bool :: Bool) where
+  boolVal' :: forall proxy. proxy bool -> Bool
+  boolVal' _ = boolVal @bool
+
+  boolVal :: Bool
+  boolVal = boolVal' $ Proxy @bool
+
+instance KnownBool 'True where boolVal = True
+instance KnownBool 'False where boolVal = False
diff --git a/users/grfn/xanthous/src/Xanthous/Util/Comonad.hs b/users/grfn/xanthous/src/Xanthous/Util/Comonad.hs
new file mode 100644
index 000000000000..9e158cc8e2d4
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/src/Xanthous/Util/Graph.hs b/users/grfn/xanthous/src/Xanthous/Util/Graph.hs
new file mode 100644
index 000000000000..8e5c04f4bfa9
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/src/Xanthous/Util/Graphics.hs b/users/grfn/xanthous/src/Xanthous/Util/Graphics.hs
new file mode 100644
index 000000000000..6ba63a2d8a3f
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Util/Graphics.hs
@@ -0,0 +1,178 @@
+{-# 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/grfn/xanthous/src/Xanthous/Util/Inflection.hs b/users/grfn/xanthous/src/Xanthous/Util/Inflection.hs
new file mode 100644
index 000000000000..724f2339dd21
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/src/Xanthous/Util/JSON.hs b/users/grfn/xanthous/src/Xanthous/Util/JSON.hs
new file mode 100644
index 000000000000..91d1328e4a10
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/src/Xanthous/Util/Optparse.hs b/users/grfn/xanthous/src/Xanthous/Util/Optparse.hs
new file mode 100644
index 000000000000..dfa65372351d
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/src/Xanthous/Util/QuickCheck.hs b/users/grfn/xanthous/src/Xanthous/Util/QuickCheck.hs
new file mode 100644
index 000000000000..be12bc294513
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Util/QuickCheck.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE UndecidableInstances #-}
+module Xanthous.Util.QuickCheck
+  ( functionShow
+  , FunctionShow(..)
+  , functionJSON
+  , FunctionJSON(..)
+  , genericArbitrary
+  , GenericArbitrary(..)
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+import Test.QuickCheck
+import Test.QuickCheck.Function
+import Test.QuickCheck.Instances.ByteString ()
+import Test.QuickCheck.Arbitrary.Generic
+import Data.Aeson
+import GHC.Generics (Rep)
+--------------------------------------------------------------------------------
+
+newtype FunctionShow a = FunctionShow a
+  deriving newtype (Show, Read)
+
+instance (Show a, Read a) => Function (FunctionShow a) where
+  function = functionShow
+
+functionJSON :: (ToJSON a, FromJSON a) => (a -> c) -> a :-> c
+functionJSON = functionMap encode (headEx . decode)
+
+newtype FunctionJSON a = FunctionJSON a
+  deriving newtype (ToJSON, FromJSON)
+
+instance (ToJSON a, FromJSON a) => Function (FunctionJSON a) where
+  function = functionJSON
+
+--------------------------------------------------------------------------------
+
+newtype GenericArbitrary a = GenericArbitrary a
+  deriving newtype Generic
+
+instance (Generic a, GArbitrary rep, Rep a ~ rep)
+  => Arbitrary (GenericArbitrary a) where
+  arbitrary = genericArbitrary
diff --git a/users/grfn/xanthous/src/Xanthous/messages.yaml b/users/grfn/xanthous/src/Xanthous/messages.yaml
new file mode 100644
index 000000000000..c1835ef2327b
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/messages.yaml
@@ -0,0 +1,120 @@
+welcome: Welcome to Xanthous, {{characterName}}! It's dangerous out there, why not stay inside? Use hjklybnu to move.
+dead:
+  - You have died...
+  - You die...
+  - You perish...
+  - You have perished...
+
+generic:
+  continue: Press enter to continue...
+
+save:
+  location: "Enter filename to save to: "
+  overwrite: "A file named {{filename}} already exists. Would you like to overwrite it? "
+
+quit:
+  confirm: Really quit without saving?
+
+entities:
+  description: You see here {{entityDescriptions}}
+
+pickUp:
+  menu: What would you like to pick up?
+  pickUp: You pick up the {{item.itemType.name}}
+  nothingToPickUp: "There's nothing here to pick up"
+
+cant:
+  goUp:
+    - You can't go up here
+    - There's nothing here that would let you go up
+  goDown:
+    - You can't go down here
+    - There's nothing here that would let you go down
+
+open:
+  prompt: Direction to open (hjklybnu.)?
+  success: "You open the door."
+  locked: "That door is locked"
+  nothingToOpen: "There's nothing to open there."
+  alreadyOpen: "That door is already open."
+
+close:
+  prompt: Direction to close (hjklybnu.)?
+  success:
+    - You close the door.
+    - You shut the door.
+  nothingToClose: "There's nothing to close there."
+  alreadyClosed: "That door is already closed."
+  blocked: "The {{entityDescriptions}} {{blockOrBlocks}} the door!"
+
+look:
+  prompt: Select a position on the map to describe (use Enter to confirm)
+  nothing: There's nothing there
+
+character:
+  namePrompt: "What's your name? "
+
+combat:
+  nothingToAttack: There's nothing to attack there.
+  menu: Which creature would you like to attack?
+  fistSelfDamage:
+    - You hit so hard with your fists you hurt yourself!
+    - The punch leaves your knuckles bloody!
+  hit:
+    fists:
+      - You punch the {{creature.creatureType.name}} with your bare fists! It hurts. A lot.
+      - You strike the {{creature.creatureType.name}} with your bare fists! It leaves a bit of a bruise on your knuckles.
+    generic:
+      - You hit the {{creature.creatureType.name}}.
+      - You attack the {{creature.creatureType.name}}.
+  creatureAttack:
+    - The {{creature.creatureType.name}} hits you!
+    - The {{creature.creatureType.name}} attacks you!
+  killed:
+    - You kill the {{creature.creatureType.name}}!
+    - You've killed the {{creature.creatureType.name}}!
+
+debug:
+  toggleRevealAll: revealAll now set to {{revealAll}}
+
+eat:
+  noFood:
+    - You have nothing edible.
+    - You don't have any food.
+    - You don't have anything to eat.
+    - You search your pockets for something edible, and come up short.
+  menuPrompt: What would you like to eat?
+  eat: You eat the {{item.itemType.name}}.
+
+read:
+  prompt: Direction to read (hjklybnu.)?
+  nothing: "There's nothing there to read"
+  result: "\"{{message}}\""
+
+wield:
+  nothing:
+    - You aren't carrying anything you can wield
+    - You can't wield anything in your backpack
+    - You can't wield anything currently in your backpack
+  menu: What would you like to wield?
+  # TODO: use actual hands
+  wielded : You wield the {{wieldedItem.itemType.name}} in your right hand.
+
+drop:
+  nothing: You aren't carrying anything
+  menu: What would you like to drop?
+  # TODO: use actual hands
+  dropped:
+    - You drop the {{item.itemType.name}}.
+    - You drop the {{item.itemType.name}} on the ground.
+    - You put the {{item.itemType.name}} on the ground.
+    - You take the {{item.itemType.name}} out of your backpack and put it on the ground.
+    - You take the {{item.itemType.name}} out of your backpack and drop it on the ground.
+
+autoMove:
+  enemyInSight:
+    - There's a {{firstEntity.creatureType.name}} nearby!
+###
+
+tutorial:
+  message1: The caves are dark and full of nightmarish creatures - and you are likely to perish without food. Seek out sustenance! You can pick items up with ,.
diff --git a/users/grfn/xanthous/test/Spec.hs b/users/grfn/xanthous/test/Spec.hs
new file mode 100644
index 000000000000..f15c393ac917
--- /dev/null
+++ b/users/grfn/xanthous/test/Spec.hs
@@ -0,0 +1,47 @@
+--------------------------------------------------------------------------------
+import           Test.Prelude
+--------------------------------------------------------------------------------
+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.NestedMapSpec
+import qualified Xanthous.DataSpec
+import qualified Xanthous.Entities.RawsSpec
+import qualified Xanthous.GameSpec
+import qualified Xanthous.Generators.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 = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous"
+  [ Xanthous.Data.EntitiesSpec.test
+  , Xanthous.Data.EntityMap.GraphicsSpec.test
+  , Xanthous.Data.EntityMapSpec.test
+  , Xanthous.Data.LevelsSpec.test
+  , Xanthous.Data.NestedMapSpec.test
+  , Xanthous.DataSpec.test
+  , Xanthous.Entities.RawsSpec.test
+  , Xanthous.GameSpec.test
+  , Xanthous.Generators.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/grfn/xanthous/test/Test/Prelude.hs b/users/grfn/xanthous/test/Test/Prelude.hs
new file mode 100644
index 000000000000..c423796184f7
--- /dev/null
+++ b/users/grfn/xanthous/test/Test/Prelude.hs
@@ -0,0 +1,19 @@
+module Test.Prelude
+  ( module Xanthous.Prelude
+  , module Test.Tasty
+  , module Test.Tasty.HUnit
+  , module Test.Tasty.QuickCheck
+  , module Test.QuickCheck.Classes
+  , testBatch
+  ) where
+
+import Xanthous.Prelude hiding (assert, elements)
+import Test.Tasty
+import Test.Tasty.QuickCheck
+import Test.Tasty.HUnit
+import Test.QuickCheck.Classes
+import Test.QuickCheck.Checkers (TestBatch)
+import Test.QuickCheck.Instances.ByteString ()
+
+testBatch :: TestBatch -> TestTree
+testBatch (name, tests) = testGroup name $ uncurry testProperty <$> tests
diff --git a/users/grfn/xanthous/test/Xanthous/Data/EntitiesSpec.hs b/users/grfn/xanthous/test/Xanthous/Data/EntitiesSpec.hs
new file mode 100644
index 000000000000..e403503743c0
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/test/Xanthous/Data/EntityCharSpec.hs b/users/grfn/xanthous/test/Xanthous/Data/EntityCharSpec.hs
new file mode 100644
index 000000000000..9e8024c9d223
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/test/Xanthous/Data/EntityMap/GraphicsSpec.hs b/users/grfn/xanthous/test/Xanthous/Data/EntityMap/GraphicsSpec.hs
new file mode 100644
index 000000000000..fd37548ce864
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/test/Xanthous/Data/EntityMapSpec.hs b/users/grfn/xanthous/test/Xanthous/Data/EntityMapSpec.hs
new file mode 100644
index 000000000000..7c5cad019616
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/test/Xanthous/Data/LevelsSpec.hs b/users/grfn/xanthous/test/Xanthous/Data/LevelsSpec.hs
new file mode 100644
index 000000000000..4e46946a93b0
--- /dev/null
+++ b/users/grfn/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 (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 (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 (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/grfn/xanthous/test/Xanthous/Data/NestedMapSpec.hs b/users/grfn/xanthous/test/Xanthous/Data/NestedMapSpec.hs
new file mode 100644
index 000000000000..acf7a67268f4
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/test/Xanthous/DataSpec.hs b/users/grfn/xanthous/test/Xanthous/DataSpec.hs
new file mode 100644
index 000000000000..91dc6cea1ba5
--- /dev/null
+++ b/users/grfn/xanthous/test/Xanthous/DataSpec.hs
@@ -0,0 +1,98 @@
+--------------------------------------------------------------------------------
+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
+      ]
+    ]
+  ]
diff --git a/users/grfn/xanthous/test/Xanthous/Entities/RawsSpec.hs b/users/grfn/xanthous/test/Xanthous/Entities/RawsSpec.hs
new file mode 100644
index 000000000000..2e6f35457fc7
--- /dev/null
+++ b/users/grfn/xanthous/test/Xanthous/Entities/RawsSpec.hs
@@ -0,0 +1,16 @@
+-- |
+
+module Xanthous.Entities.RawsSpec (main, test) where
+
+import Test.Prelude
+import Xanthous.Entities.Raws
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Entities.Raws"
+  [ testGroup "raws"
+    [ testCase "are all valid" $ raws `deepseq` pure ()
+    ]
+  ]
diff --git a/users/grfn/xanthous/test/Xanthous/GameSpec.hs b/users/grfn/xanthous/test/Xanthous/GameSpec.hs
new file mode 100644
index 000000000000..2fa8527d0e59
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/test/Xanthous/Generators/UtilSpec.hs b/users/grfn/xanthous/test/Xanthous/Generators/UtilSpec.hs
new file mode 100644
index 000000000000..cdfadc06f505
--- /dev/null
+++ b/users/grfn/xanthous/test/Xanthous/Generators/UtilSpec.hs
@@ -0,0 +1,84 @@
+{-# LANGUAGE PackageImports #-}
+--------------------------------------------------------------------------------
+module Xanthous.Generators.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)
+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.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
+    ]
+  , 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
+    ]
+  , 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/grfn/xanthous/test/Xanthous/MessageSpec.hs b/users/grfn/xanthous/test/Xanthous/MessageSpec.hs
new file mode 100644
index 000000000000..b681e537efe6
--- /dev/null
+++ b/users/grfn/xanthous/test/Xanthous/MessageSpec.hs
@@ -0,0 +1,53 @@
+{-# 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 ()
+    ]
+  ]
diff --git a/users/grfn/xanthous/test/Xanthous/Messages/TemplateSpec.hs b/users/grfn/xanthous/test/Xanthous/Messages/TemplateSpec.hs
new file mode 100644
index 000000000000..2a3873c3b016
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/test/Xanthous/OrphansSpec.hs b/users/grfn/xanthous/test/Xanthous/OrphansSpec.hs
new file mode 100644
index 000000000000..3740945877ef
--- /dev/null
+++ b/users/grfn/xanthous/test/Xanthous/OrphansSpec.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE BlockArguments #-}
+--------------------------------------------------------------------------------
+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           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"
+    [ testProperty "JSON round trip" $ \(attr :: Attr) ->
+        JSON.decode (JSON.encode attr) === Just attr
+    ]
+  ]
diff --git a/users/grfn/xanthous/test/Xanthous/RandomSpec.hs b/users/grfn/xanthous/test/Xanthous/RandomSpec.hs
new file mode 100644
index 000000000000..187336f08650
--- /dev/null
+++ b/users/grfn/xanthous/test/Xanthous/RandomSpec.hs
@@ -0,0 +1,25 @@
+--------------------------------------------------------------------------------
+module Xanthous.RandomSpec (main, test) where
+--------------------------------------------------------------------------------
+import Test.Prelude
+--------------------------------------------------------------------------------
+import Control.Monad.Random
+--------------------------------------------------------------------------------
+import Xanthous.Random
+--------------------------------------------------------------------------------
+
+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
+
+    ]
+  ]
+  where
+    randomTest prop = evalRandT prop . mkStdGen =<< arbitrary
diff --git a/users/grfn/xanthous/test/Xanthous/Util/GraphSpec.hs b/users/grfn/xanthous/test/Xanthous/Util/GraphSpec.hs
new file mode 100644
index 000000000000..35ff090b28b9
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/test/Xanthous/Util/GraphicsSpec.hs b/users/grfn/xanthous/test/Xanthous/Util/GraphicsSpec.hs
new file mode 100644
index 000000000000..61e589280362
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/test/Xanthous/Util/InflectionSpec.hs b/users/grfn/xanthous/test/Xanthous/Util/InflectionSpec.hs
new file mode 100644
index 000000000000..fad841043152
--- /dev/null
+++ b/users/grfn/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/grfn/xanthous/test/Xanthous/UtilSpec.hs b/users/grfn/xanthous/test/Xanthous/UtilSpec.hs
new file mode 100644
index 000000000000..8538ea5098ba
--- /dev/null
+++ b/users/grfn/xanthous/test/Xanthous/UtilSpec.hs
@@ -0,0 +1,28 @@
+module Xanthous.UtilSpec (main, test) where
+
+import Test.Prelude
+import Xanthous.Util
+
+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
+    ]
+  ]
diff --git a/users/grfn/xanthous/xanthous.cabal b/users/grfn/xanthous/xanthous.cabal
new file mode 100644
index 000000000000..9648933b768b
--- /dev/null
+++ b/users/grfn/xanthous/xanthous.cabal
@@ -0,0 +1,563 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.34.4.
+--
+-- see: https://github.com/sol/hpack
+--
+-- hash: b46f24dcf24decf8e16be6f62943648aaafc9272d923945f97d5c26a370ad235
+
+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
+      Main
+      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.NestedMap
+      Xanthous.Data.VectorBag
+      Xanthous.Entities.Character
+      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.Prompt
+      Xanthous.Game.State
+      Xanthous.Generators
+      Xanthous.Generators.CaveAutomata
+      Xanthous.Generators.Dungeon
+      Xanthous.Generators.LevelContents
+      Xanthous.Generators.Util
+      Xanthous.Generators.Village
+      Xanthous.Messages
+      Xanthous.Messages.Template
+      Xanthous.Monad
+      Xanthous.Orphans
+      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
+      LambdaCase
+      MultiWayIf
+      NoImplicitPrelude
+      NoStarIsType
+      OverloadedStrings
+      PolyKinds
+      RankNTypes
+      ScopedTypeVariables
+      TupleSections
+      TypeApplications
+      TypeFamilies
+      TypeOperators
+      ViewPatterns
+  ghc-options: -Wall
+  build-depends:
+      JuicyPixels
+    , MonadRandom
+    , QuickCheck
+    , Rasterific
+    , aeson
+    , array
+    , async
+    , base
+    , bifunctors
+    , brick
+    , checkers
+    , classy-prelude
+    , comonad
+    , comonad-extras
+    , constraints
+    , containers
+    , criterion
+    , data-default
+    , deepseq
+    , directory
+    , fgl
+    , fgl-arbitrary
+    , file-embed
+    , filepath
+    , generic-arbitrary
+    , generic-lens
+    , generic-monoid
+    , 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
+    , splitmix
+    , stache
+    , streams
+    , text
+    , text-zipper
+    , tomland
+    , transformers
+    , vector
+    , vty
+    , witherable
+    , yaml
+    , zlib
+  default-language: Haskell2010
+
+executable xanthous
+  main-is: Main.hs
+  other-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.NestedMap
+      Xanthous.Data.VectorBag
+      Xanthous.Entities.Character
+      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.Prompt
+      Xanthous.Game.State
+      Xanthous.Generators
+      Xanthous.Generators.CaveAutomata
+      Xanthous.Generators.Dungeon
+      Xanthous.Generators.LevelContents
+      Xanthous.Generators.Util
+      Xanthous.Generators.Village
+      Xanthous.Messages
+      Xanthous.Messages.Template
+      Xanthous.Monad
+      Xanthous.Orphans
+      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
+      Paths_xanthous
+  hs-source-dirs:
+      src
+  default-extensions:
+      BlockArguments
+      ConstraintKinds
+      DataKinds
+      DeriveAnyClass
+      DeriveGeneric
+      DerivingStrategies
+      DerivingVia
+      FlexibleContexts
+      FlexibleInstances
+      FunctionalDependencies
+      GADTSyntax
+      GeneralizedNewtypeDeriving
+      KindSignatures
+      LambdaCase
+      MultiWayIf
+      NoImplicitPrelude
+      NoStarIsType
+      OverloadedStrings
+      PolyKinds
+      RankNTypes
+      ScopedTypeVariables
+      TupleSections
+      TypeApplications
+      TypeFamilies
+      TypeOperators
+      ViewPatterns
+  ghc-options: -Wall -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
+    , deepseq
+    , directory
+    , fgl
+    , fgl-arbitrary
+    , file-embed
+    , filepath
+    , generic-arbitrary
+    , generic-lens
+    , generic-monoid
+    , 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
+    , 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.Data.EntitiesSpec
+      Xanthous.Data.EntityCharSpec
+      Xanthous.Data.EntityMap.GraphicsSpec
+      Xanthous.Data.EntityMapSpec
+      Xanthous.Data.LevelsSpec
+      Xanthous.Data.NestedMapSpec
+      Xanthous.DataSpec
+      Xanthous.Entities.RawsSpec
+      Xanthous.GameSpec
+      Xanthous.Generators.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
+      LambdaCase
+      MultiWayIf
+      NoImplicitPrelude
+      NoStarIsType
+      OverloadedStrings
+      PolyKinds
+      RankNTypes
+      ScopedTypeVariables
+      TupleSections
+      TypeApplications
+      TypeFamilies
+      TypeOperators
+      ViewPatterns
+  ghc-options: -Wall -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
+    , deepseq
+    , directory
+    , fgl
+    , fgl-arbitrary
+    , file-embed
+    , filepath
+    , generic-arbitrary
+    , generic-lens
+    , generic-monoid
+    , 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
+    , splitmix
+    , stache
+    , streams
+    , tasty
+    , tasty-hunit
+    , tasty-quickcheck
+    , 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
+      LambdaCase
+      MultiWayIf
+      NoImplicitPrelude
+      NoStarIsType
+      OverloadedStrings
+      PolyKinds
+      RankNTypes
+      ScopedTypeVariables
+      TupleSections
+      TypeApplications
+      TypeFamilies
+      TypeOperators
+      ViewPatterns
+  ghc-options: -Wall -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
+    , deepseq
+    , directory
+    , fgl
+    , fgl-arbitrary
+    , file-embed
+    , filepath
+    , generic-arbitrary
+    , generic-lens
+    , generic-monoid
+    , 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
+    , splitmix
+    , stache
+    , streams
+    , text
+    , text-zipper
+    , tomland
+    , transformers
+    , vector
+    , vty
+    , witherable
+    , xanthous
+    , yaml
+    , zlib
+  default-language: Haskell2010