diff options
| author | Vincent Ambo <mail@tazj.in> | 2020-06-16T00·05+0100 |
|---|---|---|
| committer | Vincent Ambo <mail@tazj.in> | 2020-06-16T00·05+0100 |
| commit | 2edb963b97867b27f68efac8d05bf966077b0b01 (patch) | |
| tree | c3bb279dfd4330e09a0af6ef4e84ff8a9a3bc7ad /users/glittershark/xanthous | |
| parent | 91f53f02d8479303910abfd3f3690d3ef27e6c4b (diff) | |
| parent | 53b56744f4335c038724a1bcffc27a7eb8cf6a6d (diff) | |
Add 'users/glittershark/xanthous/' from commit '53b56744f4335c038724a1bcffc27a7eb8cf6a6d' r/978
git-subtree-dir: users/glittershark/xanthous git-subtree-mainline: 91f53f02d8479303910abfd3f3690d3ef27e6c4b git-subtree-split: 53b56744f4335c038724a1bcffc27a7eb8cf6a6d
Diffstat (limited to 'users/glittershark/xanthous')
96 files changed, 10030 insertions, 0 deletions
diff --git a/users/glittershark/xanthous/.envrc b/users/glittershark/xanthous/.envrc new file mode 100644 index 0000000000..be81feddb1 --- /dev/null +++ b/users/glittershark/xanthous/.envrc @@ -0,0 +1 @@ +eval "$(lorri direnv)" \ No newline at end of file diff --git a/users/glittershark/xanthous/.github/actions/nix-build/Dockerfile b/users/glittershark/xanthous/.github/actions/nix-build/Dockerfile new file mode 100644 index 0000000000..cfe8e35df0 --- /dev/null +++ b/users/glittershark/xanthous/.github/actions/nix-build/Dockerfile @@ -0,0 +1,23 @@ +FROM lnl7/nix:2.1.2 + +LABEL name="Nix Build for GitHub Actions" +LABEL version="1.0" +LABEL repository="http://github.com/glittershark/xanthous" +LABEL homepage="http://github.com/glittershark/xanthous" +LABEL maintainer="Griffin Smith <root at gws dot fyi>" + +LABEL "com.github.actions.name"="Nix Build" +LABEL "com.github.actions.description"="Runs 'nix-build'" +LABEL "com.github.actions.icon"="cpu" +LABEL "com.github.actions.color"="purple" + +RUN nix-env -iA \ + nixpkgs.gnutar nixpkgs.gzip \ + nixpkgs.gnugrep nixpkgs.git && \ + mkdir -p /etc/nix && \ + (echo "binary-caches = https://cache.nixos.org/" | tee -a /etc/nix/nix.conf) && \ + (echo "trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=" | tee -a /etc/nix/nix.conf) + +COPY entrypoint.sh /entrypoint.sh +ENTRYPOINT [ "/entrypoint.sh" ] +CMD [ "--help" ] diff --git a/users/glittershark/xanthous/.github/actions/nix-build/entrypoint.sh b/users/glittershark/xanthous/.github/actions/nix-build/entrypoint.sh new file mode 100755 index 0000000000..cb7aca541a --- /dev/null +++ b/users/glittershark/xanthous/.github/actions/nix-build/entrypoint.sh @@ -0,0 +1,24 @@ +#!/usr/bin/env bash + +# Entrypoint that runs nix-build and, optionally, copies Docker image tarballs +# to real files. The reason this is necessary is because once a Nix container +# exits, you must copy out the artifacts to the working directory before exit. + +[ "$DEBUG" = "1" ] && set -x +[ "$QUIET" = "1" ] && QUIET_ARG="-Q" + +set -e + +# file to build (e.g. release.nix) +file="$1" + +[ "$file" = "" ] && echo "No .nix file to build specified!" && exit 1 +[ ! -e "$file" ] && echo "File $file not exist!" && exit 1 + +echo "Building all attrs in $file..." +nix-build --no-link ${QUIET_ARG} "$file" "${@:2}" + +echo "Copying build closure to $(pwd)/store..." +mapfile -t storePaths < <(nix-build ${QUIET_ARG} --no-link "$file" | grep -v cache-deps) +printf '%s\n' "${storePaths[@]}" > store.roots +nix copy --to "file://$(pwd)/store" "${storePaths[@]}" diff --git a/users/glittershark/xanthous/.github/workflows/haskell.yml b/users/glittershark/xanthous/.github/workflows/haskell.yml new file mode 100644 index 0000000000..df82de3e8c --- /dev/null +++ b/users/glittershark/xanthous/.github/workflows/haskell.yml @@ -0,0 +1,15 @@ +name: Haskell CI + +on: [push] + +jobs: + build: + + runs-on: ubuntu-latest + + steps: + - uses: actions/checkout@v1 + - name: Nix Build + with: + args: default.nix --arg failOnWarnings true + uses: ./.github/actions/nix-build diff --git a/users/glittershark/xanthous/.gitignore b/users/glittershark/xanthous/.gitignore new file mode 100644 index 0000000000..bc711a2470 --- /dev/null +++ b/users/glittershark/xanthous/.gitignore @@ -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 diff --git a/users/glittershark/xanthous/LICENSE b/users/glittershark/xanthous/LICENSE new file mode 100644 index 0000000000..45644ff764 --- /dev/null +++ b/users/glittershark/xanthous/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/> + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + <one line to give the program's name and a brief idea of what it does.> + Copyright (C) <year> <name of author> + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see <http://www.gnu.org/licenses/>. + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + <program> Copyright (C) <year> <name of author> + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +<http://www.gnu.org/licenses/>. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +<http://www.gnu.org/philosophy/why-not-lgpl.html>. diff --git a/users/glittershark/xanthous/README.org b/users/glittershark/xanthous/README.org new file mode 100644 index 0000000000..7e1fedb069 --- /dev/null +++ b/users/glittershark/xanthous/README.org @@ -0,0 +1,36 @@ +#+TITLE: Xanthous + +* Building + +#+BEGIN_SRC shell +$ nix build +#+END_SRC + +* Running + +#+BEGIN_SRC shell +$ ./result/bin/xanthous [--help] +#+END_SRC + +** Keyboard commands + +Keyboard commands are currently undocumented, but can be found in [[[https://github.com/glittershark/xanthous/blob/master/src/Xanthous/Command.hs#L26][this file]]. +Movement uses the nethack-esque hjklybnu. + +* Development + +Use [[https://github.com/target/lorri][lorri]], or run everything in a ~nix-shell~ + +#+BEGIN_SRC shell +# Build (for dev) +$ cabal new-build + +# Run the game +$ cabal new-run xanthous + +# Run tests +$ cabal new-run test + +# Run a repl +$ cabal new-repl +#+END_SRC diff --git a/users/glittershark/xanthous/Setup.hs b/users/glittershark/xanthous/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/users/glittershark/xanthous/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/users/glittershark/xanthous/build/generic-arbitrary-export-garbitrary.patch b/users/glittershark/xanthous/build/generic-arbitrary-export-garbitrary.patch new file mode 100644 index 0000000000..f0c936bfca --- /dev/null +++ b/users/glittershark/xanthous/build/generic-arbitrary-export-garbitrary.patch @@ -0,0 +1,12 @@ +diff --git a/src/Test/QuickCheck/Arbitrary/Generic.hs b/src/Test/QuickCheck/Arbitrary/Generic.hs +index fed6ab3..91f59f1 100644 +--- a/src/Test/QuickCheck/Arbitrary/Generic.hs ++++ b/src/Test/QuickCheck/Arbitrary/Generic.hs +@@ -23,6 +23,7 @@ The generated 'arbitrary' method is equivalent to + + module Test.QuickCheck.Arbitrary.Generic + ( Arbitrary(..) ++ , GArbitrary + , genericArbitrary + , genericShrink + ) where diff --git a/users/glittershark/xanthous/build/hgeometry-fix-haddock.patch b/users/glittershark/xanthous/build/hgeometry-fix-haddock.patch new file mode 100644 index 0000000000..748c65b3e0 --- /dev/null +++ b/users/glittershark/xanthous/build/hgeometry-fix-haddock.patch @@ -0,0 +1,13 @@ +diff --git a/src/Data/Geometry/PlanarSubdivision/Merge.hs b/src/Data/Geometry/PlanarSubdivision/Merge.hs +index 1136114..3f4e7bb 100644 +--- a/src/Data/Geometry/PlanarSubdivision/Merge.hs ++++ b/src/Data/Geometry/PlanarSubdivision/Merge.hs +@@ -153,7 +153,7 @@ mergeWith' mergeFaces p1 p2 = PlanarSubdivision cs vd rd rf + -- we have to shift the number of the *Arcs*. Since every dart + -- consists of two arcs, we have to shift by numDarts / 2 + -- Furthermore, we take numFaces - 1 since we want the first +- -- *internal* face of p2 (the one with FaceId 1) to correspond with the first free ++ -- /internal/ face of p2 (the one with FaceId 1) to correspond with the first free + -- position (at index numFaces) + + cs = p1^.components <> p2'^.components diff --git a/users/glittershark/xanthous/build/update-comonad-extras.patch b/users/glittershark/xanthous/build/update-comonad-extras.patch new file mode 100644 index 0000000000..cd1dbe24d3 --- /dev/null +++ b/users/glittershark/xanthous/build/update-comonad-extras.patch @@ -0,0 +1,92 @@ +diff --git a/comonad-extras.cabal b/comonad-extras.cabal +index fc3745a..77a2f0d 100644 +--- a/comonad-extras.cabal ++++ b/comonad-extras.cabal +@@ -1,7 +1,7 @@ + name: comonad-extras + category: Control, Comonads +-version: 4.0 ++version: 5.0 + x-revision: 1 + license: BSD3 + cabal-version: >= 1.6 + license-file: LICENSE +@@ -34,8 +34,8 @@ library + build-depends: + array >= 0.3 && < 0.6, +- base >= 4 && < 4.7, +- containers >= 0.4 && < 0.6, +- comonad >= 4 && < 5, ++ base >= 4 && < 5, ++ containers >= 0.6 && < 0.7, ++ comonad >= 5 && < 6, + distributive >= 0.3.2 && < 1, +- semigroupoids >= 4 && < 5, +- transformers >= 0.2 && < 0.4 ++ semigroupoids >= 5 && < 6, ++ transformers >= 0.5 && < 0.6 + + exposed-modules: + Control.Comonad.Store.Zipper +diff --git a/src/Control/Comonad/Store/Pointer.hs b/src/Control/Comonad/Store/Pointer.hs +index 5044a1e..8d4c62d 100644 +--- a/src/Control/Comonad/Store/Pointer.hs ++++ b/src/Control/Comonad/Store/Pointer.hs +@@ -41,7 +41,6 @@ module Control.Comonad.Store.Pointer + , module Control.Comonad.Store.Class + ) where + +-import Control.Applicative + import Control.Comonad + import Control.Comonad.Hoist.Class + import Control.Comonad.Trans.Class +@@ -51,27 +50,8 @@ import Control.Comonad.Env.Class + import Data.Functor.Identity + import Data.Functor.Extend + import Data.Array +- + #ifdef __GLASGOW_HASKELL__ + import Data.Typeable +-instance (Typeable i, Typeable1 w) => Typeable1 (PointerT i w) where +- typeOf1 diwa = mkTyConApp storeTTyCon [typeOf (i diwa), typeOf1 (w diwa)] +- where +- i :: PointerT i w a -> i +- i = undefined +- w :: PointerT i w a -> w a +- w = undefined +- +-instance (Typeable i, Typeable1 w, Typeable a) => Typeable (PointerT i w a) where +- typeOf = typeOfDefault +- +-storeTTyCon :: TyCon +-#if __GLASGOW_HASKELL__ < 704 +-storeTTyCon = mkTyCon "Control.Comonad.Trans.Store.Pointer.PointerT" +-#else +-storeTTyCon = mkTyCon3 "comonad-extras" "Control.Comonad.Trans.Store.Pointer" "PointerT" +-#endif +-{-# NOINLINE storeTTyCon #-} + #endif + + type Pointer i = PointerT i Identity +@@ -83,6 +63,9 @@ runPointer :: Pointer i a -> (Array i a, i) + runPointer (PointerT (Identity f) i) = (f, i) + + data PointerT i w a = PointerT (w (Array i a)) i ++#ifdef __GLASGOW_HASKELL__ ++ deriving Typeable ++#endif + + runPointerT :: PointerT i w a -> (w (Array i a), i) + runPointerT (PointerT g i) = (g, i) +diff --git a/src/Control/Comonad/Store/Zipper.hs b/src/Control/Comonad/Store/Zipper.hs +index 3b70c86..decc378 100644 +--- a/src/Control/Comonad/Store/Zipper.hs ++++ b/src/Control/Comonad/Store/Zipper.hs +@@ -15,7 +15,6 @@ + module Control.Comonad.Store.Zipper + ( Zipper, zipper, zipper1, unzipper, size) where + +-import Control.Applicative + import Control.Comonad (Comonad(..)) + import Data.Functor.Extend + import Data.Foldable diff --git a/users/glittershark/xanthous/default.nix b/users/glittershark/xanthous/default.nix new file mode 100644 index 0000000000..0d08d7f26b --- /dev/null +++ b/users/glittershark/xanthous/default.nix @@ -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; } diff --git a/users/glittershark/xanthous/haskell-overlay.nix b/users/glittershark/xanthous/haskell-overlay.nix new file mode 100644 index 0000000000..fff1c21741 --- /dev/null +++ b/users/glittershark/xanthous/haskell-overlay.nix @@ -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 ]; +} diff --git a/users/glittershark/xanthous/hie.sh b/users/glittershark/xanthous/hie.sh new file mode 100755 index 0000000000..4ea97997c7 --- /dev/null +++ b/users/glittershark/xanthous/hie.sh @@ -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[*]}" diff --git a/users/glittershark/xanthous/nixpkgs.nix b/users/glittershark/xanthous/nixpkgs.nix new file mode 100644 index 0000000000..19bf2c59ce --- /dev/null +++ b/users/glittershark/xanthous/nixpkgs.nix @@ -0,0 +1,9 @@ +let + inherit (import <nixpkgs> {}) fetchFromGitHub; + nixpkgs = fetchFromGitHub { + owner = "NixOS"; + repo = "nixpkgs-channels"; + rev = "54f385241e6649128ba963c10314942d73245479"; + sha256 = "0bd4v8v4xcdbaiaa59yqprnc6dkb9jv12mb0h5xz7b51687ygh9l"; + }; +in import nixpkgs diff --git a/users/glittershark/xanthous/package.yaml b/users/glittershark/xanthous/package.yaml new file mode 100644 index 0000000000..5f43171e38 --- /dev/null +++ b/users/glittershark/xanthous/package.yaml @@ -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 diff --git a/users/glittershark/xanthous/pkg.nix b/users/glittershark/xanthous/pkg.nix new file mode 100644 index 0000000000..dcf508fa54 --- /dev/null +++ b/users/glittershark/xanthous/pkg.nix @@ -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"; +}) diff --git a/users/glittershark/xanthous/shell.nix b/users/glittershark/xanthous/shell.nix new file mode 100644 index 0000000000..edd2fe4c08 --- /dev/null +++ b/users/glittershark/xanthous/shell.nix @@ -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 diff --git a/users/glittershark/xanthous/src/Data/Aeson/Generic/DerivingVia.hs b/users/glittershark/xanthous/src/Data/Aeson/Generic/DerivingVia.hs new file mode 100644 index 0000000000..34f2a94038 --- /dev/null +++ b/users/glittershark/xanthous/src/Data/Aeson/Generic/DerivingVia.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, DeriveGeneric, DerivingVia #-} +{-# LANGUAGE ExplicitNamespaces, FlexibleContexts, FlexibleInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds, ScopedTypeVariables, StandaloneDeriving #-} +{-# LANGUAGE TypeApplications, TypeFamilies, TypeInType, TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wall #-} +-- | https://gist.github.com/konn/27c00f784dd883ec2b90eab8bc84a81d +module Data.Aeson.Generic.DerivingVia + ( StrFun(..), Setting(..), SumEncoding'(..), DefaultOptions, WithOptions(..) + , -- Utility type synonyms to save ticks (') before promoted data constructors + type Drop, type CamelTo2, type UserDefined + , type TaggedObj, type UntaggedVal, type ObjWithSingleField, type TwoElemArr + , type FieldLabelModifier + , type ConstructorTagModifier + , type AllNullaryToStringTag + , type OmitNothingFields + , type SumEnc + , type UnwrapUnaryRecords + , type TagSingleConstructors + ) + where + +import Prelude +import Data.Aeson (FromJSON (..), GFromJSON, GToJSON, + ToJSON (..)) +import Data.Aeson (Options (..), Zero, camelTo2, + genericParseJSON) +import Data.Aeson (defaultOptions, genericToJSON) +import qualified Data.Aeson as Aeson +import Data.Kind (Constraint, Type) +import Data.Proxy (Proxy (..)) +import Data.Reflection (Reifies (..)) +import GHC.Generics (Generic, Rep) +import GHC.TypeLits (KnownNat, KnownSymbol, natVal, symbolVal) +import GHC.TypeLits (Nat, Symbol) + +newtype WithOptions options a = WithOptions { runWithOptions :: a } + +data StrFun = Drop Nat + | CamelTo2 Symbol + | forall p. UserDefined p + +type Drop = 'Drop +type CamelTo2 = 'CamelTo2 +type UserDefined = 'UserDefined + +type family Demoted a where + Demoted Symbol = String + Demoted StrFun = String -> String + Demoted [a] = [Demoted a] + Demoted Setting = Options -> Options + Demoted SumEncoding' = Aeson.SumEncoding + Demoted a = a + +data SumEncoding' = TaggedObj {tagFieldName' :: Symbol, contentsFieldName :: Symbol } + | UntaggedVal + | ObjWithSingleField + | TwoElemArr + +type TaggedObj = 'TaggedObj +type UntaggedVal = 'UntaggedVal +type ObjWithSingleField = 'ObjWithSingleField +type TwoElemArr = 'TwoElemArr + +data Setting = FieldLabelModifier [StrFun] + | ConstructorTagModifier [StrFun] + | AllNullaryToStringTag Bool + | OmitNothingFields Bool + | SumEnc SumEncoding' + | UnwrapUnaryRecords Bool + | TagSingleConstructors Bool + +type FieldLabelModifier = 'FieldLabelModifier +type ConstructorTagModifier = 'ConstructorTagModifier +-- | If 'True' the constructors of a datatype, with all nullary constructors, +-- will be encoded to just a string with the constructor tag. If 'False' the +-- encoding will always follow the 'SumEncoding'. +type AllNullaryToStringTag = 'AllNullaryToStringTag +type OmitNothingFields = 'OmitNothingFields +type SumEnc = 'SumEnc +-- | Hide the field name when a record constructor has only one field, like a +-- newtype. +type UnwrapUnaryRecords = 'UnwrapUnaryRecords +-- | Encode types with a single constructor as sums, so that +-- 'AllNullaryToStringTag' and 'SumEncoding' apply. +type TagSingleConstructors = 'TagSingleConstructors + +class Demotable (a :: k) where + demote :: proxy a -> Demoted k + +type family All (p :: Type -> Constraint) (xs :: [k]) :: Constraint where + All p '[] = () + All p (x ': xs) = (p x, All p xs) + +instance Reifies f (String -> String) => Demotable ('UserDefined f) where + demote _ = reflect @f Proxy + +instance KnownSymbol sym => Demotable sym where + demote = symbolVal + +instance (KnownSymbol s, KnownSymbol t) => Demotable ('TaggedObj s t) where + demote _ = Aeson.TaggedObject (symbolVal @s Proxy) (symbolVal @t Proxy) + +instance Demotable 'UntaggedVal where + demote _ = Aeson.UntaggedValue + +instance Demotable 'ObjWithSingleField where + demote _ = Aeson.ObjectWithSingleField + +instance Demotable 'TwoElemArr where + demote _ = Aeson.TwoElemArray + +instance Demotable xs => Demotable ('FieldLabelModifier xs) where + demote _ o = o { fieldLabelModifier = foldr (.) id (demote (Proxy @xs)) } + +instance Demotable xs => Demotable ('ConstructorTagModifier xs) where + demote _ o = o { constructorTagModifier = foldr (.) id (demote (Proxy @xs)) } + +instance Demotable b => Demotable ('AllNullaryToStringTag b) where + demote _ o = o { allNullaryToStringTag = demote (Proxy @b) } + +instance Demotable b => Demotable ('OmitNothingFields b) where + demote _ o = o { omitNothingFields = demote (Proxy @b) } + +instance Demotable b => Demotable ('UnwrapUnaryRecords b) where + demote _ o = o { unwrapUnaryRecords = demote (Proxy @b) } + +instance Demotable b => Demotable ('TagSingleConstructors b) where + demote _ o = o { tagSingleConstructors = demote (Proxy @b) } + +instance Demotable b => Demotable ('SumEnc b) where + demote _ o = o { sumEncoding = demote (Proxy @b) } + +instance Demotable 'True where + demote _ = True + +instance Demotable 'False where + demote _ = False + +instance KnownNat n => Demotable ('Drop n) where + demote _ = drop (fromIntegral $ natVal (Proxy :: Proxy n)) + +instance KnownSymbol sym => Demotable ('CamelTo2 sym) where + demote _ = camelTo2 $ head $ symbolVal @sym Proxy + +instance {-# OVERLAPPING #-} Demotable ('[] :: [k]) where + demote _ = [] + +instance (Demotable (x :: k), Demotable (xs :: [k])) => Demotable (x ': xs) where + demote _ = demote (Proxy @x) : demote (Proxy @xs) + +type DefaultOptions = ('[] :: [Setting]) + +reflectOptions :: forall xs proxy. Demotable (xs :: [Setting]) => proxy xs -> Options +reflectOptions pxy = foldr (.) id (demote pxy) defaultOptions + +instance (Demotable (options :: [Setting])) => Reifies options Options where + reflect = reflectOptions + +instance (Generic a, GToJSON Zero (Rep a), Reifies (options :: k) Options) + => ToJSON (WithOptions options a) where + toJSON = genericToJSON (reflect (Proxy @options)) . runWithOptions + +instance (Generic a, GFromJSON Zero (Rep a), Reifies (options :: k) Options) + => FromJSON (WithOptions options a) where + parseJSON = fmap WithOptions . genericParseJSON (reflect (Proxy @options)) diff --git a/users/glittershark/xanthous/src/Main.hs b/users/glittershark/xanthous/src/Main.hs new file mode 100644 index 0000000000..dcd31afff9 --- /dev/null +++ b/users/glittershark/xanthous/src/Main.hs @@ -0,0 +1,159 @@ +module Main ( main ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (finally) +import Brick +import qualified Brick.BChan +import qualified Graphics.Vty as Vty +import qualified Options.Applicative as Opt +import System.Random +import Control.Monad.Random (getRandom) +import Control.Exception (finally) +import System.Exit (die) +-------------------------------------------------------------------------------- +import qualified Xanthous.Game as Game +import Xanthous.Game.Env (GameEnv(..)) +import Xanthous.App +import Xanthous.Generators + ( GeneratorInput + , parseGeneratorInput + , generateFromInput + , showCells + ) +import qualified Xanthous.Entities.Character as Character +import Xanthous.Generators.Util (regions) +import Xanthous.Generators.LevelContents +import Xanthous.Data (Dimensions, Dimensions'(Dimensions)) +import Data.Array.IArray ( amap ) +-------------------------------------------------------------------------------- + +data RunParams = RunParams + { seed :: Maybe Int + , characterName :: Maybe Text + } + deriving stock (Show, Eq) + +parseRunParams :: Opt.Parser RunParams +parseRunParams = RunParams + <$> optional (Opt.option Opt.auto + ( Opt.long "seed" + <> Opt.help "Random seed for the game." + )) + <*> optional (Opt.strOption + ( Opt.short 'n' + <> Opt.long "name" + <> Opt.help + ( "Name for the character. If not set on the command line, " + <> "will be prompted for at runtime" + ) + )) + +data Command + = Run RunParams + | Load FilePath + | Generate GeneratorInput Dimensions (Maybe Int) + +parseDimensions :: Opt.Parser Dimensions +parseDimensions = Dimensions + <$> Opt.option Opt.auto + ( Opt.short 'w' + <> Opt.long "width" + <> Opt.metavar "TILES" + ) + <*> Opt.option Opt.auto + ( Opt.short 'h' + <> Opt.long "height" + <> Opt.metavar "TILES" + ) + + +parseCommand :: Opt.Parser Command +parseCommand = (<|> Run <$> parseRunParams) $ Opt.subparser + $ Opt.command "run" + (Opt.info + (Run <$> parseRunParams) + (Opt.progDesc "Run the game")) + <> Opt.command "load" + (Opt.info + (Load <$> Opt.argument Opt.str (Opt.metavar "FILE")) + (Opt.progDesc "Load a saved game")) + <> Opt.command "generate" + (Opt.info + (Generate + <$> parseGeneratorInput + <*> parseDimensions + <*> optional + (Opt.option Opt.auto (Opt.long "seed")) + <**> Opt.helper + ) + (Opt.progDesc "Generate a sample level")) + +optParser :: Opt.ParserInfo Command +optParser = Opt.info + (parseCommand <**> Opt.helper) + (Opt.header "Xanthous: a WIP TUI RPG") + +thanks :: IO () +thanks = putStr "\n\n" >> putStrLn "Thanks for playing Xanthous!" + +newGame :: RunParams -> IO () +newGame rparams = do + gameSeed <- maybe getRandom pure $ seed rparams + when (isNothing $ seed rparams) + . putStrLn + $ "Seed: " <> tshow gameSeed + let initialState = Game.initialStateFromSeed gameSeed &~ do + for_ (characterName rparams) $ \cn -> + Game.character . Character.characterName ?= cn + runGame NewGame initialState `finally` do + thanks + when (isNothing $ seed rparams) + . putStrLn + $ "Seed: " <> tshow gameSeed + putStr "\n\n" + +loadGame :: FilePath -> IO () +loadGame saveFile = do + gameState <- maybe (die "Invalid save file!") pure + =<< Game.loadGame . fromStrict <$> readFile @IO saveFile + gameState `deepseq` runGame LoadGame gameState + +runGame :: RunType -> Game.GameState -> IO () +runGame rt gameState = do + eventChan <- Brick.BChan.newBChan 10 + let gameEnv = GameEnv eventChan + app <- makeApp gameEnv rt + let buildVty = Vty.mkVty Vty.defaultConfig + initialVty <- buildVty + _game' <- customMain + initialVty + buildVty + (Just eventChan) + app + gameState + pure () + +runGenerate :: GeneratorInput -> Dimensions -> Maybe Int -> IO () +runGenerate input dims mSeed = do + putStrLn "Generating..." + genSeed <- maybe getRandom pure mSeed + let randGen = mkStdGen genSeed + res = generateFromInput input dims randGen + rs = regions $ amap not res + when (isNothing mSeed) + . putStrLn + $ "Seed: " <> tshow genSeed + putStr "num regions: " + print $ length rs + putStr "region lengths: " + print $ length <$> rs + putStr "character position: " + print =<< chooseCharacterPosition res + putStrLn $ showCells res + +runCommand :: Command -> IO () +runCommand (Run runParams) = newGame runParams +runCommand (Load saveFile) = loadGame saveFile +runCommand (Generate input dims mSeed) = runGenerate input dims mSeed + +main :: IO () +main = runCommand =<< Opt.execParser optParser diff --git a/users/glittershark/xanthous/src/Xanthous/AI/Gormlak.hs b/users/glittershark/xanthous/src/Xanthous/AI/Gormlak.hs new file mode 100644 index 0000000000..8040fea35b --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/AI/Gormlak.hs @@ -0,0 +1,124 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE UndecidableInstances #-} +-------------------------------------------------------------------------------- +module Xanthous.AI.Gormlak + ( HasVisionRadius(..) + , GormlakBrain(..) + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (lines) +-------------------------------------------------------------------------------- +import Control.Monad.State +import Control.Monad.Random +import Data.Aeson (object) +import qualified Data.Aeson as A +import Data.Generics.Product.Fields +-------------------------------------------------------------------------------- +import Xanthous.Data + ( Positioned(..), positioned, position + , diffPositions, stepTowards, isUnit + , Ticks, (|*|), invertedRate + ) +import Xanthous.Data.EntityMap +import Xanthous.Entities.Creature.Hippocampus +import Xanthous.Entities.Character (Character) +import qualified Xanthous.Entities.Character as Character +import qualified Xanthous.Entities.RawTypes as Raw +import Xanthous.Entities.RawTypes (CreatureType) +import Xanthous.Game.State +import Xanthous.Game.Lenses + ( Collision(..), entitiesCollision, collisionAt + , character, characterPosition + ) +import Xanthous.Data.EntityMap.Graphics (linesOfSight, canSee) +import Xanthous.Random +import Xanthous.Monad (say) +-------------------------------------------------------------------------------- + +-- TODO move the following two classes to a more central location + +class HasVisionRadius a where visionRadius :: a -> Word + +type IsCreature entity = + ( HasVisionRadius entity + , HasField "_hippocampus" entity entity Hippocampus Hippocampus + , HasField "_creatureType" entity entity CreatureType CreatureType + , A.ToJSON entity + ) + +-------------------------------------------------------------------------------- + +stepGormlak + :: forall entity m. + ( MonadState GameState m, MonadRandom m + , IsCreature entity + ) + => Ticks + -> Positioned entity + -> m (Positioned entity) +stepGormlak ticks pe@(Positioned pos creature) = do + dest <- maybe (selectDestination pos creature) pure + $ creature ^. field @"_hippocampus" . destination + let progress' = + dest ^. destinationProgress + + creature ^. field @"_creatureType" . Raw.speed . invertedRate |*| ticks + if progress' < 1 + then pure + $ pe + & positioned . field @"_hippocampus" . destination + ?~ (dest & destinationProgress .~ progress') + else do + let newPos = dest ^. destinationPosition + remainingSpeed = progress' - 1 + newDest <- selectDestination newPos creature + <&> destinationProgress +~ remainingSpeed + let pe' = pe & positioned . field @"_hippocampus" . destination ?~ newDest + collisionAt newPos >>= \case + Nothing -> pure $ pe' & position .~ newPos + Just Stop -> pure pe' + Just Combat -> do + ents <- use $ entities . atPosition newPos + when (any (entityIs @Character) ents) attackCharacter + pure pe' + where + selectDestination pos' creature' = destinationFromPos <$> do + canSeeCharacter <- uses entities $ canSee (entityIs @Character) pos' vision + if canSeeCharacter + then do + charPos <- use characterPosition + if isUnit (pos' `diffPositions` charPos) + then attackCharacter $> pos' + else pure $ pos' `stepTowards` charPos + else do + lines <- map (takeWhile (isNothing . entitiesCollision . map snd . snd) + -- the first item on these lines is always the creature itself + . fromMaybe mempty . tailMay) + . linesOfSight pos' (visionRadius creature') + <$> use entities + line <- choose $ weightedBy length lines + pure $ fromMaybe pos' $ fmap fst . headMay =<< line + + vision = visionRadius creature + attackCharacter = do + say ["combat", "creatureAttack"] $ object [ "creature" A..= creature ] + character %= Character.damage 1 + +newtype GormlakBrain entity = GormlakBrain { _unGormlakBrain :: entity } + +instance (IsCreature entity) => Brain (GormlakBrain entity) where + step ticks + = fmap (fmap GormlakBrain) + . stepGormlak ticks + . fmap _unGormlakBrain + entityCanMove = const True + +-------------------------------------------------------------------------------- + +-- instance Brain Creature where +-- step = brainVia GormlakBrain +-- entityCanMove = const True + +-- instance Entity Creature where +-- blocksVision _ = False +-- description = view $ Creature.creatureType . Raw.description +-- entityChar = view $ Creature.creatureType . char diff --git a/users/glittershark/xanthous/src/Xanthous/App.hs b/users/glittershark/xanthous/src/Xanthous/App.hs new file mode 100644 index 0000000000..672aa93f6b --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/App.hs @@ -0,0 +1,468 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE RecordWildCards #-} +-------------------------------------------------------------------------------- +module Xanthous.App + ( makeApp + , RunType(..) + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +import Brick hiding (App, halt, continue, raw) +import qualified Brick +import Graphics.Vty.Attributes (defAttr) +import Graphics.Vty.Input.Events (Event(EvKey)) +import Control.Monad.State (get, gets) +import Control.Monad.State.Class (modify) +import Data.Aeson (object, ToJSON) +import qualified Data.Aeson as A +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.Vector as V +import System.Exit +import System.Directory (doesFileExist) +-------------------------------------------------------------------------------- +import Xanthous.App.Common +import Xanthous.App.Time +import Xanthous.App.Prompt +import Xanthous.App.Autocommands +import Xanthous.Command +import Xanthous.Data + ( move + , Dimensions'(Dimensions) + , positioned + , position + , Position + , (|*|) + ) +import Xanthous.Data.App (ResourceName, Panel(..), AppEvent(..)) +import qualified Xanthous.Data.EntityMap as EntityMap +import Xanthous.Data.Levels (prevLevel, nextLevel) +import qualified Xanthous.Data.Levels as Levels +import Xanthous.Data.Entities (blocksObject) +import Xanthous.Game +import Xanthous.Game.State +import Xanthous.Game.Env +import Xanthous.Game.Draw (drawGame) +import Xanthous.Game.Prompt +import qualified Xanthous.Messages as Messages +import Xanthous.Random +import Xanthous.Util (removeVectorIndex) +import Xanthous.Util.Inflection (toSentence) +-------------------------------------------------------------------------------- +import qualified Xanthous.Entities.Character as Character +import Xanthous.Entities.Character hiding (pickUpItem) +import Xanthous.Entities.Item (Item) +import qualified Xanthous.Entities.Item as Item +import Xanthous.Entities.Creature (Creature) +import qualified Xanthous.Entities.Creature as Creature +import Xanthous.Entities.Environment + (Door, open, closed, locked, GroundMessage(..), Staircase(..)) +import Xanthous.Entities.RawTypes + ( edible, eatMessage, hitpointsHealed + , attackMessage + ) +import Xanthous.Generators +import qualified Xanthous.Generators.CaveAutomata as CaveAutomata +import qualified Xanthous.Generators.Dungeon as Dungeon +-------------------------------------------------------------------------------- + +type App = Brick.App GameState AppEvent ResourceName + +data RunType = NewGame | LoadGame + deriving stock (Eq) + +makeApp :: GameEnv -> RunType -> IO App +makeApp env rt = pure $ Brick.App + { appDraw = drawGame + , appChooseCursor = const headMay + , appHandleEvent = \game event -> runAppM (handleEvent event) env game + , appStartEvent = case rt of + NewGame -> runAppM (startEvent >> get) env + LoadGame -> pure + , appAttrMap = const $ attrMap defAttr [] + } + +runAppM :: AppM a -> GameEnv -> GameState -> EventM ResourceName a +runAppM appm ge = fmap fst . runAppT appm ge + +startEvent :: AppM () +startEvent = do + initLevel + modify updateCharacterVision + use (character . characterName) >>= \case + Nothing -> prompt_ @'StringPrompt ["character", "namePrompt"] Uncancellable + $ \(StringResult s) -> do + character . characterName ?= s + say ["welcome"] =<< use character + Just n -> say ["welcome"] $ object [ "characterName" A..= n ] + +initLevel :: AppM () +initLevel = do + level <- genLevel 0 + entities <>= levelToEntityMap level + characterPosition .= level ^. levelCharacterPosition + +-------------------------------------------------------------------------------- + +handleEvent :: BrickEvent ResourceName AppEvent -> AppM (Next GameState) +handleEvent ev = use promptState >>= \case + NoPrompt -> handleNoPromptEvent ev + WaitingPrompt msg pr -> handlePromptEvent msg pr ev + + +handleNoPromptEvent :: BrickEvent ResourceName AppEvent -> AppM (Next GameState) +handleNoPromptEvent (VtyEvent (EvKey k mods)) + | Just command <- commandFromKey k mods + = do messageHistory %= nextTurn + handleCommand command +handleNoPromptEvent (AppEvent AutoContinue) = do + preuse (autocommand . _ActiveAutocommand . _1) >>= traverse_ autoStep + continue +handleNoPromptEvent _ = continue + +handleCommand :: Command -> AppM (Next GameState) +handleCommand Quit = confirm_ ["quit", "confirm"] (liftIO exitSuccess) >> continue +handleCommand (Move dir) = do + newPos <- uses characterPosition $ move dir + collisionAt newPos >>= \case + Nothing -> do + characterPosition .= newPos + stepGameBy =<< uses (character . speed) (|*| 1) + describeEntitiesAt newPos + Just Combat -> attackAt newPos + Just Stop -> pure () + continue + +handleCommand PickUp = do + pos <- use characterPosition + uses entities (entitiesAtPositionWithType @Item pos) >>= \case + [] -> say_ ["pickUp", "nothingToPickUp"] + [item] -> pickUpItem item + items' -> + menu_ ["pickUp", "menu"] Cancellable (entityMenu_ items') + $ \(MenuResult item) -> pickUpItem item + continue + where + pickUpItem (itemID, item) = do + character %= Character.pickUpItem item + entities . at itemID .= Nothing + say ["pickUp", "pickUp"] $ object [ "item" A..= item ] + stepGameBy 100 -- TODO + +handleCommand Drop = do + selectItemFromInventory_ ["drop", "menu"] Cancellable id + (say_ ["drop", "nothing"]) + $ \(MenuResult item) -> do + entitiesAtCharacter %= (SomeEntity item <|) + say ["drop", "dropped"] $ object [ "item" A..= item ] + continue + +handleCommand PreviousMessage = do + messageHistory %= previousMessage + continue + +handleCommand Open = do + prompt_ @'DirectionPrompt ["open", "prompt"] Cancellable + $ \(DirectionResult dir) -> do + pos <- move dir <$> use characterPosition + doors <- uses entities $ entitiesAtPositionWithType @Door pos + if | null doors -> say_ ["open", "nothingToOpen"] + | any (view $ _2 . locked) doors -> say_ ["open", "locked"] + | all (view $ _2 . open) doors -> say_ ["open", "alreadyOpen"] + | otherwise -> do + for_ doors $ \(eid, _) -> + entities . ix eid . positioned . _SomeEntity . open .= True + say_ ["open", "success"] + pure () + stepGame -- TODO + continue + +handleCommand Close = do + prompt_ @'DirectionPrompt ["close", "prompt"] Cancellable + $ \(DirectionResult dir) -> do + pos <- move dir <$> use characterPosition + (nonDoors, doors) <- uses entities + $ partitionEithers + . toList + . map ( (matching . aside $ _SomeEntity @Door) + . over _2 (view positioned) + ) + . EntityMap.atPositionWithIDs pos + if | null doors -> say_ ["close", "nothingToClose"] + | all (view $ _2 . closed) doors -> say_ ["close", "alreadyClosed"] + | any (view blocksObject . entityAttributes . snd) nonDoors -> + say ["close", "blocked"] + $ object [ "entityDescriptions" + A..= ( toSentence + . map description + . filter (view blocksObject . entityAttributes) + . map snd + ) nonDoors + , "blockOrBlocks" + A..= ( if length nonDoors == 1 + then "blocks" + else "block" + :: Text) + ] + | otherwise -> do + for_ doors $ \(eid, _) -> + entities . ix eid . positioned . _SomeEntity . closed .= True + for_ nonDoors $ \(eid, _) -> + entities . ix eid . position %= move dir + say_ ["close", "success"] + pure () + stepGame -- TODO + continue + +handleCommand Look = do + prompt_ @'PointOnMap ["look", "prompt"] Cancellable + $ \(PointOnMapResult pos) -> + use (entities . EntityMap.atPosition pos) + >>= \case + Empty -> say_ ["look", "nothing"] + ents -> describeEntities ents + continue + +handleCommand Wait = stepGame >> continue + +handleCommand Eat = do + uses (character . inventory . backpack) + (V.mapMaybe (\item -> (item,) <$> item ^. Item.itemType . edible)) + >>= \case + Empty -> say_ ["eat", "noFood"] + food -> + let foodMenuItem idx (item, edibleItem) + = ( item ^. Item.itemType . char . char + , MenuOption (description item) (idx, item, edibleItem)) + -- TODO refactor to use entityMenu_ + menuItems = mkMenuItems $ imap foodMenuItem food + in menu_ ["eat", "menuPrompt"] Cancellable menuItems + $ \(MenuResult (idx, item, edibleItem)) -> do + character . inventory . backpack %= removeVectorIndex idx + let msg = fromMaybe (Messages.lookup ["eat", "eat"]) + $ edibleItem ^. eatMessage + character . characterHitpoints' += + edibleItem ^. hitpointsHealed . to fromIntegral + message msg $ object ["item" A..= item] + stepGame -- TODO + continue + +handleCommand Read = do + -- TODO allow reading things in the inventory (combo direction+menu prompt?) + prompt_ @'DirectionPrompt ["read", "prompt"] Cancellable + $ \(DirectionResult dir) -> do + pos <- uses characterPosition $ move dir + uses entities + (fmap snd . entitiesAtPositionWithType @GroundMessage pos) >>= \case + Empty -> say_ ["read", "nothing"] + GroundMessage msg :< Empty -> + say ["read", "result"] $ object ["message" A..= msg] + msgs -> + let readAndContinue Empty = pure () + readAndContinue (msg :< msgs') = + prompt @'Continue + ["read", "result"] + (object ["message" A..= msg]) + Cancellable + . const + $ readAndContinue msgs' + readAndContinue _ = error "this is total" + in readAndContinue msgs + continue + +handleCommand ShowInventory = showPanel InventoryPanel >> continue + +handleCommand Wield = do + selectItemFromInventory_ ["wield", "menu"] Cancellable asWieldedItem + (say_ ["wield", "nothing"]) + $ \(MenuResult item) -> do + prevItems <- character . inventory . wielded <<.= inRightHand item + character . inventory . backpack + <>= fromList (prevItems ^.. wieldedItems . wieldedItem) + say ["wield", "wielded"] item + continue + +handleCommand Save = do + -- TODO default save locations / config file? + prompt_ @'StringPrompt ["save", "location"] Cancellable + $ \(StringResult filename) -> do + exists <- liftIO . doesFileExist $ unpack filename + if exists + then confirm ["save", "overwrite"] (object ["filename" A..= filename]) + $ doSave filename + else doSave filename + continue + where + doSave filename = do + src <- gets saveGame + lift . liftIO $ do + writeFile (unpack filename) $ toStrict src + exitSuccess + +handleCommand GoUp = do + hasStairs <- uses entitiesAtCharacter $ elem (SomeEntity UpStaircase) + if hasStairs + then uses levels prevLevel >>= \case + Just levs' -> levels .= levs' + Nothing -> + -- TODO in nethack, this leaves the game. Maybe something similar here? + say_ ["cant", "goUp"] + else say_ ["cant", "goUp"] + + continue + +handleCommand GoDown = do + hasStairs <- uses entitiesAtCharacter $ elem (SomeEntity DownStaircase) + + if hasStairs + then do + levs <- use levels + let newLevelNum = Levels.pos levs + 1 + levs' <- nextLevel (levelToGameLevel <$> genLevel newLevelNum) levs + cEID <- use characterEntityID + pCharacter <- entities . at cEID <<.= Nothing + levels .= levs' + entities . at cEID .= pCharacter + characterPosition .= extract levs' ^. upStaircasePosition + else say_ ["cant", "goDown"] + + continue + +handleCommand (StartAutoMove dir) = do + runAutocommand $ AutoMove dir + continue + +-- + +handleCommand ToggleRevealAll = do + val <- debugState . allRevealed <%= not + say ["debug", "toggleRevealAll"] $ object [ "revealAll" A..= val ] + continue + +-------------------------------------------------------------------------------- +attackAt :: Position -> AppM () +attackAt pos = + uses entities (entitiesAtPositionWithType @Creature pos) >>= \case + Empty -> say_ ["combat", "nothingToAttack"] + (creature :< Empty) -> attackCreature creature + creatures -> + menu_ ["combat", "menu"] Cancellable (entityMenu_ creatures) + $ \(MenuResult creature) -> attackCreature creature + where + attackCreature (creatureID, creature) = do + charDamage <- uses character characterDamage + let creature' = Creature.damage charDamage creature + msgParams = object ["creature" A..= creature'] + if Creature.isDead creature' + then do + say ["combat", "killed"] msgParams + entities . at creatureID .= Nothing + else do + msg <- uses character getAttackMessage + message msg msgParams + entities . ix creatureID . positioned .= SomeEntity creature' + + whenM (uses character $ isNothing . weapon) + $ whenM (chance (0.08 :: Float)) $ do + say_ ["combat", "fistSelfDamage"] + character %= Character.damage 1 + + stepGame -- TODO + weapon chr = chr ^? inventory . wielded . wieldedItems . wieldableItem + getAttackMessage chr = + case weapon chr of + Just wi -> + fromMaybe (Messages.lookup ["combat", "hit", "generic"]) + $ wi ^. attackMessage + Nothing -> + Messages.lookup ["combat", "hit", "fists"] + +entityMenu_ + :: (Comonad w, Entity entity) + => [w entity] + -> Map Char (MenuOption (w entity)) +entityMenu_ = mkMenuItems @[_] . map entityMenuItem + where + entityMenuItem wentity + = let entity = extract wentity + in (entityMenuChar entity, MenuOption (description entity) wentity) + + +entityMenuChar :: Entity a => a -> Char +entityMenuChar entity + = let ec = entityChar entity ^. char + in if ec `elem` (['a'..'z'] ++ ['A'..'Z']) + then ec + else 'a' + +-- | Prompt with an item to select out of the inventory, remove it from the +-- inventory, and call callback with it +selectItemFromInventory + :: forall item params. + (ToJSON params) + => [Text] -- ^ Menu message + -> params -- ^ Menu message params + -> PromptCancellable -- ^ Is the menu cancellable? + -> Prism' Item item -- ^ Attach some extra information to the item, in a + -- recoverable fashion. Prism vs iso so we can discard + -- items. + -> AppM () -- ^ Action to take if there are no items matching + -> (PromptResult ('Menu item) -> AppM ()) + -> AppM () +selectItemFromInventory msgPath msgParams cancellable extraInfo onEmpty cb = + uses (character . inventory . backpack) + (V.mapMaybe $ preview extraInfo) + >>= \case + Empty -> onEmpty + items' -> + menu msgPath msgParams cancellable (itemMenu items') + $ \(MenuResult (idx, item)) -> do + character . inventory . backpack %= removeVectorIndex idx + cb $ MenuResult item + where + itemMenu = mkMenuItems . imap itemMenuItem + itemMenuItem idx extraInfoItem = + let item = extraInfo # extraInfoItem + in ( entityMenuChar item + , MenuOption (description item) (idx, extraInfoItem)) + +selectItemFromInventory_ + :: forall item. + [Text] -- ^ Menu message + -> PromptCancellable -- ^ Is the menu cancellable? + -> Prism' Item item -- ^ Attach some extra information to the item, in a + -- recoverable fashion. Prism vs iso so we can discard + -- items. + -> AppM () -- ^ Action to take if there are no items matching + -> (PromptResult ('Menu item) -> AppM ()) + -> AppM () +selectItemFromInventory_ msgPath = selectItemFromInventory msgPath () + +-- entityMenu :: Entity entity => [entity] -> Map Char (MenuOption entity) +-- entityMenu = map (map runIdentity) . entityMenu_ . fmap Identity + +showPanel :: Panel -> AppM () +showPanel panel = do + activePanel ?= panel + prompt_ @'Continue ["generic", "continue"] Uncancellable + . const + $ activePanel .= Nothing + +-------------------------------------------------------------------------------- + +genLevel + :: Int -- ^ level number + -> AppM Level +genLevel _num = do + let dims = Dimensions 80 80 + generator <- choose $ CaveAutomata :| [Dungeon] + level <- case generator of + CaveAutomata -> generateLevel SCaveAutomata CaveAutomata.defaultParams dims + Dungeon -> generateLevel SDungeon Dungeon.defaultParams dims + pure $!! level + +levelToGameLevel :: Level -> GameLevel +levelToGameLevel level = + let _levelEntities = levelToEntityMap level + _upStaircasePosition = level ^. levelCharacterPosition + _levelRevealedPositions = mempty + in GameLevel {..} diff --git a/users/glittershark/xanthous/src/Xanthous/App/Autocommands.hs b/users/glittershark/xanthous/src/Xanthous/App/Autocommands.hs new file mode 100644 index 0000000000..35b92bba72 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/App/Autocommands.hs @@ -0,0 +1,65 @@ +-------------------------------------------------------------------------------- +module Xanthous.App.Autocommands + ( runAutocommand + , autoStep + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Control.Concurrent (threadDelay) +import qualified Data.Aeson as A +import Data.Aeson (object) +import Data.List.NonEmpty (nonEmpty) +import qualified Data.List.NonEmpty as NE +import Control.Monad.State (gets) +-------------------------------------------------------------------------------- +import Xanthous.App.Common +import Xanthous.App.Time +import Xanthous.Data +import Xanthous.Data.App +import Xanthous.Entities.Character (speed) +import Xanthous.Entities.Creature (Creature, creatureType) +import Xanthous.Entities.RawTypes (hostile) +import Xanthous.Game.State +import Xanthous.Game.Lenses (characterVisibleEntities) +-------------------------------------------------------------------------------- + +autoStep :: Autocommand -> AppM () +autoStep (AutoMove dir) = do + newPos <- uses characterPosition $ move dir + collisionAt newPos >>= \case + Nothing -> do + characterPosition .= newPos + stepGameBy =<< uses (character . speed) (|*| 1) + describeEntitiesAt newPos + maybeVisibleEnemies <- nonEmpty <$> enemiesInSight + for_ maybeVisibleEnemies $ \visibleEnemies -> do + say ["autoMove", "enemyInSight"] + $ object [ "firstEntity" A..= NE.head visibleEnemies ] + cancelAutocommand + Just _ -> cancelAutocommand + where + enemiesInSight :: AppM [Creature] + enemiesInSight = do + ents <- gets characterVisibleEntities + pure $ ents + ^.. folded + . _SomeEntity @Creature + . filtered (view $ creatureType . hostile) + +-------------------------------------------------------------------------------- + +autocommandIntervalμs :: Int +autocommandIntervalμs = 1000 * 50 -- 50 ms + +runAutocommand :: Autocommand -> AppM () +runAutocommand ac = do + env <- ask + tid <- liftIO . async $ runReaderT go env + autocommand .= ActiveAutocommand ac tid + where + go = everyμs autocommandIntervalμs $ sendEvent AutoContinue + +-- | Perform 'act' every μs microseconds forever +everyμs :: MonadIO m => Int -> m () -> m () +everyμs μs act = act >> liftIO (threadDelay μs) >> everyμs μs act diff --git a/users/glittershark/xanthous/src/Xanthous/App/Common.hs b/users/glittershark/xanthous/src/Xanthous/App/Common.hs new file mode 100644 index 0000000000..69ba6f0e05 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/App/Common.hs @@ -0,0 +1,67 @@ +-------------------------------------------------------------------------------- +module Xanthous.App.Common + ( describeEntities + , describeEntitiesAt + , entitiesAtPositionWithType + + -- * Re-exports + , MonadState + , MonadRandom + , EntityMap + , module Xanthous.Game.Lenses + , module Xanthous.Monad + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Data.Aeson (object) +import qualified Data.Aeson as A +import Control.Monad.State (MonadState) +import Control.Monad.Random (MonadRandom) +-------------------------------------------------------------------------------- +import Xanthous.Data (Position, positioned) +import Xanthous.Data.EntityMap (EntityMap) +import qualified Xanthous.Data.EntityMap as EntityMap +import Xanthous.Game +import Xanthous.Game.Lenses +import Xanthous.Game.State +import Xanthous.Monad +import Xanthous.Entities.Character (Character) +import Xanthous.Util.Inflection (toSentence) +-------------------------------------------------------------------------------- + +entitiesAtPositionWithType + :: forall a. (Entity a, Typeable a) + => Position + -> EntityMap SomeEntity + -> [(EntityMap.EntityID, a)] +entitiesAtPositionWithType pos em = + let someEnts = EntityMap.atPositionWithIDs pos em + in flip foldMap someEnts $ \(eid, view positioned -> se) -> + case downcastEntity @a se of + Just e -> [(eid, e)] + Nothing -> [] + +describeEntitiesAt :: (MonadState GameState m, MonadRandom m) => Position -> m () +describeEntitiesAt pos = + use ( entities + . EntityMap.atPosition pos + . to (filter (not . entityIs @Character)) + ) >>= \case + Empty -> pure () + ents -> describeEntities ents + +describeEntities + :: ( Entity entity + , MonadRandom m + , MonadState GameState m + , MonoFoldable (f Text) + , Functor f + , Element (f Text) ~ Text + ) + => f entity + -> m () +describeEntities ents = + let descriptions = description <$> ents + in say ["entities", "description"] + $ object ["entityDescriptions" A..= toSentence descriptions] diff --git a/users/glittershark/xanthous/src/Xanthous/App/Prompt.hs b/users/glittershark/xanthous/src/Xanthous/App/Prompt.hs new file mode 100644 index 0000000000..6704a601da --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/App/Prompt.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE UndecidableInstances #-} +-------------------------------------------------------------------------------- +module Xanthous.App.Prompt + ( handlePromptEvent + , clearPrompt + , prompt + , prompt_ + , confirm_ + , confirm + , menu + , menu_ + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Brick (BrickEvent(..), Next) +import Brick.Widgets.Edit (handleEditorEvent) +import Data.Aeson (ToJSON, object) +import Graphics.Vty.Input.Events (Event(EvKey), Key(..)) +import GHC.TypeLits (TypeError, ErrorMessage(..)) +-------------------------------------------------------------------------------- +import Xanthous.App.Common +import Xanthous.Data (move) +import Xanthous.Command (directionFromChar) +import Xanthous.Data.App (ResourceName, AppEvent) +import Xanthous.Game.Prompt +import Xanthous.Game.State +import qualified Xanthous.Messages as Messages +-------------------------------------------------------------------------------- + +handlePromptEvent + :: Text -- ^ Prompt message + -> Prompt AppM + -> BrickEvent ResourceName AppEvent + -> AppM (Next GameState) + +handlePromptEvent _ (Prompt Cancellable _ _ _ _) (VtyEvent (EvKey KEsc [])) + = clearPrompt >> continue +handlePromptEvent _ pr (VtyEvent (EvKey KEnter [])) + = clearPrompt >> submitPrompt pr >> continue + +handlePromptEvent _ pr@(Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'y') [])) + = clearPrompt >> submitPrompt pr >> continue + +handlePromptEvent _ (Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'n') [])) + = clearPrompt >> continue + +handlePromptEvent + msg + (Prompt c SStringPrompt (StringPromptState edit) pri cb) + (VtyEvent ev) + = do + edit' <- lift $ handleEditorEvent ev edit + let prompt' = Prompt c SStringPrompt (StringPromptState edit') pri cb + promptState .= WaitingPrompt msg prompt' + continue + +handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ cb) + (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) [])) + = clearPrompt >> cb (DirectionResult dir) >> continue +handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ _) _ = continue + +handlePromptEvent _ (Prompt _ SMenu _ items' cb) (VtyEvent (EvKey (KChar chr) [])) + | Just (MenuOption _ res) <- items' ^. at chr + = clearPrompt >> cb (MenuResult res) >> continue + | otherwise + = continue + +handlePromptEvent + msg + (Prompt c SPointOnMap (PointOnMapPromptState pos) pri cb) + (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) [])) + = let pos' = move dir pos + prompt' = Prompt c SPointOnMap (PointOnMapPromptState pos') pri cb + in promptState .= WaitingPrompt msg prompt' + >> continue +handlePromptEvent _ (Prompt _ SPointOnMap _ _ _) _ = continue + +handlePromptEvent + _ + (Prompt Cancellable _ _ _ _) + (VtyEvent (EvKey (KChar 'q') [])) + = clearPrompt >> continue +handlePromptEvent _ _ _ = continue + +clearPrompt :: AppM () +clearPrompt = promptState .= NoPrompt + +class NotMenu (pt :: PromptType) +instance NotMenu 'StringPrompt +instance NotMenu 'Confirm +instance NotMenu 'DirectionPrompt +instance NotMenu 'PointOnMap +instance NotMenu 'Continue +instance TypeError ('Text "Cannot use `prompt` or `prompt_` for menu prompts" + ':$$: 'Text "Use `menu` or `menu_` instead") + => NotMenu ('Menu a) + +prompt + :: forall (pt :: PromptType) (params :: Type). + (ToJSON params, SingPromptType pt, NotMenu pt) + => [Text] -- ^ Message key + -> params -- ^ Message params + -> PromptCancellable + -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler + -> AppM () +prompt msgPath params cancellable cb = do + let pt = singPromptType @pt + msg <- Messages.message msgPath params + p <- case pt of + SPointOnMap -> do + charPos <- use characterPosition + pure $ mkPointOnMapPrompt cancellable charPos cb + SStringPrompt -> pure $ mkPrompt cancellable pt cb + SConfirm -> pure $ mkPrompt cancellable pt cb + SDirectionPrompt -> pure $ mkPrompt cancellable pt cb + SContinue -> pure $ mkPrompt cancellable pt cb + SMenu -> error "unreachable" + promptState .= WaitingPrompt msg p + +prompt_ + :: forall (pt :: PromptType). + (SingPromptType pt, NotMenu pt) + => [Text] -- ^ Message key + -> PromptCancellable + -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler + -> AppM () +prompt_ msg = prompt msg $ object [] + +confirm + :: ToJSON params + => [Text] -- ^ Message key + -> params + -> AppM () + -> AppM () +confirm msgPath params + = prompt @'Confirm msgPath params Cancellable . const + +confirm_ :: [Text] -> AppM () -> AppM () +confirm_ msgPath = confirm msgPath $ object [] + +menu :: forall (a :: Type) (params :: Type). + (ToJSON params) + => [Text] -- ^ Message key + -> params -- ^ Message params + -> PromptCancellable + -> Map Char (MenuOption a) -- ^ Menu items + -> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler + -> AppM () +menu msgPath params cancellable items' cb = do + msg <- Messages.message msgPath params + let p = mkMenu cancellable items' cb + promptState .= WaitingPrompt msg p + +menu_ :: forall (a :: Type). + [Text] -- ^ Message key + -> PromptCancellable + -> Map Char (MenuOption a) -- ^ Menu items + -> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler + -> AppM () +menu_ msgPath = menu msgPath $ object [] diff --git a/users/glittershark/xanthous/src/Xanthous/App/Time.hs b/users/glittershark/xanthous/src/Xanthous/App/Time.hs new file mode 100644 index 0000000000..b17348f385 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/App/Time.hs @@ -0,0 +1,40 @@ +-------------------------------------------------------------------------------- +module Xanthous.App.Time + ( stepGame + , stepGameBy + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import System.Exit +-------------------------------------------------------------------------------- +import Xanthous.Data (Ticks) +import Xanthous.App.Prompt +import qualified Xanthous.Data.EntityMap as EntityMap +import Xanthous.Entities.Character (isDead) +import Xanthous.Game.State +import Xanthous.Game.Prompt +import Xanthous.Game.Lenses +import Control.Monad.State (modify) +-------------------------------------------------------------------------------- + + +stepGameBy :: Ticks -> AppM () +stepGameBy ticks = do + ents <- uses entities EntityMap.toEIDsAndPositioned + for_ ents $ \(eid, pEntity) -> do + pEntity' <- step ticks pEntity + entities . ix eid .= pEntity' + + modify updateCharacterVision + + whenM (uses character isDead) + . prompt_ @'Continue ["dead"] Uncancellable + . const . lift . liftIO + $ exitSuccess + +ticksPerTurn :: Ticks +ticksPerTurn = 100 + +stepGame :: AppM () +stepGame = stepGameBy ticksPerTurn diff --git a/users/glittershark/xanthous/src/Xanthous/Command.hs b/users/glittershark/xanthous/src/Xanthous/Command.hs new file mode 100644 index 0000000000..37025dd37a --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Command.hs @@ -0,0 +1,73 @@ +-------------------------------------------------------------------------------- +module Xanthous.Command where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (Left, Right, Down) +-------------------------------------------------------------------------------- +import Graphics.Vty.Input (Key(..), Modifier(..)) +import qualified Data.Char as Char +-------------------------------------------------------------------------------- +import Xanthous.Data (Direction(..)) +-------------------------------------------------------------------------------- + +data Command + = Quit + | Move Direction + | StartAutoMove Direction + | PreviousMessage + | PickUp + | Drop + | Open + | Close + | Wait + | Eat + | Look + | Save + | Read + | ShowInventory + | Wield + | GoUp + | GoDown + + -- | TODO replace with `:` commands + | ToggleRevealAll + +commandFromKey :: Key -> [Modifier] -> Maybe Command +commandFromKey (KChar 'q') [] = Just Quit +commandFromKey (KChar '.') [] = Just Wait +commandFromKey (KChar (directionFromChar -> Just dir)) [] = Just $ Move dir +commandFromKey (KChar c) [] + | Char.isUpper c + , Just dir <- directionFromChar $ Char.toLower c + = Just $ StartAutoMove dir +commandFromKey (KChar 'p') [MCtrl] = Just PreviousMessage +commandFromKey (KChar ',') [] = Just PickUp +commandFromKey (KChar 'd') [] = Just Drop +commandFromKey (KChar 'o') [] = Just Open +commandFromKey (KChar 'c') [] = Just Close +commandFromKey (KChar ';') [] = Just Look +commandFromKey (KChar 'e') [] = Just Eat +commandFromKey (KChar 'S') [] = Just Save +commandFromKey (KChar 'r') [] = Just Read +commandFromKey (KChar 'i') [] = Just ShowInventory +commandFromKey (KChar 'w') [] = Just Wield +commandFromKey (KChar '<') [] = Just GoUp +commandFromKey (KChar '>') [] = Just GoDown + +-- DEBUG COMMANDS -- +commandFromKey (KChar 'r') [MMeta] = Just ToggleRevealAll + +commandFromKey _ _ = Nothing + +-------------------------------------------------------------------------------- + +directionFromChar :: Char -> Maybe Direction +directionFromChar 'h' = Just Left +directionFromChar 'j' = Just Down +directionFromChar 'k' = Just Up +directionFromChar 'l' = Just Right +directionFromChar 'y' = Just UpLeft +directionFromChar 'u' = Just UpRight +directionFromChar 'b' = Just DownLeft +directionFromChar 'n' = Just DownRight +directionFromChar '.' = Just Here +directionFromChar _ = Nothing diff --git a/users/glittershark/xanthous/src/Xanthous/Data.hs b/users/glittershark/xanthous/src/Xanthous/Data.hs new file mode 100644 index 0000000000..3cb74bdca9 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Data.hs @@ -0,0 +1,571 @@ +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoTypeSynonymInstances #-} +{-# LANGUAGE DuplicateRecordFields #-} +-------------------------------------------------------------------------------- +-- | Common data types for Xanthous +-------------------------------------------------------------------------------- +module Xanthous.Data + ( Opposite(..) + + -- * + , Position'(..) + , Position + , x + , y + + -- ** + , Positioned(..) + , _Positioned + , position + , positioned + , loc + , _Position + , positionFromPair + , addPositions + , diffPositions + , stepTowards + , isUnit + + -- * Boxes + , Box(..) + , topLeftCorner + , bottomRightCorner + , setBottomRightCorner + , dimensions + , inBox + , boxIntersects + , boxCenter + , boxEdge + , module Linear.V2 + + -- * + , Per(..) + , invertRate + , invertedRate + , (|*|) + , Ticks(..) + , Tiles(..) + , TicksPerTile + , TilesPerTick + , timesTiles + + -- * + , Dimensions'(..) + , Dimensions + , HasWidth(..) + , HasHeight(..) + + -- * + , Direction(..) + , move + , asPosition + , directionOf + , Cardinal(..) + + -- * + , Corner(..) + , Edge(..) + , cornerEdges + + -- * + , Neighbors(..) + , edges + , neighborDirections + , neighborPositions + , arrayNeighbors + , rotations + + -- * + , Hitpoints(..) + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (Left, Down, Right, (.=), elements) +-------------------------------------------------------------------------------- +import Linear.V2 hiding (_x, _y) +import qualified Linear.V2 as L +import Linear.V4 hiding (_x, _y) +import Test.QuickCheck (Arbitrary, CoArbitrary, Function, elements) +import Test.QuickCheck.Arbitrary.Generic +import Data.Group +import Brick (Location(Location), Edges(..)) +import Data.Monoid (Product(..), Sum(..)) +import Data.Array.IArray +import Data.Aeson.Generic.DerivingVia +import Data.Aeson + ( ToJSON(..), FromJSON(..), object, (.=), (.:), withObject) +-------------------------------------------------------------------------------- +import Xanthous.Util (EqEqProp(..), EqProp, between) +import Xanthous.Util.QuickCheck (GenericArbitrary(..)) +import Xanthous.Orphans () +import Xanthous.Util.Graphics +-------------------------------------------------------------------------------- + +-- | opposite ∘ opposite ≡ id +class Opposite x where + opposite :: x -> x + +-------------------------------------------------------------------------------- + +-- fromScalar ∘ scalar ≡ id +class Scalar a where + scalar :: a -> Double + fromScalar :: Double -> a + +instance Scalar Double where + scalar = id + fromScalar = id + +newtype ScalarIntegral a = ScalarIntegral a + deriving newtype (Eq, Ord, Num, Enum, Real, Integral) +instance Integral a => Scalar (ScalarIntegral a) where + scalar = fromIntegral + fromScalar = floor + +deriving via (ScalarIntegral Integer) instance Scalar Integer +deriving via (ScalarIntegral Word) instance Scalar Word + +-------------------------------------------------------------------------------- + +data Position' a where + Position :: { _x :: a + , _y :: a + } -> (Position' a) + deriving stock (Show, Eq, Generic, Ord, Functor, Foldable, Traversable) + deriving anyclass (NFData, Hashable, CoArbitrary, Function) + deriving EqProp via EqEqProp (Position' a) + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + (Position' a) + +x, y :: Lens' (Position' a) a +x = lens (\(Position xx _) -> xx) (\(Position _ yy) xx -> Position xx yy) +y = lens (\(Position _ yy) -> yy) (\(Position xx _) yy -> Position xx yy) + +type Position = Position' Int + +instance Arbitrary a => Arbitrary (Position' a) where + arbitrary = genericArbitrary + shrink (Position px py) = Position <$> shrink px <*> shrink py + + +instance Num a => Semigroup (Position' a) where + (Position x₁ y₁) <> (Position x₂ y₂) = Position (x₁ + x₂) (y₁ + y₂) + +instance Num a => Monoid (Position' a) where + mempty = Position 0 0 + +instance Num a => Group (Position' a) where + invert (Position px py) = Position (negate px) (negate py) + +-- | Positions convert to scalars by discarding their orientation and just +-- measuring the length from the origin +instance (Ord a, Num a, Scalar a) => Scalar (Position' a) where + scalar = fromIntegral . length . line (0, 0) . view _Position + fromScalar n = Position (fromScalar n) (fromScalar n) + +data Positioned a where + Positioned :: Position -> a -> Positioned a + deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + deriving anyclass (NFData, CoArbitrary, Function) +type role Positioned representational + +_Positioned :: Iso (Position, a) (Position, b) (Positioned a) (Positioned b) +_Positioned = iso hither yon + where + hither (pos, a) = Positioned pos a + yon (Positioned pos b) = (pos, b) + +instance Arbitrary a => Arbitrary (Positioned a) where + arbitrary = Positioned <$> arbitrary <*> arbitrary + +instance ToJSON a => ToJSON (Positioned a) where + toJSON (Positioned pos val) = object + [ "position" .= pos + , "data" .= val + ] + +instance FromJSON a => FromJSON (Positioned a) where + parseJSON = withObject "Positioned" $ \obj -> + Positioned <$> obj .: "position" <*> obj .: "data" + +position :: Lens' (Positioned a) Position +position = lens + (\(Positioned pos _) -> pos) + (\(Positioned _ a) pos -> Positioned pos a) + +positioned :: Lens (Positioned a) (Positioned b) a b +positioned = lens + (\(Positioned _ x') -> x') + (\(Positioned pos _) x' -> Positioned pos x') + +loc :: Iso' Position Location +loc = iso hither yon + where + hither (Position px py) = Location (px, py) + yon (Location (lx, ly)) = Position lx ly + +_Position :: Iso' (Position' a) (a, a) +_Position = iso hither yon + where + hither (Position px py) = (px, py) + yon (lx, ly) = Position lx ly + +positionFromPair :: (Num a, Integral i, Integral j) => (i, j) -> Position' a +positionFromPair (i, j) = Position (fromIntegral i) (fromIntegral j) + +-- | Add two positions +-- +-- Operation for the additive group on positions +addPositions :: Num a => Position' a -> Position' a -> Position' a +addPositions = (<>) + +-- | Subtract two positions. +-- +-- diffPositions pos₁ pos₂ = pos₁ `addPositions` (invert pos₂) +diffPositions :: Num a => Position' a -> Position' a -> Position' a +diffPositions (Position x₁ y₁) (Position x₂ y₂) = Position (x₁ - x₂) (y₁ - y₂) + +-- | Is this position a unit position? or: When taken as a difference, does this +-- position represent a step of one tile? +-- +-- ∀ dir :: Direction. isUnit ('asPosition' dir) +isUnit :: (Eq a, Num a) => Position' a -> Bool +isUnit (Position px py) = + abs px `elem` [0,1] && abs py `elem` [0, 1] && (px, py) /= (0, 0) + +-------------------------------------------------------------------------------- + +data Dimensions' a = Dimensions + { _width :: a + , _height :: a + } + deriving stock (Show, Eq, Functor, Generic) + deriving anyclass (CoArbitrary, Function) +makeFieldsNoPrefix ''Dimensions' + +instance Arbitrary a => Arbitrary (Dimensions' a) where + arbitrary = Dimensions <$> arbitrary <*> arbitrary + +type Dimensions = Dimensions' Word + +-------------------------------------------------------------------------------- + +data Direction where + Up :: Direction + Down :: Direction + Left :: Direction + Right :: Direction + UpLeft :: Direction + UpRight :: Direction + DownLeft :: Direction + DownRight :: Direction + Here :: Direction + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (CoArbitrary, Function, NFData, ToJSON, FromJSON, Hashable) + deriving Arbitrary via GenericArbitrary Direction + +instance Opposite Direction where + opposite Up = Down + opposite Down = Up + opposite Left = Right + opposite Right = Left + opposite UpLeft = DownRight + opposite UpRight = DownLeft + opposite DownLeft = UpRight + opposite DownRight = UpLeft + opposite Here = Here + +move :: Num a => Direction -> Position' a -> Position' a +move Up = y -~ 1 +move Down = y +~ 1 +move Left = x -~ 1 +move Right = x +~ 1 +move UpLeft = move Up . move Left +move UpRight = move Up . move Right +move DownLeft = move Down . move Left +move DownRight = move Down . move Right +move Here = id + +asPosition :: Direction -> Position +asPosition dir = move dir mempty + +-- | Returns the direction that a given position is from a given source position +directionOf + :: Position -- ^ Source + -> Position -- ^ Target + -> Direction +directionOf (Position x₁ y₁) (Position x₂ y₂) = + case (x₁ `compare` x₂, y₁ `compare` y₂) of + (EQ, EQ) -> Here + (EQ, LT) -> Down + (EQ, GT) -> Up + (LT, EQ) -> Right + (GT, EQ) -> Left + + (LT, LT) -> DownRight + (GT, LT) -> DownLeft + + (LT, GT) -> UpRight + (GT, GT) -> UpLeft + +-- | Take one (potentially diagonal) step towards the given position +-- +-- ∀ src tgt. isUnit (src `diffPositions` (src `stepTowards tgt`)) +stepTowards + :: Position -- ^ Source + -> Position -- ^ Target + -> Position +stepTowards (view _Position -> p₁) (view _Position -> p₂) + | p₁ == p₂ = _Position # p₁ + | otherwise = + let (_:p:_) = line p₁ p₂ + in _Position # p + +-- | Newtype controlling arbitrary generation to only include cardinal +-- directions ('Up', 'Down', 'Left', 'Right') +newtype Cardinal = Cardinal { getCardinal :: Direction } + deriving stock (Eq, Show, Ord, Generic) + deriving anyclass (NFData, Function, CoArbitrary) + deriving newtype (Opposite) + +instance Arbitrary Cardinal where + arbitrary = Cardinal <$> elements [Up, Down, Left, Right] + +-------------------------------------------------------------------------------- + +data Corner + = TopLeft + | TopRight + | BottomLeft + | BottomRight + deriving stock (Show, Eq, Ord, Enum, Bounded, Generic) + deriving Arbitrary via GenericArbitrary Corner + +instance Opposite Corner where + opposite TopLeft = BottomRight + opposite TopRight = BottomLeft + opposite BottomLeft = TopRight + opposite BottomRight = TopLeft + +data Edge + = TopEdge + | LeftEdge + | RightEdge + | BottomEdge + deriving stock (Show, Eq, Ord, Enum, Bounded, Generic) + deriving Arbitrary via GenericArbitrary Edge + +instance Opposite Edge where + opposite TopEdge = BottomEdge + opposite BottomEdge = TopEdge + opposite LeftEdge = RightEdge + opposite RightEdge = LeftEdge + +cornerEdges :: Corner -> (Edge, Edge) +cornerEdges TopLeft = (TopEdge, LeftEdge) +cornerEdges TopRight = (TopEdge, RightEdge) +cornerEdges BottomLeft = (BottomEdge, LeftEdge) +cornerEdges BottomRight = (BottomEdge, RightEdge) + +-------------------------------------------------------------------------------- + +data Neighbors a = Neighbors + { _topLeft + , _top + , _topRight + , _left + , _right + , _bottomLeft + , _bottom + , _bottomRight :: a + } + deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary (Neighbors a) +makeFieldsNoPrefix ''Neighbors + +instance Applicative Neighbors where + pure α = Neighbors + { _topLeft = α + , _top = α + , _topRight = α + , _left = α + , _right = α + , _bottomLeft = α + , _bottom = α + , _bottomRight = α + } + nf <*> nx = Neighbors + { _topLeft = nf ^. topLeft $ nx ^. topLeft + , _top = nf ^. top $ nx ^. top + , _topRight = nf ^. topRight $ nx ^. topRight + , _left = nf ^. left $ nx ^. left + , _right = nf ^. right $ nx ^. right + , _bottomLeft = nf ^. bottomLeft $ nx ^. bottomLeft + , _bottom = nf ^. bottom $ nx ^. bottom + , _bottomRight = nf ^. bottomRight $ nx ^. bottomRight + } + +edges :: Neighbors a -> Edges a +edges neighs = Edges + { eTop = neighs ^. top + , eBottom = neighs ^. bottom + , eLeft = neighs ^. left + , eRight = neighs ^. right + } + +neighborDirections :: Neighbors Direction +neighborDirections = Neighbors + { _topLeft = UpLeft + , _top = Up + , _topRight = UpRight + , _left = Left + , _right = Right + , _bottomLeft = DownLeft + , _bottom = Down + , _bottomRight = DownRight + } + +neighborPositions :: Num a => Position' a -> Neighbors (Position' a) +neighborPositions pos = (`move` pos) <$> neighborDirections + +arrayNeighbors + :: (IArray a e, Ix i, Num i) + => a (i, i) e + -> (i, i) + -> Neighbors (Maybe e) +arrayNeighbors arr center = arrLookup <$> neighborPositions (_Position # center) + where + arrLookup (view _Position -> pos) + | inRange (bounds arr) pos = Just $ arr ! pos + | otherwise = Nothing + +-- | Returns a list of all 4 90-degree rotations of the given neighbors +rotations :: Neighbors a -> V4 (Neighbors a) +rotations orig@(Neighbors tl t tr l r bl b br) = V4 + orig -- tl t tr + -- l r + -- bl b br + + (Neighbors bl l tl b t br r tr) -- bl l tl + -- b t + -- br r tr + + (Neighbors br b bl r l tr t tl) -- br b bl + -- r l + -- tr t tl + + (Neighbors tr r br t b tl l bl) -- tr r br + -- t b + -- tl l bl + +-------------------------------------------------------------------------------- + +newtype Per a b = Rate Double + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving (Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON) via Double + deriving (Semigroup, Monoid) via Product Double +instance Arbitrary (Per a b) where arbitrary = genericArbitrary + +invertRate :: a `Per` b -> b `Per` a +invertRate (Rate p) = Rate $ 1 / p + +invertedRate :: Iso (a `Per` b) (b' `Per` a') (b `Per` a) (a' `Per` b') +invertedRate = iso invertRate invertRate + +infixl 7 |*| +(|*|) :: (Scalar a, Scalar b) => a `Per` b -> b -> a +(|*|) (Rate rate) b = fromScalar $ rate * scalar b + +newtype Ticks = Ticks Word + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving (Num, Ord, Bounded, Enum, Integral, Real, ToJSON, FromJSON) via Word + deriving (Semigroup, Monoid) via (Sum Word) + deriving Scalar via ScalarIntegral Ticks +instance Arbitrary Ticks where arbitrary = genericArbitrary + +newtype Tiles = Tiles Double + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving (Num, Ord, Enum, Real, ToJSON, FromJSON, Scalar) via Double + deriving (Semigroup, Monoid) via (Sum Double) +instance Arbitrary Tiles where arbitrary = genericArbitrary + +type TicksPerTile = Ticks `Per` Tiles +type TilesPerTick = Tiles `Per` Ticks + +timesTiles :: TicksPerTile -> Tiles -> Ticks +timesTiles = (|*|) + +-------------------------------------------------------------------------------- + +newtype Hitpoints = Hitpoints Word + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving (Arbitrary, Num, Ord, Bounded, Enum, Integral, Real, ToJSON, FromJSON) + via Word + deriving (Semigroup, Monoid) via Sum Word + +-------------------------------------------------------------------------------- + +data Box a = Box + { _topLeftCorner :: V2 a + , _dimensions :: V2 a + } + deriving stock (Show, Eq, Ord, Functor, Generic) + deriving Arbitrary via GenericArbitrary (Box a) +makeFieldsNoPrefix ''Box + +bottomRightCorner :: Num a => Box a -> V2 a +bottomRightCorner box = + V2 (box ^. topLeftCorner . L._x + box ^. dimensions . L._x) + (box ^. topLeftCorner . L._y + box ^. dimensions . L._y) + +setBottomRightCorner :: (Num a, Ord a) => Box a -> V2 a -> Box a +setBottomRightCorner box br@(V2 brx bry) + | brx < box ^. topLeftCorner . L._x || bry < box ^. topLeftCorner . L._y + = box & topLeftCorner .~ br + & dimensions . L._x .~ ((box ^. topLeftCorner . L._x) - brx) + & dimensions . L._y .~ ((box ^. topLeftCorner . L._y) - bry) + | otherwise + = box & dimensions . L._x .~ (brx - (box ^. topLeftCorner . L._x)) + & dimensions . L._y .~ (bry - (box ^. topLeftCorner . L._y)) + +inBox :: (Ord a, Num a) => Box a -> V2 a -> Bool +inBox box pt = flip all [L._x, L._y] $ \component -> + between (box ^. topLeftCorner . component) + (box ^. to bottomRightCorner . component) + (pt ^. component) + +boxIntersects :: (Ord a, Num a) => Box a -> Box a -> Bool +boxIntersects box₁ box₂ + = any (inBox box₁) [box₂ ^. topLeftCorner, bottomRightCorner box₂] + +boxCenter :: (Fractional a) => Box a -> V2 a +boxCenter box = V2 cx cy + where + cx = box ^. topLeftCorner . L._x + (box ^. dimensions . L._x / 2) + cy = box ^. topLeftCorner . L._y + (box ^. dimensions . L._y / 2) + +boxEdge :: (Enum a, Num a) => Box a -> Edge -> [V2 a] +boxEdge box LeftEdge = + V2 (box ^. topLeftCorner . L._x) + <$> [box ^. topLeftCorner . L._y .. box ^. to bottomRightCorner . L._y] +boxEdge box RightEdge = + V2 (box ^. to bottomRightCorner . L._x) + <$> [box ^. to bottomRightCorner . L._y .. box ^. to bottomRightCorner . L._y] +boxEdge box TopEdge = + flip V2 (box ^. topLeftCorner . L._y) + <$> [box ^. topLeftCorner . L._x .. box ^. to bottomRightCorner . L._x] +boxEdge box BottomEdge = + flip V2 (box ^. to bottomRightCorner . L._y) + <$> [box ^. topLeftCorner . L._x .. box ^. to bottomRightCorner . L._x] diff --git a/users/glittershark/xanthous/src/Xanthous/Data/App.hs b/users/glittershark/xanthous/src/Xanthous/Data/App.hs new file mode 100644 index 0000000000..0361d2a59e --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Data/App.hs @@ -0,0 +1,39 @@ +-------------------------------------------------------------------------------- +module Xanthous.Data.App + ( Panel(..) + , ResourceName(..) + , AppEvent(..) + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Test.QuickCheck +import Data.Aeson (ToJSON, FromJSON) +-------------------------------------------------------------------------------- +import Xanthous.Util.QuickCheck +-------------------------------------------------------------------------------- + +-- | Enum for "panels" displayed in the game's UI. +data Panel + = InventoryPanel -- ^ A panel displaying the character's inventory + deriving stock (Show, Eq, Ord, Generic, Enum, Bounded) + deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON) + deriving Arbitrary via GenericArbitrary Panel + + +data ResourceName + = MapViewport -- ^ The main viewport where we display the game content + | Character -- ^ The character + | MessageBox -- ^ The box where we display messages to the user + | Prompt -- ^ The game's prompt + | Panel Panel -- ^ A panel in the game + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON) + deriving Arbitrary via GenericArbitrary ResourceName + +data AppEvent + = AutoContinue -- ^ Continue whatever autocommand has been requested by the + -- user + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON) + deriving Arbitrary via GenericArbitrary AppEvent diff --git a/users/glittershark/xanthous/src/Xanthous/Data/Entities.hs b/users/glittershark/xanthous/src/Xanthous/Data/Entities.hs new file mode 100644 index 0000000000..39953410f2 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Data/Entities.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} +-------------------------------------------------------------------------------- +module Xanthous.Data.Entities + ( -- * Collisions + Collision(..) + , _Stop + , _Combat + -- * Entity Attributes + , EntityAttributes(..) + , blocksVision + , blocksObject + , collision + , defaultEntityAttributes + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Data.Aeson (ToJSON(..), FromJSON(..), (.:?), (.!=), withObject) +import Data.Aeson.Generic.DerivingVia +import Xanthous.Util.QuickCheck (GenericArbitrary(..)) +import Test.QuickCheck +-------------------------------------------------------------------------------- + +data Collision + = Stop -- ^ Can't move through this + | Combat -- ^ Moving into this equates to hitting it with a stick + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary Collision + deriving (ToJSON, FromJSON) + via WithOptions '[ AllNullaryToStringTag 'True ] + Collision +makePrisms ''Collision + +-- | Attributes of an entity +data EntityAttributes = EntityAttributes + { _blocksVision :: Bool + -- | Does this entity block a large object from being put in the same tile as + -- it - eg a a door being closed on it + , _blocksObject :: Bool + -- | What type of collision happens when moving into this entity? + , _collision :: Collision + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary EntityAttributes + deriving (ToJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + EntityAttributes +makeLenses ''EntityAttributes + +instance FromJSON EntityAttributes where + parseJSON = withObject "EntityAttributes" $ \o -> do + _blocksVision <- o .:? "blocksVision" + .!= _blocksVision defaultEntityAttributes + _blocksObject <- o .:? "blocksObject" + .!= _blocksObject defaultEntityAttributes + _collision <- o .:? "collision" + .!= _collision defaultEntityAttributes + pure EntityAttributes {..} + +defaultEntityAttributes :: EntityAttributes +defaultEntityAttributes = EntityAttributes + { _blocksVision = False + , _blocksObject = False + , _collision = Stop + } diff --git a/users/glittershark/xanthous/src/Xanthous/Data/EntityChar.hs b/users/glittershark/xanthous/src/Xanthous/Data/EntityChar.hs new file mode 100644 index 0000000000..855a3462da --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Data/EntityChar.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Data.EntityChar + ( EntityChar(..) + , HasChar(..) + , HasStyle(..) + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding ((.=)) +-------------------------------------------------------------------------------- +import qualified Graphics.Vty.Attributes as Vty +import Test.QuickCheck +import Data.Aeson +-------------------------------------------------------------------------------- +import Xanthous.Orphans () +import Xanthous.Util.QuickCheck (GenericArbitrary(..)) +-------------------------------------------------------------------------------- + + +class HasChar s a | s -> a where + char :: Lens' s a + {-# MINIMAL char #-} + +data EntityChar = EntityChar + { _char :: Char + , _style :: Vty.Attr + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary EntityChar +makeFieldsNoPrefix ''EntityChar + +instance FromJSON EntityChar where + parseJSON (String (chr :< Empty)) = pure $ EntityChar chr Vty.defAttr + parseJSON (Object o) = do + (EntityChar _char _) <- o .: "char" + _style <- o .:? "style" .!= Vty.defAttr + pure EntityChar {..} + parseJSON _ = fail "Invalid type, expected string or object" + +instance ToJSON EntityChar where + toJSON (EntityChar chr styl) + | styl == Vty.defAttr = String $ chr <| Empty + | otherwise = object + [ "char" .= chr + , "style" .= styl + ] + +instance IsString EntityChar where + fromString [ch] = EntityChar ch Vty.defAttr + fromString _ = error "Entity char must only be a single character" diff --git a/users/glittershark/xanthous/src/Xanthous/Data/EntityMap.hs b/users/glittershark/xanthous/src/Xanthous/Data/EntityMap.hs new file mode 100644 index 0000000000..d24defa841 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Data/EntityMap.hs @@ -0,0 +1,272 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveFunctor #-} +-------------------------------------------------------------------------------- +module Xanthous.Data.EntityMap + ( EntityMap + , _EntityMap + , EntityID + , emptyEntityMap + , insertAt + , insertAtReturningID + , fromEIDsAndPositioned + , toEIDsAndPositioned + , atPosition + , atPositionWithIDs + , positions + , lookup + , lookupWithPosition + -- , positionedEntities + , neighbors + , Deduplicate(..) + + -- * debug + , byID + , byPosition + , lastID + + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (lookup) +import Xanthous.Data + ( Position + , Positioned(..) + , positioned + , Neighbors(..) + , neighborPositions + ) +import Xanthous.Data.VectorBag +import Xanthous.Orphans () +import Xanthous.Util (EqEqProp(..)) +-------------------------------------------------------------------------------- +import Data.Monoid (Endo(..)) +import Test.QuickCheck (Arbitrary(..), CoArbitrary, Function) +import Test.QuickCheck.Checkers (EqProp) +import Test.QuickCheck.Instances.UnorderedContainers () +import Test.QuickCheck.Instances.Vector () +import Text.Show (showString, showParen) +import Data.Aeson +-------------------------------------------------------------------------------- + +type EntityID = Word32 +type NonNullSet a = NonNull (Set a) + +data EntityMap a where + EntityMap :: + { _byPosition :: Map Position (NonNullSet EntityID) + , _byID :: HashMap EntityID (Positioned a) + , _lastID :: EntityID + } -> EntityMap a + deriving stock (Functor, Foldable, Traversable, Generic) + deriving anyclass (NFData, CoArbitrary, Function) +deriving via (EqEqProp (EntityMap a)) instance (Eq a, Ord a) => EqProp (EntityMap a) +makeLenses ''EntityMap + +instance ToJSON a => ToJSON (EntityMap a) where + toJSON = toJSON . toEIDsAndPositioned + + +instance FromJSON a => FromJSON (EntityMap a) where + parseJSON = fmap (fromEIDsAndPositioned @[_]) . parseJSON + +byIDInvariantError :: forall a. a +byIDInvariantError = error $ "Invariant violation: All EntityIDs in byPosition " + <> "must point to entityIDs in byID" + +instance (Ord a, Eq a) => Eq (EntityMap a) where + -- em₁ == em₂ = em₁ ^. _EntityMap == em₂ ^. _EntityMap + (==) = (==) `on` view (_EntityMap . to sort) + +deriving stock instance (Ord a) => Ord (EntityMap a) + +instance Show a => Show (EntityMap a) where + showsPrec pr em + = showParen (pr > 10) + $ showString + . ("fromEIDsAndPositioned " <>) + . show + . toEIDsAndPositioned + $ em + +instance Arbitrary a => Arbitrary (EntityMap a) where + arbitrary = review _EntityMap <$> arbitrary + shrink em = review _EntityMap <$> shrink (em ^. _EntityMap) + +type instance Index (EntityMap a) = EntityID +type instance IxValue (EntityMap a) = (Positioned a) +instance Ixed (EntityMap a) where ix eid = at eid . traverse + +instance At (EntityMap a) where + at eid = lens (view $ byID . at eid) setter + where + setter :: EntityMap a -> Maybe (Positioned a) -> EntityMap a + setter m Nothing = fromMaybe m $ do + Positioned pos _ <- m ^. byID . at eid + pure $ m + & removeEIDAtPos pos + & byID . at eid .~ Nothing + setter m (Just pe@(Positioned pos _)) = m + & (case lookupWithPosition eid m of + Nothing -> id + Just (Positioned origPos _) -> removeEIDAtPos origPos + ) + & byID . at eid ?~ pe + & byPosition . at pos %~ \case + Nothing -> Just $ opoint eid + Just es -> Just $ ninsertSet eid es + removeEIDAtPos pos = + byPosition . at pos %~ (>>= fromNullable . ndeleteSet eid) + +instance Semigroup (EntityMap a) where + em₁ <> em₂ = alaf Endo foldMap (uncurry insertAt) (em₂ ^. _EntityMap) em₁ + +instance Monoid (EntityMap a) where + mempty = emptyEntityMap + +instance FunctorWithIndex EntityID EntityMap + +instance FoldableWithIndex EntityID EntityMap + +instance TraversableWithIndex EntityID EntityMap where + itraversed = byID . itraversed . rmap sequenceA . distrib + itraverse = itraverseOf itraversed + +type instance Element (EntityMap a) = a +instance MonoFoldable (EntityMap a) + +emptyEntityMap :: EntityMap a +emptyEntityMap = EntityMap mempty mempty 0 + +newtype Deduplicate a = Deduplicate (EntityMap a) + deriving stock (Show, Traversable, Generic) + deriving newtype (Eq, Functor, Foldable, EqProp, Arbitrary) + +instance Semigroup (Deduplicate a) where + (Deduplicate em₁) <> (Deduplicate em₂) = + let _byID = em₁ ^. byID <> em₂ ^. byID + _byPosition = mempty &~ do + ifor_ _byID $ \eid (Positioned pos _) -> + at pos %= \case + Just eids -> Just $ ninsertSet eid eids + Nothing -> Just $ opoint eid + _lastID = fromMaybe 1 $ maximumOf (ifolded . asIndex) _byID + in Deduplicate EntityMap{..} + + +-------------------------------------------------------------------------------- + +_EntityMap :: Iso' (EntityMap a) [(Position, a)] +_EntityMap = iso hither yon + where + hither :: EntityMap a -> [(Position, a)] + hither em = do + (pos, eids) <- em ^. byPosition . _Wrapped + eid <- toList eids + ent <- em ^.. byID . at eid . folded . positioned + pure (pos, ent) + yon :: [(Position, a)] -> EntityMap a + yon poses = alaf Endo foldMap (uncurry insertAt) poses emptyEntityMap + + +insertAtReturningID :: forall a. Position -> a -> EntityMap a -> (EntityID, EntityMap a) +insertAtReturningID pos e em = + let (eid, em') = em & lastID <+~ 1 + in em' + & byID . at eid ?~ Positioned pos e + & byPosition . at pos %~ \case + Nothing -> Just $ opoint eid + Just es -> Just $ ninsertSet eid es + & (eid, ) + +insertAt :: forall a. Position -> a -> EntityMap a -> EntityMap a +insertAt pos e = snd . insertAtReturningID pos e + +atPosition :: forall a. (Ord a, Show a) => Position -> Lens' (EntityMap a) (VectorBag a) +atPosition pos = lens getter setter + where + getter em = + let eids :: VectorBag EntityID + eids = maybe mempty (VectorBag . toVector . toNullable) + $ em ^. byPosition . at pos + in getEIDAssume em <$> eids + setter em Empty = em & byPosition . at pos .~ Nothing + setter em (sort -> entities) = + let origEIDs = maybe Empty toNullable $ em ^. byPosition . at pos + origEntitiesWithIDs = + sortOn snd $ toList origEIDs <&> \eid -> (eid, getEIDAssume em eid) + go alles₁@((eid, e₁) :< es₁) -- orig + (e₂ :< es₂) -- new + | e₁ == e₂ + -- same, do nothing + = let (eids, lastEID, byID') = go es₁ es₂ + in (insertSet eid eids, lastEID, byID') + | otherwise + -- e₂ is new, generate a new ID for it + = let (eids, lastEID, byID') = go alles₁ es₂ + eid' = succ lastEID + in (insertSet eid' eids, eid', byID' & at eid' ?~ Positioned pos e₂) + go Empty Empty = (mempty, em ^. lastID, em ^. byID) + go orig Empty = + let byID' = foldr deleteMap (em ^. byID) $ map fst orig + in (mempty, em ^. lastID, byID') + go Empty (new :< news) = + let (eids, lastEID, byID') = go Empty news + eid' = succ lastEID + in (insertSet eid' eids, eid', byID' & at eid' ?~ Positioned pos new) + go _ _ = error "unreachable" + (eidsAtPosition, newLastID, newByID) = go origEntitiesWithIDs entities + in em & byPosition . at pos .~ fromNullable eidsAtPosition + & byID .~ newByID + & lastID .~ newLastID + +getEIDAssume :: EntityMap a -> EntityID -> a +getEIDAssume em eid = fromMaybe byIDInvariantError + $ em ^? byID . ix eid . positioned + +atPositionWithIDs :: Position -> EntityMap a -> Vector (EntityID, Positioned a) +atPositionWithIDs pos em = + let eids = maybe mempty (toVector . toNullable) + $ em ^. byPosition . at pos + in (id &&& Positioned pos . getEIDAssume em) <$> eids + +fromEIDsAndPositioned + :: forall mono a. (MonoFoldable mono, Element mono ~ (EntityID, Positioned a)) + => mono + -> EntityMap a +fromEIDsAndPositioned eps = newLastID $ alaf Endo foldMap insert' eps mempty + where + insert' (eid, pe@(Positioned pos _)) + = (byID . at eid ?~ pe) + . (byPosition . at pos %~ \case + Just eids -> Just $ ninsertSet eid eids + Nothing -> Just $ opoint eid + ) + newLastID em = em & lastID + .~ fromMaybe 1 + (maximumOf (ifolded . asIndex) (em ^. byID)) + +toEIDsAndPositioned :: EntityMap a -> [(EntityID, Positioned a)] +toEIDsAndPositioned = itoListOf $ byID . ifolded + +positions :: EntityMap a -> [Position] +positions = toListOf $ byPosition . to keys . folded + +lookupWithPosition :: EntityID -> EntityMap a -> Maybe (Positioned a) +lookupWithPosition eid = view $ byID . at eid + +lookup :: EntityID -> EntityMap a -> Maybe a +lookup eid = fmap (view positioned) . lookupWithPosition eid + +-- unlawful :( +-- positionedEntities :: IndexedTraversal EntityID (EntityMap a) (EntityMap b) (Positioned a) (Positioned b) +-- positionedEntities = byID . itraversed + +neighbors :: (Ord a, Show a) => Position -> EntityMap a -> Neighbors (VectorBag a) +neighbors pos em = (\p -> view (atPosition p) em) <$> neighborPositions pos + +-------------------------------------------------------------------------------- +makeWrapped ''Deduplicate diff --git a/users/glittershark/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs b/users/glittershark/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs new file mode 100644 index 0000000000..5a73bd3938 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs @@ -0,0 +1,64 @@ +-------------------------------------------------------------------------------- +module Xanthous.Data.EntityMap.Graphics + ( visiblePositions + , visibleEntities + , linesOfSight + , canSee + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (lines) +-------------------------------------------------------------------------------- +import Xanthous.Util (takeWhileInclusive) +import Xanthous.Data +import Xanthous.Data.Entities +import Xanthous.Data.EntityMap +import Xanthous.Game.State +import Xanthous.Util.Graphics (circle, line) +-------------------------------------------------------------------------------- + +-- | Returns a set of positions that are visible, when taking into account +-- 'blocksVision', from the given position, within the given radius. +visiblePositions + :: Entity e + => Position + -> Word -- ^ Vision radius + -> EntityMap e + -> Set Position +visiblePositions pos radius + = setFromList . positions . visibleEntities pos radius + +-- | Returns a list of individual lines of sight, each of which is a list of +-- entities at positions on that line of sight +linesOfSight + :: forall e. Entity e + => Position + -> Word + -> EntityMap e + -> [[(Position, Vector (EntityID, e))]] +linesOfSight (view _Position -> pos) visionRadius em + = entitiesOnLines + <&> takeWhileInclusive + (none (view blocksVision . entityAttributes . snd) . snd) + where + radius = circle pos $ fromIntegral visionRadius + lines = line pos <$> radius + entitiesOnLines :: [[(Position, Vector (EntityID, e))]] + entitiesOnLines = lines <&> map getPositionedAt + getPositionedAt :: (Int, Int) -> (Position, Vector (EntityID, e)) + getPositionedAt p = + let ppos = _Position # p + in (ppos, over _2 (view positioned) <$> atPositionWithIDs ppos em) + +-- | Given a point and a radius of vision, returns a list of all entities that +-- are *visible* (eg, not blocked by an entity that obscures vision) from that +-- point +visibleEntities :: Entity e => Position -> Word -> EntityMap e -> EntityMap e +visibleEntities pos visionRadius + = fromEIDsAndPositioned + . foldMap (\(p, es) -> over _2 (Positioned p) <$> es) + . fold + . linesOfSight pos visionRadius + +canSee :: Entity e => (e -> Bool) -> Position -> Word -> EntityMap e -> Bool +canSee match pos radius = any match . visibleEntities pos radius +-- ^ this might be optimizable diff --git a/users/glittershark/xanthous/src/Xanthous/Data/Levels.hs b/users/glittershark/xanthous/src/Xanthous/Data/Levels.hs new file mode 100644 index 0000000000..efc0f53ace --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Data/Levels.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Data.Levels + ( Levels + , allLevels + , nextLevel + , prevLevel + , mkLevels1 + , mkLevels + , oneLevel + , current + , ComonadStore(..) + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding ((<.>), Empty, foldMap) +import Xanthous.Util (between, EqProp, EqEqProp(..)) +import Xanthous.Util.Comonad (current) +import Xanthous.Orphans () +-------------------------------------------------------------------------------- +import Control.Comonad.Store +import Control.Comonad.Store.Zipper +import Data.Aeson (ToJSON(..), FromJSON(..)) +import Data.Aeson.Generic.DerivingVia +import Data.Functor.Apply +import Data.Foldable (foldMap) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE +import Data.Maybe (fromJust) +import Data.Sequence (Seq((:<|), Empty)) +import Data.Semigroup.Foldable.Class +import Data.Text (replace) +import Test.QuickCheck +-------------------------------------------------------------------------------- + +-- | Collection of levels plus a pointer to the current level +-- +-- Navigation is via the 'Comonad' instance. We can get the current level with +-- 'extract': +-- +-- extract @Levels :: Levels level -> level +-- +-- For access to and modification of the level, use +-- 'Xanthous.Util.Comonad.current' +newtype Levels a = Levels { levelZipper :: Zipper Seq a } + deriving stock (Generic) + deriving (Functor, Comonad, Foldable) via (Zipper Seq) + deriving (ComonadStore Int) via (Zipper Seq) + +type instance Element (Levels a) = a +instance MonoFoldable (Levels a) +instance MonoFunctor (Levels a) +instance MonoTraversable (Levels a) + +instance Traversable Levels where + traverse f (Levels z) = Levels <$> traverse f z + +instance Foldable1 Levels + +instance Traversable1 Levels where + traverse1 f (Levels z) = seek (pos z) . partialMkLevels <$> go (unzipper z) + where + go Empty = error "empty seq, unreachable" + go (x :<| xs) = (<|) <$> f x <.> go xs + +-- | Always takes the position of the latter element +instance Semigroup (Levels a) where + levs₁ <> levs₂ + = seek (pos levs₂) + . partialMkLevels + $ allLevels levs₁ <> allLevels levs₂ + +-- | Make Levels from a Seq. Throws an error if the seq is not empty +partialMkLevels :: Seq a -> Levels a +partialMkLevels = Levels . fromJust . zipper + +-- | Make Levels from a possibly-empty structure +mkLevels :: Foldable1 f => f level -> Maybe (Levels level) +mkLevels = fmap Levels . zipper . foldMap pure + +-- | Make Levels from a non-empty structure +mkLevels1 :: Foldable1 f => f level -> Levels level +mkLevels1 = fromJust . mkLevels + +oneLevel :: a -> Levels a +oneLevel = mkLevels1 . Identity + +-- | Get a sequence of all the levels +allLevels :: Levels a -> Seq a +allLevels = unzipper . levelZipper + +-- | Step to the next level, generating a new level if necessary using the given +-- applicative action +nextLevel + :: Applicative m + => m level -- ^ Generate a new level, if necessary + -> Levels level + -> m (Levels level) +nextLevel genLevel levs + | pos levs + 1 < size (levelZipper levs) + = pure $ seeks succ levs + | otherwise + = genLevel <&> \level -> + seek (pos levs + 1) . partialMkLevels $ allLevels levs |> level + +-- | Go to the previous level. Returns Nothing if 'pos' is 0 +prevLevel :: Levels level -> Maybe (Levels level) +prevLevel levs | pos levs == 0 = Nothing + | otherwise = Just $ seeks pred levs + +-------------------------------------------------------------------------------- + +-- | alternate, slower representation of Levels we can Iso into to perform +-- various operations +data AltLevels a = AltLevels + { _levels :: NonEmpty a + , _currentLevel :: Int -- ^ invariant: is within the bounds of _levels + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + (AltLevels a) +makeLenses ''AltLevels + +alt :: Iso (Levels a) (Levels b) (AltLevels a) (AltLevels b) +alt = iso hither yon + where + hither levs = AltLevels (NE.fromList . toList $ allLevels levs) (pos levs) + yon (AltLevels levs curr) = seek curr $ mkLevels1 levs + +instance Eq a => Eq (Levels a) where + (==) = (==) `on` view alt + +deriving via EqEqProp (Levels a) instance Eq a => EqProp (Levels a) + +instance Show a => Show (Levels a) where + show = unpack . replace "AltLevels" "Levels" . pack . show . view alt + +instance NFData a => NFData (Levels a) where + rnf = rnf . view alt + +instance ToJSON a => ToJSON (Levels a) where + toJSON = toJSON . view alt + +instance FromJSON a => FromJSON (Levels a) where + parseJSON = fmap (review alt) . parseJSON + +instance Arbitrary a => Arbitrary (AltLevels a) where + arbitrary = do + _levels <- arbitrary + _currentLevel <- choose (0, length _levels - 1) + pure AltLevels {..} + shrink als = do + _levels <- shrink $ als ^. levels + _currentLevel <- filter (between 0 $ length _levels - 1) + $ shrink $ als ^. currentLevel + pure AltLevels {..} + + +instance Arbitrary a => Arbitrary (Levels a) where + arbitrary = review alt <$> arbitrary + shrink = fmap (review alt) . shrink . view alt + +instance CoArbitrary a => CoArbitrary (Levels a) where + coarbitrary = coarbitrary . view alt + +instance Function a => Function (Levels a) where + function = functionMap (view alt) (review alt) diff --git a/users/glittershark/xanthous/src/Xanthous/Data/NestedMap.hs b/users/glittershark/xanthous/src/Xanthous/Data/NestedMap.hs new file mode 100644 index 0000000000..1b875d4483 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Data/NestedMap.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE PolyKinds #-} +-------------------------------------------------------------------------------- +module Xanthous.Data.NestedMap + ( NestedMapVal(..) + , NestedMap(..) + , lookup + , lookupVal + , insert + + -- * + , (:->) + , BifunctorFunctor'(..) + , BifunctorMonad'(..) + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (lookup, foldMap) +import qualified Xanthous.Prelude as P +-------------------------------------------------------------------------------- +import Test.QuickCheck +import Data.Aeson +import Data.Function (fix) +import Data.Foldable (Foldable(..)) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE +-------------------------------------------------------------------------------- + +-- | Natural transformations on bifunctors +type (:->) p q = forall a b. p a b -> q a b +infixr 0 :-> + +class (forall b. Bifunctor b => Bifunctor (t b)) => BifunctorFunctor' t where + bifmap' :: (Bifunctor p, Bifunctor q) => (p :-> q) -> t p :-> t q + +class BifunctorFunctor' t => BifunctorMonad' t where + bireturn' :: (Bifunctor p) => p :-> t p + + bibind' :: (Bifunctor p, Bifunctor q) => (p :-> t q) -> t p :-> t q + bibind' f = bijoin' . bifmap' f + + bijoin' :: (Bifunctor p) => t (t p) :-> t p + bijoin' = bibind' id + + {-# MINIMAL bireturn', (bibind' | bijoin') #-} + +-------------------------------------------------------------------------------- + +data NestedMapVal m k v = Val v | Nested (NestedMap m k v) + +deriving stock instance + ( forall k' v'. (Show k', Show v') => Show (m k' v') + , Show k + , Show v + ) => Show (NestedMapVal m k v) + +deriving stock instance + ( forall k' v'. (Eq k', Eq v') => Eq (m k' v') + , Eq k + , Eq v + ) => Eq (NestedMapVal m k v) + +instance + forall m k v. + ( Arbitrary (m k v) + , Arbitrary (m k (NestedMapVal m k v)) + , Arbitrary k + , Arbitrary v + , IsMap (m k (NestedMapVal m k v)) + , MapValue (m k (NestedMapVal m k v)) ~ (NestedMapVal m k v) + , ContainerKey (m k (NestedMapVal m k v)) ~ k + ) => Arbitrary (NestedMapVal m k v) where + arbitrary = sized . fix $ \gen n -> + let nst = fmap (NestedMap . mapFromList) + . listOf + $ (,) <$> arbitrary @k <*> gen (n `div` 2) + in if n == 0 + then Val <$> arbitrary + else oneof [ Val <$> arbitrary + , Nested <$> nst] + shrink (Val v) = Val <$> shrink v + shrink (Nested mkv) = Nested <$> shrink mkv + +instance Functor (m k) => Functor (NestedMapVal m k) where + fmap f (Val v) = Val $ f v + fmap f (Nested m) = Nested $ fmap f m + +instance Bifunctor m => Bifunctor (NestedMapVal m) where + bimap _ g (Val v) = Val $ g v + bimap f g (Nested m) = Nested $ bimap f g m + +instance BifunctorFunctor' NestedMapVal where + bifmap' _ (Val v) = Val v + bifmap' f (Nested m) = Nested $ bifmap' f m + +instance (ToJSONKey k, ToJSON v, ToJSON (m k (NestedMapVal m k v))) + => ToJSON (NestedMapVal m k v) where + toJSON (Val v) = toJSON v + toJSON (Nested m) = toJSON m + +instance Foldable (m k) => Foldable (NestedMapVal m k) where + foldMap f (Val v) = f v + foldMap f (Nested m) = foldMap f m + +-- _NestedMapVal +-- :: forall m k v m' k' v'. +-- ( IsMap (m k v), IsMap (m' k' v') +-- , IsMap (m [k] v), IsMap (m' [k'] v') +-- , ContainerKey (m k v) ~ k, ContainerKey (m' k' v') ~ k' +-- , ContainerKey (m [k] v) ~ [k], ContainerKey (m' [k'] v') ~ [k'] +-- , MapValue (m k v) ~ v, MapValue (m' k' v') ~ v' +-- , MapValue (m [k] v) ~ v, MapValue (m' [k'] v') ~ v' +-- ) +-- => Iso (NestedMapVal m k v) +-- (NestedMapVal m' k' v') +-- (m [k] v) +-- (m' [k'] v') +-- _NestedMapVal = iso hither yon +-- where +-- hither :: NestedMapVal m k v -> m [k] v +-- hither (Val v) = singletonMap [] v +-- hither (Nested m) = bimap _ _ $ m ^. _NestedMap +-- yon = _ + +-------------------------------------------------------------------------------- + +newtype NestedMap m k v = NestedMap (m k (NestedMapVal m k v)) + +deriving stock instance + ( forall k' v'. (Eq k', Eq v') => Eq (m k' v') + , Eq k + , Eq v + ) => Eq (NestedMap m k v) + +deriving stock instance + ( forall k' v'. (Show k', Show v') => Show (m k' v') + , Show k + , Show v + ) => Show (NestedMap m k v) + +instance Arbitrary (m k (NestedMapVal m k v)) + => Arbitrary (NestedMap m k v) where + arbitrary = NestedMap <$> arbitrary + shrink (NestedMap m) = NestedMap <$> shrink m + +instance Functor (m k) => Functor (NestedMap m k) where + fmap f (NestedMap m) = NestedMap $ fmap (fmap f) m + +instance Bifunctor m => Bifunctor (NestedMap m) where + bimap f g (NestedMap m) = NestedMap $ bimap f (bimap f g) m + +instance BifunctorFunctor' NestedMap where + bifmap' f (NestedMap m) = NestedMap . f $ bimap id (bifmap' f) m + +instance (ToJSONKey k, ToJSON v, ToJSON (m k (NestedMapVal m k v))) + => ToJSON (NestedMap m k v) where + toJSON (NestedMap m) = toJSON m + +instance Foldable (m k) => Foldable (NestedMap m k) where + foldMap f (NestedMap m) = foldMap (foldMap f) m + +-------------------------------------------------------------------------------- + +lookup + :: ( IsMap (m k (NestedMapVal m k v)) + , MapValue (m k (NestedMapVal m k v)) ~ (NestedMapVal m k v) + , ContainerKey (m k (NestedMapVal m k v)) ~ k + ) + => NonEmpty k + -> NestedMap m k v + -> Maybe (NestedMapVal m k v) +lookup (p :| []) (NestedMap vs) = P.lookup p vs +lookup (p :| (p₁ : ps)) (NestedMap vs) = P.lookup p vs >>= \case + (Val _) -> Nothing + (Nested vs') -> lookup (p₁ :| ps) vs' + +lookupVal + :: ( IsMap (m k (NestedMapVal m k v)) + , MapValue (m k (NestedMapVal m k v)) ~ (NestedMapVal m k v) + , ContainerKey (m k (NestedMapVal m k v)) ~ k + ) + => NonEmpty k + -> NestedMap m k v + -> Maybe v +lookupVal ks m + | Just (Val v) <- lookup ks m = Just v + | otherwise = Nothing + +insert + :: ( IsMap (m k (NestedMapVal m k v)) + , MapValue (m k (NestedMapVal m k v)) ~ (NestedMapVal m k v) + , ContainerKey (m k (NestedMapVal m k v)) ~ k + ) + => NonEmpty k + -> v + -> NestedMap m k v + -> NestedMap m k v +insert (k :| []) v (NestedMap m) = NestedMap $ P.insertMap k (Val v) m +insert (k₁ :| (k₂ : ks)) v (NestedMap m) = NestedMap $ alterMap upd k₁ m + where + upd (Just (Nested nm)) = Just . Nested $ insert (k₂ :| ks) v nm + upd _ = Just $ + let (kΩ :| ks') = NE.reverse (k₂ :| ks) + in P.foldl' + (\m' k -> Nested . NestedMap . singletonMap k $ m') + (Nested . NestedMap . singletonMap kΩ $ Val v) + ks' + +-- _NestedMap +-- :: ( IsMap (m k v), IsMap (m' k' v') +-- , IsMap (m (NonEmpty k) v), IsMap (m' (NonEmpty k') v') +-- , ContainerKey (m k v) ~ k, ContainerKey (m' k' v') ~ k' +-- , ContainerKey (m (NonEmpty k) v) ~ (NonEmpty k) +-- , ContainerKey (m' (NonEmpty k') v') ~ (NonEmpty k') +-- , MapValue (m k v) ~ v, MapValue (m' k' v') ~ v' +-- , MapValue (m (NonEmpty k) v) ~ v, MapValue (m' (NonEmpty k') v') ~ v' +-- ) +-- => Iso (NestedMap m k v) +-- (NestedMap m' k' v') +-- (m (NonEmpty k) v) +-- (m' (NonEmpty k') v') +-- _NestedMap = iso undefined yon +-- where +-- hither (NestedMap m) = undefined . mapToList $ m +-- yon mkv = undefined diff --git a/users/glittershark/xanthous/src/Xanthous/Data/VectorBag.hs b/users/glittershark/xanthous/src/Xanthous/Data/VectorBag.hs new file mode 100644 index 0000000000..bd9af369e0 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Data/VectorBag.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Data.VectorBag + (VectorBag(..) + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +import Data.Aeson +import qualified Data.Vector as V +import Test.QuickCheck +import Test.QuickCheck.Instances.Vector () +-------------------------------------------------------------------------------- + +-- | Acts exactly like a Vector, except ignores order when testing for equality +newtype VectorBag a = VectorBag (Vector a) + deriving stock + ( Traversable + , Generic + ) + deriving newtype + ( Show + , Read + , Foldable + , FromJSON + , FromJSON1 + , ToJSON + , Reversing + , Applicative + , Functor + , Monad + , Monoid + , Semigroup + , Arbitrary + , CoArbitrary + ) +makeWrapped ''VectorBag + +instance Function a => Function (VectorBag a) where + function = functionMap (\(VectorBag v) -> v) VectorBag + +type instance Element (VectorBag a) = a +deriving via (Vector a) instance MonoFoldable (VectorBag a) +deriving via (Vector a) instance GrowingAppend (VectorBag a) +deriving via (Vector a) instance SemiSequence (VectorBag a) +deriving via (Vector a) instance MonoPointed (VectorBag a) +deriving via (Vector a) instance MonoFunctor (VectorBag a) + +instance Cons (VectorBag a) (VectorBag b) a b where + _Cons = prism (\(x, VectorBag xs) -> VectorBag $ x <| xs) $ \(VectorBag v) -> + if V.null v + then Left (VectorBag mempty) + else Right (V.unsafeHead v, VectorBag $ V.unsafeTail v) + +instance AsEmpty (VectorBag a) where + _Empty = prism' (const $ VectorBag Empty) $ \case + (VectorBag Empty) -> Just () + _ -> Nothing + +{- + TODO: + , Ixed + , FoldableWithIndex + , FunctorWithIndex + , TraversableWithIndex + , Snoc + , Each +-} + +instance Ord a => Eq (VectorBag a) where + (==) = (==) `on` (view _Wrapped . sort) + +instance Ord a => Ord (VectorBag a) where + compare = compare `on` (view _Wrapped . sort) + +instance MonoTraversable (VectorBag a) where + otraverse f (VectorBag v) = VectorBag <$> otraverse f v + +instance IsSequence (VectorBag a) where + fromList = VectorBag . fromList + break prd (VectorBag v) = bimap VectorBag VectorBag $ break prd v + span prd (VectorBag v) = bimap VectorBag VectorBag $ span prd v + dropWhile prd (VectorBag v) = VectorBag $ dropWhile prd v + takeWhile prd (VectorBag v) = VectorBag $ takeWhile prd v + splitAt idx (VectorBag v) = bimap VectorBag VectorBag $ splitAt idx v + unsafeSplitAt idx (VectorBag v) = + bimap VectorBag VectorBag $ unsafeSplitAt idx v + take n (VectorBag v) = VectorBag $ take n v + unsafeTake n (VectorBag v) = VectorBag $ unsafeTake n v + drop n (VectorBag v) = VectorBag $ drop n v + unsafeDrop n (VectorBag v) = VectorBag $ unsafeDrop n v + partition p (VectorBag v) = bimap VectorBag VectorBag $ partition p v diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Character.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Character.hs new file mode 100644 index 0000000000..c18d726a4b --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Entities/Character.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE TemplateHaskell #-} +module Xanthous.Entities.Character + ( Character(..) + , characterName + , inventory + , characterDamage + , characterHitpoints' + , characterHitpoints + , hitpointRecoveryRate + , speed + + -- * Inventory + , Inventory(..) + , backpack + , wielded + , items + -- ** Wielded items + , Wielded(..) + , hands + , leftHand + , rightHand + , inLeftHand + , inRightHand + , doubleHanded + , wieldedItems + , WieldedItem(..) + , wieldedItem + , wieldableItem + , asWieldedItem + + -- * + , mkCharacter + , pickUpItem + , isDead + , damage + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Brick +import Data.Aeson.Generic.DerivingVia +import Data.Aeson (ToJSON, FromJSON) +import Data.Coerce (coerce) +import Test.QuickCheck +import Test.QuickCheck.Instances.Vector () +import Test.QuickCheck.Arbitrary.Generic +-------------------------------------------------------------------------------- +import Xanthous.Util.QuickCheck +import Xanthous.Game.State +import Xanthous.Entities.Item +import Xanthous.Data + ( TicksPerTile, Hitpoints, Per, Ticks, (|*|), positioned + , Positioned(..) + ) +import Xanthous.Entities.RawTypes (WieldableItem, wieldable) +import qualified Xanthous.Entities.RawTypes as Raw +-------------------------------------------------------------------------------- + +data WieldedItem = WieldedItem + { _wieldedItem :: Item + , _wieldableItem :: WieldableItem + -- ^ Invariant: item ^. itemType . wieldable ≡ Just wieldableItem + } + deriving stock (Eq, Show, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + WieldedItem +makeFieldsNoPrefix ''WieldedItem + +asWieldedItem :: Prism' Item WieldedItem +asWieldedItem = prism' hither yon + where + yon item = WieldedItem item <$> item ^. itemType . wieldable + hither (WieldedItem item _) = item + +instance Brain WieldedItem where + step ticks (Positioned p wi) = + over positioned (\i -> WieldedItem i $ wi ^. wieldableItem) + <$> step ticks (Positioned p $ wi ^. wieldedItem) + +instance Draw WieldedItem where + draw = draw . view wieldedItem + +instance Entity WieldedItem where + entityAttributes = entityAttributes . view wieldedItem + description = description . view wieldedItem + entityChar = entityChar . view wieldedItem + +instance Arbitrary WieldedItem where + arbitrary = genericArbitrary <&> \wi -> + wi & wieldedItem . itemType . wieldable ?~ wi ^. wieldableItem + +data Wielded + = DoubleHanded WieldedItem + | Hands { _leftHand :: !(Maybe WieldedItem) + , _rightHand :: !(Maybe WieldedItem) + } + deriving stock (Eq, Show, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary Wielded + deriving (ToJSON, FromJSON) + via WithOptions '[ 'SumEnc 'ObjWithSingleField ] + Wielded + +hands :: Prism' Wielded (Maybe WieldedItem, Maybe WieldedItem) +hands = prism' (uncurry Hands) $ \case + Hands l r -> Just (l, r) + _ -> Nothing + +leftHand :: Traversal' Wielded WieldedItem +leftHand = hands . _1 . _Just + +inLeftHand :: WieldedItem -> Wielded +inLeftHand wi = Hands (Just wi) Nothing + +rightHand :: Traversal' Wielded WieldedItem +rightHand = hands . _2 . _Just + +inRightHand :: WieldedItem -> Wielded +inRightHand wi = Hands Nothing (Just wi) + +doubleHanded :: Prism' Wielded WieldedItem +doubleHanded = prism' DoubleHanded $ \case + DoubleHanded i -> Just i + _ -> Nothing + +wieldedItems :: Traversal' Wielded WieldedItem +wieldedItems k (DoubleHanded wielded) = DoubleHanded <$> k wielded +wieldedItems k (Hands l r) = Hands <$> _Just k l <*> _Just k r + +data Inventory = Inventory + { _backpack :: Vector Item + , _wielded :: Wielded + } + deriving stock (Eq, Show, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary Inventory + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + Inventory +makeFieldsNoPrefix ''Inventory + +items :: Traversal' Inventory Item +items k (Inventory bp w) = Inventory + <$> traversed k bp + <*> (wieldedItems . wieldedItem) k w + +type instance Element Inventory = Item + +instance MonoFunctor Inventory where + omap = over items + +instance MonoFoldable Inventory where + ofoldMap = foldMapOf items + ofoldr = foldrOf items + ofoldl' = foldlOf' items + otoList = toListOf items + oall = allOf items + oany = anyOf items + onull = nullOf items + ofoldr1Ex = foldr1Of items + ofoldl1Ex' = foldl1Of' items + headEx = headEx . toListOf items + lastEx = lastEx . toListOf items + +instance MonoTraversable Inventory where + otraverse = traverseOf items + +instance Semigroup Inventory where + inv₁ <> inv₂ = + let backpack' = inv₁ ^. backpack <> inv₂ ^. backpack + (wielded', backpack'') = case (inv₁ ^. wielded, inv₂ ^. wielded) of + (wielded₁, wielded₂@(DoubleHanded _)) -> + (wielded₂, backpack' <> fromList (wielded₁ ^.. wieldedItems . wieldedItem)) + (wielded₁, wielded₂@(Hands (Just _) (Just _))) -> + (wielded₂, backpack' <> fromList (wielded₁ ^.. wieldedItems . wieldedItem)) + (wielded₁, Hands Nothing Nothing) -> (wielded₁, backpack') + (Hands Nothing Nothing, wielded₂) -> (wielded₂, backpack') + (Hands (Just l₁) Nothing, Hands Nothing (Just r₂)) -> + (Hands (Just l₁) (Just r₂), backpack') + (wielded₁@(DoubleHanded _), wielded₂) -> + (wielded₁, backpack' <> fromList (wielded₂ ^.. wieldedItems . wieldedItem)) + (Hands Nothing (Just r₁), Hands Nothing (Just r₂)) -> + (Hands Nothing (Just r₂), r₁ ^. wieldedItem <| backpack') + (Hands Nothing r₁, Hands (Just l₂) Nothing) -> + (Hands (Just l₂) r₁, backpack') + (Hands (Just l₁) Nothing, Hands (Just l₂) Nothing) -> + (Hands (Just l₂) Nothing, l₁ ^. wieldedItem <| backpack') + (Hands (Just l₁) (Just r₁), Hands Nothing (Just r₂)) -> + (Hands (Just l₁) (Just r₂), r₁ ^. wieldedItem <| backpack') + (Hands (Just l₁) (Just r₁), Hands (Just l₂) Nothing) -> + (Hands (Just l₂) (Just r₁), l₁ ^. wieldedItem <| backpack') + in Inventory backpack'' wielded' + +instance Monoid Inventory where + mempty = Inventory mempty $ Hands Nothing Nothing + +-------------------------------------------------------------------------------- + +data Character = Character + { _inventory :: !Inventory + , _characterName :: !(Maybe Text) + , _characterHitpoints' :: !Double + , _speed :: TicksPerTile + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + Character +makeLenses ''Character + +characterHitpoints :: Character -> Hitpoints +characterHitpoints = views characterHitpoints' floor + +scrollOffset :: Int +scrollOffset = 5 + +instance Draw Character where + draw _ = visibleRegion rloc rreg $ str "@" + where + rloc = Location (negate scrollOffset, negate scrollOffset) + rreg = (2 * scrollOffset, 2 * scrollOffset) + drawPriority = const maxBound -- Character should always be on top, for now + +instance Brain Character where + step ticks = (pure .) $ positioned . characterHitpoints' %~ \hp -> + if hp > fromIntegral initialHitpoints + then hp + else hp + hitpointRecoveryRate |*| ticks + +instance Entity Character where + description _ = "yourself" + entityChar _ = "@" + +instance Arbitrary Character where + arbitrary = genericArbitrary + +initialHitpoints :: Hitpoints +initialHitpoints = 10 + +hitpointRecoveryRate :: Double `Per` Ticks +hitpointRecoveryRate = 1.0 / (15 * coerce defaultSpeed) + +defaultSpeed :: TicksPerTile +defaultSpeed = 100 + +mkCharacter :: Character +mkCharacter = Character + { _inventory = mempty + , _characterName = Nothing + , _characterHitpoints' = fromIntegral initialHitpoints + , _speed = defaultSpeed + } + +defaultCharacterDamage :: Hitpoints +defaultCharacterDamage = 1 + +-- | Returns the damage that the character currently does with an attack +-- TODO use double-handed/left-hand/right-hand here +characterDamage :: Character -> Hitpoints +characterDamage + = fromMaybe defaultCharacterDamage + . preview (inventory . wielded . wieldedItems . wieldableItem . Raw.damage) + +isDead :: Character -> Bool +isDead = (== 0) . characterHitpoints + +pickUpItem :: Item -> Character -> Character +pickUpItem it = inventory . backpack %~ (it <|) + +damage :: Hitpoints -> Character -> Character +damage (fromIntegral -> amount) = characterHitpoints' %~ \case + n | n <= amount -> 0 + | otherwise -> n - amount diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Creature.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Creature.hs new file mode 100644 index 0000000000..e95e9f0b98 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Entities/Creature.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Entities.Creature + ( -- * Creature + Creature(..) + -- ** Lenses + , creatureType + , hitpoints + , hippocampus + + -- ** Creature functions + , newWithType + , damage + , isDead + , visionRadius + + -- * Hippocampus + , Hippocampus(..) + -- ** Lenses + , destination + -- ** Destination + , Destination(..) + , destinationFromPos + -- *** Lenses + , destinationPosition + , destinationProgress + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Test.QuickCheck +import Test.QuickCheck.Arbitrary.Generic +import Data.Aeson.Generic.DerivingVia +import Data.Aeson (ToJSON, FromJSON) +-------------------------------------------------------------------------------- +import Xanthous.AI.Gormlak +import Xanthous.Entities.RawTypes hiding + (Creature, description, damage) +import qualified Xanthous.Entities.RawTypes as Raw +import Xanthous.Game.State +import Xanthous.Data +import Xanthous.Data.Entities +import Xanthous.Entities.Creature.Hippocampus +-------------------------------------------------------------------------------- + +data Creature = Creature + { _creatureType :: !CreatureType + , _hitpoints :: !Hitpoints + , _hippocampus :: !Hippocampus + } + deriving stock (Eq, Show, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Draw via DrawRawCharPriority "_creatureType" 1000 Creature + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + Creature +instance Arbitrary Creature where arbitrary = genericArbitrary +makeLenses ''Creature + +instance HasVisionRadius Creature where + visionRadius = const 50 -- TODO + +instance Brain Creature where + step = brainVia GormlakBrain + entityCanMove = const True + +instance Entity Creature where + entityAttributes _ = defaultEntityAttributes + & blocksObject .~ True + description = view $ creatureType . Raw.description + entityChar = view $ creatureType . char + entityCollision = const $ Just Combat + +-------------------------------------------------------------------------------- + +newWithType :: CreatureType -> Creature +newWithType _creatureType = + let _hitpoints = _creatureType ^. maxHitpoints + _hippocampus = initialHippocampus + in Creature {..} + +damage :: Hitpoints -> Creature -> Creature +damage amount = hitpoints %~ \hp -> + if hp <= amount + then 0 + else hp - amount + +isDead :: Creature -> Bool +isDead = views hitpoints (== 0) + +{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-} diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs new file mode 100644 index 0000000000..501a5b5972 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Entities.Creature.Hippocampus + (-- * Hippocampus + Hippocampus(..) + , initialHippocampus + -- ** Lenses + , destination + -- ** Destination + , Destination(..) + , destinationFromPos + -- *** Lenses + , destinationPosition + , destinationProgress + ) +where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Data.Aeson.Generic.DerivingVia +import Data.Aeson (ToJSON, FromJSON) +import Test.QuickCheck +import Test.QuickCheck.Arbitrary.Generic +-------------------------------------------------------------------------------- +import Xanthous.Data +import Xanthous.Util.QuickCheck +-------------------------------------------------------------------------------- + + +data Destination = Destination + { _destinationPosition :: !Position + -- | The progress towards the destination, tracked as an offset from the + -- creature's original position. + -- + -- When this value reaches >= 1, the creature has reached their destination + , _destinationProgress :: !Tiles + } + deriving stock (Eq, Show, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + Destination +instance Arbitrary Destination where arbitrary = genericArbitrary +makeLenses ''Destination + +destinationFromPos :: Position -> Destination +destinationFromPos _destinationPosition = + let _destinationProgress = 0 + in Destination{..} + +data Hippocampus = Hippocampus + { _destination :: !(Maybe Destination) + } + deriving stock (Eq, Show, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary Hippocampus + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + Hippocampus +makeLenses ''Hippocampus + +initialHippocampus :: Hippocampus +initialHippocampus = Hippocampus Nothing diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Draw/Util.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Draw/Util.hs new file mode 100644 index 0000000000..aa6c5fa4fc --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Entities/Draw/Util.hs @@ -0,0 +1,31 @@ +module Xanthous.Entities.Draw.Util where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Brick.Widgets.Border.Style +import Brick.Types (Edges(..)) +-------------------------------------------------------------------------------- + +borderFromEdges :: BorderStyle -> Edges Bool -> Char +borderFromEdges bstyle edges = ($ bstyle) $ case edges of + Edges False False False False -> const '☐' + + Edges True False False False -> bsVertical + Edges False True False False -> bsVertical + Edges False False True False -> bsHorizontal + Edges False False False True -> bsHorizontal + + Edges True True False False -> bsVertical + Edges True False True False -> bsCornerBR + Edges True False False True -> bsCornerBL + + Edges False True True False -> bsCornerTR + Edges False True False True -> bsCornerTL + Edges False False True True -> bsHorizontal + + Edges False True True True -> bsIntersectT + Edges True False True True -> bsIntersectB + Edges True True False True -> bsIntersectL + Edges True True True False -> bsIntersectR + + Edges True True True True -> bsIntersectFull diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs new file mode 100644 index 0000000000..62e6e15c98 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-------------------------------------------------------------------------------- +module Xanthous.Entities.Entities () where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Test.QuickCheck +import qualified Test.QuickCheck.Gen as Gen +import Data.Aeson +-------------------------------------------------------------------------------- +import Xanthous.Entities.Character +import Xanthous.Entities.Item +import Xanthous.Entities.Creature +import Xanthous.Entities.Environment +import Xanthous.Game.State +import Xanthous.Util.QuickCheck +import Data.Aeson.Generic.DerivingVia +-------------------------------------------------------------------------------- + +instance Arbitrary SomeEntity where + arbitrary = Gen.oneof + [ SomeEntity <$> arbitrary @Character + , SomeEntity <$> arbitrary @Item + , SomeEntity <$> arbitrary @Creature + , SomeEntity <$> arbitrary @Wall + , SomeEntity <$> arbitrary @Door + , SomeEntity <$> arbitrary @GroundMessage + , SomeEntity <$> arbitrary @Staircase + ] + +instance FromJSON SomeEntity where + parseJSON = withObject "Entity" $ \obj -> do + (entityType :: Text) <- obj .: "type" + case entityType of + "Character" -> SomeEntity @Character <$> obj .: "data" + "Item" -> SomeEntity @Item <$> obj .: "data" + "Creature" -> SomeEntity @Creature <$> obj .: "data" + "Wall" -> SomeEntity @Wall <$> obj .: "data" + "Door" -> SomeEntity @Door <$> obj .: "data" + "GroundMessage" -> SomeEntity @GroundMessage <$> obj .: "data" + "Staircase" -> SomeEntity @Staircase <$> obj .: "data" + _ -> fail . unpack $ "Invalid entity type \"" <> entityType <> "\"" + +deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameLevel + instance FromJSON GameLevel +deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameState + instance FromJSON GameState + +instance Entity SomeEntity where + entityAttributes (SomeEntity ent) = entityAttributes ent + description (SomeEntity ent) = description ent + entityChar (SomeEntity ent) = entityChar ent + entityCollision (SomeEntity ent) = entityCollision ent + +instance Function SomeEntity where + function = functionJSON + +instance CoArbitrary SomeEntity where + coarbitrary = coarbitrary . encode diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs-boot b/users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs-boot new file mode 100644 index 0000000000..519a862c6a --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs-boot @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Xanthous.Entities.Entities where + +import Test.QuickCheck +import Data.Aeson +import Xanthous.Game.State (SomeEntity, GameState, Entity) + +instance Arbitrary SomeEntity +instance Function SomeEntity +instance CoArbitrary SomeEntity +instance FromJSON SomeEntity +instance Entity SomeEntity + +instance FromJSON GameState diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Environment.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Environment.hs new file mode 100644 index 0000000000..b45a91eabe --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Entities/Environment.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE TemplateHaskell #-} +module Xanthous.Entities.Environment + ( + -- * Walls + Wall(..) + + -- * Doors + , Door(..) + , open + , closed + , locked + , unlockedDoor + + -- * Messages + , GroundMessage(..) + + -- * Stairs + , Staircase(..) + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Test.QuickCheck +import Brick (str) +import Brick.Widgets.Border.Style (unicode) +import Brick.Types (Edges(..)) +import Data.Aeson +import Data.Aeson.Generic.DerivingVia +-------------------------------------------------------------------------------- +import Xanthous.Entities.Draw.Util +import Xanthous.Data +import Xanthous.Data.Entities +import Xanthous.Game.State +import Xanthous.Util.QuickCheck +-------------------------------------------------------------------------------- + +data Wall = Wall + deriving stock (Show, Eq, Ord, Generic, Enum) + deriving anyclass (NFData, CoArbitrary, Function) + +instance ToJSON Wall where + toJSON = const $ String "Wall" + +instance FromJSON Wall where + parseJSON = withText "Wall" $ \case + "Wall" -> pure Wall + _ -> fail "Invalid Wall: expected Wall" + +instance Brain Wall where step = brainVia Brainless + +instance Entity Wall where + entityAttributes _ = defaultEntityAttributes + & blocksVision .~ True + & blocksObject .~ True + description _ = "a wall" + entityChar _ = "┼" + +instance Arbitrary Wall where + arbitrary = pure Wall + +wallEdges :: (MonoFoldable mono, Element mono ~ SomeEntity) + => Neighbors mono -> Edges Bool +wallEdges neighs = any (entityIs @Wall) <$> edges neighs + +instance Draw Wall where + drawWithNeighbors neighs _wall = + str . pure . borderFromEdges unicode $ wallEdges neighs + +data Door = Door + { _open :: Bool + , _locked :: Bool + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON) + deriving Arbitrary via GenericArbitrary Door +makeLenses ''Door + +instance Draw Door where + drawWithNeighbors neighs door + = str . pure . ($ door ^. open) $ case wallEdges neighs of + Edges True False False False -> vertDoor + Edges False True False False -> vertDoor + Edges True True False False -> vertDoor + Edges False False True False -> horizDoor + Edges False False False True -> horizDoor + Edges False False True True -> horizDoor + _ -> allsidesDoor + where + horizDoor True = '␣' + horizDoor False = 'ᚔ' + vertDoor True = '[' + vertDoor False = 'ǂ' + allsidesDoor True = '+' + allsidesDoor False = '▥' + +instance Brain Door where step = brainVia Brainless + +instance Entity Door where + entityAttributes door = defaultEntityAttributes + & blocksVision .~ not (door ^. open) + description door | door ^. open = "an open door" + | otherwise = "a closed door" + entityChar _ = "d" + entityCollision door | door ^. open = Nothing + | otherwise = Just Stop + +closed :: Lens' Door Bool +closed = open . involuted not + +-- | A closed, unlocked door +unlockedDoor :: Door +unlockedDoor = Door + { _open = False + , _locked = False + } + +-------------------------------------------------------------------------------- + +newtype GroundMessage = GroundMessage Text + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary GroundMessage + deriving (ToJSON, FromJSON) + via WithOptions '[ 'TagSingleConstructors 'True + , 'SumEnc 'ObjWithSingleField + ] + GroundMessage + deriving Draw + via DrawStyledCharacter ('Just 'Yellow) 'Nothing "≈" + GroundMessage +instance Brain GroundMessage where step = brainVia Brainless + +instance Entity GroundMessage where + description = const "a message on the ground. Press r. to read it." + entityChar = const "≈" + entityCollision = const Nothing + +-------------------------------------------------------------------------------- + +data Staircase = UpStaircase | DownStaircase + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary Staircase + deriving (ToJSON, FromJSON) + via WithOptions '[ 'TagSingleConstructors 'True + , 'SumEnc 'ObjWithSingleField + ] + Staircase +instance Brain Staircase where step = brainVia Brainless + +instance Draw Staircase where + draw UpStaircase = str "<" + draw DownStaircase = str ">" + +instance Entity Staircase where + description UpStaircase = "a staircase leading upwards" + description DownStaircase = "a staircase leading downwards" + entityChar UpStaircase = "<" + entityChar DownStaircase = ">" + entityCollision = const Nothing diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Item.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Item.hs new file mode 100644 index 0000000000..b50a5eab80 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Entities/Item.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StandaloneDeriving #-} +-------------------------------------------------------------------------------- +module Xanthous.Entities.Item + ( Item(..) + , itemType + , newWithType + , isEdible + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +import Test.QuickCheck +import Data.Aeson (ToJSON, FromJSON) +import Data.Aeson.Generic.DerivingVia +-------------------------------------------------------------------------------- +import Xanthous.Entities.RawTypes hiding (Item, description, isEdible) +import qualified Xanthous.Entities.RawTypes as Raw +import Xanthous.Game.State +-------------------------------------------------------------------------------- + +data Item = Item + { _itemType :: ItemType + } + deriving stock (Eq, Show, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Draw via DrawRawChar "_itemType" Item + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + Item +makeLenses ''Item + +{-# ANN Item ("HLint: ignore Use newtype instead of data" :: String )#-} + +-- deriving via (Brainless Item) instance Brain Item +instance Brain Item where step = brainVia Brainless + +instance Arbitrary Item where + arbitrary = Item <$> arbitrary + +instance Entity Item where + description = view $ itemType . Raw.description + entityChar = view $ itemType . Raw.char + entityCollision = const Nothing + +newWithType :: ItemType -> Item +newWithType = Item + +isEdible :: Item -> Bool +isEdible = Raw.isEdible . view itemType diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/RawTypes.hs b/users/glittershark/xanthous/src/Xanthous/Entities/RawTypes.hs new file mode 100644 index 0000000000..30039662f0 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Entities/RawTypes.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DuplicateRecordFields #-} +-------------------------------------------------------------------------------- +module Xanthous.Entities.RawTypes + ( + EntityRaw(..) + , _Creature + , _Item + + -- * Creatures + , CreatureType(..) + , hostile + + -- * Items + , ItemType(..) + -- ** Item sub-types + -- *** Edible + , EdibleItem(..) + , isEdible + -- *** Wieldable + , WieldableItem(..) + , isWieldable + + -- * Lens classes + , HasAttackMessage(..) + , HasChar(..) + , HasDamage(..) + , HasDescription(..) + , HasEatMessage(..) + , HasEdible(..) + , HasFriendly(..) + , HasHitpointsHealed(..) + , HasLongDescription(..) + , HasMaxHitpoints(..) + , HasName(..) + , HasSpeed(..) + , HasWieldable(..) + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +import Test.QuickCheck +import Data.Aeson.Generic.DerivingVia +import Data.Aeson (ToJSON, FromJSON) +-------------------------------------------------------------------------------- +import Xanthous.Messages (Message(..)) +import Xanthous.Data (TicksPerTile, Hitpoints) +import Xanthous.Data.EntityChar +import Xanthous.Util.QuickCheck +-------------------------------------------------------------------------------- + +data CreatureType = CreatureType + { _name :: !Text + , _description :: !Text + , _char :: !EntityChar + , _maxHitpoints :: !Hitpoints + , _friendly :: !Bool + , _speed :: !TicksPerTile + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary CreatureType + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + CreatureType +makeFieldsNoPrefix ''CreatureType + +hostile :: Lens' CreatureType Bool +hostile = friendly . involuted not + +-------------------------------------------------------------------------------- + +data EdibleItem = EdibleItem + { _hitpointsHealed :: Int + , _eatMessage :: Maybe Message + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary EdibleItem + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + EdibleItem +makeFieldsNoPrefix ''EdibleItem + +data WieldableItem = WieldableItem + { _damage :: !Hitpoints + , _attackMessage :: !(Maybe Message) + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary WieldableItem + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + WieldableItem +makeFieldsNoPrefix ''WieldableItem + +-------------------------------------------------------------------------------- + +data ItemType = ItemType + { _name :: Text + , _description :: Text + , _longDescription :: Text + , _char :: EntityChar + , _edible :: Maybe EdibleItem + , _wieldable :: Maybe WieldableItem + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary ItemType + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + ItemType +makeFieldsNoPrefix ''ItemType + +-- | Can this item be eaten? +isEdible :: ItemType -> Bool +isEdible = has $ edible . _Just + +-- | Can this item be used as a weapon? +isWieldable :: ItemType -> Bool +isWieldable = has $ wieldable . _Just + +-------------------------------------------------------------------------------- + +data EntityRaw + = Creature CreatureType + | Item ItemType + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) + deriving Arbitrary via GenericArbitrary EntityRaw + deriving (FromJSON) + via WithOptions '[ SumEnc ObjWithSingleField ] + EntityRaw +makePrisms ''EntityRaw diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Raws.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Raws.hs new file mode 100644 index 0000000000..d4cae7ccc2 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Entities/Raws.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Entities.Raws + ( raws + , raw + , RawType(..) + , rawsWithType + , entityFromRaw + ) where +-------------------------------------------------------------------------------- +import Data.FileEmbed +import qualified Data.Yaml as Yaml +import Xanthous.Prelude +import System.FilePath.Posix +-------------------------------------------------------------------------------- +import Xanthous.Entities.RawTypes +import Xanthous.Game.State +import qualified Xanthous.Entities.Creature as Creature +import qualified Xanthous.Entities.Item as Item +import Xanthous.AI.Gormlak () +-------------------------------------------------------------------------------- +rawRaws :: [(FilePath, ByteString)] +rawRaws = $(embedDir "src/Xanthous/Entities/Raws") + +raws :: HashMap Text EntityRaw +raws + = mapFromList + . map (bimap + (pack . takeBaseName) + (either (error . Yaml.prettyPrintParseException) id + . Yaml.decodeEither')) + $ rawRaws + +raw :: Text -> Maybe EntityRaw +raw n = raws ^. at n + +class RawType (a :: Type) where + _RawType :: Prism' EntityRaw a + +instance RawType CreatureType where + _RawType = prism' Creature $ \case + Creature c -> Just c + _ -> Nothing + +instance RawType ItemType where + _RawType = prism' Item $ \case + Item i -> Just i + _ -> Nothing + +rawsWithType :: forall a. RawType a => HashMap Text a +rawsWithType = mapFromList . itoListOf (ifolded . _RawType) $ raws + +-------------------------------------------------------------------------------- + +entityFromRaw :: EntityRaw -> SomeEntity +entityFromRaw (Creature creatureType) + = SomeEntity $ Creature.newWithType creatureType +entityFromRaw (Item itemType) + = SomeEntity $ Item.newWithType itemType diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml b/users/glittershark/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml new file mode 100644 index 0000000000..2eac895190 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml @@ -0,0 +1,13 @@ +Creature: + name: gormlak + description: a gormlak + longDescription: | + A chittering imp-like creature with bright yellow horns. It adores shiny objects + and gathers in swarms. + char: + char: g + style: + foreground: red + maxHitpoints: 5 + speed: 125 + friendly: false diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Raws/noodles.yaml b/users/glittershark/xanthous/src/Xanthous/Entities/Raws/noodles.yaml new file mode 100644 index 0000000000..c3f19dce91 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Entities/Raws/noodles.yaml @@ -0,0 +1,12 @@ +Item: + name: noodles + description: "a big bowl o' noodles" + longDescription: You know exactly what kind of noodles + char: + char: 'n' + style: + foreground: yellow + edible: + hitpointsHealed: 2 + eatMessage: + - You slurp up the noodles. Yumm! diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Raws/stick.yaml b/users/glittershark/xanthous/src/Xanthous/Entities/Raws/stick.yaml new file mode 100644 index 0000000000..bc7fde4d8b --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Entities/Raws/stick.yaml @@ -0,0 +1,14 @@ +Item: + name: stick + description: a wooden stick + longDescription: A sturdy branch broken off from some sort of tree + char: + char: ∤ + style: + foreground: yellow + wieldable: + damage: 2 + attackMessage: + - You bonk the {{creature.creatureType.name}} over the head with your stick. + - You bash the {{creature.creatureType.name}} on the noggin with your stick. + - You whack the {{creature.creatureType.name}} with your stick. diff --git a/users/glittershark/xanthous/src/Xanthous/Game.hs b/users/glittershark/xanthous/src/Xanthous/Game.hs new file mode 100644 index 0000000000..4ca6688919 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Game.hs @@ -0,0 +1,72 @@ +module Xanthous.Game + ( GameState(..) + , levels + , entities + , revealedPositions + , messageHistory + , randomGen + , promptState + , GamePromptState(..) + + , getInitialState + , initialStateFromSeed + + , positionedCharacter + , character + , characterPosition + , updateCharacterVision + , characterVisiblePositions + , entitiesAtCharacter + + -- * Messages + , MessageHistory(..) + , HasMessages(..) + , HasTurn(..) + , HasDisplayedTurn(..) + , pushMessage + , previousMessage + , nextTurn + + -- * Collisions + , Collision(..) + , collisionAt + + -- * App monad + , AppT(..) + + -- * Saving the game + , saveGame + , loadGame + , saved + + -- * Debug State + , DebugState(..) + , debugState + , allRevealed + ) where +-------------------------------------------------------------------------------- +import qualified Codec.Compression.Zlib as Zlib +import Codec.Compression.Zlib.Internal (DecompressError) +import qualified Data.Aeson as JSON +import System.IO.Unsafe +-------------------------------------------------------------------------------- +import Xanthous.Prelude +import Xanthous.Game.State +import Xanthous.Game.Lenses +import Xanthous.Game.Arbitrary () +import Xanthous.Entities.Entities () +-------------------------------------------------------------------------------- + +saveGame :: GameState -> LByteString +saveGame = Zlib.compress . JSON.encode + +loadGame :: LByteString -> Maybe GameState +loadGame = JSON.decode <=< decompressZlibMay + where + decompressZlibMay bs + = unsafeDupablePerformIO + $ (let r = Zlib.decompress bs in r `seq` pure (Just r)) + `catch` \(_ :: DecompressError) -> pure Nothing + +saved :: Prism' LByteString GameState +saved = prism' saveGame loadGame diff --git a/users/glittershark/xanthous/src/Xanthous/Game/Arbitrary.hs b/users/glittershark/xanthous/src/Xanthous/Game/Arbitrary.hs new file mode 100644 index 0000000000..a1eb789a33 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Game/Arbitrary.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RecordWildCards #-} +-------------------------------------------------------------------------------- +module Xanthous.Game.Arbitrary where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (foldMap) +-------------------------------------------------------------------------------- +import Test.QuickCheck +import System.Random +import Data.Foldable (foldMap) +-------------------------------------------------------------------------------- +import Xanthous.Data.Levels +import qualified Xanthous.Data.EntityMap as EntityMap +import Xanthous.Entities.Entities () +import Xanthous.Entities.Character +import Xanthous.Game.State +import Xanthous.Util.QuickCheck (GenericArbitrary(..)) +-------------------------------------------------------------------------------- + +deriving via GenericArbitrary GameLevel instance Arbitrary GameLevel + +instance Arbitrary GameState where + arbitrary = do + chr <- arbitrary @Character + _upStaircasePosition <- arbitrary + _messageHistory <- arbitrary + levs <- arbitrary @(Levels GameLevel) + _levelRevealedPositions <- + fmap setFromList + . sublistOf + . foldMap (EntityMap.positions . _levelEntities) + $ levs + let (_characterEntityID, _levelEntities) = + EntityMap.insertAtReturningID _upStaircasePosition (SomeEntity chr) + $ levs ^. current . levelEntities + _levels = levs & current .~ GameLevel {..} + _randomGen <- mkStdGen <$> arbitrary + let _promptState = NoPrompt -- TODO + _activePanel <- arbitrary + _debugState <- arbitrary + let _autocommand = NoAutocommand + pure $ GameState {..} + + +instance CoArbitrary GameLevel +instance Function GameLevel +instance CoArbitrary GameState +instance Function GameState diff --git a/users/glittershark/xanthous/src/Xanthous/Game/Draw.hs b/users/glittershark/xanthous/src/Xanthous/Game/Draw.hs new file mode 100644 index 0000000000..b9bd8fdc03 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Game/Draw.hs @@ -0,0 +1,166 @@ +-------------------------------------------------------------------------------- +module Xanthous.Game.Draw + ( drawGame + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +import Brick hiding (loc, on) +import Brick.Widgets.Border +import Brick.Widgets.Border.Style +import Brick.Widgets.Edit +-------------------------------------------------------------------------------- +import Xanthous.Data +import Xanthous.Data.App (ResourceName, Panel(..)) +import qualified Xanthous.Data.App as Resource +import Xanthous.Data.EntityMap (EntityMap, atPosition) +import qualified Xanthous.Data.EntityMap as EntityMap +import Xanthous.Game.State +import Xanthous.Entities.Character +import Xanthous.Entities.Item (Item) +import Xanthous.Game + ( GameState(..) + , entities + , revealedPositions + , characterPosition + , characterVisiblePositions + , character + , MessageHistory(..) + , messageHistory + , GamePromptState(..) + , promptState + , debugState, allRevealed + ) +import Xanthous.Game.Prompt +import Xanthous.Orphans () +-------------------------------------------------------------------------------- + +cursorPosition :: GameState -> Widget ResourceName -> Widget ResourceName +cursorPosition game + | WaitingPrompt _ (Prompt _ SPointOnMap (PointOnMapPromptState pos) _ _) + <- game ^. promptState + = showCursor Resource.Prompt (pos ^. loc) + | otherwise + = showCursor Resource.Character (game ^. characterPosition . loc) + +drawMessages :: MessageHistory -> Widget ResourceName +drawMessages = txtWrap . (<> " ") . unwords . reverse . oextract + +drawPromptState :: GamePromptState m -> Widget ResourceName +drawPromptState NoPrompt = emptyWidget +drawPromptState (WaitingPrompt msg (Prompt _ pt ps pri _)) = + case (pt, ps, pri) of + (SStringPrompt, StringPromptState edit, _) -> + txtWrap msg <+> txt " " <+> renderEditor (txt . fold) True edit + (SDirectionPrompt, DirectionPromptState, _) -> txtWrap msg + (SContinue, _, _) -> txtWrap msg + (SMenu, _, menuItems) -> + txtWrap msg + <=> foldl' (<=>) emptyWidget (map drawMenuItem $ itoList menuItems) + _ -> txtWrap msg + where + drawMenuItem (chr, MenuOption m _) = + str ("[" <> pure chr <> "] ") <+> txtWrap m + +drawEntities + :: (Position -> Bool) + -- ^ Is a given position directly visible to the character? + -> (Position -> Bool) + -- ^ Has a given position *ever* been seen by the character? + -> EntityMap SomeEntity -- ^ all entities + -> Widget ResourceName +drawEntities isVisible isRevealed allEnts + = vBox rows + where + entityPositions = EntityMap.positions allEnts + maxY = fromMaybe 0 $ maximumOf (folded . y) entityPositions + maxX = fromMaybe 0 $ maximumOf (folded . x) entityPositions + rows = mkRow <$> [0..maxY] + mkRow rowY = hBox $ renderEntityAt . flip Position rowY <$> [0..maxX] + renderEntityAt pos + = let entitiesAtPosition = allEnts ^. atPosition pos + immobileEntitiesAtPosition = + filter (not . entityCanMove) entitiesAtPosition + in renderTopEntity pos + $ if | isVisible pos -> entitiesAtPosition + | isRevealed pos -> immobileEntitiesAtPosition + | otherwise -> mempty + renderTopEntity pos ents + = let neighbors = EntityMap.neighbors pos allEnts + in maybe (str " ") (drawWithNeighbors neighbors) + $ maximumBy (compare `on` drawPriority) + <$> fromNullable ents + +drawMap :: GameState -> Widget ResourceName +drawMap game + = viewport Resource.MapViewport Both + . cursorPosition game + $ drawEntities + (`member` characterVisiblePositions game) + (\pos -> (game ^. debugState . allRevealed) + || (pos `member` (game ^. revealedPositions))) + (game ^. entities) + +bullet :: Char +bullet = '•' + +drawInventoryPanel :: GameState -> Widget ResourceName +drawInventoryPanel game + = drawWielded (game ^. character . inventory . wielded) + <=> drawBackpack (game ^. character . inventory . backpack) + where + drawWielded (Hands Nothing Nothing) = emptyWidget + drawWielded (DoubleHanded i) = + txtWrap $ "You are holding " <> description i <> " in both hands" + drawWielded (Hands l r) = drawHand "left" l <=> drawHand "right" r + drawHand side = maybe emptyWidget $ \i -> + txtWrap ( "You are holding " + <> description i + <> " in your " <> side <> " hand" + ) + <=> txt " " + + drawBackpack :: Vector Item -> Widget ResourceName + drawBackpack Empty = txtWrap "Your backpack is empty right now." + drawBackpack backpackItems + = txtWrap ( "You are currently carrying the following items in your " + <> "backpack:") + <=> txt " " + <=> foldl' (<=>) emptyWidget + (map + (txtWrap . ((bullet <| " ") <>) . description) + backpackItems) + + +drawPanel :: GameState -> Panel -> Widget ResourceName +drawPanel game panel + = border + . hLimit 35 + . viewport (Resource.Panel panel) Vertical + . case panel of + InventoryPanel -> drawInventoryPanel + $ game + +drawCharacterInfo :: Character -> Widget ResourceName +drawCharacterInfo ch = txt " " <+> charName <+> charHitpoints + where + charName | Just n <- ch ^. characterName + = txt $ n <> " " + | otherwise + = emptyWidget + charHitpoints + = txt "Hitpoints: " + <+> txt (tshow $ let Hitpoints hp = characterHitpoints ch in hp) + +drawGame :: GameState -> [Widget ResourceName] +drawGame game + = pure + . withBorderStyle unicode + $ case game ^. promptState of + NoPrompt -> drawMessages (game ^. messageHistory) + _ -> emptyWidget + <=> drawPromptState (game ^. promptState) + <=> + (maybe emptyWidget (drawPanel game) (game ^. activePanel) + <+> border (drawMap game) + ) + <=> drawCharacterInfo (game ^. character) diff --git a/users/glittershark/xanthous/src/Xanthous/Game/Env.hs b/users/glittershark/xanthous/src/Xanthous/Game/Env.hs new file mode 100644 index 0000000000..6e10d0f735 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Game/Env.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Game.Env + ( GameEnv(..) + , eventChan + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Brick.BChan (BChan) +import Xanthous.Data.App (AppEvent) +-------------------------------------------------------------------------------- + +data GameEnv = GameEnv + { _eventChan :: BChan AppEvent + } + deriving stock (Generic) +makeLenses ''GameEnv +{-# ANN GameEnv ("HLint: ignore Use newtype instead of data" :: String) #-} diff --git a/users/glittershark/xanthous/src/Xanthous/Game/Lenses.hs b/users/glittershark/xanthous/src/Xanthous/Game/Lenses.hs new file mode 100644 index 0000000000..5d5e673c5b --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Game/Lenses.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +-------------------------------------------------------------------------------- +module Xanthous.Game.Lenses + ( positionedCharacter + , character + , characterPosition + , updateCharacterVision + , characterVisiblePositions + , characterVisibleEntities + , getInitialState + , initialStateFromSeed + , entitiesAtCharacter + + -- * Collisions + , Collision(..) + , entitiesCollision + , collisionAt + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import System.Random +import Control.Monad.State +import Control.Monad.Random (getRandom) +-------------------------------------------------------------------------------- +import Xanthous.Game.State +import Xanthous.Data +import Xanthous.Data.Levels +import qualified Xanthous.Data.EntityMap as EntityMap +import Xanthous.Data.EntityMap.Graphics + (visiblePositions, visibleEntities) +import Xanthous.Data.VectorBag +import Xanthous.Entities.Character (Character, mkCharacter) +import {-# SOURCE #-} Xanthous.Entities.Entities () +-------------------------------------------------------------------------------- + +getInitialState :: IO GameState +getInitialState = initialStateFromSeed <$> getRandom + +initialStateFromSeed :: Int -> GameState +initialStateFromSeed seed = + let _randomGen = mkStdGen seed + chr = mkCharacter + _upStaircasePosition = Position 0 0 + (_characterEntityID, _levelEntities) + = EntityMap.insertAtReturningID + _upStaircasePosition + (SomeEntity chr) + mempty + _levelRevealedPositions = mempty + level = GameLevel {..} + _levels = oneLevel level + _messageHistory = mempty + _promptState = NoPrompt + _activePanel = Nothing + _debugState = DebugState + { _allRevealed = False + } + _autocommand = NoAutocommand + in GameState {..} + + +positionedCharacter :: Lens' GameState (Positioned Character) +positionedCharacter = lens getPositionedCharacter setPositionedCharacter + where + setPositionedCharacter :: GameState -> Positioned Character -> GameState + setPositionedCharacter game chr + = game + & entities . at (game ^. characterEntityID) + ?~ fmap SomeEntity chr + + getPositionedCharacter :: GameState -> Positioned Character + getPositionedCharacter game + = over positioned + ( fromMaybe (error "Invariant error: Character was not a character!") + . downcastEntity + ) + . fromMaybe (error "Invariant error: Character not found!") + $ EntityMap.lookupWithPosition + (game ^. characterEntityID) + (game ^. entities) + + +character :: Lens' GameState Character +character = positionedCharacter . positioned + +characterPosition :: Lens' GameState Position +characterPosition = positionedCharacter . position + +visionRadius :: Word +visionRadius = 12 -- TODO make this dynamic + +-- | Update the revealed entities at the character's position based on their +-- vision +updateCharacterVision :: GameState -> GameState +updateCharacterVision game + = game & revealedPositions <>~ characterVisiblePositions game + +characterVisiblePositions :: GameState -> Set Position +characterVisiblePositions game = + let charPos = game ^. characterPosition + in visiblePositions charPos visionRadius $ game ^. entities + +characterVisibleEntities :: GameState -> EntityMap.EntityMap SomeEntity +characterVisibleEntities game = + let charPos = game ^. characterPosition + in visibleEntities charPos visionRadius $ game ^. entities + +entitiesCollision + :: ( Functor f + , forall xx. MonoFoldable (f xx) + , forall xx. Element (f xx) ~ xx + , Element (f (Maybe Collision)) ~ Maybe Collision + , Show (f (Maybe Collision)) + , Show (f SomeEntity) + ) + => f SomeEntity + -> Maybe Collision +entitiesCollision = join . maximumMay . fmap entityCollision + +collisionAt :: MonadState GameState m => Position -> m (Maybe Collision) +collisionAt p = uses (entities . EntityMap.atPosition p) entitiesCollision + +entitiesAtCharacter :: Lens' GameState (VectorBag SomeEntity) +entitiesAtCharacter = lens getter setter + where + getter gs = gs ^. entities . EntityMap.atPosition (gs ^. characterPosition) + setter gs ents = gs + & entities . EntityMap.atPosition (gs ^. characterPosition) .~ ents diff --git a/users/glittershark/xanthous/src/Xanthous/Game/Prompt.hs b/users/glittershark/xanthous/src/Xanthous/Game/Prompt.hs new file mode 100644 index 0000000000..30b5fe7545 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Game/Prompt.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveFunctor #-} +-------------------------------------------------------------------------------- +module Xanthous.Game.Prompt + ( PromptType(..) + , SPromptType(..) + , SingPromptType(..) + , PromptCancellable(..) + , PromptResult(..) + , PromptState(..) + , MenuOption(..) + , mkMenuItems + , PromptInput + , Prompt(..) + , mkPrompt + , mkMenu + , mkPointOnMapPrompt + , isCancellable + , submitPrompt + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Brick.Widgets.Edit (Editor, editorText, getEditContents) +import Test.QuickCheck +import Test.QuickCheck.Arbitrary.Generic +-------------------------------------------------------------------------------- +import Xanthous.Util (smallestNotIn) +import Xanthous.Data (Direction, Position) +import Xanthous.Data.App (ResourceName) +import qualified Xanthous.Data.App as Resource +-------------------------------------------------------------------------------- + +data PromptType where + StringPrompt :: PromptType + Confirm :: PromptType + Menu :: Type -> PromptType + DirectionPrompt :: PromptType + PointOnMap :: PromptType + Continue :: PromptType + deriving stock (Generic) + +instance Show PromptType where + show StringPrompt = "StringPrompt" + show Confirm = "Confirm" + show (Menu _) = "Menu" + show DirectionPrompt = "DirectionPrompt" + show PointOnMap = "PointOnMap" + show Continue = "Continue" + +data SPromptType :: PromptType -> Type where + SStringPrompt :: SPromptType 'StringPrompt + SConfirm :: SPromptType 'Confirm + SMenu :: SPromptType ('Menu a) + SDirectionPrompt :: SPromptType 'DirectionPrompt + SPointOnMap :: SPromptType 'PointOnMap + SContinue :: SPromptType 'Continue + +instance NFData (SPromptType pt) where + rnf SStringPrompt = () + rnf SConfirm = () + rnf SMenu = () + rnf SDirectionPrompt = () + rnf SPointOnMap = () + rnf SContinue = () + +class SingPromptType pt where singPromptType :: SPromptType pt +instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt +instance SingPromptType 'Confirm where singPromptType = SConfirm +instance SingPromptType 'DirectionPrompt where singPromptType = SDirectionPrompt +instance SingPromptType 'PointOnMap where singPromptType = SPointOnMap +instance SingPromptType 'Continue where singPromptType = SContinue + +instance Show (SPromptType pt) where + show SStringPrompt = "SStringPrompt" + show SConfirm = "SConfirm" + show SMenu = "SMenu" + show SDirectionPrompt = "SDirectionPrompt" + show SPointOnMap = "SPointOnMap" + show SContinue = "SContinue" + +data PromptCancellable + = Cancellable + | Uncancellable + deriving stock (Show, Eq, Ord, Enum, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + +instance Arbitrary PromptCancellable where + arbitrary = genericArbitrary + +data PromptResult (pt :: PromptType) where + StringResult :: Text -> PromptResult 'StringPrompt + ConfirmResult :: Bool -> PromptResult 'Confirm + MenuResult :: forall a. a -> PromptResult ('Menu a) + DirectionResult :: Direction -> PromptResult 'DirectionPrompt + PointOnMapResult :: Position -> PromptResult 'PointOnMap + ContinueResult :: PromptResult 'Continue + +instance Arbitrary (PromptResult 'StringPrompt) where + arbitrary = StringResult <$> arbitrary + +instance Arbitrary (PromptResult 'Confirm) where + arbitrary = ConfirmResult <$> arbitrary + +instance Arbitrary a => Arbitrary (PromptResult ('Menu a)) where + arbitrary = MenuResult <$> arbitrary + +instance Arbitrary (PromptResult 'DirectionPrompt) where + arbitrary = DirectionResult <$> arbitrary + +instance Arbitrary (PromptResult 'PointOnMap) where + arbitrary = PointOnMapResult <$> arbitrary + +instance Arbitrary (PromptResult 'Continue) where + arbitrary = pure ContinueResult + +-------------------------------------------------------------------------------- + +data PromptState pt where + StringPromptState + :: Editor Text ResourceName -> PromptState 'StringPrompt + DirectionPromptState :: PromptState 'DirectionPrompt + ContinuePromptState :: PromptState 'Continue + ConfirmPromptState :: PromptState 'Confirm + MenuPromptState :: forall a. PromptState ('Menu a) + PointOnMapPromptState :: Position -> PromptState 'PointOnMap + +instance NFData (PromptState pt) where + rnf sps@(StringPromptState ed) = sps `deepseq` ed `deepseq` () + rnf DirectionPromptState = () + rnf ContinuePromptState = () + rnf ConfirmPromptState = () + rnf MenuPromptState = () + rnf pomps@(PointOnMapPromptState pos) = pomps `deepseq` pos `deepseq` () + +instance Arbitrary (PromptState 'StringPrompt) where + arbitrary = StringPromptState <$> arbitrary + +instance Arbitrary (PromptState 'DirectionPrompt) where + arbitrary = pure DirectionPromptState + +instance Arbitrary (PromptState 'Continue) where + arbitrary = pure ContinuePromptState + +instance Arbitrary (PromptState ('Menu a)) where + arbitrary = pure MenuPromptState + +instance CoArbitrary (PromptState 'StringPrompt) where + coarbitrary (StringPromptState ed) = coarbitrary ed + +instance CoArbitrary (PromptState 'DirectionPrompt) where + coarbitrary DirectionPromptState = coarbitrary () + +instance CoArbitrary (PromptState 'Continue) where + coarbitrary ContinuePromptState = coarbitrary () + +instance CoArbitrary (PromptState ('Menu a)) where + coarbitrary MenuPromptState = coarbitrary () + +deriving stock instance Show (PromptState pt) + +data MenuOption a = MenuOption Text a + deriving stock (Eq, Generic, Functor) + deriving anyclass (NFData, CoArbitrary, Function) + +instance Comonad MenuOption where + extract (MenuOption _ x) = x + extend cok mo@(MenuOption text _) = MenuOption text (cok mo) + +mkMenuItems :: (MonoFoldable f, Element f ~ (Char, MenuOption a)) + => f + -> Map Char (MenuOption a) +mkMenuItems = flip foldl' mempty $ \items (chr, option) -> + let chr' = if has (ix chr) items + then smallestNotIn $ keys items + else chr + in items & at chr' ?~ option + +instance Show (MenuOption a) where + show (MenuOption m _) = show m + +type family PromptInput (pt :: PromptType) :: Type where + PromptInput ('Menu a) = Map Char (MenuOption a) + PromptInput 'PointOnMap = Position -- Character pos + PromptInput _ = () + +data Prompt (m :: Type -> Type) where + Prompt + :: forall (pt :: PromptType) + (m :: Type -> Type). + PromptCancellable + -> SPromptType pt + -> PromptState pt + -> PromptInput pt + -> (PromptResult pt -> m ()) + -> Prompt m + +instance Show (Prompt m) where + show (Prompt c pt ps pri _) + = "(Prompt " + <> show c <> " " + <> show pt <> " " + <> show ps <> " " + <> showPri + <> " <function>)" + where showPri = case pt of + SMenu -> show pri + _ -> "()" + +instance NFData (Prompt m) where + rnf (Prompt c SMenu ps pri cb) + = c + `deepseq` ps + `deepseq` pri + `seq` cb + `seq` () + rnf (Prompt c spt ps pri cb) + = c + `deepseq` spt + `deepseq` ps + `deepseq` pri + `seq` cb + `seq` () + +instance CoArbitrary (m ()) => CoArbitrary (Prompt m) where + coarbitrary (Prompt c SStringPrompt ps pri cb) = + variant @Int 1 . coarbitrary (c, ps, pri, cb) + coarbitrary (Prompt c SConfirm _ pri cb) = -- TODO fill in prompt state + variant @Int 2 . coarbitrary (c, pri, cb) + coarbitrary (Prompt c SMenu _ps _pri _cb) = + variant @Int 3 . coarbitrary c {-, ps, pri, cb -} + coarbitrary (Prompt c SDirectionPrompt ps pri cb) = + variant @Int 4 . coarbitrary (c, ps, pri, cb) + coarbitrary (Prompt c SPointOnMap _ pri cb) = -- TODO fill in prompt state + variant @Int 5 . coarbitrary (c, pri, cb) + coarbitrary (Prompt c SContinue ps pri cb) = + variant @Int 6 . coarbitrary (c, ps, pri, cb) + +-- instance Function (Prompt m) where +-- function = functionMap toTuple _fromTuple +-- where +-- toTuple (Prompt c pt ps pri cb) = (c, pt, ps, pri, cb) + + +mkPrompt :: (PromptInput pt ~ ()) => PromptCancellable -> SPromptType pt -> (PromptResult pt -> m ()) -> Prompt m +mkPrompt c pt@SStringPrompt cb = + let ps = StringPromptState $ editorText Resource.Prompt (Just 1) "" + in Prompt c pt ps () cb +mkPrompt c pt@SDirectionPrompt cb = Prompt c pt DirectionPromptState () cb +mkPrompt c pt@SContinue cb = Prompt c pt ContinuePromptState () cb +mkPrompt c pt@SConfirm cb = Prompt c pt ConfirmPromptState () cb + +mkMenu + :: forall a m. + PromptCancellable + -> Map Char (MenuOption a) -- ^ Menu items + -> (PromptResult ('Menu a) -> m ()) + -> Prompt m +mkMenu c = Prompt c SMenu MenuPromptState + +mkPointOnMapPrompt + :: PromptCancellable + -> Position + -> (PromptResult 'PointOnMap -> m ()) + -> Prompt m +mkPointOnMapPrompt c pos = Prompt c SPointOnMap (PointOnMapPromptState pos) pos + +isCancellable :: Prompt m -> Bool +isCancellable (Prompt Cancellable _ _ _ _) = True +isCancellable (Prompt Uncancellable _ _ _ _) = False + +submitPrompt :: Applicative m => Prompt m -> m () +submitPrompt (Prompt _ pt ps _ cb) = + case (pt, ps) of + (SStringPrompt, StringPromptState edit) -> + cb . StringResult . mconcat . getEditContents $ edit + (SDirectionPrompt, DirectionPromptState) -> + pure () -- Don't use submit with a direction prompt + (SContinue, ContinuePromptState) -> + cb ContinueResult + (SMenu, MenuPromptState) -> + pure () -- Don't use submit with a menu prompt + (SPointOnMap, PointOnMapPromptState pos) -> + cb $ PointOnMapResult pos + (SConfirm, ConfirmPromptState) -> + cb $ ConfirmResult True diff --git a/users/glittershark/xanthous/src/Xanthous/Game/State.hs b/users/glittershark/xanthous/src/Xanthous/Game/State.hs new file mode 100644 index 0000000000..f614cad473 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Game/State.hs @@ -0,0 +1,558 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +-------------------------------------------------------------------------------- +module Xanthous.Game.State + ( GameState(..) + , entities + , levels + , revealedPositions + , messageHistory + , randomGen + , activePanel + , promptState + , characterEntityID + , autocommand + , GamePromptState(..) + + -- * Game Level + , GameLevel(..) + , levelEntities + , upStaircasePosition + , levelRevealedPositions + + -- * Messages + , MessageHistory(..) + , HasMessages(..) + , HasTurn(..) + , HasDisplayedTurn(..) + , pushMessage + , previousMessage + , nextTurn + + -- * Autocommands + , Autocommand(..) + , AutocommandState(..) + , _NoAutocommand + , _ActiveAutocommand + + -- * App monad + , AppT(..) + , AppM + , runAppT + + -- * Entities + , Draw(..) + , Brain(..) + , Brainless(..) + , brainVia + , Collision(..) + , Entity(..) + , SomeEntity(..) + , downcastEntity + , _SomeEntity + , entityIs + -- ** Vias + , Color(..) + , DrawNothing(..) + , DrawRawChar(..) + , DrawRawCharPriority(..) + , DrawCharacter(..) + , DrawStyledCharacter(..) + , DeriveEntity(..) + -- ** Field classes + , HasChar(..) + , HasStyle(..) + + -- * Debug State + , DebugState(..) + , debugState + , allRevealed + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Data.List.NonEmpty ( NonEmpty((:|))) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Typeable +import Data.Coerce +import System.Random +import Test.QuickCheck +import Test.QuickCheck.Arbitrary.Generic +import Control.Monad.Random.Class +import Control.Monad.State +import Control.Monad.Trans.Control (MonadTransControl(..)) +import Control.Monad.Trans.Compose +import Control.Monad.Morph (MFunctor(..)) +import Brick (EventM, Widget, raw, str, emptyWidget) +import Data.Aeson (ToJSON(..), FromJSON(..), Value(Null)) +import qualified Data.Aeson as JSON +import Data.Aeson.Generic.DerivingVia +import Data.Generics.Product.Fields +import qualified Graphics.Vty.Attributes as Vty +import qualified Graphics.Vty.Image as Vty +-------------------------------------------------------------------------------- +import Xanthous.Util (KnownBool(..)) +import Xanthous.Util.QuickCheck (GenericArbitrary(..)) +import Xanthous.Data +import Xanthous.Data.App +import Xanthous.Data.Levels +import Xanthous.Data.EntityMap (EntityMap, EntityID) +import Xanthous.Data.EntityChar +import Xanthous.Data.VectorBag +import Xanthous.Data.Entities +import Xanthous.Orphans () +import Xanthous.Game.Prompt +import Xanthous.Game.Env +-------------------------------------------------------------------------------- + +data MessageHistory + = MessageHistory + { _messages :: Map Word (NonEmpty Text) + , _turn :: Word + , _displayedTurn :: Maybe Word + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary MessageHistory + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + MessageHistory +makeFieldsNoPrefix ''MessageHistory + +instance Semigroup MessageHistory where + (MessageHistory msgs₁ turn₁ dt₁) <> (MessageHistory msgs₂ turn₂ dt₂) = + MessageHistory (msgs₁ <> msgs₂) (max turn₁ turn₂) $ case (dt₁, dt₂) of + (_, Nothing) -> Nothing + (Just t, _) -> Just t + (Nothing, Just t) -> Just t + +instance Monoid MessageHistory where + mempty = MessageHistory mempty 0 Nothing + +type instance Element MessageHistory = [Text] +instance MonoFunctor MessageHistory where + omap f mh@(MessageHistory _ t _) = + mh & messages . at t %~ (NonEmpty.nonEmpty . f . toList =<<) + +instance MonoComonad MessageHistory where + oextract (MessageHistory ms t dt) = maybe [] toList $ ms ^. at (fromMaybe t dt) + oextend cok mh@(MessageHistory _ t dt) = + mh & messages . at (fromMaybe t dt) .~ NonEmpty.nonEmpty (cok mh) + +pushMessage :: Text -> MessageHistory -> MessageHistory +pushMessage msg mh@(MessageHistory _ turn' _) = + mh + & messages . at turn' %~ \case + Nothing -> Just $ msg :| mempty + Just msgs -> Just $ msg <| msgs + & displayedTurn .~ Nothing + +nextTurn :: MessageHistory -> MessageHistory +nextTurn = (turn +~ 1) . (displayedTurn .~ Nothing) + +previousMessage :: MessageHistory -> MessageHistory +previousMessage mh = mh & displayedTurn .~ maximumOf + (messages . ifolded . asIndex . filtered (< mh ^. turn)) + mh + + +-------------------------------------------------------------------------------- + +data GamePromptState m where + NoPrompt :: GamePromptState m + WaitingPrompt :: Text -> Prompt m -> GamePromptState m + deriving stock (Show, Generic) + deriving anyclass (NFData) + +-- | Non-injective! We never try to serialize waiting prompts, since: +-- +-- * they contain callback functions +-- * we can't save the game when in a prompt anyway +instance ToJSON (GamePromptState m) where + toJSON _ = Null + +-- | Always expects Null +instance FromJSON (GamePromptState m) where + parseJSON Null = pure NoPrompt + parseJSON _ = fail "Invalid GamePromptState; expected null" + +instance CoArbitrary (GamePromptState m) where + coarbitrary NoPrompt = variant @Int 1 + coarbitrary (WaitingPrompt txt _) = variant @Int 2 . coarbitrary txt + +instance Function (GamePromptState m) where + function = functionMap onlyNoPrompt (const NoPrompt) + where + onlyNoPrompt NoPrompt = () + onlyNoPrompt (WaitingPrompt _ _) = + error "Can't handle prompts in Function!" + +-------------------------------------------------------------------------------- + +newtype AppT m a + = AppT { unAppT :: ReaderT GameEnv (StateT GameState m) a } + deriving ( Functor + , Applicative + , Monad + , MonadState GameState + , MonadReader GameEnv + , MonadIO + ) + via (ReaderT GameEnv (StateT GameState m)) + deriving ( MonadTrans + , MFunctor + ) + via (ReaderT GameEnv `ComposeT` StateT GameState) + +type AppM = AppT (EventM ResourceName) + +-------------------------------------------------------------------------------- + +class Draw a where + drawWithNeighbors :: Neighbors (VectorBag SomeEntity) -> a -> Widget n + drawWithNeighbors = const draw + + draw :: a -> Widget n + draw = drawWithNeighbors $ pure mempty + + -- | higher priority gets drawn on top + drawPriority :: a -> Word + drawPriority = const minBound + +instance Draw a => Draw (Positioned a) where + drawWithNeighbors ns (Positioned _ a) = drawWithNeighbors ns a + draw (Positioned _ a) = draw a + +newtype DrawCharacter (char :: Symbol) (a :: Type) where + DrawCharacter :: a -> DrawCharacter char a + +instance KnownSymbol char => Draw (DrawCharacter char a) where + draw _ = str $ symbolVal @char Proxy + +data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White + +class KnownColor (color :: Color) where + colorVal :: forall proxy. proxy color -> Vty.Color + +instance KnownColor 'Black where colorVal _ = Vty.black +instance KnownColor 'Red where colorVal _ = Vty.red +instance KnownColor 'Green where colorVal _ = Vty.green +instance KnownColor 'Yellow where colorVal _ = Vty.yellow +instance KnownColor 'Blue where colorVal _ = Vty.blue +instance KnownColor 'Magenta where colorVal _ = Vty.magenta +instance KnownColor 'Cyan where colorVal _ = Vty.cyan +instance KnownColor 'White where colorVal _ = Vty.white + +class KnownMaybeColor (maybeColor :: Maybe Color) where + maybeColorVal :: forall proxy. proxy maybeColor -> Maybe Vty.Color + +instance KnownMaybeColor 'Nothing where maybeColorVal _ = Nothing +instance KnownColor color => KnownMaybeColor ('Just color) where + maybeColorVal _ = Just $ colorVal @color Proxy + +newtype DrawStyledCharacter (fg :: Maybe Color) (bg :: Maybe Color) (char :: Symbol) (a :: Type) where + DrawStyledCharacter :: a -> DrawStyledCharacter fg bg char a + +instance + ( KnownMaybeColor fg + , KnownMaybeColor bg + , KnownSymbol char + ) + => Draw (DrawStyledCharacter fg bg char a) where + draw _ = raw $ Vty.string attr $ symbolVal @char Proxy + where attr = Vty.Attr + { Vty.attrStyle = Vty.Default + , Vty.attrForeColor = maybe Vty.Default Vty.SetTo + $ maybeColorVal @fg Proxy + , Vty.attrBackColor = maybe Vty.Default Vty.SetTo + $ maybeColorVal @bg Proxy + , Vty.attrURL = Vty.Default + } + +instance Draw EntityChar where + draw EntityChar{..} = raw $ Vty.string _style [_char] + +-------------------------------------------------------------------------------- + +newtype DrawNothing (a :: Type) = DrawNothing a + +instance Draw (DrawNothing a) where + draw = const emptyWidget + drawPriority = const 0 + +newtype DrawRawChar (rawField :: Symbol) (a :: Type) = DrawRawChar a + +instance + forall rawField a raw. + ( HasField rawField a a raw raw + , HasChar raw EntityChar + ) => Draw (DrawRawChar rawField a) where + draw (DrawRawChar e) = draw $ e ^. field @rawField . char + +newtype DrawRawCharPriority + (rawField :: Symbol) + (priority :: Nat) + (a :: Type) + = DrawRawCharPriority a + +instance + forall rawField priority a raw. + ( HasField rawField a a raw raw + , KnownNat priority + , HasChar raw EntityChar + ) => Draw (DrawRawCharPriority rawField priority a) where + draw (DrawRawCharPriority e) = draw $ e ^. field @rawField . char + drawPriority = const . fromIntegral $ natVal @priority Proxy + + +-------------------------------------------------------------------------------- + +class Brain a where + step :: Ticks -> Positioned a -> AppM (Positioned a) + -- | Does this entity ever move on its own? + entityCanMove :: a -> Bool + entityCanMove = const False + +newtype Brainless a = Brainless a + +instance Brain (Brainless a) where + step = const pure + +-- | Workaround for the inability to use DerivingVia on Brain due to the lack of +-- higher-order roles (specifically AppT not having its last type argument have +-- role representational bc of StateT) +brainVia + :: forall brain entity. (Coercible entity brain, Brain brain) + => (entity -> brain) -- ^ constructor, ignored + -> (Ticks -> Positioned entity -> AppM (Positioned entity)) +brainVia _ ticks = fmap coerce . step ticks . coerce @_ @(Positioned brain) + +-------------------------------------------------------------------------------- + +class ( Show a, Eq a, Ord a, NFData a + , ToJSON a, FromJSON a + , Draw a, Brain a + ) => Entity a where + entityAttributes :: a -> EntityAttributes + entityAttributes = const defaultEntityAttributes + description :: a -> Text + entityChar :: a -> EntityChar + entityCollision :: a -> Maybe Collision + entityCollision = const $ Just Stop + +data SomeEntity where + SomeEntity :: forall a. (Entity a, Typeable a) => a -> SomeEntity + +instance Show SomeEntity where + show (SomeEntity e) = "SomeEntity (" <> show e <> ")" + +instance Eq SomeEntity where + (SomeEntity (a :: ea)) == (SomeEntity (b :: eb)) = case eqT @ea @eb of + Just Refl -> a == b + _ -> False + +instance Ord SomeEntity where + compare (SomeEntity (a :: ea)) (SomeEntity (b :: eb)) = case eqT @ea @eb of + Just Refl -> compare a b + _ -> compare (typeRep $ Proxy @ea) (typeRep $ Proxy @eb) + + +instance NFData SomeEntity where + rnf (SomeEntity ent) = ent `deepseq` () + +instance ToJSON SomeEntity where + toJSON (SomeEntity ent) = entityToJSON ent + where + entityToJSON :: forall entity. (Entity entity, Typeable entity) + => entity -> JSON.Value + entityToJSON entity = JSON.object + [ "type" JSON..= tshow (typeRep @_ @entity Proxy) + , "data" JSON..= toJSON entity + ] + +instance Draw SomeEntity where + drawWithNeighbors ns (SomeEntity ent) = drawWithNeighbors ns ent + drawPriority (SomeEntity ent) = drawPriority ent + +instance Brain SomeEntity where + step ticks (Positioned p (SomeEntity ent)) = + fmap SomeEntity <$> step ticks (Positioned p ent) + entityCanMove (SomeEntity ent) = entityCanMove ent + +downcastEntity :: forall (a :: Type). (Typeable a) => SomeEntity -> Maybe a +downcastEntity (SomeEntity e) = cast e + +entityIs :: forall (a :: Type). (Typeable a) => SomeEntity -> Bool +entityIs = isJust . downcastEntity @a + +_SomeEntity :: forall a. (Entity a, Typeable a) => Prism' SomeEntity a +_SomeEntity = prism' SomeEntity downcastEntity + +newtype DeriveEntity + (blocksVision :: Bool) + (description :: Symbol) + (entityChar :: Symbol) + (entity :: Type) + = DeriveEntity entity + deriving newtype (Show, Eq, Ord, NFData, ToJSON, FromJSON, Draw) + +instance Brain entity => Brain (DeriveEntity b d c entity) where + step = brainVia $ \(DeriveEntity e) -> e + +instance + ( KnownBool blocksVision + , KnownSymbol description + , KnownSymbol entityChar + , Show entity, Eq entity, Ord entity, NFData entity + , ToJSON entity, FromJSON entity + , Draw entity, Brain entity + ) + => Entity (DeriveEntity blocksVision description entityChar entity) where + entityAttributes _ = defaultEntityAttributes + & blocksVision .~ boolVal @blocksVision + description _ = pack . symbolVal $ Proxy @description + entityChar _ = fromString . symbolVal $ Proxy @entityChar + +-------------------------------------------------------------------------------- + +data GameLevel = GameLevel + { _levelEntities :: !(EntityMap SomeEntity) + , _upStaircasePosition :: !Position + , _levelRevealedPositions :: !(Set Position) + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) + deriving (ToJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + GameLevel + +-------------------------------------------------------------------------------- + +data Autocommand + = AutoMove Direction + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, Hashable, ToJSON, FromJSON, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary Autocommand +{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-} + +data AutocommandState + = NoAutocommand + | ActiveAutocommand Autocommand (Async ()) + deriving stock (Eq, Ord, Generic) + deriving anyclass (Hashable) + +instance Show AutocommandState where + show NoAutocommand = "NoAutocommand" + show (ActiveAutocommand ac _) = + "(ActiveAutocommand " <> show ac <> " <Async>)" + +instance ToJSON AutocommandState where + toJSON = const Null + +instance FromJSON AutocommandState where + parseJSON Null = pure NoAutocommand + parseJSON _ = fail "Invalid AutocommandState; expected null" + +instance NFData AutocommandState where + rnf NoAutocommand = () + rnf (ActiveAutocommand ac t) = ac `deepseq` t `seq` () + +instance CoArbitrary AutocommandState where + coarbitrary NoAutocommand = variant @Int 1 + coarbitrary (ActiveAutocommand ac t) + = variant @Int 2 + . coarbitrary ac + . coarbitrary (hash t) + +instance Function AutocommandState where + function = functionMap onlyNoAC (const NoAutocommand) + where + onlyNoAC NoAutocommand = () + onlyNoAC _ = error "Can't handle autocommands in Function" + +-------------------------------------------------------------------------------- + + +data DebugState = DebugState + { _allRevealed :: !Bool + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + DebugState +{-# ANN DebugState ("HLint: ignore Use newtype instead of data" :: String) #-} + +instance Arbitrary DebugState where + arbitrary = genericArbitrary + +data GameState = GameState + { _levels :: !(Levels GameLevel) + , _characterEntityID :: !EntityID + , _messageHistory :: !MessageHistory + , _randomGen :: !StdGen + + -- | The active panel displayed in the UI, if any + , _activePanel :: !(Maybe Panel) + + , _promptState :: !(GamePromptState AppM) + , _debugState :: !DebugState + , _autocommand :: !AutocommandState + } + deriving stock (Show, Generic) + deriving anyclass (NFData) + deriving (ToJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + GameState + +makeLenses ''GameLevel +makeLenses ''GameState + +entities :: Lens' GameState (EntityMap SomeEntity) +entities = levels . current . levelEntities + +revealedPositions :: Lens' GameState (Set Position) +revealedPositions = levels . current . levelRevealedPositions + +instance Eq GameState where + (==) = (==) `on` \gs -> + ( gs ^. entities + , gs ^. revealedPositions + , gs ^. characterEntityID + , gs ^. messageHistory + , gs ^. activePanel + , gs ^. debugState + ) + +-------------------------------------------------------------------------------- + +runAppT :: Monad m => AppT m a -> GameEnv -> GameState -> m (a, GameState) +runAppT appt env initialState + = flip runStateT initialState + . flip runReaderT env + . unAppT + $ appt + +instance (Monad m) => MonadRandom (AppT m) where + getRandomR rng = randomGen %%= randomR rng + getRandom = randomGen %%= random + getRandomRs rng = uses randomGen $ randomRs rng + getRandoms = uses randomGen randoms + +instance MonadTransControl AppT where + type StT AppT a = (a, GameState) + liftWith f + = AppT + . ReaderT $ \e + -> StateT $ \s + -> (,s) <$> f (\action -> runAppT action e s) + restoreT = AppT . ReaderT . const . StateT . const + +-------------------------------------------------------------------------------- + +makeLenses ''DebugState +makePrisms ''AutocommandState diff --git a/users/glittershark/xanthous/src/Xanthous/Generators.hs b/users/glittershark/xanthous/src/Xanthous/Generators.hs new file mode 100644 index 0000000000..9b2b90e300 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Generators.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Generators + ( generate + , Generator(..) + , SGenerator(..) + , GeneratorInput + , generateFromInput + , parseGeneratorInput + , showCells + , Level(..) + , levelWalls + , levelItems + , levelCreatures + , levelDoors + , levelCharacterPosition + , levelTutorialMessage + , generateLevel + , levelToEntityMap + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +import Data.Array.Unboxed +import System.Random (RandomGen) +import qualified Options.Applicative as Opt +import Control.Monad.Random +-------------------------------------------------------------------------------- +import qualified Xanthous.Generators.CaveAutomata as CaveAutomata +import qualified Xanthous.Generators.Dungeon as Dungeon +import Xanthous.Generators.Util +import Xanthous.Generators.LevelContents +import Xanthous.Data (Dimensions, Position'(Position), Position) +import Xanthous.Data.EntityMap (EntityMap, _EntityMap) +import qualified Xanthous.Data.EntityMap as EntityMap +import Xanthous.Entities.Environment +import Xanthous.Entities.Item (Item) +import Xanthous.Entities.Creature (Creature) +import Xanthous.Game.State (SomeEntity(..)) +-------------------------------------------------------------------------------- + +data Generator + = CaveAutomata + | Dungeon + deriving stock (Show, Eq) + +data SGenerator (gen :: Generator) where + SCaveAutomata :: SGenerator 'CaveAutomata + SDungeon :: SGenerator 'Dungeon + +type family Params (gen :: Generator) :: Type where + Params 'CaveAutomata = CaveAutomata.Params + Params 'Dungeon = Dungeon.Params + +generate + :: RandomGen g + => SGenerator gen + -> Params gen + -> Dimensions + -> g + -> Cells +generate SCaveAutomata = CaveAutomata.generate +generate SDungeon = Dungeon.generate + +data GeneratorInput where + GeneratorInput :: forall gen. SGenerator gen -> Params gen -> GeneratorInput + +generateFromInput :: RandomGen g => GeneratorInput -> Dimensions -> g -> Cells +generateFromInput (GeneratorInput sg ps) = generate sg ps + +parseGeneratorInput :: Opt.Parser GeneratorInput +parseGeneratorInput = Opt.subparser + $ generatorCommand SCaveAutomata + "cave" + "Cellular-automata based cave generator" + CaveAutomata.parseParams + <> generatorCommand SDungeon + "dungeon" + "Classic dungeon map generator" + Dungeon.parseParams + where + generatorCommand sgen name desc parseParams = + Opt.command name + (Opt.info + (GeneratorInput <$> pure sgen <*> parseParams) + (Opt.progDesc desc) + ) + + +showCells :: Cells -> Text +showCells arr = + let ((minX, minY), (maxX, maxY)) = bounds arr + showCellVal True = "x" + showCellVal False = " " + showCell = showCellVal . (arr !) + row r = foldMap (showCell . (, r)) [minX..maxX] + rows = row <$> [minY..maxY] + in intercalate "\n" rows + +cellsToWalls :: Cells -> EntityMap Wall +cellsToWalls cells = foldl' maybeInsertWall mempty . assocs $ cells + where + maybeInsertWall em (pos@(x, y), True) + | not (surroundedOnAllSides pos) = + let x' = fromIntegral x + y' = fromIntegral y + in EntityMap.insertAt (Position x' y') Wall em + maybeInsertWall em _ = em + surroundedOnAllSides pos = numAliveNeighbors cells pos == 8 + +-------------------------------------------------------------------------------- + +data Level = Level + { _levelWalls :: !(EntityMap Wall) + , _levelDoors :: !(EntityMap Door) + , _levelItems :: !(EntityMap Item) + , _levelCreatures :: !(EntityMap Creature) + , _levelTutorialMessage :: !(EntityMap GroundMessage) + , _levelStaircases :: !(EntityMap Staircase) + , _levelCharacterPosition :: !Position + } + deriving stock (Generic) + deriving anyclass (NFData) +makeLenses ''Level + +generateLevel + :: MonadRandom m + => SGenerator gen + -> Params gen + -> Dimensions + -> m Level +generateLevel gen ps dims = do + rand <- mkStdGen <$> getRandom + let cells = generate gen ps dims rand + _levelWalls = cellsToWalls cells + _levelItems <- randomItems cells + _levelCreatures <- randomCreatures cells + _levelDoors <- randomDoors cells + _levelCharacterPosition <- chooseCharacterPosition cells + let upStaircase = _EntityMap # [(_levelCharacterPosition, UpStaircase)] + downStaircase <- placeDownStaircase cells + let _levelStaircases = upStaircase <> downStaircase + _levelTutorialMessage <- tutorialMessage cells _levelCharacterPosition + pure Level {..} + +levelToEntityMap :: Level -> EntityMap SomeEntity +levelToEntityMap level + = (SomeEntity <$> level ^. levelWalls) + <> (SomeEntity <$> level ^. levelDoors) + <> (SomeEntity <$> level ^. levelItems) + <> (SomeEntity <$> level ^. levelCreatures) + <> (SomeEntity <$> level ^. levelTutorialMessage) + <> (SomeEntity <$> level ^. levelStaircases) diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs b/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs new file mode 100644 index 0000000000..83740fe4b7 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Generators.CaveAutomata + ( Params(..) + , defaultParams + , parseParams + , generate + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +import Control.Monad.Random (RandomGen, runRandT) +import Data.Array.ST +import Data.Array.Unboxed +import qualified Options.Applicative as Opt +-------------------------------------------------------------------------------- +import Xanthous.Util (between) +import Xanthous.Util.Optparse +import Xanthous.Data (Dimensions, width, height) +import Xanthous.Generators.Util +-------------------------------------------------------------------------------- + +data Params = Params + { _aliveStartChance :: Double + , _birthLimit :: Word + , _deathLimit :: Word + , _steps :: Word + } + deriving stock (Show, Eq, Generic) +makeLenses ''Params + +defaultParams :: Params +defaultParams = Params + { _aliveStartChance = 0.6 + , _birthLimit = 3 + , _deathLimit = 4 + , _steps = 4 + } + +parseParams :: Opt.Parser Params +parseParams = Params + <$> Opt.option parseChance + ( Opt.long "alive-start-chance" + <> Opt.value (defaultParams ^. aliveStartChance) + <> Opt.showDefault + <> Opt.help ( "Chance for each cell to start alive at the beginning of " + <> "the cellular automata" + ) + <> Opt.metavar "CHANCE" + ) + <*> Opt.option parseNeighbors + ( Opt.long "birth-limit" + <> Opt.value (defaultParams ^. birthLimit) + <> Opt.showDefault + <> Opt.help "Minimum neighbor count required for birth of a cell" + <> Opt.metavar "NEIGHBORS" + ) + <*> Opt.option parseNeighbors + ( Opt.long "death-limit" + <> Opt.value (defaultParams ^. deathLimit) + <> Opt.showDefault + <> Opt.help "Maximum neighbor count required for death of a cell" + <> Opt.metavar "NEIGHBORS" + ) + <*> Opt.option Opt.auto + ( Opt.long "steps" + <> Opt.value (defaultParams ^. steps) + <> Opt.showDefault + <> Opt.help "Number of generations to run the automata for" + <> Opt.metavar "STEPS" + ) + where + parseChance = readWithGuard + (between 0 1) + $ \res -> "Chance must be in the range [0,1], got: " <> show res + + parseNeighbors = readWithGuard + (between 0 8) + $ \res -> "Neighbors must be in the range [0,8], got: " <> show res + +generate :: RandomGen g => Params -> Dimensions -> g -> Cells +generate params dims gen + = runSTUArray + $ fmap fst + $ flip runRandT gen + $ generate' params dims + +generate' :: RandomGen g => Params -> Dimensions -> CellM g s (MCells s) +generate' params dims = do + cells <- randInitialize dims $ params ^. aliveStartChance + let steps' = params ^. steps + when (steps' > 0) + $ for_ [0 .. pred steps'] . const $ stepAutomata cells dims params + -- Remove all but the largest contiguous region of unfilled space + (_: smallerRegions) <- lift $ regions @UArray . amap not <$> freeze cells + lift $ fillAllM (fold smallerRegions) cells + lift $ fillOuterEdgesM cells + pure cells + +stepAutomata :: forall s g. MCells s -> Dimensions -> Params -> CellM g s () +stepAutomata cells dims params = do + origCells <- lift $ cloneMArray @_ @(STUArray s) cells + for_ (range ((0, 0), (dims ^. width, dims ^. height))) $ \pos -> do + neighs <- lift $ numAliveNeighborsM origCells pos + origValue <- lift $ readArray origCells pos + lift . writeArray cells pos + $ if origValue + then neighs >= params ^. deathLimit + else neighs > params ^. birthLimit diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/Dungeon.hs b/users/glittershark/xanthous/src/Xanthous/Generators/Dungeon.hs new file mode 100644 index 0000000000..7fde0075e6 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Generators/Dungeon.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Generators.Dungeon + ( Params(..) + , defaultParams + , parseParams + , generate + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding ((:>)) +-------------------------------------------------------------------------------- +import Control.Monad.Random +import Data.Array.ST +import Data.Array.IArray (amap) +import Data.Stream.Infinite (Stream(..)) +import qualified Data.Stream.Infinite as Stream +import qualified Data.Graph.Inductive.Graph as Graph +import Data.Graph.Inductive.PatriciaTree +import qualified Data.List.NonEmpty as NE +import Data.Maybe (fromJust) +import Linear.V2 +import Linear.Metric +import qualified Options.Applicative as Opt +-------------------------------------------------------------------------------- +import Xanthous.Random +import Xanthous.Data hiding (x, y, _x, _y, edges) +import Xanthous.Generators.Util +import Xanthous.Util.Graphics (delaunay, straightLine) +import Xanthous.Util.Graph (mstSubGraph) +-------------------------------------------------------------------------------- + +data Params = Params + { _numRoomsRange :: (Word, Word) + , _roomDimensionRange :: (Word, Word) + , _connectednessRatioRange :: (Double, Double) + } + deriving stock (Show, Eq, Ord, Generic) +makeLenses ''Params + +defaultParams :: Params +defaultParams = Params + { _numRoomsRange = (6, 8) + , _roomDimensionRange = (3, 12) + , _connectednessRatioRange = (0.1, 0.15) + } + +parseParams :: Opt.Parser Params +parseParams = Params + <$> parseRange + "num-rooms" + "number of rooms to generate in the dungeon" + "ROOMS" + (defaultParams ^. numRoomsRange) + <*> parseRange + "room-size" + "size in tiles of one of the sides of a room" + "TILES" + (defaultParams ^. roomDimensionRange) + <*> parseRange + "connectedness-ratio" + ( "ratio of edges from the delaunay triangulation to re-add to the " + <> "minimum-spanning-tree") + "RATIO" + (defaultParams ^. connectednessRatioRange) + <**> Opt.helper + where + parseRange name desc metavar (defMin, defMax) = + (,) + <$> Opt.option Opt.auto + ( Opt.long ("min-" <> name) + <> Opt.value defMin + <> Opt.showDefault + <> Opt.help ("Minimum " <> desc) + <> Opt.metavar metavar + ) + <*> Opt.option Opt.auto + ( Opt.long ("max-" <> name) + <> Opt.value defMax + <> Opt.showDefault + <> Opt.help ("Maximum " <> desc) + <> Opt.metavar metavar + ) + +generate :: RandomGen g => Params -> Dimensions -> g -> Cells +generate params dims gen + = amap not + $ runSTUArray + $ fmap fst + $ flip runRandT gen + $ generate' params dims + +-------------------------------------------------------------------------------- + +generate' :: RandomGen g => Params -> Dimensions -> CellM g s (MCells s) +generate' params dims = do + cells <- initializeEmpty dims + rooms <- genRooms params dims + for_ rooms $ fillRoom cells + + let fullRoomGraph = delaunayRoomGraph rooms + mst = mstSubGraph fullRoomGraph + mstEdges = Graph.edges mst + nonMSTEdges = filter (\(n₁, n₂, _) -> (n₁, n₂) `notElem` mstEdges) + $ Graph.labEdges fullRoomGraph + + reintroEdgeCount <- floor . (* fromIntegral (length nonMSTEdges)) + <$> getRandomR (params ^. connectednessRatioRange) + let reintroEdges = take reintroEdgeCount nonMSTEdges + corridorGraph = Graph.insEdges reintroEdges mst + + corridors <- traverse + ( uncurry corridorBetween + . over both (fromJust . Graph.lab corridorGraph) + ) $ Graph.edges corridorGraph + + for_ (join corridors) $ \pt -> lift $ writeArray cells pt True + + pure cells + +type Room = Box Word + +genRooms :: MonadRandom m => Params -> Dimensions -> m [Room] +genRooms params dims = do + numRooms <- fromIntegral <$> getRandomR (params ^. numRoomsRange) + subRand . fmap (Stream.take numRooms . removeIntersecting []) . infinitely $ do + roomWidth <- getRandomR $ params ^. roomDimensionRange + roomHeight <- getRandomR $ params ^. roomDimensionRange + xPos <- getRandomR (0, dims ^. width - roomWidth) + yPos <- getRandomR (0, dims ^. height - roomHeight) + pure Box + { _topLeftCorner = V2 xPos yPos + , _dimensions = V2 roomWidth roomHeight + } + where + removeIntersecting seen (room :> rooms) + | any (boxIntersects room) seen + = removeIntersecting seen rooms + | otherwise + = room :> removeIntersecting (room : seen) rooms + streamRepeat x = x :> streamRepeat x + infinitely = sequence . streamRepeat + +delaunayRoomGraph :: [Room] -> Gr Room Double +delaunayRoomGraph rooms = + Graph.insEdges edges . Graph.insNodes nodes $ Graph.empty + where + edges = map (\((n₁, room₁), (n₂, room₂)) -> (n₁, n₂, roomDist room₁ room₂)) + . over (mapped . both) snd + . delaunay @Double + . NE.fromList + . map (\p@(_, room) -> (boxCenter $ fromIntegral <$> room, p)) + $ nodes + nodes = zip [0..] rooms + roomDist = distance `on` (boxCenter . fmap fromIntegral) + +fillRoom :: MCells s -> Room -> CellM g s () +fillRoom cells room = + let V2 posx posy = room ^. topLeftCorner + V2 dimx dimy = room ^. dimensions + in for_ [posx .. posx + dimx] $ \x -> + for_ [posy .. posy + dimy] $ \y -> + lift $ writeArray cells (x, y) True + +corridorBetween :: MonadRandom m => Room -> Room -> m [(Word, Word)] +corridorBetween originRoom destinationRoom + = straightLine <$> origin <*> destination + where + origin = choose . NE.fromList . map toTuple =<< originEdge + destination = choose . NE.fromList . map toTuple =<< destinationEdge + originEdge = pickEdge originRoom originCorner + destinationEdge = pickEdge destinationRoom destinationCorner + pickEdge room corner = choose . over both (boxEdge room) $ cornerEdges corner + originCorner = + case ( compare (originRoom ^. topLeftCorner . _x) + (destinationRoom ^. topLeftCorner . _x) + , compare (originRoom ^. topLeftCorner . _y) + (destinationRoom ^. topLeftCorner . _y) + ) of + (LT, LT) -> BottomRight + (LT, GT) -> TopRight + (GT, LT) -> BottomLeft + (GT, GT) -> TopLeft + + (EQ, LT) -> BottomLeft + (EQ, GT) -> TopRight + (GT, EQ) -> TopLeft + (LT, EQ) -> BottomRight + (EQ, EQ) -> TopLeft -- should never happen + + destinationCorner = opposite originCorner + toTuple (V2 x y) = (x, y) diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/LevelContents.hs b/users/glittershark/xanthous/src/Xanthous/Generators/LevelContents.hs new file mode 100644 index 0000000000..ed4cc87e79 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Generators/LevelContents.hs @@ -0,0 +1,130 @@ +-------------------------------------------------------------------------------- +module Xanthous.Generators.LevelContents + ( chooseCharacterPosition + , randomItems + , randomCreatures + , randomDoors + , placeDownStaircase + , tutorialMessage + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (any, toList) +-------------------------------------------------------------------------------- +import Control.Monad.Random +import Data.Array.IArray (amap, bounds, rangeSize, (!)) +import qualified Data.Array.IArray as Arr +import Data.Foldable (any, toList) +-------------------------------------------------------------------------------- +import Xanthous.Generators.Util +import Xanthous.Random +import Xanthous.Data ( Position, _Position, positionFromPair + , rotations, arrayNeighbors, Neighbors(..) + , neighborPositions + ) +import Xanthous.Data.EntityMap (EntityMap, _EntityMap) +import Xanthous.Entities.Raws (rawsWithType, RawType) +import qualified Xanthous.Entities.Item as Item +import Xanthous.Entities.Item (Item) +import qualified Xanthous.Entities.Creature as Creature +import Xanthous.Entities.Creature (Creature) +import Xanthous.Entities.Environment + (GroundMessage(..), Door(..), unlockedDoor, Staircase(..)) +import Xanthous.Messages (message_) +import Xanthous.Util.Graphics (circle) +-------------------------------------------------------------------------------- + +chooseCharacterPosition :: MonadRandom m => Cells -> m Position +chooseCharacterPosition = randomPosition + +randomItems :: MonadRandom m => Cells -> m (EntityMap Item) +randomItems = randomEntities Item.newWithType (0.0004, 0.001) + +placeDownStaircase :: MonadRandom m => Cells -> m (EntityMap Staircase) +placeDownStaircase cells = do + pos <- randomPosition cells + pure $ _EntityMap # [(pos, DownStaircase)] + +randomDoors :: MonadRandom m => Cells -> m (EntityMap Door) +randomDoors cells = do + doorRatio <- getRandomR subsetRange + let numDoors = floor $ doorRatio * fromIntegral (length candidateCells) + doorPositions = + removeAdjacent . fmap positionFromPair . take numDoors $ candidateCells + doors = zip doorPositions $ repeat unlockedDoor + pure $ _EntityMap # doors + where + removeAdjacent = + foldr (\pos acc -> + if pos `elem` (acc >>= toList . neighborPositions) + then acc + else pos : acc + ) [] + candidateCells = filter doorable $ Arr.indices cells + subsetRange = (0.8 :: Double, 1.0) + doorable pos = + not (fromMaybe True $ cells ^? ix pos) + && any (teeish . fmap (fromMaybe True)) + (rotations $ arrayNeighbors cells pos) + -- only generate doors at the *ends* of hallways, eg (where O is walkable, + -- X is a wall, and D is a door): + -- + -- O O O + -- X D X + -- O + teeish (fmap not -> (Neighbors tl t tr l r _ b _ )) = + and [tl, t, tr, b] && (and . fmap not) [l, r] + +randomCreatures :: MonadRandom m => Cells -> m (EntityMap Creature) +randomCreatures = randomEntities Creature.newWithType (0.0007, 0.002) + +tutorialMessage :: MonadRandom m + => Cells + -> Position -- ^ CharacterPosition + -> m (EntityMap GroundMessage) +tutorialMessage cells characterPosition = do + let distance = 2 + pos <- fmap (fromMaybe (error "No valid positions for tutorial message?")) + . choose . ChooseElement + $ accessiblePositionsWithin distance cells characterPosition + msg <- message_ ["tutorial", "message1"] + pure $ _EntityMap # [(pos, GroundMessage msg)] + where + accessiblePositionsWithin :: Int -> Cells -> Position -> [Position] + accessiblePositionsWithin dist valid pos = + review _Position + <$> filter (\(px, py) -> not $ valid ! (fromIntegral px, fromIntegral py)) + (circle (pos ^. _Position) dist) + +randomEntities + :: forall entity raw m. (MonadRandom m, RawType raw) + => (raw -> entity) + -> (Float, Float) + -> Cells + -> m (EntityMap entity) +randomEntities newWithType sizeRange cells = + case fromNullable $ rawsWithType @raw of + Nothing -> pure mempty + Just raws -> do + let len = rangeSize $ bounds cells + (numEntities :: Int) <- + floor . (* fromIntegral len) <$> getRandomR sizeRange + entities <- for [0..numEntities] $ const $ do + pos <- randomPosition cells + raw <- choose raws + let entity = newWithType raw + pure (pos, entity) + pure $ _EntityMap # entities + +randomPosition :: MonadRandom m => Cells -> m Position +randomPosition = fmap positionFromPair . choose . impureNonNull . cellCandidates + +-- cellCandidates :: Cells -> Cells +cellCandidates :: Cells -> Set (Word, Word) +cellCandidates + -- find the largest contiguous region of cells in the cave. + = maximumBy (compare `on` length) + . fromMaybe (error "No regions generated! this should never happen.") + . fromNullable + . regions + -- cells ends up with true = wall, we want true = can put an item here + . amap not diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs b/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs new file mode 100644 index 0000000000..cdac568e40 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +-------------------------------------------------------------------------------- +module Xanthous.Generators.Util + ( MCells + , Cells + , CellM + , randInitialize + , initializeEmpty + , numAliveNeighborsM + , numAliveNeighbors + , fillOuterEdgesM + , cloneMArray + , floodFill + , regions + , fillAll + , fillAllM + , fromPoints + , fromPointsM + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (Foldable, toList, for_) +import Data.Array.ST +import Data.Array.Unboxed +import Control.Monad.ST +import Control.Monad.Random +import Data.Monoid +import Data.Foldable (Foldable, toList, for_) +import qualified Data.Set as Set +import Data.Semigroup.Foldable +-------------------------------------------------------------------------------- +import Xanthous.Util (foldlMapM', maximum1, minimum1) +import Xanthous.Data (Dimensions, width, height) +-------------------------------------------------------------------------------- + +type MCells s = STUArray s (Word, Word) Bool +type Cells = UArray (Word, Word) Bool +type CellM g s a = RandT g (ST s) a + +randInitialize :: RandomGen g => Dimensions -> Double -> CellM g s (MCells s) +randInitialize dims aliveChance = do + res <- initializeEmpty dims + for_ [0..dims ^. width] $ \i -> + for_ [0..dims ^. height] $ \j -> do + val <- (>= aliveChance) <$> getRandomR (0, 1) + lift $ writeArray res (i, j) val + pure res + +initializeEmpty :: RandomGen g => Dimensions -> CellM g s (MCells s) +initializeEmpty dims = + lift $ newArray ((0, 0), (dims ^. width, dims ^. height)) False + +numAliveNeighborsM + :: forall a i j m + . (MArray a Bool m, Ix (i, j), Integral i, Integral j) + => a (i, j) Bool + -> (i, j) + -> m Word +numAliveNeighborsM cells (x, y) = do + cellBounds <- getBounds cells + getSum <$> foldlMapM' + (fmap (Sum . fromIntegral . fromEnum) . boundedGet cellBounds) + neighborPositions + + where + boundedGet :: ((i, j), (i, j)) -> (Int, Int) -> m Bool + boundedGet ((minX, minY), (maxX, maxY)) (i, j) + | x <= minX + || y <= minY + || x >= maxX + || y >= maxY + = pure True + | otherwise = + let nx = fromIntegral $ fromIntegral x + i + ny = fromIntegral $ fromIntegral y + j + in readArray cells (nx, ny) + + neighborPositions :: [(Int, Int)] + neighborPositions = [(i, j) | i <- [-1..1], j <- [-1..1], (i, j) /= (0, 0)] + +numAliveNeighbors + :: forall a i j + . (IArray a Bool, Ix (i, j), Integral i, Integral j) + => a (i, j) Bool + -> (i, j) + -> Word +numAliveNeighbors cells (x, y) = + let cellBounds = bounds cells + in getSum $ foldMap + (Sum . fromIntegral . fromEnum . boundedGet cellBounds) + neighborPositions + + where + boundedGet :: ((i, j), (i, j)) -> (Int, Int) -> Bool + boundedGet ((minX, minY), (maxX, maxY)) (i, j) + | x <= minX + || y <= minY + || x >= maxX + || y >= maxY + = True + | otherwise = + let nx = fromIntegral $ fromIntegral x + i + ny = fromIntegral $ fromIntegral y + j + in cells ! (nx, ny) + + neighborPositions :: [(Int, Int)] + neighborPositions = [(i, j) | i <- [-1..1], j <- [-1..1], (i, j) /= (0, 0)] + +fillOuterEdgesM :: (MArray a Bool m, Ix i, Ix j) => a (i, j) Bool -> m () +fillOuterEdgesM arr = do + ((minX, minY), (maxX, maxY)) <- getBounds arr + for_ (range (minX, maxX)) $ \x -> do + writeArray arr (x, minY) True + writeArray arr (x, maxY) True + for_ (range (minY, maxY)) $ \y -> do + writeArray arr (minX, y) True + writeArray arr (maxX, y) True + +cloneMArray + :: forall a a' i e m. + ( Ix i + , MArray a e m + , MArray a' e m + , IArray UArray e + ) + => a i e + -> m (a' i e) +cloneMArray = thaw @_ @UArray <=< freeze + +-------------------------------------------------------------------------------- + +-- | Flood fill a cell array starting at a point, returning a list of all the +-- (true) cell locations reachable from that point +floodFill :: forall a i j. + ( IArray a Bool + , Ix (i, j) + , Enum i , Enum j + , Bounded i , Bounded j + , Eq i , Eq j + , Show i, Show j + ) + => a (i, j) Bool -- ^ array + -> (i, j) -- ^ position + -> Set (i, j) +floodFill = go mempty + where + go :: Set (i, j) -> a (i, j) Bool -> (i, j) -> Set (i, j) + -- TODO pass result in rather than passing seen in, return result + go res arr@(bounds -> arrBounds) idx@(x, y) + | not (inRange arrBounds idx) = res + | not (arr ! idx) = res + | otherwise = + let neighbors + = filter (inRange arrBounds) + . filter (/= idx) + . filter (`notMember` res) + $ (,) + <$> [(if x == minBound then x else pred x) + .. + (if x == maxBound then x else succ x)] + <*> [(if y == minBound then y else pred y) + .. + (if y == maxBound then y else succ y)] + in foldl' (\r idx' -> + if arr ! idx' + then r <> go (r & contains idx' .~ True) arr idx' + else r) + (res & contains idx .~ True) neighbors + +-- | Gives a list of all the disconnected regions in a cell array, represented +-- each as lists of points +regions :: forall a i j. + ( IArray a Bool + , Ix (i, j) + , Enum i , Enum j + , Bounded i , Bounded j + , Eq i , Eq j + , Show i, Show j + ) + => a (i, j) Bool + -> [Set (i, j)] +regions arr + | Just firstPoint <- findFirstPoint arr = + let region = floodFill arr firstPoint + arr' = fillAll region arr + in region : regions arr' + | otherwise = [] + where + findFirstPoint :: a (i, j) Bool -> Maybe (i, j) + findFirstPoint = fmap fst . headMay . filter snd . assocs + +fillAll :: (IArray a Bool, Ix i, Foldable f) => f i -> a i Bool -> a i Bool +fillAll ixes a = accum (const fst) a $ (, (False, ())) <$> toList ixes + +fillAllM :: (MArray a Bool m, Ix i, Foldable f) => f i -> a i Bool -> m () +fillAllM ixes a = for_ ixes $ \i -> writeArray a i False + +fromPoints + :: forall a f i. + ( IArray a Bool + , Ix i + , Functor f + , Foldable1 f + ) + => f (i, i) + -> a (i, i) Bool +fromPoints points = + let pts = Set.fromList $ toList points + dims = ( (minimum1 $ fst <$> points, minimum1 $ snd <$> points) + , (maximum1 $ fst <$> points, maximum1 $ snd <$> points) + ) + in array dims $ range dims <&> \i -> (i, i `member` pts) + +fromPointsM + :: (MArray a Bool m, Ix i, Element f ~ i, MonoFoldable f) + => NonNull f + -> m (a i Bool) +fromPointsM points = do + arr <- newArray (minimum points, maximum points) False + fillAllM (otoList points) arr + pure arr diff --git a/users/glittershark/xanthous/src/Xanthous/Messages.hs b/users/glittershark/xanthous/src/Xanthous/Messages.hs new file mode 100644 index 0000000000..2b1b3da1e8 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Messages.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Messages + ( Message(..) + , resolve + , MessageMap(..) + , lookupMessage + + -- * Game messages + , messages + , render + , lookup + , message + , message_ + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (lookup) +-------------------------------------------------------------------------------- +import Control.Monad.Random.Class (MonadRandom) +import Data.Aeson (FromJSON, ToJSON, toJSON) +import qualified Data.Aeson as JSON +import Data.Aeson.Generic.DerivingVia +import Data.FileEmbed +import Data.List.NonEmpty +import Test.QuickCheck hiding (choose) +import Test.QuickCheck.Arbitrary.Generic +import Test.QuickCheck.Instances.UnorderedContainers () +import Text.Mustache +import qualified Data.Yaml as Yaml +-------------------------------------------------------------------------------- +import Xanthous.Random +import Xanthous.Orphans () +-------------------------------------------------------------------------------- + +data Message = Single Template | Choice (NonEmpty Template) + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (CoArbitrary, Function, NFData) + deriving (ToJSON, FromJSON) + via WithOptions '[ SumEnc UntaggedVal ] + Message + +instance Arbitrary Message where + arbitrary = genericArbitrary + shrink = genericShrink + +resolve :: MonadRandom m => Message -> m Template +resolve (Single t) = pure t +resolve (Choice ts) = choose ts + +data MessageMap = Direct Message | Nested (HashMap Text MessageMap) + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (CoArbitrary, Function, NFData) + deriving (ToJSON, FromJSON) + via WithOptions '[ SumEnc UntaggedVal ] + MessageMap + +instance Arbitrary MessageMap where + arbitrary = frequency [ (10, Direct <$> arbitrary) + , (1, Nested <$> arbitrary) + ] + +lookupMessage :: [Text] -> MessageMap -> Maybe Message +lookupMessage [] (Direct msg) = Just msg +lookupMessage (k:ks) (Nested m) = lookupMessage ks =<< m ^. at k +lookupMessage _ _ = Nothing + +type instance Index MessageMap = [Text] +type instance IxValue MessageMap = Message +instance Ixed MessageMap where + ix [] f (Direct msg) = Direct <$> f msg + ix (k:ks) f (Nested m) = case m ^. at k of + Just m' -> ix ks f m' <&> \m'' -> + Nested $ m & at k ?~ m'' + Nothing -> pure $ Nested m + ix _ _ m = pure m + +-------------------------------------------------------------------------------- + +rawMessages :: ByteString +rawMessages = $(embedFile "src/Xanthous/messages.yaml") + +messages :: MessageMap +messages + = either (error . Yaml.prettyPrintParseException) id + $ Yaml.decodeEither' rawMessages + +render :: (MonadRandom m, ToJSON params) => Message -> params -> m Text +render msg params = do + tpl <- resolve msg + pure . toStrict . renderMustache tpl $ toJSON params + +lookup :: [Text] -> Message +lookup path = fromMaybe notFound $ messages ^? ix path + where notFound + = Single + $ compileMustacheText "template" "Message not found" + ^?! _Right + +message :: (MonadRandom m, ToJSON params) => [Text] -> params -> m Text +message path params = maybe notFound (`render` params) $ messages ^? ix path + where + notFound = pure "Message not found" + +message_ :: (MonadRandom m) => [Text] -> m Text +message_ path = maybe notFound (`render` JSON.object []) $ messages ^? ix path + where + notFound = pure "Message not found" diff --git a/users/glittershark/xanthous/src/Xanthous/Messages/Template.hs b/users/glittershark/xanthous/src/Xanthous/Messages/Template.hs new file mode 100644 index 0000000000..0f47729d68 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Messages/Template.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE DeriveDataTypeable #-} +-------------------------------------------------------------------------------- +module Xanthous.Messages.Template + ( -- * Template AST + Template(..) + , Substitution(..) + , Filter(..) + + -- ** Template AST transformations + , reduceTemplate + + -- * Template parser + , template + , runParser + , errorBundlePretty + + -- * Template pretty-printer + , ppTemplate + + -- * Rendering templates + , TemplateVar(..) + , nested + , TemplateVars(..) + , vars + , RenderError + , render + ) +where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding + (many, concat, try, elements, some, parts) +-------------------------------------------------------------------------------- +import Test.QuickCheck hiding (label) +import Test.QuickCheck.Instances.Text () +import Test.QuickCheck.Instances.Semigroup () +import Test.QuickCheck.Checkers (EqProp) +import Control.Monad.Combinators.NonEmpty +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Data +import Text.Megaparsec hiding (sepBy1, some) +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L +import Data.Function (fix) +-------------------------------------------------------------------------------- +import Xanthous.Util (EqEqProp(..)) +-------------------------------------------------------------------------------- + +genIdentifier :: Gen Text +genIdentifier = pack <$> listOf1 (elements identifierChars) + +identifierChars :: String +identifierChars = ['a'..'z'] <> ['A'..'Z'] <> ['-', '_'] + +newtype Filter = FilterName Text + deriving stock (Show, Eq, Ord, Generic, Data) + deriving anyclass (NFData) + deriving (IsString) via Text + +instance Arbitrary Filter where + arbitrary = FilterName <$> genIdentifier + shrink (FilterName fn) = fmap FilterName . filter (not . null) $ shrink fn + +data Substitution + = SubstPath (NonEmpty Text) + | SubstFilter Substitution Filter + deriving stock (Show, Eq, Ord, Generic, Data) + deriving anyclass (NFData) + +instance Arbitrary Substitution where + arbitrary = sized . fix $ \gen n -> + let leaves = + [ SubstPath <$> ((:|) <$> genIdentifier <*> listOf genIdentifier)] + subtree = gen $ n `div` 2 + in if n == 0 + then oneof leaves + else oneof $ leaves <> [ SubstFilter <$> subtree <*> arbitrary ] + shrink (SubstPath pth) = + fmap SubstPath + . filter (not . any ((||) <$> null <*> any (`notElem` identifierChars))) + $ shrink pth + shrink (SubstFilter s f) + = shrink s + <> (uncurry SubstFilter <$> shrink (s, f)) + +data Template + = Literal Text + | Subst Substitution + | Concat Template Template + deriving stock (Show, Generic, Data) + deriving anyclass (NFData) + deriving EqProp via EqEqProp Template + +instance Plated Template where + plate _ tpl@(Literal _) = pure tpl + plate _ tpl@(Subst _) = pure tpl + plate f (Concat tpl₁ tpl₂) = Concat <$> f tpl₁ <*> f tpl₂ + +reduceTemplate :: Template -> Template +reduceTemplate = transform $ \case + (Concat (Literal t₁) (Literal t₂)) -> Literal (t₁ <> t₂) + (Concat (Literal "") t) -> t + (Concat t (Literal "")) -> t + (Concat t₁ (Concat t₂ t₃)) -> Concat (Concat t₁ t₂) t₃ + (Concat (Concat t₁ (Literal t₂)) (Literal t₃)) -> (Concat t₁ (Literal $ t₂ <> t₃)) + t -> t + +instance Eq Template where + tpl₁ == tpl₂ = case (reduceTemplate tpl₁, reduceTemplate tpl₂) of + (Literal t₁, Literal t₂) -> t₁ == t₂ + (Subst s₁, Subst s₂) -> s₁ == s₂ + (Concat ta₁ ta₂, Concat tb₁ tb₂) -> ta₁ == tb₁ && ta₂ == tb₂ + _ -> False + +instance Arbitrary Template where + arbitrary = sized . fix $ \gen n -> + let leaves = [ Literal . filter (`notElem` ['\\', '{']) <$> arbitrary + , Subst <$> arbitrary + ] + subtree = gen $ n `div` 2 + genConcat = Concat <$> subtree <*> subtree + in if n == 0 + then oneof leaves + else oneof $ genConcat : leaves + shrink (Literal t) = Literal <$> shrink t + shrink (Subst s) = Subst <$> shrink s + shrink (Concat t₁ t₂) + = shrink t₁ + <> shrink t₂ + <> (Concat <$> shrink t₁ <*> shrink t₂) + +instance Semigroup Template where + (<>) = Concat + +instance Monoid Template where + mempty = Literal "" + +-------------------------------------------------------------------------------- + +type Parser = Parsec Void Text + +sc :: Parser () +sc = L.space space1 empty empty + +lexeme :: Parser a -> Parser a +lexeme = L.lexeme sc + +symbol :: Text -> Parser Text +symbol = L.symbol sc + +identifier :: Parser Text +identifier = lexeme . label "identifier" $ do + firstChar <- letterChar <|> oneOf ['-', '_'] + restChars <- many $ alphaNumChar <|> oneOf ['-', '_'] + pure $ firstChar <| pack restChars + +filterName :: Parser Filter +filterName = FilterName <$> identifier + +substitutionPath :: Parser Substitution +substitutionPath = SubstPath <$> sepBy1 identifier (char '.') + +substitutionFilter :: Parser Substitution +substitutionFilter = do + path <- substitutionPath + fs <- some $ symbol "|" *> filterName + pure $ foldl' SubstFilter path fs + -- pure $ SubstFilter path f + +substitutionContents :: Parser Substitution +substitutionContents + = try substitutionFilter + <|> substitutionPath + +substitution :: Parser Substitution +substitution = between (string "{{") (string "}}") substitutionContents + +literal :: Parser Template +literal = Literal <$> + ( (string "\\{" $> "{") + <|> takeWhile1P Nothing (`notElem` ['\\', '{']) + ) + +subst :: Parser Template +subst = Subst <$> substitution + +template' :: Parser Template +template' = do + parts <- many $ literal <|> subst + pure $ foldr Concat (Literal "") parts + + +template :: Parser Template +template = reduceTemplate <$> template' <* eof + +-------------------------------------------------------------------------------- + +ppSubstitution :: Substitution -> Text +ppSubstitution (SubstPath substParts) = intercalate "." substParts +ppSubstitution (SubstFilter s (FilterName f)) = ppSubstitution s <> " | " <> f + +ppTemplate :: Template -> Text +ppTemplate (Literal txt) = txt +ppTemplate (Subst s) = "{{" <> ppSubstitution s <> "}}" +ppTemplate (Concat tpl₁ tpl₂) = ppTemplate tpl₁ <> ppTemplate tpl₂ + +-------------------------------------------------------------------------------- + +data TemplateVar + = Val Text + | Nested (Map Text TemplateVar) + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) + +nested :: [(Text, TemplateVar)] -> TemplateVar +nested = Nested . mapFromList + +instance Arbitrary TemplateVar where + arbitrary = sized . fix $ \gen n -> + let nst = fmap mapFromList . listOf $ (,) <$> arbitrary <*> gen (n `div` 2) + in if n == 0 + then Val <$> arbitrary + else oneof [ Val <$> arbitrary + , Nested <$> nst] + +newtype TemplateVars = Vars { getTemplateVars :: Map Text TemplateVar } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) + deriving (Arbitrary) via (Map Text TemplateVar) + +type instance Index TemplateVars = Text +type instance IxValue TemplateVars = TemplateVar +instance Ixed TemplateVars where + ix k f (Vars vs) = Vars <$> ix k f vs +instance At TemplateVars where + at k f (Vars vs) = Vars <$> at k f vs + +vars :: [(Text, TemplateVar)] -> TemplateVars +vars = Vars . mapFromList + +lookupVar :: TemplateVars -> NonEmpty Text -> Maybe TemplateVar +lookupVar vs (p :| []) = vs ^. at p +lookupVar vs (p :| (p₁ : ps)) = vs ^. at p >>= \case + (Val _) -> Nothing + (Nested vs') -> lookupVar (Vars vs') $ p₁ :| ps + +data RenderError + = NoSuchVariable (NonEmpty Text) + | NestedFurther (NonEmpty Text) + | NoSuchFilter Filter + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) + +renderSubst + :: Map Filter (Text -> Text) -- ^ Filters + -> TemplateVars + -> Substitution + -> Either RenderError Text +renderSubst _ vs (SubstPath pth) = + case lookupVar vs pth of + Just (Val v) -> Right v + Just (Nested _) -> Left $ NestedFurther pth + Nothing -> Left $ NoSuchVariable pth +renderSubst fs vs (SubstFilter s fn) = + case fs ^. at fn of + Just filterFn -> filterFn <$> renderSubst fs vs s + Nothing -> Left $ NoSuchFilter fn + +render + :: Map Filter (Text -> Text) -- ^ Filters + -> TemplateVars -- ^ Template variables + -> Template -- ^ Template + -> Either RenderError Text +render _ _ (Literal s) = pure s +render fs vs (Concat t₁ t₂) = (<>) <$> render fs vs t₁ <*> render fs vs t₂ +render fs vs (Subst s) = renderSubst fs vs s diff --git a/users/glittershark/xanthous/src/Xanthous/Monad.hs b/users/glittershark/xanthous/src/Xanthous/Monad.hs new file mode 100644 index 0000000000..db602de56f --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Monad.hs @@ -0,0 +1,76 @@ +-------------------------------------------------------------------------------- +module Xanthous.Monad + ( AppT(..) + , AppM + , runAppT + , continue + , halt + + -- * Messages + , say + , say_ + , message + , message_ + , writeMessage + + -- * Autocommands + , cancelAutocommand + + -- * Events + , sendEvent + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +import Control.Monad.Random +import Control.Monad.State +import qualified Brick +import Brick (EventM, Next) +import Brick.BChan (writeBChan) +import Data.Aeson (ToJSON, object) +-------------------------------------------------------------------------------- +import Xanthous.Data.App (AppEvent) +import Xanthous.Game.State +import Xanthous.Game.Env +import Xanthous.Messages (Message) +import qualified Xanthous.Messages as Messages +-------------------------------------------------------------------------------- + +halt :: AppT (EventM n) (Next GameState) +halt = lift . Brick.halt =<< get + +continue :: AppT (EventM n) (Next GameState) +continue = lift . Brick.continue =<< get + +-------------------------------------------------------------------------------- + +say :: (MonadRandom m, ToJSON params, MonadState GameState m) + => [Text] -> params -> m () +say msgPath = writeMessage <=< Messages.message msgPath + +say_ :: (MonadRandom m, MonadState GameState m) => [Text] -> m () +say_ msgPath = say msgPath $ object [] + +message :: (MonadRandom m, ToJSON params, MonadState GameState m) + => Message -> params -> m () +message msg = writeMessage <=< Messages.render msg + +message_ :: (MonadRandom m, MonadState GameState m) + => Message -> m () +message_ msg = message msg $ object [] + +writeMessage :: MonadState GameState m => Text -> m () +writeMessage m = messageHistory %= pushMessage m + +-- | Cancel the currently active autocommand, if any +cancelAutocommand :: (MonadState GameState m, MonadIO m) => m () +cancelAutocommand = do + traverse_ (liftIO . cancel . snd) =<< preuse (autocommand . _ActiveAutocommand) + autocommand .= NoAutocommand + +-------------------------------------------------------------------------------- + +-- | Send an event to the app in an environment where the game env is available +sendEvent :: (MonadReader GameEnv m, MonadIO m) => AppEvent -> m () +sendEvent evt = do + ec <- view eventChan + liftIO $ writeBChan ec evt diff --git a/users/glittershark/xanthous/src/Xanthous/Orphans.hs b/users/glittershark/xanthous/src/Xanthous/Orphans.hs new file mode 100644 index 0000000000..8e82c372b2 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Orphans.hs @@ -0,0 +1,345 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wno-orphans #-} +-------------------------------------------------------------------------------- +module Xanthous.Orphans + ( ppTemplate + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (elements, (.=)) +-------------------------------------------------------------------------------- +import Data.Aeson +import Data.Aeson.Types (typeMismatch) +import Data.List.NonEmpty (NonEmpty(..)) +import Graphics.Vty.Attributes +import Brick.Widgets.Edit +import Data.Text.Zipper.Generic (GenericTextZipper) +import Brick.Widgets.Core (getName) +import System.Random (StdGen) +import Test.QuickCheck +import "quickcheck-instances" Test.QuickCheck.Instances () +import Text.Megaparsec (errorBundlePretty) +import Text.Megaparsec.Pos +import Text.Mustache +import Text.Mustache.Type ( showKey ) +import Control.Monad.State +import Linear +-------------------------------------------------------------------------------- +import Xanthous.Util.JSON +import Xanthous.Util.QuickCheck +-------------------------------------------------------------------------------- + +instance forall s a. + ( Cons s s a a + , IsSequence s + , Element s ~ a + ) => Cons (NonNull s) (NonNull s) a a where + _Cons = prism hither yon + where + hither :: (a, NonNull s) -> NonNull s + hither (a, ns) = + let s = toNullable ns + in impureNonNull $ a <| s + + yon :: NonNull s -> Either (NonNull s) (a, NonNull s) + yon ns = case nuncons ns of + (_, Nothing) -> Left ns + (x, Just xs) -> Right (x, xs) + +instance forall a. Cons (NonEmpty a) (NonEmpty a) a a where + _Cons = prism hither yon + where + hither :: (a, NonEmpty a) -> NonEmpty a + hither (a, x :| xs) = a :| (x : xs) + + yon :: NonEmpty a -> Either (NonEmpty a) (a, NonEmpty a) + yon ns@(x :| xs) = case xs of + (y : ys) -> Right (x, y :| ys) + [] -> Left ns + + +instance Arbitrary PName where + arbitrary = PName . pack <$> listOf1 (elements ['a'..'z']) + +instance Arbitrary Key where + arbitrary = Key <$> listOf1 arbSafeText + where arbSafeText = pack <$> listOf1 (elements ['a'..'z']) + shrink (Key []) = error "unreachable" + shrink k@(Key [_]) = pure k + shrink (Key (p:ps)) = Key . (p :) <$> shrink ps + +instance Arbitrary Pos where + arbitrary = mkPos . succ . abs <$> arbitrary + shrink (unPos -> 1) = [] + shrink (unPos -> x) = mkPos <$> [x..1] + +instance Arbitrary Node where + arbitrary = sized node + where + node n | n > 0 = oneof $ leaves ++ branches (n `div` 2) + node _ = oneof leaves + branches n = + [ Section <$> arbitrary <*> subnodes n + , InvertedSection <$> arbitrary <*> subnodes n + ] + subnodes = fmap concatTextBlocks . listOf . node + leaves = + [ TextBlock . pack <$> listOf1 (elements ['a'..'z']) + , EscapedVar <$> arbitrary + , UnescapedVar <$> arbitrary + -- TODO fix pretty-printing of mustache partials + -- , Partial <$> arbitrary <*> arbitrary + ] + shrink = genericShrink + +concatTextBlocks :: [Node] -> [Node] +concatTextBlocks [] = [] +concatTextBlocks [x] = [x] +concatTextBlocks (TextBlock txt₁ : TextBlock txt₂ : xs) + = concatTextBlocks $ TextBlock (txt₁ <> txt₂) : concatTextBlocks xs +concatTextBlocks (x : xs) = x : concatTextBlocks xs + +instance Arbitrary Template where + arbitrary = do + template <- concatTextBlocks <$> arbitrary + -- templateName <- arbitrary + -- rest <- arbitrary + let templateName = "template" + rest = mempty + pure $ Template + { templateActual = templateName + , templateCache = rest & at templateName ?~ template + } + shrink (Template actual cache) = + let Just tpl = cache ^. at actual + in do + cache' <- shrink cache + tpl' <- shrink tpl + actual' <- shrink actual + pure $ Template + { templateActual = actual' + , templateCache = cache' & at actual' ?~ tpl' + } + +instance CoArbitrary Template where + coarbitrary = coarbitrary . ppTemplate + +instance Function Template where + function = functionMap ppTemplate parseTemplatePartial + where + parseTemplatePartial txt + = compileMustacheText "template" txt ^?! _Right + +ppNode :: Map PName [Node] -> Node -> Text +ppNode _ (TextBlock txt) = txt +ppNode _ (EscapedVar k) = "{{" <> showKey k <> "}}" +ppNode ctx (Section k body) = + let sk = showKey k + in "{{#" <> sk <> "}}" <> foldMap (ppNode ctx) body <> "{{/" <> sk <> "}}" +ppNode _ (UnescapedVar k) = "{{{" <> showKey k <> "}}}" +ppNode ctx (InvertedSection k body) = + let sk = showKey k + in "{{^" <> sk <> "}}" <> foldMap (ppNode ctx) body <> "{{/" <> sk <> "}}" +ppNode _ (Partial n _) = "{{> " <> unPName n <> "}}" + +ppTemplate :: Template -> Text +ppTemplate (Template actual cache) = + case cache ^. at actual of + Nothing -> error "Template not found?" + Just nodes -> foldMap (ppNode cache) nodes + +instance ToJSON Template where + toJSON = String . ppTemplate + +instance FromJSON Template where + parseJSON + = withText "Template" + $ either (fail . errorBundlePretty) pure + . compileMustacheText "template" + +deriving anyclass instance NFData Node +deriving anyclass instance NFData Template + +instance FromJSON Color where + parseJSON (String "black") = pure black + parseJSON (String "red") = pure red + parseJSON (String "green") = pure green + parseJSON (String "yellow") = pure yellow + parseJSON (String "blue") = pure blue + parseJSON (String "magenta") = pure magenta + parseJSON (String "cyan") = pure cyan + parseJSON (String "white") = pure white + parseJSON (String "brightBlack") = pure brightBlack + parseJSON (String "brightRed") = pure brightRed + parseJSON (String "brightGreen") = pure brightGreen + parseJSON (String "brightYellow") = pure brightYellow + parseJSON (String "brightBlue") = pure brightBlue + parseJSON (String "brightMagenta") = pure brightMagenta + parseJSON (String "brightCyan") = pure brightCyan + parseJSON (String "brightWhite") = pure brightWhite + parseJSON n@(Number _) = Color240 <$> parseJSON n + parseJSON x = typeMismatch "Color" x + +instance ToJSON Color where + toJSON color + | color == black = "black" + | color == red = "red" + | color == green = "green" + | color == yellow = "yellow" + | color == blue = "blue" + | color == magenta = "magenta" + | color == cyan = "cyan" + | color == white = "white" + | color == brightBlack = "brightBlack" + | color == brightRed = "brightRed" + | color == brightGreen = "brightGreen" + | color == brightYellow = "brightYellow" + | color == brightBlue = "brightBlue" + | color == brightMagenta = "brightMagenta" + | color == brightCyan = "brightCyan" + | color == brightWhite = "brightWhite" + | Color240 num <- color = toJSON num + | otherwise = error $ "unimplemented: " <> show color + +instance (Eq a, Show a, Read a, FromJSON a) => FromJSON (MaybeDefault a) where + parseJSON Null = pure Default + parseJSON (String "keepCurrent") = pure KeepCurrent + parseJSON x = SetTo <$> parseJSON x + +instance ToJSON a => ToJSON (MaybeDefault a) where + toJSON Default = Null + toJSON KeepCurrent = String "keepCurrent" + toJSON (SetTo x) = toJSON x + +-------------------------------------------------------------------------------- + +instance Arbitrary Color where + arbitrary = oneof [ Color240 <$> choose (0, 239) + , ISOColor <$> choose (0, 15) + ] + +deriving anyclass instance CoArbitrary Color +deriving anyclass instance Function Color + +instance (Eq a, Show a, Read a, Arbitrary a) => Arbitrary (MaybeDefault a) where + arbitrary = oneof [ pure Default + , pure KeepCurrent + , SetTo <$> arbitrary + ] + +instance CoArbitrary a => CoArbitrary (MaybeDefault a) where + coarbitrary Default = variant @Int 1 + coarbitrary KeepCurrent = variant @Int 2 + coarbitrary (SetTo x) = variant @Int 3 . coarbitrary x + +instance (Eq a, Show a, Read a, Function a) => Function (MaybeDefault a) where + function = functionShow + +instance Arbitrary Attr where + arbitrary = do + attrStyle <- arbitrary + attrForeColor <- arbitrary + attrBackColor <- arbitrary + attrURL <- arbitrary + pure Attr {..} + +deriving anyclass instance CoArbitrary Attr +deriving anyclass instance Function Attr + +instance ToJSON Attr where + toJSON Attr{..} = object + [ "style" .= maybeDefaultToJSONWith styleToJSON attrStyle + , "foreground" .= attrForeColor + , "background" .= attrBackColor + , "url" .= attrURL + ] + where + maybeDefaultToJSONWith _ Default = Null + maybeDefaultToJSONWith _ KeepCurrent = String "keepCurrent" + maybeDefaultToJSONWith tj (SetTo x) = tj x + styleToJSON style + | style == standout = "standout" + | style == underline = "underline" + | style == reverseVideo = "reverseVideo" + | style == blink = "blink" + | style == dim = "dim" + | style == bold = "bold" + | style == italic = "italic" + | otherwise = toJSON style + +instance FromJSON Attr where + parseJSON = withObject "Attr" $ \obj -> do + attrStyle <- parseStyle =<< obj .:? "style" .!= Default + attrForeColor <- obj .:? "foreground" .!= Default + attrBackColor <- obj .:? "background" .!= Default + attrURL <- obj .:? "url" .!= Default + pure Attr{..} + + where + parseStyle (SetTo (String "standout")) = pure (SetTo standout) + parseStyle (SetTo (String "underline")) = pure (SetTo underline) + parseStyle (SetTo (String "reverseVideo")) = pure (SetTo reverseVideo) + parseStyle (SetTo (String "blink")) = pure (SetTo blink) + parseStyle (SetTo (String "dim")) = pure (SetTo dim) + parseStyle (SetTo (String "bold")) = pure (SetTo bold) + parseStyle (SetTo (String "italic")) = pure (SetTo italic) + parseStyle (SetTo n@(Number _)) = SetTo <$> parseJSON n + parseStyle (SetTo v) = typeMismatch "Style" v + parseStyle Default = pure Default + parseStyle KeepCurrent = pure KeepCurrent + +deriving stock instance Ord Color +deriving stock instance Ord a => Ord (MaybeDefault a) +deriving stock instance Ord Attr + +-------------------------------------------------------------------------------- + +instance NFData a => NFData (NonNull a) where + rnf xs = xs `seq` toNullable xs `deepseq` () + +instance forall t name. (NFData t, Monoid t, NFData name) + => NFData (Editor t name) where + rnf ed = getName @_ @name ed `deepseq` getEditContents ed `deepseq` () + +instance NFData StdGen where + -- StdGen's fields are bang-patterned so this is actually correct! + rnf sg = sg `seq` () + +deriving via (ReadShowJSON StdGen) instance ToJSON StdGen +deriving via (ReadShowJSON StdGen) instance FromJSON StdGen + +instance Function StdGen where + function = functionShow + +-------------------------------------------------------------------------------- + +instance CoArbitrary a => CoArbitrary (NonNull a) where + coarbitrary = coarbitrary . toNullable + +instance (MonoFoldable a, Function a) => Function (NonNull a) where + function = functionMap toNullable $ fromMaybe (error "null") . fromNullable + +instance (Arbitrary t, Arbitrary n, GenericTextZipper t) + => Arbitrary (Editor t n) where + arbitrary = editor <$> arbitrary <*> arbitrary <*> arbitrary + +instance forall t n. (CoArbitrary t, CoArbitrary n, Monoid t) + => CoArbitrary (Editor t n) where + coarbitrary ed = coarbitrary (getName @_ @n ed, getEditContents ed) + +instance CoArbitrary StdGen where + coarbitrary = coarbitrary . show + +-------------------------------------------------------------------------------- + +deriving newtype instance (Arbitrary s, CoArbitrary (m (a, s))) + => CoArbitrary (StateT s m a) + +-------------------------------------------------------------------------------- + +deriving via (GenericArbitrary (V2 a)) instance Arbitrary a => Arbitrary (V2 a) +instance CoArbitrary a => CoArbitrary (V2 a) +instance Function a => Function (V2 a) diff --git a/users/glittershark/xanthous/src/Xanthous/Prelude.hs b/users/glittershark/xanthous/src/Xanthous/Prelude.hs new file mode 100644 index 0000000000..9a4ca0149f --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Prelude.hs @@ -0,0 +1,36 @@ +-------------------------------------------------------------------------------- +module Xanthous.Prelude + ( module ClassyPrelude + , Type + , Constraint + , module GHC.TypeLits + , module Control.Lens + , module Data.Void + , module Control.Comonad + + + -- * Classy-Prelude addons + , ninsertSet + , ndeleteSet + , toVector + ) where +-------------------------------------------------------------------------------- +import ClassyPrelude hiding + (return, (<|), unsnoc, uncons, cons, snoc, index, (<.>), Index, say) +import Data.Kind +import GHC.TypeLits hiding (Text) +import Control.Lens hiding (levels, Level) +import Data.Void +import Control.Comonad +-------------------------------------------------------------------------------- + +ninsertSet + :: (IsSet set, MonoPointed set) + => Element set -> NonNull set -> NonNull set +ninsertSet x xs = impureNonNull $ opoint x `union` toNullable xs + +ndeleteSet :: IsSet b => Element b -> NonNull b -> b +ndeleteSet x = deleteSet x . toNullable + +toVector :: (MonoFoldable (f a), Element (f a) ~ a) => f a -> Vector a +toVector = fromList . toList diff --git a/users/glittershark/xanthous/src/Xanthous/Random.hs b/users/glittershark/xanthous/src/Xanthous/Random.hs new file mode 100644 index 0000000000..41c80ab73c --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Random.hs @@ -0,0 +1,102 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-------------------------------------------------------------------------------- +module Xanthous.Random + ( Choose(..) + , ChooseElement(..) + , Weighted(..) + , evenlyWeighted + , weightedBy + , subRand + , chance + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Data.List.NonEmpty (NonEmpty(..)) +import Control.Monad.Random.Class (MonadRandom(getRandomR, getRandom)) +import Control.Monad.Random (Rand, evalRand, mkStdGen, StdGen) +import Data.Random.Shuffle.Weighted +import Data.Random.Distribution +import Data.Random.Distribution.Uniform +import Data.Random.Distribution.Uniform.Exclusive +import Data.Random.Sample +import qualified Data.Random.Source as DRS +-------------------------------------------------------------------------------- + +instance {-# INCOHERENT #-} (Monad m, MonadRandom m) => DRS.MonadRandom m where + getRandomWord8 = getRandom + getRandomWord16 = getRandom + getRandomWord32 = getRandom + getRandomWord64 = getRandom + getRandomDouble = getRandom + getRandomNByteInteger n = getRandomR (0, 256 ^ n) + +class Choose a where + type RandomResult a + choose :: MonadRandom m => a -> m (RandomResult a) + +newtype ChooseElement a = ChooseElement a + +instance MonoFoldable a => Choose (ChooseElement a) where + type RandomResult (ChooseElement a) = Maybe (Element a) + choose (ChooseElement xs) = do + chosenIdx <- getRandomR (0, olength xs - 1) + let pick _ (Just x) = Just x + pick (x, i) Nothing + | i == chosenIdx = Just x + | otherwise = Nothing + pure $ ofoldr pick Nothing $ zip (toList xs) [0..] + +instance MonoFoldable a => Choose (NonNull a) where + type RandomResult (NonNull a) = Element a + choose + = fmap (fromMaybe (error "unreachable")) -- why not lol + . choose + . ChooseElement + . toNullable + +instance Choose (NonEmpty a) where + type RandomResult (NonEmpty a) = a + choose = choose . fromNonEmpty @[_] + +instance Choose (a, a) where + type RandomResult (a, a) = a + choose (x, y) = choose (x :| [y]) + +newtype Weighted w t a = Weighted (t (w, a)) + +evenlyWeighted :: [a] -> Weighted Int [] a +evenlyWeighted = Weighted . itoList + +weightedBy :: Functor t => (a -> w) -> t a -> Weighted w t a +weightedBy weighting xs = Weighted $ (weighting &&& id) <$> xs + +instance (Num w, Ord w, Distribution Uniform w, Excludable w) => Choose (Weighted w [] a) where + type RandomResult (Weighted w [] a) = Maybe a + choose (Weighted ws) = sample $ headMay <$> weightedSample 1 ws + +instance (Num w, Ord w, Distribution Uniform w, Excludable w) => Choose (Weighted w NonEmpty a) where + type RandomResult (Weighted w NonEmpty a) = a + choose (Weighted ws) = + sample + $ fromMaybe (error "unreachable") . headMay + <$> weightedSample 1 (toList ws) + +subRand :: MonadRandom m => Rand StdGen a -> m a +subRand sub = evalRand sub . mkStdGen <$> getRandom + +-- | Has a @n@ chance of returning 'True' +-- +-- eg, chance 0.5 will return 'True' half the time +chance + :: (Num w, Ord w, Distribution Uniform w, Excludable w, MonadRandom m) + => w + -> m Bool +chance n = choose $ weightedBy (bool 1 (n * 2)) bools + +-------------------------------------------------------------------------------- + +bools :: NonEmpty Bool +bools = True :| [False] diff --git a/users/glittershark/xanthous/src/Xanthous/Util.hs b/users/glittershark/xanthous/src/Xanthous/Util.hs new file mode 100644 index 0000000000..524ad4819d --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Util.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE QuantifiedConstraints #-} +-------------------------------------------------------------------------------- +module Xanthous.Util + ( EqEqProp(..) + , EqProp(..) + , foldlMapM + , foldlMapM' + , between + + , appendVia + + -- * Foldable + -- ** Uniqueness + -- *** Predicates on uniqueness + , isUniqueOf + , isUnique + -- *** Removing all duplicate elements in n * log n time + , uniqueOf + , unique + -- *** Removing sequentially duplicate elements in linear time + , uniqOf + , uniq + -- ** Bag sequence algorithms + , takeWhileInclusive + , smallestNotIn + , removeVectorIndex + , maximum1 + , minimum1 + + -- * Combinators + , times, times_ + + -- * Type-level programming utils + , KnownBool(..) + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (foldr) +-------------------------------------------------------------------------------- +import Test.QuickCheck.Checkers +import Data.Foldable (foldr) +import Data.Monoid +import Data.Proxy +import qualified Data.Vector as V +import Data.Semigroup (Max(..), Min(..)) +import Data.Semigroup.Foldable +-------------------------------------------------------------------------------- + +newtype EqEqProp a = EqEqProp a + deriving newtype Eq + +instance Eq a => EqProp (EqEqProp a) where + (=-=) = eq + +foldlMapM :: forall g b a m. (Foldable g, Monoid b, Applicative m) => (a -> m b) -> g a -> m b +foldlMapM f = foldr f' (pure mempty) + where + f' :: a -> m b -> m b + f' x = liftA2 mappend (f x) + +-- Strict in the monoidal accumulator. For monads strict +-- in the left argument of bind, this will run in constant +-- space. +foldlMapM' :: forall g b a m. (Foldable g, Monoid b, Monad m) => (a -> m b) -> g a -> m b +foldlMapM' f xs = foldr f' pure xs mempty + where + f' :: a -> (b -> m b) -> b -> m b + f' x k bl = do + br <- f x + let !b = mappend bl br + k b + +between + :: Ord a + => a -- ^ lower bound + -> a -- ^ upper bound + -> a -- ^ scrutinee + -> Bool +between lower upper x = x >= lower && x <= upper + +-- | +-- >>> appendVia Sum 1 2 +-- 3 +appendVia :: (Rewrapping s t, Semigroup s) => (Unwrapped s -> s) -> Unwrapped s -> Unwrapped s -> Unwrapped s +appendVia wrap x y = op wrap $ wrap x <> wrap y + +-------------------------------------------------------------------------------- + +-- | Returns True if the targets of the given 'Fold' are unique per the 'Ord' instance for @a@ +-- +-- >>> isUniqueOf (folded . _1) ([(1, 2), (2, 2), (3, 2)] :: [(Int, Int)]) +-- True +-- +-- >>> isUniqueOf (folded . _2) ([(1, 2), (2, 2), (3, 2)] :: [(Int, Int)]) +-- False +-- +-- @ +-- 'isUniqueOf' :: Ord a => 'Getter' s a -> s -> 'Bool' +-- 'isUniqueOf' :: Ord a => 'Fold' s a -> s -> 'Bool' +-- 'isUniqueOf' :: Ord a => 'Lens'' s a -> s -> 'Bool' +-- 'isUniqueOf' :: Ord a => 'Iso'' s a -> s -> 'Bool' +-- 'isUniqueOf' :: Ord a => 'Traversal'' s a -> s -> 'Bool' +-- 'isUniqueOf' :: Ord a => 'Prism'' s a -> s -> 'Bool' +-- @ +isUniqueOf :: Ord a => Getting (Endo (Set a, Bool)) s a -> s -> Bool +isUniqueOf aFold = orOf _2 . foldrOf aFold rejectUnique (mempty, True) + where + rejectUnique x (seen, acc) + | seen ^. contains x = (seen, False) + | otherwise = (seen & contains x .~ True, acc) + +-- | Returns true if the given 'Foldable' container contains only unique +-- elements, as determined by the 'Ord' instance for @a@ +-- +-- >>> isUnique ([3, 1, 2] :: [Int]) +-- True +-- +-- >>> isUnique ([1, 1, 2, 2, 3, 1] :: [Int]) +-- False +isUnique :: (Foldable f, Ord a) => f a -> Bool +isUnique = isUniqueOf folded + + +-- | O(n * log n). Returns a monoidal, 'Cons'able container (a list, a Set, +-- etc.) consisting of the unique (per the 'Ord' instance for @a@) targets of +-- the given 'Fold' +-- +-- >>> uniqueOf (folded . _2) ([(1, 2), (2, 2), (3, 2), (4, 3)] :: [(Int, Int)]) :: [Int] +-- [2,3] +-- +-- @ +-- 'uniqueOf' :: Ord a => 'Getter' s a -> s -> [a] +-- 'uniqueOf' :: Ord a => 'Fold' s a -> s -> [a] +-- 'uniqueOf' :: Ord a => 'Lens'' s a -> s -> [a] +-- 'uniqueOf' :: Ord a => 'Iso'' s a -> s -> [a] +-- 'uniqueOf' :: Ord a => 'Traversal'' s a -> s -> [a] +-- 'uniqueOf' :: Ord a => 'Prism'' s a -> s -> [a] +-- @ +uniqueOf + :: (Monoid c, Ord w, Cons c c w w) => Getting (Endo (Set w, c)) a w -> a -> c +uniqueOf aFold = snd . foldrOf aFold rejectUnique (mempty, mempty) + where + rejectUnique x (seen, acc) + | seen ^. contains x = (seen, acc) + | otherwise = (seen & contains x .~ True, cons x acc) + +-- | Returns a monoidal, 'Cons'able container (a list, a Set, etc.) consisting +-- of the unique (per the 'Ord' instance for @a@) contents of the given +-- 'Foldable' container +-- +-- >>> unique [1, 1, 2, 2, 3, 1] :: [Int] +-- [2,3,1] + +-- >>> unique [1, 1, 2, 2, 3, 1] :: Set Int +-- fromList [3,2,1] +unique :: (Foldable f, Cons c c a a, Ord a, Monoid c) => f a -> c +unique = uniqueOf folded + +-------------------------------------------------------------------------------- + +-- | O(n). Returns a monoidal, 'Cons'able container (a list, a Vector, etc.) +-- consisting of the targets of the given 'Fold' with sequential duplicate +-- elements removed +-- +-- This function (sorry for the confusing name) differs from 'uniqueOf' in that +-- it only compares /sequentially/ duplicate elements (and thus operates in +-- linear time). +-- cf 'Data.Vector.uniq' and POSIX @uniq@ for the name +-- +-- >>> uniqOf (folded . _2) ([(1, 2), (2, 2), (3, 1), (4, 2)] :: [(Int, Int)]) :: [Int] +-- [2,1,2] +-- +-- @ +-- 'uniqOf' :: Eq a => 'Getter' s a -> s -> [a] +-- 'uniqOf' :: Eq a => 'Fold' s a -> s -> [a] +-- 'uniqOf' :: Eq a => 'Lens'' s a -> s -> [a] +-- 'uniqOf' :: Eq a => 'Iso'' s a -> s -> [a] +-- 'uniqOf' :: Eq a => 'Traversal'' s a -> s -> [a] +-- 'uniqOf' :: Eq a => 'Prism'' s a -> s -> [a] +-- @ +uniqOf :: (Monoid c, Cons c c w w, Eq w) => Getting (Endo (Maybe w, c)) a w -> a -> c +uniqOf aFold = snd . foldrOf aFold rejectSeen (Nothing, mempty) + where + rejectSeen x (Nothing, acc) = (Just x, x <| acc) + rejectSeen x tup@(Just a, acc) + | x == a = tup + | otherwise = (Just x, x <| acc) + +-- | O(n). Returns a monoidal, 'Cons'able container (a list, a Vector, etc.) +-- consisting of the targets of the given 'Foldable' container with sequential +-- duplicate elements removed +-- +-- This function (sorry for the confusing name) differs from 'unique' in that +-- it only compares /sequentially/ unique elements (and thus operates in linear +-- time). +-- cf 'Data.Vector.uniq' and POSIX @uniq@ for the name +-- +-- >>> uniq [1, 1, 1, 2, 2, 2, 3, 3, 1] :: [Int] +-- [1,2,3,1] +-- +-- >>> uniq [1, 1, 1, 2, 2, 2, 3, 3, 1] :: Vector Int +-- [1,2,3,1] +-- +uniq :: (Foldable f, Eq a, Cons c c a a, Monoid c) => f a -> c +uniq = uniqOf folded + +-- | Like 'takeWhile', but inclusive +takeWhileInclusive :: (a -> Bool) -> [a] -> [a] +takeWhileInclusive _ [] = [] +takeWhileInclusive p (x:xs) = x : if p x then takeWhileInclusive p xs else [] + +-- | Returns the smallest value not in a list +smallestNotIn :: (Ord a, Bounded a, Enum a) => [a] -> a +smallestNotIn xs = case uniq $ sort xs of + [] -> minBound + xs'@(x : _) + | x > minBound -> minBound + | otherwise + -> snd . headEx . filter (uncurry (/=)) $ zip (xs' ++ [minBound]) [minBound..] + +-- | Remove the element at the given index, if any, from the given vector +removeVectorIndex :: Int -> Vector a -> Vector a +removeVectorIndex idx vect = + let (before, after) = V.splitAt idx vect + in before <> fromMaybe Empty (tailMay after) + +maximum1 :: (Ord a, Foldable1 f) => f a -> a +maximum1 = getMax . foldMap1 Max + +minimum1 :: (Ord a, Foldable1 f) => f a -> a +minimum1 = getMin . foldMap1 Min + +times :: (Applicative f, Num n, Enum n) => n -> (n -> f b) -> f [b] +times n f = traverse f [1..n] + +times_ :: (Applicative f, Num n, Enum n) => n -> f a -> f [a] +times_ n fa = times n (const fa) + +-------------------------------------------------------------------------------- + +-- | This class gives a boolean associated with a type-level bool, a'la +-- 'KnownSymbol', 'KnownNat' etc. +class KnownBool (bool :: Bool) where + boolVal' :: forall proxy. proxy bool -> Bool + boolVal' _ = boolVal @bool + + boolVal :: Bool + boolVal = boolVal' $ Proxy @bool + +instance KnownBool 'True where boolVal = True +instance KnownBool 'False where boolVal = False diff --git a/users/glittershark/xanthous/src/Xanthous/Util/Comonad.hs b/users/glittershark/xanthous/src/Xanthous/Util/Comonad.hs new file mode 100644 index 0000000000..9e158cc8e2 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Util/Comonad.hs @@ -0,0 +1,24 @@ +-------------------------------------------------------------------------------- +module Xanthous.Util.Comonad + ( -- * Store comonad utils + replace + , current + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Control.Comonad.Store.Class +-------------------------------------------------------------------------------- + +-- | Replace the current position of a store comonad with a new value by +-- comparing positions +replace :: (Eq i, ComonadStore i w) => w a -> a -> w a +replace w x = w =>> \w' -> if pos w' == pos w then x else extract w' +{-# INLINE replace #-} + +-- | Lens into the current position of a store comonad. +-- +-- current = lens extract replace +current :: (Eq i, ComonadStore i w) => Lens' (w a) a +current = lens extract replace +{-# INLINE current #-} diff --git a/users/glittershark/xanthous/src/Xanthous/Util/Graph.hs b/users/glittershark/xanthous/src/Xanthous/Util/Graph.hs new file mode 100644 index 0000000000..8e5c04f4bf --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Util/Graph.hs @@ -0,0 +1,33 @@ +-------------------------------------------------------------------------------- +module Xanthous.Util.Graph where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Data.Graph.Inductive.Query.MST (msTree) +import qualified Data.Graph.Inductive.Graph as Graph +import Data.Graph.Inductive.Graph +import Data.Graph.Inductive.Basic (undir) +import Data.Set (isSubsetOf) +-------------------------------------------------------------------------------- + +mstSubGraph + :: forall gr node edge. (DynGraph gr, Real edge, Show edge) + => gr node edge -> gr node edge +mstSubGraph graph = insEdges mstEdges . insNodes (labNodes graph) $ Graph.empty + where + mstEdges = ordNub $ do + LP path <- msTree $ undir graph + case path of + [] -> [] + [_] -> [] + ((n₂, edgeWeight) : (n₁, _) : _) -> + pure (n₁, n₂, edgeWeight) + +isSubGraphOf + :: (Graph gr1, Graph gr2, Ord node, Ord edge) + => gr1 node edge + -> gr2 node edge + -> Bool +isSubGraphOf graph₁ graph₂ + = setFromList (labNodes graph₁) `isSubsetOf` setFromList (labNodes graph₂) + && setFromList (labEdges graph₁) `isSubsetOf` setFromList (labEdges graph₂) diff --git a/users/glittershark/xanthous/src/Xanthous/Util/Graphics.hs b/users/glittershark/xanthous/src/Xanthous/Util/Graphics.hs new file mode 100644 index 0000000000..5f7432f4c7 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Util/Graphics.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | Graphics algorithms and utils for rendering things in 2D space +-------------------------------------------------------------------------------- +module Xanthous.Util.Graphics + ( circle + , filledCircle + , line + , straightLine + , delaunay + + -- * Debugging and testing tools + , renderBooleanGraphics + , showBooleanGraphics + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +-- https://github.com/noinia/hgeometry/issues/28 +-- import qualified Algorithms.Geometry.DelaunayTriangulation.DivideAndConquer +-- as Geometry +import qualified Algorithms.Geometry.DelaunayTriangulation.Naive + as Geometry +import qualified Algorithms.Geometry.DelaunayTriangulation.Types as Geometry +import Control.Monad.State (execState, State) +import qualified Data.Geometry.Point as Geometry +import Data.Ext ((:+)(..)) +import Data.List (unfoldr) +import Data.List.NonEmpty (NonEmpty((:|))) +import qualified Data.List.NonEmpty as NE +import Data.Ix (Ix) +import Linear.V2 +-------------------------------------------------------------------------------- + + +-- | Generate a circle centered at the given point and with the given radius +-- using the <midpoint circle algorithm +-- https://en.wikipedia.org/wiki/Midpoint_circle_algorithm>. +-- +-- Code taken from <https://rosettacode.org/wiki/Bitmap/Midpoint_circle_algorithm#Haskell> +circle :: (Num i, Ord i) + => (i, i) -- ^ center + -> i -- ^ radius + -> [(i, i)] +circle (x₀, y₀) radius + -- Four initial points, plus the generated points + = (x₀, y₀ + radius) : (x₀, y₀ - radius) : (x₀ + radius, y₀) : (x₀ - radius, y₀) : points + where + -- Creates the (x, y) octet offsets, then maps them to absolute points in all octets. + points = concatMap generatePoints $ unfoldr step initialValues + + generatePoints (x, y) + = [ (x₀ `xop` x', y₀ `yop` y') + | (x', y') <- [(x, y), (y, x)] + , xop <- [(+), (-)] + , yop <- [(+), (-)] + ] + + initialValues = (1 - radius, 1, (-2) * radius, 0, radius) + + step (f, ddf_x, ddf_y, x, y) + | x >= y = Nothing + | otherwise = Just ((x', y'), (f', ddf_x', ddf_y', x', y')) + where + (f', ddf_y', y') | f >= 0 = (f + ddf_y' + ddf_x', ddf_y + 2, y - 1) + | otherwise = (f + ddf_x, ddf_y, y) + ddf_x' = ddf_x + 2 + x' = x + 1 + + +data FillState i + = FillState + { _inCircle :: Bool + , _result :: NonEmpty (i, i) + } +makeLenses ''FillState + +runFillState :: NonEmpty (i, i) -> State (FillState i) a -> [(i, i)] +runFillState circumference s + = toList + . view result + . execState s + $ FillState False circumference + +-- | Generate a *filled* circle centered at the given point and with the given +-- radius by filling a circle generated with 'circle' +filledCircle :: (Num i, Integral i, Ix i) + => (i, i) -- ^ center + -> i -- ^ radius + -> [(i, i)] +filledCircle origin radius = + case NE.nonEmpty (circle origin radius) of + Nothing -> [] + Just circumference -> runFillState circumference $ + -- the first and last lines of all circles are solid, so the whole "in the + -- circle, out of the circle" thing doesn't work... but that's fine since + -- we don't need to fill them. So just skip them + for_ [succ minX..pred maxX] $ \x -> + for_ [minY..maxY] $ \y -> do + let pt = (x, y) + next = (x, succ y) + whenM (use inCircle) $ result %= NE.cons pt + + when (pt `elem` circumference && next `notElem` circumference) + $ inCircle %= not + + where + ((minX, minY), (maxX, maxY)) = minmaxes circumference + +-- | Draw a line between two points using Bresenham's line drawing algorithm +-- +-- Code taken from <https://wiki.haskell.org/Bresenham%27s_line_drawing_algorithm> +line :: (Num i, Ord i) => (i, i) -> (i, i) -> [(i, i)] +line pa@(xa, ya) pb@(xb, yb) + = (if maySwitch pa < maySwitch pb then id else reverse) points + where + points = map maySwitch . unfoldr go $ (x₁, y₁, 0) + steep = abs (yb - ya) > abs (xb - xa) + maySwitch = if steep then swap else id + [(x₁, y₁), (x₂, y₂)] = sort [maySwitch pa, maySwitch pb] + δx = x₂ - x₁ + δy = abs (y₂ - y₁) + ystep = if y₁ < y₂ then 1 else -1 + go (xTemp, yTemp, err) + | xTemp > x₂ = Nothing + | otherwise = Just ((xTemp, yTemp), (xTemp + 1, newY, newError)) + where + tempError = err + δy + (newY, newError) = if (2 * tempError) >= δx + then (yTemp + ystep, tempError - δx) + else (yTemp, tempError) + +straightLine :: (Num i, Ord i) => (i, i) -> (i, i) -> [(i, i)] +straightLine pa@(xa, _) pb@(_, yb) = line pa midpoint ++ line midpoint pb + where midpoint = (xa, yb) + + +delaunay + :: (Ord n, Fractional n) + => NonEmpty (V2 n, p) + -> [((V2 n, p), (V2 n, p))] +delaunay + = map (over both fromPoint) + . Geometry.triangulationEdges + . Geometry.delaunayTriangulation + . map toPoint + where + toPoint (V2 px py, pid) = Geometry.Point2 px py :+ pid + fromPoint (Geometry.Point2 px py :+ pid) = (V2 px py, pid) + +-------------------------------------------------------------------------------- + +renderBooleanGraphics :: forall i. (Num i, Ord i, Enum i) => [(i, i)] -> String +renderBooleanGraphics [] = "" +renderBooleanGraphics (pt : pts') = intercalate "\n" rows + where + rows = row <$> [minX..maxX] + row x = [minY..maxY] <&> \y -> if (x, y) `member` ptSet then 'X' else ' ' + ((minX, minY), (maxX, maxY)) = minmaxes pts + pts = pt :| pts' + ptSet :: Set (i, i) + ptSet = setFromList $ toList pts + +showBooleanGraphics :: forall i. (Num i, Ord i, Enum i) => [(i, i)] -> IO () +showBooleanGraphics = putStrLn . pack . renderBooleanGraphics + +minmaxes :: forall i. (Ord i) => NonEmpty (i, i) -> ((i, i), (i, i)) +minmaxes xs = + ( ( minimum1Of (traverse1 . _1) xs + , minimum1Of (traverse1 . _2) xs + ) + , ( maximum1Of (traverse1 . _1) xs + , maximum1Of (traverse1 . _2) xs + ) + ) diff --git a/users/glittershark/xanthous/src/Xanthous/Util/Inflection.hs b/users/glittershark/xanthous/src/Xanthous/Util/Inflection.hs new file mode 100644 index 0000000000..724f2339dd --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Util/Inflection.hs @@ -0,0 +1,14 @@ + +module Xanthous.Util.Inflection + ( toSentence + ) where + +import Xanthous.Prelude + +toSentence :: (MonoFoldable mono, Element mono ~ Text) => mono -> Text +toSentence xs = case reverse . toList $ xs of + [] -> "" + [x] -> x + [b, a] -> a <> " and " <> b + (final : butlast) -> + intercalate ", " (reverse butlast) <> ", and " <> final diff --git a/users/glittershark/xanthous/src/Xanthous/Util/JSON.hs b/users/glittershark/xanthous/src/Xanthous/Util/JSON.hs new file mode 100644 index 0000000000..91d1328e4a --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Util/JSON.hs @@ -0,0 +1,19 @@ +-------------------------------------------------------------------------------- +module Xanthous.Util.JSON + ( ReadShowJSON(..) + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Data.Aeson +-------------------------------------------------------------------------------- + +newtype ReadShowJSON a = ReadShowJSON a + deriving newtype (Read, Show) + +instance Show a => ToJSON (ReadShowJSON a) where + toJSON = toJSON . show + +instance Read a => FromJSON (ReadShowJSON a) where + parseJSON = withText "readable" + $ maybe (fail "Could not read") pure . readMay diff --git a/users/glittershark/xanthous/src/Xanthous/Util/Optparse.hs b/users/glittershark/xanthous/src/Xanthous/Util/Optparse.hs new file mode 100644 index 0000000000..dfa6537235 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Util/Optparse.hs @@ -0,0 +1,21 @@ +-------------------------------------------------------------------------------- +module Xanthous.Util.Optparse + ( readWithGuard + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import qualified Options.Applicative as Opt +-------------------------------------------------------------------------------- + +readWithGuard + :: Read b + => (b -> Bool) + -> (b -> String) + -> Opt.ReadM b +readWithGuard predicate errmsg = do + res <- Opt.auto + unless (predicate res) + $ Opt.readerError + $ errmsg res + pure res diff --git a/users/glittershark/xanthous/src/Xanthous/Util/QuickCheck.hs b/users/glittershark/xanthous/src/Xanthous/Util/QuickCheck.hs new file mode 100644 index 0000000000..be12bc2945 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Util/QuickCheck.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE UndecidableInstances #-} +module Xanthous.Util.QuickCheck + ( functionShow + , FunctionShow(..) + , functionJSON + , FunctionJSON(..) + , genericArbitrary + , GenericArbitrary(..) + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +import Test.QuickCheck +import Test.QuickCheck.Function +import Test.QuickCheck.Instances.ByteString () +import Test.QuickCheck.Arbitrary.Generic +import Data.Aeson +import GHC.Generics (Rep) +-------------------------------------------------------------------------------- + +newtype FunctionShow a = FunctionShow a + deriving newtype (Show, Read) + +instance (Show a, Read a) => Function (FunctionShow a) where + function = functionShow + +functionJSON :: (ToJSON a, FromJSON a) => (a -> c) -> a :-> c +functionJSON = functionMap encode (headEx . decode) + +newtype FunctionJSON a = FunctionJSON a + deriving newtype (ToJSON, FromJSON) + +instance (ToJSON a, FromJSON a) => Function (FunctionJSON a) where + function = functionJSON + +-------------------------------------------------------------------------------- + +newtype GenericArbitrary a = GenericArbitrary a + deriving newtype Generic + +instance (Generic a, GArbitrary rep, Rep a ~ rep) + => Arbitrary (GenericArbitrary a) where + arbitrary = genericArbitrary diff --git a/users/glittershark/xanthous/src/Xanthous/messages.yaml b/users/glittershark/xanthous/src/Xanthous/messages.yaml new file mode 100644 index 0000000000..c1835ef232 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/messages.yaml @@ -0,0 +1,120 @@ +welcome: Welcome to Xanthous, {{characterName}}! It's dangerous out there, why not stay inside? Use hjklybnu to move. +dead: + - You have died... + - You die... + - You perish... + - You have perished... + +generic: + continue: Press enter to continue... + +save: + location: "Enter filename to save to: " + overwrite: "A file named {{filename}} already exists. Would you like to overwrite it? " + +quit: + confirm: Really quit without saving? + +entities: + description: You see here {{entityDescriptions}} + +pickUp: + menu: What would you like to pick up? + pickUp: You pick up the {{item.itemType.name}} + nothingToPickUp: "There's nothing here to pick up" + +cant: + goUp: + - You can't go up here + - There's nothing here that would let you go up + goDown: + - You can't go down here + - There's nothing here that would let you go down + +open: + prompt: Direction to open (hjklybnu.)? + success: "You open the door." + locked: "That door is locked" + nothingToOpen: "There's nothing to open there." + alreadyOpen: "That door is already open." + +close: + prompt: Direction to close (hjklybnu.)? + success: + - You close the door. + - You shut the door. + nothingToClose: "There's nothing to close there." + alreadyClosed: "That door is already closed." + blocked: "The {{entityDescriptions}} {{blockOrBlocks}} the door!" + +look: + prompt: Select a position on the map to describe (use Enter to confirm) + nothing: There's nothing there + +character: + namePrompt: "What's your name? " + +combat: + nothingToAttack: There's nothing to attack there. + menu: Which creature would you like to attack? + fistSelfDamage: + - You hit so hard with your fists you hurt yourself! + - The punch leaves your knuckles bloody! + hit: + fists: + - You punch the {{creature.creatureType.name}} with your bare fists! It hurts. A lot. + - You strike the {{creature.creatureType.name}} with your bare fists! It leaves a bit of a bruise on your knuckles. + generic: + - You hit the {{creature.creatureType.name}}. + - You attack the {{creature.creatureType.name}}. + creatureAttack: + - The {{creature.creatureType.name}} hits you! + - The {{creature.creatureType.name}} attacks you! + killed: + - You kill the {{creature.creatureType.name}}! + - You've killed the {{creature.creatureType.name}}! + +debug: + toggleRevealAll: revealAll now set to {{revealAll}} + +eat: + noFood: + - You have nothing edible. + - You don't have any food. + - You don't have anything to eat. + - You search your pockets for something edible, and come up short. + menuPrompt: What would you like to eat? + eat: You eat the {{item.itemType.name}}. + +read: + prompt: Direction to read (hjklybnu.)? + nothing: "There's nothing there to read" + result: "\"{{message}}\"" + +wield: + nothing: + - You aren't carrying anything you can wield + - You can't wield anything in your backpack + - You can't wield anything currently in your backpack + menu: What would you like to wield? + # TODO: use actual hands + wielded : You wield the {{wieldedItem.itemType.name}} in your right hand. + +drop: + nothing: You aren't carrying anything + menu: What would you like to drop? + # TODO: use actual hands + dropped: + - You drop the {{item.itemType.name}}. + - You drop the {{item.itemType.name}} on the ground. + - You put the {{item.itemType.name}} on the ground. + - You take the {{item.itemType.name}} out of your backpack and put it on the ground. + - You take the {{item.itemType.name}} out of your backpack and drop it on the ground. + +autoMove: + enemyInSight: + - There's a {{firstEntity.creatureType.name}} nearby! +### + +tutorial: + message1: The caves are dark and full of nightmarish creatures - and you are likely to perish without food. Seek out sustenance! You can pick items up with ,. diff --git a/users/glittershark/xanthous/test/Spec.hs b/users/glittershark/xanthous/test/Spec.hs new file mode 100644 index 0000000000..b7004b4f89 --- /dev/null +++ b/users/glittershark/xanthous/test/Spec.hs @@ -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 + ] diff --git a/users/glittershark/xanthous/test/Test/Prelude.hs b/users/glittershark/xanthous/test/Test/Prelude.hs new file mode 100644 index 0000000000..c423796184 --- /dev/null +++ b/users/glittershark/xanthous/test/Test/Prelude.hs @@ -0,0 +1,19 @@ +module Test.Prelude + ( module Xanthous.Prelude + , module Test.Tasty + , module Test.Tasty.HUnit + , module Test.Tasty.QuickCheck + , module Test.QuickCheck.Classes + , testBatch + ) where + +import Xanthous.Prelude hiding (assert, elements) +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.Tasty.HUnit +import Test.QuickCheck.Classes +import Test.QuickCheck.Checkers (TestBatch) +import Test.QuickCheck.Instances.ByteString () + +testBatch :: TestBatch -> TestTree +testBatch (name, tests) = testGroup name $ uncurry testProperty <$> tests diff --git a/users/glittershark/xanthous/test/Xanthous/Data/EntitiesSpec.hs b/users/glittershark/xanthous/test/Xanthous/Data/EntitiesSpec.hs new file mode 100644 index 0000000000..e403503743 --- /dev/null +++ b/users/glittershark/xanthous/test/Xanthous/Data/EntitiesSpec.hs @@ -0,0 +1,28 @@ +-------------------------------------------------------------------------------- +module Xanthous.Data.EntitiesSpec (main, test) where +-------------------------------------------------------------------------------- +import Test.Prelude +-------------------------------------------------------------------------------- +import qualified Data.Aeson as JSON +-------------------------------------------------------------------------------- +import Xanthous.Data.Entities +-------------------------------------------------------------------------------- + +main :: IO () +main = defaultMain test + +test :: TestTree +test = testGroup "Xanthous.Data.Entities" + [ testGroup "Collision" + [ testProperty "JSON round-trip" $ \(c :: Collision) -> + JSON.decode (JSON.encode c) === Just c + , testGroup "JSON encoding examples" + [ testCase "Stop" $ JSON.encode Stop @?= "\"Stop\"" + , testCase "Combat" $ JSON.encode Combat @?= "\"Combat\"" + ] + ] + , testGroup "EntityAttributes" + [ testProperty "JSON round-trip" $ \(ea :: EntityAttributes) -> + JSON.decode (JSON.encode ea) === Just ea + ] + ] diff --git a/users/glittershark/xanthous/test/Xanthous/Data/EntityCharSpec.hs b/users/glittershark/xanthous/test/Xanthous/Data/EntityCharSpec.hs new file mode 100644 index 0000000000..9e8024c9d2 --- /dev/null +++ b/users/glittershark/xanthous/test/Xanthous/Data/EntityCharSpec.hs @@ -0,0 +1,18 @@ +-------------------------------------------------------------------------------- +module Xanthous.Data.EntityCharSpec where +-------------------------------------------------------------------------------- +import Test.Prelude +-------------------------------------------------------------------------------- +import qualified Data.Aeson as JSON +-------------------------------------------------------------------------------- +import Xanthous.Data.EntityChar +-------------------------------------------------------------------------------- + +main :: IO () +main = defaultMain test + +test :: TestTree +test = testGroup "Xanthous.Data.EntityChar" + [ testProperty "JSON round-trip" $ \(ec :: EntityChar) -> + JSON.decode (JSON.encode ec) === Just ec + ] diff --git a/users/glittershark/xanthous/test/Xanthous/Data/EntityMap/GraphicsSpec.hs b/users/glittershark/xanthous/test/Xanthous/Data/EntityMap/GraphicsSpec.hs new file mode 100644 index 0000000000..fd37548ce8 --- /dev/null +++ b/users/glittershark/xanthous/test/Xanthous/Data/EntityMap/GraphicsSpec.hs @@ -0,0 +1,57 @@ +-------------------------------------------------------------------------------- +module Xanthous.Data.EntityMap.GraphicsSpec (main, test) where +-------------------------------------------------------------------------------- +import Test.Prelude +import Data.Aeson +-------------------------------------------------------------------------------- +import Xanthous.Game.State +import Xanthous.Data +import Xanthous.Data.EntityMap +import Xanthous.Data.EntityMap.Graphics +import Xanthous.Entities.Environment (Wall(..)) +-------------------------------------------------------------------------------- + +main :: IO () +main = defaultMain test + +test :: TestTree +test = testGroup "Xanthous.Data.EntityMap.Graphics" + [ testGroup "visiblePositions" + [ testProperty "one step in each cardinal direction is always visible" + $ \pos (Cardinal dir) (Positive r) (wallPositions :: Set Position)-> + pos `notMember` wallPositions ==> + let em = review _EntityMap . map (, Wall) . toList $ wallPositions + em' = em & atPosition (move dir pos) %~ (Wall <|) + poss = visiblePositions pos r em' + in counterexample ("visiblePositions: " <> show poss) + $ move dir pos `member` poss + , testGroup "bugs" + [ testCase "non-contiguous bug 1" + $ let charPos = Position 20 20 + gormlakPos = Position 17 19 + em = insertAt gormlakPos TestEntity + . insertAt charPos TestEntity + $ mempty + visPositions = visiblePositions charPos 12 em + in (gormlakPos `member` visPositions) @? + ( "not (" + <> show gormlakPos <> " `member` " + <> show visPositions + <> ")" + ) + ] + ] + ] + +-------------------------------------------------------------------------------- + +data TestEntity = TestEntity + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (ToJSON, FromJSON, NFData) + +instance Brain TestEntity where + step _ = pure +instance Draw TestEntity +instance Entity TestEntity where + description _ = "" + entityChar _ = "e" diff --git a/users/glittershark/xanthous/test/Xanthous/Data/EntityMapSpec.hs b/users/glittershark/xanthous/test/Xanthous/Data/EntityMapSpec.hs new file mode 100644 index 0000000000..7c5cad0196 --- /dev/null +++ b/users/glittershark/xanthous/test/Xanthous/Data/EntityMapSpec.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE ApplicativeDo #-} +-------------------------------------------------------------------------------- +module Xanthous.Data.EntityMapSpec where +-------------------------------------------------------------------------------- +import Test.Prelude +-------------------------------------------------------------------------------- +import qualified Data.Aeson as JSON +-------------------------------------------------------------------------------- +import Xanthous.Data.EntityMap +import Xanthous.Data (Positioned(..)) +-------------------------------------------------------------------------------- + +main :: IO () +main = defaultMain test + +test :: TestTree +test = localOption (QuickCheckTests 20) + $ testGroup "Xanthous.Data.EntityMap" + [ testBatch $ monoid @(EntityMap Int) mempty + , testGroup "Deduplicate" + [ testGroup "Semigroup laws" + [ testProperty "associative" $ \(a :: Deduplicate (EntityMap Int)) b c -> + a <> (b <> c) === (a <> b) <> c + ] + ] + , testGroup "Eq laws" + [ testProperty "reflexivity" $ \(em :: EntityMap Int) -> + em == em + , testProperty "symmetric" $ \(em₁ :: EntityMap Int) em₂ -> + (em₁ == em₂) == (em₂ == em₁) + , testProperty "transitive" $ \(em₁ :: EntityMap Int) em₂ em₃ -> + if (em₁ == em₂ && em₂ == em₃) + then (em₁ == em₃) + else True + ] + , testGroup "JSON encoding/decoding" + [ testProperty "round-trips" $ \(em :: EntityMap Int) -> + let em' = JSON.decode (JSON.encode em) + in counterexample (show (em' ^? _Just . lastID, em ^. lastID + , em' ^? _Just . byID == em ^. byID . re _Just + , em' ^? _Just . byPosition == em ^. byPosition . re _Just + , em' ^? _Just . _EntityMap == em ^. _EntityMap . re _Just + )) + $ em' === Just em + , testProperty "Preserves IDs" $ \(em :: EntityMap Int) -> + let Just em' = JSON.decode $ JSON.encode em + in toEIDsAndPositioned em' === toEIDsAndPositioned em + ] + + , localOption (QuickCheckTests 50) + $ testGroup "atPosition" + [ testProperty "setget" $ \pos (em :: EntityMap Int) es -> + view (atPosition pos) (set (atPosition pos) es em) === es + , testProperty "getset" $ \pos (em :: EntityMap Int) -> + set (atPosition pos) (view (atPosition pos) em) em === em + , testProperty "setset" $ \pos (em :: EntityMap Int) es -> + (set (atPosition pos) es . set (atPosition pos) es) em + === + set (atPosition pos) es em + -- testProperty "lens laws" $ \pos -> isLens $ atPosition @Int pos + , testProperty "preserves IDs" $ \(em :: EntityMap Int) e1 e2 p -> + let (eid, em') = insertAtReturningID p e1 em + em'' = em' & atPosition p %~ (e2 <|) + in + counterexample ("em': " <> show em') + . counterexample ("em'': " <> show em'') + $ em'' ^. at eid === Just (Positioned p e1) + ] + ] diff --git a/users/glittershark/xanthous/test/Xanthous/Data/LevelsSpec.hs b/users/glittershark/xanthous/test/Xanthous/Data/LevelsSpec.hs new file mode 100644 index 0000000000..4e46946a93 --- /dev/null +++ b/users/glittershark/xanthous/test/Xanthous/Data/LevelsSpec.hs @@ -0,0 +1,66 @@ +-------------------------------------------------------------------------------- +module Xanthous.Data.LevelsSpec (main, test) where +-------------------------------------------------------------------------------- +import Test.Prelude +-------------------------------------------------------------------------------- +import qualified Data.Aeson as JSON +-------------------------------------------------------------------------------- +import Xanthous.Util (between) +import Xanthous.Data.Levels +-------------------------------------------------------------------------------- + +main :: IO () +main = defaultMain test + +test :: TestTree +test = testGroup "Xanthous.Data.Levels" + [ testGroup "current" + [ testProperty "view is extract" $ \(levels :: Levels Int) -> + levels ^. current === extract levels + , testProperty "set replaces current" $ \(levels :: Levels Int) new -> + extract (set current new levels) === new + , testProperty "set extract is id" $ \(levels :: Levels Int) -> + set current (extract levels) levels === levels + , testProperty "set y ∘ set x ≡ set y" $ \(levels :: Levels Int) x y -> + set current y (set current x levels) === set current y levels + ] + , localOption (QuickCheckTests 20) + $ testBatch $ semigroup @(Levels Int) (error "unused", 1 :: Int) + , testGroup "next/prev" + [ testGroup "nextLevel" + [ testProperty "seeks forwards" $ \(levels :: Levels Int) genned -> + (pos . runIdentity . nextLevel (Identity genned) $ levels) + === pos levels + 1 + , testProperty "maintains the invariant" $ \(levels :: Levels Int) genned -> + let levels' = runIdentity . nextLevel (Identity genned) $ levels + in between 0 (length levels') $ pos levels' + , testProperty "extract is total" $ \(levels :: Levels Int) genned -> + let levels' = runIdentity . nextLevel (Identity genned) $ levels + in total $ extract levels' + , testProperty "uses the generated level as the next level" + $ \(levels :: Levels Int) genned -> + let levels' = seek (length levels - 1) levels + levels'' = runIdentity . nextLevel (Identity genned) $ levels' + in counterexample (show levels'') + $ extract levels'' === genned + ] + , testGroup "prevLevel" + [ testProperty "seeks backwards" $ \(levels :: Levels Int) -> + case prevLevel levels of + Nothing -> property Discard + Just levels' -> pos levels' === pos levels - 1 + , testProperty "maintains the invariant" $ \(levels :: Levels Int) -> + case prevLevel levels of + Nothing -> property Discard + Just levels' -> property $ between 0 (length levels') $ pos levels' + , testProperty "extract is total" $ \(levels :: Levels Int) -> + case prevLevel levels of + Nothing -> property Discard + Just levels' -> total $ extract levels' + ] + ] + , testGroup "JSON" + [ testProperty "toJSON/parseJSON round-trip" $ \(levels :: Levels Int) -> + JSON.decode (JSON.encode levels) === Just levels + ] + ] diff --git a/users/glittershark/xanthous/test/Xanthous/Data/NestedMapSpec.hs b/users/glittershark/xanthous/test/Xanthous/Data/NestedMapSpec.hs new file mode 100644 index 0000000000..acf7a67268 --- /dev/null +++ b/users/glittershark/xanthous/test/Xanthous/Data/NestedMapSpec.hs @@ -0,0 +1,20 @@ +-------------------------------------------------------------------------------- +module Xanthous.Data.NestedMapSpec (main, test) where +-------------------------------------------------------------------------------- +import Test.Prelude +-------------------------------------------------------------------------------- +import Test.QuickCheck.Instances.Semigroup () +-------------------------------------------------------------------------------- +import qualified Xanthous.Data.NestedMap as NM +-------------------------------------------------------------------------------- + +main :: IO () +main = defaultMain test + +test :: TestTree +test = testGroup "Xanthous.Data.NestedMap" + [ testProperty "insert/lookup" $ \nm ks v -> + let nm' = NM.insert ks v nm + in counterexample ("inserted: " <> show nm') + $ NM.lookup @Map @Int @Int ks nm' === Just (NM.Val v) + ] diff --git a/users/glittershark/xanthous/test/Xanthous/DataSpec.hs b/users/glittershark/xanthous/test/Xanthous/DataSpec.hs new file mode 100644 index 0000000000..91dc6cea1b --- /dev/null +++ b/users/glittershark/xanthous/test/Xanthous/DataSpec.hs @@ -0,0 +1,98 @@ +-------------------------------------------------------------------------------- +module Xanthous.DataSpec (main, test) where +-------------------------------------------------------------------------------- +import Test.Prelude hiding (Right, Left, Down, toList, all) +import Data.Group +import Data.Foldable (toList, all) +-------------------------------------------------------------------------------- +import Xanthous.Data +-------------------------------------------------------------------------------- + +main :: IO () +main = defaultMain test + +test :: TestTree +test = testGroup "Xanthous.Data" + [ testGroup "Position" + [ testBatch $ monoid @Position mempty + , testProperty "group laws" $ \(pos :: Position) -> + pos <> invert pos == mempty && invert pos <> pos == mempty + , testGroup "stepTowards laws" + [ testProperty "takes only one step" $ \src tgt -> + src /= tgt ==> + isUnit (src `diffPositions` (src `stepTowards` tgt)) + -- , testProperty "moves in the right direction" $ \src tgt -> + -- stepTowards src tgt == move (directionOf src tgt) src + ] + , testProperty "directionOf laws" $ \pos dir -> + directionOf pos (move dir pos) == dir + , testProperty "diffPositions is add inverse" $ \(pos₁ :: Position) pos₂ -> + diffPositions pos₁ pos₂ == addPositions pos₁ (invert pos₂) + , testGroup "isUnit" + [ testProperty "double direction is never unit" $ \dir -> + not . isUnit $ move dir (asPosition dir) + , testCase "examples" $ do + isUnit (Position @Int 1 1) @? "not . isUnit $ Position 1 1" + isUnit (Position @Int 0 (-1)) @? "not . isUnit $ Position 0 (-1)" + (not . isUnit) (Position @Int 1 13) @? "isUnit $ Position 1 13" + ] + ] + + , testGroup "Direction" + [ testProperty "opposite is involutive" $ \(dir :: Direction) -> + opposite (opposite dir) == dir + , testProperty "opposite provides inverse" $ \dir -> + invert (asPosition dir) === asPosition (opposite dir) + , testProperty "asPosition isUnit" $ \dir -> + dir /= Here ==> isUnit (asPosition dir) + , testGroup "Move" + [ testCase "Up" $ move Up mempty @?= Position @Int 0 (-1) + , testCase "Down" $ move Down mempty @?= Position @Int 0 1 + , testCase "Left" $ move Left mempty @?= Position @Int (-1) 0 + , testCase "Right" $ move Right mempty @?= Position @Int 1 0 + , testCase "UpLeft" $ move UpLeft mempty @?= Position @Int (-1) (-1) + , testCase "UpRight" $ move UpRight mempty @?= Position @Int 1 (-1) + , testCase "DownLeft" $ move DownLeft mempty @?= Position @Int (-1) 1 + , testCase "DownRight" $ move DownRight mempty @?= Position @Int 1 1 + ] + ] + + , testGroup "Corner" + [ testGroup "instance Opposite" + [ testProperty "involutive" $ \(corner :: Corner) -> + opposite (opposite corner) === corner + ] + ] + + , testGroup "Edge" + [ testGroup "instance Opposite" + [ testProperty "involutive" $ \(edge :: Edge) -> + opposite (opposite edge) === edge + ] + ] + + , testGroup "Box" + [ testGroup "boxIntersects" + [ testProperty "True" $ \dims -> + boxIntersects (Box @Word (V2 1 1) (V2 2 2)) + (Box (V2 2 2) dims) + , testProperty "False" $ \dims -> + not $ boxIntersects (Box @Word (V2 1 1) (V2 2 2)) + (Box (V2 4 2) dims) + ] + ] + + , testGroup "Neighbors" + [ testGroup "rotations" + [ testProperty "always has the same members" + $ \(neighs :: Neighbors Int) -> + all (\ns -> sort (toList ns) == sort (toList neighs)) + $ rotations neighs + , testProperty "all rotations have the same rotations" + $ \(neighs :: Neighbors Int) -> + let rots = rotations neighs + in all (\ns -> sort (toList $ rotations ns) == sort (toList rots)) + rots + ] + ] + ] diff --git a/users/glittershark/xanthous/test/Xanthous/Entities/RawsSpec.hs b/users/glittershark/xanthous/test/Xanthous/Entities/RawsSpec.hs new file mode 100644 index 0000000000..2e6f35457f --- /dev/null +++ b/users/glittershark/xanthous/test/Xanthous/Entities/RawsSpec.hs @@ -0,0 +1,16 @@ +-- | + +module Xanthous.Entities.RawsSpec (main, test) where + +import Test.Prelude +import Xanthous.Entities.Raws + +main :: IO () +main = defaultMain test + +test :: TestTree +test = testGroup "Xanthous.Entities.Raws" + [ testGroup "raws" + [ testCase "are all valid" $ raws `deepseq` pure () + ] + ] diff --git a/users/glittershark/xanthous/test/Xanthous/GameSpec.hs b/users/glittershark/xanthous/test/Xanthous/GameSpec.hs new file mode 100644 index 0000000000..2fa8527d0e --- /dev/null +++ b/users/glittershark/xanthous/test/Xanthous/GameSpec.hs @@ -0,0 +1,55 @@ +module Xanthous.GameSpec where + +import Test.Prelude hiding (Down) +import Xanthous.Game +import Xanthous.Game.State +import Control.Lens.Properties +import Xanthous.Data (move, Direction(Down)) +import Xanthous.Data.EntityMap (atPosition) + +main :: IO () +main = defaultMain test + +test :: TestTree +test + = localOption (QuickCheckTests 10) + . localOption (QuickCheckMaxSize 10) + $ testGroup "Xanthous.Game" + [ testGroup "positionedCharacter" + [ testProperty "lens laws" $ isLens positionedCharacter + , testCase "updates the position of the character" $ do + initialGame <- getInitialState + let initialPos = initialGame ^. characterPosition + updatedGame = initialGame & characterPosition %~ move Down + updatedPos = updatedGame ^. characterPosition + updatedPos @?= move Down initialPos + updatedGame ^. entities . atPosition initialPos @?= fromList [] + updatedGame ^. entities . atPosition updatedPos + @?= fromList [SomeEntity $ initialGame ^. character] + ] + , testGroup "characterPosition" + [ testProperty "lens laws" $ isLens characterPosition + ] + , testGroup "character" + [ testProperty "lens laws" $ isLens character + ] + , testGroup "MessageHistory" + [ testGroup "MonoComonad laws" + [ testProperty "oextend oextract ≡ id" + $ \(mh :: MessageHistory) -> oextend oextract mh === mh + , testProperty "oextract ∘ oextend f ≡ f" + $ \(mh :: MessageHistory) f -> (oextract . oextend f) mh === f mh + , testProperty "oextend f ∘ oextend g ≡ oextend (f . oextend g)" + $ \(mh :: MessageHistory) f g -> + (oextend f . oextend g) mh === oextend (f . oextend g) mh + ] + ] + , testGroup "Saving the game" + [ testProperty "forms a prism" $ isPrism saved + , testProperty "round-trips" $ \gs -> + loadGame (saveGame gs) === Just gs + , testProperty "preserves the character ID" $ \gs -> + let Just gs' = loadGame $ saveGame gs + in gs' ^. character === gs ^. character + ] + ] diff --git a/users/glittershark/xanthous/test/Xanthous/Generators/UtilSpec.hs b/users/glittershark/xanthous/test/Xanthous/Generators/UtilSpec.hs new file mode 100644 index 0000000000..c82c385987 --- /dev/null +++ b/users/glittershark/xanthous/test/Xanthous/Generators/UtilSpec.hs @@ -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 + ] + ] diff --git a/users/glittershark/xanthous/test/Xanthous/MessageSpec.hs b/users/glittershark/xanthous/test/Xanthous/MessageSpec.hs new file mode 100644 index 0000000000..b681e537ef --- /dev/null +++ b/users/glittershark/xanthous/test/Xanthous/MessageSpec.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedLists #-} +module Xanthous.MessageSpec ( main, test ) where + +import Test.Prelude +import Xanthous.Messages +import Data.Aeson +import Text.Mustache +import Control.Lens.Properties + +main :: IO () +main = defaultMain test + +test :: TestTree +test = testGroup "Xanthous.Messages" + [ testGroup "Message" + [ testGroup "JSON decoding" + [ testCase "Single" + $ decode "\"Test Single Template\"" + @?= Just (Single + $ compileMustacheText "template" "Test Single Template" + ^?! _Right) + , testCase "Choice" + $ decode "[\"Choice 1\", \"Choice 2\"]" + @?= Just + (Choice + [ compileMustacheText "template" "Choice 1" ^?! _Right + , compileMustacheText "template" "Choice 2" ^?! _Right + ]) + ] + ] + , localOption (QuickCheckTests 50) + . localOption (QuickCheckMaxSize 10) + $ testGroup "MessageMap" + [ testGroup "instance Ixed" + [ testProperty "traversal laws" $ \k -> + isTraversal $ ix @MessageMap k + , testCase "preview when exists" $ + let + Right tpl = compileMustacheText "foo" "bar" + msg = Single tpl + mm = Nested $ [("foo", Direct msg)] + in mm ^? ix ["foo"] @?= Just msg + ] + , testGroup "lookupMessage" + [ testProperty "is equivalent to preview ix" $ \msgMap path -> + lookupMessage path msgMap === msgMap ^? ix path + ] + ] + + , testGroup "Messages" + [ testCase "are all valid" $ messages `deepseq` pure () + ] + ] diff --git a/users/glittershark/xanthous/test/Xanthous/Messages/TemplateSpec.hs b/users/glittershark/xanthous/test/Xanthous/Messages/TemplateSpec.hs new file mode 100644 index 0000000000..8ea5186c50 --- /dev/null +++ b/users/glittershark/xanthous/test/Xanthous/Messages/TemplateSpec.hs @@ -0,0 +1,80 @@ +-------------------------------------------------------------------------------- +module Xanthous.Messages.TemplateSpec (main, test) where +-------------------------------------------------------------------------------- +import Test.Prelude +import Test.QuickCheck.Instances.Text () +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Function (fix) +-------------------------------------------------------------------------------- +import Xanthous.Messages.Template +-------------------------------------------------------------------------------- + +main :: IO () +main = defaultMain test + +test :: TestTree +test = testGroup "Xanthous.Messages.Template" + [ testGroup "parsing" + [ testProperty "literals" $ forAll genLiteral $ \s -> + testParse template s === Right (Literal s) + , parseCase "escaped curlies" + "foo\\{" + $ Literal "foo{" + , parseCase "simple substitution" + "foo {{bar}}" + $ Literal "foo " `Concat` Subst (SubstPath $ "bar" :| []) + , parseCase "substitution with filters" + "foo {{bar | baz}}" + $ Literal "foo " + `Concat` Subst (SubstFilter (SubstPath $ "bar" :| []) + (FilterName "baz")) + , parseCase "substitution with multiple filters" + "foo {{bar | baz | qux}}" + $ Literal "foo " + `Concat` Subst (SubstFilter (SubstFilter (SubstPath $ "bar" :| []) + (FilterName "baz")) + (FilterName "qux")) + , parseCase "two substitutions and a literal" + "{{a}}{{b}}c" + $ Subst (SubstPath $ "a" :| []) + `Concat` Subst (SubstPath $ "b" :| []) + `Concat` Literal "c" + , localOption (QuickCheckTests 10) + $ testProperty "round-trips with ppTemplate" $ \tpl -> + testParse template (ppTemplate tpl) === Right tpl + ] + , testBatch $ monoid @Template mempty + , testGroup "rendering" + [ testProperty "rendering literals renders literally" + $ forAll genLiteral $ \s fs vs -> + render fs vs (Literal s) === Right s + , testProperty "rendering substitutions renders substitutions" + $ forAll genPath $ \ident val fs -> + let tpl = Subst (SubstPath ident) + tvs = varsWith ident val + in render fs tvs tpl === Right val + , testProperty "filters filter" $ forAll genPath + $ \ident filterName filterFn val -> + let tpl = Subst (SubstFilter (SubstPath ident) filterName) + fs = mapFromList [(filterName, filterFn)] + vs = varsWith ident val + in render fs vs tpl === Right (filterFn val) + ] + ] + where + genLiteral = filter (`notElem` ['\\', '{']) <$> arbitrary + parseCase name input expected = + testCase name $ testParse template input @?= Right expected + testParse p = over _Left errorBundlePretty . runParser p "<test>" + genIdentifier = pack @Text <$> listOf1 (elements identifierChars) + identifierChars = ['a'..'z'] <> ['A'..'Z'] <> ['-', '_'] + + varsWith (p :| []) val = vars [(p, Val val)] + varsWith (phead :| ps) val = vars . pure . (phead ,) . flip fix ps $ + \next pth -> case pth of + [] -> Val val + p : ps' -> nested [(p, next ps')] + + genPath = (:|) <$> genIdentifier <*> listOf genIdentifier + +-- diff --git a/users/glittershark/xanthous/test/Xanthous/OrphansSpec.hs b/users/glittershark/xanthous/test/Xanthous/OrphansSpec.hs new file mode 100644 index 0000000000..3740945877 --- /dev/null +++ b/users/glittershark/xanthous/test/Xanthous/OrphansSpec.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE BlockArguments #-} +-------------------------------------------------------------------------------- +module Xanthous.OrphansSpec where +-------------------------------------------------------------------------------- +import Test.Prelude +-------------------------------------------------------------------------------- +import Text.Mustache +import Text.Megaparsec (errorBundlePretty) +import Graphics.Vty.Attributes +import qualified Data.Aeson as JSON +-------------------------------------------------------------------------------- +import Xanthous.Orphans +-------------------------------------------------------------------------------- + +main :: IO () +main = defaultMain test + +test :: TestTree +test = testGroup "Xanthous.Orphans" + [ localOption (QuickCheckTests 50) + . localOption (QuickCheckMaxSize 10) + $ testGroup "Template" + [ testProperty "ppTemplate / compileMustacheText " \tpl -> + let src = ppTemplate tpl + res :: Either String Template + res = over _Left errorBundlePretty + $ compileMustacheText (templateActual tpl) src + expected = templateCache tpl ^?! at (templateActual tpl) + in + counterexample (unpack src) + $ Right expected === do + (Template actual cache) <- res + maybe (Left "Template not found") Right $ cache ^? at actual + , testProperty "JSON round trip" $ \(tpl :: Template) -> + counterexample (unpack $ ppTemplate tpl) + $ JSON.decode (JSON.encode tpl) === Just tpl + ] + , testGroup "Attr" + [ testProperty "JSON round trip" $ \(attr :: Attr) -> + JSON.decode (JSON.encode attr) === Just attr + ] + ] diff --git a/users/glittershark/xanthous/test/Xanthous/Util/GraphSpec.hs b/users/glittershark/xanthous/test/Xanthous/Util/GraphSpec.hs new file mode 100644 index 0000000000..35ff090b28 --- /dev/null +++ b/users/glittershark/xanthous/test/Xanthous/Util/GraphSpec.hs @@ -0,0 +1,39 @@ +module Xanthous.Util.GraphSpec (main, test) where +-------------------------------------------------------------------------------- +import Test.Prelude +-------------------------------------------------------------------------------- +import Xanthous.Util.Graph +import Data.Graph.Inductive.Basic +import Data.Graph.Inductive.Graph (labNodes, size, order) +import Data.Graph.Inductive.PatriciaTree +import Data.Graph.Inductive.Arbitrary +-------------------------------------------------------------------------------- + +main :: IO () +main = defaultMain test + +test :: TestTree +test = testGroup "Xanthous.Util.Graph" + [ testGroup "mstSubGraph" + [ testProperty "always produces a subgraph" + $ \(CG _ (graph :: Gr Int Int)) -> + let msg = mstSubGraph $ undir graph + in counterexample (show msg) + $ msg `isSubGraphOf` undir graph + , testProperty "returns a graph with the same nodes" + $ \(CG _ (graph :: Gr Int Int)) -> + let msg = mstSubGraph graph + in counterexample (show msg) + $ labNodes msg === labNodes graph + , testProperty "has nodes - 1 edges" + $ \(CG _ (graph :: Gr Int Int)) -> + order graph > 1 ==> + let msg = mstSubGraph graph + in counterexample (show msg) + $ size msg === order graph - 1 + , testProperty "always produces a simple graph" + $ \(CG _ (graph :: Gr Int Int)) -> + let msg = mstSubGraph graph + in counterexample (show msg) $ isSimple msg + ] + ] diff --git a/users/glittershark/xanthous/test/Xanthous/Util/GraphicsSpec.hs b/users/glittershark/xanthous/test/Xanthous/Util/GraphicsSpec.hs new file mode 100644 index 0000000000..ff99d10738 --- /dev/null +++ b/users/glittershark/xanthous/test/Xanthous/Util/GraphicsSpec.hs @@ -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) + ] + ] + +-------------------------------------------------------------------------------- diff --git a/users/glittershark/xanthous/test/Xanthous/Util/InflectionSpec.hs b/users/glittershark/xanthous/test/Xanthous/Util/InflectionSpec.hs new file mode 100644 index 0000000000..fad8410431 --- /dev/null +++ b/users/glittershark/xanthous/test/Xanthous/Util/InflectionSpec.hs @@ -0,0 +1,18 @@ +module Xanthous.Util.InflectionSpec (main, test) where + +import Test.Prelude +import Xanthous.Util.Inflection + +main :: IO () +main = defaultMain test + +test :: TestTree +test = testGroup "Xanthous.Util.Inflection" + [ testGroup "toSentence" + [ testCase "empty" $ toSentence [] @?= "" + , testCase "single" $ toSentence ["x"] @?= "x" + , testCase "two" $ toSentence ["x", "y"] @?= "x and y" + , testCase "three" $ toSentence ["x", "y", "z"] @?= "x, y, and z" + , testCase "four" $ toSentence ["x", "y", "z", "w"] @?= "x, y, z, and w" + ] + ] diff --git a/users/glittershark/xanthous/test/Xanthous/UtilSpec.hs b/users/glittershark/xanthous/test/Xanthous/UtilSpec.hs new file mode 100644 index 0000000000..8538ea5098 --- /dev/null +++ b/users/glittershark/xanthous/test/Xanthous/UtilSpec.hs @@ -0,0 +1,28 @@ +module Xanthous.UtilSpec (main, test) where + +import Test.Prelude +import Xanthous.Util + +main :: IO () +main = defaultMain test + +test :: TestTree +test = testGroup "Xanthous.Util" + [ testGroup "smallestNotIn" + [ testCase "examples" $ do + smallestNotIn [7 :: Word, 3, 7] @?= 0 + smallestNotIn [7 :: Word, 0, 1, 3, 7] @?= 2 + , testProperty "returns an element not in the list" $ \(xs :: [Word]) -> + smallestNotIn xs `notElem` xs + , testProperty "pred return is in the list" $ \(xs :: [Word]) -> + let res = smallestNotIn xs + in res /= 0 ==> pred res `elem` xs + , testProperty "ignores order" $ \(xs :: [Word]) -> + forAll (shuffle xs) $ \shuffledXs -> + smallestNotIn xs === smallestNotIn shuffledXs + ] + , testGroup "takeWhileInclusive" + [ testProperty "takeWhileInclusive (const True) ≡ id" + $ \(xs :: [Int]) -> takeWhileInclusive (const True) xs === xs + ] + ] diff --git a/users/glittershark/xanthous/xanthous.cabal b/users/glittershark/xanthous/xanthous.cabal new file mode 100644 index 0000000000..6d0b7b1093 --- /dev/null +++ b/users/glittershark/xanthous/xanthous.cabal @@ -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 |