diff options
Diffstat (limited to 'users/glittershark/xanthous')
102 files changed, 0 insertions, 10558 deletions
diff --git a/users/glittershark/xanthous/.envrc b/users/glittershark/xanthous/.envrc deleted file mode 100644 index be81feddb1..0000000000 --- a/users/glittershark/xanthous/.envrc +++ /dev/null @@ -1 +0,0 @@ -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 deleted file mode 100644 index cfe8e35df0..0000000000 --- a/users/glittershark/xanthous/.github/actions/nix-build/Dockerfile +++ /dev/null @@ -1,23 +0,0 @@ -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 deleted file mode 100755 index cb7aca541a..0000000000 --- a/users/glittershark/xanthous/.github/actions/nix-build/entrypoint.sh +++ /dev/null @@ -1,24 +0,0 @@ -#!/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 deleted file mode 100644 index df82de3e8c..0000000000 --- a/users/glittershark/xanthous/.github/workflows/haskell.yml +++ /dev/null @@ -1,15 +0,0 @@ -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 deleted file mode 100644 index 74014978ff..0000000000 --- a/users/glittershark/xanthous/.gitignore +++ /dev/null @@ -1,34 +0,0 @@ -dist -dist-* -cabal-dev -*.o -*.hi -*.hie -*.chi -*.chs.h -*.dyn_o -*.dyn_hi -.hpc -.hsenv -.cabal-sandbox/ -cabal.sandbox.config -*.prof -*.aux -*.hp -*.eventlog -.stack-work/ -cabal.project.local -cabal.project.local~ -.HTF/ -.ghc.environment.* - - -# from nix-build -result - -# grr -*_flymake.hs - -# app-specific -debug.log -data diff --git a/users/glittershark/xanthous/LICENSE b/users/glittershark/xanthous/LICENSE deleted file mode 100644 index 45644ff764..0000000000 --- a/users/glittershark/xanthous/LICENSE +++ /dev/null @@ -1,674 +0,0 @@ - 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 deleted file mode 100644 index 7e1fedb069..0000000000 --- a/users/glittershark/xanthous/README.org +++ /dev/null @@ -1,36 +0,0 @@ -#+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 deleted file mode 100644 index 9a994af677..0000000000 --- a/users/glittershark/xanthous/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/users/glittershark/xanthous/bench/Bench.hs b/users/glittershark/xanthous/bench/Bench.hs deleted file mode 100644 index 5889618ee4..0000000000 --- a/users/glittershark/xanthous/bench/Bench.hs +++ /dev/null @@ -1,12 +0,0 @@ --------------------------------------------------------------------------------- -module Main where --------------------------------------------------------------------------------- -import Bench.Prelude --------------------------------------------------------------------------------- -import qualified Xanthous.RandomBench -import qualified Xanthous.Generators.UtilBench - -main :: IO () -main = defaultMain - [ Xanthous.Generators.UtilBench.benchmark - ] diff --git a/users/glittershark/xanthous/bench/Bench/Prelude.hs b/users/glittershark/xanthous/bench/Bench/Prelude.hs deleted file mode 100644 index c553abd6d5..0000000000 --- a/users/glittershark/xanthous/bench/Bench/Prelude.hs +++ /dev/null @@ -1,9 +0,0 @@ --------------------------------------------------------------------------------- -module Bench.Prelude - ( module Xanthous.Prelude - , module Criterion.Main - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude -import Criterion.Main --------------------------------------------------------------------------------- diff --git a/users/glittershark/xanthous/bench/Xanthous/Generators/UtilBench.hs b/users/glittershark/xanthous/bench/Xanthous/Generators/UtilBench.hs deleted file mode 100644 index 56310e691c..0000000000 --- a/users/glittershark/xanthous/bench/Xanthous/Generators/UtilBench.hs +++ /dev/null @@ -1,37 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Generators.UtilBench (benchmark, main) where --------------------------------------------------------------------------------- -import Bench.Prelude --------------------------------------------------------------------------------- -import Data.Array.IArray -import Data.Array.Unboxed -import System.Random (getStdGen) --------------------------------------------------------------------------------- -import Xanthous.Generators.Util -import qualified Xanthous.Generators.CaveAutomata as CaveAutomata -import Xanthous.Data (Dimensions'(..)) --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain [benchmark] - --------------------------------------------------------------------------------- - -benchmark :: Benchmark -benchmark = bgroup "Generators.Util" - [ bgroup "floodFill" - [ env (NFWrapper <$> cells) $ \(NFWrapper ir) -> - bench "checkerboard" $ nf (floodFill ir) (1,0) - ] - ] - where - cells :: IO Cells - cells = CaveAutomata.generate - CaveAutomata.defaultParams - (Dimensions 50 50) - <$> getStdGen - -newtype NFWrapper a = NFWrapper a - -instance NFData (NFWrapper a) where - rnf (NFWrapper x) = x `seq` () diff --git a/users/glittershark/xanthous/bench/Xanthous/RandomBench.hs b/users/glittershark/xanthous/bench/Xanthous/RandomBench.hs deleted file mode 100644 index fae4af92a7..0000000000 --- a/users/glittershark/xanthous/bench/Xanthous/RandomBench.hs +++ /dev/null @@ -1,32 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.RandomBench (benchmark, main) where --------------------------------------------------------------------------------- -import Bench.Prelude --------------------------------------------------------------------------------- -import Control.Parallel.Strategies -import Control.Monad.Random --------------------------------------------------------------------------------- -import Xanthous.Random --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain [benchmark] - --------------------------------------------------------------------------------- - -benchmark :: Benchmark -benchmark = bgroup "Random" - [ bgroup "chooseSubset" - [ bench "serially" $ - nf (evalRand $ chooseSubset (0.5 :: Double) [1 :: Int ..1000000]) - (mkStdGen 1234) - ] - , bgroup "choose weightedBy" - [ bench "serially" $ - nf (evalRand - . choose - . weightedBy (\n -> product [n, pred n .. 1]) - $ [1 :: Int ..1000000]) - (mkStdGen 1234) - ] - ] diff --git a/users/glittershark/xanthous/build/generic-arbitrary-export-garbitrary.patch b/users/glittershark/xanthous/build/generic-arbitrary-export-garbitrary.patch deleted file mode 100644 index f0c936bfca..0000000000 --- a/users/glittershark/xanthous/build/generic-arbitrary-export-garbitrary.patch +++ /dev/null @@ -1,12 +0,0 @@ -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 deleted file mode 100644 index 748c65b3e0..0000000000 --- a/users/glittershark/xanthous/build/hgeometry-fix-haddock.patch +++ /dev/null @@ -1,13 +0,0 @@ -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 deleted file mode 100644 index cd1dbe24d3..0000000000 --- a/users/glittershark/xanthous/build/update-comonad-extras.patch +++ /dev/null @@ -1,92 +0,0 @@ -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 deleted file mode 100644 index 0b89a50afb..0000000000 --- a/users/glittershark/xanthous/default.nix +++ /dev/null @@ -1,7 +0,0 @@ -{ pkgs ? (import ../../../. {}).third_party -, lib ? pkgs.lib -, ... -}: -pkgs.haskell.lib.failOnAllWarnings ( - pkgs.haskellPackages.callPackage (import ./pkg.nix { inherit pkgs; }) {} -) diff --git a/users/glittershark/xanthous/hie.yaml b/users/glittershark/xanthous/hie.yaml deleted file mode 100644 index 49f8ec1fbb..0000000000 --- a/users/glittershark/xanthous/hie.yaml +++ /dev/null @@ -1,10 +0,0 @@ -cradle: - cabal: - - path: './src' - component: 'lib:xanthous' - - path: './test' - component: 'test:test' - - path: './src' - component: 'exe:xanthous' - - path: './bench' - component: 'bench:benchmark' diff --git a/users/glittershark/xanthous/nixpkgs.nix b/users/glittershark/xanthous/nixpkgs.nix deleted file mode 100644 index 7d7c164405..0000000000 --- a/users/glittershark/xanthous/nixpkgs.nix +++ /dev/null @@ -1,3 +0,0 @@ -args: -let pkgs = (import ../../../. args).third_party; -in pkgs // { inherit pkgs; } diff --git a/users/glittershark/xanthous/package.yaml b/users/glittershark/xanthous/package.yaml deleted file mode 100644 index e8cda59692..0000000000 --- a/users/glittershark/xanthous/package.yaml +++ /dev/null @@ -1,153 +0,0 @@ -name: xanthous -version: 0.1.0.0 -github: "glittershark/xanthous" -license: GPL-3 -author: "Griffin Smith" -maintainer: "root@gws.fyi" -copyright: "2019 Griffin Smith" - -extra-source-files: -- README.org - -synopsis: A WIP TUI RPG -category: Game - -description: Please see the README on GitHub at <https://github.com/glittershark/xanthous> - -dependencies: -- base - -- aeson -- array -- async -- QuickCheck -- quickcheck-text -- quickcheck-instances -- brick -- bifunctors -- checkers -- classy-prelude -- comonad -- comonad-extras -- constraints -- containers -- criterion -- data-default -- deepseq -- directory -- fgl -- fgl-arbitrary -- file-embed -- filepath -- generic-arbitrary -- generic-monoid -- generic-lens -- groups -- hgeometry -- hgeometry-combinatorial -- JuicyPixels -- lens -- lifted-async -- linear -- megaparsec -- mmorph -- monad-control -- MonadRandom -- mtl -- optparse-applicative -- parallel -- parser-combinators -- pointed -- random -- random-fu -- random-extras -- random-source -- raw-strings-qq -- reflection -- Rasterific -- splitmix -- streams -- stache -- semigroupoids -- tomland -- transformers -- text -- text-zipper -- vector -- vty -- witherable -- yaml -- zlib - -default-extensions: -- BlockArguments -- ConstraintKinds -- DataKinds -- DeriveAnyClass -- DeriveGeneric -- DerivingStrategies -- DerivingVia -- FlexibleContexts -- FlexibleInstances -- FunctionalDependencies -- GADTSyntax -- GeneralizedNewtypeDeriving -- KindSignatures -- LambdaCase -- MultiWayIf -- NoImplicitPrelude -- NoStarIsType -- OverloadedStrings -- PolyKinds -- RankNTypes -- ScopedTypeVariables -- TupleSections -- TypeApplications -- TypeFamilies -- TypeOperators -- ViewPatterns - -ghc-options: -- -Wall - -library: - source-dirs: src - -executable: - source-dirs: src - main: Main.hs - dependencies: - - xanthous - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - - -O2 - -tests: - test: - main: Spec.hs - source-dirs: test - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - - -O0 - dependencies: - - xanthous - - tasty - - tasty-hunit - - tasty-quickcheck - - lens-properties - -benchmarks: - benchmark: - main: Bench.hs - source-dirs: bench - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - xanthous - - criterion diff --git a/users/glittershark/xanthous/pkg.nix b/users/glittershark/xanthous/pkg.nix deleted file mode 100644 index 16a6500866..0000000000 --- a/users/glittershark/xanthous/pkg.nix +++ /dev/null @@ -1,16 +0,0 @@ -{ depot ? (import ../../../. {}) -, pkgs ? depot.third_party.nixpkgs -, ... }: - -let - ignore = depot.third_party.gitignoreSource.gitignoreFilter ./.; -in import (pkgs.haskellPackages.haskellSrc2nix { - name = "xanthous"; - src = builtins.path { - name = "xanthous-source"; - path = ./.; - filter = path: type: ignore path type - || builtins.baseNameOf path == "package.yaml"; - }; - extraCabal2nixOptions = "--hpack"; -}) diff --git a/users/glittershark/xanthous/shell.nix b/users/glittershark/xanthous/shell.nix deleted file mode 100644 index 29a4952106..0000000000 --- a/users/glittershark/xanthous/shell.nix +++ /dev/null @@ -1,16 +0,0 @@ -{ pkgs ? (import ../../../. {}).third_party, ... }: - -(pkgs.haskellPackages.extend (pkgs.haskell.lib.packageSourceOverrides { - xanthous = pkgs.gitignoreSource ./.; -})).shellFor { - packages = p: [p.xanthous]; - withHoogle = true; - doBenchmark = true; - buildInputs = with pkgs.haskellPackages; [ - cabal-install - ghc-prof-flamegraph - hp2pretty - hlint - haskell-language-server - ]; -} diff --git a/users/glittershark/xanthous/src/Data/Aeson/Generic/DerivingVia.hs b/users/glittershark/xanthous/src/Data/Aeson/Generic/DerivingVia.hs deleted file mode 100644 index 34f2a94038..0000000000 --- a/users/glittershark/xanthous/src/Data/Aeson/Generic/DerivingVia.hs +++ /dev/null @@ -1,167 +0,0 @@ -{-# 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 deleted file mode 100644 index dcd31afff9..0000000000 --- a/users/glittershark/xanthous/src/Main.hs +++ /dev/null @@ -1,159 +0,0 @@ -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 deleted file mode 100644 index a6cc789d68..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/AI/Gormlak.hs +++ /dev/null @@ -1,124 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE UndecidableInstances #-} --------------------------------------------------------------------------------- -module Xanthous.AI.Gormlak - ( HasVisionRadius(..) - , GormlakBrain(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (lines) --------------------------------------------------------------------------------- -import Control.Monad.State -import Control.Monad.Random -import Data.Aeson (object) -import qualified Data.Aeson as A -import Data.Generics.Product.Fields --------------------------------------------------------------------------------- -import Xanthous.Data - ( Positioned(..), positioned, position - , diffPositions, stepTowards, isUnit - , Ticks, (|*|), invertedRate - ) -import Xanthous.Data.EntityMap -import Xanthous.Entities.Creature.Hippocampus -import Xanthous.Entities.Character (Character) -import qualified Xanthous.Entities.Character as Character -import qualified Xanthous.Entities.RawTypes as Raw -import Xanthous.Entities.RawTypes (CreatureType) -import Xanthous.Game.State -import Xanthous.Game.Lenses - ( entitiesCollision, collisionAt - , character, characterPosition - ) -import Xanthous.Data.EntityMap.Graphics (linesOfSight, canSee) -import Xanthous.Random -import Xanthous.Monad (say) --------------------------------------------------------------------------------- - --- TODO move the following two classes to a more central location - -class HasVisionRadius a where visionRadius :: a -> Word - -type IsCreature entity = - ( HasVisionRadius entity - , HasField "_hippocampus" entity entity Hippocampus Hippocampus - , HasField "_creatureType" entity entity CreatureType CreatureType - , A.ToJSON entity - ) - --------------------------------------------------------------------------------- - -stepGormlak - :: forall entity m. - ( MonadState GameState m, MonadRandom m - , IsCreature entity - ) - => Ticks - -> Positioned entity - -> m (Positioned entity) -stepGormlak ticks pe@(Positioned pos creature) = do - dest <- maybe (selectDestination pos creature) pure - $ creature ^. field @"_hippocampus" . destination - let progress' = - dest ^. destinationProgress - + creature ^. field @"_creatureType" . Raw.speed . invertedRate |*| ticks - if progress' < 1 - then pure - $ pe - & positioned . field @"_hippocampus" . destination - ?~ (dest & destinationProgress .~ progress') - else do - let newPos = dest ^. destinationPosition - remainingSpeed = progress' - 1 - newDest <- selectDestination newPos creature - <&> destinationProgress +~ remainingSpeed - let pe' = pe & positioned . field @"_hippocampus" . destination ?~ newDest - collisionAt newPos >>= \case - Nothing -> pure $ pe' & position .~ newPos - Just Stop -> pure pe' - Just Combat -> do - ents <- use $ entities . atPosition newPos - when (any (entityIs @Character) ents) attackCharacter - pure pe' - where - selectDestination pos' creature' = destinationFromPos <$> do - canSeeCharacter <- uses entities $ canSee (entityIs @Character) pos' vision - if canSeeCharacter - then do - charPos <- use characterPosition - if isUnit (pos' `diffPositions` charPos) - then attackCharacter $> pos' - else pure $ pos' `stepTowards` charPos - else do - lines <- map (takeWhile (isNothing . entitiesCollision . map snd . snd) - -- the first item on these lines is always the creature itself - . fromMaybe mempty . tailMay) - . linesOfSight pos' (visionRadius creature') - <$> use entities - line <- choose $ weightedBy length lines - pure $ fromMaybe pos' $ fmap fst . headMay =<< line - - vision = visionRadius creature - attackCharacter = do - say ["combat", "creatureAttack"] $ object [ "creature" A..= creature ] - character %= Character.damage 1 - -newtype GormlakBrain entity = GormlakBrain { _unGormlakBrain :: entity } - -instance (IsCreature entity) => Brain (GormlakBrain entity) where - step ticks - = fmap (fmap GormlakBrain) - . stepGormlak ticks - . fmap _unGormlakBrain - entityCanMove = const True - --------------------------------------------------------------------------------- - --- instance Brain Creature where --- step = brainVia GormlakBrain --- entityCanMove = const True - --- instance Entity Creature where --- blocksVision _ = False --- description = view $ Creature.creatureType . Raw.description --- entityChar = view $ Creature.creatureType . char diff --git a/users/glittershark/xanthous/src/Xanthous/App.hs b/users/glittershark/xanthous/src/Xanthous/App.hs deleted file mode 100644 index 9091961b72..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/App.hs +++ /dev/null @@ -1,469 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE RecordWildCards #-} --------------------------------------------------------------------------------- -module Xanthous.App - ( makeApp - , RunType(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude -import Brick hiding (App, halt, continue, raw) -import qualified Brick -import Graphics.Vty.Attributes (defAttr) -import Graphics.Vty.Input.Events (Event(EvKey)) -import Control.Monad.State (get, gets) -import Control.Monad.State.Class (modify) -import Data.Aeson (object, ToJSON) -import qualified Data.Aeson as A -import qualified Data.Vector as V -import System.Exit -import System.Directory (doesFileExist) -import Data.List.NonEmpty (NonEmpty(..)) --------------------------------------------------------------------------------- -import Xanthous.App.Common -import Xanthous.App.Time -import Xanthous.App.Prompt -import Xanthous.App.Autocommands -import Xanthous.Command -import Xanthous.Data - ( move - , Dimensions'(Dimensions) - , positioned - , position - , Position - , (|*|) - ) -import Xanthous.Data.App (ResourceName, Panel(..), AppEvent(..)) -import qualified Xanthous.Data.EntityMap as EntityMap -import Xanthous.Data.Levels (prevLevel, nextLevel) -import qualified Xanthous.Data.Levels as Levels -import Xanthous.Data.Entities (blocksObject) -import Xanthous.Game -import Xanthous.Game.State -import Xanthous.Game.Env -import Xanthous.Game.Draw (drawGame) -import Xanthous.Game.Prompt -import qualified Xanthous.Messages as Messages -import Xanthous.Random -import Xanthous.Util (removeVectorIndex) -import Xanthous.Util.Inflection (toSentence) --------------------------------------------------------------------------------- -import qualified Xanthous.Entities.Character as Character -import Xanthous.Entities.Character hiding (pickUpItem) -import Xanthous.Entities.Item (Item) -import qualified Xanthous.Entities.Item as Item -import Xanthous.Entities.Creature (Creature) -import qualified Xanthous.Entities.Creature as Creature -import Xanthous.Entities.Environment - (Door, open, closed, locked, GroundMessage(..), Staircase(..)) -import Xanthous.Entities.RawTypes - ( edible, eatMessage, hitpointsHealed - , attackMessage - ) -import Xanthous.Generators -import qualified Xanthous.Generators.CaveAutomata as CaveAutomata -import qualified Xanthous.Generators.Dungeon as Dungeon --------------------------------------------------------------------------------- - -type App = Brick.App GameState AppEvent ResourceName - -data RunType = NewGame | LoadGame - deriving stock (Eq) - -makeApp :: GameEnv -> RunType -> IO App -makeApp env rt = pure $ Brick.App - { appDraw = drawGame - , appChooseCursor = const headMay - , appHandleEvent = \game event -> runAppM (handleEvent event) env game - , appStartEvent = case rt of - NewGame -> runAppM (startEvent >> get) env - LoadGame -> pure - , appAttrMap = const $ attrMap defAttr [] - } - -runAppM :: AppM a -> GameEnv -> GameState -> EventM ResourceName a -runAppM appm ge = fmap fst . runAppT appm ge - -startEvent :: AppM () -startEvent = do - initLevel - modify updateCharacterVision - use (character . characterName) >>= \case - Nothing -> prompt_ @'StringPrompt ["character", "namePrompt"] Uncancellable - $ \(StringResult s) -> do - character . characterName ?= s - say ["welcome"] =<< use character - Just n -> say ["welcome"] $ object [ "characterName" A..= n ] - -initLevel :: AppM () -initLevel = do - level <- genLevel 0 - entities <>= levelToEntityMap level - characterPosition .= level ^. levelCharacterPosition - --------------------------------------------------------------------------------- - -handleEvent :: BrickEvent ResourceName AppEvent -> AppM (Next GameState) -handleEvent ev = use promptState >>= \case - NoPrompt -> handleNoPromptEvent ev - WaitingPrompt msg pr -> handlePromptEvent msg pr ev - - -handleNoPromptEvent :: BrickEvent ResourceName AppEvent -> AppM (Next GameState) -handleNoPromptEvent (VtyEvent (EvKey k mods)) - | Just command <- commandFromKey k mods - = do messageHistory %= nextTurn - cancelAutocommand - handleCommand command -handleNoPromptEvent (AppEvent AutoContinue) = do - preuse (autocommand . _ActiveAutocommand . _1) >>= traverse_ autoStep - continue -handleNoPromptEvent _ = continue - -handleCommand :: Command -> AppM (Next GameState) -handleCommand Quit = confirm_ ["quit", "confirm"] (liftIO exitSuccess) >> continue -handleCommand (Move dir) = do - newPos <- uses characterPosition $ move dir - collisionAt newPos >>= \case - Nothing -> do - characterPosition .= newPos - stepGameBy =<< uses (character . speed) (|*| 1) - describeEntitiesAt newPos - Just Combat -> attackAt newPos - Just Stop -> pure () - continue - -handleCommand PickUp = do - pos <- use characterPosition - uses entities (entitiesAtPositionWithType @Item pos) >>= \case - [] -> say_ ["pickUp", "nothingToPickUp"] - [item] -> pickUpItem item - items' -> - menu_ ["pickUp", "menu"] Cancellable (entityMenu_ items') - $ \(MenuResult item) -> pickUpItem item - continue - where - pickUpItem (itemID, item) = do - character %= Character.pickUpItem item - entities . at itemID .= Nothing - say ["pickUp", "pickUp"] $ object [ "item" A..= item ] - stepGameBy 100 -- TODO - -handleCommand Drop = do - selectItemFromInventory_ ["drop", "menu"] Cancellable id - (say_ ["drop", "nothing"]) - $ \(MenuResult item) -> do - entitiesAtCharacter %= (SomeEntity item <|) - say ["drop", "dropped"] $ object [ "item" A..= item ] - continue - -handleCommand PreviousMessage = do - messageHistory %= previousMessage - continue - -handleCommand Open = do - prompt_ @'DirectionPrompt ["open", "prompt"] Cancellable - $ \(DirectionResult dir) -> do - pos <- move dir <$> use characterPosition - doors <- uses entities $ entitiesAtPositionWithType @Door pos - if | null doors -> say_ ["open", "nothingToOpen"] - | any (view $ _2 . locked) doors -> say_ ["open", "locked"] - | all (view $ _2 . open) doors -> say_ ["open", "alreadyOpen"] - | otherwise -> do - for_ doors $ \(eid, _) -> - entities . ix eid . positioned . _SomeEntity . open .= True - say_ ["open", "success"] - pure () - stepGame -- TODO - continue - -handleCommand Close = do - prompt_ @'DirectionPrompt ["close", "prompt"] Cancellable - $ \(DirectionResult dir) -> do - pos <- move dir <$> use characterPosition - (nonDoors, doors) <- uses entities - $ partitionEithers - . toList - . map ( (matching . aside $ _SomeEntity @Door) - . over _2 (view positioned) - ) - . EntityMap.atPositionWithIDs pos - if | null doors -> say_ ["close", "nothingToClose"] - | all (view $ _2 . closed) doors -> say_ ["close", "alreadyClosed"] - | any (view blocksObject . entityAttributes . snd) nonDoors -> - say ["close", "blocked"] - $ object [ "entityDescriptions" - A..= ( toSentence - . map description - . filter (view blocksObject . entityAttributes) - . map snd - ) nonDoors - , "blockOrBlocks" - A..= ( if length nonDoors == 1 - then "blocks" - else "block" - :: Text) - ] - | otherwise -> do - for_ doors $ \(eid, _) -> - entities . ix eid . positioned . _SomeEntity . closed .= True - for_ nonDoors $ \(eid, _) -> - entities . ix eid . position %= move dir - say_ ["close", "success"] - pure () - stepGame -- TODO - continue - -handleCommand Look = do - prompt_ @'PointOnMap ["look", "prompt"] Cancellable - $ \(PointOnMapResult pos) -> - gets (revealedEntitiesAtPosition pos) - >>= \case - Empty -> say_ ["look", "nothing"] - ents -> describeEntities ents - continue - -handleCommand Wait = stepGame >> continue - -handleCommand Eat = do - uses (character . inventory . backpack) - (V.mapMaybe (\item -> (item,) <$> item ^. Item.itemType . edible)) - >>= \case - Empty -> say_ ["eat", "noFood"] - food -> - let foodMenuItem idx (item, edibleItem) - = ( item ^. Item.itemType . char . char - , MenuOption (description item) (idx, item, edibleItem)) - -- TODO refactor to use entityMenu_ - menuItems = mkMenuItems $ imap foodMenuItem food - in menu_ ["eat", "menuPrompt"] Cancellable menuItems - $ \(MenuResult (idx, item, edibleItem)) -> do - character . inventory . backpack %= removeVectorIndex idx - let msg = fromMaybe (Messages.lookup ["eat", "eat"]) - $ edibleItem ^. eatMessage - character . characterHitpoints' += - edibleItem ^. hitpointsHealed . to fromIntegral - message msg $ object ["item" A..= item] - stepGame -- TODO - continue - -handleCommand Read = do - -- TODO allow reading things in the inventory (combo direction+menu prompt?) - prompt_ @'DirectionPrompt ["read", "prompt"] Cancellable - $ \(DirectionResult dir) -> do - pos <- uses characterPosition $ move dir - uses entities - (fmap snd . entitiesAtPositionWithType @GroundMessage pos) >>= \case - Empty -> say_ ["read", "nothing"] - GroundMessage msg :< Empty -> - say ["read", "result"] $ object ["message" A..= msg] - msgs -> - let readAndContinue Empty = pure () - readAndContinue (msg :< msgs') = - prompt @'Continue - ["read", "result"] - (object ["message" A..= msg]) - Cancellable - . const - $ readAndContinue msgs' - readAndContinue _ = error "this is total" - in readAndContinue msgs - continue - -handleCommand ShowInventory = showPanel InventoryPanel >> continue - -handleCommand Wield = do - selectItemFromInventory_ ["wield", "menu"] Cancellable asWieldedItem - (say_ ["wield", "nothing"]) - $ \(MenuResult item) -> do - prevItems <- character . inventory . wielded <<.= inRightHand item - character . inventory . backpack - <>= fromList (prevItems ^.. wieldedItems . wieldedItem) - say ["wield", "wielded"] item - continue - -handleCommand Save = do - -- TODO default save locations / config file? - prompt_ @'StringPrompt ["save", "location"] Cancellable - $ \(StringResult filename) -> do - exists <- liftIO . doesFileExist $ unpack filename - if exists - then confirm ["save", "overwrite"] (object ["filename" A..= filename]) - $ doSave filename - else doSave filename - continue - where - doSave filename = do - src <- gets saveGame - lift . liftIO $ do - writeFile (unpack filename) $ toStrict src - exitSuccess - -handleCommand GoUp = do - hasStairs <- uses entitiesAtCharacter $ elem (SomeEntity UpStaircase) - if hasStairs - then uses levels prevLevel >>= \case - Just levs' -> levels .= levs' - Nothing -> - -- TODO in nethack, this leaves the game. Maybe something similar here? - say_ ["cant", "goUp"] - else say_ ["cant", "goUp"] - - continue - -handleCommand GoDown = do - hasStairs <- uses entitiesAtCharacter $ elem (SomeEntity DownStaircase) - - if hasStairs - then do - levs <- use levels - let newLevelNum = Levels.pos levs + 1 - levs' <- nextLevel (levelToGameLevel <$> genLevel newLevelNum) levs - cEID <- use characterEntityID - pCharacter <- entities . at cEID <<.= Nothing - levels .= levs' - entities . at cEID .= pCharacter - characterPosition .= extract levs' ^. upStaircasePosition - else say_ ["cant", "goDown"] - - continue - -handleCommand (StartAutoMove dir) = do - runAutocommand $ AutoMove dir - continue - --- - -handleCommand ToggleRevealAll = do - val <- debugState . allRevealed <%= not - say ["debug", "toggleRevealAll"] $ object [ "revealAll" A..= val ] - continue - --------------------------------------------------------------------------------- -attackAt :: Position -> AppM () -attackAt pos = - uses entities (entitiesAtPositionWithType @Creature pos) >>= \case - Empty -> say_ ["combat", "nothingToAttack"] - (creature :< Empty) -> attackCreature creature - creatures -> - menu_ ["combat", "menu"] Cancellable (entityMenu_ creatures) - $ \(MenuResult creature) -> attackCreature creature - where - attackCreature (creatureID, creature) = do - charDamage <- uses character characterDamage - let creature' = Creature.damage charDamage creature - msgParams = object ["creature" A..= creature'] - if Creature.isDead creature' - then do - say ["combat", "killed"] msgParams - entities . at creatureID .= Nothing - else do - msg <- uses character getAttackMessage - message msg msgParams - entities . ix creatureID . positioned .= SomeEntity creature' - - whenM (uses character $ isNothing . weapon) - $ whenM (chance (0.08 :: Float)) $ do - say_ ["combat", "fistSelfDamage"] - character %= Character.damage 1 - - stepGame -- TODO - weapon chr = chr ^? inventory . wielded . wieldedItems . wieldableItem - getAttackMessage chr = - case weapon chr of - Just wi -> - fromMaybe (Messages.lookup ["combat", "hit", "generic"]) - $ wi ^. attackMessage - Nothing -> - Messages.lookup ["combat", "hit", "fists"] - -entityMenu_ - :: (Comonad w, Entity entity) - => [w entity] - -> Map Char (MenuOption (w entity)) -entityMenu_ = mkMenuItems @[_] . map entityMenuItem - where - entityMenuItem wentity - = let entity = extract wentity - in (entityMenuChar entity, MenuOption (description entity) wentity) - - -entityMenuChar :: Entity a => a -> Char -entityMenuChar entity - = let ec = entityChar entity ^. char - in if ec `elem` (['a'..'z'] ++ ['A'..'Z']) - then ec - else 'a' - --- | Prompt with an item to select out of the inventory, remove it from the --- inventory, and call callback with it -selectItemFromInventory - :: forall item params. - (ToJSON params) - => [Text] -- ^ Menu message - -> params -- ^ Menu message params - -> PromptCancellable -- ^ Is the menu cancellable? - -> Prism' Item item -- ^ Attach some extra information to the item, in a - -- recoverable fashion. Prism vs iso so we can discard - -- items. - -> AppM () -- ^ Action to take if there are no items matching - -> (PromptResult ('Menu item) -> AppM ()) - -> AppM () -selectItemFromInventory msgPath msgParams cancellable extraInfo onEmpty cb = - uses (character . inventory . backpack) - (V.mapMaybe $ preview extraInfo) - >>= \case - Empty -> onEmpty - items' -> - menu msgPath msgParams cancellable (itemMenu items') - $ \(MenuResult (idx, item)) -> do - character . inventory . backpack %= removeVectorIndex idx - cb $ MenuResult item - where - itemMenu = mkMenuItems . imap itemMenuItem - itemMenuItem idx extraInfoItem = - let item = extraInfo # extraInfoItem - in ( entityMenuChar item - , MenuOption (description item) (idx, extraInfoItem)) - -selectItemFromInventory_ - :: forall item. - [Text] -- ^ Menu message - -> PromptCancellable -- ^ Is the menu cancellable? - -> Prism' Item item -- ^ Attach some extra information to the item, in a - -- recoverable fashion. Prism vs iso so we can discard - -- items. - -> AppM () -- ^ Action to take if there are no items matching - -> (PromptResult ('Menu item) -> AppM ()) - -> AppM () -selectItemFromInventory_ msgPath = selectItemFromInventory msgPath () - --- entityMenu :: Entity entity => [entity] -> Map Char (MenuOption entity) --- entityMenu = map (map runIdentity) . entityMenu_ . fmap Identity - -showPanel :: Panel -> AppM () -showPanel panel = do - activePanel ?= panel - prompt_ @'Continue ["generic", "continue"] Uncancellable - . const - $ activePanel .= Nothing - --------------------------------------------------------------------------------- - -genLevel - :: Int -- ^ level number - -> AppM Level -genLevel _num = do - let dims = Dimensions 80 80 - generator <- choose $ CaveAutomata :| [Dungeon] - level <- case generator of - CaveAutomata -> generateLevel SCaveAutomata CaveAutomata.defaultParams dims - Dungeon -> generateLevel SDungeon Dungeon.defaultParams dims - pure $!! level - -levelToGameLevel :: Level -> GameLevel -levelToGameLevel level = - let _levelEntities = levelToEntityMap level - _upStaircasePosition = level ^. levelCharacterPosition - _levelRevealedPositions = mempty - in GameLevel {..} diff --git a/users/glittershark/xanthous/src/Xanthous/App/Autocommands.hs b/users/glittershark/xanthous/src/Xanthous/App/Autocommands.hs deleted file mode 100644 index f393a0e2ea..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/App/Autocommands.hs +++ /dev/null @@ -1,64 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.App.Autocommands - ( runAutocommand - , autoStep - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Control.Concurrent (threadDelay) -import qualified Data.Aeson as A -import Data.Aeson (object) -import Data.List.NonEmpty (nonEmpty) -import qualified Data.List.NonEmpty as NE -import Control.Monad.State (gets) --------------------------------------------------------------------------------- -import Xanthous.App.Common -import Xanthous.App.Time -import Xanthous.Data -import Xanthous.Data.App -import Xanthous.Entities.Character (speed) -import Xanthous.Entities.Creature (Creature, creatureType) -import Xanthous.Entities.RawTypes (hostile) -import Xanthous.Game.State --------------------------------------------------------------------------------- - -autoStep :: Autocommand -> AppM () -autoStep (AutoMove dir) = do - newPos <- uses characterPosition $ move dir - collisionAt newPos >>= \case - Nothing -> do - characterPosition .= newPos - stepGameBy =<< uses (character . speed) (|*| 1) - describeEntitiesAt newPos - maybeVisibleEnemies <- nonEmpty <$> enemiesInSight - for_ maybeVisibleEnemies $ \visibleEnemies -> do - say ["autoMove", "enemyInSight"] - $ object [ "firstEntity" A..= NE.head visibleEnemies ] - cancelAutocommand - Just _ -> cancelAutocommand - where - enemiesInSight :: AppM [Creature] - enemiesInSight = do - ents <- gets characterVisibleEntities - pure $ ents - ^.. folded - . _SomeEntity @Creature - . filtered (view $ creatureType . hostile) - --------------------------------------------------------------------------------- - -autocommandIntervalμs :: Int -autocommandIntervalμs = 1000 * 50 -- 50 ms - -runAutocommand :: Autocommand -> AppM () -runAutocommand ac = do - env <- ask - tid <- liftIO . async $ runReaderT go env - autocommand .= ActiveAutocommand ac tid - where - go = everyμs autocommandIntervalμs $ sendEvent AutoContinue - --- | Perform 'act' every μs microseconds forever -everyμs :: MonadIO m => Int -> m () -> m () -everyμs μs act = act >> liftIO (threadDelay μs) >> everyμs μs act diff --git a/users/glittershark/xanthous/src/Xanthous/App/Common.hs b/users/glittershark/xanthous/src/Xanthous/App/Common.hs deleted file mode 100644 index 69ba6f0e05..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/App/Common.hs +++ /dev/null @@ -1,67 +0,0 @@ --------------------------------------------------------------------------------- -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 deleted file mode 100644 index 9b5a3bf24f..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/App/Prompt.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} --------------------------------------------------------------------------------- -module Xanthous.App.Prompt - ( handlePromptEvent - , clearPrompt - , prompt - , prompt_ - , confirm_ - , confirm - , menu - , menu_ - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Brick (BrickEvent(..), Next) -import Brick.Widgets.Edit (handleEditorEvent) -import Data.Aeson (ToJSON, object) -import Graphics.Vty.Input.Events (Event(EvKey), Key(..)) -import GHC.TypeLits (ErrorMessage(..)) --------------------------------------------------------------------------------- -import Xanthous.App.Common -import Xanthous.Data (move) -import Xanthous.Command (directionFromChar) -import Xanthous.Data.App (ResourceName, AppEvent) -import Xanthous.Game.Prompt -import Xanthous.Game.State -import qualified Xanthous.Messages as Messages --------------------------------------------------------------------------------- - -handlePromptEvent - :: Text -- ^ Prompt message - -> Prompt AppM - -> BrickEvent ResourceName AppEvent - -> AppM (Next GameState) - -handlePromptEvent _ (Prompt Cancellable _ _ _ _) (VtyEvent (EvKey KEsc [])) - = clearPrompt >> continue -handlePromptEvent _ pr (VtyEvent (EvKey KEnter [])) - = clearPrompt >> submitPrompt pr >> continue - -handlePromptEvent _ pr@(Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'y') [])) - = clearPrompt >> submitPrompt pr >> continue - -handlePromptEvent _ (Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'n') [])) - = clearPrompt >> continue - -handlePromptEvent - msg - (Prompt c SStringPrompt (StringPromptState edit) pri cb) - (VtyEvent ev) - = do - edit' <- lift $ handleEditorEvent ev edit - let prompt' = Prompt c SStringPrompt (StringPromptState edit') pri cb - promptState .= WaitingPrompt msg prompt' - continue - -handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ cb) - (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) [])) - = clearPrompt >> cb (DirectionResult dir) >> continue -handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ _) _ = continue - -handlePromptEvent _ (Prompt _ SMenu _ items' cb) (VtyEvent (EvKey (KChar chr) [])) - | Just (MenuOption _ res) <- items' ^. at chr - = clearPrompt >> cb (MenuResult res) >> continue - | otherwise - = continue - -handlePromptEvent - msg - (Prompt c SPointOnMap (PointOnMapPromptState pos) pri cb) - (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) [])) - = let pos' = move dir pos - prompt' = Prompt c SPointOnMap (PointOnMapPromptState pos') pri cb - in promptState .= WaitingPrompt msg prompt' - >> continue -handlePromptEvent _ (Prompt _ SPointOnMap _ _ _) _ = continue - -handlePromptEvent - _ - (Prompt Cancellable _ _ _ _) - (VtyEvent (EvKey (KChar 'q') [])) - = clearPrompt >> continue -handlePromptEvent _ _ _ = continue - -clearPrompt :: AppM () -clearPrompt = promptState .= NoPrompt - -class NotMenu (pt :: PromptType) -instance NotMenu 'StringPrompt -instance NotMenu 'Confirm -instance NotMenu 'DirectionPrompt -instance NotMenu 'PointOnMap -instance NotMenu 'Continue -instance TypeError ('Text "Cannot use `prompt` or `prompt_` for menu prompts" - ':$$: 'Text "Use `menu` or `menu_` instead") - => NotMenu ('Menu a) - -prompt - :: forall (pt :: PromptType) (params :: Type). - (ToJSON params, SingPromptType pt, NotMenu pt) - => [Text] -- ^ Message key - -> params -- ^ Message params - -> PromptCancellable - -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler - -> AppM () -prompt msgPath params cancellable cb = do - let pt = singPromptType @pt - msg <- Messages.message msgPath params - p <- case pt of - SPointOnMap -> do - charPos <- use characterPosition - pure $ mkPointOnMapPrompt cancellable charPos cb - SStringPrompt -> pure $ mkPrompt cancellable pt cb - SConfirm -> pure $ mkPrompt cancellable pt cb - SDirectionPrompt -> pure $ mkPrompt cancellable pt cb - SContinue -> pure $ mkPrompt cancellable pt cb - SMenu -> error "unreachable" - promptState .= WaitingPrompt msg p - -prompt_ - :: forall (pt :: PromptType). - (SingPromptType pt, NotMenu pt) - => [Text] -- ^ Message key - -> PromptCancellable - -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler - -> AppM () -prompt_ msg = prompt msg $ object [] - -confirm - :: ToJSON params - => [Text] -- ^ Message key - -> params - -> AppM () - -> AppM () -confirm msgPath params - = prompt @'Confirm msgPath params Cancellable . const - -confirm_ :: [Text] -> AppM () -> AppM () -confirm_ msgPath = confirm msgPath $ object [] - -menu :: forall (a :: Type) (params :: Type). - (ToJSON params) - => [Text] -- ^ Message key - -> params -- ^ Message params - -> PromptCancellable - -> Map Char (MenuOption a) -- ^ Menu items - -> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler - -> AppM () -menu msgPath params cancellable items' cb = do - msg <- Messages.message msgPath params - let p = mkMenu cancellable items' cb - promptState .= WaitingPrompt msg p - -menu_ :: forall (a :: Type). - [Text] -- ^ Message key - -> PromptCancellable - -> Map Char (MenuOption a) -- ^ Menu items - -> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler - -> AppM () -menu_ msgPath = menu msgPath $ object [] diff --git a/users/glittershark/xanthous/src/Xanthous/App/Time.hs b/users/glittershark/xanthous/src/Xanthous/App/Time.hs deleted file mode 100644 index b17348f385..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/App/Time.hs +++ /dev/null @@ -1,40 +0,0 @@ --------------------------------------------------------------------------------- -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 deleted file mode 100644 index 37025dd37a..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Command.hs +++ /dev/null @@ -1,73 +0,0 @@ --------------------------------------------------------------------------------- -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 deleted file mode 100644 index c9c11b553b..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Data.hs +++ /dev/null @@ -1,590 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE NoTypeSynonymInstances #-} -{-# LANGUAGE DuplicateRecordFields #-} --------------------------------------------------------------------------------- --- | Common data types for Xanthous --------------------------------------------------------------------------------- -module Xanthous.Data - ( Opposite(..) - - -- * - , Position'(..) - , Position - , x - , y - - -- ** - , Positioned(..) - , _Positioned - , position - , positioned - , loc - , _Position - , positionFromPair - , positionFromV2 - , addPositions - , diffPositions - , stepTowards - , isUnit - - -- * Boxes - , Box(..) - , topLeftCorner - , bottomRightCorner - , setBottomRightCorner - , dimensions - , inBox - , boxIntersects - , boxCenter - , boxEdge - , module Linear.V2 - - -- * - , Per(..) - , invertRate - , invertedRate - , (|*|) - , Ticks(..) - , Tiles(..) - , TicksPerTile - , TilesPerTick - , timesTiles - - -- * - , Dimensions'(..) - , Dimensions - , HasWidth(..) - , HasHeight(..) - - -- * - , Direction(..) - , move - , asPosition - , directionOf - , Cardinal(..) - - -- * - , Corner(..) - , Edge(..) - , cornerEdges - - -- * - , Neighbors(..) - , edges - , neighborDirections - , neighborPositions - , neighborCells - , arrayNeighbors - , rotations - , HasTopLeft(..) - , HasTop(..) - , HasTopRight(..) - , HasLeft(..) - , HasRight(..) - , HasBottomLeft(..) - , HasBottom(..) - , HasBottomRight(..) - - -- * - , Hitpoints(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (Left, Down, Right, (.=), elements) --------------------------------------------------------------------------------- -import Linear.V2 hiding (_x, _y) -import qualified Linear.V2 as L -import Linear.V4 hiding (_x, _y) -import Test.QuickCheck (CoArbitrary, Function, elements) -import Test.QuickCheck.Arbitrary.Generic -import Data.Group -import Brick (Location(Location), Edges(..)) -import Data.Monoid (Product(..), Sum(..)) -import Data.Array.IArray -import Data.Aeson.Generic.DerivingVia -import Data.Aeson - ( ToJSON(..), FromJSON(..), object, (.=), (.:), withObject) --------------------------------------------------------------------------------- -import Xanthous.Util (EqEqProp(..), EqProp, between) -import Xanthous.Util.QuickCheck (GenericArbitrary(..)) -import Xanthous.Orphans () -import Xanthous.Util.Graphics --------------------------------------------------------------------------------- - --- | opposite ∘ opposite ≡ id -class Opposite x where - opposite :: x -> x - --------------------------------------------------------------------------------- - --- fromScalar ∘ scalar ≡ id -class Scalar a where - scalar :: a -> Double - fromScalar :: Double -> a - -instance Scalar Double where - scalar = id - fromScalar = id - -newtype ScalarIntegral a = ScalarIntegral a - deriving newtype (Eq, Ord, Num, Enum, Real, Integral) -instance Integral a => Scalar (ScalarIntegral a) where - scalar = fromIntegral - fromScalar = floor - -deriving via (ScalarIntegral Integer) instance Scalar Integer -deriving via (ScalarIntegral Word) instance Scalar Word - --------------------------------------------------------------------------------- - -data Position' a where - Position :: { _x :: a - , _y :: a - } -> (Position' a) - deriving stock (Show, Eq, Generic, Ord, Functor, Foldable, Traversable) - deriving anyclass (NFData, Hashable, CoArbitrary, Function) - deriving EqProp via EqEqProp (Position' a) - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - (Position' a) - -x, y :: Lens' (Position' a) a -x = lens (\(Position xx _) -> xx) (\(Position _ yy) xx -> Position xx yy) -y = lens (\(Position _ yy) -> yy) (\(Position xx _) yy -> Position xx yy) - -type Position = Position' Int - -instance Arbitrary a => Arbitrary (Position' a) where - arbitrary = genericArbitrary - shrink (Position px py) = Position <$> shrink px <*> shrink py - - -instance Num a => Semigroup (Position' a) where - (Position x₁ y₁) <> (Position x₂ y₂) = Position (x₁ + x₂) (y₁ + y₂) - -instance Num a => Monoid (Position' a) where - mempty = Position 0 0 - -instance Num a => Group (Position' a) where - invert (Position px py) = Position (negate px) (negate py) - --- | Positions convert to scalars by discarding their orientation and just --- measuring the length from the origin -instance (Ord a, Num a, Scalar a) => Scalar (Position' a) where - scalar = fromIntegral . length . line 0 . view _Position - fromScalar n = Position (fromScalar n) (fromScalar n) - -data Positioned a where - Positioned :: Position -> a -> Positioned a - deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) - deriving anyclass (NFData, CoArbitrary, Function) -type role Positioned representational - -_Positioned :: Iso (Position, a) (Position, b) (Positioned a) (Positioned b) -_Positioned = iso hither yon - where - hither (pos, a) = Positioned pos a - yon (Positioned pos b) = (pos, b) - -instance Arbitrary a => Arbitrary (Positioned a) where - arbitrary = Positioned <$> arbitrary <*> arbitrary - -instance ToJSON a => ToJSON (Positioned a) where - toJSON (Positioned pos val) = object - [ "position" .= pos - , "data" .= val - ] - -instance FromJSON a => FromJSON (Positioned a) where - parseJSON = withObject "Positioned" $ \obj -> - Positioned <$> obj .: "position" <*> obj .: "data" - -position :: Lens' (Positioned a) Position -position = lens - (\(Positioned pos _) -> pos) - (\(Positioned _ a) pos -> Positioned pos a) - -positioned :: Lens (Positioned a) (Positioned b) a b -positioned = lens - (\(Positioned _ x') -> x') - (\(Positioned pos _) x' -> Positioned pos x') - -loc :: Iso' Position Location -loc = iso hither yon - where - hither (Position px py) = Location (px, py) - yon (Location (lx, ly)) = Position lx ly - -_Position :: Iso' (Position' a) (V2 a) -_Position = iso hither yon - where - hither (Position px py) = (V2 px py) - yon (V2 lx ly) = Position lx ly - -positionFromPair :: (Num a, Integral i, Integral j) => (i, j) -> Position' a -positionFromPair (i, j) = Position (fromIntegral i) (fromIntegral j) - -positionFromV2 :: (Num a, Integral i) => V2 i -> Position' a -positionFromV2 (V2 xx yy) = Position (fromIntegral xx) (fromIntegral yy) - --- | Add two positions --- --- Operation for the additive group on positions -addPositions :: Num a => Position' a -> Position' a -> Position' a -addPositions = (<>) - --- | Subtract two positions. --- --- diffPositions pos₁ pos₂ = pos₁ `addPositions` (invert pos₂) -diffPositions :: Num a => Position' a -> Position' a -> Position' a -diffPositions (Position x₁ y₁) (Position x₂ y₂) = Position (x₁ - x₂) (y₁ - y₂) - --- | Is this position a unit position? or: When taken as a difference, does this --- position represent a step of one tile? --- --- ∀ dir :: Direction. isUnit ('asPosition' dir) -isUnit :: (Eq a, Num a) => Position' a -> Bool -isUnit (Position px py) = - abs px `elem` [0,1] && abs py `elem` [0, 1] && (px, py) /= (0, 0) - --------------------------------------------------------------------------------- - -data Dimensions' a = Dimensions - { _width :: a - , _height :: a - } - deriving stock (Show, Eq, Functor, Generic) - deriving anyclass (CoArbitrary, Function) -makeFieldsNoPrefix ''Dimensions' - -instance Arbitrary a => Arbitrary (Dimensions' a) where - arbitrary = Dimensions <$> arbitrary <*> arbitrary - -type Dimensions = Dimensions' Word - --------------------------------------------------------------------------------- - -data Direction where - Up :: Direction - Down :: Direction - Left :: Direction - Right :: Direction - UpLeft :: Direction - UpRight :: Direction - DownLeft :: Direction - DownRight :: Direction - Here :: Direction - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (CoArbitrary, Function, NFData, ToJSON, FromJSON, Hashable) - deriving Arbitrary via GenericArbitrary Direction - -instance Opposite Direction where - opposite Up = Down - opposite Down = Up - opposite Left = Right - opposite Right = Left - opposite UpLeft = DownRight - opposite UpRight = DownLeft - opposite DownLeft = UpRight - opposite DownRight = UpLeft - opposite Here = Here - -move :: Num a => Direction -> Position' a -> Position' a -move Up = y -~ 1 -move Down = y +~ 1 -move Left = x -~ 1 -move Right = x +~ 1 -move UpLeft = move Up . move Left -move UpRight = move Up . move Right -move DownLeft = move Down . move Left -move DownRight = move Down . move Right -move Here = id - -asPosition :: Direction -> Position -asPosition dir = move dir mempty - --- | Returns the direction that a given position is from a given source position -directionOf - :: Position -- ^ Source - -> Position -- ^ Target - -> Direction -directionOf (Position x₁ y₁) (Position x₂ y₂) = - case (x₁ `compare` x₂, y₁ `compare` y₂) of - (EQ, EQ) -> Here - (EQ, LT) -> Down - (EQ, GT) -> Up - (LT, EQ) -> Right - (GT, EQ) -> Left - - (LT, LT) -> DownRight - (GT, LT) -> DownLeft - - (LT, GT) -> UpRight - (GT, GT) -> UpLeft - --- | Take one (potentially diagonal) step towards the given position --- --- ∀ src tgt. isUnit (src `diffPositions` (src `stepTowards tgt`)) -stepTowards - :: Position -- ^ Source - -> Position -- ^ Target - -> Position -stepTowards (view _Position -> p₁) (view _Position -> p₂) - | p₁ == p₂ = _Position # p₁ - | otherwise = - let (_:p:_) = line p₁ p₂ - in _Position # p - --- | Newtype controlling arbitrary generation to only include cardinal --- directions ('Up', 'Down', 'Left', 'Right') -newtype Cardinal = Cardinal { getCardinal :: Direction } - deriving stock (Eq, Show, Ord, Generic) - deriving anyclass (NFData, Function, CoArbitrary) - deriving newtype (Opposite) - -instance Arbitrary Cardinal where - arbitrary = Cardinal <$> elements [Up, Down, Left, Right] - --------------------------------------------------------------------------------- - -data Corner - = TopLeft - | TopRight - | BottomLeft - | BottomRight - deriving stock (Show, Eq, Ord, Enum, Bounded, Generic) - deriving Arbitrary via GenericArbitrary Corner - -instance Opposite Corner where - opposite TopLeft = BottomRight - opposite TopRight = BottomLeft - opposite BottomLeft = TopRight - opposite BottomRight = TopLeft - -data Edge - = TopEdge - | LeftEdge - | RightEdge - | BottomEdge - deriving stock (Show, Eq, Ord, Enum, Bounded, Generic) - deriving Arbitrary via GenericArbitrary Edge - -instance Opposite Edge where - opposite TopEdge = BottomEdge - opposite BottomEdge = TopEdge - opposite LeftEdge = RightEdge - opposite RightEdge = LeftEdge - -cornerEdges :: Corner -> (Edge, Edge) -cornerEdges TopLeft = (TopEdge, LeftEdge) -cornerEdges TopRight = (TopEdge, RightEdge) -cornerEdges BottomLeft = (BottomEdge, LeftEdge) -cornerEdges BottomRight = (BottomEdge, RightEdge) - --------------------------------------------------------------------------------- - -data Neighbors a = Neighbors - { _topLeft - , _top - , _topRight - , _left - , _right - , _bottomLeft - , _bottom - , _bottomRight :: a - } - deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) - deriving anyclass (NFData, CoArbitrary, Function, MonoFoldable) - deriving Arbitrary via GenericArbitrary (Neighbors a) - -type instance Element (Neighbors a) = a - -makeFieldsNoPrefix ''Neighbors - -instance Applicative Neighbors where - pure α = Neighbors - { _topLeft = α - , _top = α - , _topRight = α - , _left = α - , _right = α - , _bottomLeft = α - , _bottom = α - , _bottomRight = α - } - nf <*> nx = Neighbors - { _topLeft = nf ^. topLeft $ nx ^. topLeft - , _top = nf ^. top $ nx ^. top - , _topRight = nf ^. topRight $ nx ^. topRight - , _left = nf ^. left $ nx ^. left - , _right = nf ^. right $ nx ^. right - , _bottomLeft = nf ^. bottomLeft $ nx ^. bottomLeft - , _bottom = nf ^. bottom $ nx ^. bottom - , _bottomRight = nf ^. bottomRight $ nx ^. bottomRight - } - -edges :: Neighbors a -> Edges a -edges neighs = Edges - { eTop = neighs ^. top - , eBottom = neighs ^. bottom - , eLeft = neighs ^. left - , eRight = neighs ^. right - } - -neighborDirections :: Neighbors Direction -neighborDirections = Neighbors - { _topLeft = UpLeft - , _top = Up - , _topRight = UpRight - , _left = Left - , _right = Right - , _bottomLeft = DownLeft - , _bottom = Down - , _bottomRight = DownRight - } - -neighborPositions :: Num a => Position' a -> Neighbors (Position' a) -neighborPositions pos = (`move` pos) <$> neighborDirections - -neighborCells :: Num a => V2 a -> Neighbors (V2 a) -neighborCells = map (view _Position) . neighborPositions . review _Position - -arrayNeighbors - :: (IArray a e, Ix i, Num i) - => a (V2 i) e - -> V2 i - -> Neighbors (Maybe e) -arrayNeighbors arr center = arrLookup <$> neighborPositions (_Position # center) - where - arrLookup (view _Position -> pos) - | inRange (bounds arr) pos = Just $ arr ! pos - | otherwise = Nothing - --- | Returns a list of all 4 90-degree rotations of the given neighbors -rotations :: Neighbors a -> V4 (Neighbors a) -rotations orig@(Neighbors tl t tr l r bl b br) = V4 - orig -- tl t tr - -- l r - -- bl b br - - (Neighbors bl l tl b t br r tr) -- bl l tl - -- b t - -- br r tr - - (Neighbors br b bl r l tr t tl) -- br b bl - -- r l - -- tr t tl - - (Neighbors tr r br t b tl l bl) -- tr r br - -- t b - -- tl l bl - --------------------------------------------------------------------------------- - -newtype Per a b = Rate Double - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving (Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON) via Double - deriving (Semigroup, Monoid) via Product Double -instance Arbitrary (Per a b) where arbitrary = genericArbitrary - -invertRate :: a `Per` b -> b `Per` a -invertRate (Rate p) = Rate $ 1 / p - -invertedRate :: Iso (a `Per` b) (b' `Per` a') (b `Per` a) (a' `Per` b') -invertedRate = iso invertRate invertRate - -infixl 7 |*| -(|*|) :: (Scalar a, Scalar b) => a `Per` b -> b -> a -(|*|) (Rate rate) b = fromScalar $ rate * scalar b - -newtype Ticks = Ticks Word - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving (Num, Ord, Bounded, Enum, Integral, Real, ToJSON, FromJSON) via Word - deriving (Semigroup, Monoid) via (Sum Word) - deriving Scalar via ScalarIntegral Ticks -instance Arbitrary Ticks where arbitrary = genericArbitrary - -newtype Tiles = Tiles Double - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving (Num, Ord, Enum, Real, ToJSON, FromJSON, Scalar) via Double - deriving (Semigroup, Monoid) via (Sum Double) -instance Arbitrary Tiles where arbitrary = genericArbitrary - -type TicksPerTile = Ticks `Per` Tiles -type TilesPerTick = Tiles `Per` Ticks - -timesTiles :: TicksPerTile -> Tiles -> Ticks -timesTiles = (|*|) - --------------------------------------------------------------------------------- - -newtype Hitpoints = Hitpoints Word - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving (Arbitrary, Num, Ord, Bounded, Enum, Integral, Real, ToJSON, FromJSON) - via Word - deriving (Semigroup, Monoid) via Sum Word - --------------------------------------------------------------------------------- - -data Box a = Box - { _topLeftCorner :: V2 a - , _dimensions :: V2 a - } - deriving stock (Show, Eq, Ord, Functor, Generic) - deriving Arbitrary via GenericArbitrary (Box a) -makeFieldsNoPrefix ''Box - -bottomRightCorner :: Num a => Box a -> V2 a -bottomRightCorner box = - V2 (box ^. topLeftCorner . L._x + box ^. dimensions . L._x) - (box ^. topLeftCorner . L._y + box ^. dimensions . L._y) - -setBottomRightCorner :: (Num a, Ord a) => Box a -> V2 a -> Box a -setBottomRightCorner box br@(V2 brx bry) - | brx < box ^. topLeftCorner . L._x || bry < box ^. topLeftCorner . L._y - = box & topLeftCorner .~ br - & dimensions . L._x .~ ((box ^. topLeftCorner . L._x) - brx) - & dimensions . L._y .~ ((box ^. topLeftCorner . L._y) - bry) - | otherwise - = box & dimensions . L._x .~ (brx - (box ^. topLeftCorner . L._x)) - & dimensions . L._y .~ (bry - (box ^. topLeftCorner . L._y)) - -inBox :: (Ord a, Num a) => Box a -> V2 a -> Bool -inBox box pt = flip all [L._x, L._y] $ \component -> - between (box ^. topLeftCorner . component) - (box ^. to bottomRightCorner . component) - (pt ^. component) - -boxIntersects :: (Ord a, Num a) => Box a -> Box a -> Bool -boxIntersects box₁ box₂ - = any (inBox box₁) [box₂ ^. topLeftCorner, bottomRightCorner box₂] - -boxCenter :: (Fractional a) => Box a -> V2 a -boxCenter box = V2 cx cy - where - cx = box ^. topLeftCorner . L._x + (box ^. dimensions . L._x / 2) - cy = box ^. topLeftCorner . L._y + (box ^. dimensions . L._y / 2) - -boxEdge :: (Enum a, Num a) => Box a -> Edge -> [V2 a] -boxEdge box LeftEdge = - V2 (box ^. topLeftCorner . L._x) - <$> [box ^. topLeftCorner . L._y .. box ^. to bottomRightCorner . L._y] -boxEdge box RightEdge = - V2 (box ^. to bottomRightCorner . L._x) - <$> [box ^. to bottomRightCorner . L._y .. box ^. to bottomRightCorner . L._y] -boxEdge box TopEdge = - flip V2 (box ^. topLeftCorner . L._y) - <$> [box ^. topLeftCorner . L._x .. box ^. to bottomRightCorner . L._x] -boxEdge box BottomEdge = - flip V2 (box ^. to bottomRightCorner . L._y) - <$> [box ^. topLeftCorner . L._x .. box ^. to bottomRightCorner . L._x] diff --git a/users/glittershark/xanthous/src/Xanthous/Data/App.hs b/users/glittershark/xanthous/src/Xanthous/Data/App.hs deleted file mode 100644 index 0361d2a59e..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Data/App.hs +++ /dev/null @@ -1,39 +0,0 @@ --------------------------------------------------------------------------------- -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 deleted file mode 100644 index 39953410f2..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Data/Entities.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# 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 deleted file mode 100644 index 855a3462da..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Data/EntityChar.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# 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 deleted file mode 100644 index d24defa841..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Data/EntityMap.hs +++ /dev/null @@ -1,272 +0,0 @@ -{-# 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 deleted file mode 100644 index 19e7b0cdf0..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs +++ /dev/null @@ -1,64 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Data.EntityMap.Graphics - ( visiblePositions - , visibleEntities - , linesOfSight - , canSee - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (lines) --------------------------------------------------------------------------------- -import Xanthous.Util (takeWhileInclusive) -import Xanthous.Data -import Xanthous.Data.Entities -import Xanthous.Data.EntityMap -import Xanthous.Game.State -import Xanthous.Util.Graphics (circle, line) --------------------------------------------------------------------------------- - --- | Returns a set of positions that are visible, when taking into account --- 'blocksVision', from the given position, within the given radius. -visiblePositions - :: Entity e - => Position - -> Word -- ^ Vision radius - -> EntityMap e - -> Set Position -visiblePositions pos radius - = setFromList . positions . visibleEntities pos radius - --- | Returns a list of individual lines of sight, each of which is a list of --- entities at positions on that line of sight -linesOfSight - :: forall e. Entity e - => Position - -> Word - -> EntityMap e - -> [[(Position, Vector (EntityID, e))]] -linesOfSight (view _Position -> pos) visionRadius em - = entitiesOnLines - <&> takeWhileInclusive - (none (view blocksVision . entityAttributes . snd) . snd) - where - radius = circle pos $ fromIntegral visionRadius - lines = line pos <$> radius - entitiesOnLines :: [[(Position, Vector (EntityID, e))]] - entitiesOnLines = lines <&> map getPositionedAt - getPositionedAt :: V2 Int -> (Position, Vector (EntityID, e)) - getPositionedAt p = - let ppos = _Position # p - in (ppos, over _2 (view positioned) <$> atPositionWithIDs ppos em) - --- | Given a point and a radius of vision, returns a list of all entities that --- are *visible* (eg, not blocked by an entity that obscures vision) from that --- point -visibleEntities :: Entity e => Position -> Word -> EntityMap e -> EntityMap e -visibleEntities pos visionRadius - = fromEIDsAndPositioned - . foldMap (\(p, es) -> over _2 (Positioned p) <$> es) - . fold - . linesOfSight pos visionRadius - -canSee :: Entity e => (e -> Bool) -> Position -> Word -> EntityMap e -> Bool -canSee match pos radius = any match . visibleEntities pos radius --- ^ this might be optimizable diff --git a/users/glittershark/xanthous/src/Xanthous/Data/Levels.hs b/users/glittershark/xanthous/src/Xanthous/Data/Levels.hs deleted file mode 100644 index efc0f53ace..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Data/Levels.hs +++ /dev/null @@ -1,170 +0,0 @@ -{-# 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 deleted file mode 100644 index 1b875d4483..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Data/NestedMap.hs +++ /dev/null @@ -1,227 +0,0 @@ -{-# 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 deleted file mode 100644 index 2e6d48062a..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Data/VectorBag.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Data.VectorBag - (VectorBag(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude -import Data.Aeson -import qualified Data.Vector as V -import Test.QuickCheck -import Test.QuickCheck.Instances.Vector () --------------------------------------------------------------------------------- - --- | Acts exactly like a Vector, except ignores order when testing for equality -newtype VectorBag a = VectorBag (Vector a) - deriving stock - ( Traversable - , Generic - ) - deriving newtype - ( Show - , Read - , Foldable - , FromJSON - , FromJSON1 - , ToJSON - , Reversing - , Applicative - , Functor - , Monad - , Monoid - , Semigroup - , Arbitrary - , CoArbitrary - , Filterable - ) -makeWrapped ''VectorBag - -instance Function a => Function (VectorBag a) where - function = functionMap (\(VectorBag v) -> v) VectorBag - -type instance Element (VectorBag a) = a -deriving via (Vector a) instance MonoFoldable (VectorBag a) -deriving via (Vector a) instance GrowingAppend (VectorBag a) -deriving via (Vector a) instance SemiSequence (VectorBag a) -deriving via (Vector a) instance MonoPointed (VectorBag a) -deriving via (Vector a) instance MonoFunctor (VectorBag a) - -instance Cons (VectorBag a) (VectorBag b) a b where - _Cons = prism (\(x, VectorBag xs) -> VectorBag $ x <| xs) $ \(VectorBag v) -> - if V.null v - then Left (VectorBag mempty) - else Right (V.unsafeHead v, VectorBag $ V.unsafeTail v) - -instance AsEmpty (VectorBag a) where - _Empty = prism' (const $ VectorBag Empty) $ \case - (VectorBag Empty) -> Just () - _ -> Nothing - -instance Witherable VectorBag where - wither f (VectorBag v) = VectorBag <$> wither f v - witherM f (VectorBag v) = VectorBag <$> witherM f v - filterA p (VectorBag v) = VectorBag <$> filterA p v - -{- - TODO: - , Ixed - , FoldableWithIndex - , FunctorWithIndex - , TraversableWithIndex - , Snoc - , Each --} - -instance Ord a => Eq (VectorBag a) where - (==) = (==) `on` (view _Wrapped . sort) - -instance Ord a => Ord (VectorBag a) where - compare = compare `on` (view _Wrapped . sort) - -instance MonoTraversable (VectorBag a) where - otraverse f (VectorBag v) = VectorBag <$> otraverse f v - -instance IsSequence (VectorBag a) where - fromList = VectorBag . fromList - break prd (VectorBag v) = bimap VectorBag VectorBag $ break prd v - span prd (VectorBag v) = bimap VectorBag VectorBag $ span prd v - dropWhile prd (VectorBag v) = VectorBag $ dropWhile prd v - takeWhile prd (VectorBag v) = VectorBag $ takeWhile prd v - splitAt idx (VectorBag v) = bimap VectorBag VectorBag $ splitAt idx v - unsafeSplitAt idx (VectorBag v) = - bimap VectorBag VectorBag $ unsafeSplitAt idx v - take n (VectorBag v) = VectorBag $ take n v - unsafeTake n (VectorBag v) = VectorBag $ unsafeTake n v - drop n (VectorBag v) = VectorBag $ drop n v - unsafeDrop n (VectorBag v) = VectorBag $ unsafeDrop n v - partition p (VectorBag v) = bimap VectorBag VectorBag $ partition p v diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Character.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Character.hs deleted file mode 100644 index c18d726a4b..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/Character.hs +++ /dev/null @@ -1,276 +0,0 @@ -{-# 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 deleted file mode 100644 index e95e9f0b98..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/Creature.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# 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 deleted file mode 100644 index 501a5b5972..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# 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 deleted file mode 100644 index aa6c5fa4fc..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/Draw/Util.hs +++ /dev/null @@ -1,31 +0,0 @@ -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 deleted file mode 100644 index a0c037a1b4..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --------------------------------------------------------------------------------- -module Xanthous.Entities.Entities () where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Test.QuickCheck -import qualified Test.QuickCheck.Gen as Gen -import Data.Aeson --------------------------------------------------------------------------------- -import Xanthous.Entities.Character -import Xanthous.Entities.Item -import Xanthous.Entities.Creature -import Xanthous.Entities.Environment -import Xanthous.Entities.Marker -import Xanthous.Game.State -import Xanthous.Util.QuickCheck -import Data.Aeson.Generic.DerivingVia --------------------------------------------------------------------------------- - -instance Arbitrary SomeEntity where - arbitrary = Gen.oneof - [ SomeEntity <$> arbitrary @Character - , SomeEntity <$> arbitrary @Item - , SomeEntity <$> arbitrary @Creature - , SomeEntity <$> arbitrary @Wall - , SomeEntity <$> arbitrary @Door - , SomeEntity <$> arbitrary @GroundMessage - , SomeEntity <$> arbitrary @Staircase - , SomeEntity <$> arbitrary @Marker - ] - -instance FromJSON SomeEntity where - parseJSON = withObject "Entity" $ \obj -> do - (entityType :: Text) <- obj .: "type" - case entityType of - "Character" -> SomeEntity @Character <$> obj .: "data" - "Item" -> SomeEntity @Item <$> obj .: "data" - "Creature" -> SomeEntity @Creature <$> obj .: "data" - "Wall" -> SomeEntity @Wall <$> obj .: "data" - "Door" -> SomeEntity @Door <$> obj .: "data" - "GroundMessage" -> SomeEntity @GroundMessage <$> obj .: "data" - "Staircase" -> SomeEntity @Staircase <$> obj .: "data" - "Marker" -> SomeEntity @Marker <$> obj .: "data" - _ -> fail . unpack $ "Invalid entity type \"" <> entityType <> "\"" - -deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameLevel - instance FromJSON GameLevel -deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameState - instance FromJSON GameState - -instance Entity SomeEntity where - entityAttributes (SomeEntity ent) = entityAttributes ent - description (SomeEntity ent) = description ent - entityChar (SomeEntity ent) = entityChar ent - entityCollision (SomeEntity ent) = entityCollision ent - -instance Function SomeEntity where - function = functionJSON - -instance CoArbitrary SomeEntity where - coarbitrary = coarbitrary . encode diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs-boot b/users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs-boot deleted file mode 100644 index 519a862c6a..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs-boot +++ /dev/null @@ -1,14 +0,0 @@ -{-# 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 deleted file mode 100644 index b45a91eabe..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/Environment.hs +++ /dev/null @@ -1,160 +0,0 @@ -{-# 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 deleted file mode 100644 index b50a5eab80..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/Item.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# 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/Marker.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Marker.hs deleted file mode 100644 index 14d02872ed..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/Marker.hs +++ /dev/null @@ -1,41 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Entities.Marker ( Marker(..) ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Data.Aeson -import Test.QuickCheck -import qualified Graphics.Vty.Attributes as Vty -import qualified Graphics.Vty.Image as Vty -import Brick.Widgets.Core (raw) --------------------------------------------------------------------------------- -import Xanthous.Game.State -import Xanthous.Data.Entities (EntityAttributes(..)) --------------------------------------------------------------------------------- - --- | Mark on the map - for use in debugging / development only. -newtype Marker = Marker Text - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving (Semigroup, Monoid, ToJSON, FromJSON, Arbitrary) via Text - -instance Brain Marker where step = brainVia Brainless - -instance Entity Marker where - entityAttributes = const EntityAttributes - { _blocksVision = False - , _blocksObject = False - , _collision = Stop - } - description (Marker m) = "[M] " <> m - entityChar = const $ "X" & style .~ markerStyle - entityCollision = const Nothing - -instance Draw Marker where - draw = const . raw $ Vty.char markerStyle 'X' - drawPriority = const maxBound - -markerStyle :: Vty.Attr -markerStyle = Vty.defAttr - `Vty.withForeColor` Vty.red - `Vty.withBackColor` Vty.black diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/RawTypes.hs b/users/glittershark/xanthous/src/Xanthous/Entities/RawTypes.hs deleted file mode 100644 index 30039662f0..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/RawTypes.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-# 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 deleted file mode 100644 index d4cae7ccc2..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/Raws.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# 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 deleted file mode 100644 index 2eac895190..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml +++ /dev/null @@ -1,13 +0,0 @@ -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 deleted file mode 100644 index c3f19dce91..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/Raws/noodles.yaml +++ /dev/null @@ -1,12 +0,0 @@ -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 deleted file mode 100644 index bc7fde4d8b..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/Raws/stick.yaml +++ /dev/null @@ -1,14 +0,0 @@ -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 deleted file mode 100644 index 89c23f0de8..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Game.hs +++ /dev/null @@ -1,73 +0,0 @@ -module Xanthous.Game - ( GameState(..) - , levels - , entities - , revealedPositions - , messageHistory - , randomGen - , promptState - , GamePromptState(..) - - , getInitialState - , initialStateFromSeed - - , positionedCharacter - , character - , characterPosition - , updateCharacterVision - , characterVisiblePositions - , entitiesAtCharacter - , revealedEntitiesAtPosition - - -- * Messages - , MessageHistory(..) - , HasMessages(..) - , HasTurn(..) - , HasDisplayedTurn(..) - , pushMessage - , previousMessage - , nextTurn - - -- * Collisions - , Collision(..) - , collisionAt - - -- * App monad - , AppT(..) - - -- * Saving the game - , saveGame - , loadGame - , saved - - -- * Debug State - , DebugState(..) - , debugState - , allRevealed - ) where --------------------------------------------------------------------------------- -import qualified Codec.Compression.Zlib as Zlib -import Codec.Compression.Zlib.Internal (DecompressError) -import qualified Data.Aeson as JSON -import System.IO.Unsafe --------------------------------------------------------------------------------- -import Xanthous.Prelude -import Xanthous.Game.State -import Xanthous.Game.Lenses -import Xanthous.Game.Arbitrary () -import Xanthous.Entities.Entities () --------------------------------------------------------------------------------- - -saveGame :: GameState -> LByteString -saveGame = Zlib.compress . JSON.encode - -loadGame :: LByteString -> Maybe GameState -loadGame = JSON.decode <=< decompressZlibMay - where - decompressZlibMay bs - = unsafeDupablePerformIO - $ (let r = Zlib.decompress bs in r `seq` pure (Just r)) - `catch` \(_ :: DecompressError) -> pure Nothing - -saved :: Prism' LByteString GameState -saved = prism' saveGame loadGame diff --git a/users/glittershark/xanthous/src/Xanthous/Game/Arbitrary.hs b/users/glittershark/xanthous/src/Xanthous/Game/Arbitrary.hs deleted file mode 100644 index 1b15ad4ffa..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Game/Arbitrary.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE RecordWildCards #-} --------------------------------------------------------------------------------- -module Xanthous.Game.Arbitrary where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (foldMap) --------------------------------------------------------------------------------- -import Test.QuickCheck -import System.Random -import Data.Foldable (foldMap) --------------------------------------------------------------------------------- -import Xanthous.Data.Levels -import qualified Xanthous.Data.EntityMap as EntityMap -import Xanthous.Entities.Entities () -import Xanthous.Entities.Character -import Xanthous.Game.State -import Xanthous.Orphans () -import Xanthous.Util.QuickCheck (GenericArbitrary(..)) --------------------------------------------------------------------------------- - -deriving via GenericArbitrary GameLevel instance Arbitrary GameLevel - -instance Arbitrary GameState where - arbitrary = do - chr <- arbitrary @Character - _upStaircasePosition <- arbitrary - _messageHistory <- arbitrary - levs <- arbitrary @(Levels GameLevel) - _levelRevealedPositions <- - fmap setFromList - . sublistOf - . foldMap (EntityMap.positions . _levelEntities) - $ levs - let (_characterEntityID, _levelEntities) = - EntityMap.insertAtReturningID _upStaircasePosition (SomeEntity chr) - $ levs ^. current . levelEntities - _levels = levs & current .~ GameLevel {..} - _randomGen <- mkStdGen <$> arbitrary - let _promptState = NoPrompt -- TODO - _activePanel <- arbitrary - _debugState <- arbitrary - let _autocommand = NoAutocommand - pure $ GameState {..} - - -instance CoArbitrary GameLevel -instance Function GameLevel -instance CoArbitrary GameState -instance Function GameState diff --git a/users/glittershark/xanthous/src/Xanthous/Game/Draw.hs b/users/glittershark/xanthous/src/Xanthous/Game/Draw.hs deleted file mode 100644 index 2375ae8c55..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Game/Draw.hs +++ /dev/null @@ -1,143 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Game.Draw - ( drawGame - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude -import Brick hiding (loc, on) -import Brick.Widgets.Border -import Brick.Widgets.Border.Style -import Brick.Widgets.Edit --------------------------------------------------------------------------------- -import Xanthous.Data -import Xanthous.Data.App (ResourceName, Panel(..)) -import qualified Xanthous.Data.App as Resource -import qualified Xanthous.Data.EntityMap as EntityMap -import Xanthous.Game.State -import Xanthous.Entities.Character -import Xanthous.Entities.Item (Item) -import Xanthous.Game - ( characterPosition - , character - , revealedEntitiesAtPosition - ) -import Xanthous.Game.Prompt -import Xanthous.Orphans () --------------------------------------------------------------------------------- - -cursorPosition :: GameState -> Widget ResourceName -> Widget ResourceName -cursorPosition game - | WaitingPrompt _ (Prompt _ SPointOnMap (PointOnMapPromptState pos) _ _) - <- game ^. promptState - = showCursor Resource.Prompt (pos ^. loc) - | otherwise - = showCursor Resource.Character (game ^. characterPosition . loc) - -drawMessages :: MessageHistory -> Widget ResourceName -drawMessages = txtWrap . (<> " ") . unwords . reverse . oextract - -drawPromptState :: GamePromptState m -> Widget ResourceName -drawPromptState NoPrompt = emptyWidget -drawPromptState (WaitingPrompt msg (Prompt _ pt ps pri _)) = - case (pt, ps, pri) of - (SStringPrompt, StringPromptState edit, _) -> - txtWrap msg <+> txt " " <+> renderEditor (txt . fold) True edit - (SDirectionPrompt, DirectionPromptState, _) -> txtWrap msg - (SContinue, _, _) -> txtWrap msg - (SMenu, _, menuItems) -> - txtWrap msg - <=> foldl' (<=>) emptyWidget (map drawMenuItem $ itoList menuItems) - _ -> txtWrap msg - where - drawMenuItem (chr, MenuOption m _) = - str ("[" <> pure chr <> "] ") <+> txtWrap m - -drawEntities - :: GameState - -> Widget ResourceName -drawEntities game = vBox rows - where - allEnts = game ^. entities - entityPositions = EntityMap.positions allEnts - maxY = fromMaybe 0 $ maximumOf (folded . y) entityPositions - maxX = fromMaybe 0 $ maximumOf (folded . x) entityPositions - rows = mkRow <$> [0..maxY] - mkRow rowY = hBox $ renderEntityAt . flip Position rowY <$> [0..maxX] - renderEntityAt pos - = renderTopEntity pos $ revealedEntitiesAtPosition pos game - renderTopEntity pos ents - = let neighbors = EntityMap.neighbors pos allEnts - in maybe (str " ") (drawWithNeighbors neighbors) - $ maximumBy (compare `on` drawPriority) - <$> fromNullable ents - -drawMap :: GameState -> Widget ResourceName -drawMap game - = viewport Resource.MapViewport Both - . cursorPosition game - $ drawEntities game - -bullet :: Char -bullet = '•' - -drawInventoryPanel :: GameState -> Widget ResourceName -drawInventoryPanel game - = drawWielded (game ^. character . inventory . wielded) - <=> drawBackpack (game ^. character . inventory . backpack) - where - drawWielded (Hands Nothing Nothing) = emptyWidget - drawWielded (DoubleHanded i) = - txtWrap $ "You are holding " <> description i <> " in both hands" - drawWielded (Hands l r) = drawHand "left" l <=> drawHand "right" r - drawHand side = maybe emptyWidget $ \i -> - txtWrap ( "You are holding " - <> description i - <> " in your " <> side <> " hand" - ) - <=> txt " " - - drawBackpack :: Vector Item -> Widget ResourceName - drawBackpack Empty = txtWrap "Your backpack is empty right now." - drawBackpack backpackItems - = txtWrap ( "You are currently carrying the following items in your " - <> "backpack:") - <=> txt " " - <=> foldl' (<=>) emptyWidget - (map - (txtWrap . ((bullet <| " ") <>) . description) - backpackItems) - - -drawPanel :: GameState -> Panel -> Widget ResourceName -drawPanel game panel - = border - . hLimit 35 - . viewport (Resource.Panel panel) Vertical - . case panel of - InventoryPanel -> drawInventoryPanel - $ game - -drawCharacterInfo :: Character -> Widget ResourceName -drawCharacterInfo ch = txt " " <+> charName <+> charHitpoints - where - charName | Just n <- ch ^. characterName - = txt $ n <> " " - | otherwise - = emptyWidget - charHitpoints - = txt "Hitpoints: " - <+> txt (tshow $ let Hitpoints hp = characterHitpoints ch in hp) - -drawGame :: GameState -> [Widget ResourceName] -drawGame game - = pure - . withBorderStyle unicode - $ case game ^. promptState of - NoPrompt -> drawMessages (game ^. messageHistory) - _ -> emptyWidget - <=> drawPromptState (game ^. promptState) - <=> - (maybe emptyWidget (drawPanel game) (game ^. activePanel) - <+> border (drawMap game) - ) - <=> drawCharacterInfo (game ^. character) diff --git a/users/glittershark/xanthous/src/Xanthous/Game/Env.hs b/users/glittershark/xanthous/src/Xanthous/Game/Env.hs deleted file mode 100644 index 6e10d0f735..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Game/Env.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# 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 deleted file mode 100644 index 6242b855f1..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Game/Lenses.hs +++ /dev/null @@ -1,150 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE AllowAmbiguousTypes #-} --------------------------------------------------------------------------------- -module Xanthous.Game.Lenses - ( positionedCharacter - , character - , characterPosition - , updateCharacterVision - , characterVisiblePositions - , characterVisibleEntities - , getInitialState - , initialStateFromSeed - , entitiesAtCharacter - , revealedEntitiesAtPosition - - -- * Collisions - , Collision(..) - , entitiesCollision - , collisionAt - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import System.Random -import Control.Monad.State -import Control.Monad.Random (getRandom) --------------------------------------------------------------------------------- -import Xanthous.Game.State -import Xanthous.Data -import Xanthous.Data.Levels -import qualified Xanthous.Data.EntityMap as EntityMap -import Xanthous.Data.EntityMap.Graphics - (visiblePositions, visibleEntities) -import Xanthous.Data.VectorBag -import Xanthous.Entities.Character (Character, mkCharacter) -import {-# SOURCE #-} Xanthous.Entities.Entities () --------------------------------------------------------------------------------- - -getInitialState :: IO GameState -getInitialState = initialStateFromSeed <$> getRandom - -initialStateFromSeed :: Int -> GameState -initialStateFromSeed seed = - let _randomGen = mkStdGen seed - chr = mkCharacter - _upStaircasePosition = Position 0 0 - (_characterEntityID, _levelEntities) - = EntityMap.insertAtReturningID - _upStaircasePosition - (SomeEntity chr) - mempty - _levelRevealedPositions = mempty - level = GameLevel {..} - _levels = oneLevel level - _messageHistory = mempty - _promptState = NoPrompt - _activePanel = Nothing - _debugState = DebugState - { _allRevealed = False - } - _autocommand = NoAutocommand - in GameState {..} - - -positionedCharacter :: Lens' GameState (Positioned Character) -positionedCharacter = lens getPositionedCharacter setPositionedCharacter - where - setPositionedCharacter :: GameState -> Positioned Character -> GameState - setPositionedCharacter game chr - = game - & entities . at (game ^. characterEntityID) - ?~ fmap SomeEntity chr - - getPositionedCharacter :: GameState -> Positioned Character - getPositionedCharacter game - = over positioned - ( fromMaybe (error "Invariant error: Character was not a character!") - . downcastEntity - ) - . fromMaybe (error "Invariant error: Character not found!") - $ EntityMap.lookupWithPosition - (game ^. characterEntityID) - (game ^. entities) - - -character :: Lens' GameState Character -character = positionedCharacter . positioned - -characterPosition :: Lens' GameState Position -characterPosition = positionedCharacter . position - -visionRadius :: Word -visionRadius = 12 -- TODO make this dynamic - --- | Update the revealed entities at the character's position based on their --- vision -updateCharacterVision :: GameState -> GameState -updateCharacterVision game - = game & revealedPositions <>~ characterVisiblePositions game - -characterVisiblePositions :: GameState -> Set Position -characterVisiblePositions game = - let charPos = game ^. characterPosition - in visiblePositions charPos visionRadius $ game ^. entities - -characterVisibleEntities :: GameState -> EntityMap.EntityMap SomeEntity -characterVisibleEntities game = - let charPos = game ^. characterPosition - in visibleEntities charPos visionRadius $ game ^. entities - -entitiesCollision - :: ( Functor f - , forall xx. MonoFoldable (f xx) - , Element (f SomeEntity) ~ SomeEntity - , Element (f (Maybe Collision)) ~ Maybe Collision - , Show (f (Maybe Collision)) - , Show (f SomeEntity) - ) - => f SomeEntity - -> Maybe Collision -entitiesCollision = join . maximumMay . fmap entityCollision - -collisionAt :: MonadState GameState m => Position -> m (Maybe Collision) -collisionAt p = uses (entities . EntityMap.atPosition p) entitiesCollision - -entitiesAtCharacter :: Lens' GameState (VectorBag SomeEntity) -entitiesAtCharacter = lens getter setter - where - getter gs = gs ^. entities . EntityMap.atPosition (gs ^. characterPosition) - setter gs ents = gs - & entities . EntityMap.atPosition (gs ^. characterPosition) .~ ents - --- | Returns all entities at the given position that are revealed to the --- character. --- --- Concretely, this is either entities that are *currently* visible to the --- character, or entities, that are immobile and that the character has seen --- before -revealedEntitiesAtPosition :: Position -> GameState -> (VectorBag SomeEntity) -revealedEntitiesAtPosition p gs - | p `member` characterVisiblePositions gs - = entitiesAtPosition - | p `member` (gs ^. revealedPositions) - = immobileEntitiesAtPosition - | otherwise - = mempty - where - entitiesAtPosition = gs ^. entities . EntityMap.atPosition p - immobileEntitiesAtPosition = filter (not . entityCanMove) entitiesAtPosition diff --git a/users/glittershark/xanthous/src/Xanthous/Game/Prompt.hs b/users/glittershark/xanthous/src/Xanthous/Game/Prompt.hs deleted file mode 100644 index 30b5fe7545..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Game/Prompt.hs +++ /dev/null @@ -1,289 +0,0 @@ -{-# 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 deleted file mode 100644 index f614cad473..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Game/State.hs +++ /dev/null @@ -1,558 +0,0 @@ -{-# 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 deleted file mode 100644 index ef37070b6e..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Generators.hs +++ /dev/null @@ -1,168 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Generators - ( generate - , Generator(..) - , SGenerator(..) - , GeneratorInput(..) - , generateFromInput - , parseGeneratorInput - , showCells - , Level(..) - , levelWalls - , levelItems - , levelCreatures - , levelDoors - , levelCharacterPosition - , levelTutorialMessage - , levelExtra - , generateLevel - , levelToEntityMap - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude -import Data.Array.Unboxed -import qualified Options.Applicative as Opt -import Control.Monad.Random --------------------------------------------------------------------------------- -import qualified Xanthous.Generators.CaveAutomata as CaveAutomata -import qualified Xanthous.Generators.Dungeon as Dungeon -import Xanthous.Generators.Util -import Xanthous.Generators.LevelContents -import Xanthous.Generators.Village as Village -import Xanthous.Data (Dimensions, Position'(Position), Position) -import Xanthous.Data.EntityMap (EntityMap, _EntityMap) -import qualified Xanthous.Data.EntityMap as EntityMap -import Xanthous.Entities.Environment -import Xanthous.Entities.Item (Item) -import Xanthous.Entities.Creature (Creature) -import Xanthous.Game.State (SomeEntity(..)) -import Linear.V2 --------------------------------------------------------------------------------- - -data Generator - = CaveAutomata - | Dungeon - deriving stock (Show, Eq) - -data SGenerator (gen :: Generator) where - SCaveAutomata :: SGenerator 'CaveAutomata - SDungeon :: SGenerator 'Dungeon - -type family Params (gen :: Generator) :: Type where - Params 'CaveAutomata = CaveAutomata.Params - Params 'Dungeon = Dungeon.Params - -generate - :: RandomGen g - => SGenerator gen - -> Params gen - -> Dimensions - -> g - -> Cells -generate SCaveAutomata = CaveAutomata.generate -generate SDungeon = Dungeon.generate - -data GeneratorInput where - GeneratorInput :: forall gen. SGenerator gen -> Params gen -> GeneratorInput - -generateFromInput :: RandomGen g => GeneratorInput -> Dimensions -> g -> Cells -generateFromInput (GeneratorInput sg ps) = generate sg ps - -parseGeneratorInput :: Opt.Parser GeneratorInput -parseGeneratorInput = Opt.subparser - $ generatorCommand SCaveAutomata - "cave" - "Cellular-automata based cave generator" - CaveAutomata.parseParams - <> generatorCommand SDungeon - "dungeon" - "Classic dungeon map generator" - Dungeon.parseParams - where - generatorCommand sgen name desc parseParams = - Opt.command name - (Opt.info - (GeneratorInput <$> pure sgen <*> parseParams) - (Opt.progDesc desc) - ) - - -showCells :: Cells -> Text -showCells arr = - let (V2 minX minY, V2 maxX maxY) = bounds arr - showCellVal True = "x" - showCellVal False = " " - showCell = showCellVal . (arr !) - row r = foldMap (showCell . (`V2` r)) [minX..maxX] - rows = row <$> [minY..maxY] - in intercalate "\n" rows - -cellsToWalls :: Cells -> EntityMap Wall -cellsToWalls cells = foldl' maybeInsertWall mempty . assocs $ cells - where - maybeInsertWall em (pos@(V2 x y), True) - | not (surroundedOnAllSides pos) = - let x' = fromIntegral x - y' = fromIntegral y - in EntityMap.insertAt (Position x' y') Wall em - maybeInsertWall em _ = em - surroundedOnAllSides pos = numAliveNeighbors cells pos == 8 - --------------------------------------------------------------------------------- - -data Level = Level - { _levelWalls :: !(EntityMap Wall) - , _levelDoors :: !(EntityMap Door) - , _levelItems :: !(EntityMap Item) - , _levelCreatures :: !(EntityMap Creature) - , _levelTutorialMessage :: !(EntityMap GroundMessage) - , _levelStaircases :: !(EntityMap Staircase) - , _levelExtra :: !(EntityMap SomeEntity) -- ^ TODO this is a bit of a hack... - , _levelCharacterPosition :: !Position - } - deriving stock (Generic) - deriving anyclass (NFData) -makeLenses ''Level - -generateLevel - :: MonadRandom m - => SGenerator gen - -> Params gen - -> Dimensions - -> m Level -generateLevel gen ps dims = do - rand <- mkStdGen <$> getRandom - let cells = generate gen ps dims rand - _levelWalls = cellsToWalls cells - village <- generateVillage cells gen - let _levelExtra = village - _levelItems <- randomItems cells - _levelCreatures <- randomCreatures cells - _levelDoors <- randomDoors cells - _levelCharacterPosition <- chooseCharacterPosition cells - let upStaircase = _EntityMap # [(_levelCharacterPosition, UpStaircase)] - downStaircase <- placeDownStaircase cells - let _levelStaircases = upStaircase <> downStaircase - _levelTutorialMessage <- tutorialMessage cells _levelCharacterPosition - pure Level {..} - -levelToEntityMap :: Level -> EntityMap SomeEntity -levelToEntityMap level - = (SomeEntity <$> level ^. levelWalls) - <> (SomeEntity <$> level ^. levelDoors) - <> (SomeEntity <$> level ^. levelItems) - <> (SomeEntity <$> level ^. levelCreatures) - <> (SomeEntity <$> level ^. levelTutorialMessage) - <> (SomeEntity <$> level ^. levelStaircases) - <> (level ^. levelExtra) - -generateVillage - :: MonadRandom m - => Cells -- ^ Wall positions - -> SGenerator gen - -> m (EntityMap SomeEntity) -generateVillage wallPositions SCaveAutomata = Village.fromCave wallPositions -generateVillage _ _ = pure mempty diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs b/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs deleted file mode 100644 index be904662f3..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Generators.CaveAutomata - ( Params(..) - , defaultParams - , parseParams - , generate - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude -import Control.Monad.Random (RandomGen, runRandT) -import Data.Array.ST -import Data.Array.Unboxed -import qualified Options.Applicative as Opt --------------------------------------------------------------------------------- -import Xanthous.Util (between) -import Xanthous.Util.Optparse -import Xanthous.Data (Dimensions, width, height) -import Xanthous.Generators.Util -import Linear.V2 --------------------------------------------------------------------------------- - -data Params = Params - { _aliveStartChance :: Double - , _birthLimit :: Word - , _deathLimit :: Word - , _steps :: Word - } - deriving stock (Show, Eq, Generic) -makeLenses ''Params - -defaultParams :: Params -defaultParams = Params - { _aliveStartChance = 0.6 - , _birthLimit = 3 - , _deathLimit = 4 - , _steps = 4 - } - -parseParams :: Opt.Parser Params -parseParams = Params - <$> Opt.option parseChance - ( Opt.long "alive-start-chance" - <> Opt.value (defaultParams ^. aliveStartChance) - <> Opt.showDefault - <> Opt.help ( "Chance for each cell to start alive at the beginning of " - <> "the cellular automata" - ) - <> Opt.metavar "CHANCE" - ) - <*> Opt.option parseNeighbors - ( Opt.long "birth-limit" - <> Opt.value (defaultParams ^. birthLimit) - <> Opt.showDefault - <> Opt.help "Minimum neighbor count required for birth of a cell" - <> Opt.metavar "NEIGHBORS" - ) - <*> Opt.option parseNeighbors - ( Opt.long "death-limit" - <> Opt.value (defaultParams ^. deathLimit) - <> Opt.showDefault - <> Opt.help "Maximum neighbor count required for death of a cell" - <> Opt.metavar "NEIGHBORS" - ) - <*> Opt.option Opt.auto - ( Opt.long "steps" - <> Opt.value (defaultParams ^. steps) - <> Opt.showDefault - <> Opt.help "Number of generations to run the automata for" - <> Opt.metavar "STEPS" - ) - <**> Opt.helper - where - parseChance = readWithGuard - (between 0 1) - $ \res -> "Chance must be in the range [0,1], got: " <> show res - - parseNeighbors = readWithGuard - (between 0 8) - $ \res -> "Neighbors must be in the range [0,8], got: " <> show res - -generate :: RandomGen g => Params -> Dimensions -> g -> Cells -generate params dims gen - = runSTUArray - $ fmap fst - $ flip runRandT gen - $ generate' params dims - -generate' :: RandomGen g => Params -> Dimensions -> CellM g s (MCells s) -generate' params dims = do - cells <- randInitialize dims $ params ^. aliveStartChance - let steps' = params ^. steps - when (steps' > 0) - $ for_ [0 .. pred steps'] . const $ stepAutomata cells dims params - -- Remove all but the largest contiguous region of unfilled space - (_: smallerRegions) <- lift $ regions @UArray . amap not <$> freeze cells - lift $ fillAllM (fold smallerRegions) cells - lift $ fillOuterEdgesM cells - pure cells - -stepAutomata :: forall s g. MCells s -> Dimensions -> Params -> CellM g s () -stepAutomata cells dims params = do - origCells <- lift $ cloneMArray @_ @(STUArray s) cells - for_ (range (0, V2 (dims ^. width) (dims ^. height))) $ \pos -> do - neighs <- lift $ numAliveNeighborsM origCells pos - origValue <- lift $ readArray origCells pos - lift . writeArray cells pos - $ if origValue - then neighs >= params ^. deathLimit - else neighs > params ^. birthLimit diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/Dungeon.hs b/users/glittershark/xanthous/src/Xanthous/Generators/Dungeon.hs deleted file mode 100644 index f30713ce11..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Generators/Dungeon.hs +++ /dev/null @@ -1,190 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Generators.Dungeon - ( Params(..) - , defaultParams - , parseParams - , generate - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding ((:>)) --------------------------------------------------------------------------------- -import Control.Monad.Random -import Data.Array.ST -import Data.Array.IArray (amap) -import Data.Stream.Infinite (Stream(..)) -import qualified Data.Stream.Infinite as Stream -import qualified Data.Graph.Inductive.Graph as Graph -import Data.Graph.Inductive.PatriciaTree -import qualified Data.List.NonEmpty as NE -import Data.Maybe (fromJust) -import Linear.V2 -import Linear.Metric -import qualified Options.Applicative as Opt --------------------------------------------------------------------------------- -import Xanthous.Random -import Xanthous.Data hiding (x, y, _x, _y, edges) -import Xanthous.Generators.Util -import Xanthous.Util.Graphics (delaunay, straightLine) -import Xanthous.Util.Graph (mstSubGraph) --------------------------------------------------------------------------------- - -data Params = Params - { _numRoomsRange :: (Word, Word) - , _roomDimensionRange :: (Word, Word) - , _connectednessRatioRange :: (Double, Double) - } - deriving stock (Show, Eq, Ord, Generic) -makeLenses ''Params - -defaultParams :: Params -defaultParams = Params - { _numRoomsRange = (6, 8) - , _roomDimensionRange = (3, 12) - , _connectednessRatioRange = (0.1, 0.15) - } - -parseParams :: Opt.Parser Params -parseParams = Params - <$> parseRange - "num-rooms" - "number of rooms to generate in the dungeon" - "ROOMS" - (defaultParams ^. numRoomsRange) - <*> parseRange - "room-size" - "size in tiles of one of the sides of a room" - "TILES" - (defaultParams ^. roomDimensionRange) - <*> parseRange - "connectedness-ratio" - ( "ratio of edges from the delaunay triangulation to re-add to the " - <> "minimum-spanning-tree") - "RATIO" - (defaultParams ^. connectednessRatioRange) - <**> Opt.helper - where - parseRange name desc metavar (defMin, defMax) = - (,) - <$> Opt.option Opt.auto - ( Opt.long ("min-" <> name) - <> Opt.value defMin - <> Opt.showDefault - <> Opt.help ("Minimum " <> desc) - <> Opt.metavar metavar - ) - <*> Opt.option Opt.auto - ( Opt.long ("max-" <> name) - <> Opt.value defMax - <> Opt.showDefault - <> Opt.help ("Maximum " <> desc) - <> Opt.metavar metavar - ) - -generate :: RandomGen g => Params -> Dimensions -> g -> Cells -generate params dims gen - = amap not - $ runSTUArray - $ fmap fst - $ flip runRandT gen - $ generate' params dims - --------------------------------------------------------------------------------- - -generate' :: RandomGen g => Params -> Dimensions -> CellM g s (MCells s) -generate' params dims = do - cells <- initializeEmpty dims - rooms <- genRooms params dims - for_ rooms $ fillRoom cells - - let fullRoomGraph = delaunayRoomGraph rooms - mst = mstSubGraph fullRoomGraph - mstEdges = Graph.edges mst - nonMSTEdges = filter (\(n₁, n₂, _) -> (n₁, n₂) `notElem` mstEdges) - $ Graph.labEdges fullRoomGraph - - reintroEdgeCount <- floor . (* fromIntegral (length nonMSTEdges)) - <$> getRandomR (params ^. connectednessRatioRange) - let reintroEdges = take reintroEdgeCount nonMSTEdges - corridorGraph = Graph.insEdges reintroEdges mst - - corridors <- traverse - ( uncurry corridorBetween - . over both (fromJust . Graph.lab corridorGraph) - ) $ Graph.edges corridorGraph - - for_ (join corridors) $ \pt -> lift $ writeArray cells pt True - - pure cells - -type Room = Box Word - -genRooms :: MonadRandom m => Params -> Dimensions -> m [Room] -genRooms params dims = do - numRooms <- fromIntegral <$> getRandomR (params ^. numRoomsRange) - subRand . fmap (Stream.take numRooms . removeIntersecting []) . infinitely $ do - roomWidth <- getRandomR $ params ^. roomDimensionRange - roomHeight <- getRandomR $ params ^. roomDimensionRange - xPos <- getRandomR (0, dims ^. width - roomWidth) - yPos <- getRandomR (0, dims ^. height - roomHeight) - pure Box - { _topLeftCorner = V2 xPos yPos - , _dimensions = V2 roomWidth roomHeight - } - where - removeIntersecting seen (room :> rooms) - | any (boxIntersects room) seen - = removeIntersecting seen rooms - | otherwise - = room :> removeIntersecting (room : seen) rooms - streamRepeat x = x :> streamRepeat x - infinitely = sequence . streamRepeat - -delaunayRoomGraph :: [Room] -> Gr Room Double -delaunayRoomGraph rooms = - Graph.insEdges edges . Graph.insNodes nodes $ Graph.empty - where - edges = map (\((n₁, room₁), (n₂, room₂)) -> (n₁, n₂, roomDist room₁ room₂)) - . over (mapped . both) snd - . delaunay @Double - . NE.fromList - . map (\p@(_, room) -> (boxCenter $ fromIntegral <$> room, p)) - $ nodes - nodes = zip [0..] rooms - roomDist = distance `on` (boxCenter . fmap fromIntegral) - -fillRoom :: MCells s -> Room -> CellM g s () -fillRoom cells room = - let V2 posx posy = room ^. topLeftCorner - V2 dimx dimy = room ^. dimensions - in for_ [posx .. posx + dimx] $ \x -> - for_ [posy .. posy + dimy] $ \y -> - lift $ writeArray cells (V2 x y) True - -corridorBetween :: MonadRandom m => Room -> Room -> m [V2 Word] -corridorBetween originRoom destinationRoom - = straightLine <$> origin <*> destination - where - origin = choose . NE.fromList =<< originEdge - destination = choose . NE.fromList =<< destinationEdge - originEdge = pickEdge originRoom originCorner - destinationEdge = pickEdge destinationRoom destinationCorner - pickEdge room corner = choose . over both (boxEdge room) $ cornerEdges corner - originCorner = - case ( compare (originRoom ^. topLeftCorner . _x) - (destinationRoom ^. topLeftCorner . _x) - , compare (originRoom ^. topLeftCorner . _y) - (destinationRoom ^. topLeftCorner . _y) - ) of - (LT, LT) -> BottomRight - (LT, GT) -> TopRight - (GT, LT) -> BottomLeft - (GT, GT) -> TopLeft - - (EQ, LT) -> BottomLeft - (EQ, GT) -> TopRight - (GT, EQ) -> TopLeft - (LT, EQ) -> BottomRight - (EQ, EQ) -> TopLeft -- should never happen - - destinationCorner = opposite originCorner diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/LevelContents.hs b/users/glittershark/xanthous/src/Xanthous/Generators/LevelContents.hs deleted file mode 100644 index 8ebcc7f4da..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Generators/LevelContents.hs +++ /dev/null @@ -1,133 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Generators.LevelContents - ( chooseCharacterPosition - , randomItems - , randomCreatures - , randomDoors - , placeDownStaircase - , tutorialMessage - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (any, toList) --------------------------------------------------------------------------------- -import Control.Monad.Random -import Data.Array.IArray (amap, bounds, rangeSize, (!)) -import qualified Data.Array.IArray as Arr -import Data.Foldable (any, toList) -import Linear.V2 --------------------------------------------------------------------------------- -import Xanthous.Generators.Util -import Xanthous.Random -import Xanthous.Data - ( positionFromV2, Position, _Position - , rotations, arrayNeighbors, Neighbors(..) - , neighborPositions - ) -import Xanthous.Data.EntityMap (EntityMap, _EntityMap) -import Xanthous.Entities.Raws (rawsWithType, RawType) -import qualified Xanthous.Entities.Item as Item -import Xanthous.Entities.Item (Item) -import qualified Xanthous.Entities.Creature as Creature -import Xanthous.Entities.Creature (Creature) -import Xanthous.Entities.Environment - (GroundMessage(..), Door(..), unlockedDoor, Staircase(..)) -import Xanthous.Messages (message_) -import Xanthous.Util.Graphics (circle) --------------------------------------------------------------------------------- - -chooseCharacterPosition :: MonadRandom m => Cells -> m Position -chooseCharacterPosition = randomPosition - -randomItems :: MonadRandom m => Cells -> m (EntityMap Item) -randomItems = randomEntities Item.newWithType (0.0004, 0.001) - -placeDownStaircase :: MonadRandom m => Cells -> m (EntityMap Staircase) -placeDownStaircase cells = do - pos <- randomPosition cells - pure $ _EntityMap # [(pos, DownStaircase)] - -randomDoors :: MonadRandom m => Cells -> m (EntityMap Door) -randomDoors cells = do - doorRatio <- getRandomR subsetRange - let numDoors = floor $ doorRatio * fromIntegral (length candidateCells) - doorPositions = - removeAdjacent . fmap positionFromV2 . take numDoors $ candidateCells - doors = zip doorPositions $ repeat unlockedDoor - pure $ _EntityMap # doors - where - removeAdjacent = - foldr (\pos acc -> - if pos `elem` (acc >>= toList . neighborPositions) - then acc - else pos : acc - ) [] - candidateCells = filter doorable $ Arr.indices cells - subsetRange = (0.8 :: Double, 1.0) - doorable pos = - not (fromMaybe True $ cells ^? ix pos) - && any (teeish . fmap (fromMaybe True)) - (rotations $ arrayNeighbors cells pos) - -- only generate doors at the *ends* of hallways, eg (where O is walkable, - -- X is a wall, and D is a door): - -- - -- O O O - -- X D X - -- O - teeish (fmap not -> (Neighbors tl t tr l r _ b _ )) = - and [tl, t, tr, b] && (and . fmap not) [l, r] - -randomCreatures :: MonadRandom m => Cells -> m (EntityMap Creature) -randomCreatures = randomEntities Creature.newWithType (0.0007, 0.002) - -tutorialMessage :: MonadRandom m - => Cells - -> Position -- ^ CharacterPosition - -> m (EntityMap GroundMessage) -tutorialMessage cells characterPosition = do - let distance = 2 - pos <- fmap (fromMaybe (error "No valid positions for tutorial message?")) - . choose . ChooseElement - $ accessiblePositionsWithin distance cells characterPosition - msg <- message_ ["tutorial", "message1"] - pure $ _EntityMap # [(pos, GroundMessage msg)] - where - accessiblePositionsWithin :: Int -> Cells -> Position -> [Position] - accessiblePositionsWithin dist valid pos = - review _Position - <$> filter - (\pt -> not $ valid ! (fromIntegral <$> pt)) - (circle (pos ^. _Position) dist) - -randomEntities - :: forall entity raw m. (MonadRandom m, RawType raw) - => (raw -> entity) - -> (Float, Float) - -> Cells - -> m (EntityMap entity) -randomEntities newWithType sizeRange cells = - case fromNullable $ rawsWithType @raw of - Nothing -> pure mempty - Just raws -> do - let len = rangeSize $ bounds cells - (numEntities :: Int) <- - floor . (* fromIntegral len) <$> getRandomR sizeRange - entities <- for [0..numEntities] $ const $ do - pos <- randomPosition cells - raw <- choose raws - let entity = newWithType raw - pure (pos, entity) - pure $ _EntityMap # entities - -randomPosition :: MonadRandom m => Cells -> m Position -randomPosition = fmap positionFromV2 . choose . impureNonNull . cellCandidates - --- cellCandidates :: Cells -> Cells -cellCandidates :: Cells -> Set (V2 Word) -cellCandidates - -- find the largest contiguous region of cells in the cave. - = maximumBy (compare `on` length) - . fromMaybe (error "No regions generated! this should never happen.") - . fromNullable - . regions - -- cells ends up with true = wall, we want true = can put an item here - . amap not diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs b/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs deleted file mode 100644 index 88aadd5aad..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs +++ /dev/null @@ -1,220 +0,0 @@ -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE AllowAmbiguousTypes #-} --------------------------------------------------------------------------------- -module Xanthous.Generators.Util - ( MCells - , Cells - , CellM - , randInitialize - , initializeEmpty - , numAliveNeighborsM - , numAliveNeighbors - , fillOuterEdgesM - , cloneMArray - , floodFill - , regions - , fillAll - , fillAllM - , fromPoints - , fromPointsM - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (Foldable, toList, for_) --------------------------------------------------------------------------------- -import Data.Array.ST -import Data.Array.Unboxed -import Control.Monad.ST -import Control.Monad.Random -import Data.Monoid -import Data.Foldable (Foldable, toList, for_) -import qualified Data.Set as Set -import Data.Semigroup.Foldable -import Linear.V2 --------------------------------------------------------------------------------- -import Xanthous.Util (foldlMapM', maximum1, minimum1) -import Xanthous.Data (Dimensions, width, height) --------------------------------------------------------------------------------- - -type MCells s = STUArray s (V2 Word) Bool -type Cells = UArray (V2 Word) Bool -type CellM g s a = RandT g (ST s) a - -randInitialize :: RandomGen g => Dimensions -> Double -> CellM g s (MCells s) -randInitialize dims aliveChance = do - res <- initializeEmpty dims - for_ [0..dims ^. width] $ \i -> - for_ [0..dims ^. height] $ \j -> do - val <- (>= aliveChance) <$> getRandomR (0, 1) - lift $ writeArray res (V2 i j) val - pure res - -initializeEmpty :: RandomGen g => Dimensions -> CellM g s (MCells s) -initializeEmpty dims = - lift $ newArray (0, V2 (dims ^. width) (dims ^. height)) False - -numAliveNeighborsM - :: forall a i m - . (MArray a Bool m, Ix i, Integral i) - => a (V2 i) Bool - -> V2 i - -> m Word -numAliveNeighborsM cells (V2 x y) = do - cellBounds <- getBounds cells - getSum <$> foldlMapM' - (fmap (Sum . fromIntegral . fromEnum) . boundedGet cellBounds) - neighborPositions - - where - boundedGet :: (V2 i, V2 i) -> (Int, Int) -> m Bool - boundedGet (V2 minX minY, V2 maxX maxY) (i, j) - | x <= minX - || y <= minY - || x >= maxX - || y >= maxY - = pure True - | otherwise = - let nx = fromIntegral $ fromIntegral x + i - ny = fromIntegral $ fromIntegral y + j - in readArray cells $ V2 nx ny - -numAliveNeighbors - :: forall a i - . (IArray a Bool, Ix i, Integral i) - => a (V2 i) Bool - -> V2 i - -> Word -numAliveNeighbors cells (V2 x y) = - let cellBounds = bounds cells - in getSum $ foldMap - (Sum . fromIntegral . fromEnum . boundedGet cellBounds) - neighborPositions - - where - boundedGet :: (V2 i, V2 i) -> (Int, Int) -> Bool - boundedGet (V2 minX minY, V2 maxX maxY) (i, j) - | x <= minX - || y <= minY - || x >= maxX - || y >= maxY - = True - | otherwise = - let nx = fromIntegral $ fromIntegral x + i - ny = fromIntegral $ fromIntegral y + j - in cells ! V2 nx ny - -neighborPositions :: [(Int, Int)] -neighborPositions = [(i, j) | i <- [-1..1], j <- [-1..1], (i, j) /= (0, 0)] - -fillOuterEdgesM :: (MArray a Bool m, Ix i) => a (V2 i) Bool -> m () -fillOuterEdgesM arr = do - (V2 minX minY, V2 maxX maxY) <- getBounds arr - for_ (range (minX, maxX)) $ \x -> do - writeArray arr (V2 x minY) True - writeArray arr (V2 x maxY) True - for_ (range (minY, maxY)) $ \y -> do - writeArray arr (V2 minX y) True - writeArray arr (V2 maxX y) True - -cloneMArray - :: forall a a' i e m. - ( Ix i - , MArray a e m - , MArray a' e m - , IArray UArray e - ) - => a i e - -> m (a' i e) -cloneMArray = thaw @_ @UArray <=< freeze - --------------------------------------------------------------------------------- - --- | Flood fill a cell array starting at a point, returning a list of all the --- (true) cell locations reachable from that point -floodFill :: forall a i. - ( IArray a Bool - , Ix i - , Enum i - , Bounded i - , Eq i - ) - => a (V2 i) Bool -- ^ array - -> (V2 i) -- ^ position - -> Set (V2 i) -floodFill = go mempty - where - go :: Set (V2 i) -> a (V2 i) Bool -> (V2 i) -> Set (V2 i) - go res arr@(bounds -> arrBounds) idx@(V2 x y) - | not (inRange arrBounds idx) = res - | not (arr ! idx) = res - | otherwise = - let neighbors - = filter (inRange arrBounds) - . filter (/= idx) - . filter (`notMember` res) - $ V2 - <$> [(if x == minBound then x else pred x) - .. - (if x == maxBound then x else succ x)] - <*> [(if y == minBound then y else pred y) - .. - (if y == maxBound then y else succ y)] - in foldl' (\r idx' -> - if arr ! idx' - then r <> (let r' = r & contains idx' .~ True - in r' `seq` go r' arr idx') - else r) - (res & contains idx .~ True) neighbors -{-# SPECIALIZE floodFill :: UArray (V2 Word) Bool -> (V2 Word) -> Set (V2 Word) #-} - --- | Gives a list of all the disconnected regions in a cell array, represented --- each as lists of points -regions :: forall a i. - ( IArray a Bool - , Ix i - , Enum i - , Bounded i - , Eq i - ) - => a (V2 i) Bool - -> [Set (V2 i)] -regions arr - | Just firstPoint <- findFirstPoint arr = - let region = floodFill arr firstPoint - arr' = fillAll region arr - in region : regions arr' - | otherwise = [] - where - findFirstPoint :: a (V2 i) Bool -> Maybe (V2 i) - findFirstPoint = fmap fst . headMay . filter snd . assocs -{-# SPECIALIZE regions :: UArray (V2 Word) Bool -> [Set (V2 Word)] #-} - -fillAll :: (IArray a Bool, Ix i, Foldable f) => f i -> a i Bool -> a i Bool -fillAll ixes a = accum (const fst) a $ (, (False, ())) <$> toList ixes - -fillAllM :: (MArray a Bool m, Ix i, Foldable f) => f i -> a i Bool -> m () -fillAllM ixes a = for_ ixes $ \i -> writeArray a i False - -fromPoints - :: forall a f i. - ( IArray a Bool - , Ix i - , Functor f - , Foldable1 f - ) - => f (i, i) - -> a (i, i) Bool -fromPoints points = - let pts = Set.fromList $ toList points - dims = ( (minimum1 $ fst <$> points, minimum1 $ snd <$> points) - , (maximum1 $ fst <$> points, maximum1 $ snd <$> points) - ) - in array dims $ range dims <&> \i -> (i, i `member` pts) - -fromPointsM - :: (MArray a Bool m, Ix i, Element f ~ i, MonoFoldable f) - => NonNull f - -> m (a i Bool) -fromPointsM points = do - arr <- newArray (minimum points, maximum points) False - fillAllM (otoList points) arr - pure arr diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/Village.hs b/users/glittershark/xanthous/src/Xanthous/Generators/Village.hs deleted file mode 100644 index cc9c9d963f..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Generators/Village.hs +++ /dev/null @@ -1,125 +0,0 @@ -module Xanthous.Generators.Village - ( fromCave - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (any, failing, toList) --------------------------------------------------------------------------------- -import Control.Monad.Random (MonadRandom) -import Control.Monad.State (execStateT, MonadState, modify) -import Control.Monad.Trans.Maybe -import Control.Parallel.Strategies -import Data.Array.IArray -import Data.Foldable (any, toList) --------------------------------------------------------------------------------- -import Xanthous.Data -import Xanthous.Data.EntityMap (EntityMap) -import qualified Xanthous.Data.EntityMap as EntityMap -import Xanthous.Entities.Environment -import Xanthous.Generators.Util -import Xanthous.Game.State (SomeEntity(..)) -import Xanthous.Random --------------------------------------------------------------------------------- - -fromCave :: MonadRandom m - => Cells -- ^ The positions of all the walls - -> m (EntityMap SomeEntity) -fromCave wallPositions = execStateT (fromCave' wallPositions) mempty - -fromCave' :: forall m. (MonadRandom m, MonadState (EntityMap SomeEntity) m) - => Cells - -> m () -fromCave' wallPositions = failing (pure ()) $ do - Just villageRegion <- - choose - . (`using` parTraversable rdeepseq) - . weightedBy (\reg -> let circSize = length $ circumference reg - in if circSize == 50 - then (1.0 :: Double) - else 1.0 / (fromIntegral . abs $ circSize - 50)) - $ regions closedHallways - - let circ = setFromList . circumference $ villageRegion - - centerPoints <- chooseSubset (0.1 :: Double) $ toList circ - - roomTiles <- foldM - (flip $ const $ stepOut circ) - (map pure centerPoints) - [0 :: Int ..2] - - let roomWalls = circumference . setFromList @(Set _) <$> roomTiles - allWalls = join roomWalls - - doorPositions <- fmap join . for roomWalls $ \room -> - let candidates = filter (`notMember` circ) room - in fmap toList . choose $ ChooseElement candidates - - let entryways = - filter (\pt -> - let ncs = neighborCells pt - in any ((&&) <$> (not . (wallPositions !)) - <*> (`notMember` villageRegion)) ncs - && any ((&&) <$> (`member` villageRegion) - <*> (`notElem` allWalls)) ncs) - $ toList villageRegion - - Just entryway <- choose $ ChooseElement entryways - - for_ (filter ((&&) <$> (`notElem` doorPositions) <*> (/= entryway)) allWalls) - $ insertEntity Wall - for_ (filter (/= entryway) doorPositions) $ insertEntity unlockedDoor - insertEntity unlockedDoor entryway - - - where - insertEntity e pt = modify $ EntityMap.insertAt (ptToPos pt) $ SomeEntity e - ptToPos pt = _Position # (fromIntegral <$> pt) - - stepOut :: Set (V2 Word) -> [[V2 Word]] -> MaybeT m [[V2 Word]] - stepOut circ rooms = for rooms $ \room -> - let nextLevels = hashNub $ toList . neighborCells =<< room - in pure - . (<> room) - $ filter ((&&) <$> (`notMember` circ) <*> (`notElem` join rooms)) - nextLevels - - circumference pts = - filter (any (`notMember` pts) . neighborCells) $ toList pts - closedHallways = closeHallways livePositions - livePositions = amap not wallPositions - --------------------------------------------------------------------------------- - -closeHallways :: Cells -> Cells -closeHallways livePositions = - livePositions // mapMaybe closeHallway (assocs livePositions) - where - closeHallway (_, False) = Nothing - closeHallway (pos, _) - | isHallway pos = Just (pos, False) - | otherwise = Nothing - isHallway pos = any ((&&) <$> not . view left <*> not . view right) - . rotations - . fmap (fromMaybe False) - $ arrayNeighbors livePositions pos - -failing :: Monad m => m a -> MaybeT m a -> m a -failing result = (maybe result pure =<<) . runMaybeT - -{- - -import Xanthous.Generators.Village -import Xanthous.Generators -import Xanthous.Data -import System.Random -import qualified Data.Text -import qualified Xanthous.Generators.CaveAutomata as CA -let gi = GeneratorInput SCaveAutomata CA.defaultParams -wallPositions <- generateFromInput gi (Dimensions 80 50) <$> getStdGen -putStrLn . Data.Text.unpack $ showCells wallPositions - -import Data.Array.IArray -let closedHallways = closeHallways . amap not $ wallPositions -putStrLn . Data.Text.unpack . showCells $ amap not closedHallways - --} diff --git a/users/glittershark/xanthous/src/Xanthous/Messages.hs b/users/glittershark/xanthous/src/Xanthous/Messages.hs deleted file mode 100644 index 2b1b3da1e8..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Messages.hs +++ /dev/null @@ -1,107 +0,0 @@ -{-# 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 deleted file mode 100644 index 5176880355..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Messages/Template.hs +++ /dev/null @@ -1,275 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} --------------------------------------------------------------------------------- -module Xanthous.Messages.Template - ( -- * Template AST - Template(..) - , Substitution(..) - , Filter(..) - - -- ** Template AST transformations - , reduceTemplate - - -- * Template parser - , template - , runParser - , errorBundlePretty - - -- * Template pretty-printer - , ppTemplate - - -- * Rendering templates - , TemplateVar(..) - , nested - , TemplateVars(..) - , vars - , RenderError - , render - ) -where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding - (many, concat, try, elements, some, parts) --------------------------------------------------------------------------------- -import Test.QuickCheck hiding (label) -import Test.QuickCheck.Instances.Text () -import Test.QuickCheck.Instances.Semigroup () -import Test.QuickCheck.Checkers (EqProp) -import Control.Monad.Combinators.NonEmpty -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Data -import Text.Megaparsec hiding (sepBy1, some) -import Text.Megaparsec.Char -import qualified Text.Megaparsec.Char.Lexer as L -import Data.Function (fix) --------------------------------------------------------------------------------- -import Xanthous.Util (EqEqProp(..)) --------------------------------------------------------------------------------- - -genIdentifier :: Gen Text -genIdentifier = pack <$> listOf1 (elements identifierChars) - -identifierChars :: String -identifierChars = ['a'..'z'] <> ['A'..'Z'] <> ['-', '_'] - -newtype Filter = FilterName Text - deriving stock (Show, Eq, Ord, Generic, Data) - deriving anyclass (NFData) - deriving (IsString) via Text - -instance Arbitrary Filter where - arbitrary = FilterName <$> genIdentifier - shrink (FilterName fn) = fmap FilterName . filter (not . null) $ shrink fn - -data Substitution - = SubstPath (NonEmpty Text) - | SubstFilter Substitution Filter - deriving stock (Show, Eq, Ord, Generic, Data) - deriving anyclass (NFData) - -instance Arbitrary Substitution where - arbitrary = sized . fix $ \gen n -> - let leaves = - [ SubstPath <$> ((:|) <$> genIdentifier <*> listOf genIdentifier)] - subtree = gen $ n `div` 2 - in if n == 0 - then oneof leaves - else oneof $ leaves <> [ SubstFilter <$> subtree <*> arbitrary ] - shrink (SubstPath pth) = - fmap SubstPath - . filter (not . any ((||) <$> null <*> any (`notElem` identifierChars))) - $ shrink pth - shrink (SubstFilter s f) - = shrink s - <> (uncurry SubstFilter <$> shrink (s, f)) - -data Template - = Literal Text - | Subst Substitution - | Concat Template Template - deriving stock (Show, Generic, Data) - deriving anyclass (NFData) - deriving EqProp via EqEqProp Template - -instance Plated Template where - plate _ tpl@(Literal _) = pure tpl - plate _ tpl@(Subst _) = pure tpl - plate f (Concat tpl₁ tpl₂) = Concat <$> f tpl₁ <*> f tpl₂ - -reduceTemplate :: Template -> Template -reduceTemplate = transform $ \case - (Concat (Literal t₁) (Literal t₂)) -> Literal (t₁ <> t₂) - (Concat (Literal "") t) -> t - (Concat t (Literal "")) -> t - (Concat t₁ (Concat t₂ t₃)) -> Concat (Concat t₁ t₂) t₃ - (Concat (Concat t₁ (Literal t₂)) (Literal t₃)) -> (Concat t₁ (Literal $ t₂ <> t₃)) - t -> t - -instance Eq Template where - tpl₁ == tpl₂ = case (reduceTemplate tpl₁, reduceTemplate tpl₂) of - (Literal t₁, Literal t₂) -> t₁ == t₂ - (Subst s₁, Subst s₂) -> s₁ == s₂ - (Concat ta₁ ta₂, Concat tb₁ tb₂) -> ta₁ == tb₁ && ta₂ == tb₂ - _ -> False - -instance Arbitrary Template where - arbitrary = sized . fix $ \gen n -> - let leaves = [ Literal . pack . filter (`notElem` ['\\', '{']) <$> arbitrary - , Subst <$> arbitrary - ] - subtree = gen $ n `div` 2 - genConcat = Concat <$> subtree <*> subtree - in if n == 0 - then oneof leaves - else oneof $ genConcat : leaves - shrink (Literal t) = Literal <$> shrink t - shrink (Subst s) = Subst <$> shrink s - shrink (Concat t₁ t₂) - = shrink t₁ - <> shrink t₂ - <> (Concat <$> shrink t₁ <*> shrink t₂) - -instance Semigroup Template where - (<>) = Concat - -instance Monoid Template where - mempty = Literal "" - --------------------------------------------------------------------------------- - -type Parser = Parsec Void Text - -sc :: Parser () -sc = L.space space1 empty empty - -lexeme :: Parser a -> Parser a -lexeme = L.lexeme sc - -symbol :: Text -> Parser Text -symbol = L.symbol sc - -identifier :: Parser Text -identifier = lexeme . label "identifier" $ do - firstChar <- letterChar <|> oneOf ['-', '_'] - restChars <- many $ alphaNumChar <|> oneOf ['-', '_'] - pure $ firstChar <| pack restChars - -filterName :: Parser Filter -filterName = FilterName <$> identifier - -substitutionPath :: Parser Substitution -substitutionPath = SubstPath <$> sepBy1 identifier (char '.') - -substitutionFilter :: Parser Substitution -substitutionFilter = do - path <- substitutionPath - fs <- some $ symbol "|" *> filterName - pure $ foldl' SubstFilter path fs - -- pure $ SubstFilter path f - -substitutionContents :: Parser Substitution -substitutionContents - = try substitutionFilter - <|> substitutionPath - -substitution :: Parser Substitution -substitution = between (string "{{") (string "}}") substitutionContents - -literal :: Parser Template -literal = Literal <$> - ( (string "\\{" $> "{") - <|> takeWhile1P Nothing (`notElem` ['\\', '{']) - ) - -subst :: Parser Template -subst = Subst <$> substitution - -template' :: Parser Template -template' = do - parts <- many $ literal <|> subst - pure $ foldr Concat (Literal "") parts - - -template :: Parser Template -template = reduceTemplate <$> template' <* eof - --------------------------------------------------------------------------------- - -ppSubstitution :: Substitution -> Text -ppSubstitution (SubstPath substParts) = intercalate "." substParts -ppSubstitution (SubstFilter s (FilterName f)) = ppSubstitution s <> " | " <> f - -ppTemplate :: Template -> Text -ppTemplate (Literal txt) = txt -ppTemplate (Subst s) = "{{" <> ppSubstitution s <> "}}" -ppTemplate (Concat tpl₁ tpl₂) = ppTemplate tpl₁ <> ppTemplate tpl₂ - --------------------------------------------------------------------------------- - -data TemplateVar - = Val Text - | Nested (Map Text TemplateVar) - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData) - -nested :: [(Text, TemplateVar)] -> TemplateVar -nested = Nested . mapFromList - -instance Arbitrary TemplateVar where - arbitrary = sized . fix $ \gen n -> - let nst = fmap mapFromList . listOf $ (,) <$> arbitrary <*> gen (n `div` 2) - in if n == 0 - then Val <$> arbitrary - else oneof [ Val <$> arbitrary - , Nested <$> nst] - -newtype TemplateVars = Vars { getTemplateVars :: Map Text TemplateVar } - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData) - deriving (Arbitrary) via (Map Text TemplateVar) - -type instance Index TemplateVars = Text -type instance IxValue TemplateVars = TemplateVar -instance Ixed TemplateVars where - ix k f (Vars vs) = Vars <$> ix k f vs -instance At TemplateVars where - at k f (Vars vs) = Vars <$> at k f vs - -vars :: [(Text, TemplateVar)] -> TemplateVars -vars = Vars . mapFromList - -lookupVar :: TemplateVars -> NonEmpty Text -> Maybe TemplateVar -lookupVar vs (p :| []) = vs ^. at p -lookupVar vs (p :| (p₁ : ps)) = vs ^. at p >>= \case - (Val _) -> Nothing - (Nested vs') -> lookupVar (Vars vs') $ p₁ :| ps - -data RenderError - = NoSuchVariable (NonEmpty Text) - | NestedFurther (NonEmpty Text) - | NoSuchFilter Filter - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData) - -renderSubst - :: Map Filter (Text -> Text) -- ^ Filters - -> TemplateVars - -> Substitution - -> Either RenderError Text -renderSubst _ vs (SubstPath pth) = - case lookupVar vs pth of - Just (Val v) -> Right v - Just (Nested _) -> Left $ NestedFurther pth - Nothing -> Left $ NoSuchVariable pth -renderSubst fs vs (SubstFilter s fn) = - case fs ^. at fn of - Just filterFn -> filterFn <$> renderSubst fs vs s - Nothing -> Left $ NoSuchFilter fn - -render - :: Map Filter (Text -> Text) -- ^ Filters - -> TemplateVars -- ^ Template variables - -> Template -- ^ Template - -> Either RenderError Text -render _ _ (Literal s) = pure s -render fs vs (Concat t₁ t₂) = (<>) <$> render fs vs t₁ <*> render fs vs t₂ -render fs vs (Subst s) = renderSubst fs vs s diff --git a/users/glittershark/xanthous/src/Xanthous/Monad.hs b/users/glittershark/xanthous/src/Xanthous/Monad.hs deleted file mode 100644 index db602de56f..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Monad.hs +++ /dev/null @@ -1,76 +0,0 @@ --------------------------------------------------------------------------------- -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 deleted file mode 100644 index 1fe9708edb..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Orphans.hs +++ /dev/null @@ -1,352 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE PackageImports #-} -{-# OPTIONS_GHC -Wno-orphans #-} --------------------------------------------------------------------------------- -module Xanthous.Orphans - ( ppTemplate - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (elements, (.=)) --------------------------------------------------------------------------------- -import Data.Aeson -import Data.Aeson.Types (typeMismatch) -import Data.List.NonEmpty (NonEmpty(..)) -import Graphics.Vty.Attributes -import Brick.Widgets.Edit -import Data.Text.Zipper.Generic (GenericTextZipper) -import Brick.Widgets.Core (getName) -import System.Random.Internal (StdGen (..)) -import System.Random.SplitMix (SMGen ()) -import Test.QuickCheck -import "quickcheck-instances" Test.QuickCheck.Instances () -import Text.Megaparsec (errorBundlePretty) -import Text.Megaparsec.Pos -import Text.Mustache -import Text.Mustache.Type ( showKey ) -import Control.Monad.State -import Linear --------------------------------------------------------------------------------- -import Xanthous.Util.JSON -import Xanthous.Util.QuickCheck --------------------------------------------------------------------------------- - -instance forall s a. - ( Cons s s a a - , IsSequence s - , Element s ~ a - ) => Cons (NonNull s) (NonNull s) a a where - _Cons = prism hither yon - where - hither :: (a, NonNull s) -> NonNull s - hither (a, ns) = - let s = toNullable ns - in impureNonNull $ a <| s - - yon :: NonNull s -> Either (NonNull s) (a, NonNull s) - yon ns = case nuncons ns of - (_, Nothing) -> Left ns - (x, Just xs) -> Right (x, xs) - -instance forall a. Cons (NonEmpty a) (NonEmpty a) a a where - _Cons = prism hither yon - where - hither :: (a, NonEmpty a) -> NonEmpty a - hither (a, x :| xs) = a :| (x : xs) - - yon :: NonEmpty a -> Either (NonEmpty a) (a, NonEmpty a) - yon ns@(x :| xs) = case xs of - (y : ys) -> Right (x, y :| ys) - [] -> Left ns - - -instance Arbitrary PName where - arbitrary = PName . pack <$> listOf1 (elements ['a'..'z']) - -instance Arbitrary Key where - arbitrary = Key <$> listOf1 arbSafeText - where arbSafeText = pack <$> listOf1 (elements ['a'..'z']) - shrink (Key []) = error "unreachable" - shrink k@(Key [_]) = pure k - shrink (Key (p:ps)) = Key . (p :) <$> shrink ps - -instance Arbitrary Pos where - arbitrary = mkPos . succ . abs <$> arbitrary - shrink (unPos -> 1) = [] - shrink (unPos -> x) = mkPos <$> [x..1] - -instance Arbitrary Node where - arbitrary = sized node - where - node n | n > 0 = oneof $ leaves ++ branches (n `div` 2) - node _ = oneof leaves - branches n = - [ Section <$> arbitrary <*> subnodes n - , InvertedSection <$> arbitrary <*> subnodes n - ] - subnodes = fmap concatTextBlocks . listOf . node - leaves = - [ TextBlock . pack <$> listOf1 (elements ['a'..'z']) - , EscapedVar <$> arbitrary - , UnescapedVar <$> arbitrary - -- TODO fix pretty-printing of mustache partials - -- , Partial <$> arbitrary <*> arbitrary - ] - shrink = genericShrink - -concatTextBlocks :: [Node] -> [Node] -concatTextBlocks [] = [] -concatTextBlocks [x] = [x] -concatTextBlocks (TextBlock txt₁ : TextBlock txt₂ : xs) - = concatTextBlocks $ TextBlock (txt₁ <> txt₂) : concatTextBlocks xs -concatTextBlocks (x : xs) = x : concatTextBlocks xs - -instance Arbitrary Template where - arbitrary = do - template <- concatTextBlocks <$> arbitrary - -- templateName <- arbitrary - -- rest <- arbitrary - let templateName = "template" - rest = mempty - pure $ Template - { templateActual = templateName - , templateCache = rest & at templateName ?~ template - } - shrink (Template actual cache) = - let Just tpl = cache ^. at actual - in do - cache' <- shrink cache - tpl' <- shrink tpl - actual' <- shrink actual - pure $ Template - { templateActual = actual' - , templateCache = cache' & at actual' ?~ tpl' - } - -instance CoArbitrary Template where - coarbitrary = coarbitrary . ppTemplate - -instance Function Template where - function = functionMap ppTemplate parseTemplatePartial - where - parseTemplatePartial txt - = compileMustacheText "template" txt ^?! _Right - -ppNode :: Map PName [Node] -> Node -> Text -ppNode _ (TextBlock txt) = txt -ppNode _ (EscapedVar k) = "{{" <> showKey k <> "}}" -ppNode ctx (Section k body) = - let sk = showKey k - in "{{#" <> sk <> "}}" <> foldMap (ppNode ctx) body <> "{{/" <> sk <> "}}" -ppNode _ (UnescapedVar k) = "{{{" <> showKey k <> "}}}" -ppNode ctx (InvertedSection k body) = - let sk = showKey k - in "{{^" <> sk <> "}}" <> foldMap (ppNode ctx) body <> "{{/" <> sk <> "}}" -ppNode _ (Partial n _) = "{{> " <> unPName n <> "}}" - -ppTemplate :: Template -> Text -ppTemplate (Template actual cache) = - case cache ^. at actual of - Nothing -> error "Template not found?" - Just nodes -> foldMap (ppNode cache) nodes - -instance ToJSON Template where - toJSON = String . ppTemplate - -instance FromJSON Template where - parseJSON - = withText "Template" - $ either (fail . errorBundlePretty) pure - . compileMustacheText "template" - -deriving anyclass instance NFData Node -deriving anyclass instance NFData Template - -instance FromJSON Color where - parseJSON (String "black") = pure black - parseJSON (String "red") = pure red - parseJSON (String "green") = pure green - parseJSON (String "yellow") = pure yellow - parseJSON (String "blue") = pure blue - parseJSON (String "magenta") = pure magenta - parseJSON (String "cyan") = pure cyan - parseJSON (String "white") = pure white - parseJSON (String "brightBlack") = pure brightBlack - parseJSON (String "brightRed") = pure brightRed - parseJSON (String "brightGreen") = pure brightGreen - parseJSON (String "brightYellow") = pure brightYellow - parseJSON (String "brightBlue") = pure brightBlue - parseJSON (String "brightMagenta") = pure brightMagenta - parseJSON (String "brightCyan") = pure brightCyan - parseJSON (String "brightWhite") = pure brightWhite - parseJSON n@(Number _) = Color240 <$> parseJSON n - parseJSON x = typeMismatch "Color" x - -instance ToJSON Color where - toJSON color - | color == black = "black" - | color == red = "red" - | color == green = "green" - | color == yellow = "yellow" - | color == blue = "blue" - | color == magenta = "magenta" - | color == cyan = "cyan" - | color == white = "white" - | color == brightBlack = "brightBlack" - | color == brightRed = "brightRed" - | color == brightGreen = "brightGreen" - | color == brightYellow = "brightYellow" - | color == brightBlue = "brightBlue" - | color == brightMagenta = "brightMagenta" - | color == brightCyan = "brightCyan" - | color == brightWhite = "brightWhite" - | Color240 num <- color = toJSON num - | otherwise = error $ "unimplemented: " <> show color - -instance (Eq a, Show a, Read a, FromJSON a) => FromJSON (MaybeDefault a) where - parseJSON Null = pure Default - parseJSON (String "keepCurrent") = pure KeepCurrent - parseJSON x = SetTo <$> parseJSON x - -instance ToJSON a => ToJSON (MaybeDefault a) where - toJSON Default = Null - toJSON KeepCurrent = String "keepCurrent" - toJSON (SetTo x) = toJSON x - --------------------------------------------------------------------------------- - -instance Arbitrary Color where - arbitrary = oneof [ Color240 <$> choose (0, 239) - , ISOColor <$> choose (0, 15) - ] - -deriving anyclass instance CoArbitrary Color -deriving anyclass instance Function Color - -instance (Eq a, Show a, Read a, Arbitrary a) => Arbitrary (MaybeDefault a) where - arbitrary = oneof [ pure Default - , pure KeepCurrent - , SetTo <$> arbitrary - ] - -instance CoArbitrary a => CoArbitrary (MaybeDefault a) where - coarbitrary Default = variant @Int 1 - coarbitrary KeepCurrent = variant @Int 2 - coarbitrary (SetTo x) = variant @Int 3 . coarbitrary x - -instance (Eq a, Show a, Read a, Function a) => Function (MaybeDefault a) where - function = functionShow - -instance Arbitrary Attr where - arbitrary = do - attrStyle <- arbitrary - attrForeColor <- arbitrary - attrBackColor <- arbitrary - attrURL <- arbitrary - pure Attr {..} - -deriving anyclass instance CoArbitrary Attr -deriving anyclass instance Function Attr - -instance ToJSON Attr where - toJSON Attr{..} = object - [ "style" .= maybeDefaultToJSONWith styleToJSON attrStyle - , "foreground" .= attrForeColor - , "background" .= attrBackColor - , "url" .= attrURL - ] - where - maybeDefaultToJSONWith _ Default = Null - maybeDefaultToJSONWith _ KeepCurrent = String "keepCurrent" - maybeDefaultToJSONWith tj (SetTo x) = tj x - styleToJSON style - | style == standout = "standout" - | style == underline = "underline" - | style == reverseVideo = "reverseVideo" - | style == blink = "blink" - | style == dim = "dim" - | style == bold = "bold" - | style == italic = "italic" - | otherwise = toJSON style - -instance FromJSON Attr where - parseJSON = withObject "Attr" $ \obj -> do - attrStyle <- parseStyle =<< obj .:? "style" .!= Default - attrForeColor <- obj .:? "foreground" .!= Default - attrBackColor <- obj .:? "background" .!= Default - attrURL <- obj .:? "url" .!= Default - pure Attr{..} - - where - parseStyle (SetTo (String "standout")) = pure (SetTo standout) - parseStyle (SetTo (String "underline")) = pure (SetTo underline) - parseStyle (SetTo (String "reverseVideo")) = pure (SetTo reverseVideo) - parseStyle (SetTo (String "blink")) = pure (SetTo blink) - parseStyle (SetTo (String "dim")) = pure (SetTo dim) - parseStyle (SetTo (String "bold")) = pure (SetTo bold) - parseStyle (SetTo (String "italic")) = pure (SetTo italic) - parseStyle (SetTo n@(Number _)) = SetTo <$> parseJSON n - parseStyle (SetTo v) = typeMismatch "Style" v - parseStyle Default = pure Default - parseStyle KeepCurrent = pure KeepCurrent - -deriving stock instance Ord Color -deriving stock instance Ord a => Ord (MaybeDefault a) -deriving stock instance Ord Attr - --------------------------------------------------------------------------------- - -instance NFData a => NFData (NonNull a) where - rnf xs = xs `seq` toNullable xs `deepseq` () - -instance forall t name. (NFData t, Monoid t, NFData name) - => NFData (Editor t name) where - rnf ed = getName @_ @name ed `deepseq` getEditContents ed `deepseq` () - -deriving via (ReadShowJSON SMGen) instance ToJSON SMGen -deriving via (ReadShowJSON SMGen) instance FromJSON SMGen - -instance ToJSON StdGen where - toJSON = toJSON . unStdGen - toEncoding = toEncoding . unStdGen - -instance FromJSON StdGen where - parseJSON = fmap StdGen . parseJSON - --------------------------------------------------------------------------------- - -instance CoArbitrary a => CoArbitrary (NonNull a) where - coarbitrary = coarbitrary . toNullable - -instance (MonoFoldable a, Function a) => Function (NonNull a) where - function = functionMap toNullable $ fromMaybe (error "null") . fromNullable - -instance (Arbitrary t, Arbitrary n, GenericTextZipper t) - => Arbitrary (Editor t n) where - arbitrary = editor <$> arbitrary <*> arbitrary <*> arbitrary - -instance forall t n. (CoArbitrary t, CoArbitrary n, Monoid t) - => CoArbitrary (Editor t n) where - coarbitrary ed = coarbitrary (getName @_ @n ed, getEditContents ed) - -instance CoArbitrary StdGen where - coarbitrary = coarbitrary . show - -instance Function StdGen where - function = functionMap unStdGen StdGen - -instance Function SMGen where - function = functionShow - --------------------------------------------------------------------------------- - -deriving newtype instance (Arbitrary s, CoArbitrary (m (a, s))) - => CoArbitrary (StateT s m a) - --------------------------------------------------------------------------------- - -deriving via (GenericArbitrary (V2 a)) instance Arbitrary a => Arbitrary (V2 a) -instance CoArbitrary a => CoArbitrary (V2 a) -instance Function a => Function (V2 a) diff --git a/users/glittershark/xanthous/src/Xanthous/Prelude.hs b/users/glittershark/xanthous/src/Xanthous/Prelude.hs deleted file mode 100644 index 4d79b026f1..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Prelude.hs +++ /dev/null @@ -1,47 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Prelude - ( module ClassyPrelude - , Type - , Constraint - , module GHC.TypeLits - , module Control.Lens - , module Data.Void - , module Control.Comonad - , module Witherable - , fail - - , (&!) - - -- * Classy-Prelude addons - , ninsertSet - , ndeleteSet - , toVector - ) where --------------------------------------------------------------------------------- -import ClassyPrelude hiding - ( return, (<|), unsnoc, uncons, cons, snoc, index, (<.>), Index, say - , catMaybes, filter, mapMaybe, hashNub, ordNub - ) -import Data.Kind -import GHC.TypeLits hiding (Text) -import Control.Lens hiding (levels, Level) -import Data.Void -import Control.Comonad -import Witherable -import Control.Monad.Fail (fail) --------------------------------------------------------------------------------- - -ninsertSet - :: (IsSet set, MonoPointed set) - => Element set -> NonNull set -> NonNull set -ninsertSet x xs = impureNonNull $ opoint x `union` toNullable xs - -ndeleteSet :: IsSet b => Element b -> NonNull b -> b -ndeleteSet x = deleteSet x . toNullable - -toVector :: (MonoFoldable (f a), Element (f a) ~ a) => f a -> Vector a -toVector = fromList . toList - -infixl 1 &! -(&!) :: a -> (a -> b) -> b -(&!) = flip ($!) diff --git a/users/glittershark/xanthous/src/Xanthous/Random.hs b/users/glittershark/xanthous/src/Xanthous/Random.hs deleted file mode 100644 index 6d34109df7..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Random.hs +++ /dev/null @@ -1,118 +0,0 @@ --------------------------------------------------------------------------------- -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --------------------------------------------------------------------------------- -module Xanthous.Random - ( Choose(..) - , ChooseElement(..) - , Weighted(..) - , evenlyWeighted - , weightedBy - , subRand - , chance - , chooseSubset - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Data.List.NonEmpty (NonEmpty(..)) -import Control.Monad.Random.Class (MonadRandom(getRandomR, getRandom)) -import Control.Monad.Random (Rand, evalRand, mkStdGen, StdGen) -import Data.Functor.Compose -import Data.Random.Shuffle.Weighted -import Data.Random.Distribution -import Data.Random.Distribution.Uniform -import Data.Random.Distribution.Uniform.Exclusive -import Data.Random.Sample -import qualified Data.Random.Source as DRS --------------------------------------------------------------------------------- - -instance {-# INCOHERENT #-} (Monad m, MonadRandom m) => DRS.MonadRandom m where - getRandomWord8 = getRandom - getRandomWord16 = getRandom - getRandomWord32 = getRandom - getRandomWord64 = getRandom - getRandomDouble = getRandom - getRandomNByteInteger n = getRandomR (0, 256 ^ n) - -class Choose a where - type RandomResult a - choose :: MonadRandom m => a -> m (RandomResult a) - -newtype ChooseElement a = ChooseElement a - -instance MonoFoldable a => Choose (ChooseElement a) where - type RandomResult (ChooseElement a) = Maybe (Element a) - choose (ChooseElement xs) = do - chosenIdx <- getRandomR (0, olength xs - 1) - let pick _ (Just x) = Just x - pick (x, i) Nothing - | i == chosenIdx = Just x - | otherwise = Nothing - pure $ ofoldr pick Nothing $ zip (toList xs) [0..] - -instance MonoFoldable a => Choose (NonNull a) where - type RandomResult (NonNull a) = Element a - choose - = fmap (fromMaybe (error "unreachable")) -- why not lol - . choose - . ChooseElement - . toNullable - -instance Choose (NonEmpty a) where - type RandomResult (NonEmpty a) = a - choose = choose . fromNonEmpty @[_] - -instance Choose (a, a) where - type RandomResult (a, a) = a - choose (x, y) = choose (x :| [y]) - -newtype Weighted w t a = Weighted (t (w, a)) - deriving (Functor, Foldable) via (t `Compose` (,) w) - -instance Traversable t => Traversable (Weighted w t) where - traverse f (Weighted twa) = Weighted <$> (traverse . traverse) f twa - -evenlyWeighted :: [a] -> Weighted Int [] a -evenlyWeighted = Weighted . itoList - --- | Weight the elements of some functor by a function. Larger values of 'w' per --- its 'Ord' instance will be more likely to be generated -weightedBy :: Functor t => (a -> w) -> t a -> Weighted w t a -weightedBy weighting xs = Weighted $ (weighting &&& id) <$> xs - -instance (Num w, Ord w, Distribution Uniform w, Excludable w) => Choose (Weighted w [] a) where - type RandomResult (Weighted w [] a) = Maybe a - choose (Weighted ws) = sample $ headMay <$> weightedSample 1 ws - -instance (Num w, Ord w, Distribution Uniform w, Excludable w) => Choose (Weighted w NonEmpty a) where - type RandomResult (Weighted w NonEmpty a) = a - choose (Weighted ws) = - sample - $ fromMaybe (error "unreachable") . headMay - <$> weightedSample 1 (toList ws) - -subRand :: MonadRandom m => Rand StdGen a -> m a -subRand sub = evalRand sub . mkStdGen <$> getRandom - --- | Has a @n@ chance of returning 'True' --- --- eg, chance 0.5 will return 'True' half the time -chance - :: (Num w, Ord w, Distribution Uniform w, Excludable w, MonadRandom m) - => w - -> m Bool -chance n = choose $ weightedBy (bool 1 (n * 2)) bools - --- | Choose a random subset of *about* @w@ of the elements of the given --- 'Witherable' structure -chooseSubset :: ( Num w, Ord w, Distribution Uniform w, Excludable w - , Witherable t - , MonadRandom m - ) => w -> t a -> m (t a) -chooseSubset = filterA . const . chance - --------------------------------------------------------------------------------- - -bools :: NonEmpty Bool -bools = True :| [False] diff --git a/users/glittershark/xanthous/src/Xanthous/Util.hs b/users/glittershark/xanthous/src/Xanthous/Util.hs deleted file mode 100644 index 524ad4819d..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Util.hs +++ /dev/null @@ -1,252 +0,0 @@ -{-# 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 deleted file mode 100644 index 9e158cc8e2..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Util/Comonad.hs +++ /dev/null @@ -1,24 +0,0 @@ --------------------------------------------------------------------------------- -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 deleted file mode 100644 index 8e5c04f4bf..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Util/Graph.hs +++ /dev/null @@ -1,33 +0,0 @@ --------------------------------------------------------------------------------- -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 deleted file mode 100644 index 6ba63a2d8a..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Util/Graphics.hs +++ /dev/null @@ -1,178 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --- | Graphics algorithms and utils for rendering things in 2D space --------------------------------------------------------------------------------- -module Xanthous.Util.Graphics - ( circle - , filledCircle - , line - , straightLine - , delaunay - - -- * Debugging and testing tools - , renderBooleanGraphics - , showBooleanGraphics - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- --- https://github.com/noinia/hgeometry/issues/28 --- import qualified Algorithms.Geometry.DelaunayTriangulation.DivideAndConquer --- as Geometry -import qualified Algorithms.Geometry.DelaunayTriangulation.Naive - as Geometry -import qualified Algorithms.Geometry.DelaunayTriangulation.Types as Geometry -import Control.Monad.State (execState, State) -import qualified Data.Geometry.Point as Geometry -import Data.Ext ((:+)(..)) -import Data.List (unfoldr) -import Data.List.NonEmpty (NonEmpty((:|))) -import qualified Data.List.NonEmpty as NE -import Data.Ix (Ix) -import Linear.V2 --------------------------------------------------------------------------------- - - --- | Generate a circle centered at the given point and with the given radius --- using the <midpoint circle algorithm --- https://en.wikipedia.org/wiki/Midpoint_circle_algorithm>. --- --- Code taken from <https://rosettacode.org/wiki/Bitmap/Midpoint_circle_algorithm#Haskell> -circle :: (Num i, Ord i) - => V2 i -- ^ center - -> i -- ^ radius - -> [V2 i] -circle (V2 x₀ y₀) radius - -- Four initial points, plus the generated points - = V2 x₀ (y₀ + radius) - : V2 x₀ (y₀ - radius) - : V2 (x₀ + radius) y₀ - : V2 (x₀ - radius) y₀ - : points - where - -- Creates the (x, y) octet offsets, then maps them to absolute points in all octets. - points = concatMap generatePoints $ unfoldr step initialValues - - generatePoints (V2 x y) - = [ V2 (x₀ `xop` x') (y₀ `yop` y') - | (x', y') <- [(x, y), (y, x)] - , xop <- [(+), (-)] - , yop <- [(+), (-)] - ] - - initialValues = (1 - radius, 1, (-2) * radius, 0, radius) - - step (f, ddf_x, ddf_y, x, y) - | x >= y = Nothing - | otherwise = Just (V2 x' y', (f', ddf_x', ddf_y', x', y')) - where - (f', ddf_y', y') | f >= 0 = (f + ddf_y' + ddf_x', ddf_y + 2, y - 1) - | otherwise = (f + ddf_x, ddf_y, y) - ddf_x' = ddf_x + 2 - x' = x + 1 - - -data FillState i - = FillState - { _inCircle :: Bool - , _result :: NonEmpty (V2 i) - } -makeLenses ''FillState - -runFillState :: NonEmpty (V2 i) -> State (FillState i) a -> [V2 i] -runFillState circumference s - = toList - . view result - . execState s - $ FillState False circumference - --- | Generate a *filled* circle centered at the given point and with the given --- radius by filling a circle generated with 'circle' -filledCircle :: (Num i, Integral i, Ix i) - => V2 i -- ^ center - -> i -- ^ radius - -> [V2 i] -filledCircle center radius = - case NE.nonEmpty (circle center radius) of - Nothing -> [] - Just circumference -> runFillState circumference $ - -- the first and last lines of all circles are solid, so the whole "in the - -- circle, out of the circle" thing doesn't work... but that's fine since - -- we don't need to fill them. So just skip them - for_ [succ minX..pred maxX] $ \x -> - for_ [minY..maxY] $ \y -> do - let pt = V2 x y - next = V2 x $ succ y - whenM (use inCircle) $ result %= NE.cons pt - - when (pt `elem` circumference && next `notElem` circumference) - $ inCircle %= not - - where - (V2 minX minY, V2 maxX maxY) = minmaxes circumference - --- | Draw a line between two points using Bresenham's line drawing algorithm --- --- Code taken from <https://wiki.haskell.org/Bresenham%27s_line_drawing_algorithm> -line :: (Num i, Ord i) => V2 i -> V2 i -> [V2 i] -line pa@(V2 xa ya) pb@(V2 xb yb) - = (if maySwitch pa < maySwitch pb then id else reverse) points - where - points = map maySwitch . unfoldr go $ (x₁, y₁, 0) - steep = abs (yb - ya) > abs (xb - xa) - maySwitch = if steep then view _yx else id - [V2 x₁ y₁, V2 x₂ y₂] = sort [maySwitch pa, maySwitch pb] - δx = x₂ - x₁ - δy = abs (y₂ - y₁) - ystep = if y₁ < y₂ then 1 else -1 - go (xTemp, yTemp, err) - | xTemp > x₂ = Nothing - | otherwise = Just ((V2 xTemp yTemp), (xTemp + 1, newY, newError)) - where - tempError = err + δy - (newY, newError) = if (2 * tempError) >= δx - then (yTemp + ystep, tempError - δx) - else (yTemp, tempError) -{-# SPECIALIZE line :: V2 Int -> V2 Int -> [V2 Int] #-} -{-# SPECIALIZE line :: V2 Word -> V2 Word -> [V2 Word] #-} - -straightLine :: (Num i, Ord i) => V2 i -> V2 i -> [V2 i] -straightLine pa@(V2 xa _) pb@(V2 _ yb) = line pa midpoint ++ line midpoint pb - where midpoint = V2 xa yb - - -delaunay - :: (Ord n, Fractional n) - => NonEmpty (V2 n, p) - -> [((V2 n, p), (V2 n, p))] -delaunay - = map (over both fromPoint) - . Geometry.edgesAsPoints - . Geometry.delaunayTriangulation - . map toPoint - where - toPoint (V2 px py, pid) = Geometry.Point2 px py :+ pid - fromPoint (Geometry.Point2 px py :+ pid) = (V2 px py, pid) - --------------------------------------------------------------------------------- - -renderBooleanGraphics :: forall i. (Num i, Ord i, Enum i) => [V2 i] -> String -renderBooleanGraphics [] = "" -renderBooleanGraphics (pt : pts') = intercalate "\n" rows - where - rows = row <$> [minX..maxX] - row x = [minY..maxY] <&> \y -> if V2 x y `member` ptSet then 'X' else ' ' - (V2 minX minY, V2 maxX maxY) = minmaxes pts - pts = pt :| pts' - ptSet :: Set (V2 i) - ptSet = setFromList $ toList pts - -showBooleanGraphics :: forall i. (Num i, Ord i, Enum i) => [V2 i] -> IO () -showBooleanGraphics = putStrLn . pack . renderBooleanGraphics - -minmaxes :: forall i. (Ord i) => NonEmpty (V2 i) -> (V2 i, V2 i) -minmaxes xs = - ( V2 (minimum1Of (traverse1 . _x) xs) - (minimum1Of (traverse1 . _y) xs) - , V2 (maximum1Of (traverse1 . _x) xs) - (maximum1Of (traverse1 . _y) xs) - ) diff --git a/users/glittershark/xanthous/src/Xanthous/Util/Inflection.hs b/users/glittershark/xanthous/src/Xanthous/Util/Inflection.hs deleted file mode 100644 index 724f2339dd..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Util/Inflection.hs +++ /dev/null @@ -1,14 +0,0 @@ - -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 deleted file mode 100644 index 91d1328e4a..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Util/JSON.hs +++ /dev/null @@ -1,19 +0,0 @@ --------------------------------------------------------------------------------- -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 deleted file mode 100644 index dfa6537235..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Util/Optparse.hs +++ /dev/null @@ -1,21 +0,0 @@ --------------------------------------------------------------------------------- -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 deleted file mode 100644 index be12bc2945..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Util/QuickCheck.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# 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 deleted file mode 100644 index c1835ef232..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/messages.yaml +++ /dev/null @@ -1,120 +0,0 @@ -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 deleted file mode 100644 index f15c393ac9..0000000000 --- a/users/glittershark/xanthous/test/Spec.hs +++ /dev/null @@ -1,47 +0,0 @@ --------------------------------------------------------------------------------- -import Test.Prelude --------------------------------------------------------------------------------- -import qualified Xanthous.Data.EntitiesSpec -import qualified Xanthous.Data.EntityCharSpec -import qualified Xanthous.Data.EntityMap.GraphicsSpec -import qualified Xanthous.Data.EntityMapSpec -import qualified Xanthous.Data.LevelsSpec -import qualified Xanthous.Data.NestedMapSpec -import qualified Xanthous.DataSpec -import qualified Xanthous.Entities.RawsSpec -import qualified Xanthous.GameSpec -import qualified Xanthous.Generators.UtilSpec -import qualified Xanthous.MessageSpec -import qualified Xanthous.Messages.TemplateSpec -import qualified Xanthous.OrphansSpec -import qualified Xanthous.RandomSpec -import qualified Xanthous.Util.GraphSpec -import qualified Xanthous.Util.GraphicsSpec -import qualified Xanthous.Util.InflectionSpec -import qualified Xanthous.UtilSpec --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous" - [ Xanthous.Data.EntitiesSpec.test - , Xanthous.Data.EntityMap.GraphicsSpec.test - , Xanthous.Data.EntityMapSpec.test - , Xanthous.Data.LevelsSpec.test - , Xanthous.Data.NestedMapSpec.test - , Xanthous.DataSpec.test - , Xanthous.Entities.RawsSpec.test - , Xanthous.GameSpec.test - , Xanthous.Generators.UtilSpec.test - , Xanthous.MessageSpec.test - , Xanthous.Messages.TemplateSpec.test - , Xanthous.OrphansSpec.test - , Xanthous.RandomSpec.test - , Xanthous.Util.GraphSpec.test - , Xanthous.Util.GraphicsSpec.test - , Xanthous.Util.InflectionSpec.test - , Xanthous.UtilSpec.test - , Xanthous.Data.EntityCharSpec.test - ] diff --git a/users/glittershark/xanthous/test/Test/Prelude.hs b/users/glittershark/xanthous/test/Test/Prelude.hs deleted file mode 100644 index c423796184..0000000000 --- a/users/glittershark/xanthous/test/Test/Prelude.hs +++ /dev/null @@ -1,19 +0,0 @@ -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 deleted file mode 100644 index e403503743..0000000000 --- a/users/glittershark/xanthous/test/Xanthous/Data/EntitiesSpec.hs +++ /dev/null @@ -1,28 +0,0 @@ --------------------------------------------------------------------------------- -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 deleted file mode 100644 index 9e8024c9d2..0000000000 --- a/users/glittershark/xanthous/test/Xanthous/Data/EntityCharSpec.hs +++ /dev/null @@ -1,18 +0,0 @@ --------------------------------------------------------------------------------- -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 deleted file mode 100644 index fd37548ce8..0000000000 --- a/users/glittershark/xanthous/test/Xanthous/Data/EntityMap/GraphicsSpec.hs +++ /dev/null @@ -1,57 +0,0 @@ --------------------------------------------------------------------------------- -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 deleted file mode 100644 index 7c5cad0196..0000000000 --- a/users/glittershark/xanthous/test/Xanthous/Data/EntityMapSpec.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# 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 deleted file mode 100644 index 4e46946a93..0000000000 --- a/users/glittershark/xanthous/test/Xanthous/Data/LevelsSpec.hs +++ /dev/null @@ -1,66 +0,0 @@ --------------------------------------------------------------------------------- -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 deleted file mode 100644 index acf7a67268..0000000000 --- a/users/glittershark/xanthous/test/Xanthous/Data/NestedMapSpec.hs +++ /dev/null @@ -1,20 +0,0 @@ --------------------------------------------------------------------------------- -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 deleted file mode 100644 index 91dc6cea1b..0000000000 --- a/users/glittershark/xanthous/test/Xanthous/DataSpec.hs +++ /dev/null @@ -1,98 +0,0 @@ --------------------------------------------------------------------------------- -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 deleted file mode 100644 index 2e6f35457f..0000000000 --- a/users/glittershark/xanthous/test/Xanthous/Entities/RawsSpec.hs +++ /dev/null @@ -1,16 +0,0 @@ --- | - -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 deleted file mode 100644 index 2fa8527d0e..0000000000 --- a/users/glittershark/xanthous/test/Xanthous/GameSpec.hs +++ /dev/null @@ -1,55 +0,0 @@ -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 deleted file mode 100644 index cdfadc06f5..0000000000 --- a/users/glittershark/xanthous/test/Xanthous/Generators/UtilSpec.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE PackageImports #-} --------------------------------------------------------------------------------- -module Xanthous.Generators.UtilSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude -import System.Random (mkStdGen) -import Control.Monad.Random (runRandT) -import Data.Array.ST (STUArray, runSTUArray, thaw) -import Data.Array.IArray (bounds) -import Data.Array.MArray (newArray, readArray, writeArray) -import Data.Array (Array, range, listArray, Ix) -import Control.Monad.ST (ST, runST) -import "checkers" Test.QuickCheck.Instances.Array () -import Linear.V2 --------------------------------------------------------------------------------- -import Xanthous.Util -import Xanthous.Data (width, height) -import Xanthous.Generators.Util --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - --------------------------------------------------------------------------------- - -newtype GenArray a b = GenArray (Array a b) - deriving stock (Show, Eq) - -instance (Ix a, Arbitrary a, CoArbitrary a, Arbitrary b) - => Arbitrary (GenArray a b) where - arbitrary = GenArray <$> do - (mkElem :: a -> b) <- arbitrary - minDims <- arbitrary - maxDims <- arbitrary - let bnds = (minDims, maxDims) - pure $ listArray bnds $ mkElem <$> range bnds - -test :: TestTree -test = testGroup "Xanthous.Generators.Util" - [ testGroup "randInitialize" - [ testProperty "returns an array of the correct dimensions" - $ \dims seed aliveChance -> - let gen = mkStdGen seed - res = runSTUArray - $ fmap fst - $ flip runRandT gen - $ randInitialize dims aliveChance - in bounds res === (0, V2 (dims ^. width) (dims ^. height)) - ] - , testGroup "numAliveNeighborsM" - [ testProperty "maxes out at 8" - $ \(GenArray (arr :: Array (V2 Word) Bool)) loc -> - let - act :: forall s. ST s Word - act = do - mArr <- thaw @_ @_ @_ @(STUArray s) arr - numAliveNeighborsM mArr loc - res = runST act - in counterexample (show res) $ between 0 8 res - ] - , testGroup "numAliveNeighbors" - [ testProperty "is equivalient to runST . numAliveNeighborsM . thaw" $ - \(GenArray (arr :: Array (V2 Word) Bool)) loc -> - let - act :: forall s. ST s Word - act = do - mArr <- thaw @_ @_ @_ @(STUArray s) arr - numAliveNeighborsM mArr loc - res = runST act - in numAliveNeighbors arr loc === res - ] - , testGroup "cloneMArray" - [ testCase "clones the array" $ runST $ - let - go :: forall s. ST s Assertion - go = do - arr <- newArray @(STUArray s) (0 :: Int, 5) (1 :: Int) - arr' <- cloneMArray @_ @(STUArray s) arr - writeArray arr' 0 1234 - x <- readArray arr 0 - pure $ x @?= 1 - in go - ] - ] diff --git a/users/glittershark/xanthous/test/Xanthous/MessageSpec.hs b/users/glittershark/xanthous/test/Xanthous/MessageSpec.hs deleted file mode 100644 index b681e537ef..0000000000 --- a/users/glittershark/xanthous/test/Xanthous/MessageSpec.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# 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 deleted file mode 100644 index 2a3873c3b0..0000000000 --- a/users/glittershark/xanthous/test/Xanthous/Messages/TemplateSpec.hs +++ /dev/null @@ -1,80 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Messages.TemplateSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude -import Test.QuickCheck.Instances.Text () -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Function (fix) --------------------------------------------------------------------------------- -import Xanthous.Messages.Template --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Messages.Template" - [ testGroup "parsing" - [ testProperty "literals" $ forAll genLiteral $ \s -> - testParse template s === Right (Literal s) - , parseCase "escaped curlies" - "foo\\{" - $ Literal "foo{" - , parseCase "simple substitution" - "foo {{bar}}" - $ Literal "foo " `Concat` Subst (SubstPath $ "bar" :| []) - , parseCase "substitution with filters" - "foo {{bar | baz}}" - $ Literal "foo " - `Concat` Subst (SubstFilter (SubstPath $ "bar" :| []) - (FilterName "baz")) - , parseCase "substitution with multiple filters" - "foo {{bar | baz | qux}}" - $ Literal "foo " - `Concat` Subst (SubstFilter (SubstFilter (SubstPath $ "bar" :| []) - (FilterName "baz")) - (FilterName "qux")) - , parseCase "two substitutions and a literal" - "{{a}}{{b}}c" - $ Subst (SubstPath $ "a" :| []) - `Concat` Subst (SubstPath $ "b" :| []) - `Concat` Literal "c" - , localOption (QuickCheckTests 10) - $ testProperty "round-trips with ppTemplate" $ \tpl -> - testParse template (ppTemplate tpl) === Right tpl - ] - , testBatch $ monoid @Template mempty - , testGroup "rendering" - [ testProperty "rendering literals renders literally" - $ forAll genLiteral $ \s fs vs -> - render fs vs (Literal s) === Right s - , testProperty "rendering substitutions renders substitutions" - $ forAll genPath $ \ident val fs -> - let tpl = Subst (SubstPath ident) - tvs = varsWith ident val - in render fs tvs tpl === Right val - , testProperty "filters filter" $ forAll genPath - $ \ident filterName filterFn val -> - let tpl = Subst (SubstFilter (SubstPath ident) filterName) - fs = mapFromList [(filterName, filterFn)] - vs = varsWith ident val - in render fs vs tpl === Right (filterFn val) - ] - ] - where - genLiteral = pack . filter (`notElem` ['\\', '{']) <$> arbitrary - parseCase name input expected = - testCase name $ testParse template input @?= Right expected - testParse p = over _Left errorBundlePretty . runParser p "<test>" - genIdentifier = pack @Text <$> listOf1 (elements identifierChars) - identifierChars = ['a'..'z'] <> ['A'..'Z'] <> ['-', '_'] - - varsWith (p :| []) val = vars [(p, Val val)] - varsWith (phead :| ps) val = vars . pure . (phead ,) . flip fix ps $ - \next pth -> case pth of - [] -> Val val - p : ps' -> nested [(p, next ps')] - - genPath = (:|) <$> genIdentifier <*> listOf genIdentifier - --- diff --git a/users/glittershark/xanthous/test/Xanthous/OrphansSpec.hs b/users/glittershark/xanthous/test/Xanthous/OrphansSpec.hs deleted file mode 100644 index 3740945877..0000000000 --- a/users/glittershark/xanthous/test/Xanthous/OrphansSpec.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# 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/RandomSpec.hs b/users/glittershark/xanthous/test/Xanthous/RandomSpec.hs deleted file mode 100644 index 187336f086..0000000000 --- a/users/glittershark/xanthous/test/Xanthous/RandomSpec.hs +++ /dev/null @@ -1,25 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.RandomSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude --------------------------------------------------------------------------------- -import Control.Monad.Random --------------------------------------------------------------------------------- -import Xanthous.Random --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Random" - [ testGroup "chooseSubset" - [ testProperty "chooses a subset" - $ \(l :: [Int]) (Positive (r :: Double)) -> randomTest $ do - ss <- chooseSubset r l - pure $ all (`elem` l) ss - - ] - ] - where - randomTest prop = evalRandT prop . mkStdGen =<< arbitrary diff --git a/users/glittershark/xanthous/test/Xanthous/Util/GraphSpec.hs b/users/glittershark/xanthous/test/Xanthous/Util/GraphSpec.hs deleted file mode 100644 index 35ff090b28..0000000000 --- a/users/glittershark/xanthous/test/Xanthous/Util/GraphSpec.hs +++ /dev/null @@ -1,39 +0,0 @@ -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 deleted file mode 100644 index 61e5892803..0000000000 --- a/users/glittershark/xanthous/test/Xanthous/Util/GraphicsSpec.hs +++ /dev/null @@ -1,72 +0,0 @@ -module Xanthous.Util.GraphicsSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude hiding (head) --------------------------------------------------------------------------------- -import Data.List (nub, head) -import Data.Set (isSubsetOf) -import Linear.V2 --------------------------------------------------------------------------------- -import Xanthous.Util.Graphics -import Xanthous.Util -import Xanthous.Orphans () --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Util.Graphics" - [ testGroup "circle" - [ testCase "radius 1, origin 2,2" - {- - | | 0 | 1 | 2 | 3 | - |---+---+---+---+---| - | 0 | | | | | - | 1 | | | x | | - | 2 | | x | | x | - | 3 | | | x | | - -} - $ (sort . unique @[] @[_]) (circle @Int (V2 2 2) 1) - @?= [ V2 1 2 - , V2 2 1, V2 2 3 - , V2 3 2 - ] - , testCase "radius 12, origin 0" - $ (sort . nub) (circle @Int 0 12) - @?= (sort . nub) - [ V2 (-12) (-4), V2 (-12) (-3), V2 (-12) (-2), V2 (-12) (-1) - , V2 (-12) 0, V2 (-12) 1, V2 (-12) 2, V2 (-12) 3, V2 (-12) 4 - , V2 (-11) (-6), V2 (-11) (-5), V2 (-11) 5, V2 (-11) 6, V2 (-10) (-7) - , V2 (-10) 7, V2 (-9) (-9), V2 (-9) (-8), V2 (-9) 8, V2 (-9) 9 - , V2 (-8) (-9), V2 (-8) 9, V2 (-7) (-10), V2 (-7) 10, V2 (-6) (-11) - , V2 (-6) 11, V2 (-5) (-11), V2 (-5) 11, V2 (-4) (-12), V2 (-4) 12 - , V2 (-3) (-12), V2 (-3) 12, V2 (-2) (-12), V2 (-2) 12, V2 (-1) (-12) - , V2 (-1) 12, V2 0 (-12), V2 0 12, V2 1 (-12), V2 1 12, V2 2 (-12) - , V2 2 12, V2 3 (-12), V2 3 12, V2 4 (-12), V2 4 12, V2 5 (-11) - , V2 5 11, V2 6 (-11), V2 6 11, V2 7 (-10), V2 7 10, V2 8 (-9), V2 8 9 - , V2 9 (-9), V2 9 (-8), V2 9 8, V2 9 9, V2 10 (-7), V2 10 7 - , V2 11 (-6), V2 11 (-5), V2 11 5, V2 11 6, V2 12 (-4), V2 12 (-3) - , V2 12 (-2), V2 12 (-1), V2 12 0, V2 12 1, V2 12 2, V2 12 3, V2 12 4 - ] - ] - , testGroup "filledCircle" - [ testProperty "is a superset of circle" $ \center radius -> - let circ = circle @Int center radius - filledCirc = filledCircle center radius - in counterexample ( "circle: " <> show circ - <> "\nfilledCircle: " <> show filledCirc) - $ setFromList circ `isSubsetOf` setFromList filledCirc - -- TODO later - -- , testProperty "is always contiguous" $ \center radius -> - -- let filledCirc = filledCircle center radius - -- in counterexample (renderBooleanGraphics filledCirc) $ - ] - , testGroup "line" - [ testProperty "starts and ends at the start and end points" $ \start end -> - let ℓ = line @Int start end - in counterexample ("line: " <> show ℓ) - $ length ℓ > 2 ==> (head ℓ === start) .&&. (head (reverse ℓ) === end) - ] - ] - --------------------------------------------------------------------------------- diff --git a/users/glittershark/xanthous/test/Xanthous/Util/InflectionSpec.hs b/users/glittershark/xanthous/test/Xanthous/Util/InflectionSpec.hs deleted file mode 100644 index fad8410431..0000000000 --- a/users/glittershark/xanthous/test/Xanthous/Util/InflectionSpec.hs +++ /dev/null @@ -1,18 +0,0 @@ -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 deleted file mode 100644 index 8538ea5098..0000000000 --- a/users/glittershark/xanthous/test/Xanthous/UtilSpec.hs +++ /dev/null @@ -1,28 +0,0 @@ -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 deleted file mode 100644 index 9648933b76..0000000000 --- a/users/glittershark/xanthous/xanthous.cabal +++ /dev/null @@ -1,563 +0,0 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.34.4. --- --- see: https://github.com/sol/hpack --- --- hash: b46f24dcf24decf8e16be6f62943648aaafc9272d923945f97d5c26a370ad235 - -name: xanthous -version: 0.1.0.0 -synopsis: A WIP TUI RPG -description: Please see the README on GitHub at <https://github.com/glittershark/xanthous> -category: Game -homepage: https://github.com/glittershark/xanthous#readme -bug-reports: https://github.com/glittershark/xanthous/issues -author: Griffin Smith -maintainer: root@gws.fyi -copyright: 2019 Griffin Smith -license: GPL-3 -license-file: LICENSE -build-type: Simple -extra-source-files: - README.org - -source-repository head - type: git - location: https://github.com/glittershark/xanthous - -library - exposed-modules: - Data.Aeson.Generic.DerivingVia - Main - Xanthous.AI.Gormlak - Xanthous.App - Xanthous.App.Autocommands - Xanthous.App.Common - Xanthous.App.Prompt - Xanthous.App.Time - Xanthous.Command - Xanthous.Data - Xanthous.Data.App - Xanthous.Data.Entities - Xanthous.Data.EntityChar - Xanthous.Data.EntityMap - Xanthous.Data.EntityMap.Graphics - Xanthous.Data.Levels - Xanthous.Data.NestedMap - Xanthous.Data.VectorBag - Xanthous.Entities.Character - Xanthous.Entities.Creature - Xanthous.Entities.Creature.Hippocampus - Xanthous.Entities.Draw.Util - Xanthous.Entities.Entities - Xanthous.Entities.Environment - Xanthous.Entities.Item - Xanthous.Entities.Marker - Xanthous.Entities.Raws - Xanthous.Entities.RawTypes - Xanthous.Game - Xanthous.Game.Arbitrary - Xanthous.Game.Draw - Xanthous.Game.Env - Xanthous.Game.Lenses - Xanthous.Game.Prompt - Xanthous.Game.State - Xanthous.Generators - Xanthous.Generators.CaveAutomata - Xanthous.Generators.Dungeon - Xanthous.Generators.LevelContents - Xanthous.Generators.Util - Xanthous.Generators.Village - Xanthous.Messages - Xanthous.Messages.Template - Xanthous.Monad - Xanthous.Orphans - Xanthous.Prelude - Xanthous.Random - Xanthous.Util - Xanthous.Util.Comonad - Xanthous.Util.Graph - Xanthous.Util.Graphics - Xanthous.Util.Inflection - Xanthous.Util.JSON - Xanthous.Util.Optparse - Xanthous.Util.QuickCheck - other-modules: - Paths_xanthous - hs-source-dirs: - src - default-extensions: - BlockArguments - ConstraintKinds - DataKinds - DeriveAnyClass - DeriveGeneric - DerivingStrategies - DerivingVia - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTSyntax - GeneralizedNewtypeDeriving - KindSignatures - LambdaCase - MultiWayIf - NoImplicitPrelude - NoStarIsType - OverloadedStrings - PolyKinds - RankNTypes - ScopedTypeVariables - TupleSections - TypeApplications - TypeFamilies - TypeOperators - ViewPatterns - ghc-options: -Wall - build-depends: - JuicyPixels - , MonadRandom - , QuickCheck - , Rasterific - , aeson - , array - , async - , base - , bifunctors - , brick - , checkers - , classy-prelude - , comonad - , comonad-extras - , constraints - , containers - , criterion - , data-default - , deepseq - , directory - , fgl - , fgl-arbitrary - , file-embed - , filepath - , generic-arbitrary - , generic-lens - , generic-monoid - , groups - , hgeometry - , hgeometry-combinatorial - , lens - , lifted-async - , linear - , megaparsec - , mmorph - , monad-control - , mtl - , optparse-applicative - , parallel - , parser-combinators - , pointed - , quickcheck-instances - , quickcheck-text - , random - , random-extras - , random-fu - , random-source - , raw-strings-qq - , reflection - , semigroupoids - , splitmix - , stache - , streams - , text - , text-zipper - , tomland - , transformers - , vector - , vty - , witherable - , yaml - , zlib - default-language: Haskell2010 - -executable xanthous - main-is: Main.hs - other-modules: - Data.Aeson.Generic.DerivingVia - Xanthous.AI.Gormlak - Xanthous.App - Xanthous.App.Autocommands - Xanthous.App.Common - Xanthous.App.Prompt - Xanthous.App.Time - Xanthous.Command - Xanthous.Data - Xanthous.Data.App - Xanthous.Data.Entities - Xanthous.Data.EntityChar - Xanthous.Data.EntityMap - Xanthous.Data.EntityMap.Graphics - Xanthous.Data.Levels - Xanthous.Data.NestedMap - Xanthous.Data.VectorBag - Xanthous.Entities.Character - Xanthous.Entities.Creature - Xanthous.Entities.Creature.Hippocampus - Xanthous.Entities.Draw.Util - Xanthous.Entities.Entities - Xanthous.Entities.Environment - Xanthous.Entities.Item - Xanthous.Entities.Marker - Xanthous.Entities.Raws - Xanthous.Entities.RawTypes - Xanthous.Game - Xanthous.Game.Arbitrary - Xanthous.Game.Draw - Xanthous.Game.Env - Xanthous.Game.Lenses - Xanthous.Game.Prompt - Xanthous.Game.State - Xanthous.Generators - Xanthous.Generators.CaveAutomata - Xanthous.Generators.Dungeon - Xanthous.Generators.LevelContents - Xanthous.Generators.Util - Xanthous.Generators.Village - Xanthous.Messages - Xanthous.Messages.Template - Xanthous.Monad - Xanthous.Orphans - Xanthous.Prelude - Xanthous.Random - Xanthous.Util - Xanthous.Util.Comonad - Xanthous.Util.Graph - Xanthous.Util.Graphics - Xanthous.Util.Inflection - Xanthous.Util.JSON - Xanthous.Util.Optparse - Xanthous.Util.QuickCheck - Paths_xanthous - hs-source-dirs: - src - default-extensions: - BlockArguments - ConstraintKinds - DataKinds - DeriveAnyClass - DeriveGeneric - DerivingStrategies - DerivingVia - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTSyntax - GeneralizedNewtypeDeriving - KindSignatures - LambdaCase - MultiWayIf - NoImplicitPrelude - NoStarIsType - OverloadedStrings - PolyKinds - RankNTypes - ScopedTypeVariables - TupleSections - TypeApplications - TypeFamilies - TypeOperators - ViewPatterns - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -O2 - build-depends: - JuicyPixels - , MonadRandom - , QuickCheck - , Rasterific - , aeson - , array - , async - , base - , bifunctors - , brick - , checkers - , classy-prelude - , comonad - , comonad-extras - , constraints - , containers - , criterion - , data-default - , deepseq - , directory - , fgl - , fgl-arbitrary - , file-embed - , filepath - , generic-arbitrary - , generic-lens - , generic-monoid - , groups - , hgeometry - , hgeometry-combinatorial - , lens - , lifted-async - , linear - , megaparsec - , mmorph - , monad-control - , mtl - , optparse-applicative - , parallel - , parser-combinators - , pointed - , quickcheck-instances - , quickcheck-text - , random - , random-extras - , random-fu - , random-source - , raw-strings-qq - , reflection - , semigroupoids - , splitmix - , stache - , streams - , text - , text-zipper - , tomland - , transformers - , vector - , vty - , witherable - , xanthous - , yaml - , zlib - default-language: Haskell2010 - -test-suite test - type: exitcode-stdio-1.0 - main-is: Spec.hs - other-modules: - Test.Prelude - Xanthous.Data.EntitiesSpec - Xanthous.Data.EntityCharSpec - Xanthous.Data.EntityMap.GraphicsSpec - Xanthous.Data.EntityMapSpec - Xanthous.Data.LevelsSpec - Xanthous.Data.NestedMapSpec - Xanthous.DataSpec - Xanthous.Entities.RawsSpec - Xanthous.GameSpec - Xanthous.Generators.UtilSpec - Xanthous.Messages.TemplateSpec - Xanthous.MessageSpec - Xanthous.OrphansSpec - Xanthous.RandomSpec - Xanthous.Util.GraphicsSpec - Xanthous.Util.GraphSpec - Xanthous.Util.InflectionSpec - Xanthous.UtilSpec - Paths_xanthous - hs-source-dirs: - test - default-extensions: - BlockArguments - ConstraintKinds - DataKinds - DeriveAnyClass - DeriveGeneric - DerivingStrategies - DerivingVia - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTSyntax - GeneralizedNewtypeDeriving - KindSignatures - LambdaCase - MultiWayIf - NoImplicitPrelude - NoStarIsType - OverloadedStrings - PolyKinds - RankNTypes - ScopedTypeVariables - TupleSections - TypeApplications - TypeFamilies - TypeOperators - ViewPatterns - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -O0 - build-depends: - JuicyPixels - , MonadRandom - , QuickCheck - , Rasterific - , aeson - , array - , async - , base - , bifunctors - , brick - , checkers - , classy-prelude - , comonad - , comonad-extras - , constraints - , containers - , criterion - , data-default - , deepseq - , directory - , fgl - , fgl-arbitrary - , file-embed - , filepath - , generic-arbitrary - , generic-lens - , generic-monoid - , groups - , hgeometry - , hgeometry-combinatorial - , lens - , lens-properties - , lifted-async - , linear - , megaparsec - , mmorph - , monad-control - , mtl - , optparse-applicative - , parallel - , parser-combinators - , pointed - , quickcheck-instances - , quickcheck-text - , random - , random-extras - , random-fu - , random-source - , raw-strings-qq - , reflection - , semigroupoids - , splitmix - , stache - , streams - , tasty - , tasty-hunit - , tasty-quickcheck - , text - , text-zipper - , tomland - , transformers - , vector - , vty - , witherable - , xanthous - , yaml - , zlib - default-language: Haskell2010 - -benchmark benchmark - type: exitcode-stdio-1.0 - main-is: Bench.hs - other-modules: - Bench.Prelude - Xanthous.Generators.UtilBench - Xanthous.RandomBench - Paths_xanthous - hs-source-dirs: - bench - default-extensions: - BlockArguments - ConstraintKinds - DataKinds - DeriveAnyClass - DeriveGeneric - DerivingStrategies - DerivingVia - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTSyntax - GeneralizedNewtypeDeriving - KindSignatures - LambdaCase - MultiWayIf - NoImplicitPrelude - NoStarIsType - OverloadedStrings - PolyKinds - RankNTypes - ScopedTypeVariables - TupleSections - TypeApplications - TypeFamilies - TypeOperators - ViewPatterns - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N - build-depends: - JuicyPixels - , MonadRandom - , QuickCheck - , Rasterific - , aeson - , array - , async - , base - , bifunctors - , brick - , checkers - , classy-prelude - , comonad - , comonad-extras - , constraints - , containers - , criterion - , data-default - , deepseq - , directory - , fgl - , fgl-arbitrary - , file-embed - , filepath - , generic-arbitrary - , generic-lens - , generic-monoid - , groups - , hgeometry - , hgeometry-combinatorial - , lens - , lifted-async - , linear - , megaparsec - , mmorph - , monad-control - , mtl - , optparse-applicative - , parallel - , parser-combinators - , pointed - , quickcheck-instances - , quickcheck-text - , random - , random-extras - , random-fu - , random-source - , raw-strings-qq - , reflection - , semigroupoids - , splitmix - , stache - , streams - , text - , text-zipper - , tomland - , transformers - , vector - , vty - , witherable - , xanthous - , yaml - , zlib - default-language: Haskell2010 |