mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source 
git-subtree-dir: users/glittershark/xanthous
git-subtree-mainline: 91f53f02d8
git-subtree-split: 53b56744f4
This commit is contained in:
Vincent Ambo 2020-06-16 01:05:44 +01:00
commit 2edb963b97
96 changed files with 10030 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
users/glittershark/xanthous/.envrc Normal file
View file

@ -0,0 +1 @@
eval "$(lorri direnv)"

23
users/glittershark/xanthous/.github/actions/nix-build/Dockerfile vendored Normal file
View file

@ -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" ]

24
users/glittershark/xanthous/.github/actions/nix-build/entrypoint.sh vendored Executable file
View file

@ -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[@]}"

15
users/glittershark/xanthous/.github/workflows/haskell.yml vendored Normal file
View file

@ -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

33
users/glittershark/xanthous/.gitignore vendored Normal file
View file

@ -0,0 +1,33 @@
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

674
users/glittershark/xanthous/LICENSE Normal file
View file

@ -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>.

36
users/glittershark/xanthous/README.org Normal file
View file

@ -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

2
users/glittershark/xanthous/Setup.hs Normal file
View file

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

12
users/glittershark/xanthous/build/generic-arbitrary-export-garbitrary.patch Normal file
View file

@ -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

13
users/glittershark/xanthous/build/hgeometry-fix-haddock.patch Normal file
View file

@ -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

92
users/glittershark/xanthous/build/update-comonad-extras.patch Normal file
View file

@ -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

19
users/glittershark/xanthous/default.nix Normal file
View file

@ -0,0 +1,19 @@
{ nixpkgs ? import ./nixpkgs.nix {}
, compiler ? "ghc865"
, failOnWarnings ? false
}:
let
inherit (nixpkgs) pkgs lib;
inherit (lib) id;
inherit (pkgs) fetchurl;
all-hies = import (fetchTarball {
url = "https://github.com/infinisil/all-hies/archive/4b6aab017cdf96a90641dc287437685675d598da.tar.gz";
sha256 = "0ap12mbzk97zmxk42fk8vqacyvpxk29r2wrnjqpx4m2w9g7gfdya";
}) {};
hie = all-hies.selection { selector = p: { inherit (p) ghc865; }; };
xanthous =
(if failOnWarnings then pkgs.haskell.lib.failOnAllWarnings else id)
((pkgs.haskellPackages
.extend (import ./haskell-overlay.nix { inherit nixpkgs; })
).callPackage (import ./pkg.nix { inherit nixpkgs; }) {}); in
xanthous // { inherit hie; }

35
users/glittershark/xanthous/haskell-overlay.nix Normal file
View file

@ -0,0 +1,35 @@
{ nixpkgs ? import ./nixpkgs.nix {} }:
let inherit (nixpkgs) pkgs;
in self: super: with pkgs.haskell.lib; rec {
generic-arbitrary = appendPatch
super.generic-arbitrary
[ ./build/generic-arbitrary-export-garbitrary.patch ];
hgeometry =
appendPatch
(self.callHackageDirect {
pkg = "hgeometry";
ver = "0.9.0.0";
sha256 = "02hyvbqm57lr47w90vdgl71cfbd6lvwpqdid9fcnmxkdjbq4kv6b";
} {}) [ ./build/hgeometry-fix-haddock.patch ];
hgeometry-combinatorial =
self.callHackageDirect {
pkg = "hgeometry-combinatorial";
ver = "0.9.0.0";
sha256 = "12k41wd9fd1y3jd5djwcpwg2s1cva87wh14i0m1yn49zax9wl740";
} {};
vinyl = pkgs.haskell.lib.overrideSrc
(pkgs.haskell.lib.markUnbroken super.vinyl)
rec {
src = nixpkgs.fetchzip {
url = "mirror://hackage/vinyl-${version}/vinyl-${version}.tar.gz";
sha256 = "190ffrmm76fh8fi9afkcda2vldf89y7dxj10434h28mbpq55kgsx";
};
version = "0.12.0";
};
comonad-extras = appendPatch (markUnbroken super.comonad-extras)
[ ./build/update-comonad-extras.patch ];
}

10
users/glittershark/xanthous/hie.sh Executable file
View file

@ -0,0 +1,10 @@
#!/usr/bin/env bash
cd "$(dirname "${BASH_SOURCE[0]}")" || exit 1
argv=( "$@" )
argv=( "${argv[@]/\'/\'\\\'\'}" )
argv=( "${argv[@]/#/\'}" )
argv=( "${argv[@]/%/\'}" )
exec nix-shell --pure --run "exec $(nix-build -o dist/nix/hie -A hie)/bin/hie ${argv[*]}"

9
users/glittershark/xanthous/nixpkgs.nix Normal file
View file

@ -0,0 +1,9 @@
let
inherit (import <nixpkgs> {}) fetchFromGitHub;
nixpkgs = fetchFromGitHub {
owner = "NixOS";
repo = "nixpkgs-channels";
rev = "54f385241e6649128ba963c10314942d73245479";
sha256 = "0bd4v8v4xcdbaiaa59yqprnc6dkb9jv12mb0h5xz7b51687ygh9l";
};
in import nixpkgs

136
users/glittershark/xanthous/package.yaml Normal file
View file

@ -0,0 +1,136 @@
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
- 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
- parser-combinators
- pointed
- random
- random-fu
- random-extras
- random-source
- raw-strings-qq
- reflection
- Rasterific
- streams
- stache
- semigroupoids
- tomland
- text
- text-zipper
- vector
- vty
- 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

19
users/glittershark/xanthous/pkg.nix Normal file
View file

@ -0,0 +1,19 @@
{ nixpkgs ? import ./nixpkgs.nix {}
,
}:
let
inherit (builtins) filterSource elem not;
inherit (nixpkgs) pkgs;
gitignoreSource = (import (pkgs.fetchFromGitHub {
owner = "hercules-ci";
repo = "gitignore";
rev = "f9e996052b5af4032fe6150bba4a6fe4f7b9d698";
sha256 = "0jrh5ghisaqdd0vldbywags20m2cxpkbbk5jjjmwaw0gr8nhsafv";
# date = 2019-09-18T15:15:15+02:00;
}) { inherit (pkgs) lib; }).gitignoreSource;
in
import (pkgs.haskellPackages.haskellSrc2nix {
name = "xanthous";
src = gitignoreSource ./.;
extraCabal2nixOptions = "--hpack";
})

30
users/glittershark/xanthous/shell.nix Normal file
View file

@ -0,0 +1,30 @@
{ nixpkgs ? import ./nixpkgs.nix {}, compiler ? "ghc865", withHoogle ? true }:
let
inherit (nixpkgs) pkgs;
pkg = import ./pkg.nix { inherit nixpkgs; };
packageSet = (
if compiler == "default"
then pkgs.haskellPackages
else pkgs.haskell.packages.${compiler}
).override {
overrides = import ./haskell-overlay.nix { inherit nixpkgs; };
};
haskellPackages = (
if withHoogle
then packageSet.override {
overrides = (self: super: {
ghc = super.ghc // { withPackages = super.ghc.withHoogle; };
ghcWithPackages = self.ghc.withPackages;
} // (import ./haskell-overlay.nix { inherit nixpkgs; }) self super);
}
else packageSet
);
drv = haskellPackages.callPackage pkg {};
inherit (pkgs.haskell.lib) addBuildTools;
in
(addBuildTools drv (with haskellPackages; [ cabal-install ])).env

167
users/glittershark/xanthous/src/Data/Aeson/Generic/DerivingVia.hs Normal file
View file

@ -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))

159
users/glittershark/xanthous/src/Main.hs Normal file
View file

@ -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

124
users/glittershark/xanthous/src/Xanthous/AI/Gormlak.hs Normal file
View file

@ -0,0 +1,124 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE UndecidableInstances #-}
--------------------------------------------------------------------------------
module Xanthous.AI.Gormlak
( HasVisionRadius(..)
, GormlakBrain(..)
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude hiding (lines)
--------------------------------------------------------------------------------
import Control.Monad.State
import Control.Monad.Random
import Data.Aeson (object)
import qualified Data.Aeson as A
import Data.Generics.Product.Fields
--------------------------------------------------------------------------------
import Xanthous.Data
( Positioned(..), positioned, position
, diffPositions, stepTowards, isUnit
, Ticks, (|*|), invertedRate
)
import Xanthous.Data.EntityMap
import Xanthous.Entities.Creature.Hippocampus
import Xanthous.Entities.Character (Character)
import qualified Xanthous.Entities.Character as Character
import qualified Xanthous.Entities.RawTypes as Raw
import Xanthous.Entities.RawTypes (CreatureType)
import Xanthous.Game.State
import Xanthous.Game.Lenses
( Collision(..), entitiesCollision, collisionAt
, character, characterPosition
)
import Xanthous.Data.EntityMap.Graphics (linesOfSight, canSee)
import Xanthous.Random
import Xanthous.Monad (say)
--------------------------------------------------------------------------------
-- TODO move the following two classes to a more central location
class HasVisionRadius a where visionRadius :: a -> Word
type IsCreature entity =
( HasVisionRadius entity
, HasField "_hippocampus" entity entity Hippocampus Hippocampus
, HasField "_creatureType" entity entity CreatureType CreatureType
, A.ToJSON entity
)
--------------------------------------------------------------------------------
stepGormlak
:: forall entity m.
( MonadState GameState m, MonadRandom m
, IsCreature entity
)
=> Ticks
-> Positioned entity
-> m (Positioned entity)
stepGormlak ticks pe@(Positioned pos creature) = do
dest <- maybe (selectDestination pos creature) pure
$ creature ^. field @"_hippocampus" . destination
let progress' =
dest ^. destinationProgress
+ creature ^. field @"_creatureType" . Raw.speed . invertedRate |*| ticks
if progress' < 1
then pure
$ pe
& positioned . field @"_hippocampus" . destination
?~ (dest & destinationProgress .~ progress')
else do
let newPos = dest ^. destinationPosition
remainingSpeed = progress' - 1
newDest <- selectDestination newPos creature
<&> destinationProgress +~ remainingSpeed
let pe' = pe & positioned . field @"_hippocampus" . destination ?~ newDest
collisionAt newPos >>= \case
Nothing -> pure $ pe' & position .~ newPos
Just Stop -> pure pe'
Just Combat -> do
ents <- use $ entities . atPosition newPos
when (any (entityIs @Character) ents) attackCharacter
pure pe'
where
selectDestination pos' creature' = destinationFromPos <$> do
canSeeCharacter <- uses entities $ canSee (entityIs @Character) pos' vision
if canSeeCharacter
then do
charPos <- use characterPosition
if isUnit (pos' `diffPositions` charPos)
then attackCharacter $> pos'
else pure $ pos' `stepTowards` charPos
else do
lines <- map (takeWhile (isNothing . entitiesCollision . map snd . snd)
-- the first item on these lines is always the creature itself
. fromMaybe mempty . tailMay)
. linesOfSight pos' (visionRadius creature')
<$> use entities
line <- choose $ weightedBy length lines
pure $ fromMaybe pos' $ fmap fst . headMay =<< line
vision = visionRadius creature
attackCharacter = do
say ["combat", "creatureAttack"] $ object [ "creature" A..= creature ]
character %= Character.damage 1
newtype GormlakBrain entity = GormlakBrain { _unGormlakBrain :: entity }
instance (IsCreature entity) => Brain (GormlakBrain entity) where
step ticks
= fmap (fmap GormlakBrain)
. stepGormlak ticks
. fmap _unGormlakBrain
entityCanMove = const True
--------------------------------------------------------------------------------
-- instance Brain Creature where
-- step = brainVia GormlakBrain
-- entityCanMove = const True
-- instance Entity Creature where
-- blocksVision _ = False
-- description = view $ Creature.creatureType . Raw.description
-- entityChar = view $ Creature.creatureType . char

468
users/glittershark/xanthous/src/Xanthous/App.hs Normal file
View file

@ -0,0 +1,468 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE RecordWildCards #-}
--------------------------------------------------------------------------------
module Xanthous.App
( makeApp
, RunType(..)
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
import Brick hiding (App, halt, continue, raw)
import qualified Brick
import Graphics.Vty.Attributes (defAttr)
import Graphics.Vty.Input.Events (Event(EvKey))
import Control.Monad.State (get, gets)
import Control.Monad.State.Class (modify)
import Data.Aeson (object, ToJSON)
import qualified Data.Aeson as A
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Vector as V
import System.Exit
import System.Directory (doesFileExist)
--------------------------------------------------------------------------------
import Xanthous.App.Common
import Xanthous.App.Time
import Xanthous.App.Prompt
import Xanthous.App.Autocommands
import Xanthous.Command
import Xanthous.Data
( move
, Dimensions'(Dimensions)
, positioned
, position
, Position
, (|*|)
)
import Xanthous.Data.App (ResourceName, Panel(..), AppEvent(..))
import qualified Xanthous.Data.EntityMap as EntityMap
import Xanthous.Data.Levels (prevLevel, nextLevel)
import qualified Xanthous.Data.Levels as Levels
import Xanthous.Data.Entities (blocksObject)
import Xanthous.Game
import Xanthous.Game.State
import Xanthous.Game.Env
import Xanthous.Game.Draw (drawGame)
import Xanthous.Game.Prompt
import qualified Xanthous.Messages as Messages
import Xanthous.Random
import Xanthous.Util (removeVectorIndex)
import Xanthous.Util.Inflection (toSentence)
--------------------------------------------------------------------------------
import qualified Xanthous.Entities.Character as Character
import Xanthous.Entities.Character hiding (pickUpItem)
import Xanthous.Entities.Item (Item)
import qualified Xanthous.Entities.Item as Item
import Xanthous.Entities.Creature (Creature)
import qualified Xanthous.Entities.Creature as Creature
import Xanthous.Entities.Environment
(Door, open, closed, locked, GroundMessage(..), Staircase(..))
import Xanthous.Entities.RawTypes
( edible, eatMessage, hitpointsHealed
, attackMessage
)
import Xanthous.Generators
import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
import qualified Xanthous.Generators.Dungeon as Dungeon
--------------------------------------------------------------------------------
type App = Brick.App GameState AppEvent ResourceName
data RunType = NewGame | LoadGame
deriving stock (Eq)
makeApp :: GameEnv -> RunType -> IO App
makeApp env rt = pure $ Brick.App
{ appDraw = drawGame
, appChooseCursor = const headMay
, appHandleEvent = \game event -> runAppM (handleEvent event) env game
, appStartEvent = case rt of
NewGame -> runAppM (startEvent >> get) env
LoadGame -> pure
, appAttrMap = const $ attrMap defAttr []
}
runAppM :: AppM a -> GameEnv -> GameState -> EventM ResourceName a
runAppM appm ge = fmap fst . runAppT appm ge
startEvent :: AppM ()
startEvent = do
initLevel
modify updateCharacterVision
use (character . characterName) >>= \case
Nothing -> prompt_ @'StringPrompt ["character", "namePrompt"] Uncancellable
$ \(StringResult s) -> do
character . characterName ?= s
say ["welcome"] =<< use character
Just n -> say ["welcome"] $ object [ "characterName" A..= n ]
initLevel :: AppM ()
initLevel = do
level <- genLevel 0
entities <>= levelToEntityMap level
characterPosition .= level ^. levelCharacterPosition
--------------------------------------------------------------------------------
handleEvent :: BrickEvent ResourceName AppEvent -> AppM (Next GameState)
handleEvent ev = use promptState >>= \case
NoPrompt -> handleNoPromptEvent ev
WaitingPrompt msg pr -> handlePromptEvent msg pr ev
handleNoPromptEvent :: BrickEvent ResourceName AppEvent -> AppM (Next GameState)
handleNoPromptEvent (VtyEvent (EvKey k mods))
| Just command <- commandFromKey k mods
= do messageHistory %= nextTurn
handleCommand command
handleNoPromptEvent (AppEvent AutoContinue) = do
preuse (autocommand . _ActiveAutocommand . _1) >>= traverse_ autoStep
continue
handleNoPromptEvent _ = continue
handleCommand :: Command -> AppM (Next GameState)
handleCommand Quit = confirm_ ["quit", "confirm"] (liftIO exitSuccess) >> continue
handleCommand (Move dir) = do
newPos <- uses characterPosition $ move dir
collisionAt newPos >>= \case
Nothing -> do
characterPosition .= newPos
stepGameBy =<< uses (character . speed) (|*| 1)
describeEntitiesAt newPos
Just Combat -> attackAt newPos
Just Stop -> pure ()
continue
handleCommand PickUp = do
pos <- use characterPosition
uses entities (entitiesAtPositionWithType @Item pos) >>= \case
[] -> say_ ["pickUp", "nothingToPickUp"]
[item] -> pickUpItem item
items' ->
menu_ ["pickUp", "menu"] Cancellable (entityMenu_ items')
$ \(MenuResult item) -> pickUpItem item
continue
where
pickUpItem (itemID, item) = do
character %= Character.pickUpItem item
entities . at itemID .= Nothing
say ["pickUp", "pickUp"] $ object [ "item" A..= item ]
stepGameBy 100 -- TODO
handleCommand Drop = do
selectItemFromInventory_ ["drop", "menu"] Cancellable id
(say_ ["drop", "nothing"])
$ \(MenuResult item) -> do
entitiesAtCharacter %= (SomeEntity item <|)
say ["drop", "dropped"] $ object [ "item" A..= item ]
continue
handleCommand PreviousMessage = do
messageHistory %= previousMessage
continue
handleCommand Open = do
prompt_ @'DirectionPrompt ["open", "prompt"] Cancellable
$ \(DirectionResult dir) -> do
pos <- move dir <$> use characterPosition
doors <- uses entities $ entitiesAtPositionWithType @Door pos
if | null doors -> say_ ["open", "nothingToOpen"]
| any (view $ _2 . locked) doors -> say_ ["open", "locked"]
| all (view $ _2 . open) doors -> say_ ["open", "alreadyOpen"]
| otherwise -> do
for_ doors $ \(eid, _) ->
entities . ix eid . positioned . _SomeEntity . open .= True
say_ ["open", "success"]
pure ()
stepGame -- TODO
continue
handleCommand Close = do
prompt_ @'DirectionPrompt ["close", "prompt"] Cancellable
$ \(DirectionResult dir) -> do
pos <- move dir <$> use characterPosition
(nonDoors, doors) <- uses entities
$ partitionEithers
. toList
. map ( (matching . aside $ _SomeEntity @Door)
. over _2 (view positioned)
)
. EntityMap.atPositionWithIDs pos
if | null doors -> say_ ["close", "nothingToClose"]
| all (view $ _2 . closed) doors -> say_ ["close", "alreadyClosed"]
| any (view blocksObject . entityAttributes . snd) nonDoors ->
say ["close", "blocked"]
$ object [ "entityDescriptions"
A..= ( toSentence
. map description
. filter (view blocksObject . entityAttributes)
. map snd
) nonDoors
, "blockOrBlocks"
A..= ( if length nonDoors == 1
then "blocks"
else "block"
:: Text)
]
| otherwise -> do
for_ doors $ \(eid, _) ->
entities . ix eid . positioned . _SomeEntity . closed .= True
for_ nonDoors $ \(eid, _) ->
entities . ix eid . position %= move dir
say_ ["close", "success"]
pure ()
stepGame -- TODO
continue
handleCommand Look = do
prompt_ @'PointOnMap ["look", "prompt"] Cancellable
$ \(PointOnMapResult pos) ->
use (entities . EntityMap.atPosition pos)
>>= \case
Empty -> say_ ["look", "nothing"]
ents -> describeEntities ents
continue
handleCommand Wait = stepGame >> continue
handleCommand Eat = do
uses (character . inventory . backpack)
(V.mapMaybe (\item -> (item,) <$> item ^. Item.itemType . edible))
>>= \case
Empty -> say_ ["eat", "noFood"]
food ->
let foodMenuItem idx (item, edibleItem)
= ( item ^. Item.itemType . char . char
, MenuOption (description item) (idx, item, edibleItem))
-- TODO refactor to use entityMenu_
menuItems = mkMenuItems $ imap foodMenuItem food
in menu_ ["eat", "menuPrompt"] Cancellable menuItems
$ \(MenuResult (idx, item, edibleItem)) -> do
character . inventory . backpack %= removeVectorIndex idx
let msg = fromMaybe (Messages.lookup ["eat", "eat"])
$ edibleItem ^. eatMessage
character . characterHitpoints' +=
edibleItem ^. hitpointsHealed . to fromIntegral
message msg $ object ["item" A..= item]
stepGame -- TODO
continue
handleCommand Read = do
-- TODO allow reading things in the inventory (combo direction+menu prompt?)
prompt_ @'DirectionPrompt ["read", "prompt"] Cancellable
$ \(DirectionResult dir) -> do
pos <- uses characterPosition $ move dir
uses entities
(fmap snd . entitiesAtPositionWithType @GroundMessage pos) >>= \case
Empty -> say_ ["read", "nothing"]
GroundMessage msg :< Empty ->
say ["read", "result"] $ object ["message" A..= msg]
msgs ->
let readAndContinue Empty = pure ()
readAndContinue (msg :< msgs') =
prompt @'Continue
["read", "result"]
(object ["message" A..= msg])
Cancellable
. const
$ readAndContinue msgs'
readAndContinue _ = error "this is total"
in readAndContinue msgs
continue
handleCommand ShowInventory = showPanel InventoryPanel >> continue
handleCommand Wield = do
selectItemFromInventory_ ["wield", "menu"] Cancellable asWieldedItem
(say_ ["wield", "nothing"])
$ \(MenuResult item) -> do
prevItems <- character . inventory . wielded <<.= inRightHand item
character . inventory . backpack
<>= fromList (prevItems ^.. wieldedItems . wieldedItem)
say ["wield", "wielded"] item
continue
handleCommand Save = do
-- TODO default save locations / config file?
prompt_ @'StringPrompt ["save", "location"] Cancellable
$ \(StringResult filename) -> do
exists <- liftIO . doesFileExist $ unpack filename
if exists
then confirm ["save", "overwrite"] (object ["filename" A..= filename])
$ doSave filename
else doSave filename
continue
where
doSave filename = do
src <- gets saveGame
lift . liftIO $ do
writeFile (unpack filename) $ toStrict src
exitSuccess
handleCommand GoUp = do
hasStairs <- uses entitiesAtCharacter $ elem (SomeEntity UpStaircase)
if hasStairs
then uses levels prevLevel >>= \case
Just levs' -> levels .= levs'
Nothing ->
-- TODO in nethack, this leaves the game. Maybe something similar here?
say_ ["cant", "goUp"]
else say_ ["cant", "goUp"]
continue
handleCommand GoDown = do
hasStairs <- uses entitiesAtCharacter $ elem (SomeEntity DownStaircase)
if hasStairs
then do
levs <- use levels
let newLevelNum = Levels.pos levs + 1
levs' <- nextLevel (levelToGameLevel <$> genLevel newLevelNum) levs
cEID <- use characterEntityID
pCharacter <- entities . at cEID <<.= Nothing
levels .= levs'
entities . at cEID .= pCharacter
characterPosition .= extract levs' ^. upStaircasePosition
else say_ ["cant", "goDown"]
continue
handleCommand (StartAutoMove dir) = do
runAutocommand $ AutoMove dir
continue
--
handleCommand ToggleRevealAll = do
val <- debugState . allRevealed <%= not
say ["debug", "toggleRevealAll"] $ object [ "revealAll" A..= val ]
continue
--------------------------------------------------------------------------------
attackAt :: Position -> AppM ()
attackAt pos =
uses entities (entitiesAtPositionWithType @Creature pos) >>= \case
Empty -> say_ ["combat", "nothingToAttack"]
(creature :< Empty) -> attackCreature creature
creatures ->
menu_ ["combat", "menu"] Cancellable (entityMenu_ creatures)
$ \(MenuResult creature) -> attackCreature creature
where
attackCreature (creatureID, creature) = do
charDamage <- uses character characterDamage
let creature' = Creature.damage charDamage creature
msgParams = object ["creature" A..= creature']
if Creature.isDead creature'
then do
say ["combat", "killed"] msgParams
entities . at creatureID .= Nothing
else do
msg <- uses character getAttackMessage
message msg msgParams
entities . ix creatureID . positioned .= SomeEntity creature'
whenM (uses character $ isNothing . weapon)
$ whenM (chance (0.08 :: Float)) $ do
say_ ["combat", "fistSelfDamage"]
character %= Character.damage 1
stepGame -- TODO
weapon chr = chr ^? inventory . wielded . wieldedItems . wieldableItem
getAttackMessage chr =
case weapon chr of
Just wi ->
fromMaybe (Messages.lookup ["combat", "hit", "generic"])
$ wi ^. attackMessage
Nothing ->
Messages.lookup ["combat", "hit", "fists"]
entityMenu_
:: (Comonad w, Entity entity)
=> [w entity]
-> Map Char (MenuOption (w entity))
entityMenu_ = mkMenuItems @[_] . map entityMenuItem
where
entityMenuItem wentity
= let entity = extract wentity
in (entityMenuChar entity, MenuOption (description entity) wentity)
entityMenuChar :: Entity a => a -> Char
entityMenuChar entity
= let ec = entityChar entity ^. char
in if ec `elem` (['a'..'z'] ++ ['A'..'Z'])
then ec
else 'a'
-- | Prompt with an item to select out of the inventory, remove it from the
-- inventory, and call callback with it
selectItemFromInventory
:: forall item params.
(ToJSON params)
=> [Text] -- ^ Menu message
-> params -- ^ Menu message params
-> PromptCancellable -- ^ Is the menu cancellable?
-> Prism' Item item -- ^ Attach some extra information to the item, in a
-- recoverable fashion. Prism vs iso so we can discard
-- items.
-> AppM () -- ^ Action to take if there are no items matching
-> (PromptResult ('Menu item) -> AppM ())
-> AppM ()
selectItemFromInventory msgPath msgParams cancellable extraInfo onEmpty cb =
uses (character . inventory . backpack)
(V.mapMaybe $ preview extraInfo)
>>= \case
Empty -> onEmpty
items' ->
menu msgPath msgParams cancellable (itemMenu items')
$ \(MenuResult (idx, item)) -> do
character . inventory . backpack %= removeVectorIndex idx
cb $ MenuResult item
where
itemMenu = mkMenuItems . imap itemMenuItem
itemMenuItem idx extraInfoItem =
let item = extraInfo # extraInfoItem
in ( entityMenuChar item
, MenuOption (description item) (idx, extraInfoItem))
selectItemFromInventory_
:: forall item.
[Text] -- ^ Menu message
-> PromptCancellable -- ^ Is the menu cancellable?
-> Prism' Item item -- ^ Attach some extra information to the item, in a
-- recoverable fashion. Prism vs iso so we can discard
-- items.
-> AppM () -- ^ Action to take if there are no items matching
-> (PromptResult ('Menu item) -> AppM ())
-> AppM ()
selectItemFromInventory_ msgPath = selectItemFromInventory msgPath ()
-- entityMenu :: Entity entity => [entity] -> Map Char (MenuOption entity)
-- entityMenu = map (map runIdentity) . entityMenu_ . fmap Identity
showPanel :: Panel -> AppM ()
showPanel panel = do
activePanel ?= panel
prompt_ @'Continue ["generic", "continue"] Uncancellable
. const
$ activePanel .= Nothing
--------------------------------------------------------------------------------
genLevel
:: Int -- ^ level number
-> AppM Level
genLevel _num = do
let dims = Dimensions 80 80
generator <- choose $ CaveAutomata :| [Dungeon]
level <- case generator of
CaveAutomata -> generateLevel SCaveAutomata CaveAutomata.defaultParams dims
Dungeon -> generateLevel SDungeon Dungeon.defaultParams dims
pure $!! level
levelToGameLevel :: Level -> GameLevel
levelToGameLevel level =
let _levelEntities = levelToEntityMap level
_upStaircasePosition = level ^. levelCharacterPosition
_levelRevealedPositions = mempty
in GameLevel {..}

65
users/glittershark/xanthous/src/Xanthous/App/Autocommands.hs Normal file
View file

@ -0,0 +1,65 @@
--------------------------------------------------------------------------------
module Xanthous.App.Autocommands
( runAutocommand
, autoStep
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
--------------------------------------------------------------------------------
import Control.Concurrent (threadDelay)
import qualified Data.Aeson as A
import Data.Aeson (object)
import Data.List.NonEmpty (nonEmpty)
import qualified Data.List.NonEmpty as NE
import Control.Monad.State (gets)
--------------------------------------------------------------------------------
import Xanthous.App.Common
import Xanthous.App.Time
import Xanthous.Data
import Xanthous.Data.App
import Xanthous.Entities.Character (speed)
import Xanthous.Entities.Creature (Creature, creatureType)
import Xanthous.Entities.RawTypes (hostile)
import Xanthous.Game.State
import Xanthous.Game.Lenses (characterVisibleEntities)
--------------------------------------------------------------------------------
autoStep :: Autocommand -> AppM ()
autoStep (AutoMove dir) = do
newPos <- uses characterPosition $ move dir
collisionAt newPos >>= \case
Nothing -> do
characterPosition .= newPos
stepGameBy =<< uses (character . speed) (|*| 1)
describeEntitiesAt newPos
maybeVisibleEnemies <- nonEmpty <$> enemiesInSight
for_ maybeVisibleEnemies $ \visibleEnemies -> do
say ["autoMove", "enemyInSight"]
$ object [ "firstEntity" A..= NE.head visibleEnemies ]
cancelAutocommand
Just _ -> cancelAutocommand
where
enemiesInSight :: AppM [Creature]
enemiesInSight = do
ents <- gets characterVisibleEntities
pure $ ents
^.. folded
. _SomeEntity @Creature
. filtered (view $ creatureType . hostile)
--------------------------------------------------------------------------------
autocommandIntervalμs :: Int
autocommandIntervalμs = 1000 * 50 -- 50 ms
runAutocommand :: Autocommand -> AppM ()
runAutocommand ac = do
env <- ask
tid <- liftIO . async $ runReaderT go env
autocommand .= ActiveAutocommand ac tid
where
go = everyμs autocommandIntervalμs $ sendEvent AutoContinue
-- | Perform 'act' every μs microseconds forever
everyμs :: MonadIO m => Int -> m () -> m ()
everyμs μs act = act >> liftIO (threadDelay μs) >> everyμs μs act

67
users/glittershark/xanthous/src/Xanthous/App/Common.hs Normal file
View file

@ -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]

161
users/glittershark/xanthous/src/Xanthous/App/Prompt.hs Normal file
View file

@ -0,0 +1,161 @@
{-# LANGUAGE UndecidableInstances #-}
--------------------------------------------------------------------------------
module Xanthous.App.Prompt
( handlePromptEvent
, clearPrompt
, prompt
, prompt_
, confirm_
, confirm
, menu
, menu_
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
--------------------------------------------------------------------------------
import Brick (BrickEvent(..), Next)
import Brick.Widgets.Edit (handleEditorEvent)
import Data.Aeson (ToJSON, object)
import Graphics.Vty.Input.Events (Event(EvKey), Key(..))
import GHC.TypeLits (TypeError, ErrorMessage(..))
--------------------------------------------------------------------------------
import Xanthous.App.Common
import Xanthous.Data (move)
import Xanthous.Command (directionFromChar)
import Xanthous.Data.App (ResourceName, AppEvent)
import Xanthous.Game.Prompt
import Xanthous.Game.State
import qualified Xanthous.Messages as Messages
--------------------------------------------------------------------------------
handlePromptEvent
:: Text -- ^ Prompt message
-> Prompt AppM
-> BrickEvent ResourceName AppEvent
-> AppM (Next GameState)
handlePromptEvent _ (Prompt Cancellable _ _ _ _) (VtyEvent (EvKey KEsc []))
= clearPrompt >> continue
handlePromptEvent _ pr (VtyEvent (EvKey KEnter []))
= clearPrompt >> submitPrompt pr >> continue
handlePromptEvent _ pr@(Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'y') []))
= clearPrompt >> submitPrompt pr >> continue
handlePromptEvent _ (Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'n') []))
= clearPrompt >> continue
handlePromptEvent
msg
(Prompt c SStringPrompt (StringPromptState edit) pri cb)
(VtyEvent ev)
= do
edit' <- lift $ handleEditorEvent ev edit
let prompt' = Prompt c SStringPrompt (StringPromptState edit') pri cb
promptState .= WaitingPrompt msg prompt'
continue
handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ cb)
(VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) []))
= clearPrompt >> cb (DirectionResult dir) >> continue
handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ _) _ = continue
handlePromptEvent _ (Prompt _ SMenu _ items' cb) (VtyEvent (EvKey (KChar chr) []))
| Just (MenuOption _ res) <- items' ^. at chr
= clearPrompt >> cb (MenuResult res) >> continue
| otherwise
= continue
handlePromptEvent
msg
(Prompt c SPointOnMap (PointOnMapPromptState pos) pri cb)
(VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) []))
= let pos' = move dir pos
prompt' = Prompt c SPointOnMap (PointOnMapPromptState pos') pri cb
in promptState .= WaitingPrompt msg prompt'
>> continue
handlePromptEvent _ (Prompt _ SPointOnMap _ _ _) _ = continue
handlePromptEvent
_
(Prompt Cancellable _ _ _ _)
(VtyEvent (EvKey (KChar 'q') []))
= clearPrompt >> continue
handlePromptEvent _ _ _ = continue
clearPrompt :: AppM ()
clearPrompt = promptState .= NoPrompt
class NotMenu (pt :: PromptType)
instance NotMenu 'StringPrompt
instance NotMenu 'Confirm
instance NotMenu 'DirectionPrompt
instance NotMenu 'PointOnMap
instance NotMenu 'Continue
instance TypeError ('Text "Cannot use `prompt` or `prompt_` for menu prompts"
':$$: 'Text "Use `menu` or `menu_` instead")
=> NotMenu ('Menu a)
prompt
:: forall (pt :: PromptType) (params :: Type).
(ToJSON params, SingPromptType pt, NotMenu pt)
=> [Text] -- ^ Message key
-> params -- ^ Message params
-> PromptCancellable
-> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler
-> AppM ()
prompt msgPath params cancellable cb = do
let pt = singPromptType @pt
msg <- Messages.message msgPath params
p <- case pt of
SPointOnMap -> do
charPos <- use characterPosition
pure $ mkPointOnMapPrompt cancellable charPos cb
SStringPrompt -> pure $ mkPrompt cancellable pt cb
SConfirm -> pure $ mkPrompt cancellable pt cb
SDirectionPrompt -> pure $ mkPrompt cancellable pt cb
SContinue -> pure $ mkPrompt cancellable pt cb
SMenu -> error "unreachable"
promptState .= WaitingPrompt msg p
prompt_
:: forall (pt :: PromptType).
(SingPromptType pt, NotMenu pt)
=> [Text] -- ^ Message key
-> PromptCancellable
-> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler
-> AppM ()
prompt_ msg = prompt msg $ object []
confirm
:: ToJSON params
=> [Text] -- ^ Message key
-> params
-> AppM ()
-> AppM ()
confirm msgPath params
= prompt @'Confirm msgPath params Cancellable . const
confirm_ :: [Text] -> AppM () -> AppM ()
confirm_ msgPath = confirm msgPath $ object []
menu :: forall (a :: Type) (params :: Type).
(ToJSON params)
=> [Text] -- ^ Message key
-> params -- ^ Message params
-> PromptCancellable
-> Map Char (MenuOption a) -- ^ Menu items
-> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler
-> AppM ()
menu msgPath params cancellable items' cb = do
msg <- Messages.message msgPath params
let p = mkMenu cancellable items' cb
promptState .= WaitingPrompt msg p
menu_ :: forall (a :: Type).
[Text] -- ^ Message key
-> PromptCancellable
-> Map Char (MenuOption a) -- ^ Menu items
-> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler
-> AppM ()
menu_ msgPath = menu msgPath $ object []

40
users/glittershark/xanthous/src/Xanthous/App/Time.hs Normal file
View file

@ -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

73
users/glittershark/xanthous/src/Xanthous/Command.hs Normal file
View file

@ -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

571
users/glittershark/xanthous/src/Xanthous/Data.hs Normal file
View file

@ -0,0 +1,571 @@
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoTypeSynonymInstances #-}
{-# LANGUAGE DuplicateRecordFields #-}
--------------------------------------------------------------------------------
-- | Common data types for Xanthous
--------------------------------------------------------------------------------
module Xanthous.Data
( Opposite(..)
-- *
, Position'(..)
, Position
, x
, y
-- **
, Positioned(..)
, _Positioned
, position
, positioned
, loc
, _Position
, positionFromPair
, addPositions
, diffPositions
, stepTowards
, isUnit
-- * Boxes
, Box(..)
, topLeftCorner
, bottomRightCorner
, setBottomRightCorner
, dimensions
, inBox
, boxIntersects
, boxCenter
, boxEdge
, module Linear.V2
-- *
, Per(..)
, invertRate
, invertedRate
, (|*|)
, Ticks(..)
, Tiles(..)
, TicksPerTile
, TilesPerTick
, timesTiles
-- *
, Dimensions'(..)
, Dimensions
, HasWidth(..)
, HasHeight(..)
-- *
, Direction(..)
, move
, asPosition
, directionOf
, Cardinal(..)
-- *
, Corner(..)
, Edge(..)
, cornerEdges
-- *
, Neighbors(..)
, edges
, neighborDirections
, neighborPositions
, arrayNeighbors
, rotations
-- *
, Hitpoints(..)
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude hiding (Left, Down, Right, (.=), elements)
--------------------------------------------------------------------------------
import Linear.V2 hiding (_x, _y)
import qualified Linear.V2 as L
import Linear.V4 hiding (_x, _y)
import Test.QuickCheck (Arbitrary, CoArbitrary, Function, elements)
import Test.QuickCheck.Arbitrary.Generic
import Data.Group
import Brick (Location(Location), Edges(..))
import Data.Monoid (Product(..), Sum(..))
import Data.Array.IArray
import Data.Aeson.Generic.DerivingVia
import Data.Aeson
( ToJSON(..), FromJSON(..), object, (.=), (.:), withObject)
--------------------------------------------------------------------------------
import Xanthous.Util (EqEqProp(..), EqProp, between)
import Xanthous.Util.QuickCheck (GenericArbitrary(..))
import Xanthous.Orphans ()
import Xanthous.Util.Graphics
--------------------------------------------------------------------------------
-- | opposite ∘ opposite ≡ id
class Opposite x where
opposite :: x -> x
--------------------------------------------------------------------------------
-- fromScalar ∘ scalar ≡ id
class Scalar a where
scalar :: a -> Double
fromScalar :: Double -> a
instance Scalar Double where
scalar = id
fromScalar = id
newtype ScalarIntegral a = ScalarIntegral a
deriving newtype (Eq, Ord, Num, Enum, Real, Integral)
instance Integral a => Scalar (ScalarIntegral a) where
scalar = fromIntegral
fromScalar = floor
deriving via (ScalarIntegral Integer) instance Scalar Integer
deriving via (ScalarIntegral Word) instance Scalar Word
--------------------------------------------------------------------------------
data Position' a where
Position :: { _x :: a
, _y :: a
} -> (Position' a)
deriving stock (Show, Eq, Generic, Ord, Functor, Foldable, Traversable)
deriving anyclass (NFData, Hashable, CoArbitrary, Function)
deriving EqProp via EqEqProp (Position' a)
deriving (ToJSON, FromJSON)
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
(Position' a)
x, y :: Lens' (Position' a) a
x = lens (\(Position xx _) -> xx) (\(Position _ yy) xx -> Position xx yy)
y = lens (\(Position _ yy) -> yy) (\(Position xx _) yy -> Position xx yy)
type Position = Position' Int
instance Arbitrary a => Arbitrary (Position' a) where
arbitrary = genericArbitrary
shrink (Position px py) = Position <$> shrink px <*> shrink py
instance Num a => Semigroup (Position' a) where
(Position x₁ y₁) <> (Position x₂ y₂) = Position (x₁ + x₂) (y₁ + y₂)
instance Num a => Monoid (Position' a) where
mempty = Position 0 0
instance Num a => Group (Position' a) where
invert (Position px py) = Position (negate px) (negate py)
-- | Positions convert to scalars by discarding their orientation and just
-- measuring the length from the origin
instance (Ord a, Num a, Scalar a) => Scalar (Position' a) where
scalar = fromIntegral . length . line (0, 0) . view _Position
fromScalar n = Position (fromScalar n) (fromScalar n)
data Positioned a where
Positioned :: Position -> a -> Positioned a
deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
type role Positioned representational
_Positioned :: Iso (Position, a) (Position, b) (Positioned a) (Positioned b)
_Positioned = iso hither yon
where
hither (pos, a) = Positioned pos a
yon (Positioned pos b) = (pos, b)
instance Arbitrary a => Arbitrary (Positioned a) where
arbitrary = Positioned <$> arbitrary <*> arbitrary
instance ToJSON a => ToJSON (Positioned a) where
toJSON (Positioned pos val) = object
[ "position" .= pos
, "data" .= val
]
instance FromJSON a => FromJSON (Positioned a) where
parseJSON = withObject "Positioned" $ \obj ->
Positioned <$> obj .: "position" <*> obj .: "data"
position :: Lens' (Positioned a) Position
position = lens
(\(Positioned pos _) -> pos)
(\(Positioned _ a) pos -> Positioned pos a)
positioned :: Lens (Positioned a) (Positioned b) a b
positioned = lens
(\(Positioned _ x') -> x')
(\(Positioned pos _) x' -> Positioned pos x')
loc :: Iso' Position Location
loc = iso hither yon
where
hither (Position px py) = Location (px, py)
yon (Location (lx, ly)) = Position lx ly
_Position :: Iso' (Position' a) (a, a)
_Position = iso hither yon
where
hither (Position px py) = (px, py)
yon (lx, ly) = Position lx ly
positionFromPair :: (Num a, Integral i, Integral j) => (i, j) -> Position' a
positionFromPair (i, j) = Position (fromIntegral i) (fromIntegral j)
-- | Add two positions
--
-- Operation for the additive group on positions
addPositions :: Num a => Position' a -> Position' a -> Position' a
addPositions = (<>)
-- | Subtract two positions.
--
-- diffPositions pos₁ pos₂ = pos₁ `addPositions` (invert pos₂)
diffPositions :: Num a => Position' a -> Position' a -> Position' a
diffPositions (Position x₁ y₁) (Position x₂ y₂) = Position (x₁ - x₂) (y₁ - y₂)
-- | Is this position a unit position? or: When taken as a difference, does this
-- position represent a step of one tile?
--
-- ∀ dir :: Direction. isUnit ('asPosition' dir)
isUnit :: (Eq a, Num a) => Position' a -> Bool
isUnit (Position px py) =
abs px `elem` [0,1] && abs py `elem` [0, 1] && (px, py) /= (0, 0)
--------------------------------------------------------------------------------
data Dimensions' a = Dimensions
{ _width :: a
, _height :: a
}
deriving stock (Show, Eq, Functor, Generic)
deriving anyclass (CoArbitrary, Function)
makeFieldsNoPrefix ''Dimensions'
instance Arbitrary a => Arbitrary (Dimensions' a) where
arbitrary = Dimensions <$> arbitrary <*> arbitrary
type Dimensions = Dimensions' Word
--------------------------------------------------------------------------------
data Direction where
Up :: Direction
Down :: Direction
Left :: Direction
Right :: Direction
UpLeft :: Direction
UpRight :: Direction
DownLeft :: Direction
DownRight :: Direction
Here :: Direction
deriving stock (Show, Eq, Ord, Generic)
deriving anyclass (CoArbitrary, Function, NFData, ToJSON, FromJSON, Hashable)
deriving Arbitrary via GenericArbitrary Direction
instance Opposite Direction where
opposite Up = Down
opposite Down = Up
opposite Left = Right
opposite Right = Left
opposite UpLeft = DownRight
opposite UpRight = DownLeft
opposite DownLeft = UpRight
opposite DownRight = UpLeft
opposite Here = Here
move :: Num a => Direction -> Position' a -> Position' a
move Up = y -~ 1
move Down = y +~ 1
move Left = x -~ 1
move Right = x +~ 1
move UpLeft = move Up . move Left
move UpRight = move Up . move Right
move DownLeft = move Down . move Left
move DownRight = move Down . move Right
move Here = id
asPosition :: Direction -> Position
asPosition dir = move dir mempty
-- | Returns the direction that a given position is from a given source position
directionOf
:: Position -- ^ Source
-> Position -- ^ Target
-> Direction
directionOf (Position x₁ y₁) (Position x₂ y₂) =
case (x₁ `compare` x₂, y₁ `compare` y₂) of
(EQ, EQ) -> Here
(EQ, LT) -> Down
(EQ, GT) -> Up
(LT, EQ) -> Right
(GT, EQ) -> Left
(LT, LT) -> DownRight
(GT, LT) -> DownLeft
(LT, GT) -> UpRight
(GT, GT) -> UpLeft
-- | Take one (potentially diagonal) step towards the given position
--
-- ∀ src tgt. isUnit (src `diffPositions` (src `stepTowards tgt`))
stepTowards
:: Position -- ^ Source
-> Position -- ^ Target
-> Position
stepTowards (view _Position -> p₁) (view _Position -> p₂)
| p₁ == p₂ = _Position # p₁
| otherwise =
let (_:p:_) = line p₁ p₂
in _Position # p
-- | Newtype controlling arbitrary generation to only include cardinal
-- directions ('Up', 'Down', 'Left', 'Right')
newtype Cardinal = Cardinal { getCardinal :: Direction }
deriving stock (Eq, Show, Ord, Generic)
deriving anyclass (NFData, Function, CoArbitrary)
deriving newtype (Opposite)
instance Arbitrary Cardinal where
arbitrary = Cardinal <$> elements [Up, Down, Left, Right]
--------------------------------------------------------------------------------
data Corner
= TopLeft
| TopRight
| BottomLeft
| BottomRight
deriving stock (Show, Eq, Ord, Enum, Bounded, Generic)
deriving Arbitrary via GenericArbitrary Corner
instance Opposite Corner where
opposite TopLeft = BottomRight
opposite TopRight = BottomLeft
opposite BottomLeft = TopRight
opposite BottomRight = TopLeft
data Edge
= TopEdge
| LeftEdge
| RightEdge
| BottomEdge
deriving stock (Show, Eq, Ord, Enum, Bounded, Generic)
deriving Arbitrary via GenericArbitrary Edge
instance Opposite Edge where
opposite TopEdge = BottomEdge
opposite BottomEdge = TopEdge
opposite LeftEdge = RightEdge
opposite RightEdge = LeftEdge
cornerEdges :: Corner -> (Edge, Edge)
cornerEdges TopLeft = (TopEdge, LeftEdge)
cornerEdges TopRight = (TopEdge, RightEdge)
cornerEdges BottomLeft = (BottomEdge, LeftEdge)
cornerEdges BottomRight = (BottomEdge, RightEdge)
--------------------------------------------------------------------------------
data Neighbors a = Neighbors
{ _topLeft
, _top
, _topRight
, _left
, _right
, _bottomLeft
, _bottom
, _bottomRight :: a
}
deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving Arbitrary via GenericArbitrary (Neighbors a)
makeFieldsNoPrefix ''Neighbors
instance Applicative Neighbors where
pure α = Neighbors
{ _topLeft = α
, _top = α
, _topRight = α
, _left = α
, _right = α
, _bottomLeft = α
, _bottom = α
, _bottomRight = α
}
nf <*> nx = Neighbors
{ _topLeft = nf ^. topLeft $ nx ^. topLeft
, _top = nf ^. top $ nx ^. top
, _topRight = nf ^. topRight $ nx ^. topRight
, _left = nf ^. left $ nx ^. left
, _right = nf ^. right $ nx ^. right
, _bottomLeft = nf ^. bottomLeft $ nx ^. bottomLeft
, _bottom = nf ^. bottom $ nx ^. bottom
, _bottomRight = nf ^. bottomRight $ nx ^. bottomRight
}
edges :: Neighbors a -> Edges a
edges neighs = Edges
{ eTop = neighs ^. top
, eBottom = neighs ^. bottom
, eLeft = neighs ^. left
, eRight = neighs ^. right
}
neighborDirections :: Neighbors Direction
neighborDirections = Neighbors
{ _topLeft = UpLeft
, _top = Up
, _topRight = UpRight
, _left = Left
, _right = Right
, _bottomLeft = DownLeft
, _bottom = Down
, _bottomRight = DownRight
}
neighborPositions :: Num a => Position' a -> Neighbors (Position' a)
neighborPositions pos = (`move` pos) <$> neighborDirections
arrayNeighbors
:: (IArray a e, Ix i, Num i)
=> a (i, i) e
-> (i, i)
-> Neighbors (Maybe e)
arrayNeighbors arr center = arrLookup <$> neighborPositions (_Position # center)
where
arrLookup (view _Position -> pos)
| inRange (bounds arr) pos = Just $ arr ! pos
| otherwise = Nothing
-- | Returns a list of all 4 90-degree rotations of the given neighbors
rotations :: Neighbors a -> V4 (Neighbors a)
rotations orig@(Neighbors tl t tr l r bl b br) = V4
orig -- tl t tr
-- l r
-- bl b br
(Neighbors bl l tl b t br r tr) -- bl l tl
-- b t
-- br r tr
(Neighbors br b bl r l tr t tl) -- br b bl
-- r l
-- tr t tl
(Neighbors tr r br t b tl l bl) -- tr r br
-- t b
-- tl l bl
--------------------------------------------------------------------------------
newtype Per a b = Rate Double
deriving stock (Show, Eq, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving (Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON) via Double
deriving (Semigroup, Monoid) via Product Double
instance Arbitrary (Per a b) where arbitrary = genericArbitrary
invertRate :: a `Per` b -> b `Per` a
invertRate (Rate p) = Rate $ 1 / p
invertedRate :: Iso (a `Per` b) (b' `Per` a') (b `Per` a) (a' `Per` b')
invertedRate = iso invertRate invertRate
infixl 7 |*|
(|*|) :: (Scalar a, Scalar b) => a `Per` b -> b -> a
(|*|) (Rate rate) b = fromScalar $ rate * scalar b
newtype Ticks = Ticks Word
deriving stock (Show, Eq, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving (Num, Ord, Bounded, Enum, Integral, Real, ToJSON, FromJSON) via Word
deriving (Semigroup, Monoid) via (Sum Word)
deriving Scalar via ScalarIntegral Ticks
instance Arbitrary Ticks where arbitrary = genericArbitrary
newtype Tiles = Tiles Double
deriving stock (Show, Eq, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving (Num, Ord, Enum, Real, ToJSON, FromJSON, Scalar) via Double
deriving (Semigroup, Monoid) via (Sum Double)
instance Arbitrary Tiles where arbitrary = genericArbitrary
type TicksPerTile = Ticks `Per` Tiles
type TilesPerTick = Tiles `Per` Ticks
timesTiles :: TicksPerTile -> Tiles -> Ticks
timesTiles = (|*|)
--------------------------------------------------------------------------------
newtype Hitpoints = Hitpoints Word
deriving stock (Show, Eq, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving (Arbitrary, Num, Ord, Bounded, Enum, Integral, Real, ToJSON, FromJSON)
via Word
deriving (Semigroup, Monoid) via Sum Word
--------------------------------------------------------------------------------
data Box a = Box
{ _topLeftCorner :: V2 a
, _dimensions :: V2 a
}
deriving stock (Show, Eq, Ord, Functor, Generic)
deriving Arbitrary via GenericArbitrary (Box a)
makeFieldsNoPrefix ''Box
bottomRightCorner :: Num a => Box a -> V2 a
bottomRightCorner box =
V2 (box ^. topLeftCorner . L._x + box ^. dimensions . L._x)
(box ^. topLeftCorner . L._y + box ^. dimensions . L._y)
setBottomRightCorner :: (Num a, Ord a) => Box a -> V2 a -> Box a
setBottomRightCorner box br@(V2 brx bry)
| brx < box ^. topLeftCorner . L._x || bry < box ^. topLeftCorner . L._y
= box & topLeftCorner .~ br
& dimensions . L._x .~ ((box ^. topLeftCorner . L._x) - brx)
& dimensions . L._y .~ ((box ^. topLeftCorner . L._y) - bry)
| otherwise
= box & dimensions . L._x .~ (brx - (box ^. topLeftCorner . L._x))
& dimensions . L._y .~ (bry - (box ^. topLeftCorner . L._y))
inBox :: (Ord a, Num a) => Box a -> V2 a -> Bool
inBox box pt = flip all [L._x, L._y] $ \component ->
between (box ^. topLeftCorner . component)
(box ^. to bottomRightCorner . component)
(pt ^. component)
boxIntersects :: (Ord a, Num a) => Box a -> Box a -> Bool
boxIntersects box₁ box₂
= any (inBox box₁) [box₂ ^. topLeftCorner, bottomRightCorner box₂]
boxCenter :: (Fractional a) => Box a -> V2 a
boxCenter box = V2 cx cy
where
cx = box ^. topLeftCorner . L._x + (box ^. dimensions . L._x / 2)
cy = box ^. topLeftCorner . L._y + (box ^. dimensions . L._y / 2)
boxEdge :: (Enum a, Num a) => Box a -> Edge -> [V2 a]
boxEdge box LeftEdge =
V2 (box ^. topLeftCorner . L._x)
<$> [box ^. topLeftCorner . L._y .. box ^. to bottomRightCorner . L._y]
boxEdge box RightEdge =
V2 (box ^. to bottomRightCorner . L._x)
<$> [box ^. to bottomRightCorner . L._y .. box ^. to bottomRightCorner . L._y]
boxEdge box TopEdge =
flip V2 (box ^. topLeftCorner . L._y)
<$> [box ^. topLeftCorner . L._x .. box ^. to bottomRightCorner . L._x]
boxEdge box BottomEdge =
flip V2 (box ^. to bottomRightCorner . L._y)
<$> [box ^. topLeftCorner . L._x .. box ^. to bottomRightCorner . L._x]

39
users/glittershark/xanthous/src/Xanthous/Data/App.hs Normal file
View file

@ -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

68
users/glittershark/xanthous/src/Xanthous/Data/Entities.hs Normal file
View file

@ -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
}

56
users/glittershark/xanthous/src/Xanthous/Data/EntityChar.hs Normal file
View file

@ -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"

272
users/glittershark/xanthous/src/Xanthous/Data/EntityMap.hs Normal file
View file

@ -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

64
users/glittershark/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs Normal file
View file

@ -0,0 +1,64 @@
--------------------------------------------------------------------------------
module Xanthous.Data.EntityMap.Graphics
( visiblePositions
, visibleEntities
, linesOfSight
, canSee
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude hiding (lines)
--------------------------------------------------------------------------------
import Xanthous.Util (takeWhileInclusive)
import Xanthous.Data
import Xanthous.Data.Entities
import Xanthous.Data.EntityMap
import Xanthous.Game.State
import Xanthous.Util.Graphics (circle, line)
--------------------------------------------------------------------------------
-- | Returns a set of positions that are visible, when taking into account
-- 'blocksVision', from the given position, within the given radius.
visiblePositions
:: Entity e
=> Position
-> Word -- ^ Vision radius
-> EntityMap e
-> Set Position
visiblePositions pos radius
= setFromList . positions . visibleEntities pos radius
-- | Returns a list of individual lines of sight, each of which is a list of
-- entities at positions on that line of sight
linesOfSight
:: forall e. Entity e
=> Position
-> Word
-> EntityMap e
-> [[(Position, Vector (EntityID, e))]]
linesOfSight (view _Position -> pos) visionRadius em
= entitiesOnLines
<&> takeWhileInclusive
(none (view blocksVision . entityAttributes . snd) . snd)
where
radius = circle pos $ fromIntegral visionRadius
lines = line pos <$> radius
entitiesOnLines :: [[(Position, Vector (EntityID, e))]]
entitiesOnLines = lines <&> map getPositionedAt
getPositionedAt :: (Int, Int) -> (Position, Vector (EntityID, e))
getPositionedAt p =
let ppos = _Position # p
in (ppos, over _2 (view positioned) <$> atPositionWithIDs ppos em)
-- | Given a point and a radius of vision, returns a list of all entities that
-- are *visible* (eg, not blocked by an entity that obscures vision) from that
-- point
visibleEntities :: Entity e => Position -> Word -> EntityMap e -> EntityMap e
visibleEntities pos visionRadius
= fromEIDsAndPositioned
. foldMap (\(p, es) -> over _2 (Positioned p) <$> es)
. fold
. linesOfSight pos visionRadius
canSee :: Entity e => (e -> Bool) -> Position -> Word -> EntityMap e -> Bool
canSee match pos radius = any match . visibleEntities pos radius
-- ^ this might be optimizable

170
users/glittershark/xanthous/src/Xanthous/Data/Levels.hs Normal file
View file

@ -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)

227
users/glittershark/xanthous/src/Xanthous/Data/NestedMap.hs Normal file
View file

@ -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

94
users/glittershark/xanthous/src/Xanthous/Data/VectorBag.hs Normal file
View file

@ -0,0 +1,94 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
module Xanthous.Data.VectorBag
(VectorBag(..)
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
import Data.Aeson
import qualified Data.Vector as V
import Test.QuickCheck
import Test.QuickCheck.Instances.Vector ()
--------------------------------------------------------------------------------
-- | Acts exactly like a Vector, except ignores order when testing for equality
newtype VectorBag a = VectorBag (Vector a)
deriving stock
( Traversable
, Generic
)
deriving newtype
( Show
, Read
, Foldable
, FromJSON
, FromJSON1
, ToJSON
, Reversing
, Applicative
, Functor
, Monad
, Monoid
, Semigroup
, Arbitrary
, CoArbitrary
)
makeWrapped ''VectorBag
instance Function a => Function (VectorBag a) where
function = functionMap (\(VectorBag v) -> v) VectorBag
type instance Element (VectorBag a) = a
deriving via (Vector a) instance MonoFoldable (VectorBag a)
deriving via (Vector a) instance GrowingAppend (VectorBag a)
deriving via (Vector a) instance SemiSequence (VectorBag a)
deriving via (Vector a) instance MonoPointed (VectorBag a)
deriving via (Vector a) instance MonoFunctor (VectorBag a)
instance Cons (VectorBag a) (VectorBag b) a b where
_Cons = prism (\(x, VectorBag xs) -> VectorBag $ x <| xs) $ \(VectorBag v) ->
if V.null v
then Left (VectorBag mempty)
else Right (V.unsafeHead v, VectorBag $ V.unsafeTail v)
instance AsEmpty (VectorBag a) where
_Empty = prism' (const $ VectorBag Empty) $ \case
(VectorBag Empty) -> Just ()
_ -> Nothing
{-
TODO:
, Ixed
, FoldableWithIndex
, FunctorWithIndex
, TraversableWithIndex
, Snoc
, Each
-}
instance Ord a => Eq (VectorBag a) where
(==) = (==) `on` (view _Wrapped . sort)
instance Ord a => Ord (VectorBag a) where
compare = compare `on` (view _Wrapped . sort)
instance MonoTraversable (VectorBag a) where
otraverse f (VectorBag v) = VectorBag <$> otraverse f v
instance IsSequence (VectorBag a) where
fromList = VectorBag . fromList
break prd (VectorBag v) = bimap VectorBag VectorBag $ break prd v
span prd (VectorBag v) = bimap VectorBag VectorBag $ span prd v
dropWhile prd (VectorBag v) = VectorBag $ dropWhile prd v
takeWhile prd (VectorBag v) = VectorBag $ takeWhile prd v
splitAt idx (VectorBag v) = bimap VectorBag VectorBag $ splitAt idx v
unsafeSplitAt idx (VectorBag v) =
bimap VectorBag VectorBag $ unsafeSplitAt idx v
take n (VectorBag v) = VectorBag $ take n v
unsafeTake n (VectorBag v) = VectorBag $ unsafeTake n v
drop n (VectorBag v) = VectorBag $ drop n v
unsafeDrop n (VectorBag v) = VectorBag $ unsafeDrop n v
partition p (VectorBag v) = bimap VectorBag VectorBag $ partition p v

276
users/glittershark/xanthous/src/Xanthous/Entities/Character.hs Normal file
View file

@ -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

92
users/glittershark/xanthous/src/Xanthous/Entities/Creature.hs Normal file
View file

@ -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) #-}

64
users/glittershark/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs Normal file
View file

@ -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

31
users/glittershark/xanthous/src/Xanthous/Entities/Draw/Util.hs Normal file
View file

@ -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

60
users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs Normal file
View file

@ -0,0 +1,60 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
--------------------------------------------------------------------------------
module Xanthous.Entities.Entities () where
--------------------------------------------------------------------------------
import Xanthous.Prelude
--------------------------------------------------------------------------------
import Test.QuickCheck
import qualified Test.QuickCheck.Gen as Gen
import Data.Aeson
--------------------------------------------------------------------------------
import Xanthous.Entities.Character
import Xanthous.Entities.Item
import Xanthous.Entities.Creature
import Xanthous.Entities.Environment
import Xanthous.Game.State
import Xanthous.Util.QuickCheck
import Data.Aeson.Generic.DerivingVia
--------------------------------------------------------------------------------
instance Arbitrary SomeEntity where
arbitrary = Gen.oneof
[ SomeEntity <$> arbitrary @Character
, SomeEntity <$> arbitrary @Item
, SomeEntity <$> arbitrary @Creature
, SomeEntity <$> arbitrary @Wall
, SomeEntity <$> arbitrary @Door
, SomeEntity <$> arbitrary @GroundMessage
, SomeEntity <$> arbitrary @Staircase
]
instance FromJSON SomeEntity where
parseJSON = withObject "Entity" $ \obj -> do
(entityType :: Text) <- obj .: "type"
case entityType of
"Character" -> SomeEntity @Character <$> obj .: "data"
"Item" -> SomeEntity @Item <$> obj .: "data"
"Creature" -> SomeEntity @Creature <$> obj .: "data"
"Wall" -> SomeEntity @Wall <$> obj .: "data"
"Door" -> SomeEntity @Door <$> obj .: "data"
"GroundMessage" -> SomeEntity @GroundMessage <$> obj .: "data"
"Staircase" -> SomeEntity @Staircase <$> obj .: "data"
_ -> fail . unpack $ "Invalid entity type \"" <> entityType <> "\""
deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameLevel
instance FromJSON GameLevel
deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameState
instance FromJSON GameState
instance Entity SomeEntity where
entityAttributes (SomeEntity ent) = entityAttributes ent
description (SomeEntity ent) = description ent
entityChar (SomeEntity ent) = entityChar ent
entityCollision (SomeEntity ent) = entityCollision ent
instance Function SomeEntity where
function = functionJSON
instance CoArbitrary SomeEntity where
coarbitrary = coarbitrary . encode

14
users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs-boot Normal file
View file

@ -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

160
users/glittershark/xanthous/src/Xanthous/Entities/Environment.hs Normal file
View file

@ -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

49
users/glittershark/xanthous/src/Xanthous/Entities/Item.hs Normal file
View file

@ -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

133
users/glittershark/xanthous/src/Xanthous/Entities/RawTypes.hs Normal file
View file

@ -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

59
users/glittershark/xanthous/src/Xanthous/Entities/Raws.hs Normal file
View file

@ -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

13
users/glittershark/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml Normal file
View file

@ -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

12
users/glittershark/xanthous/src/Xanthous/Entities/Raws/noodles.yaml Normal file
View file

@ -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!

14
users/glittershark/xanthous/src/Xanthous/Entities/Raws/stick.yaml Normal file
View file

@ -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.

72
users/glittershark/xanthous/src/Xanthous/Game.hs Normal file
View file

@ -0,0 +1,72 @@
module Xanthous.Game
( GameState(..)
, levels
, entities
, revealedPositions
, messageHistory
, randomGen
, promptState
, GamePromptState(..)
, getInitialState
, initialStateFromSeed
, positionedCharacter
, character
, characterPosition
, updateCharacterVision
, characterVisiblePositions
, entitiesAtCharacter
-- * Messages
, MessageHistory(..)
, HasMessages(..)
, HasTurn(..)
, HasDisplayedTurn(..)
, pushMessage
, previousMessage
, nextTurn
-- * Collisions
, Collision(..)
, collisionAt
-- * App monad
, AppT(..)
-- * Saving the game
, saveGame
, loadGame
, saved
-- * Debug State
, DebugState(..)
, debugState
, allRevealed
) where
--------------------------------------------------------------------------------
import qualified Codec.Compression.Zlib as Zlib
import Codec.Compression.Zlib.Internal (DecompressError)
import qualified Data.Aeson as JSON
import System.IO.Unsafe
--------------------------------------------------------------------------------
import Xanthous.Prelude
import Xanthous.Game.State
import Xanthous.Game.Lenses
import Xanthous.Game.Arbitrary ()
import Xanthous.Entities.Entities ()
--------------------------------------------------------------------------------
saveGame :: GameState -> LByteString
saveGame = Zlib.compress . JSON.encode
loadGame :: LByteString -> Maybe GameState
loadGame = JSON.decode <=< decompressZlibMay
where
decompressZlibMay bs
= unsafeDupablePerformIO
$ (let r = Zlib.decompress bs in r `seq` pure (Just r))
`catch` \(_ :: DecompressError) -> pure Nothing
saved :: Prism' LByteString GameState
saved = prism' saveGame loadGame

50
users/glittershark/xanthous/src/Xanthous/Game/Arbitrary.hs Normal file
View file

@ -0,0 +1,50 @@
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE RecordWildCards #-}
--------------------------------------------------------------------------------
module Xanthous.Game.Arbitrary where
--------------------------------------------------------------------------------
import Xanthous.Prelude hiding (foldMap)
--------------------------------------------------------------------------------
import Test.QuickCheck
import System.Random
import Data.Foldable (foldMap)
--------------------------------------------------------------------------------
import Xanthous.Data.Levels
import qualified Xanthous.Data.EntityMap as EntityMap
import Xanthous.Entities.Entities ()
import Xanthous.Entities.Character
import Xanthous.Game.State
import Xanthous.Util.QuickCheck (GenericArbitrary(..))
--------------------------------------------------------------------------------
deriving via GenericArbitrary GameLevel instance Arbitrary GameLevel
instance Arbitrary GameState where
arbitrary = do
chr <- arbitrary @Character
_upStaircasePosition <- arbitrary
_messageHistory <- arbitrary
levs <- arbitrary @(Levels GameLevel)
_levelRevealedPositions <-
fmap setFromList
. sublistOf
. foldMap (EntityMap.positions . _levelEntities)
$ levs
let (_characterEntityID, _levelEntities) =
EntityMap.insertAtReturningID _upStaircasePosition (SomeEntity chr)
$ levs ^. current . levelEntities
_levels = levs & current .~ GameLevel {..}
_randomGen <- mkStdGen <$> arbitrary
let _promptState = NoPrompt -- TODO
_activePanel <- arbitrary
_debugState <- arbitrary
let _autocommand = NoAutocommand
pure $ GameState {..}
instance CoArbitrary GameLevel
instance Function GameLevel
instance CoArbitrary GameState
instance Function GameState

166
users/glittershark/xanthous/src/Xanthous/Game/Draw.hs Normal file
View file

@ -0,0 +1,166 @@
--------------------------------------------------------------------------------
module Xanthous.Game.Draw
( drawGame
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
import Brick hiding (loc, on)
import Brick.Widgets.Border
import Brick.Widgets.Border.Style
import Brick.Widgets.Edit
--------------------------------------------------------------------------------
import Xanthous.Data
import Xanthous.Data.App (ResourceName, Panel(..))
import qualified Xanthous.Data.App as Resource
import Xanthous.Data.EntityMap (EntityMap, atPosition)
import qualified Xanthous.Data.EntityMap as EntityMap
import Xanthous.Game.State
import Xanthous.Entities.Character
import Xanthous.Entities.Item (Item)
import Xanthous.Game
( GameState(..)
, entities
, revealedPositions
, characterPosition
, characterVisiblePositions
, character
, MessageHistory(..)
, messageHistory
, GamePromptState(..)
, promptState
, debugState, allRevealed
)
import Xanthous.Game.Prompt
import Xanthous.Orphans ()
--------------------------------------------------------------------------------
cursorPosition :: GameState -> Widget ResourceName -> Widget ResourceName
cursorPosition game
| WaitingPrompt _ (Prompt _ SPointOnMap (PointOnMapPromptState pos) _ _)
<- game ^. promptState
= showCursor Resource.Prompt (pos ^. loc)
| otherwise
= showCursor Resource.Character (game ^. characterPosition . loc)
drawMessages :: MessageHistory -> Widget ResourceName
drawMessages = txtWrap . (<> " ") . unwords . reverse . oextract
drawPromptState :: GamePromptState m -> Widget ResourceName
drawPromptState NoPrompt = emptyWidget
drawPromptState (WaitingPrompt msg (Prompt _ pt ps pri _)) =
case (pt, ps, pri) of
(SStringPrompt, StringPromptState edit, _) ->
txtWrap msg <+> txt " " <+> renderEditor (txt . fold) True edit
(SDirectionPrompt, DirectionPromptState, _) -> txtWrap msg
(SContinue, _, _) -> txtWrap msg
(SMenu, _, menuItems) ->
txtWrap msg
<=> foldl' (<=>) emptyWidget (map drawMenuItem $ itoList menuItems)
_ -> txtWrap msg
where
drawMenuItem (chr, MenuOption m _) =
str ("[" <> pure chr <> "] ") <+> txtWrap m
drawEntities
:: (Position -> Bool)
-- ^ Is a given position directly visible to the character?
-> (Position -> Bool)
-- ^ Has a given position *ever* been seen by the character?
-> EntityMap SomeEntity -- ^ all entities
-> Widget ResourceName
drawEntities isVisible isRevealed allEnts
= vBox rows
where
entityPositions = EntityMap.positions allEnts
maxY = fromMaybe 0 $ maximumOf (folded . y) entityPositions
maxX = fromMaybe 0 $ maximumOf (folded . x) entityPositions
rows = mkRow <$> [0..maxY]
mkRow rowY = hBox $ renderEntityAt . flip Position rowY <$> [0..maxX]
renderEntityAt pos
= let entitiesAtPosition = allEnts ^. atPosition pos
immobileEntitiesAtPosition =
filter (not . entityCanMove) entitiesAtPosition
in renderTopEntity pos
$ if | isVisible pos -> entitiesAtPosition
| isRevealed pos -> immobileEntitiesAtPosition
| otherwise -> mempty
renderTopEntity pos ents
= let neighbors = EntityMap.neighbors pos allEnts
in maybe (str " ") (drawWithNeighbors neighbors)
$ maximumBy (compare `on` drawPriority)
<$> fromNullable ents
drawMap :: GameState -> Widget ResourceName
drawMap game
= viewport Resource.MapViewport Both
. cursorPosition game
$ drawEntities
(`member` characterVisiblePositions game)
(\pos -> (game ^. debugState . allRevealed)
|| (pos `member` (game ^. revealedPositions)))
(game ^. entities)
bullet :: Char
bullet = '•'
drawInventoryPanel :: GameState -> Widget ResourceName
drawInventoryPanel game
= drawWielded (game ^. character . inventory . wielded)
<=> drawBackpack (game ^. character . inventory . backpack)
where
drawWielded (Hands Nothing Nothing) = emptyWidget
drawWielded (DoubleHanded i) =
txtWrap $ "You are holding " <> description i <> " in both hands"
drawWielded (Hands l r) = drawHand "left" l <=> drawHand "right" r
drawHand side = maybe emptyWidget $ \i ->
txtWrap ( "You are holding "
<> description i
<> " in your " <> side <> " hand"
)
<=> txt " "
drawBackpack :: Vector Item -> Widget ResourceName
drawBackpack Empty = txtWrap "Your backpack is empty right now."
drawBackpack backpackItems
= txtWrap ( "You are currently carrying the following items in your "
<> "backpack:")
<=> txt " "
<=> foldl' (<=>) emptyWidget
(map
(txtWrap . ((bullet <| " ") <>) . description)
backpackItems)
drawPanel :: GameState -> Panel -> Widget ResourceName
drawPanel game panel
= border
. hLimit 35
. viewport (Resource.Panel panel) Vertical
. case panel of
InventoryPanel -> drawInventoryPanel
$ game
drawCharacterInfo :: Character -> Widget ResourceName
drawCharacterInfo ch = txt " " <+> charName <+> charHitpoints
where
charName | Just n <- ch ^. characterName
= txt $ n <> " "
| otherwise
= emptyWidget
charHitpoints
= txt "Hitpoints: "
<+> txt (tshow $ let Hitpoints hp = characterHitpoints ch in hp)
drawGame :: GameState -> [Widget ResourceName]
drawGame game
= pure
. withBorderStyle unicode
$ case game ^. promptState of
NoPrompt -> drawMessages (game ^. messageHistory)
_ -> emptyWidget
<=> drawPromptState (game ^. promptState)
<=>
(maybe emptyWidget (drawPanel game) (game ^. activePanel)
<+> border (drawMap game)
)
<=> drawCharacterInfo (game ^. character)

19
users/glittershark/xanthous/src/Xanthous/Game/Env.hs Normal file
View file

@ -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) #-}

131
users/glittershark/xanthous/src/Xanthous/Game/Lenses.hs Normal file
View file

@ -0,0 +1,131 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
--------------------------------------------------------------------------------
module Xanthous.Game.Lenses
( positionedCharacter
, character
, characterPosition
, updateCharacterVision
, characterVisiblePositions
, characterVisibleEntities
, getInitialState
, initialStateFromSeed
, entitiesAtCharacter
-- * Collisions
, Collision(..)
, entitiesCollision
, collisionAt
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
--------------------------------------------------------------------------------
import System.Random
import Control.Monad.State
import Control.Monad.Random (getRandom)
--------------------------------------------------------------------------------
import Xanthous.Game.State
import Xanthous.Data
import Xanthous.Data.Levels
import qualified Xanthous.Data.EntityMap as EntityMap
import Xanthous.Data.EntityMap.Graphics
(visiblePositions, visibleEntities)
import Xanthous.Data.VectorBag
import Xanthous.Entities.Character (Character, mkCharacter)
import {-# SOURCE #-} Xanthous.Entities.Entities ()
--------------------------------------------------------------------------------
getInitialState :: IO GameState
getInitialState = initialStateFromSeed <$> getRandom
initialStateFromSeed :: Int -> GameState
initialStateFromSeed seed =
let _randomGen = mkStdGen seed
chr = mkCharacter
_upStaircasePosition = Position 0 0
(_characterEntityID, _levelEntities)
= EntityMap.insertAtReturningID
_upStaircasePosition
(SomeEntity chr)
mempty
_levelRevealedPositions = mempty
level = GameLevel {..}
_levels = oneLevel level
_messageHistory = mempty
_promptState = NoPrompt
_activePanel = Nothing
_debugState = DebugState
{ _allRevealed = False
}
_autocommand = NoAutocommand
in GameState {..}
positionedCharacter :: Lens' GameState (Positioned Character)
positionedCharacter = lens getPositionedCharacter setPositionedCharacter
where
setPositionedCharacter :: GameState -> Positioned Character -> GameState
setPositionedCharacter game chr
= game
& entities . at (game ^. characterEntityID)
?~ fmap SomeEntity chr
getPositionedCharacter :: GameState -> Positioned Character
getPositionedCharacter game
= over positioned
( fromMaybe (error "Invariant error: Character was not a character!")
. downcastEntity
)
. fromMaybe (error "Invariant error: Character not found!")
$ EntityMap.lookupWithPosition
(game ^. characterEntityID)
(game ^. entities)
character :: Lens' GameState Character
character = positionedCharacter . positioned
characterPosition :: Lens' GameState Position
characterPosition = positionedCharacter . position
visionRadius :: Word
visionRadius = 12 -- TODO make this dynamic
-- | Update the revealed entities at the character's position based on their
-- vision
updateCharacterVision :: GameState -> GameState
updateCharacterVision game
= game & revealedPositions <>~ characterVisiblePositions game
characterVisiblePositions :: GameState -> Set Position
characterVisiblePositions game =
let charPos = game ^. characterPosition
in visiblePositions charPos visionRadius $ game ^. entities
characterVisibleEntities :: GameState -> EntityMap.EntityMap SomeEntity
characterVisibleEntities game =
let charPos = game ^. characterPosition
in visibleEntities charPos visionRadius $ game ^. entities
entitiesCollision
:: ( Functor f
, forall xx. MonoFoldable (f xx)
, forall xx. Element (f xx) ~ xx
, Element (f (Maybe Collision)) ~ Maybe Collision
, Show (f (Maybe Collision))
, Show (f SomeEntity)
)
=> f SomeEntity
-> Maybe Collision
entitiesCollision = join . maximumMay . fmap entityCollision
collisionAt :: MonadState GameState m => Position -> m (Maybe Collision)
collisionAt p = uses (entities . EntityMap.atPosition p) entitiesCollision
entitiesAtCharacter :: Lens' GameState (VectorBag SomeEntity)
entitiesAtCharacter = lens getter setter
where
getter gs = gs ^. entities . EntityMap.atPosition (gs ^. characterPosition)
setter gs ents = gs
& entities . EntityMap.atPosition (gs ^. characterPosition) .~ ents

289
users/glittershark/xanthous/src/Xanthous/Game/Prompt.hs Normal file
View file

@ -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

558
users/glittershark/xanthous/src/Xanthous/Game/State.hs Normal file
View file

@ -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

154
users/glittershark/xanthous/src/Xanthous/Generators.hs Normal file
View file

@ -0,0 +1,154 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
module Xanthous.Generators
( generate
, Generator(..)
, SGenerator(..)
, GeneratorInput
, generateFromInput
, parseGeneratorInput
, showCells
, Level(..)
, levelWalls
, levelItems
, levelCreatures
, levelDoors
, levelCharacterPosition
, levelTutorialMessage
, generateLevel
, levelToEntityMap
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
import Data.Array.Unboxed
import System.Random (RandomGen)
import qualified Options.Applicative as Opt
import Control.Monad.Random
--------------------------------------------------------------------------------
import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
import qualified Xanthous.Generators.Dungeon as Dungeon
import Xanthous.Generators.Util
import Xanthous.Generators.LevelContents
import Xanthous.Data (Dimensions, Position'(Position), Position)
import Xanthous.Data.EntityMap (EntityMap, _EntityMap)
import qualified Xanthous.Data.EntityMap as EntityMap
import Xanthous.Entities.Environment
import Xanthous.Entities.Item (Item)
import Xanthous.Entities.Creature (Creature)
import Xanthous.Game.State (SomeEntity(..))
--------------------------------------------------------------------------------
data Generator
= CaveAutomata
| Dungeon
deriving stock (Show, Eq)
data SGenerator (gen :: Generator) where
SCaveAutomata :: SGenerator 'CaveAutomata
SDungeon :: SGenerator 'Dungeon
type family Params (gen :: Generator) :: Type where
Params 'CaveAutomata = CaveAutomata.Params
Params 'Dungeon = Dungeon.Params
generate
:: RandomGen g
=> SGenerator gen
-> Params gen
-> Dimensions
-> g
-> Cells
generate SCaveAutomata = CaveAutomata.generate
generate SDungeon = Dungeon.generate
data GeneratorInput where
GeneratorInput :: forall gen. SGenerator gen -> Params gen -> GeneratorInput
generateFromInput :: RandomGen g => GeneratorInput -> Dimensions -> g -> Cells
generateFromInput (GeneratorInput sg ps) = generate sg ps
parseGeneratorInput :: Opt.Parser GeneratorInput
parseGeneratorInput = Opt.subparser
$ generatorCommand SCaveAutomata
"cave"
"Cellular-automata based cave generator"
CaveAutomata.parseParams
<> generatorCommand SDungeon
"dungeon"
"Classic dungeon map generator"
Dungeon.parseParams
where
generatorCommand sgen name desc parseParams =
Opt.command name
(Opt.info
(GeneratorInput <$> pure sgen <*> parseParams)
(Opt.progDesc desc)
)
showCells :: Cells -> Text
showCells arr =
let ((minX, minY), (maxX, maxY)) = bounds arr
showCellVal True = "x"
showCellVal False = " "
showCell = showCellVal . (arr !)
row r = foldMap (showCell . (, r)) [minX..maxX]
rows = row <$> [minY..maxY]
in intercalate "\n" rows
cellsToWalls :: Cells -> EntityMap Wall
cellsToWalls cells = foldl' maybeInsertWall mempty . assocs $ cells
where
maybeInsertWall em (pos@(x, y), True)
| not (surroundedOnAllSides pos) =
let x' = fromIntegral x
y' = fromIntegral y
in EntityMap.insertAt (Position x' y') Wall em
maybeInsertWall em _ = em
surroundedOnAllSides pos = numAliveNeighbors cells pos == 8
--------------------------------------------------------------------------------
data Level = Level
{ _levelWalls :: !(EntityMap Wall)
, _levelDoors :: !(EntityMap Door)
, _levelItems :: !(EntityMap Item)
, _levelCreatures :: !(EntityMap Creature)
, _levelTutorialMessage :: !(EntityMap GroundMessage)
, _levelStaircases :: !(EntityMap Staircase)
, _levelCharacterPosition :: !Position
}
deriving stock (Generic)
deriving anyclass (NFData)
makeLenses ''Level
generateLevel
:: MonadRandom m
=> SGenerator gen
-> Params gen
-> Dimensions
-> m Level
generateLevel gen ps dims = do
rand <- mkStdGen <$> getRandom
let cells = generate gen ps dims rand
_levelWalls = cellsToWalls cells
_levelItems <- randomItems cells
_levelCreatures <- randomCreatures cells
_levelDoors <- randomDoors cells
_levelCharacterPosition <- chooseCharacterPosition cells
let upStaircase = _EntityMap # [(_levelCharacterPosition, UpStaircase)]
downStaircase <- placeDownStaircase cells
let _levelStaircases = upStaircase <> downStaircase
_levelTutorialMessage <- tutorialMessage cells _levelCharacterPosition
pure Level {..}
levelToEntityMap :: Level -> EntityMap SomeEntity
levelToEntityMap level
= (SomeEntity <$> level ^. levelWalls)
<> (SomeEntity <$> level ^. levelDoors)
<> (SomeEntity <$> level ^. levelItems)
<> (SomeEntity <$> level ^. levelCreatures)
<> (SomeEntity <$> level ^. levelTutorialMessage)
<> (SomeEntity <$> level ^. levelStaircases)

110
users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs Normal file
View file

@ -0,0 +1,110 @@
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
module Xanthous.Generators.CaveAutomata
( Params(..)
, defaultParams
, parseParams
, generate
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
import Control.Monad.Random (RandomGen, runRandT)
import Data.Array.ST
import Data.Array.Unboxed
import qualified Options.Applicative as Opt
--------------------------------------------------------------------------------
import Xanthous.Util (between)
import Xanthous.Util.Optparse
import Xanthous.Data (Dimensions, width, height)
import Xanthous.Generators.Util
--------------------------------------------------------------------------------
data Params = Params
{ _aliveStartChance :: Double
, _birthLimit :: Word
, _deathLimit :: Word
, _steps :: Word
}
deriving stock (Show, Eq, Generic)
makeLenses ''Params
defaultParams :: Params
defaultParams = Params
{ _aliveStartChance = 0.6
, _birthLimit = 3
, _deathLimit = 4
, _steps = 4
}
parseParams :: Opt.Parser Params
parseParams = Params
<$> Opt.option parseChance
( Opt.long "alive-start-chance"
<> Opt.value (defaultParams ^. aliveStartChance)
<> Opt.showDefault
<> Opt.help ( "Chance for each cell to start alive at the beginning of "
<> "the cellular automata"
)
<> Opt.metavar "CHANCE"
)
<*> Opt.option parseNeighbors
( Opt.long "birth-limit"
<> Opt.value (defaultParams ^. birthLimit)
<> Opt.showDefault
<> Opt.help "Minimum neighbor count required for birth of a cell"
<> Opt.metavar "NEIGHBORS"
)
<*> Opt.option parseNeighbors
( Opt.long "death-limit"
<> Opt.value (defaultParams ^. deathLimit)
<> Opt.showDefault
<> Opt.help "Maximum neighbor count required for death of a cell"
<> Opt.metavar "NEIGHBORS"
)
<*> Opt.option Opt.auto
( Opt.long "steps"
<> Opt.value (defaultParams ^. steps)
<> Opt.showDefault
<> Opt.help "Number of generations to run the automata for"
<> Opt.metavar "STEPS"
)
where
parseChance = readWithGuard
(between 0 1)
$ \res -> "Chance must be in the range [0,1], got: " <> show res
parseNeighbors = readWithGuard
(between 0 8)
$ \res -> "Neighbors must be in the range [0,8], got: " <> show res
generate :: RandomGen g => Params -> Dimensions -> g -> Cells
generate params dims gen
= runSTUArray
$ fmap fst
$ flip runRandT gen
$ generate' params dims
generate' :: RandomGen g => Params -> Dimensions -> CellM g s (MCells s)
generate' params dims = do
cells <- randInitialize dims $ params ^. aliveStartChance
let steps' = params ^. steps
when (steps' > 0)
$ for_ [0 .. pred steps'] . const $ stepAutomata cells dims params
-- Remove all but the largest contiguous region of unfilled space
(_: smallerRegions) <- lift $ regions @UArray . amap not <$> freeze cells
lift $ fillAllM (fold smallerRegions) cells
lift $ fillOuterEdgesM cells
pure cells
stepAutomata :: forall s g. MCells s -> Dimensions -> Params -> CellM g s ()
stepAutomata cells dims params = do
origCells <- lift $ cloneMArray @_ @(STUArray s) cells
for_ (range ((0, 0), (dims ^. width, dims ^. height))) $ \pos -> do
neighs <- lift $ numAliveNeighborsM origCells pos
origValue <- lift $ readArray origCells pos
lift . writeArray cells pos
$ if origValue
then neighs >= params ^. deathLimit
else neighs > params ^. birthLimit

191
users/glittershark/xanthous/src/Xanthous/Generators/Dungeon.hs Normal file
View file

@ -0,0 +1,191 @@
{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
module Xanthous.Generators.Dungeon
( Params(..)
, defaultParams
, parseParams
, generate
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude hiding ((:>))
--------------------------------------------------------------------------------
import Control.Monad.Random
import Data.Array.ST
import Data.Array.IArray (amap)
import Data.Stream.Infinite (Stream(..))
import qualified Data.Stream.Infinite as Stream
import qualified Data.Graph.Inductive.Graph as Graph
import Data.Graph.Inductive.PatriciaTree
import qualified Data.List.NonEmpty as NE
import Data.Maybe (fromJust)
import Linear.V2
import Linear.Metric
import qualified Options.Applicative as Opt
--------------------------------------------------------------------------------
import Xanthous.Random
import Xanthous.Data hiding (x, y, _x, _y, edges)
import Xanthous.Generators.Util
import Xanthous.Util.Graphics (delaunay, straightLine)
import Xanthous.Util.Graph (mstSubGraph)
--------------------------------------------------------------------------------
data Params = Params
{ _numRoomsRange :: (Word, Word)
, _roomDimensionRange :: (Word, Word)
, _connectednessRatioRange :: (Double, Double)
}
deriving stock (Show, Eq, Ord, Generic)
makeLenses ''Params
defaultParams :: Params
defaultParams = Params
{ _numRoomsRange = (6, 8)
, _roomDimensionRange = (3, 12)
, _connectednessRatioRange = (0.1, 0.15)
}
parseParams :: Opt.Parser Params
parseParams = Params
<$> parseRange
"num-rooms"
"number of rooms to generate in the dungeon"
"ROOMS"
(defaultParams ^. numRoomsRange)
<*> parseRange
"room-size"
"size in tiles of one of the sides of a room"
"TILES"
(defaultParams ^. roomDimensionRange)
<*> parseRange
"connectedness-ratio"
( "ratio of edges from the delaunay triangulation to re-add to the "
<> "minimum-spanning-tree")
"RATIO"
(defaultParams ^. connectednessRatioRange)
<**> Opt.helper
where
parseRange name desc metavar (defMin, defMax) =
(,)
<$> Opt.option Opt.auto
( Opt.long ("min-" <> name)
<> Opt.value defMin
<> Opt.showDefault
<> Opt.help ("Minimum " <> desc)
<> Opt.metavar metavar
)
<*> Opt.option Opt.auto
( Opt.long ("max-" <> name)
<> Opt.value defMax
<> Opt.showDefault
<> Opt.help ("Maximum " <> desc)
<> Opt.metavar metavar
)
generate :: RandomGen g => Params -> Dimensions -> g -> Cells
generate params dims gen
= amap not
$ runSTUArray
$ fmap fst
$ flip runRandT gen
$ generate' params dims
--------------------------------------------------------------------------------
generate' :: RandomGen g => Params -> Dimensions -> CellM g s (MCells s)
generate' params dims = do
cells <- initializeEmpty dims
rooms <- genRooms params dims
for_ rooms $ fillRoom cells
let fullRoomGraph = delaunayRoomGraph rooms
mst = mstSubGraph fullRoomGraph
mstEdges = Graph.edges mst
nonMSTEdges = filter (\(n₁, n₂, _) -> (n₁, n₂) `notElem` mstEdges)
$ Graph.labEdges fullRoomGraph
reintroEdgeCount <- floor . (* fromIntegral (length nonMSTEdges))
<$> getRandomR (params ^. connectednessRatioRange)
let reintroEdges = take reintroEdgeCount nonMSTEdges
corridorGraph = Graph.insEdges reintroEdges mst
corridors <- traverse
( uncurry corridorBetween
. over both (fromJust . Graph.lab corridorGraph)
) $ Graph.edges corridorGraph
for_ (join corridors) $ \pt -> lift $ writeArray cells pt True
pure cells
type Room = Box Word
genRooms :: MonadRandom m => Params -> Dimensions -> m [Room]
genRooms params dims = do
numRooms <- fromIntegral <$> getRandomR (params ^. numRoomsRange)
subRand . fmap (Stream.take numRooms . removeIntersecting []) . infinitely $ do
roomWidth <- getRandomR $ params ^. roomDimensionRange
roomHeight <- getRandomR $ params ^. roomDimensionRange
xPos <- getRandomR (0, dims ^. width - roomWidth)
yPos <- getRandomR (0, dims ^. height - roomHeight)
pure Box
{ _topLeftCorner = V2 xPos yPos
, _dimensions = V2 roomWidth roomHeight
}
where
removeIntersecting seen (room :> rooms)
| any (boxIntersects room) seen
= removeIntersecting seen rooms
| otherwise
= room :> removeIntersecting (room : seen) rooms
streamRepeat x = x :> streamRepeat x
infinitely = sequence . streamRepeat
delaunayRoomGraph :: [Room] -> Gr Room Double
delaunayRoomGraph rooms =
Graph.insEdges edges . Graph.insNodes nodes $ Graph.empty
where
edges = map (\((n₁, room₁), (n₂, room₂)) -> (n₁, n₂, roomDist room₁ room₂))
. over (mapped . both) snd
. delaunay @Double
. NE.fromList
. map (\p@(_, room) -> (boxCenter $ fromIntegral <$> room, p))
$ nodes
nodes = zip [0..] rooms
roomDist = distance `on` (boxCenter . fmap fromIntegral)
fillRoom :: MCells s -> Room -> CellM g s ()
fillRoom cells room =
let V2 posx posy = room ^. topLeftCorner
V2 dimx dimy = room ^. dimensions
in for_ [posx .. posx + dimx] $ \x ->
for_ [posy .. posy + dimy] $ \y ->
lift $ writeArray cells (x, y) True
corridorBetween :: MonadRandom m => Room -> Room -> m [(Word, Word)]
corridorBetween originRoom destinationRoom
= straightLine <$> origin <*> destination
where
origin = choose . NE.fromList . map toTuple =<< originEdge
destination = choose . NE.fromList . map toTuple =<< destinationEdge
originEdge = pickEdge originRoom originCorner
destinationEdge = pickEdge destinationRoom destinationCorner
pickEdge room corner = choose . over both (boxEdge room) $ cornerEdges corner
originCorner =
case ( compare (originRoom ^. topLeftCorner . _x)
(destinationRoom ^. topLeftCorner . _x)
, compare (originRoom ^. topLeftCorner . _y)
(destinationRoom ^. topLeftCorner . _y)
) of
(LT, LT) -> BottomRight
(LT, GT) -> TopRight
(GT, LT) -> BottomLeft
(GT, GT) -> TopLeft
(EQ, LT) -> BottomLeft
(EQ, GT) -> TopRight
(GT, EQ) -> TopLeft
(LT, EQ) -> BottomRight
(EQ, EQ) -> TopLeft -- should never happen
destinationCorner = opposite originCorner
toTuple (V2 x y) = (x, y)

130
users/glittershark/xanthous/src/Xanthous/Generators/LevelContents.hs Normal file
View file

@ -0,0 +1,130 @@
--------------------------------------------------------------------------------
module Xanthous.Generators.LevelContents
( chooseCharacterPosition
, randomItems
, randomCreatures
, randomDoors
, placeDownStaircase
, tutorialMessage
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude hiding (any, toList)
--------------------------------------------------------------------------------
import Control.Monad.Random
import Data.Array.IArray (amap, bounds, rangeSize, (!))
import qualified Data.Array.IArray as Arr
import Data.Foldable (any, toList)
--------------------------------------------------------------------------------
import Xanthous.Generators.Util
import Xanthous.Random
import Xanthous.Data ( Position, _Position, positionFromPair
, rotations, arrayNeighbors, Neighbors(..)
, neighborPositions
)
import Xanthous.Data.EntityMap (EntityMap, _EntityMap)
import Xanthous.Entities.Raws (rawsWithType, RawType)
import qualified Xanthous.Entities.Item as Item
import Xanthous.Entities.Item (Item)
import qualified Xanthous.Entities.Creature as Creature
import Xanthous.Entities.Creature (Creature)
import Xanthous.Entities.Environment
(GroundMessage(..), Door(..), unlockedDoor, Staircase(..))
import Xanthous.Messages (message_)
import Xanthous.Util.Graphics (circle)
--------------------------------------------------------------------------------
chooseCharacterPosition :: MonadRandom m => Cells -> m Position
chooseCharacterPosition = randomPosition
randomItems :: MonadRandom m => Cells -> m (EntityMap Item)
randomItems = randomEntities Item.newWithType (0.0004, 0.001)
placeDownStaircase :: MonadRandom m => Cells -> m (EntityMap Staircase)
placeDownStaircase cells = do
pos <- randomPosition cells
pure $ _EntityMap # [(pos, DownStaircase)]
randomDoors :: MonadRandom m => Cells -> m (EntityMap Door)
randomDoors cells = do
doorRatio <- getRandomR subsetRange
let numDoors = floor $ doorRatio * fromIntegral (length candidateCells)
doorPositions =
removeAdjacent . fmap positionFromPair . take numDoors $ candidateCells
doors = zip doorPositions $ repeat unlockedDoor
pure $ _EntityMap # doors
where
removeAdjacent =
foldr (\pos acc ->
if pos `elem` (acc >>= toList . neighborPositions)
then acc
else pos : acc
) []
candidateCells = filter doorable $ Arr.indices cells
subsetRange = (0.8 :: Double, 1.0)
doorable pos =
not (fromMaybe True $ cells ^? ix pos)
&& any (teeish . fmap (fromMaybe True))
(rotations $ arrayNeighbors cells pos)
-- only generate doors at the *ends* of hallways, eg (where O is walkable,
-- X is a wall, and D is a door):
--
-- O O O
-- X D X
-- O
teeish (fmap not -> (Neighbors tl t tr l r _ b _ )) =
and [tl, t, tr, b] && (and . fmap not) [l, r]
randomCreatures :: MonadRandom m => Cells -> m (EntityMap Creature)
randomCreatures = randomEntities Creature.newWithType (0.0007, 0.002)
tutorialMessage :: MonadRandom m
=> Cells
-> Position -- ^ CharacterPosition
-> m (EntityMap GroundMessage)
tutorialMessage cells characterPosition = do
let distance = 2
pos <- fmap (fromMaybe (error "No valid positions for tutorial message?"))
. choose . ChooseElement
$ accessiblePositionsWithin distance cells characterPosition
msg <- message_ ["tutorial", "message1"]
pure $ _EntityMap # [(pos, GroundMessage msg)]
where
accessiblePositionsWithin :: Int -> Cells -> Position -> [Position]
accessiblePositionsWithin dist valid pos =
review _Position
<$> filter (\(px, py) -> not $ valid ! (fromIntegral px, fromIntegral py))
(circle (pos ^. _Position) dist)
randomEntities
:: forall entity raw m. (MonadRandom m, RawType raw)
=> (raw -> entity)
-> (Float, Float)
-> Cells
-> m (EntityMap entity)
randomEntities newWithType sizeRange cells =
case fromNullable $ rawsWithType @raw of
Nothing -> pure mempty
Just raws -> do
let len = rangeSize $ bounds cells
(numEntities :: Int) <-
floor . (* fromIntegral len) <$> getRandomR sizeRange
entities <- for [0..numEntities] $ const $ do
pos <- randomPosition cells
raw <- choose raws
let entity = newWithType raw
pure (pos, entity)
pure $ _EntityMap # entities
randomPosition :: MonadRandom m => Cells -> m Position
randomPosition = fmap positionFromPair . choose . impureNonNull . cellCandidates
-- cellCandidates :: Cells -> Cells
cellCandidates :: Cells -> Set (Word, Word)
cellCandidates
-- find the largest contiguous region of cells in the cave.
= maximumBy (compare `on` length)
. fromMaybe (error "No regions generated! this should never happen.")
. fromNullable
. regions
-- cells ends up with true = wall, we want true = can put an item here
. amap not

221
users/glittershark/xanthous/src/Xanthous/Generators/Util.hs Normal file
View file

@ -0,0 +1,221 @@
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
--------------------------------------------------------------------------------
module Xanthous.Generators.Util
( MCells
, Cells
, CellM
, randInitialize
, initializeEmpty
, numAliveNeighborsM
, numAliveNeighbors
, fillOuterEdgesM
, cloneMArray
, floodFill
, regions
, fillAll
, fillAllM
, fromPoints
, fromPointsM
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude hiding (Foldable, toList, for_)
import Data.Array.ST
import Data.Array.Unboxed
import Control.Monad.ST
import Control.Monad.Random
import Data.Monoid
import Data.Foldable (Foldable, toList, for_)
import qualified Data.Set as Set
import Data.Semigroup.Foldable
--------------------------------------------------------------------------------
import Xanthous.Util (foldlMapM', maximum1, minimum1)
import Xanthous.Data (Dimensions, width, height)
--------------------------------------------------------------------------------
type MCells s = STUArray s (Word, Word) Bool
type Cells = UArray (Word, Word) Bool
type CellM g s a = RandT g (ST s) a
randInitialize :: RandomGen g => Dimensions -> Double -> CellM g s (MCells s)
randInitialize dims aliveChance = do
res <- initializeEmpty dims
for_ [0..dims ^. width] $ \i ->
for_ [0..dims ^. height] $ \j -> do
val <- (>= aliveChance) <$> getRandomR (0, 1)
lift $ writeArray res (i, j) val
pure res
initializeEmpty :: RandomGen g => Dimensions -> CellM g s (MCells s)
initializeEmpty dims =
lift $ newArray ((0, 0), (dims ^. width, dims ^. height)) False
numAliveNeighborsM
:: forall a i j m
. (MArray a Bool m, Ix (i, j), Integral i, Integral j)
=> a (i, j) Bool
-> (i, j)
-> m Word
numAliveNeighborsM cells (x, y) = do
cellBounds <- getBounds cells
getSum <$> foldlMapM'
(fmap (Sum . fromIntegral . fromEnum) . boundedGet cellBounds)
neighborPositions
where
boundedGet :: ((i, j), (i, j)) -> (Int, Int) -> m Bool
boundedGet ((minX, minY), (maxX, maxY)) (i, j)
| x <= minX
|| y <= minY
|| x >= maxX
|| y >= maxY
= pure True
| otherwise =
let nx = fromIntegral $ fromIntegral x + i
ny = fromIntegral $ fromIntegral y + j
in readArray cells (nx, ny)
neighborPositions :: [(Int, Int)]
neighborPositions = [(i, j) | i <- [-1..1], j <- [-1..1], (i, j) /= (0, 0)]
numAliveNeighbors
:: forall a i j
. (IArray a Bool, Ix (i, j), Integral i, Integral j)
=> a (i, j) Bool
-> (i, j)
-> Word
numAliveNeighbors cells (x, y) =
let cellBounds = bounds cells
in getSum $ foldMap
(Sum . fromIntegral . fromEnum . boundedGet cellBounds)
neighborPositions
where
boundedGet :: ((i, j), (i, j)) -> (Int, Int) -> Bool
boundedGet ((minX, minY), (maxX, maxY)) (i, j)
| x <= minX
|| y <= minY
|| x >= maxX
|| y >= maxY
= True
| otherwise =
let nx = fromIntegral $ fromIntegral x + i
ny = fromIntegral $ fromIntegral y + j
in cells ! (nx, ny)
neighborPositions :: [(Int, Int)]
neighborPositions = [(i, j) | i <- [-1..1], j <- [-1..1], (i, j) /= (0, 0)]
fillOuterEdgesM :: (MArray a Bool m, Ix i, Ix j) => a (i, j) Bool -> m ()
fillOuterEdgesM arr = do
((minX, minY), (maxX, maxY)) <- getBounds arr
for_ (range (minX, maxX)) $ \x -> do
writeArray arr (x, minY) True
writeArray arr (x, maxY) True
for_ (range (minY, maxY)) $ \y -> do
writeArray arr (minX, y) True
writeArray arr (maxX, y) True
cloneMArray
:: forall a a' i e m.
( Ix i
, MArray a e m
, MArray a' e m
, IArray UArray e
)
=> a i e
-> m (a' i e)
cloneMArray = thaw @_ @UArray <=< freeze
--------------------------------------------------------------------------------
-- | Flood fill a cell array starting at a point, returning a list of all the
-- (true) cell locations reachable from that point
floodFill :: forall a i j.
( IArray a Bool
, Ix (i, j)
, Enum i , Enum j
, Bounded i , Bounded j
, Eq i , Eq j
, Show i, Show j
)
=> a (i, j) Bool -- ^ array
-> (i, j) -- ^ position
-> Set (i, j)
floodFill = go mempty
where
go :: Set (i, j) -> a (i, j) Bool -> (i, j) -> Set (i, j)
-- TODO pass result in rather than passing seen in, return result
go res arr@(bounds -> arrBounds) idx@(x, y)
| not (inRange arrBounds idx) = res
| not (arr ! idx) = res
| otherwise =
let neighbors
= filter (inRange arrBounds)
. filter (/= idx)
. filter (`notMember` res)
$ (,)
<$> [(if x == minBound then x else pred x)
..
(if x == maxBound then x else succ x)]
<*> [(if y == minBound then y else pred y)
..
(if y == maxBound then y else succ y)]
in foldl' (\r idx' ->
if arr ! idx'
then r <> go (r & contains idx' .~ True) arr idx'
else r)
(res & contains idx .~ True) neighbors
-- | Gives a list of all the disconnected regions in a cell array, represented
-- each as lists of points
regions :: forall a i j.
( IArray a Bool
, Ix (i, j)
, Enum i , Enum j
, Bounded i , Bounded j
, Eq i , Eq j
, Show i, Show j
)
=> a (i, j) Bool
-> [Set (i, j)]
regions arr
| Just firstPoint <- findFirstPoint arr =
let region = floodFill arr firstPoint
arr' = fillAll region arr
in region : regions arr'
| otherwise = []
where
findFirstPoint :: a (i, j) Bool -> Maybe (i, j)
findFirstPoint = fmap fst . headMay . filter snd . assocs
fillAll :: (IArray a Bool, Ix i, Foldable f) => f i -> a i Bool -> a i Bool
fillAll ixes a = accum (const fst) a $ (, (False, ())) <$> toList ixes
fillAllM :: (MArray a Bool m, Ix i, Foldable f) => f i -> a i Bool -> m ()
fillAllM ixes a = for_ ixes $ \i -> writeArray a i False
fromPoints
:: forall a f i.
( IArray a Bool
, Ix i
, Functor f
, Foldable1 f
)
=> f (i, i)
-> a (i, i) Bool
fromPoints points =
let pts = Set.fromList $ toList points
dims = ( (minimum1 $ fst <$> points, minimum1 $ snd <$> points)
, (maximum1 $ fst <$> points, maximum1 $ snd <$> points)
)
in array dims $ range dims <&> \i -> (i, i `member` pts)
fromPointsM
:: (MArray a Bool m, Ix i, Element f ~ i, MonoFoldable f)
=> NonNull f
-> m (a i Bool)
fromPointsM points = do
arr <- newArray (minimum points, maximum points) False
fillAllM (otoList points) arr
pure arr

107
users/glittershark/xanthous/src/Xanthous/Messages.hs Normal file
View file

@ -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"

275
users/glittershark/xanthous/src/Xanthous/Messages/Template.hs Normal file
View file

@ -0,0 +1,275 @@
{-# LANGUAGE DeriveDataTypeable #-}
--------------------------------------------------------------------------------
module Xanthous.Messages.Template
( -- * Template AST
Template(..)
, Substitution(..)
, Filter(..)
-- ** Template AST transformations
, reduceTemplate
-- * Template parser
, template
, runParser
, errorBundlePretty
-- * Template pretty-printer
, ppTemplate
-- * Rendering templates
, TemplateVar(..)
, nested
, TemplateVars(..)
, vars
, RenderError
, render
)
where
--------------------------------------------------------------------------------
import Xanthous.Prelude hiding
(many, concat, try, elements, some, parts)
--------------------------------------------------------------------------------
import Test.QuickCheck hiding (label)
import Test.QuickCheck.Instances.Text ()
import Test.QuickCheck.Instances.Semigroup ()
import Test.QuickCheck.Checkers (EqProp)
import Control.Monad.Combinators.NonEmpty
import Data.List.NonEmpty (NonEmpty(..))
import Data.Data
import Text.Megaparsec hiding (sepBy1, some)
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L
import Data.Function (fix)
--------------------------------------------------------------------------------
import Xanthous.Util (EqEqProp(..))
--------------------------------------------------------------------------------
genIdentifier :: Gen Text
genIdentifier = pack <$> listOf1 (elements identifierChars)
identifierChars :: String
identifierChars = ['a'..'z'] <> ['A'..'Z'] <> ['-', '_']
newtype Filter = FilterName Text
deriving stock (Show, Eq, Ord, Generic, Data)
deriving anyclass (NFData)
deriving (IsString) via Text
instance Arbitrary Filter where
arbitrary = FilterName <$> genIdentifier
shrink (FilterName fn) = fmap FilterName . filter (not . null) $ shrink fn
data Substitution
= SubstPath (NonEmpty Text)
| SubstFilter Substitution Filter
deriving stock (Show, Eq, Ord, Generic, Data)
deriving anyclass (NFData)
instance Arbitrary Substitution where
arbitrary = sized . fix $ \gen n ->
let leaves =
[ SubstPath <$> ((:|) <$> genIdentifier <*> listOf genIdentifier)]
subtree = gen $ n `div` 2
in if n == 0
then oneof leaves
else oneof $ leaves <> [ SubstFilter <$> subtree <*> arbitrary ]
shrink (SubstPath pth) =
fmap SubstPath
. filter (not . any ((||) <$> null <*> any (`notElem` identifierChars)))
$ shrink pth
shrink (SubstFilter s f)
= shrink s
<> (uncurry SubstFilter <$> shrink (s, f))
data Template
= Literal Text
| Subst Substitution
| Concat Template Template
deriving stock (Show, Generic, Data)
deriving anyclass (NFData)
deriving EqProp via EqEqProp Template
instance Plated Template where
plate _ tpl@(Literal _) = pure tpl
plate _ tpl@(Subst _) = pure tpl
plate f (Concat tpl₁ tpl₂) = Concat <$> f tpl₁ <*> f tpl₂
reduceTemplate :: Template -> Template
reduceTemplate = transform $ \case
(Concat (Literal t₁) (Literal t₂)) -> Literal (t₁ <> t₂)
(Concat (Literal "") t) -> t
(Concat t (Literal "")) -> t
(Concat t₁ (Concat t₂ t₃)) -> Concat (Concat t₁ t₂) t₃
(Concat (Concat t₁ (Literal t₂)) (Literal t₃)) -> (Concat t₁ (Literal $ t₂ <> t₃))
t -> t
instance Eq Template where
tpl₁ == tpl₂ = case (reduceTemplate tpl₁, reduceTemplate tpl₂) of
(Literal t₁, Literal t₂) -> t₁ == t₂
(Subst s₁, Subst s₂) -> s₁ == s₂
(Concat ta₁ ta₂, Concat tb₁ tb₂) -> ta₁ == tb₁ && ta₂ == tb₂
_ -> False
instance Arbitrary Template where
arbitrary = sized . fix $ \gen n ->
let leaves = [ Literal . filter (`notElem` ['\\', '{']) <$> arbitrary
, Subst <$> arbitrary
]
subtree = gen $ n `div` 2
genConcat = Concat <$> subtree <*> subtree
in if n == 0
then oneof leaves
else oneof $ genConcat : leaves
shrink (Literal t) = Literal <$> shrink t
shrink (Subst s) = Subst <$> shrink s
shrink (Concat t₁ t₂)
= shrink t₁
<> shrink t₂
<> (Concat <$> shrink t₁ <*> shrink t₂)
instance Semigroup Template where
(<>) = Concat
instance Monoid Template where
mempty = Literal ""
--------------------------------------------------------------------------------
type Parser = Parsec Void Text
sc :: Parser ()
sc = L.space space1 empty empty
lexeme :: Parser a -> Parser a
lexeme = L.lexeme sc
symbol :: Text -> Parser Text
symbol = L.symbol sc
identifier :: Parser Text
identifier = lexeme . label "identifier" $ do
firstChar <- letterChar <|> oneOf ['-', '_']
restChars <- many $ alphaNumChar <|> oneOf ['-', '_']
pure $ firstChar <| pack restChars
filterName :: Parser Filter
filterName = FilterName <$> identifier
substitutionPath :: Parser Substitution
substitutionPath = SubstPath <$> sepBy1 identifier (char '.')
substitutionFilter :: Parser Substitution
substitutionFilter = do
path <- substitutionPath
fs <- some $ symbol "|" *> filterName
pure $ foldl' SubstFilter path fs
-- pure $ SubstFilter path f
substitutionContents :: Parser Substitution
substitutionContents
= try substitutionFilter
<|> substitutionPath
substitution :: Parser Substitution
substitution = between (string "{{") (string "}}") substitutionContents
literal :: Parser Template
literal = Literal <$>
( (string "\\{" $> "{")
<|> takeWhile1P Nothing (`notElem` ['\\', '{'])
)
subst :: Parser Template
subst = Subst <$> substitution
template' :: Parser Template
template' = do
parts <- many $ literal <|> subst
pure $ foldr Concat (Literal "") parts
template :: Parser Template
template = reduceTemplate <$> template' <* eof
--------------------------------------------------------------------------------
ppSubstitution :: Substitution -> Text
ppSubstitution (SubstPath substParts) = intercalate "." substParts
ppSubstitution (SubstFilter s (FilterName f)) = ppSubstitution s <> " | " <> f
ppTemplate :: Template -> Text
ppTemplate (Literal txt) = txt
ppTemplate (Subst s) = "{{" <> ppSubstitution s <> "}}"
ppTemplate (Concat tpl₁ tpl₂) = ppTemplate tpl₁ <> ppTemplate tpl₂
--------------------------------------------------------------------------------
data TemplateVar
= Val Text
| Nested (Map Text TemplateVar)
deriving stock (Show, Eq, Generic)
deriving anyclass (NFData)
nested :: [(Text, TemplateVar)] -> TemplateVar
nested = Nested . mapFromList
instance Arbitrary TemplateVar where
arbitrary = sized . fix $ \gen n ->
let nst = fmap mapFromList . listOf $ (,) <$> arbitrary <*> gen (n `div` 2)
in if n == 0
then Val <$> arbitrary
else oneof [ Val <$> arbitrary
, Nested <$> nst]
newtype TemplateVars = Vars { getTemplateVars :: Map Text TemplateVar }
deriving stock (Show, Eq, Generic)
deriving anyclass (NFData)
deriving (Arbitrary) via (Map Text TemplateVar)
type instance Index TemplateVars = Text
type instance IxValue TemplateVars = TemplateVar
instance Ixed TemplateVars where
ix k f (Vars vs) = Vars <$> ix k f vs
instance At TemplateVars where
at k f (Vars vs) = Vars <$> at k f vs
vars :: [(Text, TemplateVar)] -> TemplateVars
vars = Vars . mapFromList
lookupVar :: TemplateVars -> NonEmpty Text -> Maybe TemplateVar
lookupVar vs (p :| []) = vs ^. at p
lookupVar vs (p :| (p₁ : ps)) = vs ^. at p >>= \case
(Val _) -> Nothing
(Nested vs') -> lookupVar (Vars vs') $ p₁ :| ps
data RenderError
= NoSuchVariable (NonEmpty Text)
| NestedFurther (NonEmpty Text)
| NoSuchFilter Filter
deriving stock (Show, Eq, Generic)
deriving anyclass (NFData)
renderSubst
:: Map Filter (Text -> Text) -- ^ Filters
-> TemplateVars
-> Substitution
-> Either RenderError Text
renderSubst _ vs (SubstPath pth) =
case lookupVar vs pth of
Just (Val v) -> Right v
Just (Nested _) -> Left $ NestedFurther pth
Nothing -> Left $ NoSuchVariable pth
renderSubst fs vs (SubstFilter s fn) =
case fs ^. at fn of
Just filterFn -> filterFn <$> renderSubst fs vs s
Nothing -> Left $ NoSuchFilter fn
render
:: Map Filter (Text -> Text) -- ^ Filters
-> TemplateVars -- ^ Template variables
-> Template -- ^ Template
-> Either RenderError Text
render _ _ (Literal s) = pure s
render fs vs (Concat t₁ t₂) = (<>) <$> render fs vs t₁ <*> render fs vs t₂
render fs vs (Subst s) = renderSubst fs vs s

76
users/glittershark/xanthous/src/Xanthous/Monad.hs Normal file
View file

@ -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

345
users/glittershark/xanthous/src/Xanthous/Orphans.hs Normal file
View file

@ -0,0 +1,345 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PackageImports #-}
{-# OPTIONS_GHC -Wno-orphans #-}
--------------------------------------------------------------------------------
module Xanthous.Orphans
( ppTemplate
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude hiding (elements, (.=))
--------------------------------------------------------------------------------
import Data.Aeson
import Data.Aeson.Types (typeMismatch)
import Data.List.NonEmpty (NonEmpty(..))
import Graphics.Vty.Attributes
import Brick.Widgets.Edit
import Data.Text.Zipper.Generic (GenericTextZipper)
import Brick.Widgets.Core (getName)
import System.Random (StdGen)
import Test.QuickCheck
import "quickcheck-instances" Test.QuickCheck.Instances ()
import Text.Megaparsec (errorBundlePretty)
import Text.Megaparsec.Pos
import Text.Mustache
import Text.Mustache.Type ( showKey )
import Control.Monad.State
import Linear
--------------------------------------------------------------------------------
import Xanthous.Util.JSON
import Xanthous.Util.QuickCheck
--------------------------------------------------------------------------------
instance forall s a.
( Cons s s a a
, IsSequence s
, Element s ~ a
) => Cons (NonNull s) (NonNull s) a a where
_Cons = prism hither yon
where
hither :: (a, NonNull s) -> NonNull s
hither (a, ns) =
let s = toNullable ns
in impureNonNull $ a <| s
yon :: NonNull s -> Either (NonNull s) (a, NonNull s)
yon ns = case nuncons ns of
(_, Nothing) -> Left ns
(x, Just xs) -> Right (x, xs)
instance forall a. Cons (NonEmpty a) (NonEmpty a) a a where
_Cons = prism hither yon
where
hither :: (a, NonEmpty a) -> NonEmpty a
hither (a, x :| xs) = a :| (x : xs)
yon :: NonEmpty a -> Either (NonEmpty a) (a, NonEmpty a)
yon ns@(x :| xs) = case xs of
(y : ys) -> Right (x, y :| ys)
[] -> Left ns
instance Arbitrary PName where
arbitrary = PName . pack <$> listOf1 (elements ['a'..'z'])
instance Arbitrary Key where
arbitrary = Key <$> listOf1 arbSafeText
where arbSafeText = pack <$> listOf1 (elements ['a'..'z'])
shrink (Key []) = error "unreachable"
shrink k@(Key [_]) = pure k
shrink (Key (p:ps)) = Key . (p :) <$> shrink ps
instance Arbitrary Pos where
arbitrary = mkPos . succ . abs <$> arbitrary
shrink (unPos -> 1) = []
shrink (unPos -> x) = mkPos <$> [x..1]
instance Arbitrary Node where
arbitrary = sized node
where
node n | n > 0 = oneof $ leaves ++ branches (n `div` 2)
node _ = oneof leaves
branches n =
[ Section <$> arbitrary <*> subnodes n
, InvertedSection <$> arbitrary <*> subnodes n
]
subnodes = fmap concatTextBlocks . listOf . node
leaves =
[ TextBlock . pack <$> listOf1 (elements ['a'..'z'])
, EscapedVar <$> arbitrary
, UnescapedVar <$> arbitrary
-- TODO fix pretty-printing of mustache partials
-- , Partial <$> arbitrary <*> arbitrary
]
shrink = genericShrink
concatTextBlocks :: [Node] -> [Node]
concatTextBlocks [] = []
concatTextBlocks [x] = [x]
concatTextBlocks (TextBlock txt₁ : TextBlock txt₂ : xs)
= concatTextBlocks $ TextBlock (txt₁ <> txt₂) : concatTextBlocks xs
concatTextBlocks (x : xs) = x : concatTextBlocks xs
instance Arbitrary Template where
arbitrary = do
template <- concatTextBlocks <$> arbitrary
-- templateName <- arbitrary
-- rest <- arbitrary
let templateName = "template"
rest = mempty
pure $ Template
{ templateActual = templateName
, templateCache = rest & at templateName ?~ template
}
shrink (Template actual cache) =
let Just tpl = cache ^. at actual
in do
cache' <- shrink cache
tpl' <- shrink tpl
actual' <- shrink actual
pure $ Template
{ templateActual = actual'
, templateCache = cache' & at actual' ?~ tpl'
}
instance CoArbitrary Template where
coarbitrary = coarbitrary . ppTemplate
instance Function Template where
function = functionMap ppTemplate parseTemplatePartial
where
parseTemplatePartial txt
= compileMustacheText "template" txt ^?! _Right
ppNode :: Map PName [Node] -> Node -> Text
ppNode _ (TextBlock txt) = txt
ppNode _ (EscapedVar k) = "{{" <> showKey k <> "}}"
ppNode ctx (Section k body) =
let sk = showKey k
in "{{#" <> sk <> "}}" <> foldMap (ppNode ctx) body <> "{{/" <> sk <> "}}"
ppNode _ (UnescapedVar k) = "{{{" <> showKey k <> "}}}"
ppNode ctx (InvertedSection k body) =
let sk = showKey k
in "{{^" <> sk <> "}}" <> foldMap (ppNode ctx) body <> "{{/" <> sk <> "}}"
ppNode _ (Partial n _) = "{{> " <> unPName n <> "}}"
ppTemplate :: Template -> Text
ppTemplate (Template actual cache) =
case cache ^. at actual of
Nothing -> error "Template not found?"
Just nodes -> foldMap (ppNode cache) nodes
instance ToJSON Template where
toJSON = String . ppTemplate
instance FromJSON Template where
parseJSON
= withText "Template"
$ either (fail . errorBundlePretty) pure
. compileMustacheText "template"
deriving anyclass instance NFData Node
deriving anyclass instance NFData Template
instance FromJSON Color where
parseJSON (String "black") = pure black
parseJSON (String "red") = pure red
parseJSON (String "green") = pure green
parseJSON (String "yellow") = pure yellow
parseJSON (String "blue") = pure blue
parseJSON (String "magenta") = pure magenta
parseJSON (String "cyan") = pure cyan
parseJSON (String "white") = pure white
parseJSON (String "brightBlack") = pure brightBlack
parseJSON (String "brightRed") = pure brightRed
parseJSON (String "brightGreen") = pure brightGreen
parseJSON (String "brightYellow") = pure brightYellow
parseJSON (String "brightBlue") = pure brightBlue
parseJSON (String "brightMagenta") = pure brightMagenta
parseJSON (String "brightCyan") = pure brightCyan
parseJSON (String "brightWhite") = pure brightWhite
parseJSON n@(Number _) = Color240 <$> parseJSON n
parseJSON x = typeMismatch "Color" x
instance ToJSON Color where
toJSON color
| color == black = "black"
| color == red = "red"
| color == green = "green"
| color == yellow = "yellow"
| color == blue = "blue"
| color == magenta = "magenta"
| color == cyan = "cyan"
| color == white = "white"
| color == brightBlack = "brightBlack"
| color == brightRed = "brightRed"
| color == brightGreen = "brightGreen"
| color == brightYellow = "brightYellow"
| color == brightBlue = "brightBlue"
| color == brightMagenta = "brightMagenta"
| color == brightCyan = "brightCyan"
| color == brightWhite = "brightWhite"
| Color240 num <- color = toJSON num
| otherwise = error $ "unimplemented: " <> show color
instance (Eq a, Show a, Read a, FromJSON a) => FromJSON (MaybeDefault a) where
parseJSON Null = pure Default
parseJSON (String "keepCurrent") = pure KeepCurrent
parseJSON x = SetTo <$> parseJSON x
instance ToJSON a => ToJSON (MaybeDefault a) where
toJSON Default = Null
toJSON KeepCurrent = String "keepCurrent"
toJSON (SetTo x) = toJSON x
--------------------------------------------------------------------------------
instance Arbitrary Color where
arbitrary = oneof [ Color240 <$> choose (0, 239)
, ISOColor <$> choose (0, 15)
]
deriving anyclass instance CoArbitrary Color
deriving anyclass instance Function Color
instance (Eq a, Show a, Read a, Arbitrary a) => Arbitrary (MaybeDefault a) where
arbitrary = oneof [ pure Default
, pure KeepCurrent
, SetTo <$> arbitrary
]
instance CoArbitrary a => CoArbitrary (MaybeDefault a) where
coarbitrary Default = variant @Int 1
coarbitrary KeepCurrent = variant @Int 2
coarbitrary (SetTo x) = variant @Int 3 . coarbitrary x
instance (Eq a, Show a, Read a, Function a) => Function (MaybeDefault a) where
function = functionShow
instance Arbitrary Attr where
arbitrary = do
attrStyle <- arbitrary
attrForeColor <- arbitrary
attrBackColor <- arbitrary
attrURL <- arbitrary
pure Attr {..}
deriving anyclass instance CoArbitrary Attr
deriving anyclass instance Function Attr
instance ToJSON Attr where
toJSON Attr{..} = object
[ "style" .= maybeDefaultToJSONWith styleToJSON attrStyle
, "foreground" .= attrForeColor
, "background" .= attrBackColor
, "url" .= attrURL
]
where
maybeDefaultToJSONWith _ Default = Null
maybeDefaultToJSONWith _ KeepCurrent = String "keepCurrent"
maybeDefaultToJSONWith tj (SetTo x) = tj x
styleToJSON style
| style == standout = "standout"
| style == underline = "underline"
| style == reverseVideo = "reverseVideo"
| style == blink = "blink"
| style == dim = "dim"
| style == bold = "bold"
| style == italic = "italic"
| otherwise = toJSON style
instance FromJSON Attr where
parseJSON = withObject "Attr" $ \obj -> do
attrStyle <- parseStyle =<< obj .:? "style" .!= Default
attrForeColor <- obj .:? "foreground" .!= Default
attrBackColor <- obj .:? "background" .!= Default
attrURL <- obj .:? "url" .!= Default
pure Attr{..}
where
parseStyle (SetTo (String "standout")) = pure (SetTo standout)
parseStyle (SetTo (String "underline")) = pure (SetTo underline)
parseStyle (SetTo (String "reverseVideo")) = pure (SetTo reverseVideo)
parseStyle (SetTo (String "blink")) = pure (SetTo blink)
parseStyle (SetTo (String "dim")) = pure (SetTo dim)
parseStyle (SetTo (String "bold")) = pure (SetTo bold)
parseStyle (SetTo (String "italic")) = pure (SetTo italic)
parseStyle (SetTo n@(Number _)) = SetTo <$> parseJSON n
parseStyle (SetTo v) = typeMismatch "Style" v
parseStyle Default = pure Default
parseStyle KeepCurrent = pure KeepCurrent
deriving stock instance Ord Color
deriving stock instance Ord a => Ord (MaybeDefault a)
deriving stock instance Ord Attr
--------------------------------------------------------------------------------
instance NFData a => NFData (NonNull a) where
rnf xs = xs `seq` toNullable xs `deepseq` ()
instance forall t name. (NFData t, Monoid t, NFData name)
=> NFData (Editor t name) where
rnf ed = getName @_ @name ed `deepseq` getEditContents ed `deepseq` ()
instance NFData StdGen where
-- StdGen's fields are bang-patterned so this is actually correct!
rnf sg = sg `seq` ()
deriving via (ReadShowJSON StdGen) instance ToJSON StdGen
deriving via (ReadShowJSON StdGen) instance FromJSON StdGen
instance Function StdGen where
function = functionShow
--------------------------------------------------------------------------------
instance CoArbitrary a => CoArbitrary (NonNull a) where
coarbitrary = coarbitrary . toNullable
instance (MonoFoldable a, Function a) => Function (NonNull a) where
function = functionMap toNullable $ fromMaybe (error "null") . fromNullable
instance (Arbitrary t, Arbitrary n, GenericTextZipper t)
=> Arbitrary (Editor t n) where
arbitrary = editor <$> arbitrary <*> arbitrary <*> arbitrary
instance forall t n. (CoArbitrary t, CoArbitrary n, Monoid t)
=> CoArbitrary (Editor t n) where
coarbitrary ed = coarbitrary (getName @_ @n ed, getEditContents ed)
instance CoArbitrary StdGen where
coarbitrary = coarbitrary . show
--------------------------------------------------------------------------------
deriving newtype instance (Arbitrary s, CoArbitrary (m (a, s)))
=> CoArbitrary (StateT s m a)
--------------------------------------------------------------------------------
deriving via (GenericArbitrary (V2 a)) instance Arbitrary a => Arbitrary (V2 a)
instance CoArbitrary a => CoArbitrary (V2 a)
instance Function a => Function (V2 a)

36
users/glittershark/xanthous/src/Xanthous/Prelude.hs Normal file
View file

@ -0,0 +1,36 @@
--------------------------------------------------------------------------------
module Xanthous.Prelude
( module ClassyPrelude
, Type
, Constraint
, module GHC.TypeLits
, module Control.Lens
, module Data.Void
, module Control.Comonad
-- * Classy-Prelude addons
, ninsertSet
, ndeleteSet
, toVector
) where
--------------------------------------------------------------------------------
import ClassyPrelude hiding
(return, (<|), unsnoc, uncons, cons, snoc, index, (<.>), Index, say)
import Data.Kind
import GHC.TypeLits hiding (Text)
import Control.Lens hiding (levels, Level)
import Data.Void
import Control.Comonad
--------------------------------------------------------------------------------
ninsertSet
:: (IsSet set, MonoPointed set)
=> Element set -> NonNull set -> NonNull set
ninsertSet x xs = impureNonNull $ opoint x `union` toNullable xs
ndeleteSet :: IsSet b => Element b -> NonNull b -> b
ndeleteSet x = deleteSet x . toNullable
toVector :: (MonoFoldable (f a), Element (f a) ~ a) => f a -> Vector a
toVector = fromList . toList

102
users/glittershark/xanthous/src/Xanthous/Random.hs Normal file
View file

@ -0,0 +1,102 @@
--------------------------------------------------------------------------------
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
--------------------------------------------------------------------------------
module Xanthous.Random
( Choose(..)
, ChooseElement(..)
, Weighted(..)
, evenlyWeighted
, weightedBy
, subRand
, chance
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
--------------------------------------------------------------------------------
import Data.List.NonEmpty (NonEmpty(..))
import Control.Monad.Random.Class (MonadRandom(getRandomR, getRandom))
import Control.Monad.Random (Rand, evalRand, mkStdGen, StdGen)
import Data.Random.Shuffle.Weighted
import Data.Random.Distribution
import Data.Random.Distribution.Uniform
import Data.Random.Distribution.Uniform.Exclusive
import Data.Random.Sample
import qualified Data.Random.Source as DRS
--------------------------------------------------------------------------------
instance {-# INCOHERENT #-} (Monad m, MonadRandom m) => DRS.MonadRandom m where
getRandomWord8 = getRandom
getRandomWord16 = getRandom
getRandomWord32 = getRandom
getRandomWord64 = getRandom
getRandomDouble = getRandom
getRandomNByteInteger n = getRandomR (0, 256 ^ n)
class Choose a where
type RandomResult a
choose :: MonadRandom m => a -> m (RandomResult a)
newtype ChooseElement a = ChooseElement a
instance MonoFoldable a => Choose (ChooseElement a) where
type RandomResult (ChooseElement a) = Maybe (Element a)
choose (ChooseElement xs) = do
chosenIdx <- getRandomR (0, olength xs - 1)
let pick _ (Just x) = Just x
pick (x, i) Nothing
| i == chosenIdx = Just x
| otherwise = Nothing
pure $ ofoldr pick Nothing $ zip (toList xs) [0..]
instance MonoFoldable a => Choose (NonNull a) where
type RandomResult (NonNull a) = Element a
choose
= fmap (fromMaybe (error "unreachable")) -- why not lol
. choose
. ChooseElement
. toNullable
instance Choose (NonEmpty a) where
type RandomResult (NonEmpty a) = a
choose = choose . fromNonEmpty @[_]
instance Choose (a, a) where
type RandomResult (a, a) = a
choose (x, y) = choose (x :| [y])
newtype Weighted w t a = Weighted (t (w, a))
evenlyWeighted :: [a] -> Weighted Int [] a
evenlyWeighted = Weighted . itoList
weightedBy :: Functor t => (a -> w) -> t a -> Weighted w t a
weightedBy weighting xs = Weighted $ (weighting &&& id) <$> xs
instance (Num w, Ord w, Distribution Uniform w, Excludable w) => Choose (Weighted w [] a) where
type RandomResult (Weighted w [] a) = Maybe a
choose (Weighted ws) = sample $ headMay <$> weightedSample 1 ws
instance (Num w, Ord w, Distribution Uniform w, Excludable w) => Choose (Weighted w NonEmpty a) where
type RandomResult (Weighted w NonEmpty a) = a
choose (Weighted ws) =
sample
$ fromMaybe (error "unreachable") . headMay
<$> weightedSample 1 (toList ws)
subRand :: MonadRandom m => Rand StdGen a -> m a
subRand sub = evalRand sub . mkStdGen <$> getRandom
-- | Has a @n@ chance of returning 'True'
--
-- eg, chance 0.5 will return 'True' half the time
chance
:: (Num w, Ord w, Distribution Uniform w, Excludable w, MonadRandom m)
=> w
-> m Bool
chance n = choose $ weightedBy (bool 1 (n * 2)) bools
--------------------------------------------------------------------------------
bools :: NonEmpty Bool
bools = True :| [False]

252
users/glittershark/xanthous/src/Xanthous/Util.hs Normal file
View file

@ -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

24
users/glittershark/xanthous/src/Xanthous/Util/Comonad.hs Normal file
View file

@ -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 #-}

33
users/glittershark/xanthous/src/Xanthous/Util/Graph.hs Normal file
View file

@ -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₂)

174
users/glittershark/xanthous/src/Xanthous/Util/Graphics.hs Normal file
View file

@ -0,0 +1,174 @@
{-# LANGUAGE TemplateHaskell #-}
-- | Graphics algorithms and utils for rendering things in 2D space
--------------------------------------------------------------------------------
module Xanthous.Util.Graphics
( circle
, filledCircle
, line
, straightLine
, delaunay
-- * Debugging and testing tools
, renderBooleanGraphics
, showBooleanGraphics
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
--------------------------------------------------------------------------------
-- https://github.com/noinia/hgeometry/issues/28
-- import qualified Algorithms.Geometry.DelaunayTriangulation.DivideAndConquer
-- as Geometry
import qualified Algorithms.Geometry.DelaunayTriangulation.Naive
as Geometry
import qualified Algorithms.Geometry.DelaunayTriangulation.Types as Geometry
import Control.Monad.State (execState, State)
import qualified Data.Geometry.Point as Geometry
import Data.Ext ((:+)(..))
import Data.List (unfoldr)
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.List.NonEmpty as NE
import Data.Ix (Ix)
import Linear.V2
--------------------------------------------------------------------------------
-- | Generate a circle centered at the given point and with the given radius
-- using the <midpoint circle algorithm
-- https://en.wikipedia.org/wiki/Midpoint_circle_algorithm>.
--
-- Code taken from <https://rosettacode.org/wiki/Bitmap/Midpoint_circle_algorithm#Haskell>
circle :: (Num i, Ord i)
=> (i, i) -- ^ center
-> i -- ^ radius
-> [(i, i)]
circle (x₀, y₀) radius
-- Four initial points, plus the generated points
= (x₀, y₀ + radius) : (x₀, y₀ - radius) : (x₀ + radius, y₀) : (x₀ - radius, y₀) : points
where
-- Creates the (x, y) octet offsets, then maps them to absolute points in all octets.
points = concatMap generatePoints $ unfoldr step initialValues
generatePoints (x, y)
= [ (x₀ `xop` x', y₀ `yop` y')
| (x', y') <- [(x, y), (y, x)]
, xop <- [(+), (-)]
, yop <- [(+), (-)]
]
initialValues = (1 - radius, 1, (-2) * radius, 0, radius)
step (f, ddf_x, ddf_y, x, y)
| x >= y = Nothing
| otherwise = Just ((x', y'), (f', ddf_x', ddf_y', x', y'))
where
(f', ddf_y', y') | f >= 0 = (f + ddf_y' + ddf_x', ddf_y + 2, y - 1)
| otherwise = (f + ddf_x, ddf_y, y)
ddf_x' = ddf_x + 2
x' = x + 1
data FillState i
= FillState
{ _inCircle :: Bool
, _result :: NonEmpty (i, i)
}
makeLenses ''FillState
runFillState :: NonEmpty (i, i) -> State (FillState i) a -> [(i, i)]
runFillState circumference s
= toList
. view result
. execState s
$ FillState False circumference
-- | Generate a *filled* circle centered at the given point and with the given
-- radius by filling a circle generated with 'circle'
filledCircle :: (Num i, Integral i, Ix i)
=> (i, i) -- ^ center
-> i -- ^ radius
-> [(i, i)]
filledCircle origin radius =
case NE.nonEmpty (circle origin radius) of
Nothing -> []
Just circumference -> runFillState circumference $
-- the first and last lines of all circles are solid, so the whole "in the
-- circle, out of the circle" thing doesn't work... but that's fine since
-- we don't need to fill them. So just skip them
for_ [succ minX..pred maxX] $ \x ->
for_ [minY..maxY] $ \y -> do
let pt = (x, y)
next = (x, succ y)
whenM (use inCircle) $ result %= NE.cons pt
when (pt `elem` circumference && next `notElem` circumference)
$ inCircle %= not
where
((minX, minY), (maxX, maxY)) = minmaxes circumference
-- | Draw a line between two points using Bresenham's line drawing algorithm
--
-- Code taken from <https://wiki.haskell.org/Bresenham%27s_line_drawing_algorithm>
line :: (Num i, Ord i) => (i, i) -> (i, i) -> [(i, i)]
line pa@(xa, ya) pb@(xb, yb)
= (if maySwitch pa < maySwitch pb then id else reverse) points
where
points = map maySwitch . unfoldr go $ (x₁, y₁, 0)
steep = abs (yb - ya) > abs (xb - xa)
maySwitch = if steep then swap else id
[(x₁, y₁), (x₂, y₂)] = sort [maySwitch pa, maySwitch pb]
δx = x₂ - x₁
δy = abs (y₂ - y₁)
ystep = if y₁ < y₂ then 1 else -1
go (xTemp, yTemp, err)
| xTemp > x₂ = Nothing
| otherwise = Just ((xTemp, yTemp), (xTemp + 1, newY, newError))
where
tempError = err + δy
(newY, newError) = if (2 * tempError) >= δx
then (yTemp + ystep, tempError - δx)
else (yTemp, tempError)
straightLine :: (Num i, Ord i) => (i, i) -> (i, i) -> [(i, i)]
straightLine pa@(xa, _) pb@(_, yb) = line pa midpoint ++ line midpoint pb
where midpoint = (xa, yb)
delaunay
:: (Ord n, Fractional n)
=> NonEmpty (V2 n, p)
-> [((V2 n, p), (V2 n, p))]
delaunay
= map (over both fromPoint)
. Geometry.triangulationEdges
. Geometry.delaunayTriangulation
. map toPoint
where
toPoint (V2 px py, pid) = Geometry.Point2 px py :+ pid
fromPoint (Geometry.Point2 px py :+ pid) = (V2 px py, pid)
--------------------------------------------------------------------------------
renderBooleanGraphics :: forall i. (Num i, Ord i, Enum i) => [(i, i)] -> String
renderBooleanGraphics [] = ""
renderBooleanGraphics (pt : pts') = intercalate "\n" rows
where
rows = row <$> [minX..maxX]
row x = [minY..maxY] <&> \y -> if (x, y) `member` ptSet then 'X' else ' '
((minX, minY), (maxX, maxY)) = minmaxes pts
pts = pt :| pts'
ptSet :: Set (i, i)
ptSet = setFromList $ toList pts
showBooleanGraphics :: forall i. (Num i, Ord i, Enum i) => [(i, i)] -> IO ()
showBooleanGraphics = putStrLn . pack . renderBooleanGraphics
minmaxes :: forall i. (Ord i) => NonEmpty (i, i) -> ((i, i), (i, i))
minmaxes xs =
( ( minimum1Of (traverse1 . _1) xs
, minimum1Of (traverse1 . _2) xs
)
, ( maximum1Of (traverse1 . _1) xs
, maximum1Of (traverse1 . _2) xs
)
)

14
users/glittershark/xanthous/src/Xanthous/Util/Inflection.hs Normal file
View file

@ -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

19
users/glittershark/xanthous/src/Xanthous/Util/JSON.hs Normal file
View file

@ -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

21
users/glittershark/xanthous/src/Xanthous/Util/Optparse.hs Normal file
View file

@ -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

42
users/glittershark/xanthous/src/Xanthous/Util/QuickCheck.hs Normal file
View file

@ -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

120
users/glittershark/xanthous/src/Xanthous/messages.yaml Normal file
View file

@ -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 ,.

45
users/glittershark/xanthous/test/Spec.hs Normal file
View file

@ -0,0 +1,45 @@
--------------------------------------------------------------------------------
import Test.Prelude
--------------------------------------------------------------------------------
import qualified Xanthous.Data.EntityCharSpec
import qualified Xanthous.Data.EntityMapSpec
import qualified Xanthous.Data.EntityMap.GraphicsSpec
import qualified Xanthous.Data.LevelsSpec
import qualified Xanthous.Data.EntitiesSpec
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.Util.GraphicsSpec
import qualified Xanthous.Util.GraphSpec
import qualified Xanthous.Util.InflectionSpec
import qualified Xanthous.UtilSpec
--------------------------------------------------------------------------------
main :: IO ()
main = defaultMain test
test :: TestTree
test = testGroup "Xanthous"
[ Xanthous.Data.EntityCharSpec.test
, Xanthous.Data.EntityMapSpec.test
, Xanthous.Data.EntityMap.GraphicsSpec.test
, Xanthous.Data.EntitiesSpec.test
, Xanthous.Data.LevelsSpec.test
, Xanthous.Data.NestedMapSpec.test
, Xanthous.Entities.RawsSpec.test
, Xanthous.GameSpec.test
, Xanthous.Generators.UtilSpec.test
, Xanthous.MessageSpec.test
, Xanthous.Messages.TemplateSpec.test
, Xanthous.OrphansSpec.test
, Xanthous.DataSpec.test
, Xanthous.UtilSpec.test
, Xanthous.Util.GraphicsSpec.test
, Xanthous.Util.GraphSpec.test
, Xanthous.Util.InflectionSpec.test
]

19
users/glittershark/xanthous/test/Test/Prelude.hs Normal file
View file

@ -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

28
users/glittershark/xanthous/test/Xanthous/Data/EntitiesSpec.hs Normal file
View file

@ -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
]
]

18
users/glittershark/xanthous/test/Xanthous/Data/EntityCharSpec.hs Normal file
View file

@ -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
]

57
users/glittershark/xanthous/test/Xanthous/Data/EntityMap/GraphicsSpec.hs Normal file
View file

@ -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"

69
users/glittershark/xanthous/test/Xanthous/Data/EntityMapSpec.hs Normal file
View file

@ -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)
]
]

66
users/glittershark/xanthous/test/Xanthous/Data/LevelsSpec.hs Normal file
View file

@ -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
]
]

20
users/glittershark/xanthous/test/Xanthous/Data/NestedMapSpec.hs Normal file
View file

@ -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)
]

98
users/glittershark/xanthous/test/Xanthous/DataSpec.hs Normal file
View file

@ -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
]
]
]

16
users/glittershark/xanthous/test/Xanthous/Entities/RawsSpec.hs Normal file
View file

@ -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 ()
]
]

55
users/glittershark/xanthous/test/Xanthous/GameSpec.hs Normal file
View file

@ -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
]
]

77
users/glittershark/xanthous/test/Xanthous/Generators/UtilSpec.hs Normal file
View file

@ -0,0 +1,77 @@
{-# 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 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, 0), (dims ^. width, dims ^. height))
]
, testGroup "numAliveNeighborsM"
[ testProperty "maxes out at 8" $ \(GenArray (arr :: Array (Word, 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 (Word, 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
]
]

53
users/glittershark/xanthous/test/Xanthous/MessageSpec.hs Normal file
View file

@ -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 ()
]
]

80
users/glittershark/xanthous/test/Xanthous/Messages/TemplateSpec.hs Normal file
View file

@ -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 = 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
--

42
users/glittershark/xanthous/test/Xanthous/OrphansSpec.hs Normal file
View file

@ -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
]
]

39
users/glittershark/xanthous/test/Xanthous/Util/GraphSpec.hs Normal file
View file

@ -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
]
]

65
users/glittershark/xanthous/test/Xanthous/Util/GraphicsSpec.hs Normal file
View file

@ -0,0 +1,65 @@
module Xanthous.Util.GraphicsSpec (main, test) where
--------------------------------------------------------------------------------
import Test.Prelude hiding (head)
--------------------------------------------------------------------------------
import Xanthous.Util.Graphics
import Xanthous.Util
import Data.List (head)
import Data.Set (isSubsetOf)
--------------------------------------------------------------------------------
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 (2, 2) 1)
@?= [ (1, 2)
, (2, 1), (2, 3)
, (3, 2)
]
, testCase "radius 12, origin 0"
$ (sort . unique @[] @[_]) (circle @Int (0, 0) 12)
@?= [ (-12,-4),(-12,-3),(-12,-2),(-12,-1),(-12,0),(-12,1),(-12,2)
, (-12,3),(-12,4),(-11,-6),(-11,-5),(-11,5),(-11,6),(-10,-7),(-10,7)
, (-9,-9),(-9,-8),(-9,8),(-9,9),(-8,-9),(-8,9),(-7,-10),(-7,10)
, (-6,-11),(-6,11),(-5,-11),(-5 ,11),(-4,-12),(-4,12),(-3,-12),(-3,12)
, (-2,-12),(-2,12),(-1,-12),(-1,12),(0,-12),(0,12),(1,-12),(1,12)
, (2,-12),(2,12),(3,-12),(3,12),(4,-12),(4,12),(5,-11),(5 ,11),(6,-11)
, (6,11),(7,-10),(7,10),(8,-9),(8,9),(9,-9),(9,-8),(9,8),(9,9),(10,-7)
, (10,7),(11,-6),(11,-5),(11,5),(11,6),(12,-4),(12,-3),(12,-2),(12,-1)
, (12,0), (12,1),(12,2),(12,3),(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)
]
]
--------------------------------------------------------------------------------

18
users/glittershark/xanthous/test/Xanthous/Util/InflectionSpec.hs Normal file
View file

@ -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"
]
]

28
users/glittershark/xanthous/test/Xanthous/UtilSpec.hs Normal file
View file

@ -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
]
]

361
users/glittershark/xanthous/xanthous.cabal Normal file
View file

@ -0,0 +1,361 @@
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.31.2.
--
-- see: https://github.com/sol/hpack
--
-- hash: 0486cac7957fae1f9badffdd082f0c5eb5910eb8c066569123b0f57bc6fa0d8b
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.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.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
, 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
, parser-combinators
, pointed
, quickcheck-instances
, quickcheck-text
, random
, random-extras
, random-fu
, random-source
, raw-strings-qq
, reflection
, semigroupoids
, stache
, streams
, text
, text-zipper
, tomland
, vector
, vty
, 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.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.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
, 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
, parser-combinators
, pointed
, quickcheck-instances
, quickcheck-text
, random
, random-extras
, random-fu
, random-source
, raw-strings-qq
, reflection
, semigroupoids
, stache
, streams
, text
, text-zipper
, tomland
, vector
, vty
, 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.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
, 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
, parser-combinators
, pointed
, quickcheck-instances
, quickcheck-text
, random
, random-extras
, random-fu
, random-source
, raw-strings-qq
, reflection
, semigroupoids
, stache
, streams
, tasty
, tasty-hunit
, tasty-quickcheck
, text
, text-zipper
, tomland
, vector
, vty
, xanthous
, yaml
, zlib
default-language: Haskell2010